├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── fourmolu.yaml ├── hypertypes.cabal ├── package.yaml ├── src ├── Hyper.hs └── Hyper │ ├── Class │ ├── Apply.hs │ ├── Context.hs │ ├── Foldable.hs │ ├── Functor.hs │ ├── HasPlain.hs │ ├── Infer.hs │ ├── Infer │ │ ├── Env.hs │ │ └── InferOf.hs │ ├── Monad.hs │ ├── Morph.hs │ ├── Nodes.hs │ ├── Optic.hs │ ├── Pointed.hs │ ├── Recursive.hs │ ├── Traversable.hs │ ├── Unify.hs │ └── ZipMatch.hs │ ├── Combinator │ ├── ANode.hs │ ├── Ann.hs │ ├── Compose.hs │ ├── Flip.hs │ └── Func.hs │ ├── Diff.hs │ ├── Infer.hs │ ├── Infer │ ├── Blame.hs │ ├── Result.hs │ └── ScopeLevel.hs │ ├── Internal │ └── Prelude.hs │ ├── Recurse.hs │ ├── Syntax.hs │ ├── Syntax │ ├── App.hs │ ├── FuncType.hs │ ├── Lam.hs │ ├── Let.hs │ ├── Map.hs │ ├── Nominal.hs │ ├── Row.hs │ ├── Scheme.hs │ ├── Scheme │ │ └── AlphaEq.hs │ ├── TypeSig.hs │ ├── TypedLam.hs │ └── Var.hs │ ├── TH │ ├── Apply.hs │ ├── Context.hs │ ├── Foldable.hs │ ├── Functor.hs │ ├── HasPlain.hs │ ├── Internal │ │ └── Utils.hs │ ├── Morph.hs │ ├── Nodes.hs │ ├── Pointed.hs │ ├── Traversable.hs │ └── ZipMatch.hs │ ├── Type.hs │ ├── Type │ ├── Functor.hs │ ├── Prune.hs │ └── Pure.hs │ ├── Unify.hs │ └── Unify │ ├── Binding.hs │ ├── Binding │ ├── ST.hs │ ├── ST │ │ └── Load.hs │ └── Save.hs │ ├── Constraints.hs │ ├── Error.hs │ ├── Generalize.hs │ ├── New.hs │ ├── Occurs.hs │ ├── QuantifiedVar.hs │ └── Term.hs ├── stack.yaml └── test ├── AlphaEqTest.hs ├── Benchmark.hs ├── BlameTest.hs ├── ExprUtils.hs ├── Hyper ├── Class │ └── Infer │ │ └── Infer1.hs └── Syntax │ ├── NamelessScope.hs │ └── NamelessScope │ └── InvDeBruijn.hs ├── LangA.hs ├── LangATest.hs ├── LangB.hs ├── LangBTest.hs ├── LangC.hs ├── LangD.hs ├── ReadMeExamples.hs ├── Spec.hs ├── TypeLang.hs └── run-interpreted /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .stack-work-profile/ 3 | *~ 4 | /tags 5 | .vscode/ 6 | /.ghci 7 | /dist/ 8 | /ghci-out/ 9 | /.dir-locals.el 10 | /.ghcid 11 | /dumps/ 12 | stack.yaml.lock 13 | /dist-newstyle/ 14 | .ghc.environment.* 15 | .DS_Store 16 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hypertypes 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 4 2 | function-arrows: trailing 3 | comma-style: leading 4 | import-export-style: leading 5 | indent-wheres: true 6 | record-brace-space: false 7 | newlines-between-decls: 1 8 | haddock-style: single-line 9 | haddock-style-module: 10 | let-style: auto 11 | in-style: left-align 12 | respectful: true 13 | fixities: 14 | - infixl 1 \\ 15 | - infixl 1 >>= 16 | - infixl 1 <&> 17 | - infixl 3 <|> 18 | - infixl 8 ^? 19 | unicode: detect 20 | single-constraint-parens: never 21 | reexports: 22 | - module Hyper.Internal.Prelude exports Data.Function 23 | -------------------------------------------------------------------------------- /hypertypes.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.36.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: hypertypes 8 | version: 0.2.3 9 | synopsis: Typed ASTs 10 | description: Please see the README on GitHub at 11 | category: Algorithms, Compilers/Interpreters, Language, Logic, Unification 12 | homepage: https://github.com/lamdu/hypertypes#readme 13 | bug-reports: https://github.com/lamdu/hypertypes/issues 14 | author: Yair Chuchem 15 | maintainer: yairchu@gmail.com 16 | copyright: 2018 Yair Chuchem" 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/lamdu/hypertypes 27 | 28 | library 29 | exposed-modules: 30 | Hyper 31 | Hyper.Class.Apply 32 | Hyper.Class.Context 33 | Hyper.Class.Foldable 34 | Hyper.Class.Functor 35 | Hyper.Class.HasPlain 36 | Hyper.Class.Infer 37 | Hyper.Class.Infer.Env 38 | Hyper.Class.Infer.InferOf 39 | Hyper.Class.Monad 40 | Hyper.Class.Morph 41 | Hyper.Class.Nodes 42 | Hyper.Class.Optic 43 | Hyper.Class.Pointed 44 | Hyper.Class.Recursive 45 | Hyper.Class.Traversable 46 | Hyper.Class.Unify 47 | Hyper.Class.ZipMatch 48 | Hyper.Combinator.Ann 49 | Hyper.Combinator.ANode 50 | Hyper.Combinator.Compose 51 | Hyper.Combinator.Flip 52 | Hyper.Combinator.Func 53 | Hyper.Diff 54 | Hyper.Infer 55 | Hyper.Infer.Blame 56 | Hyper.Infer.Result 57 | Hyper.Infer.ScopeLevel 58 | Hyper.Recurse 59 | Hyper.Syntax 60 | Hyper.Syntax.App 61 | Hyper.Syntax.FuncType 62 | Hyper.Syntax.Lam 63 | Hyper.Syntax.Let 64 | Hyper.Syntax.Map 65 | Hyper.Syntax.Nominal 66 | Hyper.Syntax.Row 67 | Hyper.Syntax.Scheme 68 | Hyper.Syntax.Scheme.AlphaEq 69 | Hyper.Syntax.TypedLam 70 | Hyper.Syntax.TypeSig 71 | Hyper.Syntax.Var 72 | Hyper.TH.Apply 73 | Hyper.TH.Context 74 | Hyper.TH.Foldable 75 | Hyper.TH.Functor 76 | Hyper.TH.HasPlain 77 | Hyper.TH.Morph 78 | Hyper.TH.Nodes 79 | Hyper.TH.Pointed 80 | Hyper.TH.Traversable 81 | Hyper.TH.ZipMatch 82 | Hyper.Type 83 | Hyper.Type.Functor 84 | Hyper.Type.Prune 85 | Hyper.Type.Pure 86 | Hyper.Unify 87 | Hyper.Unify.Binding 88 | Hyper.Unify.Binding.Save 89 | Hyper.Unify.Binding.ST 90 | Hyper.Unify.Binding.ST.Load 91 | Hyper.Unify.Constraints 92 | Hyper.Unify.Error 93 | Hyper.Unify.Generalize 94 | Hyper.Unify.New 95 | Hyper.Unify.Occurs 96 | Hyper.Unify.QuantifiedVar 97 | Hyper.Unify.Term 98 | other-modules: 99 | Hyper.Internal.Prelude 100 | Hyper.TH.Internal.Utils 101 | hs-source-dirs: 102 | src 103 | default-extensions: 104 | ConstraintKinds 105 | DataKinds 106 | DefaultSignatures 107 | DeriveGeneric 108 | DerivingStrategies 109 | GADTs 110 | GeneralizedNewtypeDeriving 111 | LambdaCase 112 | MultiParamTypeClasses 113 | RankNTypes 114 | ScopedTypeVariables 115 | StandaloneDeriving 116 | TupleSections 117 | TypeApplications 118 | TypeOperators 119 | TypeFamilies 120 | NoImplicitPrelude 121 | ghc-options: -fexpose-all-unfoldings -Wall -Wcompat -Wredundant-constraints -Wunused-packages -Wnoncanonical-monad-instances -Wincomplete-record-updates -Wincomplete-uni-patterns 122 | ghc-prof-options: -fexpose-all-unfoldings 123 | build-depends: 124 | array 125 | , base >=4.9 && <5 126 | , base-compat 127 | , binary 128 | , constraints 129 | , containers 130 | , deepseq 131 | , generic-constraints 132 | , generic-data 133 | , lattices 134 | , lens 135 | , monad-st 136 | , mtl 137 | , pretty 138 | , show-combinators 139 | , template-haskell 140 | , th-abstraction >=0.6 141 | , transformers 142 | default-language: Haskell2010 143 | 144 | test-suite hypertypes-test 145 | type: exitcode-stdio-1.0 146 | main-is: Spec.hs 147 | other-modules: 148 | AlphaEqTest 149 | BlameTest 150 | ExprUtils 151 | Hyper.Class.Infer.Infer1 152 | Hyper.Syntax.NamelessScope 153 | Hyper.Syntax.NamelessScope.InvDeBruijn 154 | LangA 155 | LangATest 156 | LangB 157 | LangBTest 158 | LangC 159 | LangD 160 | ReadMeExamples 161 | TypeLang 162 | Paths_hypertypes 163 | hs-source-dirs: 164 | test 165 | default-extensions: 166 | ConstraintKinds 167 | DataKinds 168 | DefaultSignatures 169 | DeriveGeneric 170 | DerivingStrategies 171 | GADTs 172 | GeneralizedNewtypeDeriving 173 | LambdaCase 174 | MultiParamTypeClasses 175 | RankNTypes 176 | ScopedTypeVariables 177 | StandaloneDeriving 178 | TupleSections 179 | TypeApplications 180 | TypeOperators 181 | TypeFamilies 182 | NoImplicitPrelude 183 | ghc-options: -fexpose-all-unfoldings -Wall -Wcompat -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N 184 | ghc-prof-options: -fexpose-all-unfoldings 185 | build-depends: 186 | base >=4.9 && <5 187 | , constraints 188 | , containers 189 | , generic-constraints 190 | , generic-data 191 | , hypertypes 192 | , lattices 193 | , lens 194 | , monad-st 195 | , mtl 196 | , pretty 197 | , tasty 198 | , tasty-hunit 199 | , text 200 | default-language: Haskell2010 201 | 202 | benchmark hypertypes-bench 203 | type: exitcode-stdio-1.0 204 | main-is: Benchmark.hs 205 | other-modules: 206 | LangB 207 | TypeLang 208 | hs-source-dirs: 209 | test 210 | default-extensions: 211 | ConstraintKinds 212 | DataKinds 213 | DefaultSignatures 214 | DeriveGeneric 215 | DerivingStrategies 216 | GADTs 217 | GeneralizedNewtypeDeriving 218 | LambdaCase 219 | MultiParamTypeClasses 220 | RankNTypes 221 | ScopedTypeVariables 222 | StandaloneDeriving 223 | TupleSections 224 | TypeApplications 225 | TypeOperators 226 | TypeFamilies 227 | NoImplicitPrelude 228 | ghc-options: -fexpose-all-unfoldings -Wall -Wcompat -Wredundant-constraints -Wunused-packages -O2 -Wnoncanonical-monad-instances -Wincomplete-record-updates -Wincomplete-uni-patterns 229 | ghc-prof-options: -fexpose-all-unfoldings 230 | build-depends: 231 | base >=4.9 && <5 232 | , constraints 233 | , containers 234 | , criterion 235 | , generic-constraints 236 | , generic-data 237 | , hypertypes 238 | , lattices 239 | , lens 240 | , monad-st 241 | , mtl 242 | , pretty 243 | default-language: Haskell2010 244 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: hypertypes 2 | version: 0.2.3 3 | github: "lamdu/hypertypes" 4 | license: BSD3 5 | author: "Yair Chuchem" 6 | maintainer: "yairchu@gmail.com" 7 | copyright: 2018 Yair Chuchem" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: Typed ASTs 14 | category: Algorithms, Compilers/Interpreters, Language, Logic, Unification 15 | 16 | description: Please see the README on GitHub at 17 | 18 | dependencies: 19 | - base >= 4.9 && <5 20 | - constraints 21 | - containers 22 | - generic-constraints 23 | - generic-data 24 | - lattices 25 | - lens 26 | - monad-st 27 | - mtl 28 | - pretty 29 | 30 | default-extensions: 31 | - ConstraintKinds 32 | - DataKinds 33 | - DefaultSignatures 34 | - DeriveGeneric 35 | - DerivingStrategies 36 | - GADTs 37 | - GeneralizedNewtypeDeriving 38 | - LambdaCase 39 | - MultiParamTypeClasses 40 | - RankNTypes 41 | - ScopedTypeVariables 42 | - StandaloneDeriving 43 | - TupleSections 44 | - TypeApplications 45 | - TypeOperators 46 | - TypeFamilies 47 | - NoImplicitPrelude 48 | 49 | ghc-options: 50 | - -fexpose-all-unfoldings 51 | - -Wall 52 | - -Wcompat 53 | - -Wredundant-constraints 54 | - -Wunused-packages 55 | ghc-prof-options: 56 | - -fexpose-all-unfoldings 57 | 58 | library: 59 | source-dirs: src 60 | other-modules: 61 | - Hyper.Internal.Prelude 62 | - Hyper.TH.Internal.Utils 63 | dependencies: 64 | - array 65 | - base-compat 66 | - binary 67 | - deepseq 68 | - pretty 69 | - show-combinators 70 | - template-haskell 71 | - transformers 72 | - th-abstraction >= 0.6 73 | ghc-options: 74 | - -Wnoncanonical-monad-instances 75 | - -Wincomplete-record-updates 76 | - -Wincomplete-uni-patterns 77 | 78 | tests: 79 | hypertypes-test: 80 | main: Spec.hs 81 | source-dirs: test 82 | when: 83 | - condition: false 84 | other-modules: 85 | - Benchmark 86 | ghc-options: 87 | - -threaded 88 | - -rtsopts 89 | - -with-rtsopts=-N 90 | dependencies: 91 | - hypertypes 92 | - tasty 93 | - tasty-hunit 94 | - text 95 | 96 | benchmarks: 97 | hypertypes-bench: 98 | main: Benchmark.hs 99 | source-dirs: test 100 | other-modules: 101 | - LangB 102 | - TypeLang 103 | ghc-options: 104 | - -O2 105 | - -Wnoncanonical-monad-instances 106 | - -Wincomplete-record-updates 107 | - -Wincomplete-uni-patterns 108 | dependencies: 109 | - criterion 110 | - hypertypes 111 | -------------------------------------------------------------------------------- /src/Hyper.hs: -------------------------------------------------------------------------------- 1 | -- | A convinience module which re-exports common functionality of the hypertypes library 2 | module Hyper (module X) where 3 | 4 | import Data.Constraint as X (Constraint, Dict (..), withDict) 5 | import Data.Functor.Const as X (Const (..)) 6 | import Data.Proxy as X (Proxy (..)) 7 | import GHC.Generics as X (Generic, (:*:) (..)) 8 | import Hyper.Class.Apply as X (HApplicative, HApply (..), liftH2) 9 | import Hyper.Class.Foldable as X (HFoldable (..), hfoldMap, hfolded1, htraverse1_, htraverse_) 10 | import Hyper.Class.Functor as X (HFunctor (..), hmapped1) 11 | import Hyper.Class.HasPlain as X (HasHPlain (..)) 12 | import Hyper.Class.Nodes as X (HNodes (..), HWitness (..), (#*#), (#>), _HWitness) 13 | import Hyper.Class.Pointed as X (HPointed (..)) 14 | import Hyper.Class.Recursive as X (RNodes, RTraversable, Recursively (..)) 15 | import Hyper.Class.Traversable as X (HTraversable (..), htraverse, htraverse1) 16 | import Hyper.Combinator.ANode as X 17 | import Hyper.Combinator.Ann as X 18 | import Hyper.Combinator.Compose as X (HCompose (..), hcomposed, _HCompose) 19 | import Hyper.Combinator.Flip as X 20 | import Hyper.Combinator.Func as X 21 | import Hyper.TH.Apply as X (makeHApplicativeBases) 22 | import Hyper.TH.Context as X (makeHContext) 23 | import Hyper.TH.HasPlain as X (makeHasHPlain) 24 | import Hyper.TH.Morph as X (makeHMorph) 25 | import Hyper.TH.Traversable as X (makeHTraversableAndBases, makeHTraversableApplyAndBases) 26 | import Hyper.TH.ZipMatch as X (makeZipMatch) 27 | import Hyper.Type as X 28 | import Hyper.Type.Pure as X 29 | -------------------------------------------------------------------------------- /src/Hyper/Class/Apply.hs: -------------------------------------------------------------------------------- 1 | -- | A variant of 'Data.Functor.Apply.Apply' for 'Hyper.Type.HyperType's 2 | module Hyper.Class.Apply 3 | ( HApply (..) 4 | , HApplicative 5 | , liftH2 6 | ) where 7 | 8 | import Hyper.Class.Functor (HFunctor (..)) 9 | import Hyper.Class.Nodes (HWitness) 10 | import Hyper.Class.Pointed (HPointed) 11 | import Hyper.Type (type (#)) 12 | 13 | import Hyper.Internal.Prelude 14 | 15 | -- | A variant of 'Data.Functor.Apply.Apply' for 'Hyper.Type.HyperType's. 16 | -- 17 | -- A type which has 'HApply' and 'HPointed' instances also has 'HApplicative', 18 | -- which is the equivalent to the 'Applicative' class. 19 | class HFunctor h => HApply h where 20 | -- | Combine child values 21 | -- 22 | -- >>> hzip (Person name0 age0) (Person name1 age1) 23 | -- Person (Pair name0 name1) (Pair age0 age1) 24 | hzip :: 25 | h # p -> 26 | h # q -> 27 | h # (p :*: q) 28 | 29 | -- | A variant of 'Applicative' for 'Hyper.Type.HyperType's. 30 | type HApplicative h = (HPointed h, HApply h) 31 | 32 | instance Semigroup a => HApply (Const a) where 33 | {-# INLINE hzip #-} 34 | hzip (Const x) (Const y) = Const (x <> y) 35 | 36 | instance (HApply a, HApply b) => HApply (a :*: b) where 37 | {-# INLINE hzip #-} 38 | hzip (a0 :*: b0) (a1 :*: b1) = hzip a0 a1 :*: hzip b0 b1 39 | 40 | -- | 'HApply' variant of 'Control.Applicative.liftA2' 41 | {-# INLINE liftH2 #-} 42 | liftH2 :: 43 | HApply h => 44 | (forall n. HWitness h n -> p # n -> q # n -> r # n) -> 45 | h # p -> 46 | h # q -> 47 | h # r 48 | liftH2 f x = hmap (\w (a :*: b) -> f w a b) . hzip x 49 | -------------------------------------------------------------------------------- /src/Hyper/Class/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Hyper.Class.Context 5 | ( HContext (..) 6 | , recursiveContexts 7 | , annContexts 8 | ) where 9 | 10 | import Control.Lens (from, mapped, _1, _2, _Wrapped) 11 | import Hyper.Class.Functor (HFunctor (..)) 12 | import Hyper.Class.Nodes ((#*#), (#>)) 13 | import Hyper.Class.Recursive (Recursively (..)) 14 | import Hyper.Combinator.Ann (Ann (..)) 15 | import Hyper.Combinator.Compose (HCompose (..), decompose, _HCompose) 16 | import Hyper.Combinator.Flip 17 | import Hyper.Combinator.Func (HFunc (..), _HFunc) 18 | import Hyper.Type (type (#)) 19 | import Hyper.Type.Pure (Pure (..), _Pure) 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | class HContext h where 24 | -- | Add next to each node a function to replace it in the parent with a different value 25 | hcontext :: 26 | h # p -> 27 | h # (HFunc p (Const (h # p)) :*: p) 28 | 29 | instance HContext Pure where 30 | hcontext = _Pure %~ (HFunc (Const . Pure) :*:) 31 | 32 | instance (HContext a, HFunctor a) => HContext (Ann a) where 33 | hcontext (Ann a b) = 34 | Ann 35 | (hmap (const (_1 . _HFunc . mapped . _Wrapped %~ (`Ann` b))) (hcontext a)) 36 | (HFunc (Const . Ann a) :*: b) 37 | 38 | instance (HFunctor c1, HContext c1, HFunctor h1, HContext h1) => HContext (HCompose c1 h1) where 39 | hcontext = 40 | _HCompose %~ layer (\c0 -> layer $ \c1 -> (HFunc ((_Wrapped %~ (_HCompose #)) . c0 . getConst . c1) :*:)) 41 | where 42 | layer :: 43 | (HFunctor h, HContext h) => 44 | (forall n. (p0 # HCompose q0 n -> Const (h # HCompose p0 q0) # n) -> p0 # HCompose q0 n -> p1 # HCompose q1 n) -> 45 | (h # HCompose p0 q0) -> 46 | h # HCompose p1 q1 47 | layer f = hmap (\_ (HFunc c :*: x) -> x & _HCompose %~ f (c . (_HCompose #))) . hcontext 48 | 49 | instance (Recursively HContext h, Recursively HFunctor h) => HContext (HFlip Ann h) where 50 | -- The context of (HFlip Ann h) differs from annContexts in that 51 | -- only the annotation itself is replaced rather than the whole subexpression. 52 | hcontext = 53 | hmap (const (_1 . _HFunc . mapped . _Wrapped %~ (_HFlip #))) . (from hflipped %~ f . annContexts) 54 | where 55 | f :: 56 | forall n p r. 57 | Recursively HFunctor n => 58 | Ann (HFunc (Ann p) (Const r) :*: p) # n -> 59 | Ann (HFunc p (Const r) :*: p) # n 60 | f (Ann (HFunc func :*: a) b) = 61 | Ann (HFunc (func . (`Ann` g b)) :*: a) (hmap (Proxy @(Recursively HFunctor) #> f) b) 62 | \\ recursively (Proxy @(HFunctor n)) 63 | g :: 64 | forall n a b. 65 | Recursively HFunctor n => 66 | n # Ann (a :*: b) -> 67 | n # Ann b 68 | g = 69 | hmap (Proxy @(Recursively HFunctor) #> hflipped %~ hmap (const (^. _2))) 70 | \\ recursively (Proxy @(HFunctor n)) 71 | 72 | -- | Add in the node annotations a function to replace each node in the top-level node 73 | recursiveContexts :: 74 | (Recursively HContext h, Recursively HFunctor h, Recursively HContext p, Recursively HFunctor p) => 75 | p # h -> 76 | HCompose (Ann (HFunc Pure (Const (p # h)))) p # h 77 | recursiveContexts = recursiveContextsWith . (HFunc Const :*:) 78 | 79 | recursiveContextsWith :: 80 | forall h p r. 81 | (Recursively HContext h, Recursively HFunctor h, Recursively HContext p, Recursively HFunctor p) => 82 | (HFunc p (Const r) :*: p) # h -> 83 | HCompose (Ann (HFunc Pure (Const r))) p # h 84 | recursiveContextsWith (HFunc s0 :*: x0) = 85 | _HCompose 86 | # Ann 87 | { _hAnn = _HFunc # Const . getConst . s0 . (^. decompose) 88 | , _hVal = 89 | layer x0 $ \s1 x1 -> layer x1 $ \s2 x2 -> recursiveContextsWith (HFunc (Const . getConst . s0 . s1 . s2) :*: x2) 90 | } 91 | where 92 | layer :: 93 | forall t s c0 c1. 94 | (Recursively HFunctor t, Recursively HContext t) => 95 | t # s -> 96 | (forall n. (Recursively HFunctor n, Recursively HContext n) => (s # n -> t # s) -> s # n -> HCompose c0 c1 # n) -> 97 | HCompose t c0 # c1 98 | layer x f = 99 | _HCompose 100 | # hmap (Proxy @(Recursively HContext) #*# Proxy @(Recursively HFunctor) #> \(HFunc s :*: v) -> f (getConst . s) v) (hcontext x) 101 | \\ recursively (Proxy @(HFunctor t)) 102 | \\ recursively (Proxy @(HContext t)) 103 | 104 | -- | Add in the node annotations a function to replace each node in the top-level node 105 | -- 106 | -- It is possible to define annContexts in terms of 'recursiveContexts' but the conversion is quite unwieldy. 107 | annContexts :: 108 | (Recursively HContext h, Recursively HFunctor h) => 109 | Ann p # h -> 110 | Ann (HFunc (Ann p) (Const (Ann p # h)) :*: p) # h 111 | annContexts = annContextsWith . (HFunc Const :*:) 112 | 113 | annContextsWith :: 114 | forall h p r. 115 | (Recursively HContext h, Recursively HFunctor h) => 116 | (HFunc (Ann p) (Const r) :*: Ann p) # h -> 117 | Ann (HFunc (Ann p) (Const r) :*: p) # h 118 | annContextsWith (HFunc s0 :*: Ann a b) = 119 | Ann 120 | { _hAnn = HFunc s0 :*: a 121 | , _hVal = 122 | hmap 123 | ( Proxy @(Recursively HContext) #*# 124 | Proxy @(Recursively HFunctor) #> 125 | \(HFunc s1 :*: x) -> 126 | annContextsWith (HFunc (Const . getConst . s0 . Ann a . getConst . s1) :*: x) 127 | ) 128 | (hcontext b) 129 | \\ recursively (Proxy @(HFunctor h)) 130 | \\ recursively (Proxy @(HContext h)) 131 | } 132 | -------------------------------------------------------------------------------- /src/Hyper/Class/Foldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A variant of 'Foldable' for 'Hyper.Type.HyperType's 4 | module Hyper.Class.Foldable 5 | ( HFoldable (..) 6 | , hfolded1 7 | , htraverse_ 8 | , htraverse1_ 9 | ) where 10 | 11 | import Control.Lens (Fold, folding) 12 | import GHC.Generics 13 | import Hyper.Class.Nodes (HNodes (..), HWitness (..), (#>), _HWitness) 14 | import Hyper.Type (type (#)) 15 | 16 | import Hyper.Internal.Prelude 17 | 18 | -- | A variant of 'Foldable' for 'Hyper.Type.HyperType's 19 | class HNodes h => HFoldable h where 20 | -- | 'HFoldable' variant of 'foldMap' 21 | -- 22 | -- Gets a function from @h@'s nodes (trees along witnesses that they are nodes of @h@) 23 | -- into a monoid and concats its results for all nodes. 24 | hfoldMap :: 25 | Monoid a => 26 | (forall n. HWitness h n -> p # n -> a) -> 27 | h # p -> 28 | a 29 | {-# INLINE hfoldMap #-} 30 | default hfoldMap :: 31 | ( Generic1 h 32 | , HFoldable (Rep1 h) 33 | , HWitnessType h ~ HWitnessType (Rep1 h) 34 | , Monoid a 35 | ) => 36 | (forall n. HWitness h n -> p # n -> a) -> 37 | h # p -> 38 | a 39 | hfoldMap f = hfoldMap (f . (_HWitness %~ id)) . from1 40 | 41 | instance HFoldable (Const a) where 42 | {-# INLINE hfoldMap #-} 43 | hfoldMap _ = mempty 44 | 45 | instance (HFoldable a, HFoldable b) => HFoldable (a :*: b) where 46 | {-# INLINE hfoldMap #-} 47 | hfoldMap f (x :*: y) = 48 | hfoldMap (f . HWitness . L1) x 49 | <> hfoldMap (f . HWitness . R1) y 50 | 51 | instance (HFoldable a, HFoldable b) => HFoldable (a :+: b) where 52 | {-# INLINE hfoldMap #-} 53 | hfoldMap f (L1 x) = hfoldMap (f . HWitness . L1) x 54 | hfoldMap f (R1 x) = hfoldMap (f . HWitness . R1) x 55 | 56 | deriving newtype instance HFoldable h => HFoldable (M1 i m h) 57 | deriving newtype instance HFoldable h => HFoldable (Rec1 h) 58 | 59 | -- | 'HFoldable' variant for 'Control.Lens.folded' for 'Hyper.Type.HyperType's with a single node type. 60 | -- 61 | -- Avoids using @RankNTypes@ and thus can be composed with other optics. 62 | {-# INLINE hfolded1 #-} 63 | hfolded1 :: 64 | forall h n p. 65 | ( HFoldable h 66 | , HNodesConstraint h ((~) n) 67 | ) => 68 | Fold (h # p) (p # n) 69 | hfolded1 = 70 | folding (hfoldMap @_ @[p # n] (Proxy @((~) n) #> pure)) 71 | 72 | -- | 'HFoldable' variant of 'Data.Foldable.traverse_' 73 | -- 74 | -- Applise a given action on all subtrees 75 | -- (represented as trees along witnesses that they are nodes of @h@) 76 | {-# INLINE htraverse_ #-} 77 | htraverse_ :: 78 | (Applicative f, HFoldable h) => 79 | (forall c. HWitness h c -> m # c -> f ()) -> 80 | h # m -> 81 | f () 82 | htraverse_ f = sequenceA_ . hfoldMap (fmap (: []) . f) 83 | 84 | -- | 'HFoldable' variant of 'Data.Foldable.traverse_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@) 85 | {-# INLINE htraverse1_ #-} 86 | htraverse1_ :: 87 | forall f h n p. 88 | ( Applicative f 89 | , HFoldable h 90 | , HNodesConstraint h ((~) n) 91 | ) => 92 | (p # n -> f ()) -> 93 | h # p -> 94 | f () 95 | htraverse1_ f = htraverse_ (Proxy @((~) n) #> f) 96 | -------------------------------------------------------------------------------- /src/Hyper/Class/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A variant of 'Functor' for 'Hyper.Type.HyperType's 4 | module Hyper.Class.Functor 5 | ( HFunctor (..) 6 | , hmapped1 7 | , hiso 8 | ) where 9 | 10 | import Control.Lens (AnIso', Iso', Setter, cloneIso, iso, sets, _Wrapped) 11 | import GHC.Generics 12 | import GHC.Generics.Lens (generic1) 13 | import Hyper.Class.Nodes (HNodes (..), HWitness (..), (#>), _HWitness) 14 | import Hyper.Type (type (#)) 15 | 16 | import Hyper.Internal.Prelude 17 | 18 | -- | A variant of 'Functor' for 'HyperType's 19 | class HNodes h => HFunctor h where 20 | -- | 'HFunctor' variant of 'fmap' 21 | -- 22 | -- Applied a given mapping for @h@'s nodes (trees along witnesses that they are nodes of @h@) 23 | -- to result with a new tree, potentially with a different nest type. 24 | hmap :: 25 | (forall n. HWitness h n -> p # n -> q # n) -> 26 | h # p -> 27 | h # q 28 | {-# INLINE hmap #-} 29 | default hmap :: 30 | (Generic1 h, HFunctor (Rep1 h), HWitnessType h ~ HWitnessType (Rep1 h)) => 31 | (forall n. HWitness h n -> p # n -> q # n) -> 32 | h # p -> 33 | h # q 34 | hmap f = generic1 %~ hmap (f . (_HWitness %~ id)) 35 | 36 | instance HFunctor (Const a) where 37 | {-# INLINE hmap #-} 38 | hmap _ = _Wrapped %~ id 39 | 40 | instance (HFunctor a, HFunctor b) => HFunctor (a :*: b) where 41 | {-# INLINE hmap #-} 42 | hmap f (x :*: y) = 43 | hmap (f . HWitness . L1) x 44 | :*: hmap (f . HWitness . R1) y 45 | 46 | instance (HFunctor a, HFunctor b) => HFunctor (a :+: b) where 47 | {-# INLINE hmap #-} 48 | hmap f (L1 x) = L1 (hmap (f . HWitness . L1) x) 49 | hmap f (R1 x) = R1 (hmap (f . HWitness . R1) x) 50 | 51 | deriving newtype instance HFunctor h => HFunctor (M1 i m h) 52 | deriving newtype instance HFunctor h => HFunctor (Rec1 h) 53 | 54 | -- | 'HFunctor' variant of 'Control.Lens.mapped' for 'Hyper.Type.HyperType's with a single node type. 55 | -- 56 | -- Avoids using @RankNTypes@ and thus can be composed with other optics. 57 | {-# INLINE hmapped1 #-} 58 | hmapped1 :: 59 | forall h n p q. 60 | (HFunctor h, HNodesConstraint h ((~) n)) => 61 | Setter (h # p) (h # q) (p # n) (q # n) 62 | hmapped1 = sets (\f -> hmap (Proxy @((~) n) #> f)) 63 | 64 | -- | Define 'Iso's for 'HFunctor's 65 | -- 66 | -- TODO: Is there an equivalent for this in lens that we can name this after? 67 | hiso :: 68 | HFunctor h => 69 | (forall n. HWitness h n -> AnIso' (p # n) (q # n)) -> 70 | Iso' (h # p) (h # q) 71 | hiso f = iso (hmap (\w -> (^. cloneIso (f w)))) (hmap (\w -> (cloneIso (f w) #))) 72 | -------------------------------------------------------------------------------- /src/Hyper/Class/HasPlain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A class for plain 'Data.Kind.Type' equivalents 4 | -- for the simple forms of 'Hyper.Type.HyperType's. 5 | -- 6 | -- Useful for succinct tests, examples, and for debug prints. 7 | module Hyper.Class.HasPlain 8 | ( HasHPlain (..) 9 | ) where 10 | 11 | import Control.Lens (Iso') 12 | import Hyper.Type (type (#)) 13 | import Hyper.Type.Pure (Pure) 14 | 15 | import Prelude.Compat 16 | 17 | -- | A class for a plain form of a @Pure # h@ 18 | class Show (HPlain h) => HasHPlain h where 19 | -- | Plain form data type 20 | data HPlain h 21 | 22 | -- | An 'Control.Lens.Iso' between the plain form and 'Hyper.Type.HyperType' form 23 | hPlain :: Iso' (HPlain h) (Pure # h) 24 | -------------------------------------------------------------------------------- /src/Hyper/Class/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Hyper.Class.Infer 6 | ( InferOf 7 | , Infer (..) 8 | , InferChild (..) 9 | , _InferChild 10 | , InferredChild (..) 11 | , inType 12 | , inRep 13 | ) where 14 | 15 | import qualified Control.Lens as Lens 16 | import GHC.Generics 17 | import Hyper 18 | import Hyper.Class.Unify 19 | import Hyper.Recurse 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | -- | @InferOf e@ is the inference result of @e@. 24 | -- 25 | -- Most commonly it is an inferred type, using 26 | -- 27 | -- > type instance InferOf MyTerm = ANode MyType 28 | -- 29 | -- But it may also be other things, for example: 30 | -- 31 | -- * An inferred value (for types inside terms) 32 | -- * An inferred type together with a scope 33 | type family InferOf (t :: HyperType) :: HyperType 34 | 35 | -- | A 'HyperType' containing an inferred child node 36 | data InferredChild v h t = InferredChild 37 | { _inRep :: !(h t) 38 | -- ^ Inferred node. 39 | -- 40 | -- An 'inferBody' implementation needs to place this value in the corresponding child node of the inferred term body 41 | , _inType :: !(InferOf (GetHyperType t) # v) 42 | -- ^ The inference result for the child node. 43 | -- 44 | -- An 'inferBody' implementation may use it to perform unifications with it. 45 | } 46 | 47 | makeLenses ''InferredChild 48 | 49 | -- | A 'HyperType' containing an inference action. 50 | -- 51 | -- The caller may modify the scope before invoking the action via 52 | -- 'Hyper.Class.Infer.Env.localScopeType' or 'Hyper.Infer.ScopeLevel.localLevel' 53 | newtype InferChild m h t = InferChild {inferChild :: m (InferredChild (UVarOf m) h t)} 54 | 55 | makePrisms ''InferChild 56 | 57 | -- | @Infer m t@ enables 'Hyper.Infer.infer' to perform type-inference for @t@ in the 'Monad' @m@. 58 | -- 59 | -- The 'inferContext' method represents the following constraints on @t@: 60 | -- 61 | -- * @HNodesConstraint (InferOf t) (Unify m)@ - The child nodes of the inferrence can unify in the @m@ 'Monad' 62 | -- * @HNodesConstraint t (Infer m)@ - @Infer m@ is also available for child nodes 63 | -- 64 | -- It replaces context for the 'Infer' class to avoid @UndecidableSuperClasses@. 65 | -- 66 | -- Instances usually don't need to implement this method as the default implementation works for them, 67 | -- but infinitely polymorphic trees such as 'Hyper.Type.AST.NamelessScope.Scope' do need to implement the method, 68 | -- because the required context is infinite. 69 | class (Monad m, HFunctor t) => Infer m t where 70 | -- | Infer the body of an expression given the inference actions for its child nodes. 71 | inferBody :: 72 | t # InferChild m h -> 73 | m (t # h, InferOf t # UVarOf m) 74 | default inferBody :: 75 | (Generic1 t, Infer m (Rep1 t), InferOf t ~ InferOf (Rep1 t)) => 76 | t # InferChild m h -> 77 | m (t # h, InferOf t # UVarOf m) 78 | inferBody = 79 | fmap (Lens._1 %~ to1) . inferBody . from1 80 | 81 | -- TODO: Putting documentation here causes duplication in the haddock documentation 82 | inferContext :: 83 | proxy0 m -> 84 | proxy1 t -> 85 | Dict (HNodesConstraint t (Infer m), HNodesConstraint (InferOf t) (UnifyGen m)) 86 | {-# INLINE inferContext #-} 87 | default inferContext :: 88 | (HNodesConstraint t (Infer m), HNodesConstraint (InferOf t) (UnifyGen m)) => 89 | proxy0 m -> 90 | proxy1 t -> 91 | Dict (HNodesConstraint t (Infer m), HNodesConstraint (InferOf t) (UnifyGen m)) 92 | inferContext _ _ = Dict 93 | 94 | instance Recursive (Infer m) where 95 | {-# INLINE recurse #-} 96 | recurse p = Dict \\ inferContext (Proxy @m) (proxyArgument p) 97 | 98 | type instance InferOf (a :+: _) = InferOf a 99 | 100 | instance (InferOf a ~ InferOf b, Infer m a, Infer m b) => Infer m (a :+: b) where 101 | {-# INLINE inferBody #-} 102 | inferBody (L1 x) = inferBody x <&> Lens._1 %~ L1 103 | inferBody (R1 x) = inferBody x <&> Lens._1 %~ R1 104 | 105 | {-# INLINE inferContext #-} 106 | inferContext p _ = Dict \\ inferContext p (Proxy @a) \\ inferContext p (Proxy @b) 107 | 108 | type instance InferOf (M1 _ _ h) = InferOf h 109 | 110 | instance Infer m h => Infer m (M1 i c h) where 111 | {-# INLINE inferBody #-} 112 | inferBody (M1 x) = inferBody x <&> Lens._1 %~ M1 113 | 114 | {-# INLINE inferContext #-} 115 | inferContext p _ = Dict \\ inferContext p (Proxy @h) 116 | 117 | type instance InferOf (Rec1 h) = InferOf h 118 | 119 | instance Infer m h => Infer m (Rec1 h) where 120 | {-# INLINE inferBody #-} 121 | inferBody (Rec1 x) = inferBody x <&> Lens._1 %~ Rec1 122 | 123 | {-# INLINE inferContext #-} 124 | inferContext p _ = Dict \\ inferContext p (Proxy @h) 125 | -------------------------------------------------------------------------------- /src/Hyper/Class/Infer/Env.hs: -------------------------------------------------------------------------------- 1 | -- | Traits of inference monads. 2 | module Hyper.Class.Infer.Env 3 | ( LocalScopeType (..) 4 | ) where 5 | 6 | -- | @LocalScopeType var scheme m@ represents that 7 | -- @m@ maintains a scope mapping variables of type @var@ 8 | -- to type schemes of type @scheme@. 9 | -- 10 | -- Used by the 'Hyper.Class.Infer.Infer' instances 11 | -- of 'Hyper.Type.AST.Lam.Lam' and 'Hyper.Type.AST.Let.Let'. 12 | class LocalScopeType var scheme m where 13 | -- | Add a variable type into an action's scope 14 | localScopeType :: var -> scheme -> m a -> m a 15 | -------------------------------------------------------------------------------- /src/Hyper/Class/Infer/InferOf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hyper.Class.Infer.InferOf 6 | ( HasInferredType (..) 7 | , HasInferredValue (..) 8 | , InferOfConstraint (..) 9 | ) where 10 | 11 | import Control.Lens (ALens', Lens') 12 | import Hyper.Class.Infer (InferOf) 13 | import Hyper.Type (HyperType, type (#)) 14 | 15 | import Hyper.Internal.Prelude 16 | 17 | -- | @HasInferredType t@ represents that @InferOf t@ contains a @TypeOf t@, which represents its inferred type. 18 | class HasInferredType t where 19 | -- | The type of @t@ 20 | type TypeOf t :: HyperType 21 | 22 | -- A 'Control.Lens.Lens' from an inference result to an inferred type 23 | inferredType :: Proxy t -> ALens' (InferOf t # v) (v # TypeOf t) 24 | 25 | -- | @HasInferredValue t@ represents that @InferOf t@ contains an inferred value for @t@. 26 | class HasInferredValue t where 27 | -- | A 'Control.Lens.Lens' from an inference result to an inferred value 28 | inferredValue :: Lens' (InferOf t # v) (v # t) 29 | 30 | class InferOfConstraint c h where 31 | inferOfConstraint :: proxy h -> Dict (c (InferOf h)) 32 | 33 | instance c (InferOf h) => InferOfConstraint c h where 34 | inferOfConstraint _ = Dict 35 | -------------------------------------------------------------------------------- /src/Hyper/Class/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A variant of 'Control.Monad.Monad' for 'Hyper.Type.HyperType's 4 | module Hyper.Class.Monad 5 | ( HMonad (..) 6 | , hbind 7 | ) where 8 | 9 | import Hyper.Class.Apply (HApplicative) 10 | import Hyper.Class.Functor (HFunctor (..)) 11 | import Hyper.Class.Nodes (HWitness, (#>)) 12 | import Hyper.Class.Recursive (Recursively (..)) 13 | import Hyper.Combinator.Compose (HCompose, _HCompose) 14 | import Hyper.Type (type (#)) 15 | import Hyper.Type.Pure (Pure (..), _Pure) 16 | 17 | import Hyper.Internal.Prelude 18 | 19 | -- | A variant of 'Control.Monad.Monad' for 'Hyper.Type.HyperType's 20 | class HApplicative h => HMonad h where 21 | hjoin :: 22 | Recursively HFunctor p => 23 | HCompose h h # p -> 24 | h # p 25 | 26 | instance HMonad Pure where 27 | hjoin x = 28 | _Pure 29 | # hmap 30 | (Proxy @(Recursively HFunctor) #> hjoin) 31 | (x ^. _HCompose . _Pure . _HCompose . _Pure . _HCompose) 32 | \\ recursively (p x) 33 | where 34 | p :: HCompose Pure Pure # p -> Proxy (HFunctor p) 35 | p _ = Proxy 36 | 37 | -- | A variant of 'Control.Monad.(>>=)' for 'Hyper.Type.HyperType's 38 | hbind :: 39 | (HMonad h, Recursively HFunctor p) => 40 | h # p -> 41 | (forall n. HWitness h n -> p # n -> HCompose h p # n) -> 42 | h # p 43 | hbind x f = _HCompose # hmap f x & hjoin 44 | -------------------------------------------------------------------------------- /src/Hyper/Class/Morph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | -- | An extension of 'HFunctor' for parameterized 'Hyper.Type.HyperType's 4 | module Hyper.Class.Morph 5 | ( HMorph (..) 6 | , HMorphWithConstraint 7 | , morphTraverse 8 | , (#?>) 9 | , HIs2 10 | , morphMapped1 11 | , morphTraverse1 12 | ) where 13 | 14 | import Control.Lens (Setter, sets) 15 | import Data.Kind (Type) 16 | import Hyper.Class.Traversable (ContainedH (..), HTraversable (..)) 17 | import Hyper.Type (HyperType, type (#)) 18 | 19 | import Hyper.Internal.Prelude 20 | 21 | -- | A type-varying variant of 'HFunctor' which can modify type parameters of the mapped 'HyperType' 22 | class HMorph s t where 23 | type MorphConstraint s t (c :: (HyperType -> HyperType -> Constraint)) :: Constraint 24 | 25 | data MorphWitness s t :: HyperType -> HyperType -> Type 26 | 27 | morphMap :: 28 | (forall a b. MorphWitness s t a b -> p # a -> q # b) -> 29 | s # p -> 30 | t # q 31 | 32 | morphLiftConstraint :: 33 | MorphConstraint s t c => 34 | MorphWitness s t a b -> 35 | Proxy c -> 36 | (c a b => r) -> 37 | r 38 | 39 | type HMorphWithConstraint s t c = (HMorph s t, MorphConstraint s t c) 40 | 41 | -- | 'HTraversable' extended with support of changing type parameters of the 'HyperType' 42 | morphTraverse :: 43 | (Applicative f, HMorph s t, HTraversable t) => 44 | (forall a b. MorphWitness s t a b -> p # a -> f (q # b)) -> 45 | s # p -> 46 | f (t # q) 47 | morphTraverse f = hsequence . morphMap (fmap MkContainedH . f) 48 | 49 | (#?>) :: 50 | (HMorph s t, MorphConstraint s t c) => 51 | Proxy c -> 52 | (c a b => r) -> 53 | MorphWitness s t a b -> 54 | r 55 | (#?>) p r w = morphLiftConstraint w p r 56 | 57 | class (i0 ~ t0, i1 ~ t1) => HIs2 (i0 :: HyperType) (i1 :: HyperType) t0 t1 58 | instance HIs2 a b a b 59 | 60 | morphMapped1 :: 61 | forall a b s t p q. 62 | HMorphWithConstraint s t (HIs2 a b) => 63 | Setter (s # p) (t # q) (p # a) (q # b) 64 | morphMapped1 = sets (\f -> morphMap (Proxy @(HIs2 a b) #?> f)) 65 | 66 | morphTraverse1 :: 67 | (HMorphWithConstraint s t (HIs2 a b), HTraversable t) => 68 | Traversal (s # p) (t # q) (p # a) (q # b) 69 | morphTraverse1 f = hsequence . (morphMapped1 %~ MkContainedH . f) 70 | -------------------------------------------------------------------------------- /src/Hyper/Class/Nodes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | -- | A class for witness types and lifting of constraints to the child nodes of a 'HyperType' 8 | module Hyper.Class.Nodes 9 | ( HNodes (..) 10 | , HWitness (..) 11 | , _HWitness 12 | , (#>) 13 | , (#*#) 14 | , HNodesHaveConstraint (..) 15 | ) where 16 | 17 | import Data.Kind (Type) 18 | import GHC.Generics 19 | import Hyper.Type 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | newtype HWitness h n = HWitness (HWitnessType h n) 24 | 25 | -- | 'HNodes' allows talking about the child nodes of a 'HyperType'. 26 | -- 27 | -- Various classes like 'Hyper.Class.Functor.HFunctor' build upon 'HNodes' 28 | -- to provide methods such as 'Hyper.Class.Functor.hmap' which provide a rank-n function 29 | -- for processing child nodes which requires a constraint on the nodes. 30 | class HNodes (h :: HyperType) where 31 | -- | Lift a constraint to apply to the child nodes 32 | type HNodesConstraint h (c :: (HyperType -> Constraint)) :: Constraint 33 | 34 | type HNodesConstraint h c = HNodesConstraint (Rep1 h) c 35 | 36 | -- | @HWitness h n@ is a witness that @n@ is a node of @h@. 37 | -- 38 | -- A value quantified with @forall n. HWitness h n -> ... n@, 39 | -- is equivalent for a "for-some" where the possible values for @n@ are the nodes of @h@. 40 | type HWitnessType h :: HyperType -> Type 41 | 42 | type HWitnessType h = HWitnessType (Rep1 h) 43 | 44 | -- | Lift a rank-n value with a constraint which the child nodes satisfy 45 | -- to a function from a node witness. 46 | hLiftConstraint :: 47 | HNodesConstraint h c => 48 | HWitness h n -> 49 | Proxy c -> 50 | (c n => r) -> 51 | r 52 | {-# INLINE hLiftConstraint #-} 53 | default hLiftConstraint :: 54 | ( HWitnessType h ~ HWitnessType (Rep1 h) 55 | , HNodesConstraint h c ~ HNodesConstraint (Rep1 h) c 56 | , HNodes (Rep1 h) 57 | , HNodesConstraint h c 58 | ) => 59 | HWitness h n -> 60 | Proxy c -> 61 | (c n => r) -> 62 | r 63 | hLiftConstraint (HWitness w) = hLiftConstraint @(Rep1 h) (HWitness w) 64 | 65 | makePrisms ''HWitness 66 | 67 | instance HNodes (Const a) where 68 | type HNodesConstraint (Const a) _ = () 69 | type HWitnessType (Const a) = V1 70 | {-# INLINE hLiftConstraint #-} 71 | hLiftConstraint = \case {} 72 | 73 | instance (HNodes a, HNodes b) => HNodes (a :*: b) where 74 | type HNodesConstraint (a :*: b) x = (HNodesConstraint a x, HNodesConstraint b x) 75 | type HWitnessType (a :*: b) = HWitness a :+: HWitness b 76 | {-# INLINE hLiftConstraint #-} 77 | hLiftConstraint (HWitness (L1 w)) = hLiftConstraint w 78 | hLiftConstraint (HWitness (R1 w)) = hLiftConstraint w 79 | 80 | instance (HNodes a, HNodes b) => HNodes (a :+: b) where 81 | type HNodesConstraint (a :+: b) x = (HNodesConstraint a x, HNodesConstraint b x) 82 | type HWitnessType (a :+: b) = HWitness a :+: HWitness b 83 | {-# INLINE hLiftConstraint #-} 84 | hLiftConstraint (HWitness (L1 w)) = hLiftConstraint w 85 | hLiftConstraint (HWitness (R1 w)) = hLiftConstraint w 86 | 87 | deriving newtype instance HNodes h => HNodes (M1 i m h) 88 | deriving newtype instance HNodes h => HNodes (Rec1 h) 89 | 90 | infixr 0 #> 91 | infixr 0 #*# 92 | 93 | -- | @Proxy @c #> r@ replaces the witness parameter of @r@ with a constraint on the witnessed node 94 | {-# INLINE (#>) #-} 95 | (#>) :: 96 | (HNodes h, HNodesConstraint h c) => 97 | Proxy c -> 98 | (c n => r) -> 99 | HWitness h n -> 100 | r 101 | (#>) p r w = hLiftConstraint w p r 102 | 103 | -- | A variant of '#>' which does not consume the witness parameter. 104 | -- 105 | -- @Proxy @c0 #*# Proxy @c1 #> r@ brings into context both the @c0 n@ and @c1 n@ constraints. 106 | {-# INLINE (#*#) #-} 107 | (#*#) :: 108 | (HNodes h, HNodesConstraint h c) => 109 | Proxy c -> 110 | (c n => HWitness h n -> r) -> 111 | HWitness h n -> 112 | r 113 | (#*#) p r w = (p #> r) w w 114 | 115 | -- | Defunctionalized HNodesConstraint which can be curried 116 | class HNodesHaveConstraint c h where 117 | hNodesHaveConstraint :: proxy0 c -> proxy1 h -> Dict (HNodesConstraint h c) 118 | 119 | instance HNodesConstraint h c => HNodesHaveConstraint c h where 120 | hNodesHaveConstraint _ _ = Dict 121 | -------------------------------------------------------------------------------- /src/Hyper/Class/Optic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Hyper.Class.Optic 4 | ( HNodeLens (..) 5 | , HSubset (..) 6 | , HSubset' 7 | ) where 8 | 9 | import Control.Lens (Lens', Prism) 10 | import Hyper.Type (type (#)) 11 | 12 | class HNodeLens s a where 13 | hNodeLens :: Lens' (s # h) (h # a) 14 | 15 | class HSubset s t a b where 16 | hSubset :: Prism (s # h) (t # h) (a # h) (b # h) 17 | 18 | type HSubset' s a = HSubset s s a a 19 | -------------------------------------------------------------------------------- /src/Hyper/Class/Pointed.hs: -------------------------------------------------------------------------------- 1 | -- | A variant of 'Data.Pointed.Pointed' for 'Hyper.Type.HyperType's 2 | module Hyper.Class.Pointed 3 | ( HPointed (..) 4 | ) where 5 | 6 | import GHC.Generics ((:+:) (..)) 7 | import Hyper.Class.Nodes (HNodes, HWitness (..)) 8 | import Hyper.Type (type (#)) 9 | 10 | import Hyper.Internal.Prelude 11 | 12 | -- | A variant of 'Data.Pointed.Pointed' for 'Hyper.Type.HyperType's 13 | class HNodes h => HPointed h where 14 | -- | Construct a value from a generator of @h@'s nodes 15 | -- (a generator which can generate a tree of any type given a witness that it is a node of @h@) 16 | hpure :: 17 | (forall n. HWitness h n -> p # n) -> 18 | h # p 19 | 20 | instance Monoid a => HPointed (Const a) where 21 | {-# INLINE hpure #-} 22 | hpure _ = Const mempty 23 | 24 | instance (HPointed a, HPointed b) => HPointed (a :*: b) where 25 | {-# INLINE hpure #-} 26 | hpure f = hpure (f . HWitness . L1) :*: hpure (f . HWitness . R1) 27 | -------------------------------------------------------------------------------- /src/Hyper/Class/Recursive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | -- | Classes applying on 'HyperType's recursively 5 | module Hyper.Class.Recursive 6 | ( Recursive (..) 7 | , Recursively (..) 8 | , RNodes (..) 9 | , RTraversable (..) 10 | , RecMethod 11 | , DefRecMethod 12 | , proxyArgument 13 | ) where 14 | 15 | import Hyper.Class.Foldable 16 | import Hyper.Class.Functor (HFunctor (..)) 17 | import Hyper.Class.Nodes (HNodes (..)) 18 | import Hyper.Class.Traversable 19 | import Hyper.Type 20 | import Hyper.Type.Pure (Pure (..)) 21 | 22 | import Hyper.Internal.Prelude 23 | 24 | -- | A class of constraint constructors that apply to all recursive child nodes 25 | class Recursive c where 26 | -- | Lift a recursive constraint to the next layer 27 | recurse :: (HNodes h, c h) => proxy (c h) -> Dict (HNodesConstraint h c) 28 | 29 | type RecMethod c h = Proxy h -> Dict (HNodesConstraint h c) 30 | type DefRecMethod c h = HNodesConstraint h c => RecMethod c h 31 | 32 | -- | A class of 'HyperType's which recursively implement 'HNodes' 33 | class HNodes h => RNodes h where 34 | recursiveHNodes :: RecMethod RNodes h 35 | {-# INLINE recursiveHNodes #-} 36 | default recursiveHNodes :: DefRecMethod RNodes h 37 | recursiveHNodes _ = Dict 38 | 39 | instance RNodes Pure 40 | instance RNodes (Const a) 41 | 42 | -- | Helper Proxy combinator that is useful in many instances of 'Recursive' 43 | proxyArgument :: proxy (f h :: Constraint) -> Proxy (h :: HyperType) 44 | proxyArgument _ = Proxy 45 | 46 | instance Recursive RNodes where 47 | {-# INLINE recurse #-} 48 | recurse = recursiveHNodes . proxyArgument 49 | 50 | -- | A constraint lifted to apply recursively. 51 | -- 52 | -- Note that in cases where a constraint has dependencies other than 'RNodes', 53 | -- one will want to create a class such as RTraversable to capture the dependencies, 54 | -- otherwise using it in class contexts will be quite unergonomic. 55 | class RNodes h => Recursively c h where 56 | recursively :: proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c)) 57 | {-# INLINE recursively #-} 58 | default recursively :: 59 | (c h, HNodesConstraint h (Recursively c)) => 60 | proxy (c h) -> 61 | Dict (c h, HNodesConstraint h (Recursively c)) 62 | recursively _ = Dict 63 | 64 | instance Recursive (Recursively c) where 65 | {-# INLINE recurse #-} 66 | recurse p = 67 | Dict \\ recursively (p0 p) 68 | where 69 | p0 :: proxy (Recursively c h) -> Proxy (c h) 70 | p0 _ = Proxy 71 | 72 | instance c Pure => Recursively c Pure 73 | instance c (Const a) => Recursively c (Const a) 74 | 75 | -- | A class of 'HyperType's which recursively implement 'HTraversable' 76 | class (HTraversable h, Recursively HFunctor h, Recursively HFoldable h) => RTraversable h where 77 | recursiveHTraversable :: RecMethod RTraversable h 78 | {-# INLINE recursiveHTraversable #-} 79 | default recursiveHTraversable :: DefRecMethod RTraversable h 80 | recursiveHTraversable _ = Dict 81 | 82 | instance RTraversable Pure 83 | instance RTraversable (Const a) 84 | 85 | instance Recursive RTraversable where 86 | {-# INLINE recurse #-} 87 | recurse = recursiveHTraversable . proxyArgument 88 | -------------------------------------------------------------------------------- /src/Hyper/Class/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A variant of 'Traversable' for 'Hyper.Type.HyperType's 4 | module Hyper.Class.Traversable 5 | ( HTraversable (..) 6 | , ContainedH (..) 7 | , _ContainedH 8 | , htraverse 9 | , htraverse1 10 | ) where 11 | 12 | import Control.Lens (iso) 13 | import GHC.Generics 14 | import GHC.Generics.Lens (generic1, _M1, _Rec1) 15 | import Hyper.Class.Foldable (HFoldable) 16 | import Hyper.Class.Functor (HFunctor (..), hmapped1) 17 | import Hyper.Class.Nodes (HNodes (..), HWitness) 18 | import Hyper.Type (AHyperType, type (#)) 19 | 20 | import Hyper.Internal.Prelude 21 | 22 | -- | A 'Hyper.Type.HyperType' containing a tree inside an action. 23 | -- 24 | -- Used to express 'hsequence'. 25 | newtype ContainedH f p (h :: AHyperType) = MkContainedH {runContainedH :: f (p h)} 26 | 27 | -- | An 'Iso' for the 'ContainedH' @newtype@ 28 | {-# INLINE _ContainedH #-} 29 | _ContainedH :: 30 | Iso 31 | (ContainedH f0 p0 # k0) 32 | (ContainedH f1 p1 # k1) 33 | (f0 (p0 # k0)) 34 | (f1 (p1 # k1)) 35 | _ContainedH = iso runContainedH MkContainedH 36 | 37 | -- | A variant of 'Traversable' for 'Hyper.Type.HyperType's 38 | class (HFunctor h, HFoldable h) => HTraversable h where 39 | -- | 'HTraversable' variant of 'sequenceA' 40 | hsequence :: 41 | Applicative f => 42 | h # ContainedH f p -> 43 | f (h # p) 44 | {-# INLINE hsequence #-} 45 | default hsequence :: 46 | (Generic1 h, HTraversable (Rep1 h), Applicative f) => 47 | h # ContainedH f p -> 48 | f (h # p) 49 | hsequence = generic1 hsequence 50 | 51 | instance HTraversable (Const a) where 52 | {-# INLINE hsequence #-} 53 | hsequence (Const x) = pure (Const x) 54 | 55 | instance (HTraversable a, HTraversable b) => HTraversable (a :*: b) where 56 | {-# INLINE hsequence #-} 57 | hsequence (x :*: y) = (:*:) <$> hsequence x <*> hsequence y 58 | 59 | instance (HTraversable a, HTraversable b) => HTraversable (a :+: b) where 60 | {-# INLINE hsequence #-} 61 | hsequence (L1 x) = hsequence x <&> L1 62 | hsequence (R1 x) = hsequence x <&> R1 63 | 64 | instance HTraversable h => HTraversable (M1 i m h) where 65 | {-# INLINE hsequence #-} 66 | hsequence = _M1 hsequence 67 | 68 | instance HTraversable h => HTraversable (Rec1 h) where 69 | {-# INLINE hsequence #-} 70 | hsequence = _Rec1 hsequence 71 | 72 | -- | 'HTraversable' variant of 'traverse' 73 | {-# INLINE htraverse #-} 74 | htraverse :: 75 | (Applicative f, HTraversable h) => 76 | (forall n. HWitness h n -> p # n -> f (q # n)) -> 77 | h # p -> 78 | f (h # q) 79 | htraverse f = hsequence . hmap (fmap MkContainedH . f) 80 | 81 | -- | 'HTraversable' variant of 'traverse' for 'Hyper.Type.HyperType's with a single node type. 82 | -- 83 | -- It is a valid 'Traversal' as it avoids using @RankNTypes@. 84 | {-# INLINE htraverse1 #-} 85 | htraverse1 :: 86 | (HTraversable h, HNodesConstraint h ((~) n)) => 87 | Traversal (h # p) (h # q) (p # n) (q # n) 88 | htraverse1 f = hsequence . (hmapped1 %~ MkContainedH . f) 89 | -------------------------------------------------------------------------------- /src/Hyper/Class/Unify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A class for unification 4 | module Hyper.Class.Unify 5 | ( Unify (..) 6 | , UVarOf 7 | , UnifyGen (..) 8 | , BindingDict (..) 9 | , applyBindings 10 | , semiPruneLookup 11 | , occursError 12 | ) where 13 | 14 | import Control.Monad (unless) 15 | import Control.Monad.Error.Class (MonadError (..)) 16 | import Control.Monad.Trans.Class (MonadTrans (..)) 17 | import Control.Monad.Trans.State (get, put, runStateT) 18 | import Data.Kind (Type) 19 | import Hyper.Class.Nodes (HNodes (..), (#>)) 20 | import Hyper.Class.Optic (HSubset (..), HSubset') 21 | import Hyper.Class.Recursive 22 | import Hyper.Class.Traversable (htraverse) 23 | import Hyper.Class.ZipMatch (ZipMatch) 24 | import Hyper.Type (HyperType, type (#)) 25 | import Hyper.Type.Pure (Pure, _Pure) 26 | import Hyper.Unify.Constraints 27 | import Hyper.Unify.Error (UnifyError (..)) 28 | import Hyper.Unify.QuantifiedVar (HasQuantifiedVar (..), MonadQuantify (..)) 29 | import Hyper.Unify.Term (UTerm (..), UTermBody (..), uBody) 30 | 31 | import Hyper.Internal.Prelude 32 | 33 | -- | Unification variable type for a unification monad 34 | type family UVarOf (m :: Type -> Type) :: HyperType 35 | 36 | -- | BindingDict implements unification variables for a type in a unification monad. 37 | -- 38 | -- It is parameterized on: 39 | -- 40 | -- * @v@: The unification variable 'HyperType' 41 | -- * @m@: The 'Monad' to bind in 42 | -- * @t@: The unified term's 'HyperType' 43 | -- 44 | -- Has 2 implementations in hypertypes: 45 | -- 46 | -- * 'Hyper.Unify.Binding.bindingDict' for pure state based unification 47 | -- * 'Hyper.Unify.Binding.ST.stBinding' for 'Control.Monad.ST.ST' based unification 48 | data BindingDict v m t = BindingDict 49 | { lookupVar :: !(v # t -> m (UTerm v # t)) 50 | , newVar :: !(UTerm v # t -> m (v # t)) 51 | , bindVar :: !(v # t -> UTerm v # t -> m ()) 52 | } 53 | 54 | -- | @Unify m t@ enables 'Hyper.Unify.unify' to perform unification for @t@ in the 'Monad' @m@. 55 | -- 56 | -- The 'unifyRecursive' method represents the constraint that @Unify m@ applies to all recursive child nodes. 57 | -- It replaces context for 'Unify' to avoid @UndecidableSuperClasses@. 58 | class 59 | ( Eq (UVarOf m # t) 60 | , RTraversable t 61 | , ZipMatch t 62 | , HasTypeConstraints t 63 | , HasQuantifiedVar t 64 | , Monad m 65 | , MonadQuantify (TypeConstraintsOf t) (QVar t) m 66 | ) => 67 | Unify m t 68 | where 69 | -- | The implementation for unification variables binding and lookup 70 | binding :: BindingDict (UVarOf m) m t 71 | 72 | -- | Handles a unification error. 73 | -- 74 | -- If 'unifyError' is called then unification has failed. 75 | -- A compiler implementation may present an error message based on the provided 'UnifyError' when this occurs. 76 | unifyError :: UnifyError t # UVarOf m -> m a 77 | default unifyError :: 78 | (MonadError (e # Pure) m, HSubset' e (UnifyError t)) => 79 | UnifyError t # UVarOf m -> 80 | m a 81 | unifyError e = 82 | htraverse (Proxy @(Unify m) #> applyBindings) e 83 | >>= throwError 84 | . (hSubset #) 85 | \\ unifyRecursive (Proxy @m) (Proxy @t) 86 | 87 | -- | What to do when top-levels of terms being unified do not match. 88 | -- 89 | -- Usually this will cause a 'unifyError'. 90 | -- 91 | -- Some AST terms could be equivalent despite not matching structurally, 92 | -- like record field extentions with the fields ordered differently. 93 | -- Those would override the default implementation to handle the unification of mismatching structures. 94 | structureMismatch :: 95 | (forall c. Unify m c => UVarOf m # c -> UVarOf m # c -> m (UVarOf m # c)) -> 96 | t # UVarOf m -> 97 | t # UVarOf m -> 98 | m () 99 | structureMismatch _ x y = unifyError (Mismatch x y) 100 | 101 | -- TODO: Putting documentation here causes duplication in the haddock documentation 102 | unifyRecursive :: Proxy m -> RecMethod (Unify m) t 103 | {-# INLINE unifyRecursive #-} 104 | default unifyRecursive :: HNodesConstraint t (Unify m) => Proxy m -> RecMethod (Unify m) t 105 | unifyRecursive _ _ = Dict 106 | 107 | instance Recursive (Unify m) where 108 | {-# INLINE recurse #-} 109 | recurse = unifyRecursive (Proxy @m) . proxyArgument 110 | 111 | -- | A class for unification monads with scope levels 112 | class Unify m t => UnifyGen m t where 113 | -- | Get the current scope constraint 114 | scopeConstraints :: Proxy t -> m (TypeConstraintsOf t) 115 | 116 | unifyGenRecursive :: Proxy m -> RecMethod (UnifyGen m) t 117 | {-# INLINE unifyGenRecursive #-} 118 | default unifyGenRecursive :: 119 | HNodesConstraint t (UnifyGen m) => Proxy m -> RecMethod (UnifyGen m) t 120 | unifyGenRecursive _ _ = Dict 121 | 122 | instance Recursive (UnifyGen m) where 123 | {-# INLINE recurse #-} 124 | recurse = unifyGenRecursive (Proxy @m) . proxyArgument 125 | 126 | -- | Look up a variable, and return last variable pointing to result. 127 | -- Prunes all variables on way to point to the last variable 128 | -- (path-compression ala union-find). 129 | {-# INLINE semiPruneLookup #-} 130 | semiPruneLookup :: 131 | Unify m t => 132 | UVarOf m # t -> 133 | m (UVarOf m # t, UTerm (UVarOf m) # t) 134 | semiPruneLookup v0 = 135 | lookupVar binding v0 136 | >>= \case 137 | UToVar v1 -> 138 | do 139 | (v, r) <- semiPruneLookup v1 140 | bindVar binding v0 (UToVar v) 141 | pure (v, r) 142 | t -> pure (v0, t) 143 | 144 | -- | Resolve a term from a unification variable. 145 | -- 146 | -- Note that this must be done after 147 | -- all unifications involving the term and its children are done, 148 | -- as it replaces unification state with cached resolved terms. 149 | {-# INLINE applyBindings #-} 150 | applyBindings :: 151 | forall m t. 152 | Unify m t => 153 | UVarOf m # t -> 154 | m (Pure # t) 155 | applyBindings v0 = 156 | do 157 | (v1, x) <- semiPruneLookup v0 158 | let result r = r <$ bindVar binding v1 (UResolved r) 159 | let quantify c = 160 | newQuantifiedVariable c 161 | <&> (_Pure . quantifiedVar #) 162 | >>= result 163 | case x of 164 | UResolving t -> occursError v1 t 165 | UResolved t -> pure t 166 | UUnbound c -> quantify c 167 | USkolem c -> quantify c 168 | UTerm b -> 169 | do 170 | (r, anyChild) <- 171 | htraverse 172 | ( Proxy @(Unify m) #> 173 | \c -> 174 | do 175 | get >>= lift . (`unless` bindVar binding v1 (UResolving b)) 176 | put True 177 | applyBindings c & lift 178 | ) 179 | (b ^. uBody) 180 | & (`runStateT` False) 181 | \\ unifyRecursive (Proxy @m) (Proxy @t) 182 | _Pure # r & if anyChild then result else pure 183 | UToVar{} -> error "lookup not expected to result in var" 184 | UConverted{} -> error "conversion state not expected in applyBindings" 185 | UInstantiated{} -> 186 | -- This can happen in alphaEq, 187 | -- where UInstantiated marks that var from one side matches var in the other. 188 | quantify mempty 189 | 190 | -- | Format and throw an occurs check error 191 | occursError :: 192 | Unify m t => 193 | UVarOf m # t -> 194 | UTermBody (UVarOf m) # t -> 195 | m a 196 | occursError v (UTermBody c b) = 197 | do 198 | q <- newQuantifiedVariable c 199 | bindVar binding v (UResolved (_Pure . quantifiedVar # q)) 200 | unifyError (Occurs (quantifiedVar # q) b) 201 | -------------------------------------------------------------------------------- /src/Hyper/Class/ZipMatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | A class to match term structures 4 | module Hyper.Class.ZipMatch 5 | ( ZipMatch (..) 6 | , zipMatch2 7 | , zipMatchA 8 | , zipMatch_ 9 | , zipMatch1_ 10 | ) where 11 | 12 | import GHC.Generics 13 | import GHC.Generics.Lens (generic1) 14 | import Hyper.Class.Foldable (HFoldable, htraverse1_, htraverse_) 15 | import Hyper.Class.Functor (HFunctor (..)) 16 | import Hyper.Class.Nodes (HNodes (..), HWitness) 17 | import Hyper.Class.Traversable (HTraversable, htraverse) 18 | import Hyper.Type (type (#)) 19 | import Hyper.Type.Pure (Pure (..), _Pure) 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | -- | A class to match term structures. 24 | -- 25 | -- Similar to a partial version of 'Hyper.Class.Apply.Apply' but the semantics are different - 26 | -- when the terms contain plain values, 'Hyper.Class.Apply.hzip' would append them, 27 | -- but 'zipMatch' would compare them and only produce a result if they match. 28 | -- 29 | -- The @TemplateHaskell@ generators 'Hyper.TH.Apply.makeHApply' and 'Hyper.TH.ZipMatch.makeZipMatch' 30 | -- create the instances according to these semantics. 31 | class ZipMatch h where 32 | -- | Compare two structures 33 | -- 34 | -- >>> zipMatch (NewPerson p0) (NewPerson p1) 35 | -- Just (NewPerson (Pair p0 p1)) 36 | -- >>> zipMatch (NewPerson p) (NewCake c) 37 | -- Nothing 38 | zipMatch :: h # p -> h # q -> Maybe (h # (p :*: q)) 39 | default zipMatch :: 40 | (Generic1 h, ZipMatch (Rep1 h)) => 41 | h # p -> 42 | h # q -> 43 | Maybe (h # (p :*: q)) 44 | zipMatch = generic1 . zipMatch . from1 45 | 46 | instance ZipMatch Pure where 47 | {-# INLINE zipMatch #-} 48 | zipMatch (Pure x) (Pure y) = _Pure # (x :*: y) & Just 49 | 50 | instance Eq a => ZipMatch (Const a) where 51 | {-# INLINE zipMatch #-} 52 | zipMatch (Const x) (Const y) = Const x <$ guard (x == y) 53 | 54 | instance (ZipMatch a, ZipMatch b) => ZipMatch (a :*: b) where 55 | {-# INLINE zipMatch #-} 56 | zipMatch (a0 :*: b0) (a1 :*: b1) = (:*:) <$> zipMatch a0 a1 <*> zipMatch b0 b1 57 | 58 | instance (ZipMatch a, ZipMatch b) => ZipMatch (a :+: b) where 59 | {-# INLINE zipMatch #-} 60 | zipMatch (L1 x) (L1 y) = zipMatch x y <&> L1 61 | zipMatch (R1 x) (R1 y) = zipMatch x y <&> R1 62 | zipMatch L1{} R1{} = Nothing 63 | zipMatch R1{} L1{} = Nothing 64 | 65 | deriving newtype instance ZipMatch h => ZipMatch (M1 i m h) 66 | deriving newtype instance ZipMatch h => ZipMatch (Rec1 h) 67 | 68 | -- | 'ZipMatch' variant of 'Control.Applicative.liftA2' 69 | {-# INLINE zipMatch2 #-} 70 | zipMatch2 :: 71 | (ZipMatch h, HFunctor h) => 72 | (forall n. HWitness h n -> p # n -> q # n -> r # n) -> 73 | h # p -> 74 | h # q -> 75 | Maybe (h # r) 76 | zipMatch2 f x y = zipMatch x y <&> hmap (\w (a :*: b) -> f w a b) 77 | 78 | -- | An 'Applicative' variant of 'zipMatch2' 79 | {-# INLINE zipMatchA #-} 80 | zipMatchA :: 81 | (Applicative f, ZipMatch h, HTraversable h) => 82 | (forall n. HWitness h n -> p # n -> q # n -> f (r # n)) -> 83 | h # p -> 84 | h # q -> 85 | Maybe (f (h # r)) 86 | zipMatchA f x y = zipMatch x y <&> htraverse (\w (a :*: b) -> f w a b) 87 | 88 | -- | A variant of 'zipMatchA' where the 'Applicative' actions do not contain results 89 | {-# INLINE zipMatch_ #-} 90 | zipMatch_ :: 91 | (Applicative f, ZipMatch h, HFoldable h) => 92 | (forall n. HWitness h n -> p # n -> q # n -> f ()) -> 93 | h # p -> 94 | h # q -> 95 | Maybe (f ()) 96 | zipMatch_ f x y = zipMatch x y <&> htraverse_ (\w (a :*: b) -> f w a b) 97 | 98 | -- | A variant of 'zipMatch_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@) 99 | {-# INLINE zipMatch1_ #-} 100 | zipMatch1_ :: 101 | (Applicative f, ZipMatch h, HFoldable h, HNodesConstraint h ((~) n)) => 102 | (p # n -> q # n -> f ()) -> 103 | h # p -> 104 | h # q -> 105 | Maybe (f ()) 106 | zipMatch1_ f x y = zipMatch x y <&> htraverse1_ (\(a :*: b) -> f a b) 107 | -------------------------------------------------------------------------------- /src/Hyper/Combinator/ANode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | -- | A simple 'Hyper.Type.HyperType' with a single child node 6 | module Hyper.Combinator.ANode 7 | ( ANode (..) 8 | , _ANode 9 | , W_ANode (..) 10 | , MorphWitness (..) 11 | ) where 12 | 13 | import Control.Lens (iso) 14 | import Hyper.Class.Morph (HMorph (..)) 15 | import Hyper.Class.Optic (HNodeLens (..)) 16 | import Hyper.Class.Recursive (RNodes, RTraversable, Recursively) 17 | import Hyper.TH.Traversable (makeHTraversableApplyAndBases) 18 | import Hyper.Type (type (#), type (:#)) 19 | 20 | import Hyper.Internal.Prelude 21 | 22 | -- | @ANode c@ is a 'Hyper.Type.HyperType' with a single child node of type @c@ 23 | newtype ANode c h = MkANode (h :# c) 24 | deriving stock (Generic) 25 | 26 | -- | An 'Iso' from 'ANode' its child node. 27 | -- 28 | -- Using `_ANode` rather than the 'MkANode' data constructor is recommended, 29 | -- because it helps the type inference know that @ANode c@ is parameterized with a 'Hyper.Type.HyperType'. 30 | {-# INLINE _ANode #-} 31 | _ANode :: Iso (ANode c0 # k0) (ANode c1 # k1) (k0 # c0) (k1 # c1) 32 | _ANode = iso (\(MkANode x) -> x) MkANode 33 | 34 | makeHTraversableApplyAndBases ''ANode 35 | makeCommonInstances [''ANode] 36 | 37 | instance HNodeLens (ANode c) c where hNodeLens = _ANode 38 | 39 | instance RNodes n => RNodes (ANode n) 40 | instance (c (ANode n), Recursively c n) => Recursively c (ANode n) 41 | instance RTraversable n => RTraversable (ANode n) 42 | 43 | instance HMorph (ANode a) (ANode b) where 44 | type MorphConstraint (ANode a) (ANode b) c = c a b 45 | data MorphWitness (ANode a) (ANode b) _ _ where 46 | M_ANode :: MorphWitness (ANode a) (ANode b) a b 47 | morphMap f = _ANode %~ f M_ANode 48 | morphLiftConstraint M_ANode _ x = x 49 | -------------------------------------------------------------------------------- /src/Hyper/Combinator/Ann.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Combinator.Ann 7 | ( Ann (..) 8 | , hAnn 9 | , hVal 10 | , Annotated 11 | , annotation 12 | , annValue 13 | ) where 14 | 15 | import Control.Lens (Lens, Lens', from, _Wrapped) 16 | import Hyper.Class.Foldable (HFoldable (..)) 17 | import Hyper.Class.Functor (HFunctor (..)) 18 | import Hyper.Class.Nodes 19 | import Hyper.Class.Traversable 20 | import Hyper.Combinator.Flip 21 | import Hyper.Recurse 22 | import Hyper.TH.Traversable (makeHTraversableApplyAndBases) 23 | import Hyper.Type (type (#), type (:#)) 24 | 25 | import Hyper.Internal.Prelude 26 | 27 | data Ann a h = Ann 28 | { _hAnn :: a h 29 | , _hVal :: h :# Ann a 30 | } 31 | deriving (Generic) 32 | makeLenses ''Ann 33 | 34 | makeHTraversableApplyAndBases ''Ann 35 | makeCommonInstances [''Ann] 36 | 37 | instance RNodes h => HNodes (HFlip Ann h) where 38 | type HNodesConstraint (HFlip Ann h) c = (Recursive c, c h) 39 | type HWitnessType (HFlip Ann h) = HRecWitness h 40 | hLiftConstraint (HWitness HRecSelf) = \_ x -> x 41 | hLiftConstraint (HWitness (HRecSub w0 w1)) = hLiftConstraintH w0 w1 42 | 43 | -- TODO: Dedup this and similar code in Hyper.Unify.Generalize 44 | hLiftConstraintH :: 45 | forall a c b n r. 46 | (RNodes a, HNodesConstraint (HFlip Ann a) c) => 47 | HWitness a b -> 48 | HRecWitness b n -> 49 | Proxy c -> 50 | (c n => r) -> 51 | r 52 | hLiftConstraintH c n p f = 53 | hLiftConstraint 54 | c 55 | (Proxy @RNodes) 56 | ( hLiftConstraint 57 | c 58 | p 59 | (hLiftConstraint (HWitness @(HFlip Ann _) n) p f) 60 | \\ recurse (Proxy @(c a)) 61 | ) 62 | \\ recurse (Proxy @(RNodes a)) 63 | 64 | instance RNodes a => RNodes (Ann a) where 65 | {-# INLINE recursiveHNodes #-} 66 | recursiveHNodes _ = Dict \\ recursiveHNodes (Proxy @a) 67 | 68 | instance (c (Ann a), Recursively c a) => Recursively c (Ann a) where 69 | {-# INLINE recursively #-} 70 | recursively _ = Dict \\ recursively (Proxy @(c a)) 71 | 72 | instance RTraversable a => RTraversable (Ann a) where 73 | {-# INLINE recursiveHTraversable #-} 74 | recursiveHTraversable _ = Dict \\ recursiveHTraversable (Proxy @a) 75 | 76 | instance Recursively HFunctor h => HFunctor (HFlip Ann h) where 77 | {-# INLINE hmap #-} 78 | hmap f = 79 | _HFlip 80 | %~ \(Ann a b) -> 81 | Ann 82 | (f (HWitness HRecSelf) a) 83 | ( hmap 84 | ( Proxy @(Recursively HFunctor) #*# 85 | \w -> from _HFlip %~ hmap (f . HWitness . HRecSub w . (^. _HWitness)) 86 | ) 87 | b 88 | \\ recursively (Proxy @(HFunctor h)) 89 | ) 90 | 91 | instance Recursively HFoldable h => HFoldable (HFlip Ann h) where 92 | {-# INLINE hfoldMap #-} 93 | hfoldMap f (MkHFlip (Ann a b)) = 94 | f (HWitness HRecSelf) a 95 | <> hfoldMap 96 | ( Proxy @(Recursively HFoldable) #*# 97 | \w -> hfoldMap (f . HWitness . HRecSub w . (^. _HWitness)) . MkHFlip 98 | ) 99 | b 100 | \\ recursively (Proxy @(HFoldable h)) 101 | 102 | instance RTraversable h => HTraversable (HFlip Ann h) where 103 | {-# INLINE hsequence #-} 104 | hsequence = 105 | _HFlip 106 | ( \(Ann a b) -> 107 | Ann 108 | <$> runContainedH a 109 | <*> htraverse (Proxy @RTraversable #> from _HFlip hsequence) b 110 | \\ recurse (Proxy @(RTraversable h)) 111 | ) 112 | 113 | type Annotated a = Ann (Const a) 114 | 115 | annotation :: Lens' (Annotated a # h) a 116 | annotation = hAnn . _Wrapped 117 | 118 | -- | Polymorphic lens to an @Annotated@ value 119 | annValue :: Lens (Annotated a # h0) (Annotated a # h1) (h0 # Annotated a) (h1 # Annotated a) 120 | annValue f (Ann (Const a) b) = f b <&> Ann (Const a) 121 | -------------------------------------------------------------------------------- /src/Hyper/Combinator/Flip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | -- | A combinator to flip the order of the last two type parameters of a 'Hyper.Type.HyperType'. 6 | module Hyper.Combinator.Flip 7 | ( HFlip (..) 8 | , _HFlip 9 | , hflipped 10 | , htraverseFlipped 11 | ) where 12 | 13 | import Control.Lens (from, iso) 14 | import Hyper.Class.Nodes (HWitness) 15 | import Hyper.Class.Traversable (HTraversable, htraverse) 16 | import Hyper.Type (GetHyperType, type (#)) 17 | 18 | import Hyper.Internal.Prelude 19 | 20 | -- | Flip the order of the last two type parameters of a 'Hyper.Type.HyperType'. 21 | -- 22 | -- Useful to use instances of classes such as 'Hyper.Class.Traversable.HTraversable' which 23 | -- are available on the flipped 'Hyper.Type.HyperType'. 24 | -- For example 'Hyper.Unify.Generalize.GTerm' has instances when flipped. 25 | newtype HFlip f x h 26 | = MkHFlip (f (GetHyperType h) # x) 27 | deriving stock (Generic) 28 | 29 | makeCommonInstances [''HFlip] 30 | 31 | -- | An 'Iso' from 'Flip' to its content. 32 | -- 33 | -- Using `_Flip` rather than the 'MkFlip' data constructor is recommended, 34 | -- because it helps the type inference know that @ANode c@ is parameterized with a 'Hyper.Type.HyperType'. 35 | _HFlip :: 36 | Iso 37 | (HFlip f0 x0 # k0) 38 | (HFlip f1 x1 # k1) 39 | (f0 k0 # x0) 40 | (f1 k1 # x1) 41 | _HFlip = iso (\(MkHFlip x) -> x) MkHFlip 42 | 43 | hflipped :: 44 | Iso 45 | (f0 k0 # x0) 46 | (f1 k1 # x1) 47 | (HFlip f0 x0 # k0) 48 | (HFlip f1 x1 # k1) 49 | hflipped = from _HFlip 50 | 51 | -- | Convinience function for traversal over second last 'HyperType' argument. 52 | htraverseFlipped :: 53 | (Applicative f, HTraversable (HFlip h a)) => 54 | (forall n. HWitness (HFlip h a) n -> p # n -> f (q # n)) -> 55 | h p # a -> 56 | f (h q # a) 57 | htraverseFlipped f = hflipped (htraverse f) 58 | -------------------------------------------------------------------------------- /src/Hyper/Combinator/Func.hs: -------------------------------------------------------------------------------- 1 | module Hyper.Combinator.Func 2 | ( HFunc (..) 3 | , _HFunc 4 | ) where 5 | 6 | import Control.Lens (Iso, iso) 7 | import Hyper.Type (HyperType, type (#)) 8 | 9 | newtype HFunc (i :: HyperType) o h = HFunc (i h -> o h) 10 | 11 | _HFunc :: 12 | Iso 13 | (HFunc i0 o0 # h0) 14 | (HFunc i1 o1 # h1) 15 | (i0 # h0 -> o0 # h0) 16 | (i1 # h1 -> o1 # h1) 17 | _HFunc = iso (\(HFunc x) -> x) HFunc 18 | -------------------------------------------------------------------------------- /src/Hyper/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hyper.Diff 6 | ( diff 7 | , Diff (..) 8 | , _CommonBody 9 | , _CommonSubTree 10 | , _Different 11 | , CommonBody (..) 12 | , anns 13 | , val 14 | , foldDiffs 15 | , diffP 16 | , DiffP (..) 17 | , _CommonBodyP 18 | , _CommonSubTreeP 19 | , _DifferentP 20 | , foldDiffsP 21 | ) where 22 | 23 | import Hyper 24 | import Hyper.Class.ZipMatch (ZipMatch (..)) 25 | import Hyper.Internal.Prelude 26 | import Hyper.Recurse 27 | 28 | -- | A 'HyperType' which represents the difference between two annotated trees. 29 | -- The annotation types also function as tokens 30 | -- to describe which of the two trees a term comes from. 31 | data Diff a b e 32 | = CommonSubTree (Ann (a :*: b) e) 33 | | CommonBody (CommonBody a b e) 34 | | Different ((Ann a :*: Ann b) e) 35 | deriving (Generic) 36 | 37 | -- | A 'HyperType' which represents two trees which have the same top-level node, 38 | -- but their children may differ. 39 | data CommonBody a b e = MkCommonBody 40 | { _anns :: (a :*: b) e 41 | , _val :: e :# Diff a b 42 | } 43 | deriving (Generic) 44 | 45 | makePrisms ''Diff 46 | makeLenses ''CommonBody 47 | 48 | -- | Compute the difference of two annotated trees. 49 | diff :: 50 | forall t a b. 51 | (Recursively ZipMatch t, RTraversable t) => 52 | Ann a # t -> 53 | Ann b # t -> 54 | Diff a b # t 55 | diff x@(Ann xA xB) y@(Ann yA yB) = 56 | case zipMatch xB yB of 57 | Nothing -> Different (x :*: y) 58 | Just match -> 59 | case htraverse (const (^? _CommonSubTree)) sub of 60 | Nothing -> MkCommonBody (xA :*: yA) sub & CommonBody 61 | Just r -> Ann (xA :*: yA) r & CommonSubTree 62 | where 63 | sub = 64 | hmap 65 | ( Proxy @(Recursively ZipMatch) #*# 66 | Proxy @RTraversable #> 67 | \(xC :*: yC) -> diff xC yC 68 | ) 69 | match 70 | \\ recurse (Proxy @(RTraversable t)) 71 | \\ recursively (Proxy @(ZipMatch t)) 72 | 73 | foldDiffs :: 74 | forall r h a b. 75 | (Monoid r, Recursively HFoldable h) => 76 | (forall n. HRecWitness h n -> Ann a # n -> Ann b # n -> r) -> 77 | Diff a b # h -> 78 | r 79 | foldDiffs _ CommonSubTree{} = mempty 80 | foldDiffs f (Different (x :*: y)) = f HRecSelf x y 81 | foldDiffs f (CommonBody (MkCommonBody _ x)) = 82 | hfoldMap 83 | ( Proxy @(Recursively HFoldable) #*# 84 | \w -> foldDiffs (f . HRecSub w) 85 | ) 86 | x 87 | \\ recursively (Proxy @(HFoldable h)) 88 | 89 | data DiffP h 90 | = CommonSubTreeP (HPlain (GetHyperType h)) 91 | | CommonBodyP (h :# DiffP) 92 | | DifferentP (HPlain (GetHyperType h)) (HPlain (GetHyperType h)) 93 | deriving (Generic) 94 | makePrisms ''DiffP 95 | 96 | diffP :: 97 | forall h. 98 | (Recursively ZipMatch h, Recursively HasHPlain h, RTraversable h) => 99 | HPlain h -> 100 | HPlain h -> 101 | DiffP # h 102 | diffP x y = 103 | diffPH (x ^. hPlain) (y ^. hPlain) 104 | \\ recursively (Proxy @(HasHPlain h)) 105 | 106 | diffPH :: 107 | forall h. 108 | (Recursively ZipMatch h, Recursively HasHPlain h, RTraversable h) => 109 | Pure # h -> 110 | Pure # h -> 111 | DiffP # h 112 | diffPH x y = 113 | case zipMatch (x ^. _Pure) (y ^. _Pure) of 114 | Nothing -> DifferentP (hPlain # x) (hPlain # y) 115 | Just match -> 116 | case htraverse_ (const ((() <$) . (^? _CommonSubTreeP))) sub of 117 | Nothing -> CommonBodyP sub 118 | Just () -> _CommonSubTreeP . hPlain # x 119 | where 120 | sub = 121 | hmap 122 | ( Proxy @(Recursively ZipMatch) #*# 123 | Proxy @(Recursively HasHPlain) #*# 124 | Proxy @RTraversable #> 125 | \(xC :*: yC) -> diffPH xC yC 126 | ) 127 | match 128 | \\ recurse (Proxy @(RTraversable h)) 129 | \\ recursively (Proxy @(ZipMatch h)) 130 | \\ recursively (Proxy @(HasHPlain h)) 131 | 132 | makeCommonInstances [''Diff, ''CommonBody, ''DiffP] 133 | 134 | foldDiffsP :: 135 | forall r h. 136 | (Monoid r, Recursively HFoldable h, Recursively HasHPlain h) => 137 | (forall n. HasHPlain n => HRecWitness h n -> HPlain n -> HPlain n -> r) -> 138 | DiffP # h -> 139 | r 140 | foldDiffsP f = 141 | \case 142 | CommonSubTreeP{} -> mempty 143 | DifferentP x y -> f HRecSelf x y 144 | CommonBodyP x -> 145 | hfoldMap 146 | ( Proxy @(Recursively HFoldable) #*# 147 | Proxy @(Recursively HasHPlain) #*# 148 | \w -> foldDiffsP (f . HRecSub w) 149 | ) 150 | x 151 | \\ recursively (Proxy @(HFoldable h)) 152 | \\ recursively (Proxy @(HasHPlain h)) 153 | -------------------------------------------------------------------------------- /src/Hyper/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Hyper.Infer 4 | ( infer 5 | , InferResultsConstraint 6 | , inferUVarsApplyBindings 7 | , module Hyper.Class.Infer 8 | , module Hyper.Class.Infer.Env 9 | , module Hyper.Class.Infer.InferOf 10 | , module Hyper.Infer.ScopeLevel 11 | , module Hyper.Infer.Result 12 | -- | Exported only for SPECIALIZE pragmas 13 | , inferH 14 | ) where 15 | 16 | import qualified Control.Lens as Lens 17 | import Hyper 18 | import Hyper.Class.Infer 19 | import Hyper.Class.Infer.Env 20 | import Hyper.Class.Infer.InferOf 21 | import Hyper.Class.Nodes (HNodesHaveConstraint (..)) 22 | import Hyper.Infer.Result 23 | import Hyper.Infer.ScopeLevel 24 | import Hyper.Unify (UVarOf, Unify, applyBindings) 25 | 26 | import Hyper.Internal.Prelude 27 | 28 | -- | Perform Hindley-Milner type inference of a term 29 | {-# INLINE infer #-} 30 | infer :: 31 | forall m t a. 32 | Infer m t => 33 | Ann a # t -> 34 | m (Ann (a :*: InferResult (UVarOf m)) # t) 35 | infer (Ann a x) = 36 | inferBody (hmap (Proxy @(Infer m) #> inferH) x) 37 | <&> (\(xI, t) -> Ann (a :*: InferResult t) xI) 38 | \\ inferContext (Proxy @m) (Proxy @t) 39 | 40 | {-# INLINE inferH #-} 41 | inferH :: 42 | Infer m t => 43 | Ann a # t -> 44 | InferChild m (Ann (a :*: InferResult (UVarOf m))) # t 45 | inferH c = infer c <&> (\i -> InferredChild i (i ^. hAnn . Lens._2 . _InferResult)) & InferChild 46 | 47 | type InferResultsConstraint c = Recursively (InferOfConstraint (HNodesHaveConstraint c)) 48 | 49 | inferUVarsApplyBindings :: 50 | forall m t a. 51 | ( Applicative m 52 | , RTraversable t 53 | , Recursively (InferOfConstraint HTraversable) t 54 | , InferResultsConstraint (Unify m) t 55 | ) => 56 | Ann (a :*: InferResult (UVarOf m)) # t -> 57 | m (Ann (a :*: InferResult (Pure :*: UVarOf m)) # t) 58 | inferUVarsApplyBindings = 59 | htraverseFlipped $ 60 | Proxy @(Recursively (InferOfConstraint HTraversable)) #*# 61 | Proxy @(InferResultsConstraint (Unify m)) #> 62 | Lens._2 f 63 | where 64 | f :: 65 | forall n. 66 | ( Recursively (InferOfConstraint HTraversable) n 67 | , InferResultsConstraint (Unify m) n 68 | ) => 69 | InferResult (UVarOf m) # n -> 70 | m (InferResult (Pure :*: UVarOf m) # n) 71 | f = 72 | htraverseFlipped (Proxy @(Unify m) #> \x -> applyBindings x <&> (:*: x)) 73 | \\ inferOfConstraint @HTraversable (Proxy @n) 74 | \\ recursively (Proxy @(InferOfConstraint HTraversable n)) 75 | \\ hNodesHaveConstraint (Proxy @(Unify m)) (Proxy @(InferOf n)) 76 | \\ inferOfConstraint @(HNodesHaveConstraint (Unify m)) (Proxy @n) 77 | \\ recursively (Proxy @(InferOfConstraint (HNodesHaveConstraint (Unify m)) n)) 78 | -------------------------------------------------------------------------------- /src/Hyper/Infer/Blame.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Hindley-Milner type inference with ergonomic blame assignment. 7 | -- 8 | -- 'blame' is a type-error blame assignment algorithm for languages with Hindley-Milner type inference, 9 | -- but __/without generalization of intermediate terms/__. 10 | -- This means that it is not suitable for languages with let-generalization. 11 | -- 'Hyper.Type.AST.Let.Let' is an example of a term that is not suitable for this algorithm. 12 | -- 13 | -- With the contemporary knowledge that 14 | -- ["Let Should Not Be Generalised"](https://www.microsoft.com/en-us/research/publication/let-should-not-be-generalised/), 15 | -- as argued by luminaries such as Simon Peyton Jones, 16 | -- optimistically this limitation shouldn't apply to new programming languages. 17 | -- This blame assignment algorithm can also be used in a limited sense for existing languages, 18 | -- which do have let-generalization, to provide better type errors 19 | -- in specific definitions which don't happen to use generalizing terms. 20 | -- 21 | -- The algorithm is pretty simple: 22 | -- 23 | -- * Invoke all the 'inferBody' calls as 'Hyper.Infer.infer' normally would, 24 | -- but with one important difference: 25 | -- where 'inferBody' would normally get the actual inference results of its child nodes, 26 | -- placeholders are generated in their place 27 | -- * Globally sort all of the tree nodes according to a given node prioritization 28 | -- (this prioritization would be custom for each language) 29 | -- * According to the order of prioritization, 30 | -- attempt to unify each infer-result with its placeholder using 'inferOfUnify'. 31 | -- If a unification fails, roll back its state changes. 32 | -- The nodes whose unification failed are the ones assigned with type errors. 33 | -- 34 | -- [Lamdu](https://github.com/lamdu/lamdu) uses this algorithm for its "insist type" feature, 35 | -- which moves around the blame for type mismatches. 36 | -- 37 | -- Note: If a similar algorithm already existed somewhere, 38 | -- [I](https://github.com/yairchu/) would very much like to know! 39 | module Hyper.Infer.Blame 40 | ( blame 41 | , Blame (..) 42 | , BlameResult (..) 43 | , _Good 44 | , _Mismatch 45 | , InferOf' 46 | ) where 47 | 48 | import qualified Control.Lens as Lens 49 | import Control.Monad.Except (MonadError (..)) 50 | import Data.List (sortOn) 51 | import Hyper 52 | import Hyper.Class.Infer 53 | import Hyper.Class.Traversable (ContainedH (..)) 54 | import Hyper.Class.Unify (UVarOf, UnifyGen) 55 | import Hyper.Infer.Result 56 | import Hyper.Recurse 57 | import Hyper.Unify.New (newUnbound) 58 | import Hyper.Unify.Occurs (occursCheck) 59 | 60 | import Hyper.Internal.Prelude 61 | 62 | -- | Class implementing some primitives needed by the 'blame' algorithm 63 | -- 64 | -- The 'blamableRecursive' method represents that 'Blame' applies to all recursive child nodes. 65 | -- It replaces context for 'Blame' to avoid @UndecidableSuperClasses@. 66 | class 67 | (Infer m t, RTraversable t, HTraversable (InferOf t), HPointed (InferOf t)) => 68 | Blame m t 69 | where 70 | -- | Unify the types/values in infer results 71 | inferOfUnify :: 72 | Proxy t -> 73 | InferOf t # UVarOf m -> 74 | InferOf t # UVarOf m -> 75 | m () 76 | 77 | -- | Check whether two infer results are the same 78 | inferOfMatches :: 79 | Proxy t -> 80 | InferOf t # UVarOf m -> 81 | InferOf t # UVarOf m -> 82 | m Bool 83 | 84 | -- TODO: Putting documentation here causes duplication in the haddock documentation 85 | blamableRecursive :: Proxy m -> RecMethod (Blame m) t 86 | {-# INLINE blamableRecursive #-} 87 | default blamableRecursive :: HNodesConstraint t (Blame m) => Proxy m -> RecMethod (Blame m) t 88 | blamableRecursive _ _ = Dict 89 | 90 | instance Recursive (Blame m) where 91 | recurse = blamableRecursive (Proxy @m) . proxyArgument 92 | 93 | -- | A type synonym to help 'BlameResult' be more succinct 94 | type InferOf' e v = InferOf (GetHyperType e) # v 95 | 96 | prepareH :: 97 | forall m exp a. 98 | Blame m exp => 99 | Ann a # exp -> 100 | m (Ann (a :*: InferResult (UVarOf m) :*: InferResult (UVarOf m)) # exp) 101 | prepareH t = 102 | hpure (Proxy @(UnifyGen m) #> MkContainedH newUnbound) 103 | & hsequence 104 | >>= (`prepare` t) 105 | \\ inferContext (Proxy @m) (Proxy @exp) 106 | 107 | prepare :: 108 | forall m exp a. 109 | Blame m exp => 110 | InferOf exp # UVarOf m -> 111 | Ann a # exp -> 112 | m (Ann (a :*: InferResult (UVarOf m) :*: InferResult (UVarOf m)) # exp) 113 | prepare resFromPosition (Ann a x) = 114 | hmap 115 | ( Proxy @(Blame m) #> 116 | InferChild . fmap (\t -> InferredChild t (t ^. hAnn . Lens._2 . Lens._1 . _InferResult)) . prepareH 117 | ) 118 | x 119 | \\ recurse (Proxy @(Blame m exp)) 120 | & inferBody 121 | <&> \(xI, r) -> 122 | Ann (a :*: InferResult resFromPosition :*: InferResult r) xI 123 | 124 | tryUnify :: 125 | forall err m top exp. 126 | (MonadError err m, Blame m exp) => 127 | HWitness top exp -> 128 | InferOf exp # UVarOf m -> 129 | InferOf exp # UVarOf m -> 130 | m () 131 | tryUnify _ i0 i1 = 132 | do 133 | inferOfUnify (Proxy @exp) i0 i1 134 | htraverse_ (Proxy @(UnifyGen m) #> occursCheck) i0 135 | \\ inferContext (Proxy @m) (Proxy @exp) 136 | & (`catchError` const (pure ())) 137 | 138 | data BlameResult v e 139 | = Good (InferOf' e v) 140 | | Mismatch (InferOf' e v, InferOf' e v) 141 | deriving (Generic) 142 | makePrisms ''BlameResult 143 | makeCommonInstances [''BlameResult] 144 | 145 | finalize :: 146 | forall a m exp. 147 | Blame m exp => 148 | Ann (a :*: InferResult (UVarOf m) :*: InferResult (UVarOf m)) # exp -> 149 | m (Ann (a :*: BlameResult (UVarOf m)) # exp) 150 | finalize (Ann (a :*: InferResult i0 :*: InferResult i1) x) = 151 | do 152 | match <- inferOfMatches (Proxy @exp) i0 i1 153 | let result 154 | | match = Good i0 155 | | otherwise = Mismatch (i0, i1) 156 | htraverse (Proxy @(Blame m) #> finalize) x 157 | <&> Ann (a :*: result) 158 | \\ recurse (Proxy @(Blame m exp)) 159 | 160 | -- | Perform Hindley-Milner type inference with prioritised blame for type error, 161 | -- given a prioritisation for the different nodes. 162 | -- 163 | -- The purpose of the prioritisation is to place the errors in nodes where 164 | -- the resulting errors will be easier to understand. 165 | -- 166 | -- The expected `MonadError` behavior is that catching errors rolls back their state changes 167 | -- (i.e @StateT s (Either e)@ is suitable but @EitherT e (State s)@ is not) 168 | -- 169 | -- Gets the top-level type for the term for support of recursive definitions, 170 | -- where the top-level type of the term may be in the scope of the inference monad. 171 | blame :: 172 | forall priority err m exp a. 173 | ( Ord priority 174 | , MonadError err m 175 | , Blame m exp 176 | ) => 177 | (forall n. a # n -> priority) -> 178 | InferOf exp # UVarOf m -> 179 | Ann a # exp -> 180 | m (Ann (a :*: BlameResult (UVarOf m)) # exp) 181 | blame order topLevelType e = 182 | do 183 | p <- prepare topLevelType e 184 | hfoldMap 185 | ( Proxy @(Blame m) #*# 186 | \w (a :*: InferResult i0 :*: InferResult i1) -> 187 | [(order a, tryUnify w i0 i1)] 188 | ) 189 | (_HFlip # p) 190 | & sortOn fst 191 | & traverse_ snd 192 | finalize p 193 | -------------------------------------------------------------------------------- /src/Hyper/Infer/Result.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Infer.Result 7 | ( InferResult (..) 8 | , _InferResult 9 | , inferResult 10 | ) where 11 | 12 | import Hyper 13 | import Hyper.Class.Infer 14 | import Hyper.Internal.Prelude 15 | 16 | -- | A 'HyperType' for an inferred term - the output of 'Hyper.Infer.infer' 17 | newtype InferResult v e 18 | = InferResult (InferOf (GetHyperType e) # v) 19 | deriving stock (Generic) 20 | 21 | makePrisms ''InferResult 22 | makeCommonInstances [''InferResult] 23 | 24 | -- An iso for the common case where the infer result of a term is a single value. 25 | inferResult :: 26 | InferOf e ~ ANode t => 27 | Iso 28 | (InferResult v0 # e) 29 | (InferResult v1 # e) 30 | (v0 # t) 31 | (v1 # t) 32 | inferResult = _InferResult . _ANode 33 | 34 | instance HNodes (InferOf e) => HNodes (HFlip InferResult e) where 35 | type HNodesConstraint (HFlip InferResult e) c = HNodesConstraint (InferOf e) c 36 | type HWitnessType (HFlip InferResult e) = HWitnessType (InferOf e) 37 | hLiftConstraint (HWitness w) = hLiftConstraint (HWitness @(InferOf e) w) 38 | 39 | instance HFunctor (InferOf e) => HFunctor (HFlip InferResult e) where 40 | hmap f = _HFlip . _InferResult %~ hmap (f . HWitness . (^. _HWitness)) 41 | 42 | instance HFoldable (InferOf e) => HFoldable (HFlip InferResult e) where 43 | hfoldMap f = hfoldMap (f . HWitness . (^. _HWitness)) . (^. _HFlip . _InferResult) 44 | 45 | instance HTraversable (InferOf e) => HTraversable (HFlip InferResult e) where 46 | hsequence = (_HFlip . _InferResult) hsequence 47 | -------------------------------------------------------------------------------- /src/Hyper/Infer/ScopeLevel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Hyper.Infer.ScopeLevel 4 | ( ScopeLevel (..) 5 | , _ScopeLevel 6 | , MonadScopeLevel (..) 7 | ) where 8 | 9 | import Algebra.PartialOrd (PartialOrd (..)) 10 | import Hyper.Unify.Constraints (TypeConstraints (..)) 11 | import qualified Text.PrettyPrint as Pretty 12 | import Text.PrettyPrint.HughesPJClass (Pretty (..)) 13 | 14 | import Hyper.Internal.Prelude 15 | 16 | -- | A representation of scope nesting level, 17 | -- for use in let-generalization and skolem escape detection. 18 | -- 19 | -- See ["Efficient generalization with levels"](http://okmij.org/ftp/ML/generalization.html#levels) 20 | -- for a detailed explanation. 21 | -- 22 | -- Commonly used as the 'Hyper.Unify.Constraints.TypeConstraintsOf' of terms. 23 | -- 24 | -- /Note/: The 'Ord' instance is only for use as a 'Data.Map.Map' key, not a 25 | -- logical ordering, for which 'PartialOrd' is used. 26 | newtype ScopeLevel = ScopeLevel Int 27 | deriving stock (Eq, Ord, Show, Generic) 28 | 29 | makePrisms ''ScopeLevel 30 | 31 | instance PartialOrd ScopeLevel where 32 | {-# INLINE leq #-} 33 | ScopeLevel x `leq` ScopeLevel y = x >= y 34 | 35 | instance Semigroup ScopeLevel where 36 | {-# INLINE (<>) #-} 37 | ScopeLevel x <> ScopeLevel y = ScopeLevel (min x y) 38 | 39 | instance Monoid ScopeLevel where 40 | {-# INLINE mempty #-} 41 | mempty = ScopeLevel maxBound 42 | 43 | instance TypeConstraints ScopeLevel where 44 | {-# INLINE generalizeConstraints #-} 45 | generalizeConstraints _ = mempty 46 | toScopeConstraints = id 47 | 48 | instance Pretty ScopeLevel where 49 | pPrint (ScopeLevel x) 50 | | x == maxBound = Pretty.text "*" 51 | | otherwise = Pretty.text "scope#" <> pPrint x 52 | 53 | instance NFData ScopeLevel 54 | instance Binary ScopeLevel 55 | 56 | -- | A class of 'Monad's which maintain a scope level, 57 | -- where the level can be locally increased for computations. 58 | class Monad m => MonadScopeLevel m where 59 | localLevel :: m a -> m a 60 | -------------------------------------------------------------------------------- /src/Hyper/Internal/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | 3 | module Hyper.Internal.Prelude 4 | ( makeCommonInstances 5 | , module X 6 | ) where 7 | 8 | import Control.DeepSeq as X (NFData) 9 | import Control.Lens as X (Iso, Traversal, makeLenses, makePrisms) 10 | import Control.Lens.Operators as X 11 | import Control.Monad as X (guard, void) 12 | import Data.Binary as X (Binary) 13 | import Data.Constraint as X (Constraint, Dict (..), (\\)) 14 | import Data.Foldable as X (sequenceA_, traverse_) 15 | import Data.Functor.Const as X (Const (..)) 16 | import Data.Map as X (Map) 17 | import Data.Maybe as X (fromMaybe) 18 | import Data.Proxy as X (Proxy (..)) 19 | import Data.Set as X (Set) 20 | import GHC.Generics as X (Generic, (:*:) (..)) 21 | import Generics.Constraints (makeDerivings, makeInstances) 22 | import Language.Haskell.TH (DecsQ, Name) 23 | 24 | import Prelude.Compat as X 25 | 26 | -- Derive a specific list of classes that types in hypertypes implement. 27 | makeCommonInstances :: [Name] -> DecsQ 28 | makeCommonInstances names = 29 | (<>) 30 | <$> makeDerivings [''Eq, ''Ord, ''Show] names 31 | <*> makeInstances [''Binary, ''NFData] names 32 | -------------------------------------------------------------------------------- /src/Hyper/Recurse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | Combinators for processing/constructing trees recursively 4 | module Hyper.Recurse 5 | ( module Hyper.Class.Recursive 6 | , fold 7 | , unfold 8 | , wrap 9 | , wrapM 10 | , unwrap 11 | , unwrapM 12 | , foldMapRecursive 13 | , HRecWitness (..) 14 | , (#>>) 15 | , (#**#) 16 | , (##>>) 17 | ) where 18 | 19 | import Hyper.Class.Foldable 20 | import Hyper.Class.Functor (HFunctor (..)) 21 | import Hyper.Class.Nodes (HWitness, (#*#), (#>)) 22 | import Hyper.Class.Recursive 23 | import Hyper.Class.Traversable 24 | import Hyper.Type 25 | import Hyper.Type.Pure (Pure (..), _Pure) 26 | 27 | import Hyper.Internal.Prelude 28 | 29 | -- | @HRecWitness h n@ is a witness that @n@ is a recursive node of @h@ 30 | data HRecWitness h n where 31 | HRecSelf :: HRecWitness h h 32 | HRecSub :: HWitness h c -> HRecWitness c n -> HRecWitness h n 33 | 34 | -- | Monadically convert a 'Pure' to a different 'HyperType' from the bottom up 35 | {-# INLINE wrapM #-} 36 | wrapM :: 37 | forall m h w. 38 | (Monad m, RTraversable h) => 39 | (forall n. HRecWitness h n -> n # w -> m (w # n)) -> 40 | Pure # h -> 41 | m (w # h) 42 | wrapM f x = 43 | x ^. _Pure 44 | & htraverse (Proxy @RTraversable #*# \w -> wrapM (f . HRecSub w)) 45 | >>= f HRecSelf 46 | \\ recurse (Proxy @(RTraversable h)) 47 | 48 | -- | Monadically unwrap a tree from the top down, replacing its 'HyperType' with 'Pure' 49 | {-# INLINE unwrapM #-} 50 | unwrapM :: 51 | forall m h w. 52 | (Monad m, RTraversable h) => 53 | (forall n. HRecWitness h n -> w # n -> m (n # w)) -> 54 | w # h -> 55 | m (Pure # h) 56 | unwrapM f x = 57 | f HRecSelf x 58 | >>= htraverse (Proxy @RTraversable #*# \w -> unwrapM (f . HRecSub w)) 59 | <&> (_Pure #) 60 | \\ recurse (Proxy @(RTraversable h)) 61 | 62 | -- | Wrap a 'Pure' to a different 'HyperType' from the bottom up 63 | {-# INLINE wrap #-} 64 | wrap :: 65 | forall h w. 66 | Recursively HFunctor h => 67 | (forall n. HRecWitness h n -> n # w -> w # n) -> 68 | Pure # h -> 69 | w # h 70 | wrap f x = 71 | x ^. _Pure 72 | & hmap (Proxy @(Recursively HFunctor) #*# \w -> wrap (f . HRecSub w)) 73 | & f HRecSelf 74 | \\ recursively (Proxy @(HFunctor h)) 75 | 76 | -- | Unwrap a tree from the top down, replacing its 'HyperType' with 'Pure' 77 | {-# INLINE unwrap #-} 78 | unwrap :: 79 | forall h w. 80 | Recursively HFunctor h => 81 | (forall n. HRecWitness h n -> w # n -> n # w) -> 82 | w # h -> 83 | Pure # h 84 | unwrap f x = 85 | _Pure 86 | # hmap 87 | (Proxy @(Recursively HFunctor) #*# \w -> unwrap (f . HRecSub w)) 88 | (f HRecSelf x) 89 | \\ recursively (Proxy @(HFunctor h)) 90 | 91 | -- | Recursively fold up a tree to produce a result (aka catamorphism) 92 | {-# INLINE fold #-} 93 | fold :: 94 | Recursively HFunctor h => 95 | (forall n. HRecWitness h n -> n # Const a -> a) -> 96 | Pure # h -> 97 | a 98 | fold f = getConst . wrap (fmap Const . f) 99 | 100 | -- | Build/load a tree from a seed value (aka anamorphism) 101 | {-# INLINE unfold #-} 102 | unfold :: 103 | Recursively HFunctor h => 104 | (forall n. HRecWitness h n -> a -> n # Const a) -> 105 | a -> 106 | Pure # h 107 | unfold f = unwrap (fmap (. getConst) f) . Const 108 | 109 | -- | Fold over all of the recursive child nodes of a tree in pre-order 110 | {-# INLINE foldMapRecursive #-} 111 | foldMapRecursive :: 112 | forall h p a. 113 | (Recursively HFoldable h, Recursively HFoldable p, Monoid a) => 114 | (forall n q. HRecWitness h n -> n # q -> a) -> 115 | h # p -> 116 | a 117 | foldMapRecursive f x = 118 | f HRecSelf x 119 | <> hfoldMap 120 | ( Proxy @(Recursively HFoldable) #*# 121 | \w -> 122 | hfoldMap (Proxy @(Recursively HFoldable) #> foldMapRecursive (f . HRecSub w)) 123 | \\ recursively (Proxy @(HFoldable p)) 124 | ) 125 | x 126 | \\ recursively (Proxy @(HFoldable h)) 127 | 128 | infixr 0 #>> 129 | infixr 0 ##>> 130 | infixr 0 #**# 131 | 132 | -- | @Proxy @c #> r@ replaces a recursive witness parameter of @r@ with a constraint on the witnessed node 133 | {-# INLINE (#>>) #-} 134 | (#>>) :: 135 | forall c h n r. 136 | (Recursive c, c h, RNodes h) => 137 | Proxy c -> 138 | (c n => r) -> 139 | HRecWitness h n -> 140 | r 141 | (#>>) _ r HRecSelf = r 142 | (#>>) p r (HRecSub w0 w1) = 143 | (Proxy @RNodes #*# p #> (p #>> r) w1) w0 144 | \\ recurse (Proxy @(RNodes h)) 145 | \\ recurse (Proxy @(c h)) 146 | 147 | -- | @Proxy @c #> r@ replaces a recursive witness parameter of @r@ with a @Recursively c@ constraint on the witnessed node 148 | {-# INLINE (##>>) #-} 149 | (##>>) :: 150 | forall c h n r. 151 | Recursively c h => 152 | Proxy c -> 153 | (c n => r) -> 154 | HRecWitness h n -> 155 | r 156 | (##>>) p r = 157 | \case 158 | HRecSelf -> r 159 | HRecSub w0 w1 -> (Proxy @(Recursively c) #> (p ##>> r) w1) w0 160 | \\ recursively (Proxy @(c h)) 161 | 162 | -- | A variant of '#>>' which does not consume the witness parameter. 163 | -- 164 | -- @Proxy @c0 #**# Proxy @c1 #>> r@ brings into context both the @c0 n@ and @c1 n@ constraints. 165 | {-# INLINE (#**#) #-} 166 | (#**#) :: 167 | (Recursive c, c h, RNodes h) => 168 | Proxy c -> 169 | (c n => HRecWitness h n -> r) -> 170 | HRecWitness h n -> 171 | r 172 | (#**#) p r w = (p #>> r) w w 173 | -------------------------------------------------------------------------------- /src/Hyper/Syntax.hs: -------------------------------------------------------------------------------- 1 | -- | Common programming language syntax ingredients 2 | module Hyper.Syntax 3 | ( module X 4 | ) where 5 | 6 | import Hyper.Syntax.App as X 7 | import Hyper.Syntax.FuncType as X 8 | import Hyper.Syntax.Lam as X 9 | import Hyper.Syntax.Let as X 10 | import Hyper.Syntax.TypeSig as X 11 | import Hyper.Syntax.TypedLam as X 12 | import Hyper.Syntax.Var as X 13 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Syntax.App 7 | ( App (..) 8 | , appFunc 9 | , appArg 10 | , W_App (..) 11 | , MorphWitness (..) 12 | ) where 13 | 14 | import Hyper 15 | import Hyper.Class.Optic (HSubset (..), HSubset') 16 | import Hyper.Infer 17 | import Hyper.Syntax.FuncType 18 | import Hyper.Unify (UnifyGen, unify) 19 | import Hyper.Unify.New (newTerm, newUnbound) 20 | import Text.PrettyPrint ((<+>)) 21 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 22 | 23 | import Hyper.Internal.Prelude 24 | 25 | -- | A term for function applications. 26 | -- 27 | -- @App expr@s express function applications of @expr@s. 28 | -- 29 | -- Apart from the data type, an 'Infer' instance is also provided. 30 | data App expr h = App 31 | { _appFunc :: h :# expr 32 | , _appArg :: h :# expr 33 | } 34 | deriving (Generic) 35 | 36 | makeLenses ''App 37 | makeZipMatch ''App 38 | makeHContext ''App 39 | makeHMorph ''App 40 | makeHTraversableApplyAndBases ''App 41 | makeCommonInstances [''App] 42 | 43 | instance RNodes e => RNodes (App e) 44 | instance (c (App e), Recursively c e) => Recursively c (App e) 45 | instance RTraversable e => RTraversable (App e) 46 | 47 | instance Pretty (h :# expr) => Pretty (App expr h) where 48 | pPrintPrec lvl p (App f x) = 49 | pPrintPrec lvl 10 f 50 | <+> pPrintPrec lvl 11 x 51 | & maybeParens (p > 10) 52 | 53 | type instance InferOf (App e) = ANode (TypeOf e) 54 | 55 | instance 56 | ( Infer m expr 57 | , HasInferredType expr 58 | , HSubset' (TypeOf expr) (FuncType (TypeOf expr)) 59 | , UnifyGen m (TypeOf expr) 60 | ) => 61 | Infer m (App expr) 62 | where 63 | {-# INLINE inferBody #-} 64 | inferBody (App func arg) = 65 | do 66 | InferredChild argI argR <- inferChild arg 67 | InferredChild funcI funcR <- inferChild func 68 | funcRes <- newUnbound 69 | (App funcI argI, MkANode funcRes) 70 | <$ (newTerm (hSubset # FuncType (argR ^# l) funcRes) >>= unify (funcR ^# l)) 71 | where 72 | l = inferredType (Proxy @expr) 73 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/FuncType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hyper.Syntax.FuncType 6 | ( FuncType (..) 7 | , funcIn 8 | , funcOut 9 | , W_FuncType (..) 10 | , MorphWitness (..) 11 | ) where 12 | 13 | import Generics.Constraints (makeDerivings, makeInstances) 14 | import Hyper 15 | import Text.PrettyPrint ((<+>)) 16 | import qualified Text.PrettyPrint as Pretty 17 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 18 | import Text.Show.Combinators (showCon, (@|)) 19 | 20 | import Hyper.Internal.Prelude 21 | 22 | -- | A term for the types of functions. Analogues to @(->)@ in Haskell. 23 | -- 24 | -- @FuncType typ@s express types of functions of @typ@. 25 | data FuncType typ h = FuncType 26 | { _funcIn :: h :# typ 27 | , _funcOut :: h :# typ 28 | } 29 | deriving (Generic) 30 | 31 | makeLenses ''FuncType 32 | makeZipMatch ''FuncType 33 | makeHContext ''FuncType 34 | makeHMorph ''FuncType 35 | makeHTraversableApplyAndBases ''FuncType 36 | makeDerivings [''Eq, ''Ord] [''FuncType] 37 | makeInstances [''Binary, ''NFData] [''FuncType] 38 | 39 | instance Pretty (h :# typ) => Pretty (FuncType typ h) where 40 | pPrintPrec lvl p (FuncType i o) = 41 | pPrintPrec lvl 11 i <+> Pretty.text "->" <+> pPrintPrec lvl 10 o 42 | & maybeParens (p > 10) 43 | 44 | instance Show (h :# typ) => Show (FuncType typ h) where 45 | showsPrec p (FuncType i o) = (showCon "FuncType" @| i @| o) p 46 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/Lam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Syntax.Lam 7 | ( Lam (..) 8 | , lamIn 9 | , lamOut 10 | , W_Lam (..) 11 | , MorphWitness (..) 12 | ) where 13 | 14 | import Generics.Constraints (Constraints) 15 | import Hyper 16 | import Hyper.Class.Optic (HSubset (..), HSubset') 17 | import Hyper.Infer 18 | import Hyper.Syntax.FuncType 19 | import Hyper.Unify (UVarOf, UnifyGen) 20 | import Hyper.Unify.New (newTerm, newUnbound) 21 | import qualified Text.PrettyPrint as P 22 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 23 | 24 | import Hyper.Internal.Prelude 25 | 26 | -- | A term for lambda abstractions. 27 | -- 28 | -- @Lam v expr@s express lambda abstractions with @v@s as variable names and @expr@s for bodies. 29 | -- 30 | -- Apart from the data type, an 'Infer' instance is also provided. 31 | data Lam v expr h = Lam 32 | { _lamIn :: v 33 | , _lamOut :: h :# expr 34 | } 35 | deriving (Generic) 36 | 37 | makeLenses ''Lam 38 | makeCommonInstances [''Lam] 39 | makeHTraversableApplyAndBases ''Lam 40 | makeZipMatch ''Lam 41 | makeHContext ''Lam 42 | makeHMorph ''Lam 43 | 44 | instance RNodes t => RNodes (Lam v t) 45 | instance (c (Lam v t), Recursively c t) => Recursively c (Lam v t) 46 | instance RTraversable t => RTraversable (Lam v t) 47 | 48 | instance 49 | Constraints (Lam v expr h) Pretty => 50 | Pretty (Lam v expr h) 51 | where 52 | pPrintPrec lvl p (Lam i o) = 53 | (P.text "λ" <> pPrintPrec lvl 0 i) 54 | P.<+> P.text "→" 55 | P.<+> pPrintPrec lvl 0 o 56 | & maybeParens (p > 0) 57 | 58 | type instance InferOf (Lam _ t) = ANode (TypeOf t) 59 | 60 | instance 61 | ( Infer m t 62 | , UnifyGen m (TypeOf t) 63 | , HSubset' (TypeOf t) (FuncType (TypeOf t)) 64 | , HasInferredType t 65 | , LocalScopeType v (UVarOf m # TypeOf t) m 66 | ) => 67 | Infer m (Lam v t) 68 | where 69 | {-# INLINE inferBody #-} 70 | inferBody (Lam p r) = 71 | do 72 | varType <- newUnbound 73 | InferredChild rI rR <- inferChild r & localScopeType p varType 74 | hSubset # FuncType varType (rR ^# inferredType (Proxy @t)) 75 | & newTerm 76 | <&> (Lam p rI,) . MkANode 77 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/Let.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Syntax.Let 7 | ( Let (..) 8 | , letVar 9 | , letEquals 10 | , letIn 11 | , W_Let (..) 12 | , MorphWitness (..) 13 | ) where 14 | 15 | import Generics.Constraints (Constraints) 16 | import Hyper 17 | import Hyper.Class.Unify (UVarOf, UnifyGen) 18 | import Hyper.Infer 19 | import Hyper.Unify.Generalize (GTerm, generalize) 20 | import Text.PrettyPrint (($+$), (<+>)) 21 | import qualified Text.PrettyPrint as Pretty 22 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 23 | 24 | import Hyper.Internal.Prelude 25 | 26 | -- | A term for let-expressions with let-generalization. 27 | -- 28 | -- @Let v expr@s express let-expressions with @v@s as variable names and @expr@s for terms. 29 | -- 30 | -- Apart from the data type, an 'Infer' instance is also provided. 31 | data Let v expr h = Let 32 | { _letVar :: v 33 | , _letEquals :: h :# expr 34 | , _letIn :: h :# expr 35 | } 36 | deriving (Generic) 37 | 38 | makeLenses ''Let 39 | makeCommonInstances [''Let] 40 | makeHTraversableApplyAndBases ''Let 41 | makeZipMatch ''Let 42 | makeHContext ''Let 43 | makeHMorph ''Let 44 | 45 | instance 46 | Constraints (Let v expr h) Pretty => 47 | Pretty (Let v expr h) 48 | where 49 | pPrintPrec lvl p (Let v e i) = 50 | Pretty.text "let" 51 | <+> pPrintPrec lvl 0 v 52 | <+> Pretty.text "=" 53 | <+> pPrintPrec lvl 0 e 54 | $+$ pPrintPrec lvl 0 i 55 | & maybeParens (p > 0) 56 | 57 | type instance InferOf (Let _ e) = InferOf e 58 | 59 | instance 60 | ( MonadScopeLevel m 61 | , LocalScopeType v (GTerm (UVarOf m) # TypeOf expr) m 62 | , UnifyGen m (TypeOf expr) 63 | , HasInferredType expr 64 | , HNodesConstraint (InferOf expr) (UnifyGen m) 65 | , HTraversable (InferOf expr) 66 | , Infer m expr 67 | ) => 68 | Infer m (Let v expr) 69 | where 70 | inferBody (Let v e i) = 71 | do 72 | (eI, eG) <- 73 | do 74 | InferredChild eI eR <- inferChild e 75 | generalize (eR ^# inferredType (Proxy @expr)) 76 | <&> (eI,) 77 | & localLevel 78 | inferChild i 79 | & localScopeType v eG 80 | <&> \(InferredChild iI iR) -> (Let v eI iI, iR) 81 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Syntax.Map 7 | ( TermMap (..) 8 | , _TermMap 9 | , W_TermMap (..) 10 | , MorphWitness (..) 11 | ) where 12 | 13 | import qualified Control.Lens as Lens 14 | import qualified Data.Map as Map 15 | import Hyper 16 | import Hyper.Class.ZipMatch (ZipMatch (..)) 17 | 18 | import Hyper.Internal.Prelude 19 | 20 | -- | A mapping of keys to terms. 21 | -- 22 | -- Apart from the data type, a 'ZipMatch' instance is also provided. 23 | newtype TermMap h expr f = TermMap (Map h (f :# expr)) 24 | deriving stock (Generic) 25 | 26 | makePrisms ''TermMap 27 | makeCommonInstances [''TermMap] 28 | makeHTraversableApplyAndBases ''TermMap 29 | makeHMorph ''TermMap 30 | 31 | instance Eq h => ZipMatch (TermMap h expr) where 32 | {-# INLINE zipMatch #-} 33 | zipMatch (TermMap x) (TermMap y) 34 | | Map.size x /= Map.size y = Nothing 35 | | otherwise = 36 | zipMatchList (x ^@.. Lens.itraversed) (y ^@.. Lens.itraversed) 37 | <&> TermMap . Map.fromAscList . (traverse . Lens._2 %~ uncurry (:*:)) 38 | 39 | {-# INLINE zipMatchList #-} 40 | zipMatchList :: Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))] 41 | zipMatchList [] [] = Just [] 42 | zipMatchList ((k0, v0) : xs) ((k1, v1) : ys) 43 | | k0 == k1 = 44 | zipMatchList xs ys <&> ((k0, (v0, v1)) :) 45 | zipMatchList _ _ = Nothing 46 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/Row.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Row types 7 | module Hyper.Syntax.Row 8 | ( RowConstraints (..) 9 | , RowKey 10 | , RowExtend (..) 11 | , eKey 12 | , eVal 13 | , eRest 14 | , W_RowExtend (..) 15 | , FlatRowExtends (..) 16 | , freExtends 17 | , freRest 18 | , W_FlatRowExtends (..) 19 | , MorphWitness (..) 20 | , flattenRow 21 | , flattenRowExtend 22 | , unflattenRow 23 | , verifyRowExtendConstraints 24 | , rowExtendStructureMismatch 25 | , rowElementInfer 26 | ) where 27 | 28 | import Control.Lens (Lens', Prism', contains) 29 | import qualified Control.Lens as Lens 30 | import Control.Monad (foldM) 31 | import qualified Data.Map as Map 32 | import Generics.Constraints (Constraints, makeDerivings, makeInstances) 33 | import Hyper 34 | import Hyper.Unify 35 | import Hyper.Unify.New (newTerm, newUnbound) 36 | import Hyper.Unify.Term (UTerm (..), UTermBody (..), uBody, _UTerm) 37 | import Text.Show.Combinators (showCon, (@|)) 38 | 39 | import Hyper.Internal.Prelude 40 | 41 | class 42 | (Ord (RowConstraintsKey constraints), TypeConstraints constraints) => 43 | RowConstraints constraints 44 | where 45 | type RowConstraintsKey constraints 46 | forbidden :: Lens' constraints (Set (RowConstraintsKey constraints)) 47 | 48 | type RowKey typ = RowConstraintsKey (TypeConstraintsOf typ) 49 | 50 | -- | Row-extend primitive for use in both value-level and type-level 51 | data RowExtend key val rest h = RowExtend 52 | { _eKey :: key 53 | , _eVal :: h :# val 54 | , _eRest :: h :# rest 55 | } 56 | deriving (Generic) 57 | 58 | data FlatRowExtends key val rest h = FlatRowExtends 59 | { _freExtends :: Map key (h :# val) 60 | , _freRest :: h :# rest 61 | } 62 | deriving (Generic) 63 | 64 | makeLenses ''RowExtend 65 | makeLenses ''FlatRowExtends 66 | makeCommonInstances [''FlatRowExtends] 67 | makeZipMatch ''RowExtend 68 | makeHContext ''RowExtend 69 | makeHMorph ''RowExtend 70 | makeHTraversableApplyAndBases ''RowExtend 71 | makeHTraversableApplyAndBases ''FlatRowExtends 72 | makeDerivings [''Eq, ''Ord] [''RowExtend] 73 | makeInstances [''Binary, ''NFData] [''RowExtend] 74 | 75 | instance 76 | Constraints (RowExtend key val rest h) Show => 77 | Show (RowExtend key val rest h) 78 | where 79 | showsPrec p (RowExtend h v r) = (showCon "RowExtend" @| h @| v @| r) p 80 | 81 | {-# INLINE flattenRowExtend #-} 82 | flattenRowExtend :: 83 | (Ord key, Monad m) => 84 | (v # rest -> m (Maybe (RowExtend key val rest # v))) -> 85 | RowExtend key val rest # v -> 86 | m (FlatRowExtends key val rest # v) 87 | flattenRowExtend nextExtend (RowExtend h v rest) = 88 | flattenRow nextExtend rest 89 | <&> freExtends %~ Map.unionWith (error "Colliding keys") (Map.singleton h v) 90 | 91 | {-# INLINE flattenRow #-} 92 | flattenRow :: 93 | (Ord key, Monad m) => 94 | (v # rest -> m (Maybe (RowExtend key val rest # v))) -> 95 | v # rest -> 96 | m (FlatRowExtends key val rest # v) 97 | flattenRow nextExtend x = 98 | nextExtend x 99 | >>= maybe (pure (FlatRowExtends mempty x)) (flattenRowExtend nextExtend) 100 | 101 | {-# INLINE unflattenRow #-} 102 | unflattenRow :: 103 | Monad m => 104 | (RowExtend key val rest # v -> m (v # rest)) -> 105 | FlatRowExtends key val rest # v -> 106 | m (v # rest) 107 | unflattenRow mkExtend (FlatRowExtends fields rest) = 108 | fields ^@.. Lens.itraversed & foldM f rest 109 | where 110 | f acc (key, val) = RowExtend key val acc & mkExtend 111 | 112 | -- Helpers for Unify instances of type-level RowExtends: 113 | 114 | {-# INLINE verifyRowExtendConstraints #-} 115 | verifyRowExtendConstraints :: 116 | RowConstraints (TypeConstraintsOf rowTyp) => 117 | (TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp) -> 118 | TypeConstraintsOf rowTyp -> 119 | RowExtend (RowKey rowTyp) valTyp rowTyp # h -> 120 | Maybe (RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h) 121 | verifyRowExtendConstraints toChildC c (RowExtend h v rest) 122 | | c ^. forbidden . contains h = Nothing 123 | | otherwise = 124 | RowExtend 125 | h 126 | (WithConstraint (c & forbidden .~ mempty & toChildC) v) 127 | (WithConstraint (c & forbidden . contains h .~ True) rest) 128 | & Just 129 | 130 | {-# INLINE rowExtendStructureMismatch #-} 131 | rowExtendStructureMismatch :: 132 | Ord key => 133 | ( Unify m rowTyp 134 | , Unify m valTyp 135 | ) => 136 | (forall c. Unify m c => UVarOf m # c -> UVarOf m # c -> m (UVarOf m # c)) -> 137 | Prism' (rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m) -> 138 | RowExtend key valTyp rowTyp # UVarOf m -> 139 | RowExtend key valTyp rowTyp # UVarOf m -> 140 | m () 141 | rowExtendStructureMismatch match extend r0 r1 = 142 | do 143 | flat0 <- flattenRowExtend nextExtend r0 144 | flat1 <- flattenRowExtend nextExtend r1 145 | Map.intersectionWith match (flat0 ^. freExtends) (flat1 ^. freExtends) 146 | & sequenceA_ 147 | restVar <- UUnbound mempty & newVar binding 148 | let side x y = 149 | unflattenRow 150 | mkExtend 151 | FlatRowExtends 152 | { _freExtends = 153 | (x ^. freExtends) `Map.difference` (y ^. freExtends) 154 | , _freRest = restVar 155 | } 156 | >>= match (y ^. freRest) 157 | _ <- side flat0 flat1 158 | _ <- side flat1 flat0 159 | pure () 160 | where 161 | mkExtend ext = UTermBody mempty (extend # ext) & UTerm & newVar binding 162 | nextExtend v = semiPruneLookup v <&> (^? Lens._2 . _UTerm . uBody . extend) 163 | 164 | -- Helper for infering row usages of a row element, 165 | -- such as getting a field from a record or injecting into a sum type. 166 | -- Returns a unification variable for the element and for the whole row. 167 | {-# INLINE rowElementInfer #-} 168 | rowElementInfer :: 169 | forall m valTyp rowTyp. 170 | ( UnifyGen m valTyp 171 | , UnifyGen m rowTyp 172 | , RowConstraints (TypeConstraintsOf rowTyp) 173 | ) => 174 | (RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m -> rowTyp # UVarOf m) -> 175 | RowKey rowTyp -> 176 | m (UVarOf m # valTyp, UVarOf m # rowTyp) 177 | rowElementInfer extendToRow h = 178 | do 179 | restVar <- 180 | scopeConstraints (Proxy @rowTyp) 181 | >>= newVar binding . UUnbound . (forbidden . contains h .~ True) 182 | part <- newUnbound 183 | whole <- RowExtend h part restVar & extendToRow & newTerm 184 | pure (part, whole) 185 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/Scheme/AlphaEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | Alpha-equality for schemes 4 | module Hyper.Syntax.Scheme.AlphaEq 5 | ( alphaEq 6 | ) where 7 | 8 | import Control.Lens (ix) 9 | import Hyper 10 | import Hyper.Class.Optic (HNodeLens (..)) 11 | import Hyper.Class.ZipMatch (zipMatch_) 12 | import Hyper.Recurse (wrapM, (#>>)) 13 | import Hyper.Syntax.Scheme 14 | import Hyper.Unify 15 | import Hyper.Unify.New (newTerm) 16 | import Hyper.Unify.QuantifiedVar 17 | import Hyper.Unify.Term (UTerm (..), uBody) 18 | 19 | import Hyper.Internal.Prelude 20 | 21 | makeQVarInstancesInScope :: 22 | forall m typ. 23 | UnifyGen m typ => 24 | QVars # typ -> 25 | m (QVarInstances (UVarOf m) # typ) 26 | makeQVarInstancesInScope (QVars foralls) = 27 | traverse makeSkolem foralls <&> QVarInstances 28 | where 29 | makeSkolem c = scopeConstraints (Proxy @typ) >>= newVar binding . USkolem . (c <>) 30 | 31 | schemeBodyToType :: 32 | (UnifyGen m typ, HNodeLens varTypes typ, Ord (QVar typ)) => 33 | varTypes # QVarInstances (UVarOf m) -> 34 | typ # UVarOf m -> 35 | m (UVarOf m # typ) 36 | schemeBodyToType foralls x = 37 | case x ^? quantifiedVar >>= getForAll of 38 | Nothing -> newTerm x 39 | Just r -> pure r 40 | where 41 | getForAll v = foralls ^? hNodeLens . _QVarInstances . ix v 42 | 43 | schemeToRestrictedType :: 44 | forall m varTypes typ. 45 | ( HTraversable varTypes 46 | , HNodesConstraint varTypes (UnifyGen m) 47 | , HasScheme varTypes m typ 48 | ) => 49 | Pure # Scheme varTypes typ -> 50 | m (UVarOf m # typ) 51 | schemeToRestrictedType (Pure (Scheme vars typ)) = 52 | do 53 | foralls <- htraverse (Proxy @(UnifyGen m) #> makeQVarInstancesInScope) vars 54 | wrapM (Proxy @(HasScheme varTypes m) #>> schemeBodyToType foralls) typ 55 | 56 | goUTerm :: 57 | forall m t. 58 | Unify m t => 59 | UVarOf m # t -> 60 | UTerm (UVarOf m) # t -> 61 | UVarOf m # t -> 62 | UTerm (UVarOf m) # t -> 63 | m () 64 | goUTerm xv USkolem{} yv USkolem{} = 65 | do 66 | bindVar binding xv (UInstantiated yv) 67 | bindVar binding yv (UInstantiated xv) 68 | goUTerm xv (UInstantiated xt) yv (UInstantiated yt) 69 | | xv == yt && yv == xt = pure () 70 | | otherwise = unifyError (SkolemEscape xv) 71 | goUTerm xv USkolem{} yv UUnbound{} = bindVar binding yv (UToVar xv) 72 | goUTerm xv UUnbound{} yv USkolem{} = bindVar binding xv (UToVar yv) 73 | goUTerm xv UInstantiated{} yv UUnbound{} = bindVar binding yv (UToVar xv) 74 | goUTerm xv UUnbound{} yv UInstantiated{} = bindVar binding xv (UToVar yv) 75 | goUTerm _ (UToVar xv) yv yu = 76 | do 77 | xu <- lookupVar binding xv 78 | goUTerm xv xu yv yu 79 | goUTerm xv xu _ (UToVar yv) = 80 | do 81 | yu <- lookupVar binding yv 82 | goUTerm xv xu yv yu 83 | goUTerm xv USkolem{} yv _ = unifyError (SkolemUnified xv yv) 84 | goUTerm xv _ yv USkolem{} = unifyError (SkolemUnified yv xv) 85 | goUTerm xv UInstantiated{} yv _ = unifyError (SkolemUnified xv yv) 86 | goUTerm xv _ yv UInstantiated{} = unifyError (SkolemUnified yv xv) 87 | goUTerm xv UUnbound{} yv yu = goUTerm xv yu yv yu -- Term created in structure mismatch 88 | goUTerm xv xu yv UUnbound{} = goUTerm xv xu yv xu -- Term created in structure mismatch 89 | goUTerm _ (UTerm xt) _ (UTerm yt) = 90 | zipMatch_ (Proxy @(Unify m) #> goUVar) (xt ^. uBody) (yt ^. uBody) 91 | & fromMaybe (structureMismatch (\x y -> x <$ goUVar x y) (xt ^. uBody) (yt ^. uBody)) 92 | \\ unifyRecursive (Proxy @m) (Proxy @t) 93 | goUTerm _ _ _ _ = error "unexpected state at alpha-eq" 94 | 95 | goUVar :: 96 | Unify m t => 97 | UVarOf m # t -> 98 | UVarOf m # t -> 99 | m () 100 | goUVar xv yv = 101 | do 102 | xu <- lookupVar binding xv 103 | yu <- lookupVar binding yv 104 | goUTerm xv xu yv yu 105 | 106 | -- Check for alpha equality. Raises a `unifyError` when mismatches. 107 | alphaEq :: 108 | ( HTraversable varTypes 109 | , HNodesConstraint varTypes (UnifyGen m) 110 | , HasScheme varTypes m typ 111 | ) => 112 | Pure # Scheme varTypes typ -> 113 | Pure # Scheme varTypes typ -> 114 | m () 115 | alphaEq s0 s1 = 116 | do 117 | t0 <- schemeToRestrictedType s0 118 | t1 <- schemeToRestrictedType s1 119 | goUVar t0 t1 120 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/TypeSig.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Type signatures 7 | module Hyper.Syntax.TypeSig 8 | ( TypeSig (..) 9 | , tsType 10 | , tsTerm 11 | , W_TypeSig (..) 12 | ) where 13 | 14 | import Generics.Constraints (Constraints) 15 | import Hyper 16 | import Hyper.Infer 17 | import Hyper.Syntax.Scheme 18 | import Hyper.Unify (UnifyGen, unify) 19 | import Hyper.Unify.Generalize (instantiateWith) 20 | import Hyper.Unify.Term (UTerm (..)) 21 | import Text.PrettyPrint ((<+>)) 22 | import qualified Text.PrettyPrint as Pretty 23 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 24 | 25 | import Hyper.Internal.Prelude 26 | 27 | data TypeSig vars term h = TypeSig 28 | { _tsTerm :: h :# term 29 | , _tsType :: h :# Scheme vars (TypeOf term) 30 | } 31 | deriving (Generic) 32 | 33 | makeLenses ''TypeSig 34 | makeCommonInstances [''TypeSig] 35 | makeHTraversableApplyAndBases ''TypeSig 36 | 37 | instance 38 | Constraints (TypeSig vars term h) Pretty => 39 | Pretty (TypeSig vars term h) 40 | where 41 | pPrintPrec lvl p (TypeSig term typ) = 42 | pPrintPrec lvl 1 term <+> Pretty.text ":" <+> pPrintPrec lvl 1 typ 43 | & maybeParens (p > 1) 44 | 45 | type instance InferOf (TypeSig _ t) = InferOf t 46 | 47 | instance 48 | ( MonadScopeLevel m 49 | , HasInferredType term 50 | , HasInferredValue (TypeOf term) 51 | , HTraversable vars 52 | , HTraversable (InferOf term) 53 | , HNodesConstraint (InferOf term) (UnifyGen m) 54 | , HNodesConstraint vars (MonadInstantiate m) 55 | , UnifyGen m (TypeOf term) 56 | , Infer m (TypeOf term) 57 | , Infer m term 58 | ) => 59 | Infer m (TypeSig vars term) 60 | where 61 | inferBody (TypeSig x s) = 62 | do 63 | InferredChild xI xR <- inferChild x 64 | InferredChild sI sR <- inferChild s 65 | (t, ()) <- instantiateWith (pure ()) USkolem (sR ^. _HFlip) 66 | xR 67 | & inferredType (Proxy @term) #%%~ unify t 68 | <&> (TypeSig xI sI,) 69 | & localLevel 70 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/TypedLam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Syntax.TypedLam 7 | ( TypedLam (..) 8 | , tlIn 9 | , tlInType 10 | , tlOut 11 | , W_TypedLam (..) 12 | , MorphWitness (..) 13 | ) where 14 | 15 | import Generics.Constraints (Constraints) 16 | import Hyper 17 | import Hyper.Class.Optic (HNodeLens (..), HSubset (..), HSubset') 18 | import Hyper.Infer 19 | import Hyper.Syntax.FuncType (FuncType (..)) 20 | import Hyper.Unify (UVarOf, UnifyGen) 21 | import Hyper.Unify.New (newTerm) 22 | import qualified Text.PrettyPrint as P 23 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 24 | 25 | import Hyper.Internal.Prelude 26 | 27 | data TypedLam var typ expr h = TypedLam 28 | { _tlIn :: var 29 | , _tlInType :: h :# typ 30 | , _tlOut :: h :# expr 31 | } 32 | deriving (Generic) 33 | 34 | makeLenses ''TypedLam 35 | makeCommonInstances [''TypedLam] 36 | makeHTraversableApplyAndBases ''TypedLam 37 | makeZipMatch ''TypedLam 38 | makeHContext ''TypedLam 39 | makeHMorph ''TypedLam 40 | 41 | instance (RNodes t, RNodes e) => RNodes (TypedLam v t e) 42 | instance 43 | (c (TypedLam v t e), Recursively c t, Recursively c e) => 44 | Recursively c (TypedLam v t e) 45 | instance (RTraversable t, RTraversable e) => RTraversable (TypedLam v t e) 46 | 47 | instance 48 | Constraints (TypedLam var typ expr h) Pretty => 49 | Pretty (TypedLam var typ expr h) 50 | where 51 | pPrintPrec lvl p (TypedLam i t o) = 52 | ( P.text "λ" 53 | <> pPrintPrec lvl 0 i 54 | <> P.text ":" 55 | <> pPrintPrec lvl 0 t 56 | ) 57 | P.<+> P.text "→" 58 | P.<+> pPrintPrec lvl 0 o 59 | & maybeParens (p > 0) 60 | 61 | type instance InferOf (TypedLam _ _ e) = ANode (TypeOf e) 62 | 63 | instance 64 | ( Infer m t 65 | , Infer m e 66 | , HasInferredType e 67 | , UnifyGen m (TypeOf e) 68 | , HSubset' (TypeOf e) (FuncType (TypeOf e)) 69 | , HNodeLens (InferOf t) (TypeOf e) 70 | , LocalScopeType v (UVarOf m # TypeOf e) m 71 | ) => 72 | Infer m (TypedLam v t e) 73 | where 74 | {-# INLINE inferBody #-} 75 | inferBody (TypedLam p t r) = 76 | do 77 | InferredChild tI tR <- inferChild t 78 | let tT = tR ^. hNodeLens 79 | InferredChild rI rR <- inferChild r & localScopeType p tT 80 | hSubset # FuncType tT (rR ^# inferredType (Proxy @e)) 81 | & newTerm 82 | <&> (TypedLam p tI rI,) . MkANode 83 | -------------------------------------------------------------------------------- /src/Hyper/Syntax/Var.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | -- | Variables. 8 | module Hyper.Syntax.Var 9 | ( Var (..) 10 | , _Var 11 | , VarType (..) 12 | , ScopeOf 13 | , HasScope (..) 14 | ) where 15 | 16 | import Hyper 17 | import Hyper.Infer 18 | import Hyper.Unify (UVarOf, UnifyGen) 19 | import Text.PrettyPrint.HughesPJClass (Pretty (..)) 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | type family ScopeOf (t :: HyperType) :: HyperType 24 | 25 | class HasScope m s where 26 | getScope :: m (s # UVarOf m) 27 | 28 | class VarType var expr where 29 | -- | Instantiate a type for a variable in a given scope 30 | varType :: 31 | UnifyGen m (TypeOf expr) => 32 | Proxy expr -> 33 | var -> 34 | ScopeOf expr # UVarOf m -> 35 | m (UVarOf m # TypeOf expr) 36 | 37 | -- | Parameterized by term AST and not by its type AST 38 | -- (which currently is its only part used), 39 | -- for future evaluation/complilation support. 40 | newtype Var v (expr :: HyperType) (h :: AHyperType) = Var v 41 | deriving newtype (Eq, Ord, Binary, NFData) 42 | deriving stock (Show, Generic) 43 | 44 | makePrisms ''Var 45 | makeHTraversableApplyAndBases ''Var 46 | makeZipMatch ''Var 47 | makeHContext ''Var 48 | makeHMorph ''Var 49 | 50 | instance Pretty v => Pretty (Var v expr h) where 51 | pPrintPrec lvl p (Var v) = pPrintPrec lvl p v 52 | 53 | type instance InferOf (Var _ t) = ANode (TypeOf t) 54 | 55 | instance HasInferredType (Var v t) where 56 | type TypeOf (Var v t) = TypeOf t 57 | {-# INLINE inferredType #-} 58 | inferredType _ = _ANode 59 | 60 | instance 61 | ( UnifyGen m (TypeOf expr) 62 | , HasScope m (ScopeOf expr) 63 | , VarType v expr 64 | , Monad m 65 | ) => 66 | Infer m (Var v expr) 67 | where 68 | {-# INLINE inferBody #-} 69 | inferBody (Var x) = 70 | getScope >>= varType (Proxy @expr) x <&> (Var x,) . MkANode 71 | -------------------------------------------------------------------------------- /src/Hyper/TH/Apply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Generate 'HApply' and related instances via @TemplateHaskell@ 4 | module Hyper.TH.Apply 5 | ( makeHApply 6 | , makeHApplyAndBases 7 | , makeHApplicativeBases 8 | ) where 9 | 10 | import qualified Control.Lens as Lens 11 | import Hyper.Class.Apply (HApply (..)) 12 | import Hyper.TH.Functor (makeHFunctor) 13 | import Hyper.TH.Internal.Utils 14 | import Hyper.TH.Nodes (makeHNodes) 15 | import Hyper.TH.Pointed (makeHPointed) 16 | import Language.Haskell.TH 17 | 18 | import Hyper.Internal.Prelude 19 | 20 | -- | Generate instances of 'HApply', 21 | -- 'Hyper.Class.Functor.HFunctor', 'Hyper.Class.Pointed.HPointed' and 'Hyper.Class.Nodes.HNodes', 22 | -- which together form 'HApplicative'. 23 | makeHApplicativeBases :: Name -> DecsQ 24 | makeHApplicativeBases x = 25 | sequenceA 26 | [ makeHPointed x 27 | , makeHApplyAndBases x 28 | ] 29 | <&> concat 30 | 31 | -- | Generate an instance of 'HApply' 32 | -- along with its bases 'Hyper.Class.Functor.HFunctor' and 'Hyper.Class.Nodes.HNodes' 33 | makeHApplyAndBases :: Name -> DecsQ 34 | makeHApplyAndBases x = 35 | sequenceA 36 | [ makeHNodes x 37 | , makeHFunctor x 38 | , makeHApply x 39 | ] 40 | <&> concat 41 | 42 | -- | Generate an instance of 'HApply' 43 | makeHApply :: Name -> DecsQ 44 | makeHApply typeName = makeTypeInfo typeName >>= makeHApplyForType 45 | 46 | makeHApplyForType :: TypeInfo -> DecsQ 47 | makeHApplyForType info = 48 | do 49 | (name, _, fields) <- 50 | case tiConstructors info of 51 | [x] -> pure x 52 | _ -> fail "makeHApply only supports types with a single constructor" 53 | let xVars = makeConstructorVars "x" fields 54 | let yVars = makeConstructorVars "y" fields 55 | instanceD 56 | (makeContext info >>= simplifyContext) 57 | [t|HApply $(pure (tiInstance info))|] 58 | [ InlineP 'hzip Inline FunLike AllPhases & PragmaD & pure 59 | , funD 60 | 'hzip 61 | [ clause 62 | [ consPat name xVars 63 | , consPat name yVars 64 | ] 65 | (normalB (foldl appE (conE name) (zipWith f xVars yVars))) 66 | [] 67 | ] 68 | ] 69 | <&> (: []) 70 | where 71 | bodyFor (Right x) = bodyForPat x 72 | bodyFor Left{} = [|(<>)|] 73 | bodyForPat Node{} = [|(:*:)|] 74 | bodyForPat GenEmbed{} = [|hzip|] 75 | bodyForPat FlatEmbed{} = [|hzip|] 76 | bodyForPat (InContainer _ pat) = [|liftA2 $(bodyForPat pat)|] 77 | f (p, x) (_, y) = [|$(bodyFor p) $(varE x) $(varE y)|] 78 | 79 | makeContext :: TypeInfo -> Q [Pred] 80 | makeContext info = 81 | tiConstructors info >>= (^. Lens._3) & traverse ctxFor <&> mconcat 82 | where 83 | ctxFor (Right x) = ctxForPat x 84 | ctxFor (Left x) = [t|Semigroup $(pure x)|] <&> (: []) 85 | ctxForPat (InContainer t pat) = (:) <$> [t|Applicative $(pure t)|] <*> ctxForPat pat 86 | ctxForPat (GenEmbed t) = [t|HApply $(pure t)|] <&> (: []) 87 | ctxForPat (FlatEmbed t) = makeContext t 88 | ctxForPat _ = pure [] 89 | -------------------------------------------------------------------------------- /src/Hyper/TH/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Hyper.TH.Context 4 | ( makeHContext 5 | ) where 6 | 7 | import qualified Control.Lens as Lens 8 | import Hyper.Class.Context (HContext (..)) 9 | import Hyper.Class.Functor (HFunctor (..)) 10 | import Hyper.Combinator.Func (HFunc (..), _HFunc) 11 | import Hyper.TH.Internal.Utils 12 | import Language.Haskell.TH 13 | import Language.Haskell.TH.Datatype (ConstructorVariant (..)) 14 | 15 | import Hyper.Internal.Prelude 16 | 17 | makeHContext :: Name -> DecsQ 18 | makeHContext typeName = makeTypeInfo typeName >>= makeHContextForType 19 | 20 | makeHContextForType :: TypeInfo -> DecsQ 21 | makeHContextForType info = 22 | instanceD 23 | (simplifyContext (makeContext info)) 24 | [t|HContext $(pure (tiInstance info))|] 25 | [ InlineP 'hcontext Inline FunLike AllPhases & PragmaD & pure 26 | , funD 'hcontext (tiConstructors info <&> makeHContextCtr) 27 | ] 28 | <&> (: []) 29 | 30 | makeContext :: TypeInfo -> [Pred] 31 | makeContext info = 32 | tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right >>= ctxForPat 33 | where 34 | ctxForPat (GenEmbed t) = embed t 35 | ctxForPat (FlatEmbed x) = embed (tiInstance x) 36 | ctxForPat _ = [] 37 | embed t = [ConT ''HContext `AppT` t, ConT ''HFunctor `AppT` t] 38 | 39 | makeHContextCtr :: 40 | (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause 41 | makeHContextCtr (cName, _, []) = 42 | clause [conP cName []] (normalB (conE cName)) [] 43 | makeHContextCtr (cName, RecordConstructor fieldNames, cFields) = 44 | clause 45 | [varWhole `asP` conP cName (cVars <&> varP)] 46 | (normalB (foldl appE (conE cName) (zipWith bodyFor cFields (zip fieldNames cVars)))) 47 | [] 48 | where 49 | cVars = 50 | [(0 :: Int) ..] 51 | <&> mkName . ("_x" <>) . show 52 | & take (length cFields) 53 | bodyFor Left{} (_, v) = varE v 54 | bodyFor (Right Node{}) (f, v) = 55 | [| 56 | HFunc 57 | $( lamE 58 | [varP varField] 59 | [|Lens.Const $(recUpdE (varE varWhole) [pure (f, VarE varField)])|] 60 | ) 61 | :*: $(varE v) 62 | |] 63 | bodyFor _ _ = fail "makeHContext only works for simple record fields" 64 | varWhole = mkName "_whole" 65 | varField = mkName "_field" 66 | makeHContextCtr (cName, _, [cField]) = 67 | clause [conP cName [varP cVar]] (normalB (n `appE` bodyFor cField)) [] 68 | where 69 | n = conE cName 70 | v = varE cVar 71 | bodyFor Left{} = v 72 | bodyFor (Right Node{}) = [|HFunc (Lens.Const . $n) :*: $v|] 73 | bodyFor (Right GenEmbed{}) = embed 74 | bodyFor (Right FlatEmbed{}) = embed 75 | bodyFor _ = fail "makeHContext only works for simple fields" 76 | embed = 77 | [| 78 | hmap 79 | (const (Lens._1 . _HFunc . Lens.mapped . Lens._Wrapped Lens.%~ $n)) 80 | (hcontext $v) 81 | |] 82 | cVar = mkName "_c" 83 | makeHContextCtr _ = fail "makeHContext: unsupported constructor" 84 | -------------------------------------------------------------------------------- /src/Hyper/TH/Foldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Generate 'HFoldable' instances via @TemplateHaskell@ 4 | module Hyper.TH.Foldable 5 | ( makeHFoldable 6 | ) where 7 | 8 | import qualified Control.Lens as Lens 9 | import Hyper.Class.Foldable (HFoldable (..)) 10 | import Hyper.TH.Internal.Utils 11 | import Language.Haskell.TH 12 | import Language.Haskell.TH.Datatype (ConstructorVariant) 13 | 14 | import Hyper.Internal.Prelude 15 | 16 | -- | Generate a 'HFoldable' instance 17 | makeHFoldable :: Name -> DecsQ 18 | makeHFoldable typeName = makeTypeInfo typeName >>= makeHFoldableForType 19 | 20 | makeHFoldableForType :: TypeInfo -> DecsQ 21 | makeHFoldableForType info = 22 | instanceD 23 | (makeContext info >>= simplifyContext) 24 | [t|HFoldable $(pure (tiInstance info))|] 25 | [ InlineP 'hfoldMap Inline FunLike AllPhases & PragmaD & pure 26 | , funD 'hfoldMap (tiConstructors info <&> makeCtr) 27 | ] 28 | <&> (: []) 29 | where 30 | (_, wit) = makeNodeOf info 31 | makeCtr ctr = 32 | clause [varP varF, pat] body [] 33 | where 34 | (pat, body) = makeHFoldMapCtr 0 wit ctr 35 | 36 | makeContext :: TypeInfo -> Q [Pred] 37 | makeContext info = 38 | tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right 39 | & traverse ctxForPat 40 | <&> mconcat 41 | where 42 | ctxForPat (InContainer t pat) = (:) <$> [t|Foldable $(pure t)|] <*> ctxForPat pat 43 | ctxForPat (GenEmbed t) = [t|HFoldable $(pure t)|] <&> (: []) 44 | ctxForPat (FlatEmbed t) = makeContext t 45 | ctxForPat _ = pure [] 46 | 47 | varF :: Name 48 | varF = mkName "_f" 49 | 50 | makeHFoldMapCtr :: Int -> NodeWitnesses -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> (Q Pat, Q Body) 51 | makeHFoldMapCtr i wit (cName, _, cFields) = 52 | (conP cName (cVars <&> varP), body) 53 | where 54 | cVars = 55 | [i ..] 56 | <&> mkName . ("_x" <>) . show 57 | & take (length cFields) 58 | bodyParts = 59 | zipWith 60 | (\x y -> x <&> (`appE` y)) 61 | (cFields <&> bodyFor) 62 | (cVars <&> varE) 63 | & concat 64 | body = 65 | case bodyParts of 66 | [] -> [|mempty|] 67 | _ -> foldl1 append bodyParts 68 | & normalB 69 | append x y = [|$x <> $y|] 70 | f = varE varF 71 | bodyFor (Right x) = bodyForPat x 72 | bodyFor Left{} = [] 73 | bodyForPat (Node t) = [[|$f $(nodeWit wit t)|]] 74 | bodyForPat (GenEmbed t) = [[|hfoldMap ($f . $(embedWit wit t))|]] 75 | bodyForPat (InContainer _ pat) = bodyForPat pat <&> appE [|foldMap|] 76 | bodyForPat (FlatEmbed x) = 77 | [ lamCaseE 78 | ( tiConstructors x 79 | <&> uncurry match 80 | . makeHFoldMapCtr (i + length cVars) wit 81 | ?? [] 82 | ) 83 | ] 84 | -------------------------------------------------------------------------------- /src/Hyper/TH/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Generate 'HFunctor' instances via @TemplateHaskell@ 4 | module Hyper.TH.Functor 5 | ( makeHFunctor 6 | ) where 7 | 8 | import qualified Control.Lens as Lens 9 | import Hyper.Class.Functor (HFunctor (..)) 10 | import Hyper.TH.Internal.Utils 11 | import Language.Haskell.TH 12 | import Language.Haskell.TH.Datatype (ConstructorVariant) 13 | 14 | import Hyper.Internal.Prelude 15 | 16 | -- | Generate a 'HFunctor' instance 17 | makeHFunctor :: Name -> DecsQ 18 | makeHFunctor typeName = makeTypeInfo typeName >>= makeHFunctorForType 19 | 20 | makeHFunctorForType :: TypeInfo -> DecsQ 21 | makeHFunctorForType info = 22 | instanceD 23 | (makeContext info >>= simplifyContext) 24 | [t|HFunctor $(pure (tiInstance info))|] 25 | [ InlineP 'hmap Inline FunLike AllPhases & PragmaD & pure 26 | , funD 'hmap (tiConstructors info <&> makeCtr) 27 | ] 28 | <&> (: []) 29 | where 30 | (_, wit) = makeNodeOf info 31 | makeCtr ctr = 32 | clause [varP varF, pat] body [] 33 | where 34 | (pat, body) = makeHMapCtr 0 wit ctr 35 | 36 | varF :: Name 37 | varF = mkName "_f" 38 | 39 | makeContext :: TypeInfo -> Q [Pred] 40 | makeContext info = 41 | tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right 42 | & traverse ctxForPat 43 | <&> mconcat 44 | where 45 | ctxForPat (InContainer t pat) = (:) <$> [t|Functor $(pure t)|] <*> ctxForPat pat 46 | ctxForPat (GenEmbed t) = [t|HFunctor $(pure t)|] <&> (: []) 47 | ctxForPat (FlatEmbed t) = makeContext t 48 | ctxForPat _ = pure [] 49 | 50 | makeHMapCtr :: Int -> NodeWitnesses -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> (Q Pat, Q Body) 51 | makeHMapCtr i wit (cName, _, cFields) = 52 | (conP cName (cVars <&> varP), body) 53 | where 54 | cVars = 55 | [i ..] 56 | <&> mkName . ('x' :) . show 57 | & take (length cFields) 58 | body = 59 | zipWith bodyFor cFields cVars 60 | & foldl appE (conE cName) 61 | & normalB 62 | bodyFor (Right x) v = bodyForPat x `appE` varE v 63 | bodyFor Left{} v = varE v 64 | f = varE varF 65 | bodyForPat (Node t) = [|$f $(nodeWit wit t)|] 66 | bodyForPat (GenEmbed t) = [|hmap ($f . $(embedWit wit t))|] 67 | bodyForPat (InContainer _ pat) = [|fmap $(bodyForPat pat)|] 68 | bodyForPat (FlatEmbed x) = 69 | lamCaseE 70 | ( tiConstructors x 71 | <&> uncurry match 72 | . makeHMapCtr (i + length cVars) wit 73 | ?? [] 74 | ) 75 | -------------------------------------------------------------------------------- /src/Hyper/TH/Morph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Hyper.TH.Morph 5 | ( makeHMorph 6 | ) where 7 | 8 | import qualified Control.Lens as Lens 9 | import qualified Data.Map as Map 10 | import Hyper.Class.Morph (HMorph (..)) 11 | import Hyper.TH.Internal.Utils 12 | import Language.Haskell.TH 13 | import qualified Language.Haskell.TH.Datatype as D 14 | 15 | import Hyper.Internal.Prelude 16 | 17 | makeHMorph :: Name -> DecsQ 18 | makeHMorph typeName = makeTypeInfo typeName >>= makeHMorphForType 19 | 20 | {-# ANN module "HLint: ignore Use id" #-} 21 | makeHMorphForType :: TypeInfo -> DecsQ 22 | makeHMorphForType info = 23 | -- TODO: Contexts 24 | instanceD 25 | (pure []) 26 | [t|HMorph $(pure src) $(pure dst)|] 27 | [ D.tySynInstDCompat 28 | ''MorphConstraint 29 | (Just [pure (plainTV constraintVar)]) 30 | ([src, dst, VarT constraintVar] <&> pure) 31 | (simplifyContext morphConstraint <&> toTuple) 32 | , dataInstD 33 | (pure []) 34 | ''MorphWitness 35 | [pure src, pure dst, [t|_|], [t|_|]] 36 | Nothing 37 | (witnesses ^.. traverse . Lens._2) 38 | [] 39 | , funD 'morphMap (tiConstructors info <&> mkMorphCon) 40 | , funD 'morphLiftConstraint liftConstraintClauses 41 | ] 42 | <&> (: []) 43 | where 44 | (s0, s1) = paramSubsts info 45 | src = D.applySubstitution s0 (tiInstance info) 46 | dst = D.applySubstitution s1 (tiInstance info) 47 | constraintVar = mkName "constraint" 48 | contents = childrenTypes info 49 | morphConstraint = 50 | (tcChildren contents ^.. Lens.folded <&> appSubsts (VarT constraintVar)) 51 | <> ( tcEmbeds contents ^.. Lens.folded 52 | <&> \x -> ConT ''MorphConstraint `appSubsts` x `AppT` VarT constraintVar 53 | ) 54 | appSubsts x t = x `AppT` D.applySubstitution s0 t `AppT` D.applySubstitution s1 t 55 | nodeWits = 56 | tcChildren contents ^.. Lens.folded 57 | <&> \x -> 58 | let n = witPrefix <> mkNiceTypeName x & mkName 59 | in ( x 60 | , (n, gadtC [n] [] (pure (appSubsts morphWithNessOf x))) 61 | ) 62 | embedWits = 63 | tcEmbeds contents ^.. Lens.folded 64 | <&> \x -> 65 | let n = witPrefix <> mkNiceTypeName x & mkName 66 | in ( x 67 | , 68 | ( n 69 | , gadtC 70 | [n] 71 | [ bangType 72 | (bang noSourceUnpackedness noSourceStrictness) 73 | (pure (ConT ''MorphWitness `appSubsts` x `AppT` varA `AppT` varB)) 74 | ] 75 | (pure (morphWithNessOf `AppT` varA `AppT` varB)) 76 | ) 77 | ) 78 | witnesses = nodeWits <> embedWits & Map.fromList 79 | varA = VarT (mkName "a") 80 | varB = VarT (mkName "b") 81 | witPrefix = "M_" <> niceName (tiName info) <> "_" 82 | morphWithNessOf = ConT ''MorphWitness `AppT` src `AppT` dst 83 | liftConstraintClauses 84 | | Map.null witnesses = [clause [] (normalB (lamCaseE [])) []] 85 | | otherwise = 86 | (nodeWits ^.. traverse . Lens._2 . Lens._1 <&> liftNodeConstraint) 87 | <> (embedWits ^.. traverse . Lens._2 . Lens._1 <&> liftEmbedConstraint) 88 | liftNodeConstraint n = clause [conP n [], wildP] (normalB [|\x -> x|]) [] 89 | liftEmbedConstraint n = 90 | clause 91 | [conP n [varP varW], varP varProxy] 92 | (normalB [|morphLiftConstraint $(varE varW) $(varE varProxy)|]) 93 | [] 94 | varW = mkName "w" 95 | varProxy = mkName "p" 96 | mkMorphCon con = 97 | clause [varP varF, p] b [] 98 | where 99 | (p, b) = morphCon 0 witnesses con 100 | 101 | varF :: Name 102 | varF = mkName "_f" 103 | 104 | morphCon :: Int -> Map Type (Name, a) -> (Name, b, [Either c CtrTypePattern]) -> (Q Pat, Q Body) 105 | morphCon i witnesses (n, _, fields) = 106 | ( conP n (cVars <&> varP) 107 | , normalB (foldl appE (conE n) (zipWith bodyFor fields cVars)) 108 | ) 109 | where 110 | cVars = 111 | [i ..] 112 | <&> mkName . ('x' :) . show 113 | & take (length fields) 114 | f = varE varF 115 | bodyFor Left{} v = varE v 116 | bodyFor (Right x) v = [|$(bodyForPat x) $(varE v)|] 117 | bodyForPat (Node x) = [|$f $(conE (witnesses ^?! Lens.ix x . Lens._1))|] 118 | bodyForPat (InContainer _ pat) = [|fmap $(bodyForPat pat)|] 119 | bodyForPat (FlatEmbed x) = 120 | lamCaseE 121 | ( tiConstructors x 122 | <&> uncurry match 123 | . morphCon (i + length cVars) witnesses 124 | ?? [] 125 | ) 126 | bodyForPat (GenEmbed t) = [|morphMap ($f . $(conE (witnesses ^?! Lens.ix t . Lens._1)))|] 127 | 128 | type MorphSubsts = (Map Name Type, Map Name Type) 129 | 130 | paramSubsts :: TypeInfo -> MorphSubsts 131 | paramSubsts info = 132 | (tiParams info <&> D.tvName) ^. traverse . Lens.to mkInfo 133 | where 134 | pinned = pinnedParams info 135 | mkInfo name 136 | | pinned ^. Lens.contains name = mempty 137 | | otherwise = (side name "0", side name "1") 138 | side name suffix = mempty & Lens.at name ?~ VarT (mkName (nameBase name <> suffix)) 139 | 140 | pinnedParams :: TypeInfo -> Set Name 141 | pinnedParams = (^. Lens.to tiConstructors . traverse . Lens._3 . traverse . Lens.to ctrPinnedParams) 142 | 143 | ctrPinnedParams :: Either Type CtrTypePattern -> Set Name 144 | ctrPinnedParams (Left t) = typeParams t 145 | ctrPinnedParams (Right Node{}) = mempty 146 | ctrPinnedParams (Right GenEmbed{}) = mempty 147 | ctrPinnedParams (Right (FlatEmbed info)) = pinnedParams info 148 | ctrPinnedParams (Right (InContainer c p)) = typeParams c <> ctrPinnedParams (Right p) 149 | 150 | typeParams :: Type -> Set Name 151 | typeParams (VarT x) = mempty & Lens.contains x .~ True 152 | typeParams (AppT f x) = typeParams f <> typeParams x 153 | typeParams (InfixT x _ y) = typeParams x <> typeParams y 154 | -- TODO: Missing cases 155 | typeParams _ = mempty 156 | -------------------------------------------------------------------------------- /src/Hyper/TH/Nodes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | -- | Generate 'HNodes' instances via @TemplateHaskell@ 5 | module Hyper.TH.Nodes 6 | ( makeHNodes 7 | ) where 8 | 9 | import qualified Control.Lens as Lens 10 | import GHC.Generics (V1) 11 | import Hyper.Class.Nodes (HNodes (..), HWitness (..)) 12 | import Hyper.TH.Internal.Utils 13 | import Language.Haskell.TH 14 | import qualified Language.Haskell.TH.Datatype as D 15 | import qualified Language.Haskell.TH.Datatype.TyVarBndr as D 16 | 17 | import Hyper.Internal.Prelude 18 | 19 | -- | Generate a 'HNodes' instance 20 | makeHNodes :: Name -> DecsQ 21 | makeHNodes typeName = makeTypeInfo typeName >>= makeHNodesForType 22 | 23 | makeHNodesForType :: TypeInfo -> DecsQ 24 | makeHNodesForType info = 25 | [ instanceD 26 | (simplifyContext (makeContext info)) 27 | [t|HNodes $(pure (tiInstance info))|] 28 | [ D.tySynInstDCompat 29 | ''HNodesConstraint 30 | (Just [pure (plainTV constraintVar)]) 31 | [pure (tiInstance info), c] 32 | (nodesConstraint >>= simplifyContext <&> toTuple) 33 | , D.tySynInstDCompat ''HWitnessType Nothing [pure (tiInstance info)] witType 34 | , InlineP 'hLiftConstraint Inline FunLike AllPhases & PragmaD & pure 35 | , funD 'hLiftConstraint (makeHLiftConstraints wit) 36 | ] 37 | ] 38 | <> witDecs 39 | & sequenceA 40 | where 41 | (witType, witDecs) 42 | | null nodeOfCons = ([t|V1|], []) 43 | | otherwise = 44 | ( tiParams info <&> varT . D.tvName & foldl appT (conT witTypeName) 45 | , 46 | [ dataD 47 | (pure []) 48 | witTypeName 49 | (((D.defaultBndrFlag <$) <$> tiParams info) <> [plainTV (mkName "node")]) 50 | Nothing 51 | (nodeOfCons <&> (witType >>=)) 52 | [] 53 | ] 54 | ) 55 | where 56 | witTypeName = mkName ("W_" <> niceName (tiName info)) 57 | (nodeOfCons, wit) = makeNodeOf info 58 | constraintVar = mkName "constraint" 59 | c = varT constraintVar 60 | contents = childrenTypes info 61 | nodesConstraint = 62 | (tcChildren contents ^.. Lens.folded <&> (c `appT`) . pure) 63 | <> (tcEmbeds contents ^.. Lens.folded <&> \x -> [t|HNodesConstraint $(pure x) $c|]) 64 | <> (tcOthers contents ^.. Lens.folded <&> pure) 65 | & sequenceA 66 | 67 | makeContext :: TypeInfo -> [Pred] 68 | makeContext info = 69 | tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right >>= ctxForPat 70 | where 71 | ctxForPat (InContainer _ pat) = ctxForPat pat 72 | ctxForPat (GenEmbed t) = [ConT ''HNodes `AppT` t] 73 | ctxForPat (FlatEmbed t) = makeContext t 74 | ctxForPat _ = [] 75 | 76 | makeHLiftConstraints :: NodeWitnesses -> [Q Clause] 77 | makeHLiftConstraints wit 78 | | null clauses = [clause [] (normalB [|\case {}|]) []] 79 | | otherwise = clauses 80 | where 81 | clauses = (nodeWitCtrs wit <&> liftNode) <> (embedWitCtrs wit <&> liftEmbed) 82 | liftNode x = clause [conP 'HWitness [conP x []]] (normalB [|\_ r -> r|]) [] 83 | liftEmbed x = 84 | clause 85 | [conP 'HWitness [conP x [varP witVar]]] 86 | (normalB [|hLiftConstraint $(varE witVar)|]) 87 | [] 88 | witVar :: Name 89 | witVar = mkName "witness" 90 | -------------------------------------------------------------------------------- /src/Hyper/TH/Pointed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Generate 'HPointed' instances via @TemplateHaskell@ 4 | module Hyper.TH.Pointed 5 | ( makeHPointed 6 | ) where 7 | 8 | import qualified Control.Lens as Lens 9 | import Hyper.Class.Pointed (HPointed (..)) 10 | import Hyper.TH.Internal.Utils 11 | import Language.Haskell.TH 12 | import Language.Haskell.TH.Datatype (ConstructorVariant) 13 | 14 | import Hyper.Internal.Prelude 15 | 16 | -- | Generate a 'HPointed' instance 17 | makeHPointed :: Name -> DecsQ 18 | makeHPointed typeName = makeTypeInfo typeName >>= makeHPointedForType 19 | 20 | makeHPointedForType :: TypeInfo -> DecsQ 21 | makeHPointedForType info = 22 | do 23 | cons <- 24 | case tiConstructors info of 25 | [x] -> pure x 26 | _ -> fail "makeHPointed only supports types with a single constructor" 27 | instanceD 28 | (makeContext info >>= simplifyContext) 29 | [t|HPointed $(pure (tiInstance info))|] 30 | [ InlineP 'hpure Inline FunLike AllPhases & PragmaD & pure 31 | , funD 'hpure [makeHPureCtr info cons] 32 | ] 33 | <&> (: []) 34 | 35 | makeContext :: TypeInfo -> Q [Pred] 36 | makeContext info = 37 | tiConstructors info >>= (^. Lens._3) & traverse ctxFor <&> mconcat 38 | where 39 | ctxFor (Right x) = ctxForPat x 40 | ctxFor (Left x) = [t|Monoid $(pure x)|] <&> (: []) 41 | ctxForPat (InContainer t pat) = (:) <$> [t|Applicative $(pure t)|] <*> ctxForPat pat 42 | ctxForPat (GenEmbed t) = [t|HPointed $(pure t)|] <&> (: []) 43 | ctxForPat (FlatEmbed t) = makeContext t 44 | ctxForPat _ = pure [] 45 | 46 | makeHPureCtr :: TypeInfo -> (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause 47 | makeHPureCtr typeInfo (cName, _, cFields) = 48 | clause [varP varF] (normalB (foldl appE (conE cName) (cFields <&> bodyFor))) [] 49 | where 50 | bodyFor (Right x) = bodyForPat x 51 | bodyFor Left{} = [|mempty|] 52 | f = varE varF 53 | bodyForPat (Node t) = [|$f $(nodeWit wit t)|] 54 | bodyForPat (FlatEmbed inner) = 55 | case tiConstructors inner of 56 | [(iName, _, iFields)] -> iFields <&> bodyFor & foldl appE (conE iName) 57 | _ -> fail "makeHPointed only supports embedded types with a single constructor" 58 | bodyForPat (GenEmbed t) = [|hpure ($f . $(embedWit wit t))|] 59 | bodyForPat (InContainer _ pat) = [|pure $(bodyForPat pat)|] 60 | varF = mkName "_f" 61 | (_, wit) = makeNodeOf typeInfo 62 | -------------------------------------------------------------------------------- /src/Hyper/TH/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Generate 'HTraversable' and related instances via @TemplateHaskell@ 4 | module Hyper.TH.Traversable 5 | ( makeHTraversable 6 | , makeHTraversableAndFoldable 7 | , makeHTraversableAndBases 8 | , makeHTraversableApplyAndBases 9 | ) where 10 | 11 | import qualified Control.Lens as Lens 12 | import Hyper.Class.Traversable (ContainedH (..), HTraversable (..)) 13 | import Hyper.TH.Apply (makeHApplicativeBases) 14 | import Hyper.TH.Foldable (makeHFoldable) 15 | import Hyper.TH.Functor (makeHFunctor) 16 | import Hyper.TH.Internal.Utils 17 | import Hyper.TH.Nodes (makeHNodes) 18 | import Language.Haskell.TH 19 | import Language.Haskell.TH.Datatype (ConstructorVariant) 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | -- | Generate 'HTraversable' and 'Hyper.Class.Apply.HApply' instances along with all of their base classes: 24 | -- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor', 25 | -- 'Hyper.Class.Pointed.HPointed', and 'Hyper.Class.Nodes.HNodes'. 26 | makeHTraversableApplyAndBases :: Name -> DecsQ 27 | makeHTraversableApplyAndBases x = 28 | sequenceA 29 | [ makeHApplicativeBases x 30 | , makeHTraversableAndFoldable x 31 | ] 32 | <&> concat 33 | 34 | -- | Generate a 'HTraversable' instance along with the instance of its base classes: 35 | -- 'Hyper.Class.Foldable.HFoldable', 'Hyper.Class.Functor.HFunctor', and 'Hyper.Class.Nodes.HNodes'. 36 | makeHTraversableAndBases :: Name -> DecsQ 37 | makeHTraversableAndBases x = 38 | sequenceA 39 | [ makeHNodes x 40 | , makeHFunctor x 41 | , makeHTraversableAndFoldable x 42 | ] 43 | <&> concat 44 | 45 | -- | Generate 'HTraversable' and 'Hyper.Class.Foldable.HFoldable' instances 46 | makeHTraversableAndFoldable :: Name -> DecsQ 47 | makeHTraversableAndFoldable x = 48 | sequenceA 49 | [ makeHFoldable x 50 | , makeHTraversable x 51 | ] 52 | <&> concat 53 | 54 | -- | Generate a 'HTraversable' instance 55 | makeHTraversable :: Name -> DecsQ 56 | makeHTraversable typeName = makeTypeInfo typeName >>= makeHTraversableForType 57 | 58 | makeHTraversableForType :: TypeInfo -> DecsQ 59 | makeHTraversableForType info = 60 | instanceD 61 | (makeContext info >>= simplifyContext) 62 | [t|HTraversable $(pure (tiInstance info))|] 63 | [ InlineP 'hsequence Inline FunLike AllPhases & PragmaD & pure 64 | , funD 'hsequence (tiConstructors info <&> makeCons) 65 | ] 66 | <&> (: []) 67 | 68 | makeContext :: TypeInfo -> Q [Pred] 69 | makeContext info = 70 | tiConstructors info ^.. traverse . Lens._3 . traverse . Lens._Right 71 | & traverse ctxForPat 72 | <&> mconcat 73 | where 74 | ctxForPat (InContainer t pat) = (:) <$> [t|Traversable $(pure t)|] <*> ctxForPat pat 75 | ctxForPat (GenEmbed t) = [t|HTraversable $(pure t)|] <&> (: []) 76 | ctxForPat (FlatEmbed t) = makeContext t 77 | ctxForPat _ = pure [] 78 | 79 | makeCons :: 80 | (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> ClauseQ 81 | makeCons (cName, _, cFields) = 82 | clause [consPat cName consVars] body [] 83 | where 84 | body = 85 | consVars 86 | <&> f 87 | & applicativeStyle (conE cName) 88 | & normalB 89 | consVars = makeConstructorVars "x" cFields 90 | f (pat, name) = bodyFor pat `appE` varE name 91 | bodyFor (Right x) = bodyForPat x 92 | bodyFor Left{} = [|pure|] 93 | bodyForPat Node{} = [|runContainedH|] 94 | bodyForPat FlatEmbed{} = [|hsequence|] 95 | bodyForPat GenEmbed{} = [|hsequence|] 96 | bodyForPat (InContainer _ pat) = [|traverse $(bodyForPat pat)|] 97 | -------------------------------------------------------------------------------- /src/Hyper/TH/ZipMatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Generate 'ZipMatch' instances via @TemplateHaskell@ 4 | module Hyper.TH.ZipMatch 5 | ( makeZipMatch 6 | ) where 7 | 8 | import Control.Lens (both) 9 | import Hyper.Class.ZipMatch (ZipMatch (..)) 10 | import Hyper.TH.Internal.Utils 11 | import Language.Haskell.TH 12 | import Language.Haskell.TH.Datatype (ConstructorVariant) 13 | 14 | import Hyper.Internal.Prelude 15 | 16 | -- | Generate a 'ZipMatch' instance 17 | makeZipMatch :: Name -> DecsQ 18 | makeZipMatch typeName = 19 | do 20 | info <- makeTypeInfo typeName 21 | -- (dst, var) <- parts info 22 | let ctrs = tiConstructors info <&> makeZipMatchCtr 23 | instanceD 24 | (ctrs >>= ccContext & sequenceA >>= simplifyContext) 25 | (appT (conT ''ZipMatch) (pure (tiInstance info))) 26 | [ InlineP 'zipMatch Inline FunLike AllPhases & PragmaD & pure 27 | , funD 'zipMatch ((ctrs <&> ccClause) <> [tailClause]) 28 | ] 29 | <&> (: []) 30 | where 31 | tailClause = clause [wildP, wildP] (normalB [|Nothing|]) [] 32 | 33 | data CtrCase = CtrCase 34 | { ccClause :: Q Clause 35 | , ccContext :: [Q Pred] 36 | } 37 | 38 | makeZipMatchCtr :: (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> CtrCase 39 | makeZipMatchCtr (cName, _, cFields) = 40 | CtrCase 41 | { ccClause = clause [con fst, con snd] body [] 42 | , ccContext = fieldParts >>= zmfContext 43 | } 44 | where 45 | con f = conP cName (cVars <&> varP . f) 46 | cVars = 47 | [0 :: Int ..] 48 | <&> (\n -> (mkName ('x' : n), mkName ('y' : n))) . show 49 | & take (length cFields) 50 | body 51 | | null checks = normalB bodyExp 52 | | otherwise = guardedB [(,) <$> normalG (foldl1 mkAnd checks) <*> bodyExp] 53 | checks = fieldParts >>= zmfConds 54 | mkAnd x y = [|$x && $y|] 55 | fieldParts = zipWith field (cVars <&> both %~ varE) cFields 56 | bodyExp = applicativeStyle (conE cName) (fieldParts <&> zmfResult) 57 | field (x, y) (Right Node{}) = 58 | ZipMatchField 59 | { zmfResult = [|Just ($x :*: $y)|] 60 | , zmfConds = [] 61 | , zmfContext = [] 62 | } 63 | field (x, y) (Right (GenEmbed t)) = embed t x y 64 | field (x, y) (Right (FlatEmbed t)) = embed (tiInstance t) x y 65 | field _ (Right InContainer{}) = error "TODO" 66 | field (x, y) (Left t) = 67 | ZipMatchField 68 | { zmfResult = [|Just $x|] 69 | , zmfConds = [[|$x == $y|]] 70 | , zmfContext = [[t|Eq $(pure t)|]] 71 | } 72 | embed t x y = 73 | ZipMatchField 74 | { zmfResult = [|zipMatch $x $y|] 75 | , zmfConds = [] 76 | , zmfContext = [[t|ZipMatch $(pure t)|]] 77 | } 78 | 79 | data ZipMatchField = ZipMatchField 80 | { zmfResult :: Q Exp 81 | , zmfConds :: [Q Exp] 82 | , zmfContext :: [Q Pred] 83 | } 84 | -------------------------------------------------------------------------------- /src/Hyper/Type.hs: -------------------------------------------------------------------------------- 1 | -- | A 'HyperType' is a type parameterized by a hypertype. 2 | -- 3 | -- This infinite definition is expressible using the 'AHyperType' 'Data.Kind.Kind' for hypertypes. 4 | -- 5 | -- For more information see the [README](https://github.com/lamdu/hypertypes/blob/master/README.md). 6 | module Hyper.Type 7 | ( HyperType 8 | , AHyperType (..) 9 | , GetHyperType 10 | , type (#) 11 | , type (:#) 12 | , asHyper 13 | ) where 14 | 15 | import Data.Kind (Type) 16 | 17 | import Prelude.Compat 18 | 19 | -- | A hypertype is a type parameterized by a hypertype 20 | type HyperType = AHyperType -> Type 21 | 22 | -- | A 'Data.Kind.Kind' for 'HyperType's 23 | newtype AHyperType = AHyperType HyperType 24 | 25 | -- | A type-level getter for the type constructor encoded in 'AHyperType'. 26 | -- 27 | -- Notes: 28 | -- 29 | -- * If @DataKinds@ supported lifting field getters this would had been replaced with the type's getter. 30 | -- * 'GetHyperType' is injective, but due to no support for constrained type families, 31 | -- [that's not expressible at the moment](https://ghc.haskell.org/trac/ghc/ticket/15691). 32 | -- * Because 'GetHyperType' can't declared as bijective, uses of it may restrict inference. 33 | -- In those cases wrapping terms with the 'asHyper' helper assists Haskell's type inference 34 | -- as if Haskell knew that 'GetHyperType' was bijective. 35 | type family GetHyperType h where 36 | GetHyperType ('AHyperType t) = t 37 | 38 | -- | A type synonym to express nested-HKD structures 39 | type h # p = (h ('AHyperType p) :: Type) 40 | 41 | -- | A type synonym to express child nodes in nested-HKDs 42 | type h :# p = GetHyperType h # p 43 | 44 | -- | An 'id' variant which tells the type checker that its argument is a hypertype. 45 | -- 46 | -- See the notes for 'GetHyperType' which expand on why this might be used. 47 | -- 48 | -- Note that 'asHyper' may often be used during development to assist the inference of incomplete code, 49 | -- but removed once the code is complete. 50 | asHyper :: h # p -> h # p 51 | asHyper = id 52 | -------------------------------------------------------------------------------- /src/Hyper/Type/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Lift Functors to HyperTypes 7 | module Hyper.Type.Functor 8 | ( F (..) 9 | , _F 10 | , W_F (..) 11 | ) where 12 | 13 | import Control.Lens (iso, mapped) 14 | import Hyper 15 | import Hyper.Class.Monad (HMonad (..)) 16 | 17 | import Hyper.Internal.Prelude 18 | 19 | -- | Lift a 'Functor', or type constructor of kind @Type -> Type@ to a 'Hyper.Type.HyperType'. 20 | -- 21 | -- * @F Maybe@ can be used to encode structures with missing values 22 | -- * @F (Either Text)@ can be used to encode results of parsing where structure components 23 | -- may fail to parse. 24 | newtype F f h = F (f (h :# F f)) 25 | deriving stock (Generic) 26 | 27 | -- | An 'Iso' from 'F' to its content. 28 | -- 29 | -- Using `_F` rather than the 'F' data constructor is recommended, 30 | -- because it helps the type inference know that @F f@ is parameterized with a 'Hyper.Type.HyperType'. 31 | _F :: 32 | Iso 33 | (F f0 # k0) 34 | (F f1 # k1) 35 | (f0 (k0 # F f0)) 36 | (f1 (k1 # F f1)) 37 | _F = iso (\(F x) -> x) F 38 | 39 | makeCommonInstances [''F] 40 | makeHTraversableApplyAndBases ''F 41 | 42 | instance Monad f => HMonad (F f) where 43 | hjoin = 44 | ( _F 45 | %~ ( >>= 46 | ( mapped %~ t . (^. _HCompose) 47 | ) 48 | . (^. _HCompose . _F) 49 | ) 50 | ) 51 | . (^. _HCompose) 52 | where 53 | t :: 54 | forall p. 55 | Recursively HFunctor p => 56 | p # HCompose (F f) (F f) -> 57 | p # F f 58 | t = 59 | hmap (Proxy @(Recursively HFunctor) #> hjoin) 60 | \\ recursively (Proxy @(HFunctor p)) 61 | 62 | instance RNodes (F f) 63 | instance c (F f) => Recursively c (F f) 64 | instance Traversable f => RTraversable (F f) 65 | -------------------------------------------------------------------------------- /src/Hyper/Type/Prune.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hyper.Type.Prune 7 | ( Prune (..) 8 | , W_Prune (..) 9 | , _Pruned 10 | , _Unpruned 11 | ) where 12 | 13 | import qualified Control.Lens as Lens 14 | import Hyper 15 | import Hyper.Class.Traversable 16 | import Hyper.Class.Unify (UnifyGen) 17 | import Hyper.Combinator.Compose (HComposeConstraint1) 18 | import Hyper.Infer 19 | import Hyper.Infer.Blame (Blame (..)) 20 | import Hyper.Unify.New (newUnbound) 21 | import qualified Text.PrettyPrint as Pretty 22 | import Text.PrettyPrint.HughesPJClass (Pretty (..)) 23 | 24 | import Hyper.Internal.Prelude 25 | 26 | data Prune h 27 | = Pruned 28 | | Unpruned (h :# Prune) 29 | deriving (Generic) 30 | 31 | instance Pretty (h :# Prune) => Pretty (Prune h) where 32 | pPrintPrec _ _ Pruned = Pretty.text "" 33 | pPrintPrec level prec (Unpruned x) = pPrintPrec level prec x 34 | 35 | makeCommonInstances [''Prune] 36 | makePrisms ''Prune 37 | makeHTraversableAndBases ''Prune 38 | makeZipMatch ''Prune 39 | makeHContext ''Prune 40 | 41 | -- `HPointed` and `HApplicative` instances in the spirit of `Maybe` 42 | 43 | instance HPointed Prune where 44 | hpure f = Unpruned (f (HWitness W_Prune_Prune)) 45 | 46 | instance HApply Prune where 47 | hzip Pruned _ = Pruned 48 | hzip _ Pruned = Pruned 49 | hzip (Unpruned x) (Unpruned y) = x :*: y & Unpruned 50 | 51 | instance RNodes Prune 52 | instance c Prune => Recursively c Prune 53 | instance RTraversable Prune 54 | 55 | type instance InferOf (HCompose Prune t) = InferOf t 56 | 57 | instance 58 | ( Infer m t 59 | , HPointed (InferOf t) 60 | , HTraversable (InferOf t) 61 | , HNodesConstraint t (HComposeConstraint1 (Infer m) Prune) 62 | ) => 63 | Infer m (HCompose Prune t) 64 | where 65 | inferBody (HCompose Pruned) = 66 | hpure (Proxy @(UnifyGen m) #> MkContainedH newUnbound) 67 | \\ inferContext (Proxy @m) (Proxy @t) 68 | & hsequence 69 | <&> (_HCompose # Pruned,) 70 | inferBody (HCompose (Unpruned (HCompose x))) = 71 | hmap 72 | ( \_ (HCompose (InferChild i)) -> 73 | i 74 | <&> (\(InferredChild r t) -> InferredChild (_HCompose # r) t) 75 | & InferChild 76 | ) 77 | x 78 | & inferBody 79 | <&> Lens._1 %~ (hcomposed _Unpruned #) 80 | inferContext m _ = Dict \\ inferContext m (Proxy @t) 81 | 82 | instance 83 | ( Blame m t 84 | , HNodesConstraint t (HComposeConstraint1 (Infer m) Prune) 85 | , HNodesConstraint t (HComposeConstraint1 (Blame m) Prune) 86 | , HNodesConstraint t (HComposeConstraint1 RNodes Prune) 87 | , HNodesConstraint t (HComposeConstraint1 (Recursively HFunctor) Prune) 88 | , HNodesConstraint t (HComposeConstraint1 (Recursively HFoldable) Prune) 89 | , HNodesConstraint t (HComposeConstraint1 RTraversable Prune) 90 | ) => 91 | Blame m (HCompose Prune t) 92 | where 93 | inferOfUnify _ = inferOfUnify (Proxy @t) 94 | inferOfMatches _ = inferOfMatches (Proxy @t) 95 | -------------------------------------------------------------------------------- /src/Hyper/Type/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | -- | A 'Hyper.Type.HyperType' to express the simplest plain form of a nested higher-kinded data structure. 6 | -- 7 | -- The value level [hyperfunctions](http://hackage.haskell.org/package/hyperfunctions) 8 | -- equivalent of 'Pure' is called @self@ in 9 | -- [Hyperfunctions papers](https://arxiv.org/abs/1309.5135). 10 | module Hyper.Type.Pure 11 | ( Pure (..) 12 | , _Pure 13 | , W_Pure (..) 14 | ) where 15 | 16 | import Control.Lens (iso) 17 | import Hyper.TH.Traversable (makeHTraversableApplyAndBases) 18 | import Hyper.Type (type (#), type (:#)) 19 | import Text.PrettyPrint.HughesPJClass (Pretty (..)) 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | -- | A 'Hyper.Type.HyperType' to express the simplest plain form of a nested higher-kinded data structure 24 | newtype Pure h = Pure (h :# Pure) 25 | deriving stock (Generic) 26 | 27 | makeHTraversableApplyAndBases ''Pure 28 | makeCommonInstances [''Pure] 29 | 30 | -- | An 'Iso' from 'Pure' to its content. 31 | -- 32 | -- Using `_Pure` rather than the 'Pure' data constructor is recommended, 33 | -- because it helps the type inference know that 'Pure' is parameterized with a 'Hyper.Type.HyperType'. 34 | {-# INLINE _Pure #-} 35 | _Pure :: Iso (Pure # h) (Pure # j) (h # Pure) (j # Pure) 36 | _Pure = iso (\(Pure x) -> x) Pure 37 | 38 | instance Pretty (h :# Pure) => Pretty (Pure h) where 39 | pPrintPrec lvl p (Pure x) = pPrintPrec lvl p x 40 | -------------------------------------------------------------------------------- /src/Hyper/Unify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | Unification 4 | module Hyper.Unify 5 | ( unify 6 | , module Hyper.Class.Unify 7 | , module Hyper.Unify.Binding 8 | , module Hyper.Unify.Constraints 9 | , module Hyper.Unify.Error 10 | -- | Exported only for SPECIALIZE pragmas 11 | , updateConstraints 12 | , updateTermConstraints 13 | , updateTermConstraintsH 14 | , unifyUTerms 15 | , unifyUnbound 16 | ) where 17 | 18 | import Algebra.PartialOrd (PartialOrd (..)) 19 | import Hyper 20 | import Hyper.Class.Unify 21 | import Hyper.Class.ZipMatch (zipMatchA) 22 | import Hyper.Unify.Binding (UVar) 23 | import Hyper.Unify.Constraints 24 | import Hyper.Unify.Error (UnifyError (..)) 25 | import Hyper.Unify.Term (UTerm (..), UTermBody (..), uBody, uConstraints) 26 | 27 | import Hyper.Internal.Prelude 28 | 29 | -- TODO: implement when need / better understand motivations for - 30 | -- occursIn, seenAs, getFreeVars, freshen, equals, equiv 31 | -- (from unification-fd package) 32 | 33 | {-# INLINE updateConstraints #-} 34 | updateConstraints :: 35 | Unify m t => 36 | TypeConstraintsOf t -> 37 | UVarOf m # t -> 38 | UTerm (UVarOf m) # t -> 39 | m () 40 | updateConstraints !newConstraints v x = 41 | case x of 42 | UUnbound l 43 | | newConstraints `leq` l -> pure () 44 | | otherwise -> bindVar binding v (UUnbound newConstraints) 45 | USkolem l 46 | | newConstraints `leq` l -> pure () 47 | | otherwise -> SkolemEscape v & unifyError 48 | UTerm t -> updateTermConstraints v t newConstraints 49 | UResolving t -> occursError v t & void 50 | _ -> error "updateConstraints: This shouldn't happen in unification stage" 51 | 52 | {-# INLINE updateTermConstraints #-} 53 | updateTermConstraints :: 54 | forall m t. 55 | Unify m t => 56 | UVarOf m # t -> 57 | UTermBody (UVarOf m) # t -> 58 | TypeConstraintsOf t -> 59 | m () 60 | updateTermConstraints v t newConstraints 61 | | newConstraints `leq` (t ^. uConstraints) = pure () 62 | | otherwise = 63 | do 64 | bindVar binding v (UResolving t) 65 | case verifyConstraints newConstraints (t ^. uBody) of 66 | Nothing -> ConstraintsViolation (t ^. uBody) newConstraints & unifyError 67 | Just prop -> 68 | do 69 | htraverse_ (Proxy @(Unify m) #> updateTermConstraintsH) prop 70 | UTermBody newConstraints (t ^. uBody) & UTerm & bindVar binding v 71 | \\ unifyRecursive (Proxy @m) (Proxy @t) 72 | 73 | {-# INLINE updateTermConstraintsH #-} 74 | updateTermConstraintsH :: 75 | Unify m t => 76 | WithConstraint (UVarOf m) # t -> 77 | m () 78 | updateTermConstraintsH (WithConstraint c v0) = 79 | do 80 | (v1, x) <- semiPruneLookup v0 81 | updateConstraints c v1 x 82 | 83 | -- | Unify unification variables 84 | {-# INLINE unify #-} 85 | unify :: 86 | forall m t. 87 | Unify m t => 88 | UVarOf m # t -> 89 | UVarOf m # t -> 90 | m (UVarOf m # t) 91 | unify x0 y0 92 | | x0 == y0 = pure x0 93 | | otherwise = 94 | do 95 | (x1, xu) <- semiPruneLookup x0 96 | if x1 == y0 97 | then pure x1 98 | else do 99 | (y1, yu) <- semiPruneLookup y0 100 | if x1 == y1 101 | then pure x1 102 | else unifyUTerms x1 xu y1 yu 103 | 104 | {-# INLINE unifyUnbound #-} 105 | unifyUnbound :: 106 | Unify m t => 107 | WithConstraint (UVarOf m) # t -> 108 | UVarOf m # t -> 109 | UTerm (UVarOf m) # t -> 110 | m (UVarOf m # t) 111 | unifyUnbound (WithConstraint level xv) yv yt = 112 | do 113 | updateConstraints level yv yt 114 | yv <$ bindVar binding xv (UToVar yv) 115 | 116 | {-# INLINE unifyUTerms #-} 117 | unifyUTerms :: 118 | forall m t. 119 | Unify m t => 120 | UVarOf m # t -> 121 | UTerm (UVarOf m) # t -> 122 | UVarOf m # t -> 123 | UTerm (UVarOf m) # t -> 124 | m (UVarOf m # t) 125 | unifyUTerms xv (UUnbound level) yv yt = unifyUnbound (WithConstraint level xv) yv yt 126 | unifyUTerms xv xt yv (UUnbound level) = unifyUnbound (WithConstraint level yv) xv xt 127 | unifyUTerms xv USkolem{} yv _ = xv <$ unifyError (SkolemUnified xv yv) 128 | unifyUTerms xv _ yv USkolem{} = yv <$ unifyError (SkolemUnified yv xv) 129 | unifyUTerms xv (UTerm xt) yv (UTerm yt) = 130 | do 131 | bindVar binding yv (UToVar xv) 132 | zipMatchA (Proxy @(Unify m) #> unify) (xt ^. uBody) (yt ^. uBody) 133 | & fromMaybe (xt ^. uBody <$ structureMismatch unify (xt ^. uBody) (yt ^. uBody)) 134 | >>= bindVar binding xv . UTerm . UTermBody (xt ^. uConstraints <> yt ^. uConstraints) 135 | pure xv 136 | \\ unifyRecursive (Proxy @m) (Proxy @t) 137 | unifyUTerms _ _ _ _ = error "unifyUTerms: This shouldn't happen in unification stage" 138 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Binding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | A pure data structures implementation of unification variables state 5 | module Hyper.Unify.Binding 6 | ( UVar (..) 7 | , _UVar 8 | , Binding (..) 9 | , _Binding 10 | , emptyBinding 11 | , bindingDict 12 | ) where 13 | 14 | import Control.Lens (ALens') 15 | import qualified Control.Lens as Lens 16 | import Control.Monad.State (MonadState (..)) 17 | import Data.Sequence (Seq) 18 | import Hyper.Class.Unify (BindingDict (..)) 19 | import Hyper.Type (AHyperType, type (#)) 20 | import Hyper.Unify.Term 21 | 22 | import Hyper.Internal.Prelude 23 | 24 | -- | A unification variable identifier pure state based unification 25 | newtype UVar (t :: AHyperType) = UVar Int 26 | deriving stock (Generic, Show) 27 | deriving newtype (Eq, Ord) 28 | 29 | makePrisms ''UVar 30 | 31 | -- | The state of unification variables implemented in a pure data structure 32 | newtype Binding t = Binding (Seq (UTerm UVar t)) 33 | deriving stock (Generic) 34 | 35 | makePrisms ''Binding 36 | makeCommonInstances [''Binding] 37 | 38 | -- | An empty 'Binding' 39 | emptyBinding :: Binding t 40 | emptyBinding = Binding mempty 41 | 42 | -- | A 'BindingDict' for 'UVar's in a 'MonadState' whose state contains a 'Binding' 43 | {-# INLINE bindingDict #-} 44 | bindingDict :: 45 | MonadState s m => 46 | ALens' s (Binding # t) -> 47 | BindingDict UVar m t 48 | bindingDict l = 49 | BindingDict 50 | { lookupVar = 51 | \(UVar h) -> 52 | Lens.use (Lens.cloneLens l . _Binding) 53 | <&> (^?! Lens.ix h) 54 | , newVar = 55 | \x -> 56 | Lens.cloneLens l . _Binding <<%= (Lens.|> x) 57 | <&> UVar . length 58 | , bindVar = 59 | \(UVar h) -> 60 | (Lens.cloneLens l . _Binding . Lens.ix h .=) 61 | } 62 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Binding/ST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Unification variables binding in the 'Control.Monad.ST.ST' monad 4 | module Hyper.Unify.Binding.ST 5 | ( STUVar (..) 6 | , _STUVar 7 | , stBinding 8 | ) where 9 | 10 | import Control.Monad.ST.Class (MonadST (..)) 11 | import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef) 12 | import Hyper.Class.Unify (BindingDict (..)) 13 | import Hyper.Unify.Term (UTerm (..)) 14 | 15 | import Hyper.Internal.Prelude 16 | 17 | -- | A unification variable in the 'Control.Monad.ST.ST' monad 18 | newtype STUVar s t = STUVar (STRef s (UTerm (STUVar s) t)) 19 | deriving stock (Eq) 20 | 21 | makePrisms ''STUVar 22 | 23 | -- | A 'BindingDict' for 'STUVar's 24 | {-# INLINE stBinding #-} 25 | stBinding :: 26 | MonadST m => 27 | BindingDict (STUVar (World m)) m t 28 | stBinding = 29 | BindingDict 30 | { lookupVar = liftST . readSTRef . (^. _STUVar) 31 | , newVar = \t -> newSTRef t & liftST <&> STUVar 32 | , bindVar = \v t -> writeSTRef (v ^. _STUVar) t & liftST 33 | } 34 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Binding/ST/Load.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | -- | Load serialized a binding state to 'Control.Monad.ST.ST' based bindings 5 | module Hyper.Unify.Binding.ST.Load 6 | ( load 7 | ) where 8 | 9 | import qualified Control.Lens as Lens 10 | import Control.Monad.ST.Class (MonadST (..)) 11 | import Data.Array.ST (STArray, newArray, readArray, writeArray) 12 | import Hyper 13 | import Hyper.Class.Optic (HNodeLens (..)) 14 | import Hyper.Class.Unify (BindingDict (..), UVarOf, Unify (..)) 15 | import Hyper.Recurse 16 | import Hyper.Unify.Binding (Binding (..), UVar (..), _Binding) 17 | import Hyper.Unify.Binding.ST (STUVar) 18 | import Hyper.Unify.Term (UTerm (..), uBody) 19 | 20 | import Hyper.Internal.Prelude 21 | 22 | newtype ConvertState s t = ConvertState (STArray s Int (Maybe (STUVar s t))) 23 | makePrisms ''ConvertState 24 | 25 | makeConvertState :: MonadST m => Binding # t -> m (ConvertState (World m) # t) 26 | makeConvertState (Binding x) = 27 | newArray (0, length x) Nothing & liftST <&> ConvertState 28 | 29 | loadUTerm :: 30 | forall m typeVars t. 31 | ( MonadST m 32 | , UVarOf m ~ STUVar (World m) 33 | , Unify m t 34 | , Recursively (HNodeLens typeVars) t 35 | ) => 36 | typeVars # Binding -> 37 | typeVars # ConvertState (World m) -> 38 | UTerm UVar # t -> 39 | m (UTerm (STUVar (World m)) # t) 40 | loadUTerm _ _ (UUnbound c) = UUnbound c & pure 41 | loadUTerm _ _ (USkolem c) = USkolem c & pure 42 | loadUTerm src conv (UToVar v) = loadVar src conv v <&> UToVar 43 | loadUTerm src conv (UTerm u) = uBody (loadBody src conv) u <&> UTerm 44 | loadUTerm _ _ UResolving{} = error "converting bindings after resolution" 45 | loadUTerm _ _ UResolved{} = error "converting bindings after resolution" 46 | loadUTerm _ _ UConverted{} = error "loading while saving?" 47 | loadUTerm _ _ UInstantiated{} = error "loading during instantiation" 48 | 49 | loadVar :: 50 | forall m t typeVars. 51 | ( MonadST m 52 | , UVarOf m ~ STUVar (World m) 53 | , Unify m t 54 | , Recursively (HNodeLens typeVars) t 55 | ) => 56 | typeVars # Binding -> 57 | typeVars # ConvertState (World m) -> 58 | UVar # t -> 59 | m (STUVar (World m) # t) 60 | loadVar src conv (UVar v) = 61 | withDict (recursively (Proxy @(HNodeLens typeVars t))) $ 62 | let tConv = conv ^. hNodeLens . _ConvertState 63 | in readArray tConv v 64 | & liftST 65 | >>= \case 66 | Just x -> pure x 67 | Nothing -> 68 | do 69 | u <- 70 | loadUTerm 71 | src 72 | conv 73 | (src ^?! hNodeLens . _Binding . Lens.ix v) 74 | r <- newVar binding u 75 | r <$ liftST (writeArray tConv v (Just r)) 76 | 77 | loadBody :: 78 | forall m typeVars t. 79 | ( MonadST m 80 | , UVarOf m ~ STUVar (World m) 81 | , Unify m t 82 | , Recursively (HNodeLens typeVars) t 83 | ) => 84 | typeVars # Binding -> 85 | typeVars # ConvertState (World m) -> 86 | t # UVar -> 87 | m (t # STUVar (World m)) 88 | loadBody src conv = 89 | htraverse 90 | ( Proxy @(Unify m) #*# 91 | Proxy @(Recursively (HNodeLens typeVars)) #> 92 | loadVar src conv 93 | ) 94 | \\ recurse (Proxy @(Unify m t)) 95 | \\ recursively (Proxy @(HNodeLens typeVars t)) 96 | 97 | -- | Load a given serialized unification 98 | -- and a value with serialized unification variable identifiers 99 | -- to a value with 'Control.Monad.ST.ST' unification variables. 100 | load :: 101 | ( MonadST m 102 | , UVarOf m ~ STUVar (World m) 103 | , HTraversable typeVars 104 | , Unify m t 105 | , Recursively (HNodeLens typeVars) t 106 | ) => 107 | typeVars # Binding -> 108 | t # UVar -> 109 | m (t # STUVar (World m)) 110 | load src collection = 111 | do 112 | conv <- htraverse (const makeConvertState) src 113 | loadBody src conv collection 114 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Binding/Save.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | Serialize the state of unification 4 | module Hyper.Unify.Binding.Save 5 | ( save 6 | ) where 7 | 8 | import qualified Control.Lens as Lens 9 | import Control.Monad.Trans.Class (MonadTrans (..)) 10 | import Control.Monad.Trans.State (StateT (..)) 11 | import Hyper 12 | import Hyper.Class.Optic (HNodeLens (..)) 13 | import Hyper.Class.Unify (BindingDict (..), UVarOf, Unify (..)) 14 | import Hyper.Recurse 15 | import Hyper.Unify.Binding (Binding, UVar (..), _Binding) 16 | import Hyper.Unify.Term (UTerm (..), uBody) 17 | 18 | import Hyper.Internal.Prelude 19 | 20 | saveUTerm :: 21 | forall m typeVars t. 22 | (Unify m t, Recursively (HNodeLens typeVars) t) => 23 | UTerm (UVarOf m) # t -> 24 | StateT (typeVars # Binding, [m ()]) m (UTerm UVar # t) 25 | saveUTerm (UUnbound c) = UUnbound c & pure 26 | saveUTerm (USkolem c) = USkolem c & pure 27 | saveUTerm (UToVar v) = saveVar v <&> UToVar 28 | saveUTerm (UTerm u) = uBody saveBody u <&> UTerm 29 | saveUTerm UInstantiated{} = error "converting bindings during instantiation" 30 | saveUTerm UResolving{} = error "converting bindings after resolution" 31 | saveUTerm UResolved{} = error "converting bindings after resolution" 32 | saveUTerm UConverted{} = error "converting variable again" 33 | 34 | saveVar :: 35 | forall m t typeVars. 36 | (Unify m t, Recursively (HNodeLens typeVars) t) => 37 | UVarOf m # t -> 38 | StateT (typeVars # Binding, [m ()]) m (UVar # t) 39 | saveVar v = 40 | lookupVar binding v 41 | & lift 42 | >>= \case 43 | UConverted i -> pure (UVar i) 44 | srcBody -> 45 | do 46 | pb <- Lens.use (Lens._1 . hNodeLens) 47 | let r = pb ^. _Binding & length 48 | UConverted r & bindVar binding v & lift 49 | Lens._2 %= (<> [bindVar binding v srcBody]) 50 | dstBody <- saveUTerm srcBody 51 | Lens._1 . hNodeLens .= (pb & _Binding %~ (Lens.|> dstBody)) 52 | UVar r & pure 53 | \\ recursively (Proxy @(HNodeLens typeVars t)) 54 | 55 | saveBody :: 56 | forall m typeVars t. 57 | (Unify m t, Recursively (HNodeLens typeVars) t) => 58 | t # UVarOf m -> 59 | StateT (typeVars # Binding, [m ()]) m (t # UVar) 60 | saveBody = 61 | htraverse 62 | ( Proxy @(Unify m) #*# 63 | Proxy @(Recursively (HNodeLens typeVars)) #> 64 | saveVar 65 | ) 66 | \\ recurse (Proxy @(Unify m t)) 67 | \\ recursively (Proxy @(HNodeLens typeVars t)) 68 | 69 | -- | Serialize the state of unification for 70 | -- the unification variables in a given value, 71 | -- and transform the value's unification variables 72 | -- to their serialized identifiers. 73 | save :: 74 | (Unify m t, Recursively (HNodeLens typeVars) t) => 75 | t # UVarOf m -> 76 | StateT (typeVars # Binding) m (t # UVar) 77 | save collection = 78 | StateT $ 79 | \dstState -> 80 | do 81 | (r, (finalState, recover)) <- runStateT (saveBody collection) (dstState, []) 82 | (r, finalState) <$ sequence_ recover 83 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Constraints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | -- | A class for constraints for unification variables 5 | module Hyper.Unify.Constraints 6 | ( TypeConstraints (..) 7 | , HasTypeConstraints (..) 8 | , WithConstraint (..) 9 | , wcConstraint 10 | , wcBody 11 | ) where 12 | 13 | import Algebra.PartialOrd (PartialOrd (..)) 14 | import Data.Kind (Type) 15 | import Hyper (GetHyperType, HyperType, type (#)) 16 | 17 | import Hyper.Internal.Prelude 18 | 19 | -- | A class for constraints for unification variables. 20 | class (PartialOrd c, Monoid c) => TypeConstraints c where 21 | -- | Remove scope constraints. 22 | -- 23 | -- When generalizing unification variables into universally 24 | -- quantified variables, and then into fresh unification variables 25 | -- upon instantiation, some constraints need to be carried over, 26 | -- and the "scope" constraints need to be erased. 27 | generalizeConstraints :: c -> c 28 | 29 | -- | Remove all constraints other than the scope constraints 30 | -- 31 | -- Useful for comparing constraints to the current scope constraints 32 | toScopeConstraints :: c -> c 33 | 34 | -- | A class for terms that have constraints. 35 | -- 36 | -- A dependency of `Hyper.Class.Unify.Unify` 37 | class 38 | TypeConstraints (TypeConstraintsOf ast) => 39 | HasTypeConstraints (ast :: HyperType) 40 | where 41 | type TypeConstraintsOf (ast :: HyperType) :: Type 42 | 43 | -- | Verify constraints on the ast and apply the given child 44 | -- verifier on children 45 | verifyConstraints :: 46 | TypeConstraintsOf ast -> 47 | ast # h -> 48 | Maybe (ast # WithConstraint h) 49 | 50 | -- | A 'HyperType' to represent a term alongside a constraint. 51 | -- 52 | -- Used for 'verifyConstraints'. 53 | data WithConstraint h ast = WithConstraint 54 | { _wcConstraint :: TypeConstraintsOf (GetHyperType ast) 55 | , _wcBody :: h ast 56 | } 57 | 58 | makeLenses ''WithConstraint 59 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | A type for unification errors 5 | module Hyper.Unify.Error 6 | ( UnifyError (..) 7 | , _SkolemUnified 8 | , _SkolemEscape 9 | , _ConstraintsViolation 10 | , _Occurs 11 | , _Mismatch 12 | ) where 13 | 14 | import Generics.Constraints (Constraints) 15 | import Hyper 16 | import Hyper.Unify.Constraints (TypeConstraintsOf) 17 | import Text.PrettyPrint ((<+>)) 18 | import qualified Text.PrettyPrint as Pretty 19 | import Text.PrettyPrint.HughesPJClass (Pretty (..), maybeParens) 20 | 21 | import Hyper.Internal.Prelude 22 | 23 | -- | An error that occurred during unification 24 | data UnifyError t h 25 | = -- | A universally quantified variable was unified with a 26 | -- different type 27 | SkolemUnified (h :# t) (h :# t) 28 | | -- | A universally quantified variable escapes its scope 29 | SkolemEscape (h :# t) 30 | | -- | A term violates constraints that should apply to it 31 | ConstraintsViolation (t h) (TypeConstraintsOf t) 32 | | -- | Infinite type encountered. A type occurs within itself 33 | Occurs (t h) (t h) 34 | | -- | Unification between two mismatching type structures 35 | Mismatch (t h) (t h) 36 | deriving (Generic) 37 | 38 | makePrisms ''UnifyError 39 | makeCommonInstances [''UnifyError] 40 | makeHTraversableAndBases ''UnifyError 41 | 42 | instance Constraints (UnifyError t h) Pretty => Pretty (UnifyError t h) where 43 | pPrintPrec lvl p = 44 | maybeParens haveParens . \case 45 | SkolemUnified x y -> Pretty.text "SkolemUnified" <+> r x <+> r y 46 | SkolemEscape x -> Pretty.text "SkolemEscape:" <+> r x 47 | Mismatch x y -> Pretty.text "Mismatch" <+> r x <+> r y 48 | Occurs x y -> r x <+> Pretty.text "occurs in itself, expands to:" <+> right y 49 | ConstraintsViolation x y -> Pretty.text "ConstraintsViolation" <+> r x <+> r y 50 | where 51 | haveParens = p > 10 52 | right 53 | | haveParens = pPrintPrec lvl 0 54 | | otherwise = pPrintPrec lvl p 55 | r :: Pretty a => a -> Pretty.Doc 56 | r = pPrintPrec lvl 11 57 | -------------------------------------------------------------------------------- /src/Hyper/Unify/New.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | Generate new unification variables 4 | module Hyper.Unify.New 5 | ( newUnbound 6 | , newTerm 7 | , unfreeze 8 | ) where 9 | 10 | import Hyper 11 | import Hyper.Class.Unify (BindingDict (..), UVarOf, Unify (..), UnifyGen (..)) 12 | import Hyper.Recurse 13 | import Hyper.Unify.Term (UTerm (..), UTermBody (..)) 14 | 15 | import Prelude.Compat 16 | 17 | -- | Create a new unbound unification variable in the current scope 18 | {-# INLINE newUnbound #-} 19 | newUnbound :: forall m t. UnifyGen m t => m (UVarOf m # t) 20 | newUnbound = scopeConstraints (Proxy @t) >>= newVar binding . UUnbound 21 | 22 | -- | Create a new unification term with a given body 23 | {-# INLINE newTerm #-} 24 | newTerm :: forall m t. UnifyGen m t => t # UVarOf m -> m (UVarOf m # t) 25 | newTerm x = scopeConstraints (Proxy @t) >>= newVar binding . UTerm . (`UTermBody` x) 26 | 27 | -- | Embed a pure term as a unification term 28 | {-# INLINE unfreeze #-} 29 | unfreeze :: forall m t. UnifyGen m t => Pure # t -> m (UVarOf m # t) 30 | unfreeze = wrapM (Proxy @(UnifyGen m) #>> newTerm) 31 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Occurs.hs: -------------------------------------------------------------------------------- 1 | -- | Occurs check (check whether unification terms recursively contains themselves) 2 | module Hyper.Unify.Occurs 3 | ( occursCheck 4 | ) where 5 | 6 | import Control.Monad (unless, when) 7 | import Control.Monad.Trans.Class (MonadTrans (..)) 8 | import Control.Monad.Trans.State (execStateT, get, put) 9 | import Hyper 10 | import Hyper.Class.Unify (BindingDict (..), UVarOf, Unify (..), occursError, semiPruneLookup) 11 | import Hyper.Unify.Term (UTerm (..), uBody) 12 | 13 | import Hyper.Internal.Prelude 14 | 15 | -- | Occurs check 16 | {-# INLINE occursCheck #-} 17 | occursCheck :: 18 | forall m t. 19 | Unify m t => 20 | UVarOf m # t -> 21 | m () 22 | occursCheck v0 = 23 | do 24 | (v1, x) <- semiPruneLookup v0 25 | case x of 26 | UResolving t -> occursError v1 t 27 | UResolved{} -> pure () 28 | UUnbound{} -> pure () 29 | USkolem{} -> pure () 30 | UTerm b -> 31 | htraverse_ 32 | ( Proxy @(Unify m) #> 33 | \c -> 34 | do 35 | get >>= lift . (`unless` bindVar binding v1 (UResolving b)) 36 | put True 37 | occursCheck c & lift 38 | ) 39 | (b ^. uBody) 40 | & (`execStateT` False) 41 | >>= (`when` bindVar binding v1 (UTerm b)) 42 | \\ unifyRecursive (Proxy @m) (Proxy @t) 43 | UToVar{} -> error "lookup not expected to result in var (in occursCheck)" 44 | UConverted{} -> error "conversion state not expected in occursCheck" 45 | UInstantiated{} -> error "occursCheck during instantiation" 46 | -------------------------------------------------------------------------------- /src/Hyper/Unify/QuantifiedVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | -- | A class for types that have quantified variables. 6 | module Hyper.Unify.QuantifiedVar 7 | ( HasQuantifiedVar (..) 8 | , MonadQuantify (..) 9 | , OrdQVar 10 | ) where 11 | 12 | import Control.Lens (Prism') 13 | import Hyper.Type (HyperType) 14 | 15 | import Prelude.Compat 16 | 17 | -- | Class for types which have quantified variables 18 | class HasQuantifiedVar (t :: HyperType) where 19 | -- | The type of quantified variable identifiers 20 | type QVar t 21 | 22 | -- | A `Prism'` from a type to its quantified variable term 23 | quantifiedVar :: Prism' (t f) (QVar t) 24 | 25 | -- | A constraint synonym that represents that 26 | -- the quantified variable of a type has an 'Ord' instance 27 | class (HasQuantifiedVar t, Ord (QVar t)) => OrdQVar t 28 | 29 | instance (HasQuantifiedVar t, Ord (QVar t)) => OrdQVar t 30 | 31 | -- | A monad where new quantified variables can be generated 32 | class MonadQuantify typeConstraints q m where 33 | newQuantifiedVariable :: typeConstraints -> m q 34 | -------------------------------------------------------------------------------- /src/Hyper/Unify/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | Unification terms. 5 | -- 6 | -- These represent the known state of a unification variable. 7 | module Hyper.Unify.Term 8 | ( UTerm (..) 9 | , _UUnbound 10 | , _USkolem 11 | , _UToVar 12 | , _UTerm 13 | , _UInstantiated 14 | , _UResolving 15 | , _UResolved 16 | , _UConverted 17 | , UTermBody (..) 18 | , uBody 19 | , uConstraints 20 | ) where 21 | 22 | import Hyper 23 | import Hyper.Unify.Constraints (TypeConstraintsOf) 24 | 25 | import Hyper.Internal.Prelude 26 | 27 | -- | A unification term with a known body 28 | data UTermBody v ast = UTermBody 29 | { _uConstraints :: TypeConstraintsOf (GetHyperType ast) 30 | , _uBody :: ast :# v 31 | } 32 | deriving (Generic) 33 | 34 | -- | A unification term pointed by a unification variable 35 | data UTerm v ast 36 | = -- | Unbound variable with at least the given constraints 37 | UUnbound (TypeConstraintsOf (GetHyperType ast)) 38 | | -- | A variable bound by a rigid quantified variable with 39 | -- *exactly* the given constraints 40 | USkolem (TypeConstraintsOf (GetHyperType ast)) 41 | | -- | Unified with another variable (union-find) 42 | UToVar (v ast) 43 | | -- | Known type term with unification variables as children 44 | UTerm (UTermBody v ast) 45 | | -- | Temporary state during instantiation indicating which fresh 46 | -- unification variable a skolem is mapped to 47 | UInstantiated (v ast) 48 | | -- | Temporary state while unification term is being traversed, 49 | -- if it occurs inside itself (detected via state still being 50 | -- UResolving), then the type is an infinite type 51 | UResolving (UTermBody v ast) 52 | | -- | Final resolved state. `Hyper.Unify.applyBindings` resolved to 53 | -- this expression (allowing caching/sharing) 54 | UResolved (Pure ast) 55 | | -- | Temporary state used in "Hyper.Unify.Binding.ST.Save" while 56 | -- converting to a pure binding 57 | UConverted Int 58 | deriving (Generic) 59 | 60 | makePrisms ''UTerm 61 | makeLenses ''UTermBody 62 | makeCommonInstances [''UTerm, ''UTermBody] 63 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.3 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /test/AlphaEqTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module AlphaEqTest (test) where 4 | 5 | import qualified Control.Lens as Lens 6 | import Control.Lens.Operators 7 | import Control.Monad.ST (runST) 8 | import Data.Functor.Identity (Identity (..)) 9 | import qualified Data.Map as Map 10 | import qualified Data.Set as Set 11 | import ExprUtils 12 | import Hyper 13 | import Hyper.Syntax.Scheme 14 | import Hyper.Syntax.Scheme.AlphaEq (alphaEq) 15 | import LangB 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | import TypeLang 19 | 20 | import Prelude 21 | 22 | test :: TestTree 23 | test = 24 | testGroup 25 | "alpha-eq" 26 | [ testAlphaEq (uniType TIntP) (uniType TIntP) True 27 | , testAlphaEq (uniType TIntP) intToInt False 28 | , testAlphaEq intToInt intToInt True 29 | , testAlphaEq (intsRecord ["a", "b"]) (intsRecord ["b", "a"]) True 30 | , testAlphaEq (intsRecord ["a", "b"]) (intsRecord ["b"]) False 31 | , testAlphaEq (intsRecord ["a", "b", "c"]) (intsRecord ["c", "b", "a"]) True 32 | , testAlphaEq (intsRecord ["a", "b", "c"]) (intsRecord ["b", "c", "a"]) True 33 | , testAlphaEq (forAll1 "a" id) (forAll1 "b" id) True 34 | , testAlphaEq (forAll1 "a" id) (uniType TIntP) False 35 | , testAlphaEq (forAll1r "a" TRecP) (uniType TIntP) False 36 | , testAlphaEq (forAll1r "a" TRecP) (forAll1r "b" TRecP) True 37 | , testAlphaEq (mkOpenRec "a" "x" "y") (mkOpenRec "b" "y" "x") True 38 | , testAlphaEq (valH0 (TVarP "a")) (valH0 (TRecP REmptyP)) False 39 | ] 40 | where 41 | valH0 x = 42 | TFunP (TVarP "a") (TRecP (RExtendP "t" x (RVarP "c"))) ^. hPlain 43 | & Scheme 44 | ( Types 45 | (QVars (mempty & Lens.at "a" ?~ mempty)) 46 | (QVars (mempty & Lens.at "c" ?~ RowConstraints (Set.fromList ["t"]) mempty)) 47 | ) 48 | & Pure 49 | mkOpenRec a x y = 50 | _Pure 51 | # Scheme 52 | ( Types 53 | (QVars mempty) 54 | (QVars (Map.fromList [(a, RowConstraints (Set.fromList [x, y]) mempty)])) 55 | ) 56 | ( TRecP 57 | ( RVarP a 58 | & RExtendP x TIntP 59 | & RExtendP y TIntP 60 | ) 61 | ^. hPlain 62 | ) 63 | 64 | testAlphaEq :: Pure # Scheme Types Typ -> Pure # Scheme Types Typ -> Bool -> TestTree 65 | testAlphaEq x y expect = 66 | do 67 | assertEqual msg expect pureRes 68 | assertEqual ("ST: " <> msg) expect stRes 69 | & testCase (prettyStyle x <> sep <> prettyStyle y) 70 | where 71 | sep = if expect then " == " else " != " 72 | msg = "Alpha eq of " <> prettyStyle x <> " and " <> prettyStyle y 73 | pureRes = Lens.has Lens._Right (execPureInferB (alphaEq x y)) 74 | stRes = Lens.has Lens._Right (runST (execSTInferB (alphaEq x y))) 75 | 76 | uniType :: HPlain Typ -> Pure # Scheme Types Typ 77 | uniType typ = 78 | _Pure 79 | # Scheme 80 | { _sForAlls = Types (QVars mempty) (QVars mempty) 81 | , _sTyp = typ ^. hPlain 82 | } 83 | 84 | intsRecord :: [Name] -> Pure # Scheme Types Typ 85 | intsRecord = uniType . TRecP . foldr (`RExtendP` TIntP) REmptyP 86 | 87 | intToInt :: Pure # Scheme Types Typ 88 | intToInt = TFunP TIntP TIntP & uniType 89 | 90 | forAll1 :: 91 | Name -> 92 | (HPlain Typ -> HPlain Typ) -> 93 | Pure # Scheme Types Typ 94 | forAll1 t body = 95 | forAll (Identity t) (Const ()) $ \(Identity tv) _ -> body tv 96 | 97 | forAll1r :: 98 | Name -> 99 | (HPlain Row -> HPlain Typ) -> 100 | Pure # Scheme Types Typ 101 | forAll1r t body = 102 | forAll (Const ()) (Identity t) $ \_ (Identity tv) -> body tv 103 | -------------------------------------------------------------------------------- /test/Benchmark.hs: -------------------------------------------------------------------------------- 1 | import Control.Exception (evaluate) 2 | import Control.Lens.Operators 3 | import Criterion (Benchmarkable, whnfIO) 4 | import Criterion.Main (bench, defaultMain) 5 | import Hyper 6 | import Hyper.Unify 7 | import Hyper.Unify.New (unfreeze) 8 | import LangB 9 | import Text.PrettyPrint.HughesPJClass (prettyShow) 10 | import TypeLang 11 | 12 | import Prelude 13 | 14 | fields :: [String] 15 | fields = ['a' : show i | i <- [0 :: Int .. 100]] 16 | 17 | record :: [String] -> Pure # Typ 18 | record = (^. hPlain) . TRecP . foldr (\k -> RExtendP (Name k) TIntP) REmptyP 19 | 20 | recordFwd :: Pure # Typ 21 | recordFwd = record fields 22 | 23 | recordBwd :: Pure # Typ 24 | recordBwd = record (reverse fields) 25 | 26 | unifyLargeRows :: Benchmarkable 27 | unifyLargeRows = 28 | do 29 | r1 <- unfreeze recordFwd 30 | r2 <- unfreeze recordBwd 31 | unify r1 r2 32 | & execPureInferB 33 | & either (fail . prettyShow) evaluate 34 | & whnfIO 35 | 36 | main :: IO () 37 | main = defaultMain [bench "Unify large rows" unifyLargeRows] 38 | -------------------------------------------------------------------------------- /test/BlameTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BlameTest (test) where 4 | 5 | import qualified Control.Lens as Lens 6 | import Control.Lens.Operators 7 | import ExprUtils 8 | import Hyper 9 | import Hyper.Infer.Blame 10 | import Hyper.Recurse 11 | import Hyper.Syntax (App (..), Var (..)) 12 | import Hyper.Unify.New 13 | import LangB 14 | import qualified LangBTest 15 | import Test.Tasty 16 | import Test.Tasty.HUnit 17 | 18 | import Prelude 19 | 20 | test :: TestTree 21 | test = 22 | testGroup 23 | "blame" 24 | [ testBlame (addAnns (BAppP (BVarP "unitToUnit") (BLitP 5) ^. hPlain)) "--X" 25 | , testBlame 26 | ( Ann 27 | (Const @Int 2) 28 | ( BApp 29 | ( App 30 | (Ann (Const 1) (BVar (Var "unitToUnit"))) 31 | (Ann (Const 0) (BLit 5)) 32 | ) 33 | ) 34 | ) 35 | "-X-" 36 | ] 37 | 38 | testBlame :: (Ord a, Show a) => Annotated a # LangB -> String -> TestTree 39 | testBlame term expect = 40 | case result of 41 | Left{} -> assertFailure "Unexpected type error in testBlame" 42 | Right x -> 43 | assertEqual "Wrong blame" expect formatted 44 | where 45 | formatted = x ^.. hflipped . hfolded1 . Lens._2 <&> fmt 46 | & testCase 47 | ( prettyStyle (unwrap (const (^. hVal)) term) 48 | <> " " 49 | <> show (term ^.. hflipped . hfolded1 . Lens._Wrapped) 50 | ) 51 | where 52 | fmt Good{} = '-' 53 | fmt _ = 'X' 54 | result = 55 | do 56 | top <- newUnbound 57 | blame getConst (_ANode # top) term 58 | & LangBTest.withEnv id 59 | & execPureInferB 60 | -------------------------------------------------------------------------------- /test/ExprUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module ExprUtils (prettyStyle, forAll, testCommon, addAnns, inferExpr) where 4 | 5 | import qualified Control.Lens as Lens 6 | import Control.Lens.Operators 7 | import Control.Monad 8 | import Data.Constraint 9 | import qualified Data.Map as Map 10 | import Hyper 11 | import Hyper.Infer 12 | import Hyper.Recurse 13 | import Hyper.Syntax.Scheme 14 | import Hyper.Unify 15 | import Hyper.Unify.Generalize 16 | import Hyper.Unify.QuantifiedVar 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | import qualified Text.PrettyPrint as Pretty 20 | import Text.PrettyPrint.HughesPJClass (Pretty (..)) 21 | import TypeLang 22 | 23 | import Prelude 24 | 25 | prettyStyle :: Pretty a => a -> String 26 | prettyStyle = Pretty.renderStyle (Pretty.Style Pretty.OneLineMode 0 0) . pPrint 27 | 28 | forAll :: 29 | (Traversable t, Traversable u) => 30 | t Name -> 31 | u Name -> 32 | (t (HPlain Typ) -> u (HPlain Row) -> HPlain Typ) -> 33 | Pure # Scheme Types Typ 34 | forAll tvs rvs body = 35 | _Pure 36 | # Scheme 37 | (Types (foralls tvs) (foralls rvs)) 38 | (body (tvs <&> TVarP) (rvs <&> RVarP) ^. hPlain) 39 | 40 | foralls :: 41 | (Foldable f, Monoid (TypeConstraintsOf typ), Ord (QVar typ)) => 42 | f (QVar typ) -> 43 | QVars # typ 44 | foralls xs = 45 | xs ^.. Lens.folded 46 | <&> (,mempty) 47 | & Map.fromList 48 | & QVars 49 | 50 | testCommon :: 51 | (Pretty (lang # Pure), Pretty a) => 52 | Pure # lang -> 53 | String -> 54 | Either (TypeError # Pure) a -> 55 | Either (TypeError # Pure) a -> 56 | TestTree 57 | testCommon expr expect pureRes stRes = 58 | do 59 | assertEqualStrings msg expect (prettyStyle pureRes) 60 | assertEqualStrings ("ST: " <> msg) expect (prettyStyle stRes) 61 | & testCase (prettyStyle expr) 62 | where 63 | msg = "Infer of " <> prettyStyle expr 64 | 65 | assertEqualStrings :: String -> String -> String -> IO () 66 | assertEqualStrings msg expected value 67 | | value == expected = pure () 68 | | otherwise = 69 | assertFailure (msg <> "\nexpected: " <> expected <> "\n but got: " <> value) 70 | 71 | inferExpr :: 72 | forall m t. 73 | ( HasInferredType t 74 | , Infer m t 75 | , HasScheme Types m (TypeOf t) 76 | , RTraversable t 77 | , Recursively (InferOfConstraint HFoldable) t 78 | ) => 79 | Pure # t -> 80 | m (Pure # Scheme Types (TypeOf t)) 81 | inferExpr x = 82 | do 83 | inferRes <- infer (addAnns x) 84 | result <- 85 | inferRes ^# hAnn . Lens._2 . _InferResult . inferredType (Proxy @t) 86 | & generalize 87 | >>= saveScheme 88 | result 89 | <$ htraverse_ 90 | ( Proxy @(Infer m) #*# 91 | Proxy @(Recursively (InferOfConstraint HFoldable)) #*# 92 | \(w :: HWitness (HFlip Ann t) n) (Const () :*: InferResult i) -> 93 | htraverse_ (Proxy @(UnifyGen m) #> void . applyBindings) i 94 | \\ inferContext (Proxy @m) w 95 | \\ inferOfConstraint @HFoldable w 96 | \\ recursively (Proxy @(InferOfConstraint HFoldable n)) 97 | ) 98 | (_HFlip # inferRes) 99 | 100 | addAnns :: Recursively HFunctor h => Pure # h -> Ann (Const ()) # h 101 | addAnns = wrap (const (Ann (Const ()))) 102 | -------------------------------------------------------------------------------- /test/Hyper/Class/Infer/Infer1.hs: -------------------------------------------------------------------------------- 1 | -- | 'Infer' for indexed AST types (such as 'Hyper.Type.AST.Scope.Scope') 2 | module Hyper.Class.Infer.Infer1 3 | ( HasTypeOf1 (..) 4 | , HasInferOf1 (..) 5 | , Infer1 (..) 6 | ) where 7 | 8 | import Data.Constraint (Constraint, Dict, (:-)) 9 | import Data.Kind (Type) 10 | import Data.Proxy (Proxy (..)) 11 | import Data.Type.Equality 12 | import Hyper.Infer 13 | import Hyper.Type (HyperType) 14 | 15 | class HasTypeOf1 t where 16 | type TypeOf1 t :: HyperType 17 | typeAst :: Proxy (t h) -> Dict (TypeOf (t h) ~ TypeOf1 t) 18 | 19 | class HasInferOf1 t where 20 | type InferOf1 t :: HyperType 21 | type InferOf1IndexConstraint t :: Type -> Constraint 22 | hasInferOf1 :: Proxy (t h) -> Dict (InferOf (t h) ~ InferOf1 t) 23 | 24 | class HasInferOf1 t => Infer1 m t where 25 | inferMonad :: InferOf1IndexConstraint t i :- Infer m (t i) 26 | -------------------------------------------------------------------------------- /test/Hyper/Syntax/NamelessScope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE EmptyDataDeriving #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | -- | A 'HyperType' based implementation of "locally-nameless" terms, 9 | -- inspired by the [bound](http://hackage.haskell.org/package/bound) library 10 | -- and the technique from Bird & Paterson's 11 | -- ["de Bruijn notation as a nested datatype"](https://www.semanticscholar.org/paper/De-Bruijn-Notation-as-a-Nested-Datatype-Bird-Paterson/254b3b01651c5e325d9b3cd15c106fbec40e53ea) 12 | module Hyper.Syntax.NamelessScope 13 | ( Scope (..) 14 | , _Scope 15 | , W_Scope (..) 16 | , ScopeVar (..) 17 | , _ScopeVar 18 | , EmptyScope 19 | , DeBruijnIndex (..) 20 | , ScopeTypes (..) 21 | , _ScopeTypes 22 | , W_ScopeTypes (..) 23 | , HasScopeTypes (..) 24 | ) where 25 | 26 | import Control.Lens (Lens', Prism') 27 | import qualified Control.Lens as Lens 28 | import Control.Lens.Operators 29 | import Control.Monad.Reader (MonadReader) 30 | import Data.Constraint ((:-), (\\)) 31 | import Data.Kind (Type) 32 | import Data.Sequence (Seq) 33 | import qualified Data.Sequence as Sequence 34 | import Hyper 35 | import Hyper.Class.Infer.Infer1 36 | import Hyper.Infer 37 | import Hyper.Syntax.FuncType 38 | import Hyper.Unify (UVarOf, UnifyGen) 39 | import Hyper.Unify.New (newUnbound) 40 | 41 | import Prelude 42 | 43 | data EmptyScope deriving (Show) 44 | 45 | newtype Scope expr a h = Scope (h :# expr (Maybe a)) 46 | Lens.makePrisms ''Scope 47 | 48 | newtype ScopeVar (expr :: Type -> HyperType) a (h :: AHyperType) = ScopeVar a 49 | Lens.makePrisms ''ScopeVar 50 | 51 | makeZipMatch ''Scope 52 | makeHTraversableApplyAndBases ''Scope 53 | makeZipMatch ''ScopeVar 54 | makeHTraversableApplyAndBases ''ScopeVar 55 | 56 | class DeBruijnIndex a where 57 | deBruijnIndex :: Prism' Int a 58 | 59 | instance DeBruijnIndex EmptyScope where 60 | deBruijnIndex = Lens.prism (\case {}) Left 61 | 62 | instance DeBruijnIndex a => DeBruijnIndex (Maybe a) where 63 | deBruijnIndex = 64 | Lens.prism' toInt fromInt 65 | where 66 | toInt Nothing = 0 67 | toInt (Just x) = 1 + deBruijnIndex # x 68 | fromInt x 69 | | x == 0 = Just Nothing 70 | | otherwise = (x - 1) ^? deBruijnIndex <&> Just 71 | 72 | newtype ScopeTypes t v = ScopeTypes (Seq (v :# t)) 73 | deriving newtype (Semigroup, Monoid) 74 | 75 | Lens.makePrisms ''ScopeTypes 76 | makeHTraversableApplyAndBases ''ScopeTypes 77 | 78 | -- TODO: Replace this class with ones from Infer 79 | class HasScopeTypes v t env where 80 | scopeTypes :: Lens' env (ScopeTypes t # v) 81 | 82 | instance HasScopeTypes v t (ScopeTypes t # v) where 83 | scopeTypes = id 84 | 85 | type instance InferOf (Scope t h) = FuncType (TypeOf (t h)) 86 | type instance InferOf (ScopeVar t h) = ANode (TypeOf (t h)) 87 | 88 | instance HasTypeOf1 t => HasInferOf1 (Scope t) where 89 | type InferOf1 (Scope t) = FuncType (TypeOf1 t) 90 | type InferOf1IndexConstraint (Scope t) = DeBruijnIndex 91 | hasInferOf1 p = 92 | Dict \\ typeAst (p0 p) 93 | where 94 | p0 :: Proxy (Scope t h) -> Proxy (t h) 95 | p0 _ = Proxy 96 | 97 | instance 98 | ( Infer1 m t 99 | , Monad m 100 | , InferOf1IndexConstraint t ~ DeBruijnIndex 101 | , DeBruijnIndex h 102 | , UnifyGen m (TypeOf (t h)) 103 | , MonadReader env m 104 | , HasScopeTypes (UVarOf m) (TypeOf (t h)) env 105 | , HasInferredType (t h) 106 | ) => 107 | Infer m (Scope t h) 108 | where 109 | inferBody (Scope x) = 110 | do 111 | varType <- newUnbound 112 | inferChild x 113 | & Lens.locally (scopeTypes . _ScopeTypes) (varType Sequence.<|) 114 | <&> \(InferredChild xI xR) -> 115 | ( Scope xI 116 | , FuncType varType (xR ^# inferredType (Proxy @(t h))) 117 | ) 118 | \\ (inferMonad :: DeBruijnIndex (Maybe h) :- Infer m (t (Maybe h))) 119 | \\ hasInferOf1 (Proxy @(t h)) 120 | \\ hasInferOf1 (Proxy @(t (Maybe h))) 121 | 122 | inferContext _ _ = 123 | Dict \\ inferMonad @m @t @(Maybe h) 124 | 125 | instance 126 | ( MonadReader env m 127 | , Monad m 128 | , HasScopeTypes (UVarOf m) (TypeOf (t h)) env 129 | , DeBruijnIndex h 130 | , UnifyGen m (TypeOf (t h)) 131 | ) => 132 | Infer m (ScopeVar t h) 133 | where 134 | inferBody (ScopeVar v) = 135 | Lens.view (scopeTypes . _ScopeTypes) 136 | <&> (ScopeVar v,) . MkANode . (^?! Lens.ix (deBruijnIndex # v)) 137 | -------------------------------------------------------------------------------- /test/Hyper/Syntax/NamelessScope/InvDeBruijn.hs: -------------------------------------------------------------------------------- 1 | module Hyper.Syntax.NamelessScope.InvDeBruijn 2 | ( InvDeBruijnIndex (..) 3 | , inverseDeBruijnIndex 4 | , scope 5 | , scopeVar 6 | ) where 7 | 8 | import Control.Lens (Prism', iso) 9 | import Control.Lens.Operators 10 | import Data.Proxy (Proxy (..)) 11 | import Hyper.Syntax.NamelessScope (DeBruijnIndex (..), EmptyScope, Scope (..), ScopeVar (..)) 12 | import Hyper.Type (type (#)) 13 | 14 | import Prelude 15 | 16 | class DeBruijnIndex a => InvDeBruijnIndex a where 17 | deBruijnIndexMax :: Proxy a -> Int 18 | 19 | instance InvDeBruijnIndex EmptyScope where 20 | deBruijnIndexMax _ = -1 21 | 22 | instance InvDeBruijnIndex a => InvDeBruijnIndex (Maybe a) where 23 | deBruijnIndexMax _ = 1 + deBruijnIndexMax (Proxy @a) 24 | 25 | inverseDeBruijnIndex :: forall a. InvDeBruijnIndex a => Prism' Int a 26 | inverseDeBruijnIndex = 27 | iso (l -) (l -) . deBruijnIndex 28 | where 29 | l = deBruijnIndexMax (Proxy @a) 30 | 31 | scope :: 32 | forall expr a f. 33 | InvDeBruijnIndex a => 34 | (Int -> f # expr (Maybe a)) -> 35 | Scope expr a # f 36 | scope f = Scope (f (inverseDeBruijnIndex # (Nothing :: Maybe a))) 37 | 38 | scopeVar :: InvDeBruijnIndex a => Int -> ScopeVar expr a f 39 | scopeVar x = ScopeVar (x ^?! inverseDeBruijnIndex) 40 | -------------------------------------------------------------------------------- /test/LangATest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LangATest (test) where 4 | 5 | import qualified Control.Lens as Lens 6 | import Control.Lens.Operators 7 | import Control.Monad.ST (runST) 8 | import ExprUtils 9 | import Hyper 10 | import Hyper.Syntax.NamelessScope (EmptyScope) 11 | import Hyper.Syntax.Scheme 12 | import LangA 13 | import Test.Tasty 14 | import TypeLang 15 | 16 | import Prelude 17 | 18 | test :: TestTree 19 | test = 20 | testGroup 21 | "infer LangA" 22 | [ testA lamXYx5 "Right (∀t0(*). ∀t1(*). (Int -> t0) -> t1 -> t0)" 23 | , testA infinite "Left (t0 occurs in itself, expands to: t0 -> t1)" 24 | , testA skolem "Left (SkolemEscape: t0)" 25 | , testA validForAll "Right (∀t0(*). t0 -> t0)" 26 | , testA nomLam "Right (Map[key: Int, value: Int] -> Map[key: Int, value: Int])" 27 | ] 28 | 29 | testA :: HPlain (LangA EmptyScope) -> String -> TestTree 30 | testA p expect = 31 | testCommon expr expect pureRes stRes 32 | where 33 | expr = p ^. hPlain 34 | pureRes = execPureInferA (inferExpr expr) 35 | stRes = runST (execSTInferA (inferExpr expr)) 36 | 37 | lamXYx5 :: HPlain (LangA EmptyScope) 38 | lamXYx5 = 39 | -- λx y. x 5 40 | ALamP (ALamP (AVarP (Just Nothing) `AAppP` ALitP 5)) 41 | 42 | infinite :: HPlain (LangA EmptyScope) 43 | infinite = 44 | -- λx. x x 45 | ALamP (AVarP Nothing `AAppP` AVarP Nothing) 46 | 47 | skolem :: HPlain (LangA EmptyScope) 48 | skolem = 49 | -- λx. (x : ∀a. a) 50 | ALamP 51 | ( ATypeSigP 52 | (AVarP Nothing) 53 | (Types (QVars (mempty & Lens.at "a" ?~ mempty)) (QVars mempty)) 54 | (TVarP "a") 55 | ) 56 | 57 | validForAll :: HPlain (LangA EmptyScope) 58 | validForAll = 59 | -- (λx. x) : ∀a. a -> a 60 | ATypeSigP 61 | (ALamP (AVarP Nothing)) 62 | (Types (QVars (mempty & Lens.at "a" ?~ mempty)) (QVars mempty)) 63 | (TVarP "a" `TFunP` TVarP "a") 64 | 65 | nomLam :: HPlain (LangA EmptyScope) 66 | nomLam = 67 | -- λx. (x : Map[key: Int, value: Int]) 68 | ALamP 69 | ( ATypeSigP 70 | (AVarP Nothing) 71 | (Types (QVars mempty) (QVars mempty)) 72 | ( TNomP 73 | "Map" 74 | ( Types 75 | ( QVarInstances 76 | ( mempty 77 | & Lens.at "key" ?~ Pure TInt 78 | & Lens.at "value" ?~ Pure TInt 79 | ) 80 | ) 81 | (QVarInstances mempty) 82 | ) 83 | ) 84 | ) 85 | -------------------------------------------------------------------------------- /test/LangC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module LangC where 8 | 9 | import TypeLang (Name) 10 | 11 | import Control.Lens.Operators 12 | import Data.List.NonEmpty (NonEmpty (..), cons) 13 | import Hyper 14 | import Hyper.Class.Morph (morphMapped1) 15 | import Hyper.Recurse (wrap, (##>>)) 16 | import Hyper.Syntax 17 | import Hyper.Syntax.Row (RowExtend (..)) 18 | 19 | import Prelude 20 | 21 | -- Demonstrating de-sugaring of a sugar-language to a core language: 22 | 23 | -- * Let-expressions are replaced with redexes 24 | 25 | -- * Cases and if-else expressions are replaced with applied lambda-cases 26 | 27 | data CoreForms l h 28 | = CLit Int 29 | | CApp (App l h) 30 | | CVar (Var Name l h) 31 | | CLam (Lam Name l h) 32 | | CRecEmpty 33 | | CRecExtend (RowExtend Name l l h) 34 | | CGetField (h :# l) Name 35 | | CLamCaseEmpty 36 | | CLamCaseExtend (RowExtend Name l l h) 37 | | CInject (h :# l) Name 38 | deriving (Generic) 39 | 40 | newtype LangCore h = LangCore (CoreForms LangCore h) 41 | 42 | data IfThen h = IfThen (h :# LangSugar) (h :# LangSugar) 43 | data Case h = Case Name Name (h :# LangSugar) 44 | 45 | data LangSugar h 46 | = SBase (CoreForms LangSugar h) 47 | | SLet (Let Name LangSugar h) 48 | | SCase (h :# LangSugar) [Case h] 49 | | SIfElse (NonEmpty (IfThen h)) (h :# LangSugar) 50 | 51 | makeHMorph ''CoreForms 52 | makeHTraversableAndBases ''CoreForms 53 | makeHTraversableAndBases ''LangCore 54 | makeHTraversableAndBases ''IfThen 55 | makeHTraversableAndBases ''Case 56 | makeHTraversableAndBases ''LangSugar 57 | 58 | instance RNodes LangSugar 59 | instance RTraversable LangSugar 60 | instance c LangSugar => Recursively c LangSugar 61 | 62 | desugar :: Pure # LangSugar -> Pure # LangCore 63 | desugar (Pure body) = 64 | case body of 65 | SBase x -> 66 | -- Note how we desugar all of the base forms without any boilerplate! 67 | x & morphMapped1 %~ desugar & core 68 | SLet x -> 69 | cLam v i `cApp` e 70 | where 71 | Let v i e = x & morphMapped1 %~ desugar 72 | SCase e h -> 73 | foldr step cAbsurd h `cApp` desugar e 74 | where 75 | step (Case c v b) = cAddLamCase c (v `cLam` desugar b) 76 | SIfElse g e -> 77 | foldr step (desugar e) g 78 | where 79 | step (IfThen c t) r = 80 | cAddLamCase 81 | "True" 82 | (cLam "_" (desugar t)) 83 | (cAddLamCase "False" (cLam "_" r) cAbsurd) 84 | `cApp` desugar c 85 | where 86 | core = Pure . LangCore 87 | cApp x = core . CApp . App x 88 | cLam v = core . CLam . Lam v 89 | cAbsurd = core CLamCaseEmpty 90 | cAddLamCase c h = core . CLamCaseExtend . RowExtend c h 91 | 92 | -- Lift core language into the surface language 93 | coreToSugar :: Pure # LangCore -> Pure # LangSugar 94 | coreToSugar (Pure (LangCore x)) = x & morphMapped1 %~ coreToSugar & SBase & Pure 95 | 96 | -- Convert top-level expression to sugared form when possible 97 | sugarizeTop :: LangSugar # Pure -> LangSugar # Pure 98 | sugarizeTop top@(SBase (CApp (App (Pure (SBase func)) arg))) = 99 | case func of 100 | CLam (Lam v b) -> Let v arg b & SLet 101 | CLamCaseExtend (RowExtend c0 (Pure (SBase (CLam h0))) r0) -> 102 | go ((c0, h0) :| []) r0 103 | where 104 | go cases (Pure (SBase CLamCaseEmpty)) = 105 | case cases of 106 | ("True", t) :| [("False", f)] | checkIf t f -> makeIf t f 107 | ("False", f) :| [("True", t)] | checkIf t f -> makeIf t f 108 | _ -> 109 | cases ^.. traverse 110 | <&> (\(n, Lam v b) -> Case n v b) 111 | & SCase arg 112 | where 113 | makeIf t f = 114 | case f ^. lamOut of 115 | Pure (SIfElse is e) -> SIfElse (cons i is) e 116 | _ -> SIfElse (pure i) (f ^. lamOut) 117 | where 118 | i = IfThen arg (t ^. lamOut) 119 | go cases (Pure (SBase (CLamCaseExtend (RowExtend c (Pure (SBase (CLam h))) r)))) = 120 | go (cons (c, h) cases) r 121 | go _ _ = top 122 | checkIf t f = checkIfBranch t && checkIfBranch f 123 | checkIfBranch (Lam v b) = not (usesVar v b) 124 | _ -> top 125 | sugarizeTop x = x 126 | 127 | usesVar :: Name -> Pure # LangSugar -> Bool 128 | usesVar v (Pure (SBase (CVar (Var x)))) = v == x 129 | usesVar v (Pure x) = any (usesVar v) (x ^.. hfolded1) 130 | 131 | sugarize :: Pure # LangSugar -> Pure # LangSugar 132 | sugarize = wrap (Proxy @((~) LangSugar) ##>> Pure . sugarizeTop) 133 | -------------------------------------------------------------------------------- /test/LangD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module LangD where 5 | 6 | import Hyper 7 | 8 | newtype A i k = A (B i k) 9 | newtype B i k = B (i (k :# A i)) 10 | 11 | makeHTraversableApplyAndBases ''B 12 | makeHTraversableApplyAndBases ''A 13 | 14 | newtype C (k :: AHyperType) = C (C k) 15 | 16 | -- The following doesn't work: 17 | -- makeHNodes ''C 18 | 19 | newtype D a (h :: AHyperType) = D (a h) 20 | newtype E a (h :: AHyperType) = E (D a h) 21 | 22 | makeHTraversableAndBases ''D 23 | makeHTraversableAndBases ''E 24 | -------------------------------------------------------------------------------- /test/ReadMeExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module ReadMeExamples where 10 | 11 | import Data.Text (Text) 12 | import GHC.Generics (Generic1) 13 | import Generics.Constraints (makeDerivings) 14 | import Hyper 15 | import Hyper.Class.ZipMatch (ZipMatch) 16 | import Hyper.Diff (DiffP, diffP) 17 | import Hyper.Syntax (App, TypedLam, Var) 18 | 19 | import Prelude 20 | 21 | data Expr h 22 | = EVar Text 23 | | EApp (h :# Expr) (h :# Expr) 24 | | ELam Text (h :# Typ) (h :# Expr) 25 | deriving (Generic) 26 | 27 | data Typ h 28 | = TInt 29 | | TFunc (h :# Typ) (h :# Typ) 30 | deriving (Generic) 31 | 32 | makeDerivings [''Eq, ''Ord, ''Show] [''Expr, ''Typ] 33 | makeHTraversableAndBases ''Expr 34 | makeHTraversableAndBases ''Typ 35 | makeZipMatch ''Expr 36 | makeZipMatch ''Typ 37 | 38 | instance RNodes Expr 39 | instance RNodes Typ 40 | instance (c Expr, c Typ) => Recursively c Expr 41 | instance c Typ => Recursively c Typ 42 | instance RTraversable Expr 43 | instance RTraversable Typ 44 | 45 | data RExpr h 46 | = RVar (Var Text RExpr h) 47 | | RApp (App RExpr h) 48 | | RLam (TypedLam Text Typ RExpr h) 49 | deriving 50 | ( Generic 51 | , Generic1 52 | , HNodes 53 | , HFunctor 54 | , HFoldable 55 | , HTraversable 56 | , ZipMatch 57 | , RNodes 58 | , RTraversable 59 | ) 60 | 61 | instance (c RExpr, c Typ) => Recursively c RExpr 62 | 63 | makeHasHPlain [''Expr, ''Typ, ''RExpr] 64 | 65 | verboseExpr :: Pure # Expr 66 | verboseExpr = Pure (ELam "x" (Pure TInt) (Pure (EVar "x"))) 67 | 68 | exprA, exprB :: HPlain RExpr 69 | exprA = RLamP "x" TIntP (RVarP "x") 70 | exprB = RLamP "x" (TFuncP TIntP TIntP) (RVarP "x") 71 | 72 | d :: DiffP # RExpr 73 | d = diffP exprA exprB 74 | 75 | formatDiff :: (Show a, Show b) => w -> a -> b -> String 76 | formatDiff _ x y = "- " <> show x <> "\n+ " <> show y <> "\n" 77 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import qualified AlphaEqTest 2 | import qualified BlameTest 3 | import Control.Lens.Operators 4 | import qualified LangATest 5 | import qualified LangBTest 6 | import Test.Tasty 7 | 8 | import Prelude 9 | 10 | main :: IO () 11 | main = 12 | testGroup 13 | "Tests" 14 | [ testGroup "infer" [LangATest.test, LangBTest.test] 15 | , AlphaEqTest.test 16 | , BlameTest.test 17 | ] 18 | & defaultMain 19 | -------------------------------------------------------------------------------- /test/run-interpreted: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | runhaskell -isrc -itest -XConstraintKinds -XDataKinds -XDefaultSignatures -XDeriveGeneric -XDerivingStrategies -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XRankNTypes -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeOperators -XTypeFamilies -XNoImplicitPrelude $(dirname "$0")/Spec.hs 3 | --------------------------------------------------------------------------------