├── .ghci.repl ├── .hlint.yaml ├── .stylish-haskell.yaml ├── .vscode └── sequoia.code-snippets ├── README.md ├── cabal.project ├── hie.yaml ├── script ├── ghci-flags ├── ghci-flags-dependencies └── repl ├── sequoia.cabal ├── src └── Sequoia │ ├── Biadjunction.hs │ ├── Bicontravariant.hs │ ├── Bidistributive.hs │ ├── Bifunctor │ ├── Join.hs │ ├── Product.hs │ └── Sum.hs │ ├── Birepresentable.hs │ ├── Calculus │ ├── Additive.hs │ ├── Assertion.hs │ ├── Bottom.hs │ ├── Context.hs │ ├── Control.hs │ ├── Core.hs │ ├── Down.hs │ ├── Exists.hs │ ├── ForAll.hs │ ├── Function.hs │ ├── Iff.hs │ ├── Implicative.hs │ ├── Mu.hs │ ├── Multiplicative.hs │ ├── Negate.hs │ ├── Negation.hs │ ├── Not.hs │ ├── NotUntrue.hs │ ├── Nu.hs │ ├── One.hs │ ├── Par.hs │ ├── Quantification.hs │ ├── Recursive.hs │ ├── Shift.hs │ ├── Structural.hs │ ├── Subtraction.hs │ ├── Sum.hs │ ├── Tensor.hs │ ├── Top.hs │ ├── True.hs │ ├── Up.hs │ ├── With.hs │ ├── XOr.hs │ └── Zero.hs │ ├── Confunctor.hs │ ├── Conjunction.hs │ ├── Connective │ ├── Additive.hs │ ├── Assertion.hs │ ├── Bottom.hs │ ├── Down.hs │ ├── Exists.hs │ ├── Final.hs │ ├── ForAll.hs │ ├── Function.hs │ ├── Iff.hs │ ├── Implicative.hs │ ├── Initial.hs │ ├── Mu.hs │ ├── Multiplicative.hs │ ├── Multiplicative │ │ └── Unit.hs │ ├── Negate.hs │ ├── Negation.hs │ ├── Not.hs │ ├── NotUntrue.hs │ ├── Nu.hs │ ├── One.hs │ ├── Par.hs │ ├── Par │ │ └── Parameterized.hs │ ├── Quantification.hs │ ├── Shift.hs │ ├── Subtraction.hs │ ├── Sum.hs │ ├── Tensor.hs │ ├── Top.hs │ ├── True.hs │ ├── Up.hs │ ├── With.hs │ ├── XOr.hs │ └── Zero.hs │ ├── Cons.hs │ ├── Context.hs │ ├── Contextual.hs │ ├── DeBruijn.hs │ ├── DeBruijn │ └── Typed.hs │ ├── Disjunction.hs │ ├── Functor │ ├── Applicative.hs │ ├── C.hs │ ├── Con.hs │ ├── Continuation.hs │ ├── Cov.hs │ ├── I.hs │ ├── Sink.hs │ ├── Sink │ │ └── Internal.hs │ ├── Source.hs │ └── Source │ │ └── Internal.hs │ ├── Interpreter.hs │ ├── Interpreter │ └── Typed.hs │ ├── Lambda.hs │ ├── Line.hs │ ├── Monad │ ├── It.hs │ ├── Run.hs │ └── Trans │ │ └── It.hs │ ├── Nulladjunction.hs │ ├── Polarity.hs │ ├── Print │ ├── Class.hs │ ├── Doc.hs │ ├── Prec.hs │ ├── Printer.hs │ └── Sequent.hs │ ├── Profunctor.hs │ ├── Profunctor │ ├── Adjunction.hs │ ├── Applicative.hs │ ├── Coexponential.hs │ ├── Command.hs │ ├── Continuation.hs │ ├── Diagonal.hs │ ├── Exchange.hs │ ├── Exp.hs │ ├── Exp │ │ ├── Class.hs │ │ ├── Par.hs │ │ ├── Quantified.hs │ │ └── Void.hs │ ├── Exponential.hs │ ├── Product.hs │ ├── Recall.hs │ ├── Semiring.hs │ ├── Sum.hs │ └── Value.hs │ ├── Sequent.hs │ ├── Signal.hs │ ├── Snoc.hs │ ├── Span.hs │ ├── Spine.hs │ └── Syntax.hs └── test ├── Cons └── Test.hs ├── Line └── Test.hs └── Test.hs /.ghci.repl: -------------------------------------------------------------------------------- 1 | -- GHCI settings, collected by running cabal repl -v and checking out the flags cabal passes to ghc. 2 | -- These live here instead of script/repl for ease of commenting. 3 | -- These live here instead of .ghci so cabal repl remains unaffected. 4 | -- These live here instead of script/ghci-flags so ghcide remains unaffected. 5 | 6 | -- Basic verbosity 7 | :set -v1 8 | 9 | -- Compile to object code, write interface files. 10 | :set -fwrite-interface -fobject-code 11 | 12 | -- Disable breaking on error since it hangs on uncaught exceptions when the sandbox is disabled: https://gitlab.haskell.org/ghc/ghc/issues/17743 13 | -- This was already disabled in .ghci, but it turns out that if your user-wide .ghci file sets -fbreak-on-error, it gets overriden, so we override it back again here. 14 | :set -fno-break-on-error 15 | 16 | -- Bonus: silence “add these modules to your .cabal file” warnings for files we :load 17 | :set -Wno-missing-home-modules 18 | 19 | -- Warnings for code written in the repl 20 | :seti -Weverything 21 | :seti -Wno-all-missed-specialisations 22 | :seti -Wno-implicit-prelude 23 | :seti -Wno-missed-specialisations 24 | :seti -Wno-missing-import-lists 25 | :seti -Wno-missing-local-signatures 26 | :seti -Wno-monomorphism-restriction 27 | :seti -Wno-name-shadowing 28 | :seti -Wno-safe 29 | :seti -Wno-unsafe 30 | -- 8.8+ 31 | :seti -Wno-missing-deriving-strategies 32 | -- 8.10+ 33 | :seti -Wno-missing-safe-haskell-mode 34 | :seti -Wno-prepositive-qualified-module 35 | -- 9.2+ 36 | :seti -Wno-missing-kind-signatures 37 | :seti -Wno-operator-whitespace 38 | 39 | -- We have this one on in the project but not in the REPL to reduce noise 40 | :seti -Wno-missing-signatures 41 | :seti -Wno-type-defaults 42 | :set -Wno-unused-packages 43 | 44 | :load Sequoia.Sequent Sequoia.Print.Doc Sequoia.Print.Printer Sequoia.Interpreter Sequoia.Interpreter.Typed test/Test.hs 45 | 46 | import Sequoia.Sequent 47 | import Sequoia.Interpreter.Typed 48 | import Main 49 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # Iso 2 | - fixity: infix 1 <-> 3 | 4 | # Disj 5 | - fixity: infix 3 <--> 6 | 7 | # Conj 8 | - fixity: infix 4 -><- 9 | 10 | # Continuation 11 | - fixity: infixl 8 • 12 | 13 | # Value 14 | - fixity: infixl 9 ∘ 15 | 16 | # Seq/Snk/Src 17 | - fixity: infixl 3 ↑ 18 | - fixity: infixl 2 ↓ 19 | 20 | # Control context 21 | - fixity: infixl 1 <== 22 | 23 | # Composition 24 | - fixity: infixr 1 •<< 25 | - fixity: infixr 1 >>• 26 | - fixity: infixr 1 ∘<< 27 | - fixity: infixr 1 >>∘ 28 | 29 | # Env/Res 30 | - fixity: infixl 9 •∘ 31 | - fixity: infixl 8 •• 32 | 33 | 34 | - warn: {name: "Double-negate", lhs: "K (• a)", rhs: "dn a", side: "subst K == K"} 35 | - warn: {name: "Use lmap/compose", lhs: "K ((k •) . f)", rhs: "k <<^ f", side: "subst K == K"} 36 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | 7 | - imports: 8 | align: file 9 | list_align: after_alias 10 | pad_module_names: false 11 | long_list_align: new_line_multiline 12 | empty_list_align: inherit 13 | list_padding: 2 14 | separate_lists: false 15 | space_surround: false 16 | 17 | - language_pragmas: 18 | style: vertical 19 | align: false 20 | remove_redundant: true 21 | 22 | - tabs: 23 | spaces: 2 24 | 25 | - trailing_whitespace: {} 26 | 27 | columns: 240 28 | 29 | newline: native 30 | 31 | language_extensions: 32 | - FlexibleContexts 33 | - MultiParamTypeClasses 34 | -------------------------------------------------------------------------------- /.vscode/sequoia.code-snippets: -------------------------------------------------------------------------------- 1 | { 2 | "ring": { 3 | "scope": "haskell", 4 | "prefix": "ring", 5 | "body": [ 6 | "∘" 7 | ], 8 | "description": "ring operator" 9 | }, 10 | "up": { 11 | "scope": "haskell", 12 | "prefix": "up", 13 | "body": [ 14 | "↑" 15 | ], 16 | "description": "up arrow" 17 | }, 18 | "down": { 19 | "scope": "haskell", 20 | "prefix": "down", 21 | "body": [ 22 | "↓" 23 | ], 24 | "description": "down arrow" 25 | }, 26 | "par": { 27 | "scope": "haskell", 28 | "prefix": "par", 29 | "body": [ 30 | "⅋" 31 | ], 32 | "description": "par operator" 33 | }, 34 | "tensor": { 35 | "scope": "haskell", 36 | "prefix": "tensor", 37 | "body": [ 38 | "⊗" 39 | ], 40 | "description": "tensor operator" 41 | }, 42 | "sum": { 43 | "scope": "haskell", 44 | "prefix": "sum", 45 | "body": [ 46 | "⊕" 47 | ], 48 | "description": "sum operator" 49 | }, 50 | "turnstile": { 51 | "scope": "haskell", 52 | "prefix": "turnstile", 53 | "body": [ 54 | "⊢" 55 | ], 56 | "description": "turnstile operator" 57 | }, 58 | "Gamma": { 59 | "scope": "haskell", 60 | "prefix": "Gamma", 61 | "body": [ 62 | "Γ" 63 | ], 64 | "description": "uppercase gamma" 65 | }, 66 | "Delta": { 67 | "scope": "haskell", 68 | "prefix": "Delta", 69 | "body": [ 70 | "Δ" 71 | ], 72 | "description": "uppercase delta" 73 | } 74 | // Place your sequoia workspace snippets here. Each snippet is defined under a snippet name and has a scope, prefix, body and 75 | // description. Add comma separated ids of the languages where the snippet is applicable in the scope field. If scope 76 | // is left empty or omitted, the snippet gets applied to all languages. The prefix is what is 77 | // used to trigger the snippet and the body will be expanded and inserted. Possible variables are: 78 | // $1, $2 for tab stops, $0 for the final cursor position, and ${1:label}, ${2:another} for placeholders. 79 | // Placeholders with the same ids are connected. 80 | // Example: 81 | // "Print to console": { 82 | // "scope": "javascript,typescript", 83 | // "prefix": "log", 84 | // "body": [ 85 | // "console.log('$1');", 86 | // "$2" 87 | // ], 88 | // "description": "Log output to console" 89 | // } 90 | } 91 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sequoia 2 | 3 | Sequoia is an implementation of classical logic in a sequent calculus, embedded in intuitionistic logic. It is implemented as a Haskell EDSL, and is fairly full-featured, if sparsely documented (at best). 4 | 5 | Sequoia is experimental; do not use it to pilot spacecraft, unless you really, really want to. 6 | 7 | 8 | ## Sequent calculus 9 | 10 | A sequent states that, together, all the things to the left of the ⊢ symbol (called turnstile, pronounced “proves”) suffice to prove at least one of the things on the right: 11 | 12 | > all of these → Γ ⊢ Δ ← prove some of these 13 | 14 | The elements of Γ are treated conjunctively (hence all), while the elements of Δ are treated disjunctively. Computationally, we interpret ⊢ as a kind of function, Γ as a kind of sequence, and Δ as a kind of choice, and thus we can think of Γ as inputs and Δ as outputs. 15 | 16 | Sequents are rarely seen alone, however, and instead are grouped with premises written above a line (the “line of inference”) to make rules, like this rule I’ll name “dull”: 17 | 18 | > Γ ⊢ Δ\ 19 | > ——— dull\ 20 | > Γ ⊢ Δ 21 | 22 | Typically we read these bottom-up; this says “to infer that Γ proves Δ, we must prove that Γ proves Δ.” (This is true, though not particularly helpful.) 23 | 24 | Axioms are rules which can be employed without any further premises. For example the `init` rule states that an input in Γ can become an output in Δ: 25 | 26 | > —————— init\ 27 | > A, Γ ⊢ Δ, A 28 | 29 | Rules take premises to conclusions (the sequent underneath the line), and thus the line of inference can be understood as another kind of function arrow, mapping zero or more premise sequents to a conclusion sequent. And since sequents are themselves a kind of function, mapping hypotheses to consequents, we can see that sequent calculus proofs correspond with higher-order functional programs. 30 | 31 | For that reason, sequoia can map rules like `init` straightforwardly onto functions like `id`, and the implementation further takes full advantage of the relationship beween the sequent calculus and continuation-passing style to provide a full suite of polarized connectives (datatypes corresponding to logical operators), including positive and negative falsities, truths, disjunctions, conjunctions, implications, quantifiers, etc. 32 | 33 | Furthermore, sequoia offers introduction and elimination rules for aach connective, grouped together into a typeclass. (This is done to allow for different sets of rules, even for the same connectives, to be used for e.g. linear logics, altho I haven’t implemented this yet.) The built-in type `Seq` in `Sequoia.Sequent` implements all of them. Inverses are also available where provable, as are many algebraic properties for the connectives. 34 | 35 | It is possible to perform effects, but this hasn’t been explored much yet. However, you’ve got the full power of call/CC available, not to mention delimited continuations (`Sequoia.Calculus.Control`), and while it isn’t particularly convenient at the moment, there’s even a monad transformer to lift actions into sequents. 36 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: True 3 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./src" 4 | component: "lib:sequoia" 5 | - path: "./test" 6 | component: "test:sequoia:test" 7 | -------------------------------------------------------------------------------- /script/ghci-flags: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Computes the flags for ghcide to pass to ghci. You probably won’t be running this yourself, but rather ghcide will via configuration in hie.yaml. 3 | 4 | set -e 5 | 6 | cd "$(dirname "$0")/.." 7 | 8 | ghc_version="$(ghc --numeric-version)" 9 | 10 | build_dir="dist-newstyle/build/x86_64-osx/ghc-$ghc_version" 11 | build_products_dir="$build_dir/build-repl" 12 | 13 | cores=$(sysctl -n machdep.cpu.core_count || echo 4) 14 | 15 | # disable optimizations for faster loading 16 | echo "-O0" 17 | # don’t load .ghci files (for ghcide) 18 | echo "-ignore-dot-ghci" 19 | 20 | # use as many jobs as there are physical cores 21 | echo "-j$((cores + 1))" 22 | 23 | # where to put build products 24 | echo "-outputdir $build_products_dir" 25 | echo "-odir $build_products_dir" 26 | echo "-hidir $build_products_dir" 27 | echo "-stubdir $build_products_dir" 28 | 29 | # preprocessor options, for -XCPP 30 | echo "-optP-include" 31 | echo "-optP$build_dir/sequoia-0.0.0.0/build/autogen/cabal_macros.h" 32 | 33 | # autogenerated sources, both .hs and .h (e.g. Foo_paths.hs) 34 | echo "-i$build_dir/sequoia-0.0.0.0/build/autogen" 35 | echo "-I$build_dir/sequoia-0.0.0.0/build/autogen" 36 | 37 | # .hs source dirs 38 | echo "-isrc" 39 | echo "-itest" 40 | 41 | # disable automatic selection of packages 42 | echo "-hide-all-packages" 43 | 44 | # run cabal and emit package flags from the environment file, removing comments & prefixing with - 45 | cabal v2-exec -v0 bash -- -c 'cat "$GHC_ENVIRONMENT"' | grep -v '^--' | sed -e 's/^/-/' 46 | 47 | # default language extensions 48 | echo "-XHaskell2010" 49 | 50 | # treat warnings as warnings 51 | echo "-Wwarn" 52 | 53 | # default warning flags 54 | echo "-Weverything" 55 | echo "-Wno-all-missed-specialisations" 56 | echo "-Wno-implicit-prelude" 57 | echo "-Wno-missed-specialisations" 58 | echo "-Wno-missing-import-lists" 59 | echo "-Wno-missing-local-signatures" 60 | echo "-Wno-monomorphism-restriction" 61 | echo "-Wno-name-shadowing" 62 | echo "-Wno-safe" 63 | echo "-Wno-unsafe" 64 | [[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true 65 | [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" 66 | [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" && echo "-Wno-operator-whitespace" 67 | 68 | echo "-XDeriveTraversable" 69 | echo "-XDerivingStrategies" 70 | echo "-XDerivingVia" 71 | echo "-XDisambiguateRecordFields" 72 | echo "-XDuplicateRecordFields" 73 | echo "-XEmptyCase" 74 | echo "-XFlexibleContexts" 75 | echo "-XFlexibleInstances" 76 | echo "-XGeneralizedNewtypeDeriving" 77 | echo "-XKindSignatures" 78 | echo "-XLambdaCase" 79 | echo "-XMultiParamTypeClasses" 80 | echo "-XMultiWayIf" 81 | echo "-XNamedFieldPuns" 82 | echo "-XNoStarIsType" 83 | echo "-XRankNTypes" 84 | echo "-XStandaloneDeriving" 85 | echo "-XTupleSections" 86 | echo "-XTypeApplications" 87 | echo "-XTypeOperators" 88 | echo "-XViewPatterns" 89 | -------------------------------------------------------------------------------- /script/ghci-flags-dependencies: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Computes the paths to files causing changes to the ghci flags. You probably won’t be running this yourself, but rather ghcide will via configuration in hie.yaml. 3 | 4 | set -e 5 | 6 | cd $(dirname "$0")/.. 7 | 8 | echo "cabal.project" 9 | 10 | echo "sequoia.cabal" 11 | -------------------------------------------------------------------------------- /script/repl: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Usage: script/repl [ARGS...] 3 | # Run a repl session capable of loading all of the components. Any passed arguments, e.g. module names or flags, will be passed to ghci. 4 | 5 | set -e 6 | 7 | cd "$(dirname "$0")/.." 8 | 9 | # cabal v2-build all --only-dependencies 10 | 11 | cores=$(sysctl -n machdep.cpu.core_count || echo 4) 12 | env facet_datadir=. cabal v2-exec env -- -u GHC_ENVIRONMENT ghci +RTS -N$((cores + 1)) -RTS -ghci-script=.ghci.repl $(script/ghci-flags) -no-ignore-dot-ghci $@ 13 | -------------------------------------------------------------------------------- /src/Sequoia/Biadjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Sequoia.Biadjunction 3 | ( -- * Biadjunctions 4 | Biadjunction(..) 5 | -- * Defaults 6 | , bileftAdjunctDisjConj 7 | , birightAdjunctDisjConj 8 | , leftAdjunctBiadjunction 9 | , rightAdjunctBiadjunction 10 | ) where 11 | 12 | import Data.Bifunctor 13 | import Sequoia.Bifunctor.Join 14 | import Sequoia.Birepresentable 15 | import Sequoia.Conjunction 16 | import Sequoia.Disjunction 17 | 18 | -- Biadjunctions 19 | 20 | class (Bifunctor f, Birepresentable u) => Biadjunction f u | f -> u, u -> f where 21 | bileftAdjunct :: (f a a -> b) -> (a -> u b b) 22 | birightAdjunct :: (a -> u b b) -> (f a a -> b) 23 | 24 | instance Biadjunction Either (,) where 25 | bileftAdjunct f = f . inl >---< f . inr 26 | birightAdjunct f = exl . f <--> exr . f 27 | 28 | 29 | -- Defaults 30 | 31 | bileftAdjunctDisjConj :: (Disj f, Conj u) => (f a a -> b) -> (a -> u b b) 32 | bileftAdjunctDisjConj f = f . inl >---< f . inr 33 | 34 | birightAdjunctDisjConj :: (Disj f, Conj u) => (a -> u b b) -> (f a a -> b) 35 | birightAdjunctDisjConj f = exl . f <--> exr . f 36 | 37 | leftAdjunctBiadjunction :: Biadjunction f u => (Join f a -> b) -> (a -> Join u b) 38 | leftAdjunctBiadjunction f = Join . bileftAdjunct (f . Join) 39 | 40 | rightAdjunctBiadjunction :: Biadjunction f u => (a -> Join u b) -> (Join f a -> b) 41 | rightAdjunctBiadjunction f = birightAdjunct (runJoin . f) . runJoin 42 | -------------------------------------------------------------------------------- /src/Sequoia/Bicontravariant.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Bicontravariant 2 | ( -- * Bicontravariant functors 3 | Bicontravariant(..) 4 | , contrafirst 5 | , contrasecond 6 | -- * Coercion 7 | , biphantom 8 | , lphantom 9 | , rphantom 10 | , bivacuous 11 | , firstvacuous 12 | , secondvacuous 13 | , contravacuous 14 | , contrabivacuous 15 | , contrafirstvacuous 16 | , contrasecondvacuous 17 | , divacuous 18 | , lvacuous 19 | , rvacuous 20 | ) where 21 | 22 | import Data.Bifunctor 23 | import Data.Functor.Contravariant 24 | import Data.Profunctor 25 | import Data.Void 26 | 27 | -- Bicontravariant functors 28 | 29 | class Bicontravariant p where 30 | contrabimap :: (a' -> a) -> (b' -> b) -> a `p` b -> a' `p` b' 31 | 32 | instance Bicontravariant (Forget r) where 33 | contrabimap f _ = Forget . lmap f . runForget 34 | 35 | contrafirst :: Bicontravariant p => (a' -> a) -> a `p` b -> a' `p` b 36 | contrafirst = (`contrabimap` id) 37 | 38 | contrasecond :: Bicontravariant p => (b' -> b) -> a `p` b -> a `p` b' 39 | contrasecond = (id `contrabimap`) 40 | 41 | 42 | -- Coercion 43 | 44 | biphantom :: (Bifunctor p, Bicontravariant p) => p a b -> p c d 45 | biphantom = bivacuous . contrabivacuous 46 | 47 | lphantom :: (Profunctor p, Bifunctor p) => p a b -> p c b 48 | lphantom = firstvacuous . lvacuous 49 | 50 | rphantom :: (Profunctor p, Bicontravariant p) => p a b -> p a c 51 | rphantom = rvacuous . contrasecondvacuous 52 | 53 | bivacuous :: Bifunctor p => p Void Void -> p a b 54 | bivacuous = bimap absurd absurd 55 | 56 | firstvacuous :: Bifunctor p => p Void b -> p a b 57 | firstvacuous = first absurd 58 | 59 | secondvacuous :: Bifunctor p => p a Void -> p a b 60 | secondvacuous = second absurd 61 | 62 | contravacuous :: Contravariant f => f a -> f Void 63 | contravacuous = contramap absurd 64 | 65 | contrabivacuous :: Bicontravariant p => p a b -> p Void Void 66 | contrabivacuous = contrabimap absurd absurd 67 | 68 | contrafirstvacuous :: Bicontravariant p => p a b -> p Void b 69 | contrafirstvacuous = contrafirst absurd 70 | 71 | contrasecondvacuous :: Bicontravariant p => p a b -> p a Void 72 | contrasecondvacuous = contrasecond absurd 73 | 74 | divacuous :: Profunctor p => p a Void -> p Void b 75 | divacuous = dimap absurd absurd 76 | 77 | lvacuous :: Profunctor p => p a b -> p Void b 78 | lvacuous = lmap absurd 79 | 80 | rvacuous :: Profunctor p => p a Void -> p a b 81 | rvacuous = rmap absurd 82 | -------------------------------------------------------------------------------- /src/Sequoia/Bidistributive.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Bidistributive 2 | ( -- * Bidistributive 3 | Bidistributive(..) 4 | ) where 5 | 6 | import Data.Bifunctor 7 | 8 | class Bifunctor p => Bidistributive p where 9 | {-# MINIMAL bidistribute | bicollect #-} 10 | 11 | bidistribute :: Functor f => f (p b c) -> p (f b) (f c) 12 | bidistribute = bicollect id 13 | 14 | bicollect :: Functor f => (a -> p b c) -> f a -> p (f b) (f c) 15 | bicollect f = bidistribute . fmap f 16 | 17 | instance Bidistributive (,) where 18 | bidistribute g = (fst <$> g, snd <$> g) 19 | bicollect f g = (fst . f <$> g, snd . f <$> g) 20 | -------------------------------------------------------------------------------- /src/Sequoia/Bifunctor/Join.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Bifunctor.Join 3 | ( Join(..) 4 | ) where 5 | 6 | import Data.Bifoldable 7 | import Data.Bifunctor 8 | import Data.Bitraversable 9 | import Data.Distributive 10 | import Data.Functor.Contravariant 11 | import Data.Functor.Rep 12 | import Sequoia.Bicontravariant 13 | import Sequoia.Bidistributive 14 | import Sequoia.Birepresentable 15 | 16 | newtype Join p a = Join { runJoin :: p a a } 17 | 18 | instance Bifoldable p => Foldable (Join p) where 19 | foldMap f = bifoldMap f f . runJoin 20 | 21 | instance Bifunctor p => Functor (Join p) where 22 | fmap f = Join . bimap f f . runJoin 23 | 24 | instance Bicontravariant p => Contravariant (Join p) where 25 | contramap f = Join . contrabimap f f . runJoin 26 | 27 | instance Bitraversable p => Traversable (Join p) where 28 | traverse f = fmap Join . bitraverse f f . runJoin 29 | 30 | instance Bidistributive p => Distributive (Join p) where 31 | distribute g = Join (bidistribute (runJoin <$> g)) 32 | collect f g = Join (bicollect (runJoin . f) g) 33 | 34 | instance Birepresentable p => Representable (Join p) where 35 | type Rep (Join p) = Birep p 36 | tabulate f = Join (bitabulate f f) 37 | index = fmap (either id id) . biindex . runJoin 38 | -------------------------------------------------------------------------------- /src/Sequoia/Bifunctor/Product.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Bifunctor.Product 2 | ( -- * Product type 3 | type (×)(..) 4 | -- * Construction 5 | , inP 6 | -- * Elimination 7 | , runP 8 | , exPl 9 | , exPr 10 | ) where 11 | 12 | import Control.Applicative (liftA2) 13 | import Data.Bifoldable 14 | import Data.Bifunctor 15 | import Data.Bitraversable 16 | 17 | -- Product type 18 | 19 | newtype a × b = P { getP :: forall t . (a -> b -> t) -> t } 20 | deriving (Functor) 21 | 22 | infixr 7 × 23 | 24 | instance Bifoldable (×) where 25 | bifoldMap f g = runP (\ a b -> f a <> g b) 26 | 27 | instance Bifunctor (×) where 28 | bimap f g p = P (\ lr -> runP (\ l r -> lr (f l) (g r)) p) 29 | 30 | instance Bitraversable (×) where 31 | bitraverse f g = runP (\ l r -> liftA2 inP (f l) (g r)) 32 | 33 | 34 | -- Construction 35 | 36 | inP :: a -> b -> a × b 37 | inP a b = P (\ f -> f a b) 38 | 39 | 40 | -- Elimination 41 | 42 | runP :: (a -> b -> s) -> (a × b -> s) 43 | runP f p = getP p f 44 | 45 | exPl :: a × b -> a 46 | exPl = runP const 47 | 48 | exPr :: a × b -> b 49 | exPr = runP (const id) 50 | -------------------------------------------------------------------------------- /src/Sequoia/Bifunctor/Sum.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Bifunctor.Sum 2 | ( -- * Sum type 3 | type (+)(..) 4 | -- * Construction 5 | , inSl 6 | , inSr 7 | -- * Elimination 8 | , runS 9 | ) where 10 | 11 | import Data.Bifoldable 12 | import Data.Bifunctor 13 | import Data.Bitraversable 14 | 15 | -- Sum type 16 | 17 | newtype a + b = S { getS :: forall t . (a -> t) -> (b -> t) -> t } 18 | deriving (Functor) 19 | 20 | infixr 6 + 21 | 22 | instance Bifoldable (+) where 23 | bifoldMap f g = runS f g 24 | 25 | instance Bifunctor (+) where 26 | bimap f g s = S (\ l r -> runS (l . f) (r . g) s) 27 | 28 | instance Bitraversable (+) where 29 | bitraverse f g = runS (fmap inSl . f) (fmap inSr . g) 30 | 31 | 32 | -- Construction 33 | 34 | inSl :: a -> a + b 35 | inSl a = S (\ l _ -> l a) 36 | 37 | inSr :: b -> a + b 38 | inSr b = S (\ _ r -> r b) 39 | 40 | 41 | -- Elimination 42 | 43 | runS :: (a -> t) -> (b -> t) -> (a + b -> t) 44 | runS f g s = getS s f g 45 | -------------------------------------------------------------------------------- /src/Sequoia/Birepresentable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Birepresentable 3 | ( -- * Birepresentable functors 4 | Birepresentable(..) 5 | ) where 6 | 7 | import Sequoia.Bidistributive 8 | 9 | class Bidistributive p => Birepresentable p where 10 | type Birep p 11 | bitabulate :: (Birep p -> a) -> (Birep p -> b) -> p a b 12 | biindex :: p a b -> (Birep p -> Either a b) 13 | 14 | instance Birepresentable (,) where 15 | type Birep (,) = Bool 16 | bitabulate f g = (f False, g True) 17 | biindex p = \case 18 | False -> Left (fst p) 19 | True -> Right (snd p) 20 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Additive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Additive 3 | ( -- * Additive rules 4 | AdditiveIntro 5 | , withLSum 6 | , sumLWith 7 | -- * Re-exports 8 | , module Sequoia.Calculus.Top 9 | , module Sequoia.Calculus.Zero 10 | , module Sequoia.Calculus.With 11 | , module Sequoia.Calculus.Sum 12 | ) where 13 | 14 | import Prelude hiding (init) 15 | import Sequoia.Calculus.Context 16 | import Sequoia.Calculus.Core 17 | import Sequoia.Calculus.Negation 18 | import Sequoia.Calculus.Structural 19 | import Sequoia.Calculus.Sum 20 | import Sequoia.Calculus.Top 21 | import Sequoia.Calculus.With 22 | import Sequoia.Calculus.Zero 23 | import Sequoia.Polarity 24 | 25 | type AdditiveIntro s = (TopIntro s, ZeroIntro s, WithIntro s, SumIntro s) 26 | 27 | withLSum 28 | :: (Weaken s, SumIntro s, WithIntro s, NegateIntro s, Neg a, Neg b) 29 | => _Γ ⊣s e r⊢ _Δ > Negate e a r ⊕ Negate e b r 30 | -- ----------------------------------------------------- 31 | -> a & b < _Γ ⊣s e r⊢ _Δ 32 | withLSum s = wkL s >>> sumL (negateL (withL1 init)) (negateL (withL2 init)) 33 | 34 | sumLWith 35 | :: (Weaken s, Exchange s, SumIntro s, WithIntro s, NotIntro s, Pos a, Pos b) 36 | => _Γ ⊣s e r⊢ _Δ > a ¬ r & b ¬ r 37 | -- --------------------------------------- 38 | -> a ⊕ b < _Γ ⊣s e r⊢ _Δ 39 | sumLWith s = wkL s >>> exL (sumL (exL (withL1 (notL init))) (exL (withL2 (notL init)))) 40 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Assertion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Assertion 3 | ( -- * Assertion 4 | AssertionIntro 5 | -- * Re-exports 6 | , module Sequoia.Calculus.NotUntrue 7 | , module Sequoia.Calculus.True 8 | ) where 9 | 10 | import Sequoia.Calculus.NotUntrue 11 | import Sequoia.Calculus.True 12 | 13 | type AssertionIntro s = (NotUntrueIntro s, TrueIntro s) 14 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Bottom.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Bottom 2 | ( -- * Bottom 3 | BottomIntro(..) 4 | , botR' 5 | -- * Connectives 6 | , module Sequoia.Connective.Bottom 7 | ) where 8 | 9 | import Sequoia.Calculus.Context 10 | import Sequoia.Calculus.Core 11 | import Sequoia.Connective.Bottom 12 | 13 | -- Bottom 14 | 15 | class Core s => BottomIntro s where 16 | botL 17 | -- -------------------------- 18 | :: Bottom r < _Γ ⊣s e r⊢ _Δ 19 | 20 | botR 21 | :: _Γ ⊣s e r⊢ _Δ 22 | -- -------------------------- 23 | -> _Γ ⊣s e r⊢ _Δ > Bottom r 24 | 25 | 26 | botR' 27 | :: BottomIntro s 28 | => _Γ ⊣s e r⊢ _Δ > Bottom r 29 | -- -------------------------- 30 | -> _Γ ⊣s e r⊢ _Δ 31 | botR' = (>>> botL) 32 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | module Sequoia.Calculus.Context 3 | ( -- * Γ 4 | type (<)(..) 5 | , (<|) 6 | , unconsΓ 7 | , consΓ 8 | -- * Δ 9 | , type (>)(..) 10 | , (|>) 11 | , unsnocΔ 12 | , snocΔ 13 | -- * Mixfix syntax 14 | , type (⊢) 15 | , type (⊣) 16 | ) where 17 | 18 | import Control.Applicative (liftA2) 19 | import Control.Monad (ap) 20 | import Data.Bifoldable 21 | import Data.Bifunctor 22 | import Data.Bitraversable 23 | import Fresnel.Iso 24 | import Sequoia.Conjunction 25 | import Sequoia.Disjunction 26 | import Sequoia.Profunctor.Continuation 27 | import Sequoia.Profunctor.Value as V 28 | 29 | -- Γ 30 | 31 | data a < b = a :< b 32 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 33 | 34 | infixr 4 <, :<, <| 35 | 36 | instance Conj (<) where 37 | (>--<) = (:<) 38 | (>---<) = liftA2 (:<) 39 | exl (a :< _) = a 40 | exr (_ :< b) = b 41 | 42 | instance Bifoldable (<) where 43 | bifoldMap = bifoldMapConj 44 | 45 | instance Bifunctor (<) where 46 | bimap = bimapConj 47 | 48 | instance Bitraversable (<) where 49 | bitraverse = bitraverseConj 50 | 51 | -- | Prepend a value onto a '<'-context. 52 | -- 53 | -- This is left- and right-inverse to 'unconsΓ': 54 | -- 55 | -- @ 56 | -- 'uncurry' ('<|') . 'unconsΓ' = 'id' 57 | -- @ 58 | -- @ 59 | -- 'unconsΓ' . 'uncurry' ('<|') = 'id' 60 | -- @ 61 | (<|) :: e ∘ i -> e ∘ is -> e ∘ (i < is) 62 | (<|) = (>∘∘<) 63 | 64 | -- | Split a '<'-context into its head and tail. 65 | -- 66 | -- This is left- and right-inverse to '<|': 67 | -- 68 | -- @ 69 | -- 'unconsΓ' . 'uncurry' ('<|') = 'id' 70 | -- @ 71 | -- @ 72 | -- 'uncurry' ('<|') . 'unconsΓ' = 'id' 73 | -- @ 74 | unconsΓ :: e ∘ (a < b) -> (e ∘ a, e ∘ b) 75 | unconsΓ v = (exlF v, exrF v) 76 | 77 | consΓ :: Iso 78 | (e ∘ (i < is)) (e' ∘ (i' < is')) 79 | (e ∘ i, e ∘ is) (e' ∘ i', e' ∘ is') 80 | consΓ = iso unconsΓ (uncurry (<|)) 81 | 82 | 83 | -- Δ 84 | 85 | data a > b 86 | = L a 87 | | R b 88 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 89 | 90 | infixl 4 >, |> 91 | 92 | instance DisjIn (>) where 93 | inl = L 94 | inr = R 95 | 96 | instance DisjEx (>) where 97 | f <--> g = \case 98 | L a -> f a 99 | R b -> g b 100 | 101 | instance Bifoldable (>) where 102 | bifoldMap = bifoldMapDisj 103 | 104 | instance Bifunctor (>) where 105 | bimap = bimapDisj 106 | 107 | instance Bitraversable (>) where 108 | bitraverse = bitraverseDisj 109 | 110 | instance Applicative ((>) a) where 111 | pure = R 112 | (<*>) = ap 113 | 114 | instance Monad ((>) a) where 115 | (>>=) = flip (inl <-->) 116 | 117 | -- | Discrimination of continuations in '>'. 118 | -- 119 | -- @¬A ✕ ¬B -> ¬(A + B)@ 120 | -- 121 | -- This is left- and right-inverse to 'unsnocΔ': 122 | -- 123 | -- @ 124 | -- 'uncurry' ('|>') . 'unsnocΔ' = id 125 | -- @ 126 | -- @ 127 | -- 'unsnocΔ' . 'uncurry' ('|>') = id 128 | -- @ 129 | (|>) :: os • r -> o • r -> (os > o) • r 130 | (|>) = (<••>) 131 | 132 | -- | Split a '>'-context into its initial and last parts. 133 | -- 134 | -- This is left- and right-inverse to 'unsnocΔ': 135 | -- 136 | -- @ 137 | -- 'uncurry' ('|>') . 'unsnocΔ' = id 138 | -- @ 139 | -- @ 140 | -- 'unsnocΔ' . 'uncurry' ('|>') = id 141 | -- @ 142 | unsnocΔ :: (a > b) • r -> (a • r, b • r) 143 | unsnocΔ k = (inlL k, inrL k) 144 | 145 | snocΔ :: Iso 146 | ((os > o) • r) ((os' > o') • r') 147 | (os • r, o • r) (os' • r', o' • r') 148 | snocΔ = iso unsnocΔ (uncurry (|>)) 149 | 150 | 151 | -- Mixfix syntax 152 | 153 | type l ⊢ r = l r 154 | type l ⊣ r = r l 155 | 156 | infixl 2 ⊣, ⊢ 157 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Control.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Control 2 | ( -- * Local environments 3 | Environment(..) 4 | -- * Values 5 | , vL 6 | , vR 7 | , vL' 8 | , vR' 9 | -- * Delimited control 10 | , Control(..) 11 | -- * Continuations 12 | , kL 13 | , kR 14 | , kL' 15 | , kR' 16 | ) where 17 | 18 | import Control.Monad (join) 19 | import Data.Profunctor 20 | import Prelude hiding (init) 21 | import Sequoia.Calculus.Context 22 | import Sequoia.Calculus.Core 23 | import Sequoia.Calculus.Structural 24 | import Sequoia.Contextual 25 | import Sequoia.Profunctor.Command 26 | import Sequoia.Profunctor.Continuation 27 | import Sequoia.Profunctor.Value 28 | 29 | -- Local environments 30 | 31 | class Environment s where 32 | environment 33 | -- ----------------- 34 | :: _Γ ⊣s e r⊢ _Δ > e 35 | 36 | withEnv 37 | :: _Γ ⊣s e r⊢ _Δ > e' -> _Γ ⊣s e' r⊢ _Δ 38 | -- ---------------------------------------- 39 | -> _Γ ⊣s e r⊢ _Δ 40 | 41 | 42 | -- Values 43 | 44 | vL 45 | :: Contextual s 46 | => a < _Γ ⊣s e r⊢ _Δ 47 | -- --------------------- 48 | -> e ∘ a < _Γ ⊣s e r⊢ _Δ 49 | vL = mapL join 50 | 51 | vR 52 | :: Contextual s 53 | => _Γ ⊣s e r⊢ _Δ > a 54 | -- --------------------- 55 | -> _Γ ⊣s e r⊢ _Δ > e ∘ a 56 | -- FIXME: this should preserve extant dependency on the env 57 | vR = mapR (lmap pure) 58 | 59 | vL' 60 | :: (Contextual s, Exchange s, Weaken s) 61 | => e ∘ a < _Γ ⊣s e r⊢ _Δ 62 | -- --------------------- 63 | -> a < _Γ ⊣s e r⊢ _Δ 64 | vL' s = vR init >>> wkL' s 65 | 66 | vR' 67 | :: (Contextual s, Exchange s, Weaken s) 68 | => _Γ ⊣s e r⊢ _Δ > e ∘ a 69 | -- --------------------- 70 | -> _Γ ⊣s e r⊢ _Δ > a 71 | vR' s = wkR' s >>> vL init 72 | 73 | 74 | -- Delimited control 75 | 76 | class Control s where 77 | reset 78 | :: _Γ ⊣s e _Δ⊢ _Δ 79 | -- -------------- 80 | -> _Γ ⊣s e r ⊢ _Δ 81 | 82 | shift 83 | :: a • r < _Γ ⊣s e r⊢ _Δ > r 84 | -- ------------------------- 85 | -> _Γ ⊣s e r⊢ _Δ > a 86 | 87 | 88 | -- Continuations 89 | 90 | kL 91 | :: Contextual s 92 | => _Γ ⊣s e r⊢ _Δ > a 93 | -- ------------------------- 94 | -> a • r < _Γ ⊣s e r⊢ _Δ 95 | kL = popL . val . pushR 96 | 97 | kR 98 | :: (Contextual s, Weaken s) 99 | => a < _Γ ⊣s e r⊢ _Δ 100 | -- ------------------------- 101 | -> _Γ ⊣s e r⊢ _Δ > a • r 102 | kR s = lowerL (pushL init . pure) (wkR s) 103 | 104 | kL' 105 | :: (Contextual s, Weaken s) 106 | => a • r < _Γ ⊣s e r⊢ _Δ 107 | -- ------------------------- 108 | -> _Γ ⊣s e r⊢ _Δ > a 109 | kL' s = kR init >>> wkR s 110 | 111 | kR' 112 | :: (Contextual s, Weaken s) 113 | => _Γ ⊣s e r⊢ _Δ > a • r 114 | -- ------------------------- 115 | -> a < _Γ ⊣s e r⊢ _Δ 116 | kR' s = wkL s >>> kL init 117 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Core.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Core 2 | ( -- * Core 3 | Core(..) 4 | ) where 5 | 6 | import Sequoia.Calculus.Context 7 | 8 | -- Core 9 | 10 | class Core s where 11 | {-# MINIMAL ((>>>) | (<<<)), init #-} 12 | 13 | (>>>) 14 | :: _Γ ⊣s e r⊢ _Δ > a -> a < _Γ ⊣s e r⊢ _Δ 15 | -- ---------------------------------------------- 16 | -> _Γ ⊣s e r⊢ _Δ 17 | (>>>) = flip (<<<) 18 | 19 | (<<<) 20 | :: a < _Γ ⊣s e r⊢ _Δ -> _Γ ⊣s e r⊢ _Δ > a 21 | -- ---------------------------------------------- 22 | -> _Γ ⊣s e r⊢ _Δ 23 | (<<<) = flip (>>>) 24 | 25 | infixr 1 >>>, <<< 26 | 27 | init 28 | -- ----------------------- 29 | :: a < _Γ ⊣s e r⊢ _Δ > a 30 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Down.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Down 2 | ( -- * Down 3 | DownIntro(..) 4 | , downL' 5 | , downR' 6 | -- * Connectives 7 | , module Sequoia.Connective.Down 8 | ) where 9 | 10 | import Prelude hiding (init) 11 | import Sequoia.Calculus.Context 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Calculus.Structural 14 | import Sequoia.Connective.Down 15 | import Sequoia.Polarity 16 | 17 | -- Down 18 | 19 | class Core s => DownIntro s where 20 | downL 21 | :: Neg a 22 | => a < _Γ ⊣s e r⊢ _Δ 23 | -- ------------------------ 24 | -> Down a < _Γ ⊣s e r⊢ _Δ 25 | 26 | downR 27 | :: Neg a 28 | => _Γ ⊣s e r⊢ _Δ > a 29 | -- ------------------------ 30 | -> _Γ ⊣s e r⊢ _Δ > Down a 31 | 32 | 33 | downL' 34 | :: (Weaken s, Exchange s, DownIntro s, Neg a) 35 | => Down a < _Γ ⊣s e r⊢ _Δ 36 | -- ------------------------ 37 | -> a < _Γ ⊣s e r⊢ _Δ 38 | downL' p = downR init >>> wkL' p 39 | 40 | downR' 41 | :: (Weaken s, Exchange s, DownIntro s, Neg a) 42 | => _Γ ⊣s e r⊢ _Δ > Down a 43 | -- ------------------------ 44 | -> _Γ ⊣s e r⊢ _Δ > a 45 | downR' p = wkR' p >>> downL init 46 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Exists.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Sequoia.Calculus.Exists 4 | ( -- * Existential quantification 5 | ExistentialIntro(..) 6 | , existsL' 7 | -- * Connectives 8 | , module Sequoia.Connective.Exists 9 | ) where 10 | 11 | import Prelude hiding (init) 12 | import Sequoia.Calculus.Context 13 | import Sequoia.Calculus.Core 14 | import Sequoia.Calculus.Structural 15 | import Sequoia.Connective.Exists 16 | import Sequoia.Connective.Quantification 17 | import Sequoia.Polarity 18 | 19 | -- Existential quantification 20 | 21 | class Core s => ExistentialIntro s where 22 | existsL 23 | :: (forall x . Polarized n x => f x < _Γ ⊣s e r⊢ _Δ) 24 | -- --------------------------------------------------- 25 | -> Exists r n f < _Γ ⊣s e r⊢ _Δ 26 | 27 | existsR 28 | :: (Polarized n x, Pos (f x)) 29 | => _Γ ⊣s e r⊢ _Δ > f x 30 | -- -------------------------------- 31 | -> _Γ ⊣s e r⊢ _Δ > Exists k n f 32 | 33 | 34 | existsL' 35 | :: (Weaken s, Exchange s, ExistentialIntro s, (Polarized n ==> Pos) f) 36 | => Exists k n f < _Γ ⊣s e r⊢ _Δ 37 | -- --------------------------------------------------- 38 | -> (forall x . Polarized n x => f x < _Γ ⊣s e r⊢ _Δ) 39 | existsL' p = existsR init >>> wkL' p 40 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/ForAll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Sequoia.Calculus.ForAll 4 | ( -- * Universal quantification 5 | UniversalIntro(..) 6 | , forAllR' 7 | -- * Connectives 8 | , module Sequoia.Connective.ForAll 9 | ) where 10 | 11 | import Prelude hiding (init) 12 | import Sequoia.Calculus.Context 13 | import Sequoia.Calculus.Core 14 | import Sequoia.Calculus.Negation 15 | import Sequoia.Calculus.Structural 16 | import Sequoia.Connective.ForAll 17 | import Sequoia.Connective.Quantification 18 | import Sequoia.Polarity 19 | 20 | -- Universal quantification 21 | 22 | class Core s => UniversalIntro s where 23 | forAllL 24 | :: (Polarized n x, Neg (f x)) 25 | => Negate e (f x) r ¬ r < _Γ ⊣s e r⊢ _Δ 26 | -- -------------------------------------- 27 | -> ForAll r n f < _Γ ⊣s e r⊢ _Δ 28 | 29 | forAllR 30 | :: (Polarized n ==> Neg) f 31 | => (forall x . Polarized n x => _Γ ⊣s e r⊢ _Δ > f x) 32 | -- -------------------------------------------------------------- 33 | -> _Γ ⊣s e r⊢ _Δ > ForAll r n f 34 | 35 | 36 | forAllR' 37 | :: (Weaken s, Exchange s, UniversalIntro s, NegationIntro s, (Polarized n ==> Neg) f) 38 | => _Γ ⊣s e r⊢ _Δ > ForAll r n f 39 | -- -------------------------------------------------------------- 40 | -> (forall x . Polarized n x => _Γ ⊣s e r⊢ _Δ > f x) 41 | forAllR' p = wkR' p >>> forAllL (dneN init) 42 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Function.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Function 2 | ( -- * Function 3 | FunctionIntro(..) 4 | , funL2 5 | , ($$) 6 | , funR' 7 | , funLPar 8 | , funRPar 9 | -- * Connectives 10 | , module Sequoia.Connective.Function 11 | ) where 12 | 13 | import Prelude hiding (init) 14 | import Sequoia.Calculus.Context 15 | import Sequoia.Calculus.Core 16 | import Sequoia.Calculus.Not 17 | import Sequoia.Calculus.Par 18 | import Sequoia.Calculus.Structural 19 | import Sequoia.Connective.Function 20 | import Sequoia.Polarity 21 | 22 | -- Function 23 | 24 | class Core s => FunctionIntro s where 25 | funL, (->⊢) 26 | :: (Pos a, Neg b) 27 | => _Γ ⊣s e r⊢ _Δ > a -> b < _Γ ⊣s e r⊢ _Δ 28 | -- ---------------------------------------------- 29 | -> a ~~Fun r~> b < _Γ ⊣s e r⊢ _Δ 30 | (->⊢) = funL 31 | 32 | infixr 5 ->⊢ 33 | 34 | funR 35 | :: (Pos a, Neg b) 36 | => a < _Γ ⊣s e r⊢ _Δ > b 37 | -- ----------------------------------- 38 | -> _Γ ⊣s e r⊢ _Δ > a ~~Fun r~> b 39 | 40 | 41 | funL2 42 | :: (FunctionIntro s, Pos a, Neg b) 43 | -- --------------------------------------- 44 | => a ~~Fun r~> b < a < _Γ ⊣s e r⊢ _Δ > b 45 | funL2 = init ->⊢ init 46 | 47 | ($$) 48 | :: (Weaken s, Exchange s, FunctionIntro s, Pos a, Neg b) 49 | => _Γ ⊣s e r⊢ _Δ > a ~~Fun r~> b -> _Γ ⊣s e r⊢ _Δ > a 50 | -- ---------------------------------------------------------- 51 | -> _Γ ⊣s e r⊢ _Δ > b 52 | f $$ a = wkR' f >>> wkR' a ->⊢ init 53 | 54 | funR' 55 | :: (Weaken s, Exchange s, FunctionIntro s, Pos a, Neg b) 56 | => _Γ ⊣s e r⊢ _Δ > a ~~Fun r~> b 57 | -------------------------------------- 58 | -> a < _Γ ⊣s e r⊢ _Δ > b 59 | funR' p = wkL (wkR' p) >>> funL2 60 | 61 | funLPar 62 | :: (Weaken s, Exchange s, FunctionIntro s, ParIntro s, NotIntro s, Pos a, Neg b) 63 | => a ¬ r ⅋ b < _Γ ⊣s e r⊢ _Δ 64 | -- ------------------------------- 65 | -> a ~~Fun r~> b < _Γ ⊣s e r⊢ _Δ 66 | funLPar s = parR (exR (notR (exL (init ->⊢ init)))) >>> wkL' s 67 | 68 | funRPar 69 | :: (Weaken s, Exchange s, FunctionIntro s, ParIntro s, NotIntro s, Pos a, Neg b) 70 | => _Γ ⊣s e r⊢ _Δ > a ¬ r ⅋ b 71 | -- ------------------------------- 72 | -> _Γ ⊣s e r⊢ _Δ > a ~~Fun r~> b 73 | funRPar s = wkR' s >>> funR (exL (notL init ⅋⊢ init)) 74 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Iff.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Iff 2 | ( -- * Logical biconditional 3 | IffIntro(..) 4 | , iffR1' 5 | , iffR2' 6 | -- * Connectives 7 | , module Sequoia.Connective.Iff 8 | ) where 9 | 10 | import Prelude hiding (init) 11 | import Sequoia.Calculus.Context 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Calculus.Structural 14 | import Sequoia.Connective.Iff 15 | import Sequoia.Polarity 16 | 17 | -- * Logical biconditional 18 | 19 | class Core s => IffIntro s where 20 | iffL1 21 | :: (Neg a, Neg b) 22 | => _Γ ⊣s e r⊢ _Δ > a -> b < _Γ ⊣s e r⊢ _Δ 23 | -- ---------------------------------------------- 24 | -> a <~Iff e r~> b < _Γ ⊣s e r⊢ _Δ 25 | 26 | iffL2 27 | :: (Neg a, Neg b) 28 | => _Γ ⊣s e r⊢ _Δ > b -> a < _Γ ⊣s e r⊢ _Δ 29 | -- ---------------------------------------------- 30 | -> a <~Iff e r~> b < _Γ ⊣s e r⊢ _Δ 31 | 32 | iffR 33 | :: (Neg a, Neg b) 34 | => a < _Γ ⊣s e r⊢ _Δ > b -> b < _Γ ⊣s e r⊢ _Δ > a 35 | -- ------------------------------------------------------ 36 | -> _Γ ⊣s e r⊢ _Δ > a <~Iff e r~> b 37 | 38 | 39 | iffR1' 40 | :: (Weaken s, Exchange s, IffIntro s, Neg a, Neg b) 41 | => _Γ ⊣s e r⊢ _Δ > a <~Iff e r~> b 42 | -- ------------------------------------- 43 | -> a < _Γ ⊣s e r⊢ _Δ > b 44 | iffR1' s = wkL (wkR' s) >>> iffL1 init init 45 | 46 | iffR2' 47 | :: (Weaken s, Exchange s, IffIntro s, Neg a, Neg b) 48 | => _Γ ⊣s e r⊢ _Δ > a <~Iff e r~> b 49 | -- ------------------------------------- 50 | -> b < _Γ ⊣s e r⊢ _Δ > a 51 | iffR2' s = wkL (wkR' s) >>> iffL2 init init 52 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Implicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Implicative 3 | ( -- * Implicative rules 4 | ImplicativeIntro 5 | , funLSub 6 | , subLFun 7 | -- * Re-exports 8 | , module Sequoia.Calculus.Function 9 | , module Sequoia.Calculus.Subtraction 10 | ) where 11 | 12 | import Prelude hiding (init) 13 | import Sequoia.Calculus.Context 14 | import Sequoia.Calculus.Core 15 | import Sequoia.Calculus.Function 16 | import Sequoia.Calculus.Structural 17 | import Sequoia.Calculus.Subtraction 18 | import Sequoia.Polarity 19 | 20 | type ImplicativeIntro s = (FunctionIntro s, SubtractionIntro s) 21 | 22 | funLSub 23 | :: (Weaken s, Exchange s, FunctionIntro s, SubtractionIntro s, Pos a, Neg b) 24 | => _Γ ⊣s e r⊢ _Δ > b >-Sub r-~ a 25 | -- ----------------------------------------------- 26 | -> a ~~Fun r~> b < _Γ ⊣s e r⊢ _Δ 27 | funLSub s = wkL s >>> subL (exL (init ->⊢ init)) 28 | 29 | subLFun 30 | :: (Weaken s, Exchange s, FunctionIntro s, SubtractionIntro s, Pos a, Neg b) 31 | => _Γ ⊣s e r⊢ _Δ > a ~~Fun r~> b 32 | -- ----------------------------------------------- 33 | -> b >-Sub r-~ a < _Γ ⊣s e r⊢ _Δ 34 | subLFun s = wkL s >>> subL (wkR init) ->⊢ exL (subL (wkL init)) 35 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Mu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | module Sequoia.Calculus.Mu 3 | ( -- * Recursion 4 | MuIntro(..) 5 | , muL' 6 | -- * Connectives 7 | , module Sequoia.Connective.Mu 8 | ) where 9 | 10 | import Prelude hiding (init) 11 | import Sequoia.Calculus.Context 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Calculus.Structural 14 | import Sequoia.Connective.Function 15 | import Sequoia.Connective.Mu 16 | import Sequoia.Connective.Quantification 17 | import Sequoia.Polarity 18 | 19 | -- Recursion 20 | 21 | class Core s => MuIntro s where 22 | muL 23 | :: ((Neg ==> Pos) f, Neg a) 24 | => _Γ ⊣s e r⊢ _Δ > f a ~~Fun r~> a -> a < _Γ ⊣s e r⊢ _Δ 25 | -- ------------------------------------------------------------ 26 | -> Mu e r f < _Γ ⊣s e r⊢ _Δ 27 | 28 | muR 29 | :: (Neg ==> Pos) f 30 | => _Γ ⊣s e r⊢ _Δ > ForAll r N (MuF e r f) 31 | -- ---------------------------------------- 32 | -> _Γ ⊣s e r⊢ _Δ > Mu e r f 33 | 34 | 35 | muL' 36 | :: (Weaken s, Exchange s, MuIntro s, (Neg ==> Pos) f) 37 | => Mu e r f < _Γ ⊣s e r⊢ _Δ 38 | -- ---------------------------------------- 39 | -> ForAll r N (MuF e r f) < _Γ ⊣s e r⊢ _Δ 40 | muL' p = muR init >>> wkL' p 41 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Multiplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Multiplicative 3 | ( -- * Multiplicative rules 4 | MultiplicativeIntro 5 | , parLTensor 6 | , tensorLPar 7 | -- * Re-exports 8 | , module Sequoia.Calculus.Bottom 9 | , module Sequoia.Calculus.One 10 | , module Sequoia.Calculus.Par 11 | , module Sequoia.Calculus.Tensor 12 | ) where 13 | 14 | import Prelude hiding (init) 15 | import Sequoia.Calculus.Bottom 16 | import Sequoia.Calculus.Context 17 | import Sequoia.Calculus.Core 18 | import Sequoia.Calculus.Negation 19 | import Sequoia.Calculus.One 20 | import Sequoia.Calculus.Par 21 | import Sequoia.Calculus.Structural 22 | import Sequoia.Calculus.Tensor 23 | import Sequoia.Polarity 24 | 25 | type MultiplicativeIntro s = (BottomIntro s, OneIntro s, ParIntro s, TensorIntro s) 26 | 27 | 28 | parLTensor 29 | :: (Weaken s, ParIntro s, TensorIntro s, NegateIntro s, Neg a, Neg b) 30 | => _Γ ⊣s e r⊢ _Δ > Negate e a r ⊗ Negate e b r 31 | -- ----------------------------------------------------- 32 | -> a ⅋ b < _Γ ⊣s e r⊢ _Δ 33 | parLTensor s = wkL s >>> tensorL (negateL (negateL (parL (wkR init) init))) 34 | 35 | tensorLPar 36 | :: (Weaken s, ParIntro s, TensorIntro s, NotIntro s, Pos a, Pos b) 37 | => _Γ ⊣s e r⊢ _Δ > a ¬ r ⅋ b ¬ r 38 | -- --------------------------------------- 39 | -> a ⊗ b < _Γ ⊣s e r⊢ _Δ 40 | tensorLPar s = wkL s >>> parL (notL (tensorL init)) (notL (tensorL (wkL init))) 41 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Negate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Calculus.Negate 3 | ( -- * Negate 4 | NegateIntro(..) 5 | , negateL' 6 | , negateR' 7 | , shiftN 8 | , dnePK 9 | , dniPK 10 | , negateLK 11 | , negateRK 12 | , negateLK' 13 | , negateRK' 14 | -- * Connectives 15 | , module Sequoia.Connective.Negate 16 | ) where 17 | 18 | import Data.Profunctor 19 | import Prelude hiding (init) 20 | import Sequoia.Calculus.Context 21 | import Sequoia.Calculus.Control 22 | import Sequoia.Calculus.Core 23 | import Sequoia.Calculus.Structural 24 | import Sequoia.Conjunction 25 | import Sequoia.Connective.Negate 26 | import Sequoia.Connective.Negation 27 | import Sequoia.Contextual 28 | import Sequoia.Polarity 29 | import Sequoia.Profunctor.Command 30 | import Sequoia.Profunctor.Continuation as K 31 | import Sequoia.Profunctor.Value 32 | 33 | -- Negate 34 | 35 | class Core s => NegateIntro s where 36 | negateL 37 | :: Neg a 38 | => _Γ ⊣s e r⊢ _Δ > a 39 | -- ---------------------------------- 40 | -> Negate e a r < _Γ ⊣s e r⊢ _Δ 41 | 42 | negateR 43 | :: Neg a 44 | => a < _Γ ⊣s e r⊢ _Δ 45 | -- ---------------------------------- 46 | -> _Γ ⊣s e r⊢ _Δ > Negate e a r 47 | 48 | 49 | negateL' 50 | :: (NegateIntro s, Weaken s, Neg a) 51 | => Negate e a r < _Γ ⊣s e r⊢ _Δ 52 | -- ---------------------------------- 53 | -> _Γ ⊣s e r⊢ _Δ > a 54 | negateL' p = negateR init >>> wkR p 55 | 56 | negateR' 57 | :: (NegateIntro s, Weaken s, Neg a) 58 | => _Γ ⊣s e r⊢ _Δ > Negate e a r 59 | -- ---------------------------------- 60 | -> a < _Γ ⊣s e r⊢ _Δ 61 | negateR' p = wkL p >>> negateL init 62 | 63 | 64 | shiftN 65 | :: (Control s, Contextual s) 66 | => Negate e a r < _Γ ⊣s e r⊢ _Δ > r 67 | -- ---------------------------------- 68 | -> _Γ ⊣s e r⊢ _Δ > a 69 | shiftN = shift . negateLK' 70 | 71 | 72 | dnePK 73 | :: Contextual s 74 | => a •• r < _Γ ⊣s e r⊢ _Δ 75 | -- -------------------------------------- 76 | -> Negate e (a ¬ r) r < _Γ ⊣s e r⊢ _Δ 77 | dnePK = mapL (fmap getNegateNot) 78 | 79 | dniPK 80 | :: Contextual s 81 | => _Γ ⊣s e r⊢ _Δ > a •• r 82 | -- ------------------------------------ 83 | -> _Γ ⊣s e r⊢ _Δ > Negate e (a ¬ r) r 84 | dniPK s = sequent (\ _Δ _Γ -> env (\ e -> appSequent s (lmap (fmap (negateNot e)) _Δ) _Γ)) 85 | 86 | 87 | negateLK 88 | :: Contextual s 89 | => a • r < _Γ ⊣s e r⊢ _Δ 90 | -- ------------------------------ 91 | -> Negate e a r < _Γ ⊣s e r⊢ _Δ 92 | negateLK = mapL (fmap negateK) 93 | 94 | negateRK 95 | :: Contextual s 96 | => _Γ ⊣s e r⊢ _Δ > a • r 97 | -- ------------------------------ 98 | -> _Γ ⊣s e r⊢ _Δ > Negate e a r 99 | negateRK s = sequent (\ _Δ _Γ -> env (\ e -> appSequent s (lmap (fmap (Negate e)) _Δ) _Γ)) 100 | 101 | 102 | negateLK' 103 | :: Contextual s 104 | => Negate e a r < _Γ ⊣s e r⊢ _Δ 105 | -- ------------------------------ 106 | -> a • r < _Γ ⊣s e r⊢ _Δ 107 | negateLK' s = sequent (\ _Δ _Γ -> env (\ e -> appSequent s _Δ (pure (Negate e (e ∘ exlF _Γ)) >∘∘< exrF _Γ))) 108 | 109 | negateRK' 110 | :: Contextual s 111 | => _Γ ⊣s e r⊢ _Δ > Negate e a r 112 | -- ------------------------------ 113 | -> _Γ ⊣s e r⊢ _Δ > a • r 114 | negateRK' = mapR (lmap negateK) 115 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Negation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Negation 3 | ( -- * Negation 4 | NegationIntro 5 | -- * Re-exports 6 | , module Sequoia.Calculus.Not 7 | , module Sequoia.Calculus.Negate 8 | , module Sequoia.Connective.Negation 9 | -- * Negative double negation 10 | , dneN 11 | , dniN 12 | -- * Positive double negation 13 | , dneP 14 | , dniP 15 | ) where 16 | 17 | import Prelude hiding (init) 18 | import Sequoia.Calculus.Context 19 | import Sequoia.Calculus.Negate 20 | import Sequoia.Calculus.Not 21 | import Sequoia.Connective.Negation 22 | import Sequoia.Polarity 23 | 24 | -- Negation 25 | 26 | type NegationIntro s = (NotIntro s, NegateIntro s) 27 | 28 | 29 | -- Negative double negation 30 | 31 | dneN 32 | :: (NegationIntro s, Neg a) 33 | => a < _Γ ⊣s e r⊢ _Δ 34 | -- ---------------------------------- 35 | -> Negate e a r ¬ r < _Γ ⊣s e r⊢ _Δ 36 | dneN = notL . negateR 37 | 38 | dniN 39 | :: (NegationIntro s, Neg a) 40 | => _Γ ⊣s e r⊢ _Δ > a 41 | -- ---------------------------------- 42 | -> _Γ ⊣s e r⊢ _Δ > Negate e a r ¬ r 43 | dniN = notR . negateL 44 | 45 | 46 | -- Positive double negation 47 | 48 | dneP 49 | :: (NegationIntro s, Pos a) 50 | => a < _Γ ⊣s e r⊢ _Δ 51 | -- ------------------------------------ 52 | -> Negate e (a ¬ r) r < _Γ ⊣s e r⊢ _Δ 53 | dneP = negateL . notR 54 | 55 | dniP 56 | :: (NegationIntro s, Pos a) 57 | => _Γ ⊣s e r⊢ _Δ > a 58 | -- ------------------------------------ 59 | -> _Γ ⊣s e r⊢ _Δ > Negate e (a ¬ r) r 60 | dniP = negateR . notL 61 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Not.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Calculus.Not 3 | ( -- * Not 4 | NotIntro(..) 5 | , notL' 6 | , notR' 7 | , shiftP 8 | , dneNK 9 | , dniNK 10 | , notLK 11 | , notRK 12 | , notLK' 13 | , notRK' 14 | -- * Connectives 15 | , module Sequoia.Connective.Not 16 | ) where 17 | 18 | import Data.Profunctor 19 | import Prelude hiding (init) 20 | import Sequoia.Calculus.Context 21 | import Sequoia.Calculus.Control 22 | import Sequoia.Calculus.Core 23 | import Sequoia.Calculus.Structural 24 | import Sequoia.Connective.Bottom 25 | import Sequoia.Connective.Negation 26 | import Sequoia.Connective.Not 27 | import Sequoia.Contextual 28 | import Sequoia.Polarity 29 | import Sequoia.Profunctor.Continuation 30 | import Sequoia.Profunctor.Value 31 | 32 | -- Not 33 | 34 | class Core s => NotIntro s where 35 | notL 36 | :: Pos a 37 | => _Γ ⊣s e r⊢ _Δ > a 38 | -- --------------------------- 39 | -> a ¬ r < _Γ ⊣s e r⊢ _Δ 40 | 41 | notR 42 | :: Pos a 43 | => a < _Γ ⊣s e r⊢ _Δ 44 | -- --------------------------- 45 | -> _Γ ⊣s e r⊢ _Δ > a ¬ r 46 | 47 | 48 | notL' 49 | :: (NotIntro s, Weaken s, Pos a) 50 | => a ¬ r < _Γ ⊣s e r⊢ _Δ 51 | -- --------------------------- 52 | -> _Γ ⊣s e r⊢ _Δ > a 53 | notL' p = notR init >>> wkR p 54 | 55 | notR' 56 | :: (NotIntro s, Weaken s, Pos a) 57 | => _Γ ⊣s e r⊢ _Δ > a ¬ r 58 | -- --------------------------- 59 | -> a < _Γ ⊣s e r⊢ _Δ 60 | notR' p = wkL p >>> notL init 61 | 62 | 63 | shiftP 64 | :: (Control s, Contextual s) 65 | => a ¬ r < _Γ ⊣s e r⊢ _Δ > r 66 | -- --------------------------- 67 | -> _Γ ⊣s e r⊢ _Δ > a 68 | shiftP = shift . notLK' 69 | 70 | 71 | dneNK 72 | :: Contextual s 73 | => a •• r < _Γ ⊣s e r⊢ _Δ 74 | -- ---------------------------------- 75 | -> Negate e a r ¬ r < _Γ ⊣s e r⊢ _Δ 76 | dneNK = mapL (\ v -> V (\ e -> getNotNegate e (e ∘ v))) 77 | 78 | dniNK 79 | :: Contextual s 80 | => _Γ ⊣s e r⊢ _Δ > a •• r 81 | -- ---------------------------------- 82 | -> _Γ ⊣s e r⊢ _Δ > Negate e a r ¬ r 83 | dniNK = mapR (lmap notNegate) 84 | 85 | 86 | notLK 87 | :: Contextual s 88 | => a • r < _Γ ⊣s e r⊢ _Δ 89 | -- ----------------------- 90 | -> a ¬ r < _Γ ⊣s e r⊢ _Δ 91 | notLK = mapL (fmap (rmap absurdN . getNot)) 92 | 93 | notRK 94 | :: Contextual s 95 | => _Γ ⊣s e r⊢ _Δ > a • r 96 | -- ----------------------- 97 | -> _Γ ⊣s e r⊢ _Δ > a ¬ r 98 | notRK = mapR (lmap (Not . rmap Bottom)) 99 | 100 | 101 | notLK' 102 | :: Contextual s 103 | => a ¬ r < _Γ ⊣s e r⊢ _Δ 104 | -- ----------------------- 105 | -> a • r < _Γ ⊣s e r⊢ _Δ 106 | notLK' = mapL (fmap (Not . rmap Bottom)) 107 | 108 | notRK' 109 | :: Contextual s 110 | => _Γ ⊣s e r⊢ _Δ > a ¬ r 111 | -- ----------------------- 112 | -> _Γ ⊣s e r⊢ _Δ > a • r 113 | notRK' = mapR (lmap (rmap absurdN . getNot)) 114 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/NotUntrue.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.NotUntrue 2 | ( -- * NotUntrue 3 | NotUntrueIntro(..) 4 | -- * Connectives 5 | , module Sequoia.Connective.NotUntrue 6 | ) where 7 | 8 | import Sequoia.Calculus.Context 9 | import Sequoia.Calculus.Core 10 | import Sequoia.Connective.NotUntrue 11 | import Sequoia.Polarity 12 | 13 | -- NotUntrue 14 | 15 | class Core s => NotUntrueIntro s where 16 | notUntrueL 17 | :: Neg a 18 | => a < _Γ ⊣s e r⊢ _Δ 19 | -- ----------------------- 20 | -> e ≁ a < _Γ ⊣s e r⊢ _Δ 21 | 22 | notUntrueR 23 | :: Neg a 24 | => _Γ ⊣s e r⊢ _Δ > a 25 | -- ----------------------- 26 | -> _Γ ⊣s e r⊢ _Δ > e ≁ a 27 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Nu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | module Sequoia.Calculus.Nu 3 | ( -- * Corecursion 4 | NuIntro(..) 5 | , nuR' 6 | -- * Connectives 7 | , module Sequoia.Connective.Nu 8 | ) where 9 | 10 | import Prelude hiding (init) 11 | import Sequoia.Calculus.Context 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Calculus.Structural 14 | import Sequoia.Connective.Nu 15 | import Sequoia.Connective.Quantification 16 | import Sequoia.Polarity 17 | 18 | -- Corecursion 19 | 20 | class Core s => NuIntro s where 21 | nuL 22 | :: (Pos ==> Neg) f 23 | => Exists r P (NuF e r f) < _Γ ⊣s e r⊢ _Δ 24 | -- ---------------------------------------- 25 | -> Nu e r f < _Γ ⊣s e r⊢ _Δ 26 | 27 | nuR 28 | :: (Pos ==> Neg) f 29 | => _Γ ⊣s e r⊢ _Δ > Exists r P (NuF e r f) 30 | -- ---------------------------------------- 31 | -> _Γ ⊣s e r⊢ _Δ > Nu e r f 32 | 33 | 34 | nuR' 35 | :: (Weaken s, Exchange s, NuIntro s, (Pos ==> Neg) f) 36 | => _Γ ⊣s e r⊢ _Δ > Nu e r f 37 | -- ---------------------------------------- 38 | -> _Γ ⊣s e r⊢ _Δ > Exists r P (NuF e r f) 39 | nuR' p = wkR' p >>> nuL init 40 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/One.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.One 2 | ( -- * One 3 | OneIntro(..) 4 | , oneL' 5 | -- * Connctives 6 | , module Sequoia.Connective.One 7 | ) where 8 | 9 | import Sequoia.Calculus.Context 10 | import Sequoia.Calculus.Core 11 | import Sequoia.Connective.One 12 | 13 | -- One 14 | 15 | class Core s => OneIntro s where 16 | oneL 17 | :: _Γ ⊣s e r⊢ _Δ 18 | -- ----------------------- 19 | -> One e < _Γ ⊣s e r⊢ _Δ 20 | 21 | oneR 22 | -- ----------------------- 23 | :: _Γ ⊣s e r⊢ _Δ > One e 24 | 25 | 26 | oneL' 27 | :: OneIntro s 28 | => One e < _Γ ⊣s e r⊢ _Δ 29 | -- ----------------------- 30 | -> _Γ ⊣s e r⊢ _Δ 31 | oneL' = (oneR >>>) 32 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Par.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Par 2 | ( -- * Par 3 | ParIntro(..) 4 | , parR' 5 | , parIdentityL 6 | , parIdentityR 7 | , parAssociativity 8 | , parCommutativity 9 | , parDistributivityL 10 | , parDistributivityR 11 | , parAnnihilationL 12 | , parAnnihilationR 13 | -- * Connectives 14 | , module Sequoia.Connective.Par 15 | ) where 16 | 17 | import Prelude hiding (init) 18 | import Sequoia.Calculus.Bottom 19 | import Sequoia.Calculus.Context 20 | import Sequoia.Calculus.Core 21 | import Sequoia.Calculus.Structural 22 | import Sequoia.Calculus.Top 23 | import Sequoia.Calculus.With 24 | import Sequoia.Connective.Par 25 | import Sequoia.Contextual 26 | import Sequoia.Polarity 27 | 28 | -- Par 29 | 30 | class Core s => ParIntro s where 31 | parL, (⅋⊢) 32 | :: (Neg a, Neg b) 33 | => a < _Γ ⊣s e r⊢ _Δ -> b < _Γ ⊣s e r⊢ _Δ 34 | -- ---------------------------------------------- 35 | -> a ⅋ b < _Γ ⊣s e r⊢ _Δ 36 | (⅋⊢) = parL 37 | 38 | infixr 7 ⅋⊢ 39 | 40 | parR 41 | :: (Neg a, Neg b) 42 | => _Γ ⊣s e r⊢ _Δ > a > b 43 | -- ----------------------- 44 | -> _Γ ⊣s e r⊢ _Δ > a ⅋ b 45 | 46 | 47 | parR' 48 | :: (Weaken s, Contextual s, ParIntro s, Neg a, Neg b) 49 | => _Γ ⊣s e r⊢ _Δ > a ⅋ b 50 | -- ----------------------- 51 | -> _Γ ⊣s e r⊢ _Δ > a > b 52 | parR' p = poppedR (wkR . wkR) p >>> wkR init ⅋⊢ init 53 | 54 | 55 | parIdentityL 56 | :: (ParIntro s, BottomIntro s, Neg a) 57 | -- ---------------------------------- 58 | => Bottom r ⅋ a < _Γ ⊣s e r⊢ _Δ > a 59 | parIdentityL = botL ⅋⊢ init 60 | 61 | parIdentityR 62 | :: (ParIntro s, BottomIntro s, Neg a) 63 | -- ---------------------------------- 64 | => a < _Γ ⊣s e r⊢ _Δ > a ⅋ Bottom r 65 | parIdentityR = parR (botR init) 66 | 67 | parAssociativity 68 | :: (Weaken s, Exchange s, ParIntro s, Neg a, Neg b, Neg c) 69 | -- ------------------------------------------- 70 | => a ⅋ (b ⅋ c) < _Γ ⊣s e r⊢ _Δ > (a ⅋ b) ⅋ c 71 | parAssociativity = parR (exR (parR (exR init ⅋⊢ init ⅋⊢ wkR (exR init)))) 72 | 73 | parCommutativity 74 | :: (Exchange s, ParIntro s, Neg a, Neg b) 75 | -- ------------------------------- 76 | => a ⅋ b < _Γ ⊣s e r⊢ _Δ > b ⅋ a 77 | parCommutativity = parR (init ⅋⊢ exR init) 78 | 79 | parDistributivityL 80 | :: (Exchange s, ParIntro s, WithIntro s, Neg a, Neg b, Neg c) 81 | -- --------------------------------------------- 82 | => a ⅋ c & b ⅋ c < _Γ ⊣s e r⊢ _Δ > (a & b) ⅋ c 83 | parDistributivityL = parR (exR (withL1 (init ⅋⊢ exR init) ⊢& withL2 (init ⅋⊢ exR init))) 84 | 85 | parDistributivityR 86 | :: (Exchange s, ParIntro s, WithIntro s, Neg a, Neg b, Neg c) 87 | -- --------------------------------------------- 88 | => a ⅋ (b & c) < _Γ ⊣s e r⊢ _Δ > a ⅋ b & a ⅋ c 89 | parDistributivityR = parR (exR init ⅋⊢ withL1 init) ⊢& parR (exR init ⅋⊢ withL2 init) 90 | 91 | parAnnihilationL 92 | :: TopIntro s 93 | -- ------------------------------- 94 | => Top ⅋ a < _Γ ⊣s e r⊢ _Δ > Top 95 | parAnnihilationL = topR 96 | 97 | parAnnihilationR 98 | :: (ParIntro s, TopIntro s, Neg a) 99 | -- ------------------------------- 100 | => Top < _Γ ⊣s e r⊢ _Δ > a ⅋ Top 101 | parAnnihilationR = parR topR 102 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Quantification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Quantification 3 | ( -- * Quantification rules 4 | QuantificationIntro 5 | -- * Re-exports 6 | , module Sequoia.Calculus.ForAll 7 | , module Sequoia.Calculus.Exists 8 | ) where 9 | 10 | import Sequoia.Calculus.Exists 11 | import Sequoia.Calculus.ForAll 12 | 13 | -- Quantification rules 14 | 15 | type QuantificationIntro s = (UniversalIntro s, ExistentialIntro s) 16 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Recursive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Recursive 3 | ( -- * Recursion rules 4 | RecursiveIntro 5 | -- * Re-exports 6 | , module Sequoia.Calculus.Mu 7 | , module Sequoia.Calculus.Nu 8 | ) where 9 | 10 | import Sequoia.Calculus.Mu 11 | import Sequoia.Calculus.Nu 12 | 13 | type RecursiveIntro s = (NuIntro s, MuIntro s) 14 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Shift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Calculus.Shift 3 | ( -- * Shifts 4 | ShiftIntro 5 | -- * Connectives 6 | , module Sequoia.Calculus.Down 7 | , module Sequoia.Calculus.Up 8 | ) where 9 | 10 | import Sequoia.Calculus.Down 11 | import Sequoia.Calculus.Up 12 | 13 | type ShiftIntro s = (UpIntro s, DownIntro s) 14 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Structural.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Sequoia.Calculus.Structural 5 | ( -- * Structural 6 | Structural 7 | , Weaken(..) 8 | , wkL' 9 | , wkR' 10 | , Contract(..) 11 | , Exchange(..) 12 | -- * Profunctorial structural rules 13 | , weakenL 14 | , weakenR 15 | , contractL 16 | , contractR 17 | , exchangeL 18 | , exchangeR 19 | -- * Derivation 20 | , Profunctorially(..) 21 | ) where 22 | 23 | import Data.Bifunctor 24 | import Data.Profunctor 25 | import Sequoia.Calculus.Context 26 | import Sequoia.Calculus.Core 27 | import Sequoia.Conjunction 28 | import Sequoia.Disjunction 29 | 30 | -- Structural 31 | 32 | type Structural s = (Weaken s, Contract s, Exchange s) 33 | 34 | 35 | class Core s => Weaken s where 36 | wkL 37 | :: _Γ ⊣s e r⊢ _Δ 38 | -- ------------------- 39 | -> a < _Γ ⊣s e r⊢ _Δ 40 | 41 | wkR 42 | :: _Γ ⊣s e r⊢ _Δ 43 | -- ------------------- 44 | -> _Γ ⊣s e r⊢ _Δ > a 45 | 46 | 47 | wkL' 48 | :: (Weaken s, Exchange s) 49 | => a < _Γ ⊣s e r⊢ _Δ 50 | -- ----------------------- 51 | -> a < b < _Γ ⊣s e r⊢ _Δ 52 | wkL' = exL . wkL 53 | 54 | wkR' 55 | :: (Weaken s, Exchange s) 56 | => _Γ ⊣s e r⊢ _Δ > a 57 | -- ----------------------- 58 | -> _Γ ⊣s e r⊢ _Δ > b > a 59 | wkR' = exR . wkR 60 | 61 | 62 | class Core s => Contract s where 63 | cnL 64 | :: a < a < _Γ ⊣s e r⊢ _Δ 65 | -- ----------------------- 66 | -> a < _Γ ⊣s e r⊢ _Δ 67 | 68 | cnR 69 | :: _Γ ⊣s e r⊢ _Δ > a > a 70 | -- ----------------------- 71 | -> _Γ ⊣s e r⊢ _Δ > a 72 | 73 | 74 | class Core s => Exchange s where 75 | exL 76 | :: a < b < _Γ ⊣s e r⊢ _Δ 77 | -- ----------------------- 78 | -> b < a < _Γ ⊣s e r⊢ _Δ 79 | 80 | exR 81 | :: _Γ ⊣s e r⊢ _Δ > a > b 82 | -- ----------------------- 83 | -> _Γ ⊣s e r⊢ _Δ > b > a 84 | 85 | 86 | -- Profunctorial structural rules 87 | 88 | weakenL :: (Profunctor p, Conj t) => p a b -> p (c `t` a) b 89 | weakenL = lmap exr 90 | 91 | weakenR :: (Profunctor p, Disj t) => p a b -> p a (b `t` c) 92 | weakenR = rmap inl 93 | 94 | 95 | contractL :: (Profunctor p, Conj t) => p (a `t` a) b -> p a b 96 | contractL = lmap dupConj 97 | 98 | contractR :: (Profunctor p, Disj t) => p a (b `t` b) -> p a b 99 | contractR = rmap dedupDisj 100 | 101 | 102 | exchangeL :: (Profunctor p, Conj t) => p (a `t` c) b -> p (c `t` a) b 103 | exchangeL = lmap swapConj 104 | 105 | exchangeR :: (Profunctor p, Disj t) => p a (b `t` c) -> p a (c `t` b) 106 | exchangeR = rmap mirrorDisj 107 | 108 | 109 | -- Derivation 110 | 111 | newtype Profunctorially s e r a b = Profunctorially { runProfunctorially :: s e r a b } 112 | deriving (Core, Profunctor) 113 | 114 | instance Profunctor (s e r) => Functor (Profunctorially s e r a) where 115 | fmap = rmap 116 | 117 | instance (Core s, forall e r . Profunctor (s e r)) => Weaken (Profunctorially s) where 118 | wkL = lmap exr 119 | wkR = rmap inl 120 | 121 | instance (Core s, forall e r . Profunctor (s e r)) => Contract (Profunctorially s) where 122 | cnL = lmap (exl >---< id) 123 | cnR = rmap (id <--> inr) 124 | 125 | instance (Core s, forall e r . Profunctor (s e r)) => Exchange (Profunctorially s) where 126 | exL = lmap (exl . exr >---< second exr) 127 | exR = rmap (first inl <--> inl . inr) 128 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Subtraction.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Subtraction 2 | ( -- * Subtraction 3 | SubtractionIntro(..) 4 | , subL' 5 | -- * Connectives 6 | , module Sequoia.Connective.Subtraction 7 | ) where 8 | 9 | import Prelude hiding (init) 10 | import Sequoia.Calculus.Context 11 | import Sequoia.Calculus.Core 12 | import Sequoia.Calculus.Structural 13 | import Sequoia.Connective.Subtraction 14 | import Sequoia.Polarity 15 | 16 | -- Subtraction 17 | 18 | class Core s => SubtractionIntro s where 19 | subL 20 | :: (Pos a, Neg b) 21 | => a < _Γ ⊣s e r⊢ _Δ > b 22 | -- ----------------------------------- 23 | -> b >-Sub r-~ a < _Γ ⊣s e r⊢ _Δ 24 | 25 | subR, (⊢>-) 26 | :: (Pos a, Neg b) 27 | => _Γ ⊣s e r⊢ _Δ > a -> b < _Γ ⊣s e r⊢ _Δ 28 | -- ---------------------------------------------- 29 | -> _Γ ⊣s e r⊢ _Δ > b >-Sub r-~ a 30 | (⊢>-) = subR 31 | 32 | infixr 5 ⊢>- 33 | 34 | 35 | subL' 36 | :: (Weaken s, Exchange s, SubtractionIntro s, Pos a, Neg b) 37 | => b >-Sub r-~ a < _Γ ⊣s e r⊢ _Δ 38 | -- ----------------------------------- 39 | -> a < _Γ ⊣s e r⊢ _Δ > b 40 | subL' p = init ⊢>- init >>> wkR (wkL' p) 41 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Sum.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Sum 2 | ( -- * Sum 3 | SumIntro(..) 4 | , sumL1' 5 | , sumL2' 6 | , sumIdentityL 7 | , sumIdentityR 8 | , sumAssociativity 9 | , sumCommutativity 10 | -- * Connectives 11 | , module Sequoia.Connective.Sum 12 | ) where 13 | 14 | import Prelude hiding (init) 15 | import Sequoia.Calculus.Context 16 | import Sequoia.Calculus.Core 17 | import Sequoia.Calculus.Structural 18 | import Sequoia.Calculus.Zero 19 | import Sequoia.Connective.Sum 20 | import Sequoia.Polarity 21 | 22 | -- Sum 23 | 24 | class Core s => SumIntro s where 25 | sumL, (⊕⊢) 26 | :: (Pos a, Pos b) 27 | => a < _Γ ⊣s e r⊢ _Δ -> b < _Γ ⊣s e r⊢ _Δ 28 | -- ---------------------------------------------- 29 | -> a ⊕ b < _Γ ⊣s e r⊢ _Δ 30 | (⊕⊢) = sumL 31 | 32 | infixr 6 ⊕⊢ 33 | 34 | sumR1 35 | :: (Pos a, Pos b) 36 | => _Γ ⊣s e r⊢ _Δ > a 37 | -- ----------------------- 38 | -> _Γ ⊣s e r⊢ _Δ > a ⊕ b 39 | 40 | sumR2 41 | :: (Pos a, Pos b) 42 | => _Γ ⊣s e r⊢ _Δ > b 43 | -- ----------------------- 44 | -> _Γ ⊣s e r⊢ _Δ > a ⊕ b 45 | 46 | 47 | sumL1' 48 | :: (Weaken s, Exchange s, SumIntro s, Pos a, Pos b) 49 | => a ⊕ b < _Γ ⊣s e r⊢ _Δ 50 | -- ----------------------- 51 | -> a < _Γ ⊣s e r⊢ _Δ 52 | sumL1' p = sumR1 init >>> wkL' p 53 | 54 | sumL2' 55 | :: (Weaken s, Exchange s, SumIntro s, Pos a, Pos b) 56 | => a ⊕ b < _Γ ⊣s e r⊢ _Δ 57 | -- ----------------------- 58 | -> b < _Γ ⊣s e r⊢ _Δ 59 | sumL2' p = sumR2 init >>> wkL' p 60 | 61 | 62 | sumIdentityL 63 | :: (SumIntro s, ZeroIntro s, Pos a) 64 | -- ---------------------------------- 65 | => Zero ⊕ a < _Γ ⊣s e r⊢ _Δ > a 66 | sumIdentityL = zeroL ⊕⊢ init 67 | 68 | sumIdentityR 69 | :: (SumIntro s, Pos a) 70 | -- ------------------------------ 71 | => a < _Γ ⊣s e r⊢ _Δ > a ⊕ Zero 72 | sumIdentityR = sumR1 init 73 | 74 | sumAssociativity 75 | :: (SumIntro s, Pos a, Pos b, Pos c) 76 | -- ------------------------------------------- 77 | => a ⊕ (b ⊕ c) < _Γ ⊣s e r⊢ _Δ > (a ⊕ b) ⊕ c 78 | sumAssociativity = sumR1 (sumR1 init) ⊕⊢ sumR1 (sumR2 init) ⊕⊢ sumR2 init 79 | 80 | sumCommutativity 81 | :: (Exchange s, SumIntro s, Pos a, Pos b) 82 | -- ------------------------------- 83 | => a ⊕ b < _Γ ⊣s e r⊢ _Δ > b ⊕ a 84 | sumCommutativity = sumR2 init ⊕⊢ sumR1 init 85 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Tensor.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Tensor 2 | ( -- * Tensor 3 | TensorIntro(..) 4 | , tensorL' 5 | , tensorIdentityL 6 | , tensorIdentityR 7 | , tensorAssociativity 8 | , tensorCommutativity 9 | , tensorDistributivityL 10 | , tensorDistributivityR 11 | , tensorAnnihilationL 12 | , tensorAnnihilationR 13 | -- * Connectives 14 | , module Sequoia.Connective.Tensor 15 | ) where 16 | 17 | import Prelude hiding (init) 18 | import Sequoia.Calculus.Context 19 | import Sequoia.Calculus.Core 20 | import Sequoia.Calculus.One 21 | import Sequoia.Calculus.Structural 22 | import Sequoia.Calculus.Sum 23 | import Sequoia.Calculus.Zero 24 | import Sequoia.Connective.Tensor 25 | import Sequoia.Contextual 26 | import Sequoia.Polarity 27 | 28 | -- Tensor 29 | 30 | class Core s => TensorIntro s where 31 | tensorL 32 | :: (Pos a, Pos b) 33 | => a < b < _Γ ⊣s e r⊢ _Δ 34 | -- ----------------------- 35 | -> a ⊗ b < _Γ ⊣s e r⊢ _Δ 36 | 37 | tensorR, (⊢⊗) 38 | :: (Pos a, Pos b) 39 | => _Γ ⊣s e r⊢ _Δ > a -> _Γ ⊣s e r⊢ _Δ > b 40 | -- ---------------------------------------------- 41 | -> _Γ ⊣s e r⊢ _Δ > a ⊗ b 42 | (⊢⊗) = tensorR 43 | 44 | infixr 7 ⊢⊗ 45 | 46 | 47 | tensorL' 48 | :: (Contextual s, Weaken s, TensorIntro s, Pos a, Pos b) 49 | => a ⊗ b < _Γ ⊣s e r⊢ _Δ 50 | -- ----------------------- 51 | -> a < b < _Γ ⊣s e r⊢ _Δ 52 | tensorL' p = init ⊢⊗ wkL init >>> popL (wkL . wkL . pushL p) 53 | 54 | 55 | tensorIdentityL 56 | :: (TensorIntro s, OneIntro s, Pos a) 57 | -- ------------------------------- 58 | => One e ⊗ a < _Γ ⊣s e r⊢ _Δ > a 59 | tensorIdentityL = tensorL (oneL init) 60 | 61 | tensorIdentityR 62 | :: (TensorIntro s, OneIntro s, Pos a) 63 | -- ------------------------------- 64 | => a < _Γ ⊣s e r⊢ _Δ > a ⊗ One e 65 | tensorIdentityR = init ⊢⊗ oneR 66 | 67 | tensorAssociativity 68 | :: (Weaken s, Exchange s, TensorIntro s, Pos a, Pos b, Pos c) 69 | -- ------------------------------------------- 70 | => a ⊗ (b ⊗ c) < _Γ ⊣s e r⊢ _Δ > (a ⊗ b) ⊗ c 71 | tensorAssociativity = tensorL (exL (tensorL ((wkL (exL init) ⊢⊗ init) ⊢⊗ exL init))) 72 | 73 | tensorCommutativity 74 | :: (Exchange s, TensorIntro s, Pos a, Pos b) 75 | -- ------------------------------- 76 | => a ⊗ b < _Γ ⊣s e r⊢ _Δ > b ⊗ a 77 | tensorCommutativity = tensorL (exL init ⊢⊗ init) 78 | 79 | tensorDistributivityL 80 | :: (Exchange s, TensorIntro s, SumIntro s, Pos a, Pos b, Pos c) 81 | -- --------------------------------------------- 82 | => a ⊗ c ⊕ b ⊗ c < _Γ ⊣s e r⊢ _Δ > (a ⊕ b) ⊗ c 83 | tensorDistributivityL = tensorL (sumR1 init ⊢⊗ exL init) ⊕⊢ tensorL (sumR2 init ⊢⊗ exL init) 84 | 85 | tensorDistributivityR 86 | :: (Exchange s, TensorIntro s, SumIntro s, Pos a, Pos b, Pos c) 87 | -- --------------------------------------------- 88 | => a ⊗ (b ⊕ c) < _Γ ⊣s e r⊢ _Δ > a ⊗ b ⊕ a ⊗ c 89 | tensorDistributivityR = tensorL (exL (sumR1 (exL init ⊢⊗ init) ⊕⊢ sumR2 (exL init ⊢⊗ init))) 90 | 91 | tensorAnnihilationL 92 | :: (TensorIntro s, ZeroIntro s, Pos a) 93 | -- --------------------------------- 94 | => Zero ⊗ a < _Γ ⊣s e r⊢ _Δ > Zero 95 | tensorAnnihilationL = tensorL zeroL 96 | 97 | tensorAnnihilationR 98 | :: ZeroIntro s 99 | -- --------------------------------- 100 | => Zero < _Γ ⊣s e r⊢ _Δ > a ⊗ Zero 101 | tensorAnnihilationR = zeroL 102 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Top.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Top 2 | ( -- * Top 3 | TopIntro(..) 4 | -- * Connctives 5 | , module Sequoia.Connective.Top 6 | ) where 7 | 8 | import Sequoia.Calculus.Context 9 | import Sequoia.Connective.Top 10 | 11 | -- Top 12 | 13 | class TopIntro s where 14 | topR 15 | -- --------------------- 16 | :: _Γ ⊣s e r⊢ _Δ > Top 17 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/True.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.True 2 | ( -- * True 3 | TrueIntro(..) 4 | -- * Connectives 5 | , module Sequoia.Connective.True 6 | ) where 7 | 8 | import Sequoia.Calculus.Context 9 | import Sequoia.Calculus.Core 10 | import Sequoia.Connective.True 11 | import Sequoia.Polarity 12 | 13 | -- True 14 | 15 | class Core s => TrueIntro s where 16 | trueL 17 | :: Pos a 18 | => a < _Γ ⊣s e r⊢ _Δ 19 | -- -------------------------- 20 | -> True r a < _Γ ⊣s e r⊢ _Δ 21 | 22 | trueR 23 | :: Pos a 24 | => _Γ ⊣s e r⊢ _Δ > a 25 | -- -------------------------- 26 | -> _Γ ⊣s e r⊢ _Δ > True r a 27 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Up.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Up 2 | ( -- * Up 3 | UpIntro(..) 4 | , upL' 5 | , upR' 6 | -- * Connectives 7 | , module Sequoia.Connective.Up 8 | ) where 9 | 10 | import Prelude hiding (init) 11 | import Sequoia.Calculus.Context 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Calculus.Structural 14 | import Sequoia.Connective.Up 15 | import Sequoia.Polarity 16 | 17 | -- Up 18 | 19 | class Core s => UpIntro s where 20 | upL 21 | :: Pos a 22 | => a < _Γ ⊣s e r⊢ _Δ 23 | -- ---------------------- 24 | -> Up a < _Γ ⊣s e r⊢ _Δ 25 | 26 | upR 27 | :: Pos a 28 | => _Γ ⊣s e r⊢ _Δ > a 29 | -- ---------------------- 30 | -> _Γ ⊣s e r⊢ _Δ > Up a 31 | 32 | 33 | upL' 34 | :: (Weaken s, Exchange s, UpIntro s, Pos a) 35 | => Up a < _Γ ⊣s e r⊢ _Δ 36 | -- ---------------------- 37 | -> a < _Γ ⊣s e r⊢ _Δ 38 | upL' p = upR init >>> wkL' p 39 | 40 | upR' 41 | :: (Weaken s, Exchange s, UpIntro s, Pos a) 42 | => _Γ ⊣s e r⊢ _Δ > Up a 43 | -- ---------------------- 44 | -> _Γ ⊣s e r⊢ _Δ > a 45 | upR' p = wkR' p >>> upL init 46 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/With.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.With 2 | ( -- * With 3 | WithIntro(..) 4 | , withR1' 5 | , withR2' 6 | , withIdentityL 7 | , withIdentityR 8 | , withAssociativity 9 | , withCommutativity 10 | -- * Connectives 11 | , module Sequoia.Connective.With 12 | ) where 13 | 14 | import Prelude hiding (init) 15 | import Sequoia.Calculus.Context 16 | import Sequoia.Calculus.Core 17 | import Sequoia.Calculus.Structural 18 | import Sequoia.Calculus.Top 19 | import Sequoia.Connective.With 20 | import Sequoia.Polarity 21 | 22 | -- With 23 | 24 | class Core s => WithIntro s where 25 | withL1 26 | :: (Neg a, Neg b) 27 | => a < _Γ ⊣s e r⊢ _Δ 28 | -- ----------------------- 29 | -> a & b < _Γ ⊣s e r⊢ _Δ 30 | 31 | withL2 32 | :: (Neg a, Neg b) 33 | => b < _Γ ⊣s e r⊢ _Δ 34 | -- ----------------------- 35 | -> a & b < _Γ ⊣s e r⊢ _Δ 36 | 37 | withR, (⊢&) 38 | :: (Neg a, Neg b) 39 | => _Γ ⊣s e r⊢ _Δ > a -> _Γ ⊣s e r⊢ _Δ > b 40 | -- ---------------------------------------------- 41 | -> _Γ ⊣s e r⊢ _Δ > a & b 42 | (⊢&) = withR 43 | 44 | infixr 6 ⊢& 45 | 46 | 47 | withR1' 48 | :: (Weaken s, Exchange s, WithIntro s, Neg a, Neg b) 49 | => _Γ ⊣s e r⊢ _Δ > a & b 50 | -- ----------------------- 51 | -> _Γ ⊣s e r⊢ _Δ > a 52 | withR1' t = wkR' t >>> withL1 init 53 | 54 | withR2' 55 | :: (Weaken s, Exchange s, WithIntro s, Neg a, Neg b) 56 | => _Γ ⊣s e r⊢ _Δ > a & b 57 | -- ----------------------- 58 | -> _Γ ⊣s e r⊢ _Δ > b 59 | withR2' t = wkR' t >>> withL2 init 60 | 61 | 62 | withIdentityL 63 | :: (WithIntro s, Neg a) 64 | -- ----------------------------- 65 | => Top & a < _Γ ⊣s e r⊢ _Δ > a 66 | withIdentityL = withL2 init 67 | 68 | withIdentityR 69 | :: (WithIntro s, TopIntro s, Neg a) 70 | -- ----------------------------- 71 | => a < _Γ ⊣s e r⊢ _Δ > a & Top 72 | withIdentityR = init ⊢& topR 73 | 74 | withAssociativity 75 | :: (WithIntro s, Neg a, Neg b, Neg c) 76 | -- ------------------------------------------- 77 | => a & (b & c) < _Γ ⊣s e r⊢ _Δ > (a & b) & c 78 | withAssociativity = (withL1 init ⊢& withL2 (withL1 init)) ⊢& withL2 (withL2 init) 79 | 80 | withCommutativity 81 | :: (Exchange s, WithIntro s, Neg a, Neg b) 82 | -- ------------------------------- 83 | => a & b < _Γ ⊣s e r⊢ _Δ > b & a 84 | withCommutativity = withL2 init ⊢& withL1 init 85 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/XOr.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.XOr 2 | ( -- * Exclusive disjunction 3 | XOrIntro(..) 4 | , xorL1' 5 | , xorL2' 6 | -- * Connectives 7 | , module Sequoia.Connective.XOr 8 | ) where 9 | 10 | import Prelude hiding (init) 11 | import Sequoia.Calculus.Context 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Calculus.Structural 14 | import Sequoia.Connective.XOr 15 | import Sequoia.Polarity 16 | 17 | -- Exclusive disjunction 18 | 19 | class Core s => XOrIntro s where 20 | xorL 21 | :: (Pos a, Pos b) 22 | => b < _Γ ⊣s e r⊢ _Δ > a -> a < _Γ ⊣s e r⊢ _Δ > b 23 | -- ------------------------------------------------------ 24 | -> a b < _Γ ⊣s e r⊢ _Δ 25 | 26 | xorR1 27 | :: (Pos a, Pos b) 28 | => _Γ ⊣s e r⊢ _Δ > b -> a < _Γ ⊣s e r⊢ _Δ 29 | -- ---------------------------------------------- 30 | -> _Γ ⊣s e r⊢ _Δ > a b 31 | 32 | xorR2 33 | :: (Pos a, Pos b) 34 | => _Γ ⊣s e r⊢ _Δ > a -> b < _Γ ⊣s e r⊢ _Δ 35 | -- ---------------------------------------------- 36 | -> _Γ ⊣s e r⊢ _Δ > a b 37 | 38 | xorL1' 39 | :: (Weaken s, Exchange s, XOrIntro s, Pos a, Pos b) 40 | => a b < _Γ ⊣s e r⊢ _Δ 41 | -- ------------------------------------- 42 | -> b < _Γ ⊣s e r⊢ _Δ > a 43 | xorL1' s = xorR1 init init >>> wkR (wkL' s) 44 | 45 | xorL2' 46 | :: (Weaken s, Exchange s, XOrIntro s, Pos a, Pos b) 47 | => a b < _Γ ⊣s e r⊢ _Δ 48 | -- ------------------------------------- 49 | -> a < _Γ ⊣s e r⊢ _Δ > b 50 | xorL2' s = xorR2 init init >>> wkR (wkL' s) 51 | -------------------------------------------------------------------------------- /src/Sequoia/Calculus/Zero.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Calculus.Zero 2 | ( -- * Zero 3 | ZeroIntro(..) 4 | -- * Connectives 5 | , module Sequoia.Connective.Zero 6 | ) where 7 | 8 | import Sequoia.Calculus.Context 9 | import Sequoia.Calculus.Core 10 | import Sequoia.Connective.Zero 11 | 12 | -- Zero 13 | 14 | class Core s => ZeroIntro s where 15 | zeroL 16 | -- ---------------------- 17 | :: Zero < _Γ ⊣s e r⊢ _Δ 18 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Additive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Connective.Additive 3 | ( -- * Duals 4 | elimWith 5 | , elimSum 6 | -- * Negative truth 7 | , Top(..) 8 | -- * Positive falsity 9 | , Zero 10 | , absurdP 11 | -- * Negative conjunction 12 | , type (&)(..) 13 | -- * Elimination 14 | , runWith 15 | -- * Positive disjunction 16 | , type (⊕)(..) 17 | ) where 18 | 19 | import Data.Bifoldable 20 | import Data.Bifunctor 21 | import Data.Bitraversable 22 | import Data.Functor.Adjunction 23 | import Sequoia.Biadjunction 24 | import Sequoia.Bidistributive 25 | import Sequoia.Bifunctor.Join 26 | import Sequoia.Birepresentable 27 | import Sequoia.Conjunction 28 | import Sequoia.Connective.Negation 29 | import Sequoia.Disjunction 30 | import Sequoia.Nulladjunction 31 | import Sequoia.Polarity 32 | import Sequoia.Profunctor.Continuation 33 | 34 | -- Duals 35 | 36 | elimWith :: a & b -> Negate e a r ⊕ Negate e b r -> r 37 | elimWith = flip ((. exl) . (•) <--> (. exr) . (•)) 38 | 39 | elimSum :: a ⊕ b -> a ¬ r & b ¬ r -> r 40 | elimSum = (. exl) . flip (•) <--> (. exr) . flip (•) 41 | 42 | 43 | -- Adjunctions 44 | 45 | instance Biadjunction (⊕) (&) where 46 | bileftAdjunct = bileftAdjunctDisjConj 47 | birightAdjunct = birightAdjunctDisjConj 48 | 49 | instance Adjunction (Join (⊕)) (Join (&)) where 50 | leftAdjunct = leftAdjunctBiadjunction 51 | rightAdjunct = rightAdjunctBiadjunction 52 | 53 | instance Nulladjunction Zero Top where 54 | nullleftAdjunct _ _ = Top 55 | nullrightAdjunct _ = absurdP 56 | 57 | 58 | -- Negative truth 59 | 60 | data Top = Top 61 | deriving (Eq, Ord, Show) 62 | 63 | instance Polarized N Top where 64 | 65 | 66 | -- Positive falsity 67 | 68 | data Zero 69 | 70 | instance Polarized P Zero where 71 | 72 | absurdP :: Zero -> a 73 | absurdP = \case 74 | 75 | 76 | -- Negative conjunction 77 | 78 | newtype a & b = With (forall r . (a • r ⊕ b • r) • r) 79 | 80 | infixr 6 & 81 | 82 | instance (Neg a, Neg b) => Polarized N (a & b) where 83 | 84 | instance Foldable ((&) f) where 85 | foldMap = foldMapConj 86 | 87 | instance Functor ((&) r) where 88 | fmap = fmapConj 89 | 90 | instance Traversable ((&) f) where 91 | traverse = traverseConj 92 | 93 | instance Conj (&) where 94 | a >--< b = With (dn a <••> dn b) 95 | exl = (runWith (inl idK) •) 96 | exr = (runWith (inr idK) •) 97 | 98 | instance Bifoldable (&) where 99 | bifoldMap = bifoldMapConj 100 | 101 | instance Bifunctor (&) where 102 | bimap = bimapConj 103 | 104 | instance Bitraversable (&) where 105 | bitraverse = bitraverseConj 106 | 107 | instance Bidistributive (&) where 108 | bidistribute = bidistributeConj 109 | bicollect = bicollectConj 110 | 111 | instance Birepresentable (&) where 112 | type Birep (&) = Either () () 113 | bitabulate = bitabulateConj 114 | biindex = biindexConj 115 | 116 | 117 | -- Elimination 118 | 119 | runWith :: (a • r ⊕ b • r) -> (a & b) • r 120 | runWith e = K (\ (With r) -> r • e) 121 | 122 | 123 | -- Positive disjunction 124 | 125 | data a ⊕ b 126 | = InL !a 127 | | InR !b 128 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 129 | 130 | infixr 6 ⊕ 131 | 132 | instance (Pos a, Pos b) => Polarized P (a ⊕ b) 133 | 134 | instance DisjIn (⊕) where 135 | inl = InL 136 | inr = InR 137 | 138 | instance DisjEx (⊕) where 139 | ifl <--> ifr = \case 140 | InL l -> ifl l 141 | InR r -> ifr r 142 | 143 | instance Bifoldable (⊕) where 144 | bifoldMap = bifoldMapDisj 145 | 146 | instance Bifunctor (⊕) where 147 | bimap = bimapDisj 148 | 149 | instance Bitraversable (⊕) where 150 | bitraverse = bitraverseDisj 151 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Assertion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Connective.Assertion 3 | ( -- * Connectives 4 | module Sequoia.Connective.NotUntrue 5 | , module Sequoia.Connective.True 6 | ) where 7 | 8 | import Sequoia.Connective.NotUntrue 9 | import Sequoia.Connective.True 10 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Bottom.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Bottom 2 | ( -- * Negative falsity 3 | Bottom(..) 4 | -- ** Elimination 5 | , absurdNK 6 | ) where 7 | 8 | import Sequoia.Connective.Multiplicative.Unit (Bottom(..), absurdNK) 9 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Down.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Down 2 | ( -- * Negative-to-positive shift 3 | Down(..) 4 | ) where 5 | 6 | import Sequoia.Connective.Shift 7 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Exists.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module Sequoia.Connective.Exists 3 | ( -- * Existential quantification 4 | Exists(..) 5 | -- * Construction 6 | , exists 7 | -- * Elimination 8 | , runExists 9 | , runExistsM 10 | ) where 11 | 12 | import Sequoia.Polarity 13 | import Sequoia.Profunctor 14 | import Sequoia.Profunctor.Continuation 15 | 16 | -- Universal quantification 17 | 18 | data Exists r p f = forall x . Polarized p x => Exists (f x •• r) 19 | 20 | instance Polarized P (Exists r p f) 21 | 22 | 23 | -- Construction 24 | 25 | exists :: Polarized p x => f x -> Exists r p f 26 | exists f = Exists (dn f) 27 | 28 | 29 | -- Elimination 30 | 31 | runExists :: (forall x . Polarized p x => f x -> a) -> Exists r p f -> a •• r 32 | runExists f (Exists r) = r <<^ (<<^ f) 33 | 34 | runExistsM :: (forall x . Polarized p x => f x -> a •• r) -> Exists r p f -> a •• r 35 | runExistsM f (Exists r) = f =<<^ r 36 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Final.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Final 2 | ( -- * Assertion 3 | leftAdjunct 4 | , rightAdjunct 5 | -- * Connectives 6 | , module Sequoia.Connective.Not 7 | , module Sequoia.Connective.True 8 | ) where 9 | 10 | import Control.Category ((<<<)) 11 | import Data.Profunctor 12 | import Sequoia.Connective.Bottom 13 | import Sequoia.Connective.Not 14 | import Sequoia.Connective.True 15 | import Sequoia.Profunctor.Continuation 16 | 17 | -- Adjunction 18 | 19 | leftAdjunct :: (True r a -> b • r) -> (a -> Not b r) 20 | leftAdjunct f a = Not (rmap Bottom (f (true a))) 21 | 22 | rightAdjunct :: (a -> Not b r) -> (True r a -> b • r) 23 | rightAdjunct f a = trueK a <<< rmap absurdN (getNot (f (trueA a))) 24 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/ForAll.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.ForAll 2 | ( -- * Universal quantification 3 | ForAll(..) 4 | -- * Construction 5 | , forAll 6 | ) where 7 | 8 | import Sequoia.Polarity 9 | import Sequoia.Profunctor.Continuation 10 | 11 | -- Universal quantification 12 | 13 | newtype ForAll r p f = ForAll { runForAll :: forall x . Polarized p x => f x •• r } 14 | 15 | instance Polarized N (ForAll r p f) 16 | 17 | 18 | -- Construction 19 | 20 | forAll :: (forall x . Polarized p x => f x) -> ForAll r p f 21 | forAll f = ForAll (dn f) 22 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Function.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Function 2 | ( -- * Implication 3 | Fun(..) 4 | , type (~~) 5 | , type (~>) 6 | -- * Construction 7 | , fun 8 | , fun' 9 | , funExp 10 | -- * Elimination 11 | , appFun 12 | , runFunExp 13 | ) where 14 | 15 | import qualified Control.Category as Cat 16 | import Data.Coerce 17 | import Data.Kind (Type) 18 | import Data.Profunctor.Traversing 19 | import Prelude hiding (exp) 20 | import Sequoia.Polarity 21 | import Sequoia.Profunctor 22 | import Sequoia.Profunctor.Continuation 23 | import Sequoia.Profunctor.Exp (Exp(..)) 24 | 25 | -- Implication 26 | 27 | newtype Fun r a b = Fun { getFun :: (b • r) -> (a • r) } 28 | deriving (Cat.Category, Choice, Profunctor, Strong, Traversing) via Exp r 29 | deriving (Functor) via Exp r a 30 | 31 | instance (Pos a, Neg b) => Polarized N (Fun r a b) where 32 | 33 | type l ~~(r :: Type -> Type -> Type) = r l 34 | type l~> r = l r 35 | 36 | infixr 6 ~~ 37 | infixr 5 ~> 38 | 39 | 40 | -- Construction 41 | 42 | fun :: (b • r -> a -> r) -> a ~~Fun r~> b 43 | fun = coerce 44 | 45 | fun' :: (a -> b) -> a ~~Fun r~> b 46 | fun' = Fun . (^>>) 47 | 48 | funExp :: Exp r a b -> a ~~Fun r~> b 49 | funExp = coerce 50 | 51 | 52 | -- Elimination 53 | 54 | appFun :: Fun r a b -> a -> DN r b 55 | appFun f a = DN (K ((• a) . getFun f)) 56 | 57 | runFunExp :: Fun r a b -> Exp r a b 58 | runFunExp = coerce 59 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Iff.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Iff 2 | ( -- * Logical biconditional 3 | Iff(..) 4 | , type (<~) 5 | , type (~>) 6 | ) where 7 | 8 | import Data.Kind (Type) 9 | import Sequoia.Connective.Down 10 | import Sequoia.Connective.Function 11 | import Sequoia.Connective.With 12 | import Sequoia.Polarity 13 | 14 | -- Logical biconditional 15 | 16 | newtype Iff e r a b = Iff { getIff :: (Down a ~~Fun r~> b) & (Down b ~~Fun r~> a) } 17 | 18 | instance (Neg a, Neg b) => Polarized N (Iff e r a b) 19 | 20 | type a <~(r :: Type -> Type -> Type) = r a 21 | 22 | infixr 6 <~ 23 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Implicative.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Implicative 2 | ( elimFun 3 | , funPar1 4 | , funPar2 5 | -- * Connectives 6 | , module Sequoia.Connective.Function 7 | , module Sequoia.Connective.Subtraction 8 | ) where 9 | 10 | import Fresnel.Iso 11 | import Sequoia.Connective.Function 12 | import Sequoia.Connective.Not 13 | import Sequoia.Connective.Par 14 | import Sequoia.Connective.Subtraction 15 | import Sequoia.Disjunction 16 | import Sequoia.Profunctor 17 | import Sequoia.Profunctor.Continuation 18 | import Sequoia.Profunctor.Exp (elimExp, (↑), (↓)) 19 | 20 | elimFun :: a ~~Fun r~> b -> b >-Sub r-~ a -> r 21 | elimFun f s = elimExp (runFunExp f) • runSubCoexp s 22 | 23 | funPar1 :: Iso' ((a ¬ r ⅋ b) • r) ((a ~~Fun r~> b) • r) 24 | funPar1 = iso 25 | (\ k -> k <<^ mkPar (inrL k)) 26 | (<<^ mkFun) 27 | 28 | funPar2 :: Iso' ((a ¬ r ⅋ b) •• r) ((a ~~Fun r~> b) •• r) 29 | funPar2 = iso 30 | (<<^ (<<^ mkFun)) 31 | (<<^ (\ k -> k <<^ mkPar (inrL k))) 32 | 33 | mkPar :: b • r -> a ~~Fun r~> b -> (a ¬ r ⅋ b) 34 | mkPar p f = inl (inK (\ a -> p ↓ runFunExp f ↑ a)) 35 | 36 | mkFun :: a ¬ r ⅋ b -> a ~~Fun r~> b 37 | mkFun p = fun (\ b a -> ((• a) <--> (b •)) p) 38 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Initial.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Initial 2 | ( -- * Adjunction 3 | leftAdjunct 4 | , rightAdjunct 5 | -- * Connectives 6 | , module Sequoia.Connective.NotUntrue 7 | , module Sequoia.Connective.Negate 8 | ) where 9 | 10 | import Sequoia.Connective.Negate 11 | import Sequoia.Connective.NotUntrue 12 | import Sequoia.Profunctor.Continuation 13 | import Sequoia.Profunctor.Value 14 | 15 | -- Adjunction 16 | 17 | leftAdjunct :: (Negate e a r -> b) -> (a • r -> NotUntrue e b) 18 | leftAdjunct f a = NotUntrue (V (\ e -> f (Negate e a))) 19 | 20 | rightAdjunct :: (a • r -> NotUntrue e b) -> (Negate e a r -> b) 21 | rightAdjunct f a = negateE a ∘ runNotUntrue (f (negateK a)) 22 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Mu.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Mu 2 | ( -- * Recursion 3 | Mu(..) 4 | , MuF(..) 5 | , mu 6 | , foldMu 7 | , unfoldMu 8 | , refoldMu 9 | ) where 10 | 11 | import qualified Control.Category as Cat 12 | import Data.Profunctor 13 | import Data.Profunctor.Traversing 14 | import Fresnel.Setter 15 | import Prelude hiding (exp) 16 | import Sequoia.Connective.Down 17 | import Sequoia.Connective.Function 18 | import Sequoia.Connective.Quantification 19 | import Sequoia.Polarity 20 | import Sequoia.Profunctor.Continuation 21 | import Sequoia.Profunctor.Exp (Exp, dnE, exp, exp', (↑), (↓)) 22 | 23 | -- Recursion 24 | 25 | newtype Mu e r f = Mu { getMu :: forall x . Neg x => Down (FAlg e r f x) ~~Fun r~> x } 26 | 27 | type FAlg e r f x = f x ~~Fun r~> x 28 | 29 | instance Polarized N (Mu e r f) where 30 | 31 | newtype MuF e r f a = MuF { getMuF :: Down (FAlg e r f a) ~~Fun r~> a } 32 | 33 | instance (Pos (f a), Neg a) => Polarized N (MuF e r f a) where 34 | 35 | mu :: ForAll r N (MuF e r f) -> Mu e r f 36 | mu r = Mu (funExp (dnE (over _K (lmap (lmap (runFunExp . getMuF))) (runForAll r)))) 37 | 38 | foldMu :: Neg a => f a ~~Exp r~> a -> Mu e r f ~~Exp r~> a 39 | foldMu alg = exp (\ k -> inK (\ (Mu f) -> k ↓ runFunExp f ↑ Down (funExp alg))) 40 | 41 | unfoldMu :: Traversable f => a ~~Exp r~> f a -> a ~~Exp r~> Mu e r f 42 | unfoldMu coalg = exp' (\ a -> Mu (fun (\ k (Down alg) -> k ↓ refoldCat (runFunExp alg) coalg ↑ a))) 43 | 44 | refoldMu :: (Traversable f, Neg b) => f b ~~Exp r~> b -> a ~~Exp r~> f a -> a ~~Exp r~> b 45 | refoldMu f g = foldMu f Cat.<<< unfoldMu g 46 | 47 | 48 | refoldCat :: (Cat.Category c, Traversing c, Traversable f) => f b `c` b -> a `c` f a -> a `c` b 49 | refoldCat f g = go where go = f Cat.<<< traverse' go Cat.<<< g 50 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Multiplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Sequoia.Connective.Multiplicative 4 | ( -- * Elimination 5 | elimPar 6 | , elimTensor 7 | -- * Negative falsity 8 | , Bottom(..) 9 | -- ** Elimination 10 | , absurdNK 11 | -- * Positive truth 12 | , One(..) 13 | -- * Negative disjunction 14 | , type (⅋)(..) 15 | -- ** Elimination 16 | , runPar 17 | -- * Positive conjunction 18 | , type (⊗)(..) 19 | ) where 20 | 21 | import Data.Bifoldable 22 | import Data.Bifunctor 23 | import Data.Bitraversable 24 | import Data.Functor.Adjunction 25 | import Sequoia.Biadjunction 26 | import Sequoia.Bidistributive 27 | import Sequoia.Bifunctor.Join 28 | import Sequoia.Birepresentable 29 | import Sequoia.Conjunction 30 | import Sequoia.Connective.Multiplicative.Unit 31 | import Sequoia.Connective.Negation 32 | import Sequoia.Disjunction 33 | import Sequoia.Polarity 34 | import Sequoia.Profunctor.Continuation 35 | 36 | -- Elimination 37 | 38 | elimPar :: a ⅋ b -> Negate e a r ⊗ Negate e b r -> r 39 | elimPar = (. exl) . flip (•) <--> (. exr) . flip (•) 40 | 41 | elimTensor :: a ⊗ b -> a ¬ r ⅋ b ¬ r -> r 42 | elimTensor = flip ((. exl) . (•) <--> (. exr) . (•)) 43 | 44 | 45 | -- Adjunction 46 | 47 | instance Biadjunction (⅋) (⊗) where 48 | bileftAdjunct = bileftAdjunctDisjConj 49 | birightAdjunct = birightAdjunctDisjConj 50 | 51 | instance Adjunction (Join (⅋)) (Join (⊗)) where 52 | leftAdjunct = leftAdjunctBiadjunction 53 | rightAdjunct = rightAdjunctBiadjunction 54 | 55 | 56 | -- Negative disjunction 57 | 58 | newtype a ⅋ b = Par (forall r . (a • r ⊗ b • r) • r) 59 | 60 | infixr 7 ⅋ 61 | 62 | instance (Neg a, Neg b) => Polarized N (a ⅋ b) where 63 | 64 | instance Foldable ((⅋) f) where 65 | foldMap = foldMapDisj 66 | 67 | instance Functor ((⅋) f) where 68 | fmap = fmapDisj 69 | 70 | instance Traversable ((⅋) f) where 71 | traverse = traverseDisj 72 | 73 | instance DisjIn (⅋) where 74 | inl l = Par (exlL (dn l)) 75 | inr r = Par (exrL (dn r)) 76 | 77 | instance DisjEx (⅋) where 78 | ifl <--> ifr = (runPar (K ifl >--< K ifr) •) 79 | 80 | instance Bifoldable (⅋) where 81 | bifoldMap = bifoldMapDisj 82 | 83 | instance Bifunctor (⅋) where 84 | bimap = bimapDisj 85 | 86 | instance Bitraversable (⅋) where 87 | bitraverse = bitraverseDisj 88 | 89 | 90 | -- Elimination 91 | 92 | runPar :: (a • r ⊗ b • r) -> (a ⅋ b) • r 93 | runPar e = K (\ (Par r) -> r • e) 94 | 95 | 96 | -- Positive conjunction 97 | 98 | data a ⊗ b = !a :⊗ !b 99 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 100 | 101 | infixr 7 ⊗, :⊗ 102 | 103 | instance (Pos a, Pos b) => Polarized P (a ⊗ b) where 104 | 105 | instance Conj (⊗) where 106 | (>--<) = (:⊗) 107 | exl (l :⊗ _) = l 108 | exr (_ :⊗ r) = r 109 | 110 | instance Bifoldable (⊗) where 111 | bifoldMap = bifoldMapConj 112 | 113 | instance Bifunctor (⊗) where 114 | bimap = bimapConj 115 | 116 | instance Bitraversable (⊗) where 117 | bitraverse = bitraverseConj 118 | 119 | instance Bidistributive (⊗) where 120 | bidistribute = bidistributeConj 121 | bicollect = bicollectConj 122 | 123 | instance Birepresentable (⊗) where 124 | type Birep (⊗) = Either () () 125 | bitabulate = bitabulateConj 126 | biindex = biindexConj 127 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Multiplicative/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Connective.Multiplicative.Unit 3 | ( -- * Negative falsity 4 | Bottom(..) 5 | -- ** Elimination 6 | , absurdNK 7 | -- * Positive truth 8 | , One(..) 9 | ) where 10 | 11 | import Data.Distributive 12 | import Data.Functor.Adjunction 13 | import Data.Functor.Identity 14 | import Data.Functor.Rep 15 | import Sequoia.Nulladjunction 16 | import Sequoia.Polarity 17 | import Sequoia.Profunctor.Continuation 18 | 19 | -- Adjunction 20 | 21 | instance Adjunction Bottom One where 22 | leftAdjunct f = One . f . Bottom 23 | rightAdjunct f = getOne . f . absurdN 24 | 25 | instance Adjunction One Bottom where 26 | leftAdjunct f = Bottom . f . One 27 | rightAdjunct f = absurdN . f . getOne 28 | 29 | instance Nulladjunction r e => Nulladjunction (Bottom r) (One e) where 30 | nullleftAdjunct f = One . nullleftAdjunct (f . Bottom) 31 | nullrightAdjunct f = nullrightAdjunct (getOne . f) . absurdN 32 | 33 | instance Nulladjunction e r => Nulladjunction (One e) (Bottom r) where 34 | nullleftAdjunct f = Bottom . nullleftAdjunct (f . One) 35 | nullrightAdjunct f = nullrightAdjunct (absurdN . f) . getOne 36 | 37 | 38 | -- Negative falsity 39 | 40 | newtype Bottom r = Bottom { absurdN :: r } 41 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 42 | deriving (Applicative, Monad, Representable) via Identity 43 | 44 | instance Polarized N (Bottom r) where 45 | 46 | instance Distributive Bottom where 47 | distribute = Bottom . fmap absurdN 48 | collect f = Bottom . fmap (absurdN . f) 49 | 50 | 51 | -- Elimination 52 | 53 | absurdNK :: Continuation k => Bottom r `k` r 54 | absurdNK = inK absurdN 55 | 56 | 57 | -- Positive truth 58 | 59 | newtype One e = One { getOne :: e } 60 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 61 | deriving (Applicative, Monad, Representable) via Identity 62 | 63 | instance Polarized P (One e) where 64 | 65 | instance Distributive One where 66 | distribute = One . fmap getOne 67 | collect f = One . fmap (getOne . f) 68 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Negate.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Negate 2 | ( -- * Negate 3 | Negate(..) 4 | , type (-) 5 | ) where 6 | 7 | import Data.Profunctor 8 | import Prelude hiding (negate) 9 | import Sequoia.Polarity 10 | import Sequoia.Profunctor.Continuation 11 | 12 | -- Negate 13 | 14 | data Negate e a r = Negate { negateE :: e, negateK :: a • r } 15 | deriving (Functor) 16 | 17 | instance Profunctor (Negate e) where 18 | dimap f g (Negate e k) = Negate e (dimap f g k) 19 | 20 | instance ContinuationE (Negate e) where 21 | (•) = (•) . negateK 22 | 23 | instance Neg a => Polarized P (Negate e a r) where 24 | 25 | 26 | type (-) = Negate 27 | 28 | infixr 9 - 29 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Negation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Connective.Negation 3 | ( -- * Negative double negation 4 | notNegate 5 | , getNotNegate 6 | -- * Positive double negation 7 | , negateNot 8 | , getNegateNot 9 | -- * Connectives 10 | , module Sequoia.Connective.Not 11 | , module Sequoia.Connective.Negate 12 | ) where 13 | 14 | import Data.Profunctor 15 | import Sequoia.Connective.Bottom 16 | import Sequoia.Connective.Negate 17 | import Sequoia.Connective.Not 18 | import Sequoia.Profunctor.Continuation 19 | 20 | -- Negative double negation 21 | 22 | notNegate :: a •• r -> Negate e a r ¬ r 23 | notNegate = Not . rmap Bottom . lmap negateK 24 | 25 | getNotNegate :: e -> Negate e a r ¬ r -> a •• r 26 | getNotNegate e = lmap (Negate e) . rmap absurdN . getNot 27 | 28 | 29 | -- Positive double negation 30 | 31 | negateNot :: e -> a •• r -> Negate e (a ¬ r) r 32 | negateNot e = Negate e . lmap (rmap absurdN . getNot) 33 | 34 | getNegateNot :: Negate e (a ¬ r) r -> a •• r 35 | getNegateNot = lmap (Not . rmap Bottom) . negateK 36 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Not.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Connective.Not 3 | ( -- * Not 4 | Not(..) 5 | , type (¬) 6 | ) where 7 | 8 | import Data.Distributive 9 | import Data.Functor.Identity 10 | import Data.Functor.Rep as Co 11 | import Data.Profunctor 12 | import Data.Profunctor.Rep as Pro 13 | import Data.Profunctor.Sieve 14 | import Sequoia.Connective.Bottom 15 | import Sequoia.Polarity 16 | import Sequoia.Profunctor.Continuation 17 | 18 | -- Not 19 | 20 | newtype Not a r = Not { getNot :: a • Bottom r } 21 | deriving (Functor) 22 | deriving (Co.Representable) via ((•) a) 23 | deriving (Continuation, ContinuationE, ContinuationI, Corepresentable, Costrong, Profunctor, Pro.Representable, Strong) via (•) 24 | 25 | instance Distributive (Not a) where 26 | distribute = distributeRep 27 | collect = collectRep 28 | 29 | instance Sieve Not Identity where 30 | sieve = rmap Identity . (•) 31 | 32 | instance Cosieve Not Identity where 33 | cosieve = lmap runIdentity . (•) 34 | 35 | instance Pos a => Polarized N (Not a r) where 36 | 37 | 38 | type (¬) = Not 39 | 40 | infixr 9 ¬ 41 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/NotUntrue.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.NotUntrue 2 | ( -- * NotUntrue 3 | NotUntrue(..) 4 | , type (≁) 5 | ) where 6 | 7 | import Data.Profunctor 8 | import Sequoia.Polarity 9 | import Sequoia.Profunctor.Value 10 | 11 | -- NotUntrue 12 | 13 | newtype NotUntrue e a = NotUntrue { runNotUntrue :: e ∘ a } 14 | deriving (Applicative, Functor, Monad, Profunctor, Value) 15 | 16 | instance Neg a => Polarized P (NotUntrue e a) 17 | 18 | type (≁) = NotUntrue 19 | 20 | infixr 9 ≁ 21 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Nu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module Sequoia.Connective.Nu 3 | ( -- * Corecursion 4 | Nu(..) 5 | , NuF(..) 6 | , nu 7 | , runNu 8 | ) where 9 | 10 | import Sequoia.Connective.Down 11 | import Sequoia.Connective.Function 12 | import Sequoia.Connective.Quantification 13 | import Sequoia.Connective.Tensor 14 | import Sequoia.Polarity 15 | import Sequoia.Profunctor.Continuation 16 | 17 | -- Corecursion 18 | 19 | data Nu e r f = forall x . Pos x => Nu { getNu :: Down (x ~~Fun r~> f x) ⊗ x } 20 | 21 | instance Polarized N (Nu e r f) where 22 | 23 | newtype NuF e r f a = NuF { getNuF :: Down (a ~~Fun r ~> f a) ⊗ a } 24 | 25 | instance (Neg (f a), Pos a) => Polarized P (NuF e r f a) 26 | 27 | nu :: Pos x => NuF e r f x -> Nu e r f 28 | nu r = Nu (getNuF r) 29 | 30 | runNu :: Nu e r f -> Exists r P (NuF e r f) 31 | runNu (Nu r) = Exists (dn (NuF r)) 32 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/One.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.One 2 | ( -- * Positive truth 3 | One(..) 4 | ) where 5 | 6 | import Sequoia.Connective.Multiplicative.Unit (One(..)) 7 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Par.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Par 2 | ( -- * Negative disjunction 3 | type (⅋)(..) 4 | -- * Elimination 5 | , runPar 6 | ) where 7 | 8 | import Sequoia.Connective.Multiplicative 9 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Par/Parameterized.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Par.Parameterized 2 | ( -- * Par 3 | Par(..) 4 | ) where 5 | 6 | import Data.Bifunctor 7 | import Sequoia.Conjunction 8 | import Sequoia.Disjunction 9 | import Sequoia.Polarity 10 | import Sequoia.Profunctor 11 | import Sequoia.Profunctor.Continuation 12 | 13 | -- Par 14 | 15 | newtype Par r a b = Par { getPar :: (a • r, b • r) • r } 16 | 17 | instance (Neg a, Neg b) => Polarized N (Par r a b) where 18 | 19 | instance DisjIn (Par r) where 20 | inl l = Par (exlL (dn l)) 21 | inr r = Par (exrL (dn r)) 22 | 23 | instance Functor (Par r a) where 24 | fmap = second 25 | 26 | instance Bifunctor (Par r) where 27 | bimap f g (Par r) = Par (r <<^ bimap (<<^ f) (<<^ g)) 28 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Quantification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Sequoia.Connective.Quantification 5 | ( -- * Adjunction 6 | leftAdjunct 7 | , rightAdjunct 8 | -- * Quantified constraints 9 | , type (==>) 10 | -- * Connectives 11 | , module Sequoia.Connective.Exists 12 | , module Sequoia.Connective.ForAll 13 | ) where 14 | 15 | import Data.Kind (Constraint) 16 | import Sequoia.Connective.Exists 17 | import Sequoia.Connective.ForAll 18 | import Sequoia.Polarity 19 | import Sequoia.Profunctor.Continuation 20 | 21 | -- Adjunction 22 | 23 | leftAdjunct :: (forall x . Exists r p a -> b x •• r) -> (forall x . Polarized p x => a x •• r -> ForAll r p b) 24 | leftAdjunct f a = ForAll (f (Exists a)) 25 | 26 | rightAdjunct :: (forall x . a x •• r -> ForAll r p b) -> (forall x . Polarized p x => Exists r p a -> b x •• r) 27 | rightAdjunct f (Exists r) = runForAll (f r) 28 | 29 | 30 | -- Quantified constraints 31 | 32 | type (cx ==> cf) f = (forall x . cx x => cf (f x)) :: Constraint 33 | 34 | infix 5 ==> 35 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Shift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Connective.Shift 3 | ( -- * Up 4 | Up(..) 5 | -- * Down 6 | , Down(..) 7 | ) where 8 | 9 | import Data.Coerce 10 | import Data.Distributive 11 | import Data.Functor.Adjunction 12 | import Data.Functor.Rep 13 | import Sequoia.Functor.I 14 | import Sequoia.Polarity 15 | 16 | -- Up 17 | 18 | newtype Up a = Up { getUp :: a } 19 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 20 | deriving (Applicative, Monad, Representable) via I 21 | 22 | instance Distributive Up where 23 | distribute = Up . fmap getUp 24 | collect f = Up . fmap (getUp . f) 25 | 26 | instance Pos a => Polarized N (Up a) where 27 | 28 | instance Adjunction Down Up where 29 | unit = coerce 30 | counit = coerce 31 | leftAdjunct = coerce 32 | rightAdjunct = coerce 33 | 34 | 35 | -- Down 36 | 37 | newtype Down a = Down { getDown :: a } 38 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 39 | deriving (Applicative, Monad, Representable) via I 40 | 41 | instance Distributive Down where 42 | distribute = Down . fmap getDown 43 | collect f = Down . fmap (getDown . f) 44 | 45 | instance Neg a => Polarized P (Down a) where 46 | 47 | instance Adjunction Up Down where 48 | unit = coerce 49 | counit = coerce 50 | leftAdjunct = coerce 51 | rightAdjunct = coerce 52 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Subtraction.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Subtraction 2 | ( -- * Subtraction 3 | Sub(..) 4 | , type (>-) 5 | , type (-~) 6 | -- * Elimination 7 | , runSubCoexp 8 | , appSub 9 | -- * Optics 10 | , subA_ 11 | , subK_ 12 | ) where 13 | 14 | import Data.Kind (Type) 15 | import Data.Profunctor 16 | import Fresnel.Lens 17 | import Sequoia.Polarity 18 | import Sequoia.Profunctor.Continuation 19 | import qualified Sequoia.Profunctor.Exp as Coexp 20 | 21 | -- Subtraction 22 | 23 | data Sub r b a = (:>-) { subK :: b • r, subA :: a } 24 | deriving (Functor) 25 | 26 | infixr 6 :>- 27 | 28 | instance Profunctor (Sub r) where 29 | dimap f g (k :>- a) = lmap f k :>- g a 30 | 31 | instance (Pos a, Neg b) => Polarized P (Sub r b a) where 32 | 33 | type a >-r = (r :: Type -> Type -> Type) a 34 | type s-~ b = s b 35 | 36 | infixr 6 >- 37 | infixr 5 -~ 38 | 39 | 40 | -- Elimination 41 | 42 | runSubCoexp :: Sub r b a -> Coexp.Coexp r b a 43 | runSubCoexp (k :>- a) = k Coexp.:>- a 44 | 45 | appSub :: Sub r b a -> (b • r -> a • r) -> r 46 | appSub (k :>- a) f = f k • a 47 | 48 | 49 | -- Optics 50 | 51 | subA_ :: Lens (b >-Sub r-~ a) (b >-Sub r-~ a') a a' 52 | subA_ = lens subA (\ s subA -> s{ subA }) 53 | 54 | subK_ :: Lens (b >-Sub r-~ a) (b' >-Sub r'-~ a) (b • r) (b' • r') 55 | subK_ = lens subK (\ s subK -> s{ subK }) 56 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Sum.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Sum 2 | ( -- * Positive disjunction 3 | type (⊕)(..) 4 | ) where 5 | 6 | import Sequoia.Connective.Additive 7 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Tensor.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Tensor 2 | ( -- * Positive conjunction 3 | type (⊗)(..) 4 | ) where 5 | 6 | import Sequoia.Connective.Multiplicative 7 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Top.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Top 2 | ( -- * Negative truth 3 | Top(..) 4 | ) where 5 | 6 | import Sequoia.Connective.Additive 7 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/True.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Connective.True 3 | ( -- * True 4 | True(..) 5 | , type (✓) 6 | -- * Construction 7 | , true 8 | ) where 9 | 10 | import Prelude hiding (True) 11 | import Sequoia.Polarity 12 | import Sequoia.Profunctor.Continuation 13 | 14 | -- True 15 | 16 | data True r a = True { trueA :: a, trueK :: r • r } 17 | deriving (Functor) 18 | 19 | instance Pos a => Polarized P (True e a) 20 | 21 | type (✓) = True 22 | 23 | infixr 9 ✓ 24 | 25 | 26 | -- Construction 27 | 28 | true :: a -> True r a 29 | true = (`True` idK) 30 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Up.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Up 2 | ( -- * Positive-to-negative shift 3 | Up(..) 4 | ) where 5 | 6 | import Sequoia.Connective.Shift 7 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/With.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.With 2 | ( -- * Negative conjunction 3 | type (&)(..) 4 | -- * Elimination 5 | , runWith 6 | ) where 7 | 8 | import Sequoia.Connective.Additive 9 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/XOr.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.XOr 2 | ( -- * Exclusive disjunction 3 | XOr(..) 4 | , type () 6 | ) where 7 | 8 | import Data.Kind (Type) 9 | import Sequoia.Connective.Subtraction 10 | import Sequoia.Connective.Sum 11 | import Sequoia.Connective.Up 12 | import Sequoia.Polarity 13 | 14 | -- Exclusive disjunction 15 | 16 | newtype XOr e r a b = XOr { getXOr :: (Up a >-Sub r-~ b) ⊕ (Up b >-Sub r-~ a) } 17 | 18 | instance (Pos a, Pos b) => Polarized P (XOr e r a b) 19 | 20 | type a Type -> Type) a 21 | type x/> b = x b 22 | 23 | infixr 6 25 | -------------------------------------------------------------------------------- /src/Sequoia/Connective/Zero.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Connective.Zero 2 | ( -- * Positive falsity 3 | Zero 4 | , absurdP 5 | ) where 6 | 7 | import Sequoia.Connective.Additive 8 | -------------------------------------------------------------------------------- /src/Sequoia/Cons.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Cons 3 | ( -- * Efficiently concatenable cons lists 4 | Foldl 5 | , Foldr 6 | , FoldMap 7 | , List(..) 8 | -- * Construction 9 | , fromFoldr 10 | , nil 11 | , cons 12 | , snoc 13 | , singleton 14 | , Sequoia.Cons.fromList 15 | -- * Elimination 16 | , Sequoia.Cons.toList 17 | , head 18 | , tail 19 | , uncons 20 | -- * Computation 21 | , take 22 | , drop 23 | , takeWhile 24 | , dropWhile 25 | , filter 26 | , reverse 27 | , repeat 28 | , zip 29 | , zipWith 30 | , These(..) 31 | , these 32 | , align 33 | , alignWith 34 | ) where 35 | 36 | import Control.Applicative (Alternative(..), liftA2) 37 | import Control.Monad.Zip 38 | import Data.Bifunctor (Bifunctor(..)) 39 | import Data.Bool (bool) 40 | import Data.Foldable (Foldable(..)) 41 | import Data.Functor.Classes 42 | import Data.Semialign (Align(..), Repeat(..), Semialign(..), Unalign(..), Unzip(..), Zip(..)) 43 | import Data.These 44 | import GHC.Exts (IsList(..)) 45 | import Prelude hiding (drop, dropWhile, filter, head, repeat, reverse, tail, take, takeWhile, zip, zipWith) 46 | 47 | -- Efficiently concatenable cons lists 48 | 49 | type Foldl r a = (r -> a -> r) -> r -> r 50 | type Foldr r a = (a -> r -> r) -> r -> r 51 | type FoldMap m a = (m -> m -> m) -> (a -> m) -> m -> m 52 | 53 | newtype List a = FromFoldr { toFoldr :: forall r . Foldr r a } 54 | 55 | instance Eq1 List where 56 | liftEq (==) as bs = foldr (\ a isEq bs -> foldr (\ b _ -> a == b && isEq (tail bs)) False bs) null as bs 57 | 58 | instance Eq a => Eq (List a) where 59 | (==) = eq1 60 | 61 | instance Ord1 List where 62 | liftCompare compare as bs = foldr (\ a cmp bs -> foldr (\ b _ -> compare a b <> cmp (tail bs)) GT bs) (const LT) as bs 63 | 64 | instance Ord a => Ord (List a) where 65 | compare = compare1 66 | 67 | instance Show1 List where 68 | liftShowsPrec _ showList _ = showList . Sequoia.Cons.toList 69 | 70 | instance Show a => Show (List a) where 71 | showsPrec = showsPrec1 72 | 73 | instance Semigroup (List a) where 74 | a <> b = fromFoldr (\ cons -> toFoldr a cons . toFoldr b cons) 75 | 76 | instance Monoid (List a) where 77 | mempty = nil 78 | 79 | instance Functor List where 80 | fmap f l = fromFoldr (toFoldr l . (. f)) 81 | 82 | instance Foldable List where 83 | foldr cons nil list = toFoldr list cons nil 84 | foldMap f list = toFoldr list ((<>) . f) mempty 85 | toList = Sequoia.Cons.toList 86 | null list = toFoldr list (const (const False)) True 87 | 88 | instance Traversable List where 89 | traverse f = foldr (liftA2 cons . f) (pure nil) 90 | 91 | instance Applicative List where 92 | pure = singleton 93 | liftA2 f a b = foldr (\ a cs -> foldr (cons . f a) cs b) nil a 94 | f <*> a = foldr (\ f bs -> foldr (cons . f) bs a) nil f 95 | 96 | instance Alternative List where 97 | empty = nil 98 | (<|>) = (<>) 99 | 100 | instance Monad List where 101 | l >>= f = foldr ((<>) . f) nil l 102 | 103 | instance MonadZip List where 104 | mzip = zip 105 | mzipWith = zipWith 106 | 107 | instance Semialign List where 108 | align = alignWith id 109 | 110 | alignWith f as bs = fromFoldr 111 | (\ cons nil -> foldr 112 | (\ a recur bs -> foldr 113 | (\ b _ -> cons (f (These a b)) (recur (tail bs))) 114 | (cons (f (This a)) (recur bs)) 115 | bs) 116 | (foldr (cons . f . That) nil) 117 | as bs) 118 | 119 | instance Align List where 120 | nil = fromFoldr (const id) 121 | 122 | instance Unalign List where 123 | unalign = foldr (these (first . cons) (second . cons) ((. cons) . bimap . cons)) (nil, nil) 124 | 125 | instance Zip List where 126 | zip = zipWith (,) 127 | 128 | zipWith f a b = fromFoldr (\ cons nil -> toFoldr a (\ ha t b -> toFoldr b (\ hb _ -> cons (f ha hb) (t (tail b))) nil) (const nil) b) 129 | 130 | instance Unzip List where 131 | unzip = (,) <$> fmap fst <*> fmap snd 132 | unzipWith f = (,) <$> fmap (fst . f) <*> fmap (snd . f) 133 | 134 | instance Repeat List where 135 | repeat a = cons a (repeat a) 136 | 137 | instance IsList (List a) where 138 | type Item (List a) = a 139 | fromList = Sequoia.Cons.fromList 140 | toList = Sequoia.Cons.toList 141 | 142 | 143 | -- Construction 144 | 145 | fromFoldr :: (forall r . Foldr r a) -> List a 146 | fromFoldr = FromFoldr 147 | 148 | cons :: a -> List a -> List a 149 | cons h t = fromFoldr (\ cons -> cons h . toFoldr t cons) 150 | 151 | snoc :: List a -> a -> List a 152 | snoc i l = fromFoldr (\ cons nil -> foldr cons (cons l nil) i) 153 | 154 | singleton :: a -> List a 155 | singleton a = cons a nil 156 | 157 | fromList :: [a] -> List a 158 | fromList as = fromFoldr (\ cons nil -> foldr cons nil as) 159 | 160 | 161 | -- Elimination 162 | 163 | toList :: List a -> [a] 164 | toList = foldr (:) [] 165 | 166 | head :: List a -> Maybe a 167 | head = foldr (const . Just) Nothing 168 | 169 | tail :: List a -> List a 170 | tail l = foldr (\ h t -> bool (cons h (t False)) (t False)) (const nil) l True 171 | 172 | uncons :: List a -> Maybe (a, List a) 173 | uncons = liftA2 (,) <$> head <*> Just . tail 174 | 175 | 176 | -- Computation 177 | 178 | take :: Int -> List a -> List a 179 | take n l = fromFoldr (\ cons nil -> toFoldr l (\ h t n -> if n <= 0 then nil else cons h (t (n - 1))) (const nil) n) 180 | 181 | drop :: Int -> List a -> List a 182 | drop n l = fromFoldr (\ cons nil -> toFoldr l (\ h t n -> if n <= 0 then cons h (t n) else t (n - 1)) (const nil) n) 183 | 184 | takeWhile :: (a -> Bool) -> (List a -> List a) 185 | takeWhile p l = fromFoldr (\ cons nil -> toFoldr l (\ h t -> if p h then cons h t else nil) nil) 186 | 187 | dropWhile :: (a -> Bool) -> (List a -> List a) 188 | dropWhile p l = fromFoldr (\ cons nil -> toFoldr l (\ h t done -> if done then cons h (t done) else if p h then t done else cons h (t True)) (const nil) False) 189 | 190 | filter :: (a -> Bool) -> (List a -> List a) 191 | filter p l = fromFoldr (\ cons -> toFoldr l (\ h t -> if p h then cons h t else t)) 192 | 193 | reverse :: List a -> List a 194 | reverse l = foldr (flip (.) . cons) id l nil 195 | -------------------------------------------------------------------------------- /src/Sequoia/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Sequoia.Context 4 | ( -- * Sequents 5 | type (|-)(..) 6 | -- * Empty contexts 7 | , ΓΔ(..) 8 | -- * Context extensions 9 | , type (<)(..) 10 | , type (>)(..) 11 | -- * Typed de Bruijn indices 12 | , IxL(..) 13 | , IxR(..) 14 | , Index(getIndex) 15 | , indexToLevel 16 | -- * Typed de Bruijn levels 17 | , Level(getLevel) 18 | , levelToIndex 19 | -- * Context abstractions 20 | , Ctx(..) 21 | , Cardinality(..) 22 | ) where 23 | 24 | import Data.Functor.Classes 25 | import Sequoia.Profunctor.Continuation 26 | 27 | -- Sequents 28 | 29 | data _Γ |- _Δ = _Γ :|-: _Δ 30 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 31 | 32 | infix 3 |-, :|-: 33 | 34 | 35 | -- Empty contexts 36 | 37 | newtype ΓΔ e r = ΓΔ { getΓΔ :: e } 38 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 39 | 40 | 41 | -- Context extensions 42 | 43 | data a < b = a :< b 44 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 45 | 46 | infixr 4 <, :< 47 | 48 | data as > a = as :> (a • R as) 49 | 50 | infixl 4 >, :> 51 | 52 | 53 | -- Typed de Bruijn indices 54 | 55 | data IxL a as where 56 | IxLZ :: IxL a (a < b) 57 | IxLS :: IxL c b -> IxL c (a < b) 58 | 59 | deriving instance Show (IxL as a) 60 | 61 | data IxR as a where 62 | IxRZ :: IxR (a > b) b 63 | IxRS :: IxR a c -> IxR (a > b) c 64 | 65 | deriving instance Show (IxR as a) 66 | 67 | 68 | -- | De Bruijn indices, counting up from the binding site to the reference site (“inside out”). 69 | newtype Index a as = Index { getIndex :: Int } 70 | deriving (Eq, Ord) 71 | 72 | instance Show (Index a as) where 73 | showsPrec p = showsUnaryWith showsPrec "Index" p . getIndex 74 | 75 | 76 | indexToLevel :: Cardinality as => Index a as -> Level a as 77 | indexToLevel i@(Index index) = Level $ cardinality i - index - 1 78 | 79 | 80 | -- Typed de Bruijn levels 81 | 82 | -- | De Bruijn indices, counting up from the root to the binding site (“outside in”). 83 | newtype Level a as = Level { getLevel :: Int } 84 | deriving (Eq, Ord) 85 | 86 | instance Show (Level a as) where 87 | showsPrec p = showsUnaryWith showsPrec "Level" p . getLevel 88 | 89 | 90 | levelToIndex :: Cardinality as => Level a as -> Index a as 91 | levelToIndex l@(Level level) = Index $ cardinality l - level - 1 92 | 93 | 94 | -- Context abstractions 95 | 96 | class Ctx c where 97 | type E c 98 | type R c 99 | 100 | getE :: c -> E c 101 | 102 | ( c -> a 103 | 104 | infixr 2 ) :: c -> IxR c a -> (a • R c) 107 | 108 | infixl 2 !> 109 | 110 | instance Ctx (ΓΔ e r) where 111 | type E (ΓΔ e r) = e 112 | type R (ΓΔ e r) = r 113 | getE = getΓΔ 114 | i i = case i of {} 116 | 117 | instance Ctx as => Ctx (a < as) where 118 | type E (a < as) = E as 119 | type R (a < as) = R as 120 | getE (_ :< t) = getE t 121 | IxLZ i = case i of {} 124 | 125 | instance Ctx as => Ctx (as > a) where 126 | type E (as > a) = E as 127 | type R (as > a) = R as 128 | getE (i :> _) = getE i 129 | _ :> a !> IxRZ = a 130 | as :> _ !> IxRS i = as !> i 131 | i _ = case i of {} 132 | 133 | 134 | class Cardinality ctx where 135 | cardinality :: i ctx -> Int 136 | 137 | instance Cardinality (ΓΔ e r) where 138 | cardinality _ = 0 139 | 140 | instance Cardinality as => Cardinality (a < as) where 141 | cardinality c = 1 + cardinality (tailOf c) 142 | 143 | tailOf :: i (a < as) -> [as] 144 | tailOf _ = [] 145 | 146 | instance Cardinality as => Cardinality (as > a) where 147 | cardinality c = 1 + cardinality (initOf c) 148 | 149 | initOf :: i (as > a) -> [as] 150 | initOf _ = [] 151 | -------------------------------------------------------------------------------- /src/Sequoia/DeBruijn.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.DeBruijn 2 | ( -- De Bruijn indices 3 | Index(..) 4 | , indexToLevel 5 | -- De Bruijn levels 6 | , Level(..) 7 | , levelToIndex 8 | ) where 9 | 10 | import Data.Functor.Classes 11 | 12 | -- De Bruijn indices 13 | 14 | -- | De Bruijn indices, counting up from the binding site to the reference site (“inside out”). 15 | newtype Index = Index { getIndex :: Int } 16 | deriving (Enum, Eq, Num, Ord) 17 | 18 | instance Show Index where 19 | showsPrec p = showsUnaryWith showsPrec "Index" p . getIndex 20 | 21 | 22 | indexToLevel :: Level -> Index -> Level 23 | indexToLevel (Level d) (Index index) = Level $ d - index - 1 24 | 25 | 26 | -- De Bruijn levels 27 | 28 | -- | De Bruijn indices, counting up from the root to the binding site (“outside in”). 29 | newtype Level = Level { getLevel :: Int } 30 | deriving (Enum, Eq, Num, Ord) 31 | 32 | instance Show Level where 33 | showsPrec p = showsUnaryWith showsPrec "Level" p . getLevel 34 | 35 | levelToIndex :: Level -> Level -> Index 36 | levelToIndex (Level d) (Level level) = Index $ d - level - 1 37 | -------------------------------------------------------------------------------- /src/Sequoia/DeBruijn/Typed.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.DeBruijn.Typed 2 | ( -- * Typed de Bruijn indices 3 | Index(getIndex) 4 | , indexToLevel 5 | -- * Typed de Bruijn levels 6 | , Level(getLevel) 7 | , levelToIndex 8 | ) where 9 | 10 | import Sequoia.Context 11 | -------------------------------------------------------------------------------- /src/Sequoia/Disjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Sequoia.Disjunction 3 | ( -- * Disjunction 4 | Disj 5 | , DisjIn(..) 6 | , DisjEx(..) 7 | , _inl 8 | , _inr 9 | , _inlK 10 | , _inrK 11 | , exlD 12 | , exrD 13 | , (<••>) 14 | , (<∘∘>) 15 | , mirrorDisj 16 | , cocurryDisj 17 | , councurryDisj 18 | , coapDisj 19 | -- * Generalizations 20 | , coerceDisj 21 | , leftDisj 22 | , rightDisj 23 | , (+++) 24 | , (|||) 25 | , dedupDisj 26 | , unleftDisj 27 | , unrightDisj 28 | , prismDisj 29 | -- * Defaults 30 | , foldMapDisj 31 | , fmapDisj 32 | , traverseDisj 33 | , bifoldMapDisj 34 | , bimapDisj 35 | , bitraverseDisj 36 | , bisequenceDisj 37 | -- * Lifted injections 38 | , inlF 39 | , inrF 40 | , inlK 41 | , inrK 42 | , inlL 43 | , inrL 44 | , inlR 45 | , inrR 46 | ) where 47 | 48 | import Control.Category (Category, (>>>)) 49 | import Data.Functor.Contravariant 50 | import Data.Profunctor 51 | import Data.Profunctor.Rep 52 | import Data.Profunctor.Sieve 53 | import Fresnel.Lens 54 | import Fresnel.Prism 55 | import Sequoia.Bifunctor.Sum 56 | import Sequoia.Profunctor.Command 57 | import Sequoia.Profunctor.Continuation 58 | import Sequoia.Profunctor.Diagonal 59 | import Sequoia.Profunctor.Value 60 | 61 | -- Disjunction 62 | 63 | type Disj d = (DisjIn d, DisjEx d) 64 | 65 | class DisjIn d where 66 | inl :: a -> (a `d` b) 67 | inr :: b -> (a `d` b) 68 | 69 | instance DisjIn Either where 70 | inl = Left 71 | inr = Right 72 | 73 | instance DisjIn (+) where 74 | inl = inSl 75 | inr = inSr 76 | 77 | class DisjEx d where 78 | (<-->) :: (a -> r) -> (b -> r) -> (a `d` b -> r) 79 | infixr 3 <--> 80 | 81 | instance DisjEx Either where 82 | (<-->) = either 83 | 84 | instance DisjEx (+) where 85 | (<-->) = runS 86 | 87 | _inl :: Disj d => Prism (a `d` b) (a' `d` b) a a' 88 | _inl = prism inl (inr <--> inl . inr) 89 | 90 | _inr :: Disj d => Prism (a `d` b) (a `d` b') b b' 91 | _inr = prism inr (inl . inl <--> inr) 92 | 93 | _inlK :: (Disj d, Representable k) => Lens (k (a `d` b) r) (k (a' `d` b) r) (k a r) (k a' r) 94 | _inlK = lens inlL (\ ab a' -> tabulate (sieve a' <--> sieve ab . inr)) 95 | 96 | _inrK :: (Disj d, Representable k) => Lens (k (a `d` b) r) (k (a `d` b') r) (k b r) (k b' r) 97 | _inrK = lens inrL (\ ab a' -> tabulate (sieve ab . inl <--> sieve a')) 98 | 99 | exlD :: Disj d => a `d` b -> Maybe a 100 | exlD = Just <--> const Nothing 101 | 102 | exrD :: Disj d => a `d` b -> Maybe b 103 | exrD = const Nothing <--> Just 104 | 105 | (<••>) :: (Disj d, Continuation k) => a `k` r -> b `k` r -> (a `d` b) `k` r 106 | a <••> b = inK ((a •) <--> (b •)) 107 | 108 | infixr 3 <••> 109 | 110 | (<∘∘>) :: (Disj d, Value v) => (e `v` a -> r) -> (e `v` b -> r) -> (e `v` (a `d` b) -> e |- r) 111 | (l <∘∘> r) ab = C ((l <--> r) . bisequenceDisjV ab) 112 | 113 | infixr 3 <∘∘> 114 | 115 | bisequenceDisjV :: (Disj d, Value v) => e `v` (a `d` b) -> e -> (e `v` a) `d` (e `v` b) 116 | bisequenceDisjV = fmap (bimapDisj (inV . pure) (inV . pure)) . flip (∘) 117 | 118 | mirrorDisj :: Disj d => a `d` b -> b `d` a 119 | mirrorDisj = inr <--> inl 120 | 121 | cocurryDisj :: (Disj d, Continuation k) => (c -> ((b `d` a) `k` r) `k` r) -> ((c, b `k` r) -> (a `k` r) `k` r) 122 | cocurryDisj f (c, b) = inK (\ k -> f c • (b <••> k)) 123 | 124 | councurryDisj :: (DisjIn d, Continuation k) => ((c, b `k` r) -> (a `k` r) `k` r) -> c -> ((b `d` a) `k` r) `k` r 125 | councurryDisj f c = inK (\ k -> f (c, inlL k) • inrL k) 126 | 127 | coapDisj :: (DisjIn d, Continuation k) => c -> (((c, b `k` r) `d` b) `k` r) `k` r 128 | coapDisj c = inK (\ k -> inlL k • (c, inrL k)) 129 | 130 | 131 | -- Generalizations 132 | 133 | coerceDisj :: (Disj c1, Disj c2) => a `c1` b -> a `c2` b 134 | coerceDisj = inl <--> inr 135 | 136 | leftDisj :: (Disj d, Choice p) => p a b -> p (d a c) (d b c) 137 | leftDisj = dimap coerceDisj coerceDisj . left' 138 | 139 | rightDisj :: (Disj d, Choice p) => p a b -> p (d c a) (d c b) 140 | rightDisj = dimap coerceDisj coerceDisj . right' 141 | 142 | (+++) :: (Choice p, Category p, Disj c) => a1 `p` b1 -> a2 `p` b2 -> (a1 `c` a2) `p` (b1 `c` b2) 143 | f +++ g = leftDisj f >>> rightDisj g 144 | 145 | infixr 2 +++ 146 | 147 | (|||) :: (Choice p, Category p, Disj c, Codiagonal p) => a1 `p` b -> a2 `p` b -> (a1 `c` a2) `p` b 148 | f ||| g = f +++ g >>> dedupDisj 149 | 150 | infixr 2 ||| 151 | 152 | dedupDisj :: (Codiagonal p, Disj d) => (a `d` a) `p` a 153 | dedupDisj = lmap coerceDisj dedup 154 | 155 | unleftDisj :: (Disj d, Cochoice p) => p (d a c) (d b c) -> p a b 156 | unleftDisj = unleft . dimap coerceDisj coerceDisj 157 | 158 | unrightDisj :: (Disj d, Cochoice p) => p (d c a) (d c b) -> p a b 159 | unrightDisj = unright . dimap coerceDisj coerceDisj 160 | 161 | 162 | prismDisj :: Disj d => (b -> t) -> (s -> t `d` a) -> Prism s t a b 163 | prismDisj inj prj = prism inj (coerceDisj . prj) 164 | 165 | 166 | -- Defaults 167 | 168 | foldMapDisj :: (Disj p, Monoid m) => (b -> m) -> (a `p` b) -> m 169 | foldMapDisj = (const mempty <-->) 170 | 171 | fmapDisj :: Disj p => (b -> b') -> (a `p` b -> a `p` b') 172 | fmapDisj g = inl <--> inr . g 173 | 174 | traverseDisj :: (Disj p, Applicative m) => (b -> m b') -> (a `p` b) -> m (a `p` b') 175 | traverseDisj f = pure . inl <--> inrF . f 176 | 177 | bifoldMapDisj :: Disj p => (a -> m) -> (b -> m) -> (a `p` b -> m) 178 | bifoldMapDisj = (<-->) 179 | 180 | bimapDisj :: Disj p => (a -> a') -> (b -> b') -> (a `p` b -> a' `p` b') 181 | bimapDisj = (+++) 182 | 183 | bitraverseDisj :: (Disj p, Functor m) => (a -> m a') -> (b -> m b') -> (a `p` b -> m (a' `p` b')) 184 | bitraverseDisj f g = inlF . f <--> inrF . g 185 | 186 | bisequenceDisj :: (Disj d, Functor f) => f a `d` f b -> f (a `d` b) 187 | bisequenceDisj = inlF <--> inrF 188 | 189 | 190 | -- Lifted injections 191 | 192 | inlF :: (Functor f, DisjIn d) => f a -> f (a `d` b) 193 | inrF :: (Functor f, DisjIn d) => f b -> f (a `d` b) 194 | inlF = fmap inl 195 | inrF = fmap inr 196 | 197 | inlK :: (Contravariant k, DisjIn d) => k (a `d` b) -> k a 198 | inrK :: (Contravariant k, DisjIn d) => k (a `d` b) -> k b 199 | inlK = contramap inl 200 | inrK = contramap inr 201 | 202 | inlL :: (Profunctor p, DisjIn d) => p (a `d` b) r -> p a r 203 | inrL :: (Profunctor p, DisjIn d) => p (a `d` b) r -> p b r 204 | inlL = lmap inl 205 | inrL = lmap inr 206 | 207 | inlR :: (Profunctor p, DisjIn d) => p l a -> p l (a `d` b) 208 | inrR :: (Profunctor p, DisjIn d) => p l b -> p l (a `d` b) 209 | inlR = rmap inl 210 | inrR = rmap inr 211 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Applicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Sequoia.Functor.Applicative 3 | ( -- * Contravariant applicative 4 | comap 5 | , Contrapply(..) 6 | , Contrapplicative(..) 7 | ) where 8 | 9 | import Data.Functor.Contravariant 10 | import Sequoia.Profunctor.Exp 11 | 12 | -- Contravariant applicative 13 | 14 | comap :: Contravariant f => (a' -> a) -> (f a -> f a') 15 | comap = contramap 16 | 17 | class Contravariant f => Contrapply r f | f -> r where 18 | {-# MINIMAL coliftC2 | (<&>) #-} 19 | 20 | coliftC2 :: ((b >-r-~ c) -> a) -> f a -> f b -> f c 21 | coliftC2 f = (<&>) . comap f 22 | 23 | (<&>) :: f (a >-r-~ b) -> f a -> f b 24 | (<&>) = coliftC2 id 25 | 26 | infixl 4 <&> 27 | 28 | 29 | class Contrapply r f => Contrapplicative r f | f -> r where 30 | copure :: (b -> a) -> f (a >-r-~ b) 31 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Sequoia.Functor.C 4 | ( type(·)(..) 5 | ) where 6 | 7 | import Data.Distributive 8 | import Data.Functor.Adjunction 9 | import Data.Functor.Rep 10 | import Sequoia.Polarity 11 | 12 | newtype (f · g) a = C { getC :: f (g a) } 13 | deriving (Eq, Foldable, Functor, Ord, Show) 14 | 15 | infixr 7 · 16 | 17 | deriving instance (Traversable f, Traversable g) => Traversable (f · g) 18 | 19 | instance Polarized p (f (g a)) => Polarized p ((f · g) a) where 20 | 21 | instance (Applicative f, Applicative g) => Applicative (f · g) where 22 | pure = C . pure . pure 23 | f <*> a = C ((<*>) <$> getC f <*> getC a) 24 | 25 | instance (Distributive f, Distributive g) => Distributive (f · g) where 26 | distribute = C . fmap distribute . distribute . fmap getC 27 | collect f = C . fmap distribute . distribute . fmap (getC . f) 28 | 29 | instance (Representable f, Representable g) => Representable (f · g) where 30 | type Rep (f · g) = (Rep f, Rep g) 31 | tabulate = C . tabulate . fmap tabulate . curry 32 | index = uncurry . fmap index . index . getC 33 | 34 | instance (Adjunction f1 g1, Adjunction f2 g2) => Adjunction (f2 · f1) (g1 · g2) where 35 | unit = C . leftAdjunct (leftAdjunct C) 36 | counit = rightAdjunct (rightAdjunct getC) . getC 37 | leftAdjunct = (C .) . leftAdjunct . leftAdjunct . (. C) 38 | rightAdjunct = (. getC) . rightAdjunct . rightAdjunct . (getC .) 39 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Con.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | A contravariant functor over a profunctor’s input. 4 | module Sequoia.Functor.Con 5 | ( Con(..) 6 | ) where 7 | 8 | import Data.Functor.Contravariant 9 | import Data.Functor.Contravariant.Adjunction 10 | import Data.Functor.Contravariant.Rep 11 | import Data.Profunctor 12 | import qualified Data.Profunctor.Rep as Pro 13 | import Data.Profunctor.Sieve 14 | import Sequoia.Functor.Applicative 15 | import qualified Sequoia.Profunctor.Adjunction as Pro 16 | import qualified Sequoia.Profunctor.Applicative as Pro 17 | 18 | newtype Con p r a = Con { runCon :: p a r } 19 | 20 | instance Profunctor p => Contravariant (Con p r) where 21 | contramap f = Con . lmap f . runCon 22 | 23 | instance Pro.Representable p => Representable (Con p r) where 24 | type Rep (Con p r) = Pro.Rep p r 25 | tabulate = Con . Pro.tabulate 26 | index = sieve . runCon 27 | 28 | instance Pro.Coadjunction p q => Adjunction (Con p r) (Con q r) where 29 | leftAdjunct f a = Con (Pro.leftCoadjunct (runCon . f) a) 30 | rightAdjunct f a = Con (Pro.rightCoadjunct (runCon . f) a) 31 | 32 | instance Pro.Coapply c p => Contrapply c (Con p r) where 33 | coliftC2 f (Con a) (Con b) = Con (Pro.coliftC2 f a b) 34 | Con a <&> Con b = Con (a Pro.<&> b) 35 | 36 | instance Pro.Coapplicative c p => Contrapplicative c (Con p r) where 37 | copure = Con . Pro.copure 38 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Continuation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | -- | Continuations encoded as (contravariant) functors. 4 | module Sequoia.Functor.Continuation 5 | ( -- * Continuation functor 6 | type (•)(..) 7 | -- * Continuation abstraction 8 | , Continuation(..) 9 | -- * Construction 10 | , idK 11 | , constK 12 | ) where 13 | 14 | import Data.Functor.Contravariant 15 | import Data.Functor.Contravariant.Adjunction 16 | import Data.Functor.Contravariant.Rep 17 | 18 | -- Continuation functor 19 | 20 | newtype r • a = K { runK :: a -> r } 21 | 22 | instance Contravariant ((•) r) where 23 | contramap f = K . (. f) . runK 24 | 25 | instance Representable ((•) r) where 26 | type Rep ((•) r) = r 27 | tabulate = inK 28 | index = (•) 29 | 30 | instance Continuation r ((•) r) where 31 | inK = K 32 | (•) = runK 33 | 34 | instance Adjunction ((•) r) ((•) r) where 35 | leftAdjunct f a = inK (\ b -> f b • a) 36 | rightAdjunct f a = inK (\ b -> f b • a) 37 | 38 | 39 | -- Continuation abstraction 40 | 41 | class Contravariant k => Continuation r k | k -> r where 42 | inK :: (a -> r) -> k a 43 | (•) :: k a -> (a -> r) 44 | 45 | infixl 7 • 46 | 47 | 48 | -- Construction 49 | 50 | idK :: Continuation r k => k r 51 | idK = inK id 52 | 53 | constK :: Continuation r k => r -> k a 54 | constK = inK . const 55 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Cov.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | A covariant functor over a profunctor’s output. 4 | module Sequoia.Functor.Cov 5 | ( Cov(..) 6 | ) where 7 | 8 | import Data.Distributive 9 | import Data.Functor.Adjunction 10 | import Data.Functor.Rep 11 | import Data.Profunctor 12 | import qualified Data.Profunctor.Rep as Pro 13 | import Data.Profunctor.Sieve 14 | import qualified Sequoia.Profunctor.Adjunction as Pro 15 | 16 | newtype Cov p s a = Cov { runCov :: p s a } 17 | deriving (Choice, Closed, Cochoice, Costrong, Profunctor, Strong) 18 | 19 | instance Profunctor p => Functor (Cov p s) where 20 | fmap f = Cov . rmap f . runCov 21 | 22 | instance Pro.Corepresentable p => Distributive (Cov p s) where 23 | distribute = distributeRep 24 | collect = collectRep 25 | 26 | instance Pro.Corepresentable p => Representable (Cov p s) where 27 | type Rep (Cov p s) = Pro.Corep p s 28 | tabulate = Cov . Pro.cotabulate 29 | index = cosieve . runCov 30 | 31 | instance Pro.Adjunction p q => Adjunction (Cov p r) (Cov q r) where 32 | leftAdjunct f a = Cov (Pro.leftAdjunct (f . Cov) a) 33 | rightAdjunct f a = Pro.rightAdjunct (runCov . f) (runCov a) 34 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/I.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Functor.I 3 | ( -- Identity functor 4 | I(..) 5 | ) where 6 | 7 | import Control.Applicative (liftA2) 8 | import Control.Comonad 9 | import Data.Coerce 10 | import Data.Distributive 11 | import Data.Functor.Adjunction 12 | import Data.Functor.Rep 13 | 14 | newtype I a = I { getI :: a } 15 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 16 | 17 | instance Applicative I where 18 | pure = coerce 19 | liftA2 = coerce 20 | (<*>) = coerce 21 | 22 | instance Monad I where 23 | (>>=) = flip coerce 24 | 25 | instance Comonad I where 26 | extract = coerce 27 | extend = coerce 28 | 29 | instance Distributive I where 30 | distribute = I . fmap getI 31 | collect f = I . fmap (getI . f) 32 | 33 | instance Representable I where 34 | type Rep I = () 35 | tabulate = I . ($ ()) 36 | index = const . getI 37 | 38 | instance Adjunction I I where 39 | unit = coerce 40 | counit = coerce 41 | leftAdjunct = coerce 42 | rightAdjunct = coerce 43 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Sink.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Functor.Sink 2 | ( -- * Sinks 3 | _Snk 4 | , Snk(..) 5 | -- * Construction 6 | , snk 7 | , snkFn 8 | , (Sequoia.Functor.Sink.↓) 9 | -- * Elimination 10 | , runSnk 11 | , elimSnk 12 | -- * Computation 13 | , mapSnkE 14 | , mapSnkR 15 | , mapSnkFnV 16 | , mapSnkFnC 17 | -- * Optics 18 | , _SnkExp 19 | ) where 20 | 21 | import Data.Coerce 22 | import Data.Profunctor 23 | import Fresnel.Getter 24 | import Fresnel.Iso 25 | import Fresnel.Review 26 | import Fresnel.Setter 27 | import Sequoia.Functor.Sink.Internal 28 | import Sequoia.Functor.Source.Internal 29 | import Sequoia.Profunctor.Command 30 | import Sequoia.Profunctor.Continuation 31 | import Sequoia.Profunctor.Exponential as Exp 32 | import Sequoia.Profunctor.Value 33 | 34 | -- Sinks 35 | 36 | _Snk :: Iso (Snk e r a) (Snk e' r' a') (e ∘ a -> e |- r) (e' ∘ a' -> e' |- r') 37 | _Snk = coerced 38 | 39 | 40 | -- Construction 41 | 42 | snk :: (e ∘ a -> e |- r) -> Snk e r a 43 | snk = coerce 44 | 45 | snkFn :: ((e -> a) -> (e -> r)) -> Snk e r a 46 | snkFn = coerce 47 | 48 | (↓) :: b • r -> a --|Exp e r|-> b -> a --|Snk e r 49 | k ↓ f = snk (k Exp.↓ f) 50 | 51 | infixl 2 ↓ 52 | 53 | 54 | -- Elimination 55 | 56 | runSnk :: Snk e r a -> (e ∘ a -> e |- r) 57 | runSnk = coerce . runSnk 58 | 59 | elimSnk :: Snk e r a -> Src e r a -> e |- r 60 | elimSnk sn sr = env (pure . (runSrcFn sr . flip (runSnkFn sn . pure) <*> id)) 61 | 62 | 63 | -- Computation 64 | 65 | mapSnkE :: (forall x . Iso' (e ∘ x) (e' ∘ x)) -> (Snk e r a -> Snk e' r a) 66 | mapSnkE b = over _Snk (mapSnkFnC (over _CV (view b)) . mapSnkFnV (review b)) 67 | 68 | mapSnkR :: (forall x . x • r -> x • r') -> (Snk e r a -> Snk e r' a) 69 | mapSnkR f = over _Snk (mapSnkFnC (over _CK f)) 70 | 71 | mapSnkFnV :: (forall x . e2 ∘ x -> e1 ∘ x) -> (e1 ∘ a -> e |- r) -> (e2 ∘ a -> e |- r) 72 | mapSnkFnV f = lmap f 73 | 74 | mapSnkFnC :: (e1 |- r1 -> e2 |- r2) -> (e ∘ a -> e1 |- r1) -> (e ∘ a -> e2 |- r2) 75 | mapSnkFnC = rmap 76 | 77 | 78 | -- Optics 79 | 80 | _SnkExp :: Iso (Snk e r a) (Snk e' r' a') (Exp e r a r) (Exp e' r' a' r') 81 | _SnkExp = _Snk.from (_Exp.constantWith idK (flip ((.) . (•<<)))) 82 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Sink/Internal.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Functor.Sink.Internal 2 | ( Snk(..) 3 | ) where 4 | 5 | import Data.Functor.Contravariant 6 | import Sequoia.Functor.Applicative 7 | import Sequoia.Profunctor.Continuation 8 | import Sequoia.Profunctor.Exp 9 | 10 | newtype Snk e r a = Snk { runSnkFn :: (e -> a) -> (e -> r) } 11 | 12 | instance Contravariant (Snk e r) where 13 | contramap f = Snk . (. fmap f) . runSnkFn 14 | 15 | instance Contrapply r (Snk e r) where 16 | coliftC2 f a b = Snk (\ v e -> runSnkFn a (\ e -> f (K (flip (runSnkFn b) e . const) :>- v e)) e) 17 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Source.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Functor.Source 2 | ( -- * Sources 3 | _Src 4 | , Src(..) 5 | -- * Construction 6 | , src 7 | , srcFn 8 | , (Sequoia.Functor.Source.↑) 9 | -- * Elimination 10 | , runSrc 11 | , elimSrc 12 | -- * Computation 13 | , mapSrcE 14 | , mapSrcR 15 | , mapSrcFnK 16 | , mapSrcFnC 17 | -- * Optics 18 | , _SrcExp 19 | ) where 20 | 21 | import Data.Coerce 22 | import Data.Profunctor 23 | import Fresnel.Getter 24 | import Fresnel.Iso 25 | import Fresnel.Review 26 | import Fresnel.Setter 27 | import Sequoia.Functor.Sink.Internal 28 | import Sequoia.Functor.Source.Internal 29 | import Sequoia.Profunctor.Command 30 | import Sequoia.Profunctor.Continuation 31 | import Sequoia.Profunctor.Exponential as Exp 32 | import Sequoia.Profunctor.Value 33 | 34 | -- Sources 35 | 36 | _Src :: Iso (Src e r b) (Src e' r' b') (b • r -> e |- r) (b' • r' -> e' |- r') 37 | _Src = coerced 38 | 39 | 40 | -- Construction 41 | 42 | src :: ((b • r) -> (e |- r)) -> Src e r b 43 | src = coerce 44 | 45 | srcFn :: ((b -> r) -> (e -> r)) -> Src e r b 46 | srcFn = Src 47 | 48 | (↑) :: a --|Exp e r|-> b -> e ∘ a -> Src e r|-> b 49 | f ↑ v = src (flip (↓ f) v) 50 | 51 | infixl 3 ↑ 52 | 53 | 54 | -- Elimination 55 | 56 | runSrc :: Src e r b -> (b • r -> e |- r) 57 | runSrc = coerce . runSrcFn 58 | 59 | elimSrc :: Src e r a -> Snk e r a -> e |- r 60 | elimSrc sr sn = env (pure . (runSrcFn sr . flip (runSnkFn sn . pure) <*> id)) 61 | 62 | 63 | -- Computation 64 | 65 | mapSrcE :: (forall x . e ∘ x -> e' ∘ x) -> (Src e r b -> Src e' r b) 66 | mapSrcE f = over _Src (mapSrcFnC (over _CV f)) 67 | 68 | mapSrcR :: (forall x . Iso' (x • r) (x • r')) -> (Src e r b -> Src e r' b) 69 | mapSrcR b = over _Src (mapSrcFnC (over _CK (view b)) . mapSrcFnK (review b)) 70 | 71 | mapSrcFnK :: (forall x . x • r2 -> x • r1) -> (b • r1 -> e |- r) -> (b • r2 -> e |- r) 72 | mapSrcFnK f = lmap f 73 | 74 | mapSrcFnC :: (e1 |- r1 -> e2 |- r2) -> (b • r -> e1 |- r1) -> (b • r -> e2 |- r2) 75 | mapSrcFnC = rmap 76 | 77 | 78 | -- Optics 79 | 80 | _SrcExp :: Iso (Src e r b) (Src e' r' b') (Exp e r e b) (Exp e' r' e' b') 81 | _SrcExp = _Src.from (_Exp.rmapping (constantWith idV (<<∘))) 82 | -------------------------------------------------------------------------------- /src/Sequoia/Functor/Source/Internal.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Functor.Source.Internal 2 | ( Src(..) 3 | ) where 4 | 5 | newtype Src e r b = Src { runSrcFn :: (b -> r) -> (e -> r) } 6 | 7 | instance Functor (Src e r) where 8 | fmap f = Src . (. (. f)) . runSrcFn 9 | 10 | instance Applicative (Src e r) where 11 | pure = Src . fmap const . flip ($) 12 | Src f <*> Src a = Src (\ k e -> f (\ f -> a (k . f) e) e) 13 | 14 | instance Monad (Src e r) where 15 | Src m >>= f = Src (\ k e -> m (\ a -> runSrcFn (f a) k e) e) 16 | -------------------------------------------------------------------------------- /src/Sequoia/Lambda.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Lambda 2 | () where 3 | -------------------------------------------------------------------------------- /src/Sequoia/Line.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Line 2 | ( -- * Lines 3 | Line(..) 4 | -- * Elimination 5 | , nullLine 6 | -- * Line endings 7 | , LineEnding(..) 8 | ) where 9 | 10 | import qualified Sequoia.Cons as List 11 | 12 | -- Lines 13 | 14 | data Line = Line { lineContents :: List.List Char, lineEnding :: Maybe LineEnding } 15 | deriving (Eq, Ord, Show) 16 | 17 | 18 | -- Elimination 19 | 20 | nullLine :: Line -> Bool 21 | nullLine = (&&) <$> null . lineContents <*> null . lineEnding 22 | 23 | 24 | -- Line endings 25 | 26 | data LineEnding 27 | = CR 28 | | LF 29 | | CRLF 30 | deriving (Bounded, Enum, Eq, Ord, Show) 31 | 32 | instance Semigroup LineEnding where 33 | CR <> LF = CRLF 34 | LF <> CR = CRLF 35 | a <> b = max a b 36 | -------------------------------------------------------------------------------- /src/Sequoia/Monad/It.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Monad.It 2 | ( -- * Iteratees 3 | It(..) 4 | -- * Construction 5 | , fromGetIt 6 | , mfromGetIt 7 | , doneIt 8 | , rollIt 9 | , mrollIt 10 | , unfoldIt 11 | , munfoldIt 12 | , needIt 13 | , toList 14 | , repeatIt 15 | -- * Elimination 16 | , foldIt 17 | , mfoldIt 18 | , runIt 19 | , mrunIt 20 | , evalIt 21 | -- * Computation 22 | , feedIt 23 | -- * Parsing 24 | , getLineIt 25 | , getLinesIt 26 | -- * Enumerators 27 | , Enumerator 28 | , enumList 29 | , enumFile 30 | , enumHandle 31 | -- * Enumeratees 32 | , Enumeratee 33 | , take 34 | ) where 35 | 36 | import Control.Applicative (Alternative(..)) 37 | import qualified Control.Category as Cat 38 | import Control.Effect.Lift 39 | import Control.Monad (guard) 40 | import Data.Profunctor 41 | import Foreign.C.String 42 | import Foreign.Marshal.Alloc 43 | import Foreign.Ptr 44 | import Prelude hiding (any, take) 45 | import qualified Sequoia.Cons as List 46 | import Sequoia.Line 47 | import System.IO hiding (Newline(..)) 48 | 49 | -- Iteratees 50 | 51 | -- | Iteratees, based loosely on the one in @trifecta@. 52 | newtype It i o = It { getIt :: forall s . (o -> s) -> (forall x . (x -> It i o) -> (Maybe i -> x) -> s) -> s } 53 | 54 | instance Cat.Category It where 55 | id = rollIt (maybe Cat.id doneIt) 56 | f . g = rollIt (\ a -> foldIt (\ b -> foldIt pure ($ Just b) f) ($ a) g) 57 | 58 | instance Profunctor It where 59 | dimap f g = mfoldIt (doneIt . g) ((. (. fmap f)) . mrollIt) 60 | 61 | instance Choice It where 62 | left' = foldIt (pure . Left) (\ k -> rollIt (maybe (k Nothing) (either (k . Just) (pure . Right)))) 63 | right' = foldIt (pure . Right) (\ k -> rollIt (maybe (k Nothing) (either (pure . Left) (k . Just)))) 64 | 65 | instance Functor (It i) where 66 | fmap f = mfoldIt (doneIt . f) mrollIt 67 | 68 | instance Applicative (It i) where 69 | pure = doneIt 70 | f <*> a = mfoldIt (<$> a) mrollIt f 71 | 72 | instance Monad (It i) where 73 | m >>= f = mfoldIt f mrollIt m 74 | 75 | 76 | -- Construction 77 | 78 | fromGetIt :: (forall s . (o -> s) -> ((Maybe i -> It i o) -> s) -> s) -> It i o 79 | fromGetIt f = mfromGetIt (\ a k -> f a (k id)) 80 | 81 | mfromGetIt :: (forall s . (o -> s) -> (forall x . (x -> It i o) -> (Maybe i -> x) -> s) -> s) -> It i o 82 | mfromGetIt = It 83 | 84 | 85 | doneIt :: o -> It i o 86 | doneIt a = fromGetIt (const . ($ a)) 87 | 88 | rollIt :: (Maybe i -> It i o) -> It i o 89 | rollIt = mrollIt id 90 | 91 | mrollIt :: (x -> It i o) -> (Maybe i -> x) -> It i o 92 | mrollIt k r = mfromGetIt (\ _ f -> f k r) 93 | 94 | 95 | unfoldIt :: (s -> Either o (Maybe i -> s)) -> (s -> It i o) 96 | unfoldIt coalg = go where go = munfoldIt (fmap (id,) . coalg) 97 | 98 | munfoldIt :: (s -> Either o (x -> s, Maybe i -> x)) -> (s -> It i o) 99 | munfoldIt coalg = go where go s = mfromGetIt (\ p k -> either p (uncurry (k . (go .))) (coalg s)) 100 | 101 | 102 | needIt :: (i -> Maybe o) -> It i o 103 | needIt f = i where i = rollIt (maybe i (maybe i doneIt . f)) 104 | 105 | 106 | toList :: It a [a] 107 | toList = List.toList <$> go List.nil 108 | where 109 | go as = i where i = rollIt (maybe (pure as) (go . List.snoc as)) 110 | 111 | repeatIt :: (o -> Maybe o') -> It i o -> It i [o'] 112 | repeatIt rel i = loop List.nil 113 | where 114 | loop acc = i >>= maybe (pure (List.toList acc)) (loop . List.snoc acc) . rel 115 | 116 | 117 | -- Elimination 118 | 119 | foldIt :: (o -> s) -> ((Maybe i -> s) -> s) -> (It i o -> s) 120 | foldIt p k = go where go = mfoldIt p (mk k) 121 | 122 | mfoldIt :: (o -> s) -> (forall x . (x -> s) -> ((Maybe i -> x) -> s)) -> (It i o -> s) 123 | mfoldIt p k = go where go = mrunIt p (k . (go .)) 124 | 125 | runIt :: (o -> s) -> ((Maybe i -> It i o) -> s) -> (It i o -> s) 126 | runIt p k = mrunIt p (mk k) 127 | 128 | mrunIt :: (o -> s) -> (forall x . (x -> It i o) -> (Maybe i -> x) -> s) -> (It i o -> s) 129 | mrunIt p k i = getIt i p k 130 | 131 | 132 | -- | Promote a continuation to a Mendler-style continuation. 133 | mk :: ((Maybe i -> t) -> s) -> (forall x . (x -> t) -> (Maybe i -> x) -> s) 134 | mk k = (k .) . (.) 135 | 136 | 137 | evalIt :: Monad m => It i o -> m o 138 | evalIt = foldIt pure ($ Nothing) 139 | 140 | 141 | -- Computation 142 | 143 | feedIt :: It i o -> Maybe i -> It i o 144 | feedIt i r = runIt (const i) ($ r) i 145 | 146 | 147 | -- Parsing 148 | 149 | getLineIt :: It Char Line 150 | getLineIt = loop List.nil Nothing 151 | where 152 | loop acc prev = rollIt $ \case 153 | Just '\n' -> doneIt (Line acc (Just (if prev == Just '\r' then CRLF else LF))) 154 | Just c -> loop (List.snoc acc c) (Just c) 155 | Nothing -> doneIt (Line acc Nothing) 156 | 157 | getLinesIt :: It Char [Line] 158 | getLinesIt = repeatIt (guarding (not . nullLine)) getLineIt 159 | 160 | guarding :: Alternative m => (a -> Bool) -> (a -> m a) 161 | guarding p a = a <$ guard (p a) 162 | 163 | 164 | -- Enumerators 165 | 166 | type Enumerator i m o = It i o -> m (It i o) 167 | 168 | enumList :: Monad m => [r] -> Enumerator r m a 169 | enumList = fmap pure . foldr (\ c cs i -> runIt (const i) (cs . ($ Just c)) i) id 170 | 171 | enumFile :: Has (Lift IO) sig m => FilePath -> Enumerator Char m a 172 | enumFile path = withFile' path ReadMode . flip enumHandle 173 | 174 | enumHandle :: Has (Lift IO) sig m => Handle -> Enumerator Char m a 175 | enumHandle handle i = runIt (const (pure i)) (allocaBytes' size . loop) i 176 | where 177 | size = 4096 178 | loop k p = do 179 | n <- sendIO (hGetBuf handle p size) 180 | sendIO (peekCAStringLen (p, n)) >>= \case 181 | c:cs -> enumList cs (k (Just c)) 182 | "" -> pure (k Nothing) 183 | 184 | allocaBytes' :: Has (Lift IO) sig m => Int -> (Ptr a -> m b) -> m b 185 | allocaBytes' n b = liftWith (\ hdl ctx -> allocaBytes n (\ p -> hdl (b p <$ ctx))) 186 | 187 | withFile' :: Has (Lift IO) sig m => FilePath -> IOMode -> (Handle -> m r) -> m r 188 | withFile' path mode body = liftWith (\ hdl ctx -> withFile path mode (\ h -> hdl (body h <$ ctx))) 189 | 190 | 191 | -- Enumeratees 192 | 193 | type Enumeratee i o a = It i a -> It o (It i a) 194 | 195 | take :: Int -> Enumeratee i i o 196 | take = go 197 | where 198 | go n 199 | | n <= 0 = pure 200 | | otherwise = \ i -> runIt (const (pure i)) (rollIt . (go (n - 1) .)) i 201 | -------------------------------------------------------------------------------- /src/Sequoia/Monad/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | -- | Lowering (running) “pure” monads to a value. 3 | module Sequoia.Monad.Run 4 | ( -- * Lowering 5 | MonadRun(..) 6 | -- * CPS lowering 7 | , MonadRunK(..) 8 | -- * Construction 9 | , fn 10 | , inKM 11 | , cont 12 | , contK 13 | -- * Defaults 14 | , withRunWithRep 15 | , distributeRun 16 | , collectRun 17 | ) where 18 | 19 | import Data.Functor.Identity 20 | import Data.Functor.Rep 21 | import Sequoia.Profunctor.Continuation 22 | 23 | -- Lowering 24 | 25 | class Monad m => MonadRun m where 26 | withRun :: ((forall r . m r -> r) -> m a) -> m a 27 | 28 | instance MonadRun ((->) a) where 29 | withRun b a = b ($ a) a 30 | 31 | instance MonadRun Identity where 32 | withRun b = b runIdentity 33 | 34 | instance MonadRun ((•) a) where 35 | withRun b = K (\ a -> b (• a) • a) 36 | 37 | 38 | -- CPS lowering 39 | 40 | class Monad m => MonadRunK r m | m -> r where 41 | withRunK :: ((forall x . x • r -> m x -> r) -> m a) -> m a 42 | 43 | instance MonadRunK r (DN r) where 44 | withRunK f = DN (K (\ k -> runDN (f (\ k m -> runDN m • k)) • k)) 45 | 46 | 47 | -- Construction 48 | 49 | fn :: MonadRun m => (a -> m r) -> m (a -> r) 50 | fn = distributeRun 51 | 52 | inKM :: MonadRun m => (a -> m r) -> m (a • r) 53 | inKM = fmap K . fn 54 | 55 | cont :: MonadRun m => ((forall b . (b -> m r) -> b • r) -> m a) -> m a 56 | cont f = withRun (\ run -> f (K . (run .))) 57 | 58 | contK :: MonadRunK r m => ((forall b . (b -> m r) -> b • r) -> m a) -> m a 59 | contK f = withRunK (\ run -> f (K . (run idK .))) 60 | 61 | 62 | -- Defaults 63 | 64 | withRunWithRep :: Representable f => Rep f -> ((forall r . f r -> r) -> f a) -> f a 65 | withRunWithRep r b = b (`index` r) 66 | 67 | distributeRun :: (MonadRun f, Functor g) => g (f a) -> f (g a) 68 | distributeRun = collectRun id 69 | 70 | collectRun :: (MonadRun f, Functor g) => (a -> f b) -> g a -> f (g b) 71 | collectRun f g = withRun (\ run -> pure (run . f <$> g)) 72 | -------------------------------------------------------------------------------- /src/Sequoia/Monad/Trans/It.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Monad.Trans.It 2 | ( -- * Iteratees 3 | ItT(..) 4 | , ItP(..) 5 | -- * Construction 6 | , itT 7 | , doneItT 8 | -- * Elimination 9 | , runItT 10 | , foldItT 11 | -- * Computation 12 | , dimapItT 13 | ) where 14 | 15 | import Control.Monad (ap) 16 | import Control.Monad.Trans.Class 17 | import Data.Profunctor 18 | 19 | -- Iteratees 20 | 21 | -- | Scott–encoded iteratee monad transformer, based loosely on the one in @trifecta@. 22 | newtype ItT r m a = ItT { getItT :: forall s . (a -> m s) -> ((r -> ItT r m a) -> m s) -> m s } 23 | 24 | instance Functor (ItT r m) where 25 | fmap f = go where go i = ItT (\ k r -> getItT i (k . f) (r . fmap go)) 26 | 27 | instance Applicative (ItT r m) where 28 | pure = doneItT 29 | (<*>) = ap 30 | 31 | instance Monad (ItT r m) where 32 | i >>= f = go i where go i = ItT (\ k r -> runItT (runItT k r . f) (r . fmap go) i) 33 | 34 | instance MonadTrans (ItT r) where 35 | lift m = ItT (const . (m >>=)) 36 | 37 | 38 | newtype ItP m r a = ItP { getItP :: ItT r m a } 39 | 40 | instance Profunctor (ItP m) where 41 | dimap f g (ItP i) = ItP (dimapItT f g i) 42 | 43 | 44 | -- Construction 45 | 46 | itT :: (r -> ItT r m a) -> ItT r m a 47 | itT r = ItT (const ($ r)) 48 | 49 | doneItT :: a -> ItT r m a 50 | doneItT a = ItT (const . ($ a)) 51 | 52 | 53 | -- Elimination 54 | 55 | runItT :: (a -> m s) -> ((r -> ItT r m a) -> m s) -> (ItT r m a -> m s) 56 | runItT k r i = getItT i k r 57 | 58 | foldItT :: (a -> m s) -> ((r -> m s) -> m s) -> (ItT r m a -> m s) 59 | foldItT k r = go where go = runItT k (r . fmap go) 60 | 61 | 62 | -- Computation 63 | 64 | dimapItT :: (r' -> r) -> (a -> a') -> ItT r m a -> ItT r' m a' 65 | dimapItT f g = go where go i = ItT (\ k r -> runItT (k . g) (r . (go .) . (. f)) i) 66 | -------------------------------------------------------------------------------- /src/Sequoia/Nulladjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | -- | Adjunctions between nullary “functors”. 3 | module Sequoia.Nulladjunction 4 | ( -- * Nullary adjunctions 5 | Nulladjunction(..) 6 | ) where 7 | 8 | import Data.Void 9 | 10 | -- Nullary adjunctions 11 | 12 | class Nulladjunction f u | f -> u, u -> f where 13 | nullleftAdjunct :: (f -> b) -> (a -> u) 14 | nullrightAdjunct :: (a -> u) -> (f -> b) 15 | 16 | instance Nulladjunction Void () where 17 | nullleftAdjunct _ _ = () 18 | nullrightAdjunct _ = absurd 19 | -------------------------------------------------------------------------------- /src/Sequoia/Polarity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Sequoia.Polarity 5 | ( -- * Polarities 6 | N(..) 7 | , P(..) 8 | -- * Polarization 9 | , Polarized 10 | , Neg 11 | , Pos 12 | ) where 13 | 14 | import Data.Distributive 15 | import Data.Functor.Adjunction as Co 16 | import Data.Functor.Identity 17 | import Data.Functor.Rep as Co 18 | import Data.Kind (Type) 19 | 20 | -- Polarities 21 | 22 | newtype N a = N { getN :: a } 23 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 24 | deriving (Applicative, Monad, Co.Representable) via Identity 25 | 26 | instance Distributive N where 27 | distribute = N . fmap getN 28 | 29 | instance Co.Adjunction N P where 30 | unit = P . N 31 | counit = getP . getN 32 | leftAdjunct f a = P (f ( N a)) 33 | rightAdjunct f a = getP (f (getN a)) 34 | 35 | newtype P a = P { getP :: a } 36 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 37 | deriving (Applicative, Monad, Co.Representable) via Identity 38 | 39 | instance Distributive P where 40 | distribute = P . fmap getP 41 | 42 | instance Co.Adjunction P N where 43 | unit = N . P 44 | counit = getN . getP 45 | leftAdjunct f a = N (f ( P a)) 46 | rightAdjunct f a = getN (f (getP a)) 47 | 48 | 49 | -- Polarization 50 | 51 | class Polarized (p :: Type -> Type) c | c -> p 52 | 53 | instance Polarized N (N a) 54 | instance Polarized P (P a) 55 | 56 | type Neg = Polarized N 57 | type Pos = Polarized P 58 | -------------------------------------------------------------------------------- /src/Sequoia/Print/Class.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Print.Class 2 | ( -- * Pretty-printing 3 | Document(..) 4 | -- * Combinators 5 | , parensIf 6 | , concatWith 7 | , hsep 8 | , vsep 9 | , fillSep 10 | , sep 11 | , hcat 12 | , vcat 13 | , fillCat 14 | , cat 15 | , punctuate 16 | , enclose 17 | , encloseSep 18 | , list 19 | , tupled 20 | , surround 21 | , (<+>) 22 | , () 23 | -- * Characters 24 | , lparen 25 | , rparen 26 | , lbracket 27 | , rbracket 28 | , lbrace 29 | , rbrace 30 | , langle 31 | , rangle 32 | , squote 33 | , dquote 34 | , space 35 | , space' 36 | , line 37 | , line' 38 | , softline 39 | , softline' 40 | , semi 41 | , comma 42 | , colon 43 | , dot 44 | , slash 45 | , backslash 46 | , equals 47 | , pipe 48 | -- * Responsive documents 49 | , ResponsiveDocument(..) 50 | -- * Combinators 51 | , align 52 | , hang 53 | , indent 54 | , width 55 | , fill 56 | , fillBreak 57 | ) where 58 | 59 | import Control.Applicative (liftA2) 60 | import Data.Foldable (fold) 61 | import Data.Maybe (fromMaybe) 62 | import Data.Semigroup 63 | 64 | -- Pretty-printing 65 | 66 | class Monoid p => Document p where 67 | {-# MINIMAL char | string #-} 68 | char :: Char -> p 69 | char c = string [c] 70 | string :: String -> p 71 | string = foldMap char 72 | 73 | enclosing :: p -> p -> p -> p 74 | enclosing = enclose 75 | 76 | parens :: p -> p 77 | parens = enclosing lparen rparen 78 | 79 | brackets :: p -> p 80 | brackets = enclosing lbracket rbracket 81 | 82 | braces :: p -> p 83 | braces = enclosing lbrace rbrace 84 | 85 | angles :: p -> p 86 | angles = enclosing langle rangle 87 | 88 | squotes :: p -> p 89 | squotes = enclosing squote squote 90 | 91 | dquotes :: p -> p 92 | dquotes = enclosing dquote dquote 93 | 94 | hardline :: p 95 | hardline = char '\n' 96 | 97 | 98 | group :: p -> p 99 | group = id 100 | 101 | flatAlt :: p -> p -> p 102 | flatAlt = const 103 | 104 | nest :: Int -> p -> p 105 | nest _ = id 106 | 107 | 108 | instance Document b => Document (a -> b) where 109 | char = pure . char 110 | string = pure . string 111 | 112 | enclosing l r x = enclosing <$> l <*> r <*> x 113 | 114 | parens = fmap parens 115 | brackets = fmap brackets 116 | braces = fmap braces 117 | angles = fmap angles 118 | squotes = fmap squotes 119 | dquotes = fmap dquotes 120 | 121 | hardline = pure hardline 122 | 123 | group = fmap group 124 | flatAlt = liftA2 flatAlt 125 | nest i = fmap (nest i) 126 | 127 | 128 | -- Combinators 129 | 130 | parensIf :: Document p => Bool -> p -> p 131 | parensIf True = parens 132 | parensIf False = id 133 | 134 | concatWith :: (Monoid p, Foldable t) => (p -> p -> p) -> t p -> p 135 | concatWith (<>) = fromMaybe mempty . foldr (\ a -> Just . maybe a (a <>)) Nothing 136 | 137 | 138 | hsep :: (Document p, Foldable t) => t p -> p 139 | hsep = concatWith (<+>) 140 | 141 | vsep :: (Document p, Foldable t) => t p -> p 142 | vsep = concatWith () 143 | 144 | fillSep :: (Document p, Foldable t) => t p -> p 145 | fillSep = concatWith (surround softline) 146 | 147 | sep :: (Document p, Foldable t) => t p -> p 148 | sep = group . vsep 149 | 150 | 151 | hcat :: (Document p, Foldable t) => t p -> p 152 | hcat = fold 153 | 154 | vcat :: (Document p, Foldable t) => t p -> p 155 | vcat = concatWith (surround line') 156 | 157 | fillCat :: (Document p, Foldable t) => t p -> p 158 | fillCat = concatWith (surround softline') 159 | 160 | cat :: (Document p, Foldable t) => t p -> p 161 | cat = group . vcat 162 | 163 | 164 | punctuate :: (Document p, Foldable t) => p -> t p -> [p] 165 | punctuate s = fromMaybe [] . foldr (\ a -> maybe (Just [a]) (Just . (a <> s :))) Nothing 166 | 167 | 168 | enclose :: Semigroup p => p -> p -> p -> p 169 | enclose l r x = l <> x <> r 170 | 171 | 172 | encloseSep :: (Document p, Foldable t) => p -> p -> p -> t p -> p 173 | encloseSep l r s = enclose l r . group . concatWith (surround (line' <> s)) 174 | 175 | 176 | list :: (Document p, Foldable t) => t p -> p 177 | list = group . brackets . encloseSep space' space' (comma <> space) 178 | 179 | tupled :: (Document p, Foldable t) => t p -> p 180 | tupled = group . parens . encloseSep space' space' (comma <> space) 181 | 182 | 183 | surround :: Semigroup p => p -> p -> p -> p 184 | surround x l r = enclose l r x 185 | 186 | 187 | (<+>) :: Document p => p -> p -> p 188 | (<+>) = surround space 189 | 190 | infixr 6 <+> 191 | 192 | () :: Document p => p -> p -> p 193 | () = surround line 194 | 195 | infixr 6 196 | 197 | 198 | -- Characters 199 | 200 | lparen, rparen :: Document p => p 201 | lparen = char '(' 202 | rparen = char ')' 203 | 204 | lbracket, rbracket :: Document p => p 205 | lbracket = char '[' 206 | rbracket = char ']' 207 | 208 | lbrace, rbrace :: Document p => p 209 | lbrace = char '{' 210 | rbrace = char '}' 211 | 212 | langle, rangle :: Document p => p 213 | langle = char '<' 214 | rangle = char '>' 215 | 216 | squote, dquote :: Document p => p 217 | squote = char '\'' 218 | dquote = char '"' 219 | 220 | space, space', line, line', softline, softline' :: Document p => p 221 | space = char ' ' 222 | space' = flatAlt space mempty 223 | line = flatAlt hardline space 224 | line' = flatAlt hardline mempty 225 | softline = flatAlt space hardline 226 | softline' = flatAlt mempty hardline 227 | 228 | semi, comma, colon, dot, slash, backslash, equals, pipe :: Document p => p 229 | semi = char ';' 230 | comma = char ',' 231 | colon = char ':' 232 | dot = char '.' 233 | slash = char '/' 234 | backslash = char '\\' 235 | equals = char '=' 236 | pipe = char '|' 237 | 238 | 239 | -- Responsive documents 240 | 241 | class Document p => ResponsiveDocument p where 242 | column :: (Int -> p) -> p 243 | nesting :: (Int -> p) -> p 244 | 245 | instance ResponsiveDocument b => ResponsiveDocument (a -> b) where 246 | column f a = column (`f` a) 247 | nesting f a = nesting (`f` a) 248 | 249 | 250 | -- Combinators 251 | 252 | align :: ResponsiveDocument p => p -> p 253 | align d = column (\ k -> nesting (\ i -> nest (k - i) d)) 254 | 255 | hang :: ResponsiveDocument p => Int -> p -> p 256 | hang = fmap align . nest 257 | 258 | indent :: ResponsiveDocument p => Int -> p -> p 259 | indent i d = hang i (stimes i space <> d) 260 | 261 | 262 | width :: ResponsiveDocument p => p -> (Int -> p) -> p 263 | width p f = column $ \ start -> p <> column (\ end -> f (end - start)) 264 | 265 | 266 | fill :: ResponsiveDocument p => Int -> p -> p 267 | fill n p = width p $ \ w -> stimes (n - w) space 268 | 269 | fillBreak :: ResponsiveDocument p => Int -> p -> p 270 | fillBreak f x = width x $ \case 271 | w | w > f -> nest f line' 272 | | otherwise -> stimes (f - w) space 273 | -------------------------------------------------------------------------------- /src/Sequoia/Print/Doc.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Print.Doc 2 | ( -- * Documents 3 | Doc(..) 4 | ) where 5 | 6 | import Data.Monoid (Endo(..)) 7 | import Sequoia.Print.Class 8 | 9 | -- Documents 10 | 11 | newtype Doc = Doc { getDoc :: ShowS } 12 | deriving (Monoid, Semigroup) via Endo String 13 | 14 | instance Show Doc where 15 | showsPrec _ = getDoc 16 | 17 | instance Document Doc where 18 | char c = Doc (c:) 19 | string s = Doc (s<>) 20 | -------------------------------------------------------------------------------- /src/Sequoia/Print/Prec.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Print.Prec 2 | ( -- * Precedence printing 3 | Prec(..) 4 | , PrecPrinter(..) 5 | -- * Construction 6 | , prec 7 | , atom 8 | -- * Elimination 9 | , withPrec 10 | ) where 11 | 12 | import Data.Functor.Contravariant 13 | import Sequoia.Print.Class 14 | 15 | -- Precedence printing 16 | 17 | newtype Prec = Prec { getPrec :: Int } 18 | deriving (Eq, Ord, Show) 19 | 20 | newtype PrecPrinter p a = PrecPrinter { runPrecPrinter :: Prec -> p a } 21 | deriving (Functor) 22 | 23 | instance Contravariant p => Contravariant (PrecPrinter p) where 24 | contramap f (PrecPrinter r) = PrecPrinter (contramap f . r) 25 | 26 | 27 | -- Construction 28 | 29 | prec :: Document (p a) => Prec -> p a -> PrecPrinter p a 30 | prec i pr = PrecPrinter $ \ i' -> parensIf (i' > i) pr 31 | 32 | atom :: p a -> PrecPrinter p a 33 | atom = PrecPrinter . const 34 | 35 | 36 | -- Elimination 37 | 38 | withPrec :: Prec -> PrecPrinter p a -> p a 39 | withPrec = flip runPrecPrinter 40 | -------------------------------------------------------------------------------- /src/Sequoia/Print/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | -- | Pretty-printing. 4 | module Sequoia.Print.Printer 5 | ( -- * Printers 6 | Printer(..) 7 | -- * Construction 8 | , printer 9 | , withSubject 10 | -- * Elimination 11 | , getPrint 12 | , print 13 | , appPrint 14 | , runPrint 15 | -- * Combinators 16 | , tuple 17 | , list 18 | , char1 19 | , string1 20 | ) where 21 | 22 | import Data.List (uncons) 23 | import Data.List.NonEmpty (nonEmpty, toList) 24 | import Data.Profunctor 25 | import Prelude hiding (exp, print) 26 | import Sequoia.Print.Class hiding (list) 27 | import Sequoia.Profunctor.Applicative 28 | import Sequoia.Profunctor.Continuation 29 | import Sequoia.Profunctor.Exp 30 | 31 | -- Printers 32 | 33 | newtype Printer r a b = Printer (a ~~r~> b) 34 | deriving (Applicative, Choice, Cochoice, Functor, Monad, Profunctor, Strong) 35 | 36 | instance Semigroup b => Semigroup (Printer r a b) where 37 | p1 <> p2 = printer (\ k a -> appPrint p1 a (appPrint p2 a . ((`lmap` k) . (<>)))) 38 | 39 | instance Monoid b => Monoid (Printer r a b) where 40 | mempty = printer (const . ($ mempty)) 41 | 42 | instance Document b => Document (Printer r a b) where 43 | char c = printer (const . ($ char c)) 44 | string s = printer (const . ($ string s)) 45 | 46 | instance Coapply r (Printer r) where 47 | pf <&> pa = printer (\ k b -> getPrint pf k (K (getPrint pa k) >- b)) 48 | 49 | instance Coapplicative r (Printer r) where 50 | copure = printer . const . (•) . runCoexp 51 | 52 | instance ProfunctorCPS r (Printer r) where 53 | dimapCPS f g p = printer (getExpFn f . getPrint p . getExpFn g) 54 | lmapCPS f p = printer (getExpFn f . getPrint p) 55 | rmapCPS f p = printer (getPrint p . getExpFn f) 56 | 57 | 58 | -- Construction 59 | 60 | printer :: ((b -> r) -> (a -> r)) -> Printer r a b 61 | printer = Printer . expFn 62 | 63 | withSubject :: (a -> Printer r a b) -> Printer r a b 64 | withSubject f = printer (\ k -> runPrint k <*> f) 65 | 66 | 67 | -- Elimination 68 | 69 | getPrint :: Printer r a b -> ((b -> r) -> (a -> r)) 70 | getPrint (Printer r) = getExpFn r 71 | 72 | print :: Printer b a b -> a -> b 73 | print p = getPrint p id 74 | 75 | runPrint :: (b -> r) -> a -> Printer r a b -> r 76 | runPrint k a p = getPrint p k a 77 | 78 | appPrint :: Printer r a b -> a -> (b -> r) -> r 79 | appPrint p a k = getPrint p k a 80 | 81 | 82 | -- Combinators 83 | 84 | tuple :: (forall a b . Document b => Document (p a b), Document c, Coapplicative co p) => p a c -> p b c -> p (a, b) c 85 | tuple a b = parens (lmap fst a <> comma <+> lmap snd b) 86 | 87 | list :: (forall a b . Document b => Document (p a b), Document b, ProfunctorCPS r p, Coapplicative r p) => p a b -> p [a] b 88 | list pa = brackets go 89 | where 90 | go = maybeToEither . uncons <#> mempty <&> lmap fst pa <> lmap snd tail 91 | tail = fmap toList . maybeToEither . nonEmpty <#> mempty <&> comma <> space <> go 92 | 93 | maybeToEither :: Maybe a -> Either () a 94 | maybeToEither = maybe (Left ()) Right 95 | 96 | char1 :: Document b => Printer r Char b 97 | char1 = printer (. char) 98 | 99 | string1 :: Document b => Printer r String b 100 | string1 = printer (. string) 101 | -------------------------------------------------------------------------------- /src/Sequoia/Print/Sequent.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Print.Sequent 2 | ( -- * Printable sequents 3 | Seq(..) 4 | -- * Elimination 5 | , appSeq 6 | , printSeq 7 | ) where 8 | 9 | import Control.Monad (ap) 10 | import Data.Profunctor 11 | import Prelude hiding (print) 12 | import Sequoia.Calculus.Core 13 | import Sequoia.Conjunction 14 | import Sequoia.Disjunction 15 | import Sequoia.Print.Doc 16 | import Sequoia.Print.Printer 17 | 18 | -- Printable sequents 19 | 20 | newtype Seq e r _Γ _Δ = Seq { runSeq :: Printer r _Δ Doc -> Printer r _Γ Doc } 21 | 22 | instance Profunctor (Seq e r) where 23 | dimap f g = Seq . dimap (lmap g) (lmap f) . runSeq 24 | 25 | instance Functor (Seq e r _Γ) where 26 | fmap = rmap 27 | 28 | instance Applicative (Seq e r _Γ) where 29 | pure = Seq . lmap . const 30 | (<*>) = ap 31 | 32 | instance Monad (Seq e r _Γ) where 33 | Seq r >>= f = Seq (\ _Δ -> printer (\ k _Γ -> getPrint (r (lmap f (printSeq _Γ _Δ))) k _Γ)) 34 | 35 | 36 | -- Elimination 37 | 38 | appSeq :: Seq e r _Γ _Δ -> _Γ -> Printer r _Δ Doc -> (Doc -> r) -> r 39 | appSeq s _Γ pΔ k = getPrint (runSeq s pΔ) k _Γ 40 | 41 | printSeq :: _Γ -> Printer r _Δ Doc -> Printer r (Seq e r _Γ _Δ) Doc 42 | printSeq _Γ _Δ = printer (\ k s -> appSeq s _Γ _Δ k) 43 | 44 | 45 | -- Core 46 | 47 | instance Core Seq where 48 | l >>> r = l >>= pure <--> \ a -> lmap (a >--<) r 49 | init = Seq (dimap (lmap inr) (lmap exl) id) 50 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Profunctor 2 | ( -- * Profunctors 3 | module Data.Profunctor 4 | -- * Composition 5 | , (^>>) 6 | , (<<^) 7 | , (>>^) 8 | , (^<<) 9 | ) where 10 | 11 | import Data.Profunctor 12 | 13 | -- Composition 14 | 15 | (^>>) :: Profunctor p => (a' -> a) -> (a `p` b) -> (a' `p` b) 16 | (^>>) = lmap 17 | 18 | (<<^) :: Profunctor p => (a `p` b) -> (a' -> a) -> (a' `p` b) 19 | (<<^) = flip lmap 20 | 21 | infixr 1 ^>>, <<^ 22 | 23 | (>>^) :: Profunctor p => (a `p` b) -> (b -> b') -> (a `p` b') 24 | (>>^) = flip rmap 25 | 26 | (^<<) :: Profunctor p => (b -> b') -> (a `p` b) -> (a `p` b') 27 | (^<<) = rmap 28 | 29 | infixr 1 >>^, ^<< 30 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Adjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Sequoia.Profunctor.Adjunction 5 | ( Adjunction(..) 6 | , cosieveAdjunction 7 | , cotabulateAdjunction 8 | , Coadjunction(..) 9 | , sieveCoadjunction 10 | , tabulateCoadjunction 11 | -- * Composition 12 | , Adjoint(..) 13 | , Coadjoint(..) 14 | , Boring(..) 15 | , Coboring(..) 16 | ) where 17 | 18 | import Control.Comonad 19 | import qualified Data.Functor.Adjunction as Co 20 | import Data.Functor.Const 21 | import Data.Functor.Contravariant 22 | import qualified Data.Functor.Contravariant.Adjunction as Contra 23 | import qualified Data.Functor.Contravariant.Rep as Contra 24 | import qualified Data.Functor.Rep as Co 25 | import Data.Profunctor 26 | import qualified Data.Profunctor.Rep as Pro 27 | import Data.Profunctor.Sieve 28 | 29 | -- | A covariant adjunction between two profunctors. 30 | class (Profunctor f, Pro.Corepresentable u) => Adjunction f u | f -> u, u -> f where 31 | {-# MINIMAL (leftUnit | leftAdjunct), (rightUnit | rightAdjunct) #-} 32 | 33 | leftUnit :: a -> u b (f b a) 34 | rightUnit :: f b (u b a) -> a 35 | 36 | leftUnit = leftAdjunct id 37 | rightUnit = rightAdjunct id 38 | 39 | leftAdjunct :: (f a b -> c) -> ( b -> u a c) 40 | rightAdjunct :: ( b -> u a c) -> (f a b -> c) 41 | 42 | leftAdjunct f = rmap f . leftUnit 43 | rightAdjunct f = rightUnit . rmap f 44 | 45 | 46 | cosieveAdjunction :: Adjunction f u => u a b -> (f a c -> b) 47 | cosieveAdjunction = rightAdjunct . const 48 | 49 | cotabulateAdjunction :: Adjunction f u => (f a () -> b) -> u a b 50 | cotabulateAdjunction f = leftAdjunct f () 51 | 52 | 53 | -- | A contravariant adjunction between two profunctors. 54 | class (Profunctor f, Pro.Representable u) => Coadjunction f u | f -> u, u -> f where 55 | {-# MINIMAL (leftCounit | leftCoadjunct), (rightCounit | rightCoadjunct) #-} 56 | 57 | leftCounit :: a -> u (f a b) b 58 | rightCounit :: a -> f (u a b) b 59 | 60 | leftCounit = leftCoadjunct id 61 | rightCounit = rightCoadjunct id 62 | 63 | leftCoadjunct :: (a -> f b c) -> (b -> u a c) 64 | rightCoadjunct :: (a -> u b c) -> (b -> f a c) 65 | 66 | leftCoadjunct f = lmap f . leftCounit 67 | rightCoadjunct f = lmap f . rightCounit 68 | 69 | instance Coadjunction (->) (->) where 70 | leftCounit = flip ($) 71 | rightCounit = flip ($) 72 | leftCoadjunct = flip 73 | rightCoadjunct = flip 74 | 75 | 76 | sieveCoadjunction :: Coadjunction f u => u a b -> (a -> f c b) 77 | sieveCoadjunction = rightCoadjunct . const 78 | 79 | tabulateCoadjunction :: Coadjunction f u => (a -> f () b) -> u a b 80 | tabulateCoadjunction f = leftCoadjunct f () 81 | 82 | 83 | newtype Adjoint f u a b = Adjoint { runAdjoint :: u a (f a b) } 84 | 85 | instance (Profunctor f, Profunctor u) => Profunctor (Adjoint f u) where 86 | dimap f g = Adjoint . dimap f (dimap f g) . runAdjoint 87 | 88 | instance (Profunctor f, Profunctor u) => Functor (Adjoint f u a) where 89 | fmap = rmap 90 | 91 | instance Adjunction f u => Applicative (Adjoint f u a) where 92 | pure = Adjoint . leftUnit 93 | Adjoint f <*> a = Adjoint (rmap (rightAdjunct (runAdjoint . (<$> a))) f) 94 | 95 | instance Adjunction f u => Monad (Adjoint f u a) where 96 | Adjoint u >>= f = Adjoint (rmap (rightAdjunct (runAdjoint . f)) u) 97 | 98 | instance Adjunction f u => Comonad (Adjoint u f a) where 99 | extract = rightUnit . runAdjoint 100 | extend f = Adjoint . rmap (leftAdjunct (f . Adjoint)) . runAdjoint 101 | duplicate = Adjoint . rmap (leftAdjunct Adjoint) . runAdjoint 102 | 103 | 104 | newtype Coadjoint f u a b = Coadjoint { runCoadjoint :: u (f b a) b } 105 | 106 | instance (Profunctor f, Profunctor u) => Profunctor (Coadjoint f u) where 107 | dimap f g = Coadjoint . dimap (dimap g f) g . runCoadjoint 108 | 109 | instance (Profunctor f, Profunctor u) => Functor (Coadjoint f u a) where 110 | fmap = rmap 111 | 112 | 113 | -- | Lift a boring old covariant 'Functor' into a 'Profunctor'. 114 | newtype Boring f a b = Boring { runBoring :: f b } 115 | 116 | instance Functor f => Profunctor (Boring f) where 117 | dimap _ g = Boring . fmap g . runBoring 118 | 119 | instance Functor f => Costrong (Boring f) where 120 | unfirst = Boring . fmap fst . runBoring 121 | unsecond = Boring . fmap snd . runBoring 122 | 123 | instance Functor f => Choice (Boring f) where 124 | left' = Boring . fmap Left . runBoring 125 | right' = Boring . fmap Right . runBoring 126 | 127 | instance Functor f => Sieve (Boring f) f where 128 | sieve = const . runBoring 129 | 130 | instance (Co.Representable f, Co.Rep f ~ r) => Cosieve (Boring f) (Const r) where 131 | cosieve = lmap getConst . Co.index . runBoring 132 | 133 | instance Co.Representable f => Pro.Corepresentable (Boring f) where 134 | type Corep (Boring f) = Const (Co.Rep f) 135 | cotabulate f = Boring (Co.tabulate (f . Const)) 136 | 137 | instance Co.Adjunction f u => Adjunction (Boring f) (Boring u) where 138 | leftAdjunct f a = Boring (Co.leftAdjunct (f . Boring) a) 139 | rightAdjunct f a = Co.rightAdjunct (runBoring . f) (runBoring a) 140 | 141 | 142 | -- | Lift a boring old 'Contravariant' functor into a 'Profunctor'. 143 | newtype Coboring f a b = Coboring { runCoboring :: f a } 144 | 145 | instance Contravariant f => Profunctor (Coboring f) where 146 | dimap f _ = Coboring . contramap f . runCoboring 147 | 148 | instance Contravariant f => Strong (Coboring f) where 149 | first' = Coboring . contramap fst . runCoboring 150 | second' = Coboring . contramap snd . runCoboring 151 | 152 | instance Contravariant f => Cochoice (Coboring f) where 153 | unleft = Coboring . contramap Left . runCoboring 154 | unright = Coboring . contramap Right . runCoboring 155 | 156 | instance (Contra.Representable f, Contra.Rep f ~ r) => Sieve (Coboring f) (Const r) where 157 | sieve = fmap Const . Contra.index . runCoboring 158 | 159 | instance Contra.Representable f => Pro.Representable (Coboring f) where 160 | type Rep (Coboring f) = Const (Contra.Rep f) 161 | tabulate = Coboring . Contra.tabulate . fmap getConst 162 | 163 | instance Contra.Adjunction f u => Coadjunction (Coboring f) (Coboring u) where 164 | leftCoadjunct f a = Coboring (Contra.leftAdjunct (runCoboring . f) a) 165 | rightCoadjunct f a = Coboring (Contra.rightAdjunct (runCoboring . f) a) 166 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Applicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Sequoia.Profunctor.Applicative 3 | ( ProfunctorCPS(..) 4 | , (<#>) 5 | , Coapply(..) 6 | , Coapplicative(..) 7 | ) where 8 | 9 | import Control.Category as Cat hiding ((.)) 10 | import Data.Profunctor 11 | import Prelude hiding (exp) 12 | import Sequoia.Profunctor 13 | import Sequoia.Profunctor.Exp 14 | 15 | class Profunctor p => ProfunctorCPS r p | p -> r where 16 | {-# MINIMAL dimapCPS | (lmapCPS, rmapCPS) #-} 17 | 18 | dimapCPS :: (a' ~~r~> a) -> (b ~~r~> b') -> (p a b -> p a' b') 19 | dimapCPS f g = rmapCPS g . lmapCPS f 20 | 21 | lmapCPS :: (a' ~~r~> a) -> (p a b -> p a' b) 22 | lmapCPS = (`dimapCPS` Cat.id) 23 | 24 | rmapCPS :: (b ~~r~> b') -> (p a b -> p a b') 25 | rmapCPS = (Cat.id `dimapCPS`) 26 | 27 | (<#>) :: ProfunctorCPS r p => (c -> Either a b) -> p a d -> p (b >-r-~ c) d 28 | (<#>) = lmapCPS . cocurry . exp' 29 | 30 | infixl 3 <#> 31 | 32 | class Profunctor p => Coapply r p | p -> r where 33 | {-# MINIMAL coliftC2 | (<&>) #-} 34 | 35 | coliftC2 :: ((b >-r-~ c) -> a) -> p a d -> p b d -> p c d 36 | coliftC2 f = (<&>) . lmap f 37 | 38 | (<&>) :: p (a >-r-~ b) d -> p a d -> p b d 39 | (<&>) = coliftC2 Prelude.id 40 | 41 | infixl 3 <&> 42 | 43 | instance Coapply r (Exp r) where 44 | coliftC2 f a b = Exp (\ k -> getExp a k <<^ f . (getExp b k :>-)) 45 | f <&> a = Exp (\ k -> getExp f k <<^ (getExp a k :>-)) 46 | 47 | class Coapply r p => Coapplicative r p | p -> r where 48 | copure :: (b -> a) -> p (a >-r-~ b) c 49 | 50 | instance Coapplicative r (Exp r) where 51 | copure = exp . const . runCoexp 52 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Coexponential.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | module Sequoia.Profunctor.Coexponential 3 | ( -- * Coexponential profunctor 4 | Coexp(recallFn, forgetFn) 5 | -- * Construction 6 | , (-<) 7 | , coexpFn 8 | , idCoexp 9 | -- * Elimination 10 | , withCoexpFn 11 | , withCoexp 12 | , runCoexp 13 | , unCoexp 14 | , unCoexpFn 15 | , evalCoexp 16 | , recall 17 | , forget 18 | -- * Optics 19 | , recall_ 20 | , forget_ 21 | ) where 22 | 23 | import Data.Coerce 24 | import Data.Profunctor 25 | import Fresnel.Lens 26 | import Sequoia.Profunctor.Command 27 | import Sequoia.Profunctor.Continuation 28 | import Sequoia.Profunctor.Value 29 | 30 | -- Coexponential profunctor 31 | 32 | data Coexp e r a b = (:-<) { recallFn :: e -> b, forgetFn :: a -> r } 33 | deriving (Functor) 34 | 35 | infixr 6 :-< 36 | 37 | instance Profunctor (Coexp e r) where 38 | dimap g h = unCoexp (\ r f -> rmap h r -< lmap g f) 39 | 40 | 41 | -- Construction 42 | 43 | (-<) :: e ∘ b -> a • r -> Coexp e r a b 44 | v -< k = coexpFn (∘ v) (k •) 45 | 46 | infixr 6 -< 47 | 48 | coexpFn :: (e -> b) -> (a -> r) -> Coexp e r a b 49 | coexpFn = (:-<) 50 | 51 | idCoexp :: Coexp b a a b 52 | idCoexp = coexpFn id id 53 | 54 | 55 | -- Elimination 56 | 57 | withCoexp :: Coexp e r a b -> (e ∘ b -> a • r -> s) -> s 58 | withCoexp c f = f (recall c) (forget c) 59 | 60 | withCoexpFn :: Coexp e r a b -> ((e -> b) -> (a -> r) -> s) -> s 61 | withCoexpFn c = withCoexp c . coerce 62 | 63 | runCoexp :: Coexp e r a b -> ((b -> a) -> (e -> r)) 64 | runCoexp c = withCoexpFn c dimap 65 | 66 | unCoexp :: (e ∘ b -> a • r -> s) -> Coexp e r a b -> s 67 | unCoexp = flip withCoexp 68 | 69 | unCoexpFn :: ((e -> b) -> (a -> r) -> s) -> Coexp e r a b -> s 70 | unCoexpFn = flip withCoexpFn 71 | 72 | evalCoexp :: Coexp e r a a -> e |- r 73 | evalCoexp c = C (\ e -> forget c • e ∘ recall c) 74 | 75 | recall :: Coexp e r a b -> e ∘ b 76 | recall = unCoexp const 77 | 78 | forget :: Coexp e r a b -> a • r 79 | forget = unCoexp (const id) 80 | 81 | 82 | -- Optics 83 | 84 | recall_ :: Lens (Coexp e r a b) (Coexp e' r a b') (e ∘ b) (e' ∘ b') 85 | recall_ = lens recall (\ s recall -> withCoexp s (const (recall -<))) 86 | 87 | forget_ :: Lens (Coexp e r a b) (Coexp e r' a' b) (a • r) (a' • r') 88 | forget_ = lens forget (\ s forget -> withCoexp s (const . (-< forget))) 89 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Sequoia.Profunctor.Command 5 | ( -- * Command profunctor 6 | _C 7 | , type (|-)(..) 8 | -- * Construction 9 | , ckv 10 | , (↓↑) 11 | -- * Composition 12 | , (•<<) 13 | , (>>•) 14 | , (∘>>) 15 | , (<<∘) 16 | -- * Computation 17 | , _CK 18 | , _CV 19 | -- * Ambient environment 20 | , MonadEnv(..) 21 | , val 22 | -- * Ambient control 23 | , MonadRes(..) 24 | , (••) 25 | , (•∘) 26 | ) where 27 | 28 | import Control.Arrow 29 | import Control.Category as Cat (Category) 30 | import Control.Monad (join) 31 | import Data.Distributive 32 | import Data.Functor.Identity 33 | import Data.Functor.Rep as Co 34 | import Data.Profunctor 35 | import Data.Profunctor.Rep as Pro 36 | import Data.Profunctor.Sieve 37 | import Data.Profunctor.Traversing 38 | import Fresnel.Iso 39 | import Sequoia.Functor.Source.Internal 40 | import Sequoia.Monad.Run 41 | import Sequoia.Profunctor.Continuation 42 | import Sequoia.Profunctor.Recall 43 | import Sequoia.Profunctor.Value 44 | 45 | -- Command profunctor 46 | 47 | _C :: Iso (e |- r) (e' |- r') (e -> r) (e' -> r') 48 | _C = coerced 49 | 50 | newtype e |- r = C { (<==) :: e -> r } 51 | deriving (Applicative, Arrow, ArrowApply, ArrowChoice, ArrowLoop, Cat.Category, Choice, Closed, Cochoice, Costrong, Functor, Mapping, Monad, MonadEnv e, MonadRun, Profunctor, Co.Representable, Strong, Traversing) 52 | 53 | infix 6 |- 54 | infixl 1 <== 55 | 56 | instance Distributive ((|-) e) where 57 | distribute = distributeRep 58 | collect = collectRep 59 | 60 | instance Sieve (|-) Identity where 61 | sieve = fmap Identity . (<==) 62 | 63 | instance Cosieve (|-) Identity where 64 | cosieve = lmap runIdentity . (<==) 65 | 66 | instance Pro.Representable (|-) where 67 | type Rep (|-) = Identity 68 | tabulate = C . fmap runIdentity 69 | 70 | instance Pro.Corepresentable (|-) where 71 | type Corep (|-) = Identity 72 | cotabulate = C . lmap Identity 73 | 74 | 75 | -- Construction 76 | 77 | ckv :: (a -> b) -> b • r -> e ∘ a -> e |- r 78 | ckv f k v = C ((k •) . f . (∘ v)) 79 | 80 | (↓↑) :: a • r -> e ∘ a -> e |- r 81 | (↓↑) = ckv id 82 | 83 | infix 9 ↓↑ 84 | 85 | 86 | -- Composition 87 | 88 | (•<<) :: r • s -> e |- r -> e |- s 89 | (•<<) = rmap . (•) 90 | 91 | (>>•) :: e |- r -> r • s -> e |- s 92 | (>>•) = flip (•<<) 93 | 94 | infixr 1 •<<, >>• 95 | 96 | 97 | (∘>>) :: d ∘ e -> e |- r -> d |- r 98 | (∘>>) = lmap . flip (∘) 99 | 100 | (<<∘) :: e |- r -> d ∘ e -> d |- r 101 | (<<∘) = flip (∘>>) 102 | 103 | infixr 1 ∘>>, <<∘ 104 | 105 | 106 | -- Computation 107 | 108 | _CK :: Iso 109 | (e1 |- r1) (e2 |- r2) 110 | (e1 • r1) (e2 • r2) 111 | _CK = coerced 112 | 113 | _CV :: Iso 114 | (e1 |- r1) (e2 |- r2) 115 | (e1 ∘ r1) (e2 ∘ r2) 116 | _CV = coerced 117 | 118 | 119 | -- Ambient environment 120 | 121 | class Monad m => MonadEnv e m | m -> e where 122 | {-# MINIMAL askEnv | env #-} 123 | 124 | askEnv :: m e 125 | askEnv = env pure 126 | 127 | env :: (e -> m a) -> m a 128 | env k = askEnv >>= k 129 | 130 | instance MonadEnv e ((->) e) where 131 | askEnv = id 132 | 133 | env = join 134 | 135 | deriving instance MonadEnv e ((∘) e) 136 | deriving instance MonadEnv e (Recall e a) 137 | 138 | instance MonadEnv e (Src e r) where 139 | env f = Src (\ k -> env ((`runSrcFn` k) . f)) 140 | 141 | val :: MonadEnv e m => (a -> m b) -> (e ∘ a -> m b) 142 | val f v = env (f . (∘ v)) 143 | 144 | 145 | -- Ambient control 146 | 147 | class MonadRes r m | m -> r where 148 | res :: r -> m r 149 | liftRes :: ((m a -> r) -> m a) -> m a 150 | 151 | instance MonadRes r (Src e r) where 152 | res = Src . const . pure 153 | liftRes f = Src (\ k -> env (\ e -> runSrcFn (f (($ e) . (`runSrcFn` k))) k)) 154 | 155 | (••) :: MonadRes r m => a • r -> a -> m r 156 | k •• v = res (k • v) 157 | 158 | infix 8 •• 159 | 160 | 161 | (•∘) :: (MonadEnv e m, MonadRes r m) => a • r -> e ∘ a -> m r 162 | k •∘ v = env (\ e -> res (k • e ∘ v)) 163 | 164 | infix 9 •∘ 165 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Continuation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Profunctor.Continuation 3 | ( -- * Continuation profunctor 4 | type (•)(..) 5 | -- * Continuation abstraction 6 | , Continuation 7 | , ContinuationI(..) 8 | , ContinuationE(..) 9 | -- * Construction 10 | , idK 11 | , constK 12 | -- * Coercion 13 | , _K 14 | , coerceK 15 | -- * Defaults 16 | , protabulateCont 17 | , sieveCont 18 | , cotabulateCont 19 | , cosieveCont 20 | -- * Double negation 21 | , type (••) 22 | , dn 23 | , (=<<^) 24 | , (^>>=) 25 | , (•=<<) 26 | , (>>=•) 27 | , DN(..) 28 | -- * Triple negation 29 | , type (•••) 30 | , tnE 31 | ) where 32 | 33 | import Control.Category (Category) 34 | import Data.Distributive 35 | import Data.Functor.Identity 36 | import Data.Functor.Rep as Co 37 | import Data.Profunctor.Rep as Pro 38 | import Data.Profunctor.Sieve 39 | import Data.Profunctor.Traversing 40 | import Fresnel.Iso 41 | import Sequoia.Profunctor 42 | 43 | -- Continuation profunctor 44 | 45 | newtype a • r = K { runK :: a -> r } 46 | deriving (Applicative, Category, Choice, Closed, Cochoice, Pro.Corepresentable, Costrong, Functor, Mapping, Monad, Profunctor, Co.Representable, Pro.Representable, Strong, Traversing) 47 | 48 | instance Distributive ((•) a) where 49 | distribute = distributeRep 50 | collect = collectRep 51 | 52 | instance Sieve (•) Identity where 53 | sieve = rmap Identity . (•) 54 | 55 | instance Cosieve (•) Identity where 56 | cosieve = lmap runIdentity . (•) 57 | 58 | instance Continuation (•) 59 | 60 | instance ContinuationI (•) where 61 | inK = K 62 | 63 | instance ContinuationE (•) where 64 | (•) = runK 65 | 66 | 67 | -- Continuation abstraction 68 | 69 | class (ContinuationE k, ContinuationI k) => Continuation k 70 | 71 | class Profunctor k => ContinuationI k where 72 | inK :: (a -> r) -> k a r 73 | 74 | class Profunctor k => ContinuationE k where 75 | (•) :: k a r -> (a -> r) 76 | 77 | infixl 8 • 78 | 79 | 80 | -- Construction 81 | 82 | idK :: ContinuationI k => a `k` a 83 | idK = inK id 84 | 85 | constK :: ContinuationI k => r -> a `k` r 86 | constK = inK . const 87 | 88 | 89 | -- Coercion 90 | 91 | _K :: Iso (a • r) (a' • r') (a -> r) (a' -> r') 92 | _K = coerced 93 | 94 | coerceK :: (ContinuationE j, ContinuationI k) => j a r -> k a r 95 | coerceK = inK . (•) 96 | 97 | 98 | -- Defaults 99 | 100 | protabulateCont :: ContinuationI k => (a -> Identity b) -> a `k` b 101 | protabulateCont = inK . rmap runIdentity 102 | 103 | sieveCont :: ContinuationE k => a `k` b -> (a -> Identity b) 104 | sieveCont = rmap Identity . (•) 105 | 106 | cotabulateCont :: ContinuationI k => (Identity a -> b) -> a `k` b 107 | cotabulateCont = inK . lmap Identity 108 | 109 | cosieveCont :: ContinuationE k => a `k` b -> Identity a -> b 110 | cosieveCont = lmap runIdentity . (•) 111 | 112 | 113 | -- Double negation 114 | 115 | type a ••r = a • r • r 116 | 117 | infixl 8 •• 118 | 119 | dn :: (ContinuationE j, ContinuationI k) => a -> (a `j` r) `k` r 120 | dn a = inK (• a) 121 | 122 | 123 | (=<<^) :: (a -> b •• r) -> (a •• r -> b •• r) 124 | f =<<^ m = K (\ k -> m • K ((• k) . f)) 125 | 126 | infixr 1 =<<^ 127 | 128 | (^>>=) :: a •• r -> (a -> b •• r) -> b •• r 129 | m ^>>= f = K (\ k -> m • K ((• k) . f)) 130 | 131 | infixl 1 ^>>= 132 | 133 | 134 | (•=<<) :: Monad m => (a • m b) -> (m a -> m b) 135 | (•=<<) = (=<<) . (•) 136 | 137 | infixr 1 •=<< 138 | 139 | (>>=•) :: Monad m => m a -> (a • m b) -> m b 140 | (>>=•) = (. (•)) . (>>=) 141 | 142 | infixl 1 >>=• 143 | 144 | 145 | newtype DN r a = DN { runDN :: a •• r } 146 | 147 | instance Functor (DN r) where 148 | fmap f = DN . (<<^ (<<^ f)) . runDN 149 | 150 | instance Applicative (DN r) where 151 | pure = DN . dn 152 | DN f <*> DN a = DN (f <<^ (a <<^) . (<<^)) 153 | 154 | instance Monad (DN r) where 155 | DN m >>= f = DN (m ^>>= runDN . f) 156 | 157 | 158 | -- Triple negation 159 | 160 | type a •••r = a • r • r • r 161 | 162 | infixl 8 ••• 163 | 164 | tnE :: a ••• r -> a • r 165 | tnE = (<<^ dn) 166 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Diagonal.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Profunctor.Diagonal 2 | ( -- * Diagonal functors 3 | Diagonal(..) 4 | -- * Codiagonal functors 5 | , Codiagonal(..) 6 | , swap 7 | , mirror 8 | -- * Defaults 9 | , dupArrow 10 | , dedupArrow 11 | ) where 12 | 13 | import Control.Arrow (Arrow(..), Kleisli(..)) 14 | import Control.Comonad 15 | import Data.Profunctor 16 | import Data.Profunctor.Strong 17 | import Data.Tuple (swap) 18 | 19 | -- Diagonal functors 20 | 21 | class Profunctor p => Diagonal p where 22 | dup :: a `p` (a, a) 23 | 24 | instance Diagonal (->) where 25 | dup a = (a, a) 26 | 27 | instance Monad m => Diagonal (Kleisli m) where 28 | dup = Kleisli (pure . dup) 29 | 30 | instance Diagonal p => Diagonal (Pastro p) where 31 | dup = Pastro fst dup (,()) 32 | 33 | instance Diagonal p => Diagonal (Copastro p) where 34 | dup = Copastro (\ f -> f dup) 35 | 36 | instance Applicative f => Diagonal (Star f) where 37 | dup = Star (pure . dup) 38 | 39 | instance Comonad f => Diagonal (Costar f) where 40 | dup = Costar (dup . extract) 41 | 42 | instance Arrow p => Diagonal (WrappedArrow p) where 43 | dup = WrapArrow (arr dup) 44 | 45 | 46 | -- Codiagonal functors 47 | 48 | class Profunctor p => Codiagonal p where 49 | dedup :: Either a a `p` a 50 | 51 | instance Codiagonal (->) where 52 | dedup = either id id 53 | 54 | instance Monad m => Codiagonal (Kleisli m) where 55 | dedup = Kleisli (pure . dedup) 56 | 57 | instance Codiagonal p => Codiagonal (Pastro p) where 58 | dedup = Pastro fst dedup (,()) 59 | 60 | instance Codiagonal p => Codiagonal (Copastro p) where 61 | dedup = Copastro (\ f -> f dedup) 62 | 63 | instance Applicative f => Codiagonal (Star f) where 64 | dedup = Star (pure . dedup) 65 | 66 | instance Comonad f => Codiagonal (Costar f) where 67 | dedup = Costar (dedup . extract) 68 | 69 | instance Arrow p => Codiagonal (WrappedArrow p) where 70 | dedup = WrapArrow (arr dedup) 71 | 72 | 73 | mirror :: Either a b -> Either b a 74 | mirror = either Right Left 75 | 76 | 77 | -- Defaults 78 | 79 | dupArrow :: Arrow p => a `p` (a, a) 80 | dupArrow = arr dup 81 | 82 | dedupArrow :: Arrow p => Either a a `p` a 83 | dedupArrow = arr dedup 84 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Exchange.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Profunctor.Exchange 2 | ( -- * Exchange profunctor 3 | Exchange(..) 4 | -- * Construction 5 | , exchange 6 | , idExchange 7 | -- * Elimination 8 | , runExchange 9 | ) where 10 | 11 | import Data.Profunctor 12 | 13 | -- Exchange profunctor 14 | 15 | newtype Exchange a b s t = Exchange { withExchange :: forall r . ((s -> a) -> (b -> t) -> r) -> r } 16 | deriving (Functor) 17 | 18 | instance Profunctor (Exchange a b) where 19 | dimap f g e = withExchange e (\ sa bt -> exchange (sa . f) (g . bt)) 20 | 21 | 22 | -- Construction 23 | 24 | exchange :: (s -> a) -> (b -> t) -> Exchange a b s t 25 | exchange v r = Exchange (\ f -> f v r) 26 | 27 | idExchange :: Exchange a b a b 28 | idExchange = exchange id id 29 | 30 | 31 | -- Elimination 32 | 33 | runExchange :: Exchange a b s t -> ((a -> b) -> (s -> t)) 34 | runExchange e = withExchange e (\ sa bt -> (bt .) . (. sa)) 35 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Exp.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Profunctor.Exp 2 | ( -- * Exponential functors 3 | Exp(..) 4 | -- * Mixfix syntax 5 | , type (~~) 6 | , type (~>) 7 | -- * Construction 8 | , exp 9 | , exp' 10 | , expFn 11 | -- * Elimination 12 | , appExp 13 | , runExp 14 | , elimExp 15 | , (#) 16 | , getExpFn 17 | , (↑) 18 | , (↓) 19 | -- * Computation 20 | , dnE 21 | -- * Coexponential functors 22 | , Coexp(..) 23 | -- * Mixfix syntax 24 | , type (>-) 25 | , type (-~) 26 | -- * Construction 27 | , (>-) 28 | -- * Elimination 29 | , runCoexp 30 | , elimCoexp 31 | , withCoexp 32 | -- * Computation 33 | , cocurry 34 | , uncocurry 35 | , coap 36 | ) where 37 | 38 | import qualified Control.Category as Cat 39 | import Data.Coerce 40 | import Data.Profunctor.Traversing 41 | import Prelude hiding (exp) 42 | import Sequoia.Disjunction 43 | import Sequoia.Monad.Run 44 | import Sequoia.Profunctor 45 | import Sequoia.Profunctor.Continuation 46 | 47 | -- Exponential functors 48 | 49 | newtype Exp r a b = Exp { getExp :: (b • r) -> (a • r) } 50 | 51 | instance Cat.Category (Exp r) where 52 | id = exp' id 53 | f . g = Exp (getExp g . getExp f) 54 | 55 | instance Profunctor (Exp r) where 56 | dimap f g = Exp . dimap (<<^ g) (<<^ f) . getExp 57 | 58 | instance Choice (Exp r) where 59 | left' f = Exp (\ k -> getExp f (inlL k) <••> inrL k) 60 | right' f = Exp (\ k -> inlL k <••> getExp f (inrL k)) 61 | 62 | instance Cochoice (Exp r) where 63 | unleft f = Exp (\ k -> inlL (let f' = getExp f (k <••> inrL f') in f')) 64 | unright f = Exp (\ k -> inrL (let f' = getExp f (inlL f' <••> k) in f')) 65 | 66 | instance Strong (Exp r) where 67 | first' f = Exp (\ k -> K (\ (a, c) -> getExp f (lmap (,c) k) • a)) 68 | second' f = Exp (\ k -> K (\ (c, a) -> getExp f (lmap (c,) k) • a)) 69 | 70 | instance Traversing (Exp r) where 71 | traverse' f = Exp (\ b -> inK (\ a -> runDN (traverse (DN . appExp f) a) • b)) 72 | wander traverse f = Exp (\ b -> inK (\ a -> runDN (traverse (DN . appExp f) a) • b)) 73 | 74 | instance Functor (Exp r a) where 75 | fmap = rmap 76 | 77 | instance Applicative (Exp r a) where 78 | pure = Exp . fmap (K . const) . flip (•) 79 | xf <*> xa = Exp (\ k -> cont (\ _K -> getExp xf (_K (getExp xa . (k <<^))))) 80 | 81 | instance Monad (Exp r a) where 82 | m >>= f = Exp (\ k -> K (\ a -> runExp (runExp k a <<^ f) a • m)) 83 | 84 | instance MonadRunK r (Exp r a) where 85 | withRunK f = Exp (\ k -> K (\ a -> let run k m = runExp k a • m in run k (f run))) 86 | 87 | 88 | -- Mixfix syntax 89 | 90 | type a ~~r = Exp r a 91 | type r~> b = r b 92 | 93 | infixr 1 ~~ 94 | infixr 0 ~> 95 | 96 | 97 | -- Construction 98 | 99 | exp :: (b • r -> a • r) -> Exp r a b 100 | exp = coerce 101 | 102 | exp' :: (a -> b) -> Exp r a b 103 | exp' = Exp . lmap 104 | 105 | expFn :: ((b -> r) -> (a -> r)) -> Exp r a b 106 | expFn = coerce 107 | 108 | 109 | -- Elimination 110 | 111 | appExp :: Exp r a b -> a -> b •• r 112 | appExp f a = K ((• a) . getExp f) 113 | 114 | runExp :: (b • r) -> a -> Exp r a b • r 115 | runExp k a = K (\ f -> getExp f k • a) 116 | 117 | elimExp :: Exp r a b -> Coexp r b a • r 118 | elimExp f = K (\ (b :>- a) -> getExp f b • a) 119 | 120 | (#) :: (a ~~b~> b) -> (a -> b) 121 | f # a = appExp f a • idK 122 | 123 | infixl 9 # 124 | 125 | getExpFn :: Exp r a b -> ((b -> r) -> (a -> r)) 126 | getExpFn = coerce 127 | 128 | 129 | (↑) :: (a • r) -> (a -> r) 130 | (↑) = (•) 131 | 132 | infixl 2 ↑ 133 | 134 | (↓) :: b • r -> Exp r a b -> a • r 135 | k ↓ f = getExp f k 136 | 137 | infixl 3 ↓ 138 | 139 | 140 | -- Computation 141 | 142 | dnE :: Exp r a b •• r -> Exp r a b 143 | dnE k = exp (\ k' -> k <<^ \ a -> K (\ f -> k' ↓ f ↑ a)) 144 | 145 | 146 | -- Coexponential functors 147 | 148 | data Coexp r b a = (b • r) :>- a 149 | 150 | infixr 0 :>- 151 | 152 | instance Profunctor (Coexp r) where 153 | dimap f g (b :>- a) = (b <<^ f) :>- g a 154 | 155 | instance Functor (Coexp r b) where 156 | fmap = rmap 157 | 158 | 159 | -- Mixfix syntax 160 | 161 | type b >-r = Coexp r b 162 | type r-~ a = r a 163 | 164 | infixr 1 >- 165 | infixr 0 -~ 166 | 167 | 168 | -- Construction 169 | 170 | (>-) :: (b • r) -> a -> Coexp r b a 171 | (>-) = (:>-) 172 | 173 | 174 | -- Elimination 175 | 176 | runCoexp :: (a -> b) -> Coexp r b a • r 177 | runCoexp f = K (\ (b :>- a) -> b • f a) 178 | 179 | elimCoexp :: Coexp r a b -> Exp r b a • r 180 | elimCoexp (a :>- b) = K (\ (Exp f) -> f a • b) 181 | 182 | withCoexp :: Coexp r a b -> ((a • r) -> b -> s) -> s 183 | withCoexp (a :>- b) f = f a b 184 | 185 | 186 | -- Computation 187 | 188 | cocurry :: Exp r c (Either a b) -> Exp r (Coexp r b c) a 189 | cocurry f = Exp (\ k -> K (\ (b :>- c) -> getExp f (k <••> b) • c)) 190 | 191 | uncocurry :: Exp r (Coexp r b c) a -> Exp r c (Either a b) 192 | uncocurry f = Exp (\ k -> K (\ c -> getExp f (inlL k) • (inrL k >- c))) 193 | 194 | coap :: Exp r c (Either (Coexp r b c) b) 195 | coap = Exp (\ k -> lmap (inrL k >-) (inlL k)) 196 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Exp/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Sequoia.Profunctor.Exp.Class 3 | ( -- * Exponentials 4 | Exponential(..) 5 | , exp' 6 | -- * Coexponentials 7 | , Coexponential(..) 8 | -- * Computation 9 | , cocurry 10 | ) where 11 | 12 | import Data.Profunctor 13 | import Prelude hiding (exp) 14 | 15 | -- Exponentials 16 | 17 | class Profunctor ex => Exponential r ex | ex -> r where 18 | exp :: ((b -> r) -> (a -> r)) -> ex a b 19 | 20 | appExp :: ex a b -> ((b -> r) -> (a -> r)) 21 | 22 | exp' :: Exponential r ex => (a -> b) -> ex a b 23 | exp' f = exp (. f) 24 | 25 | 26 | -- Coexponentials 27 | 28 | class Profunctor co => Coexponential r co | co -> r where 29 | coexp :: (a -> r) -> b -> co a b 30 | 31 | runCoexp :: ((a -> r) -> (b -> r)) -> (co a b -> r) 32 | 33 | 34 | -- Computation 35 | 36 | cocurry :: (Exponential r ex, Coexponential r co) => ex c (Either a b) -> ex (co b c) a 37 | cocurry f = exp (\ k -> runCoexp (appExp f . either k)) 38 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Exp/Par.hs: -------------------------------------------------------------------------------- 1 | -- | Exponentials, represented as ¬A ⅋ ≁B. 2 | module Sequoia.Profunctor.Exp.Par 3 | ( -- * Exponentials 4 | Exp(..) 5 | -- * Construction 6 | , exp 7 | , exp' 8 | -- * Elimination 9 | , runExp 10 | ) where 11 | 12 | import Prelude hiding (exp) 13 | import Sequoia.Connective.Not 14 | import Sequoia.Connective.NotUntrue 15 | import Sequoia.Profunctor 16 | import Sequoia.Profunctor.Command 17 | import Sequoia.Profunctor.Continuation 18 | import Sequoia.Profunctor.Value 19 | 20 | -- Exponentials 21 | 22 | newtype Exp env res a b = Exp { getExp :: forall res . (env ≁ b) • res -> (a ¬ res) } 23 | 24 | instance Functor (Exp env res a) where 25 | fmap = rmap 26 | 27 | instance Profunctor (Exp e r) where 28 | dimap f g (Exp r) = Exp (dimap (lmap (rmap g)) (lmap f) r) 29 | 30 | 31 | -- Construction 32 | 33 | exp :: (forall res . (env ≁ b) • res -> a -> res) -> Exp env res a b 34 | exp f = Exp (inK . f) 35 | 36 | exp' :: (a -> b) -> Exp env res a b 37 | exp' f = exp (\ b a -> b • pure (f a)) 38 | 39 | 40 | -- Elimination 41 | 42 | runExp :: Exp env res a b -> b • res -> a -> env |- res 43 | runExp (Exp r) k a = C (\ env -> r (k <<^ (env ∘)) • a) 44 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Exp/Quantified.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Profunctor.Exp.Quantified 2 | ( -- * Exponentials 3 | type (-->)(..) 4 | -- * Construction 5 | , exp 6 | -- * Elimination 7 | , (#) 8 | -- * Coexponentials 9 | , type (>--)(..) 10 | -- * Computation 11 | , cocurry 12 | ) where 13 | 14 | import qualified Control.Category as Cat 15 | import Data.Profunctor 16 | import Prelude hiding (exp) 17 | 18 | -- Exponentials 19 | 20 | newtype a --> b = Exp { getExp :: forall r . (b -> r) -> (a -> r) } 21 | deriving (Functor) 22 | 23 | infixr 0 --> 24 | 25 | instance Cat.Category (-->) where 26 | id = Exp id 27 | f . g = Exp (getExp g . getExp f) 28 | 29 | instance Profunctor (-->) where 30 | dimap f g (Exp r) = Exp (\ k -> r (k . g) . f) 31 | 32 | 33 | -- Construction 34 | 35 | exp :: (a -> b) -> (a --> b) 36 | exp f = Exp (. f) 37 | 38 | 39 | -- Elimination 40 | 41 | (#) :: (a --> b) -> (a -> b) 42 | f # a = getExp f id a 43 | 44 | infixl 9 # 45 | 46 | 47 | -- Coexponentials 48 | 49 | data b >-- a = (:>--) { coreturn :: forall r . b -> r, coconst :: a } 50 | deriving (Functor) 51 | 52 | infixr 0 >--, :>-- 53 | 54 | instance Profunctor (>--) where 55 | dimap f g (b :>-- a) = lmap f b :>-- g a 56 | 57 | 58 | -- Computation 59 | 60 | cocurry :: (c --> Either a b) -> ((b >-- c) --> a) 61 | cocurry f = Exp (\ k (b :>-- c) -> getExp f (either k b) c) 62 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Exp/Void.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Profunctor.Exp.Void 2 | ( -- * Exponentials 3 | type (-->)(..) 4 | -- * Construction 5 | , exp 6 | -- * Coexponentials 7 | , type (>--)(..) 8 | -- * Computation 9 | , cocurry 10 | , uncocurry 11 | , coap 12 | ) where 13 | 14 | import qualified Control.Category as Cat 15 | import Data.Profunctor 16 | import Data.Void 17 | import Prelude hiding (exp) 18 | import Sequoia.Disjunction 19 | 20 | -- Exponentials 21 | 22 | newtype a --> b = Exp { getExp :: (b -> Void) -> (a -> Void) } 23 | deriving (Functor) 24 | 25 | infixr 0 --> 26 | 27 | instance Cat.Category (-->) where 28 | id = Exp id 29 | f . g = Exp (getExp g . getExp f) 30 | 31 | instance Profunctor (-->) where 32 | dimap f g = Exp . dimap (lmap g) (lmap f) . getExp 33 | 34 | 35 | -- Construction 36 | 37 | exp :: (a -> b) -> (a --> b) 38 | exp f = Exp (. f) 39 | 40 | 41 | -- Coexponentials 42 | 43 | data b >-- a = (:>--) { coreturn :: b -> Void, coconst :: a } 44 | deriving (Functor) 45 | 46 | infixr 0 >--, :>-- 47 | 48 | instance Profunctor (>--) where 49 | dimap f g (b :>-- a) = b . f :>-- g a 50 | 51 | 52 | -- Computation 53 | 54 | cocurry :: (c --> Either a b) -> ((b >-- c) --> a) 55 | cocurry f = Exp (\ k (b :>-- c) -> getExp f (either k b) c) 56 | 57 | uncocurry :: ((b >-- c) --> a) -> c --> Either a b 58 | uncocurry f = Exp (\ k c -> getExp f (inlL k) (inrL k :>-- c)) 59 | 60 | coap :: c --> Either (b >-- c) b 61 | coap = Exp (\ k -> inlL k . (inrL k :>--)) 62 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Product.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Sequoia.Profunctor.Product 4 | ( (:*:)(..) 5 | , (***) 6 | ) where 7 | 8 | import qualified Control.Arrow as A ((***)) 9 | import qualified Control.Category as Cat 10 | import Data.Functor.Product 11 | import Data.Profunctor 12 | import Data.Profunctor.Rep 13 | import Data.Profunctor.Sieve 14 | 15 | newtype (p :*: q) a b = Product { runProduct :: (p a b, q a b) } 16 | 17 | infixr 6 :*: 18 | 19 | instance (Cat.Category p, Cat.Category q) => Cat.Category (p :*: q) where 20 | id = Product (Cat.id, Cat.id) 21 | Product (fp, fq) . Product (gp, gq) = Product (fp Cat.. gp, fq Cat.. gq) 22 | 23 | instance (Profunctor p, Profunctor q) => Profunctor (p :*: q) where 24 | dimap f g = Product . (dimap f g A.*** dimap f g) . runProduct 25 | 26 | instance (Strong p, Strong q) => Strong (p :*: q) where 27 | first' = Product . (first' A.*** first') . runProduct 28 | second' = Product . (second' A.*** second') . runProduct 29 | 30 | instance (Costrong p, Costrong q) => Costrong (p :*: q) where 31 | unfirst = Product . (unfirst A.*** unfirst) . runProduct 32 | unsecond = Product . (unsecond A.*** unsecond) . runProduct 33 | 34 | instance (Choice p, Choice q) => Choice (p :*: q) where 35 | left' = Product . (left' A.*** left') . runProduct 36 | right' = Product . (right' A.*** right') . runProduct 37 | 38 | instance (Cochoice p, Cochoice q) => Cochoice (p :*: q) where 39 | unleft = Product . (unleft A.*** unleft) . runProduct 40 | unright = Product . (unright A.*** unright) . runProduct 41 | 42 | instance (Closed p, Closed q) => Closed (p :*: q) where 43 | closed = Product . (closed A.*** closed) . runProduct 44 | 45 | instance (Sieve p f, Sieve q g) => Sieve (p :*: q) (Product f g) where 46 | sieve (Product (p, q)) a = Pair (sieve p a) (sieve q a) 47 | 48 | instance (Representable p, Representable q) => Representable (p :*: q) where 49 | type Rep (p :*: q) = Product (Rep p) (Rep q) 50 | tabulate f' = let f d = let Pair a b = f' d in (a, b) in Product 51 | ( tabulate (fst . f) 52 | , tabulate (snd . f) ) 53 | 54 | 55 | (***) :: (Strong p, Cat.Category p) => a1 `p` b1 -> a2 `p` b2 -> (a1, a2) `p` (b1, b2) 56 | f *** g = first' f Cat.>>> second' g 57 | 58 | infixr 3 *** 59 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Recall.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Sequoia.Profunctor.Recall 4 | ( Recall(..) 5 | ) where 6 | 7 | import Data.Bifunctor 8 | import Data.Coerce 9 | import Data.Distributive 10 | import Data.Functor.Const 11 | import Data.Functor.Rep as Co 12 | import Data.Profunctor 13 | import Data.Profunctor.Rep as Pro 14 | import Data.Profunctor.Sieve 15 | 16 | newtype Recall e a b = Recall { runRecall :: e -> b } 17 | deriving (Applicative, Functor, Monad, Co.Representable) 18 | 19 | instance Distributive (Recall e a) where 20 | distribute = distributeRep 21 | collect = collectRep 22 | 23 | instance Bifunctor (Recall e) where 24 | bimap _ g = Recall . fmap g . runRecall 25 | 26 | instance Profunctor (Recall e) where 27 | dimap _ g = Recall . fmap g . runRecall 28 | lmap _ = coerce 29 | rmap = fmap 30 | 31 | instance Costrong (Recall e) where 32 | unfirst = Recall . (fst .) . runRecall 33 | unsecond = Recall . (snd .) . runRecall 34 | 35 | instance Choice (Recall e) where 36 | left' = Recall . (Left .) . runRecall 37 | right' = Recall . (Right .) . runRecall 38 | 39 | instance Closed (Recall e) where 40 | closed = Recall . (const .) . runRecall 41 | 42 | instance Sieve (Recall e) ((->) e) where 43 | sieve = const . runRecall 44 | 45 | instance Cosieve (Recall e) (Const e) where 46 | cosieve = (. getConst) . runRecall 47 | 48 | instance Pro.Corepresentable (Recall e) where 49 | type Corep (Recall e) = Const e 50 | cotabulate = Recall . (. Const) 51 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Semiring.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Sequoia.Profunctor.Semiring 3 | ( -- * Semigroups 4 | RSemigroup(..) 5 | -- * Monoids 6 | , RMonoid(..) 7 | -- * Semirings 8 | , RApply(..) 9 | , LApply(..) 10 | , ProfunctorApply(..) 11 | -- * Unital semirings 12 | , ROne(..) 13 | , LOne(..) 14 | , ProfunctorOne(..) 15 | ) where 16 | 17 | import Data.Profunctor 18 | import Sequoia.Profunctor 19 | import Sequoia.Profunctor.Continuation 20 | import Sequoia.Profunctor.Exp 21 | 22 | -- Semigroups 23 | 24 | class Profunctor p => RSemigroup p where 25 | (<|>) :: p a b -> p a b -> p a b 26 | 27 | infixl 3 <|> 28 | 29 | 30 | -- Monoids 31 | 32 | class RSemigroup p => RMonoid p where 33 | zero :: p a b 34 | 35 | 36 | -- Semirings 37 | 38 | class Profunctor p => RApply p where 39 | (<.>) :: p a (b -> c) -> p a b -> p a c 40 | 41 | infixl 4 <.> 42 | 43 | instance RApply (->) where 44 | (<.>) = (<*>) 45 | 46 | instance RApply (Exp r) where 47 | (<.>) = (<*>) 48 | 49 | 50 | class Profunctor p => LApply r p | p -> r where 51 | (<&>) :: p (Coexp r a c) b -> p a b -> p c b 52 | 53 | infixl 4 <&> 54 | 55 | instance LApply r (Exp r) where 56 | f <&> a = Exp (\ k -> getExp f k <<^ (getExp a k :>-)) 57 | 58 | 59 | class (LApply r p, RApply p) => ProfunctorApply r p where 60 | (<&.>) :: p (Coexp r a b) (c -> d) -> (p a c -> p b d) 61 | 62 | infixl 4 <&.> 63 | 64 | 65 | -- Unital semirings 66 | 67 | class RApply p => ROne p where 68 | rpure :: b -> p a b 69 | 70 | instance ROne (->) where 71 | rpure = pure 72 | 73 | instance ROne (Exp r) where 74 | rpure = pure 75 | 76 | 77 | class LApply r p => LOne r p | p -> r where 78 | lpure :: (a • r) -> p a b 79 | 80 | instance LOne r (Exp r) where 81 | lpure = Exp . const 82 | 83 | 84 | class (LOne r p, ROne p) => ProfunctorOne r p | p -> r where 85 | dipure :: Coexp r a b -> p a b 86 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Profunctor.Sum 3 | ( (:+:)(..) 4 | , (+++) 5 | ) where 6 | 7 | import qualified Control.Arrow as A ((+++)) 8 | import qualified Control.Category as Cat 9 | import Data.Functor.Sum 10 | import Data.Profunctor 11 | import Data.Profunctor.Sieve 12 | 13 | newtype (p :+: q) a b = Sum { runSum :: Either (p a b) (q a b) } 14 | 15 | infixr 5 :+: 16 | 17 | instance (Profunctor p, Profunctor q) => Profunctor (p :+: q) where 18 | dimap f g = Sum . (dimap f g A.+++ dimap f g) . runSum 19 | 20 | instance (Strong p, Strong q) => Strong (p :+: q) where 21 | first' = Sum . (first' A.+++ first' ) . runSum 22 | second' = Sum . (second' A.+++ second') . runSum 23 | 24 | instance (Costrong p, Costrong q) => Costrong (p :+: q) where 25 | unfirst = Sum . (unfirst A.+++ unfirst ) . runSum 26 | unsecond = Sum . (unsecond A.+++ unsecond) . runSum 27 | 28 | instance (Choice p, Choice q) => Choice (p :+: q) where 29 | left' = Sum . (left' A.+++ left' ) . runSum 30 | right' = Sum . (right' A.+++ right') . runSum 31 | 32 | instance (Cochoice p, Cochoice q) => Cochoice (p :+: q) where 33 | unleft = Sum . (unleft A.+++ unleft ) . runSum 34 | unright = Sum . (unright A.+++ unright) . runSum 35 | 36 | instance (Closed p, Closed q) => Closed (p :+: q) where 37 | closed = Sum . (closed A.+++ closed) . runSum 38 | 39 | instance (Sieve p f, Sieve q g) => Sieve (p :+: q) (Sum f g) where 40 | sieve (Sum s) a = either (InL . (`sieve` a)) (InR . (`sieve` a)) s 41 | 42 | instance (Cosieve p f, Cosieve q f) => Cosieve (p :+: q) f where 43 | cosieve (Sum s) a = either (`cosieve` a) (`cosieve` a) s 44 | 45 | 46 | (+++) :: (Choice p, Cat.Category p) => a1 `p` b1 -> a2 `p` b2 -> Either a1 a2 `p` Either b1 b2 47 | f +++ g = left' f Cat.>>> right' g 48 | 49 | infixr 2 +++ 50 | -------------------------------------------------------------------------------- /src/Sequoia/Profunctor/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Sequoia.Profunctor.Value 3 | ( -- * Value profunctor 4 | type (∘)(..) 5 | -- * Value abstraction 6 | , Value(..) 7 | -- * Construction 8 | , idV 9 | , constV 10 | -- * Coercion 11 | , _V 12 | ) where 13 | 14 | import Control.Category (Category) 15 | import Data.Distributive 16 | import Data.Functor.Identity 17 | import Data.Functor.Rep as Co 18 | import Data.Profunctor 19 | import Data.Profunctor.Rep as Pro 20 | import Data.Profunctor.Sieve 21 | import Data.Profunctor.Traversing 22 | import Fresnel.Iso 23 | import Sequoia.Monad.Run 24 | 25 | -- Value profunctor 26 | 27 | newtype e ∘ a = V (e -> a) 28 | deriving (Applicative, Category, Choice, Closed, Cochoice, Pro.Corepresentable, Costrong, Functor, Mapping, Monad, MonadRun, Profunctor, Co.Representable, Pro.Representable, Strong, Traversing) 29 | 30 | instance Distributive ((∘) e) where 31 | distribute = distributeRep 32 | collect = collectRep 33 | 34 | instance Sieve (∘) Identity where 35 | sieve = rmap Identity . flip (∘) 36 | 37 | instance Cosieve (∘) Identity where 38 | cosieve = lmap runIdentity . flip (∘) 39 | 40 | instance Value (∘) where 41 | inV = V 42 | e ∘ V v = v e 43 | 44 | 45 | -- Value abstraction 46 | 47 | class Profunctor v => Value v where 48 | inV :: (e -> a) -> v e a 49 | (∘) :: e -> (v e a -> a) 50 | 51 | infixl 9 ∘ 52 | 53 | 54 | -- Construction 55 | 56 | idV :: Value v => e `v` e 57 | idV = inV id 58 | 59 | constV :: Value v => a -> e `v` a 60 | constV = inV . const 61 | 62 | 63 | -- Coercion 64 | 65 | _V :: Iso (e ∘ a) (e' ∘ a') (e -> a) (e' -> a') 66 | _V = coerced 67 | -------------------------------------------------------------------------------- /src/Sequoia/Signal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Sequoia.Signal 3 | ( -- * Signals 4 | _Sig 5 | , Sig(..) 6 | , mapKSig 7 | , mapVSig 8 | -- * Conversions 9 | , solSrc 10 | , solSnk 11 | , srcSig 12 | , composeSrcSig 13 | , snkSig 14 | , composeSigSnk 15 | , solSig 16 | , composeSrcSnk 17 | ) where 18 | 19 | import Control.Category ((<<<)) 20 | import qualified Control.Category as Cat 21 | import Control.Monad (ap) 22 | import Data.Profunctor 23 | import Fresnel.Getter 24 | import Fresnel.Iso 25 | import Fresnel.Review 26 | import Sequoia.Calculus.Context 27 | import Sequoia.Functor.Sink 28 | import Sequoia.Functor.Source 29 | import Sequoia.Monad.Run 30 | import Sequoia.Profunctor.Command 31 | import Sequoia.Profunctor.Continuation as K 32 | import Sequoia.Profunctor.Value as V 33 | 34 | -- Signals 35 | 36 | _Sig :: Iso (Sig e r a b) (Sig e' r' a' b') (b • r -> e ∘ a -> e |- r) (b' • r' -> e' ∘ a' -> e' |- r') 37 | _Sig = coerced 38 | 39 | newtype Sig e r a b = Sig { runSig :: b • r -> e ∘ a -> e |- r } 40 | 41 | instance Cat.Category (Sig e r) where 42 | id = Sig (↓↑) 43 | Sig f . Sig g = Sig (\ c a -> cont (\ _K -> g (_K (f c . pure)) a)) 44 | 45 | instance Profunctor (Sig e r) where 46 | dimap f g = Sig . dimap (lmap g) (lmap (fmap f)) . runSig 47 | 48 | instance Functor (Sig e r a) where 49 | fmap = rmap 50 | 51 | instance Applicative (Sig e r a) where 52 | pure a = Sig (ckv (const a)) 53 | (<*>) = ap 54 | 55 | instance Monad (Sig e r a) where 56 | Sig m >>= f = Sig (\ b a -> cont (\ _K -> m (_K (\ a' -> runSig (f a') b a)) a)) 57 | 58 | mapKSig :: Iso' r r' -> (Sig e r a b -> Sig e r' a b) 59 | mapKSig b = withIso b $ \ to from -> Sig . dimap (rmap from) (rmap (rmap to)) . runSig 60 | 61 | mapVSig :: Iso' e e' -> (Sig e r a b -> Sig e' r a b) 62 | mapVSig b = withIso b $ \ to from -> Sig . rmap (dimap (lmap to) (lmap from)) . runSig 63 | 64 | 65 | -- Conversions 66 | 67 | solSrc 68 | :: Iso' 69 | ( e |- r ) 70 | -- ------------------ 71 | ( Src e r ⊢ r) 72 | solSrc = iso (src . const) (($ idK) . runSrc) 73 | 74 | 75 | solSnk 76 | :: Iso' 77 | ( e |- r ) 78 | -- ------------------ 79 | (e ⊣ Snk e r ) 80 | solSnk = iso (snk . const) (($ idV) . runSnk) 81 | 82 | 83 | srcSig 84 | :: Iso' 85 | ( Src e r ⊢ b) 86 | -- ------------------ 87 | (e ⊣ Sig e r ⊢ b) 88 | srcSig = _Src.from (_Sig.rmapping (constantWith idV (<<∘))) 89 | 90 | composeSrcSig :: Src e r a -> Sig e r a b -> Src e r b 91 | composeSrcSig src sig = review srcSig (sig <<< view srcSig src) 92 | 93 | 94 | snkSig 95 | :: Iso' 96 | (a ⊣ Snk e r ) 97 | -- ------------------ 98 | (a ⊣ Sig e r ⊢ r) 99 | snkSig = _Snk.from (_Sig.constantWith idK (flip ((.) . (•<<)))) 100 | 101 | composeSigSnk :: Sig e r a b -> Snk e r b -> Snk e r a 102 | composeSigSnk sig snk = review snkSig (view snkSig snk <<< sig) 103 | 104 | 105 | solSig 106 | :: Iso' 107 | ( e |- r ) 108 | -- ------------------ 109 | (e ⊣ Sig e r ⊢ r) 110 | solSig = iso (Sig . const . const) (($ idV) . ($ idK) . runSig) 111 | 112 | 113 | composeSrcSnk :: Src e r a -> Snk e r a -> e |- r 114 | composeSrcSnk src snk = review solSig (snk^.snkSig <<< view srcSig src) 115 | 116 | 117 | {- 118 | o 119 | ==> ---> Src 120 | │ │ 121 | i │ │ i 122 | ↓ ↓ 123 | Snk ---> Sig 124 | o 125 | -} 126 | -------------------------------------------------------------------------------- /src/Sequoia/Snoc.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Snoc 2 | ( -- Snoc lists 3 | Snoc(..) 4 | ) where 5 | 6 | import Control.Applicative (Alternative(..)) 7 | import Data.Align 8 | import Data.Foldable (toList) 9 | import Data.Functor.Classes 10 | import Data.These 11 | import Data.Zip 12 | 13 | -- Snoc lists 14 | 15 | data Snoc a 16 | = Nil 17 | | Snoc a :> a 18 | deriving (Eq, Foldable, Functor, Ord, Traversable) 19 | 20 | infixl 5 :> 21 | 22 | instance Show a => Show (Snoc a) where 23 | showsPrec = showsPrec1 24 | 25 | instance Semigroup (Snoc a) where 26 | a <> b = go id b 27 | where 28 | go acc = \case 29 | Nil -> acc a 30 | bs:>b -> go (acc . (:> b)) bs 31 | 32 | instance Monoid (Snoc a) where 33 | mempty = Nil 34 | 35 | instance Semialign Snoc where 36 | align = go id 37 | where 38 | go acc = curry $ \case 39 | (Nil, Nil) -> acc Nil 40 | (Nil, bs) -> acc (That <$> bs) 41 | (as, Nil) -> acc (This <$> as) 42 | (as:>a, bs:>b) -> go (acc . (:> These a b)) as bs 43 | 44 | instance Zip Snoc where 45 | zipWith f = go id 46 | where 47 | go acc = curry $ \case 48 | (as:>a, bs:>b) -> go (acc . (:> f a b)) as bs 49 | _ -> acc Nil 50 | 51 | instance Applicative Snoc where 52 | pure = (Nil :>) 53 | fs <*> as = go id fs as 54 | where 55 | go accum Nil _ = accum Nil 56 | go accum (fs:>f) as = go (accum . flip (foldl (\ fas a -> fas :> f a)) as) fs as 57 | 58 | instance Alternative Snoc where 59 | empty = Nil 60 | (<|>) = (<>) 61 | 62 | instance Monad Snoc where 63 | as >>= f = go id as 64 | where 65 | go accum Nil = accum Nil 66 | go accum (as:>a) = go (accum . (<> f a)) as 67 | 68 | instance Eq1 Snoc where 69 | liftEq eq = go 70 | where 71 | go Nil Nil = True 72 | go (s1:>a1) (s2:>a2) = eq a1 a2 && go s1 s2 73 | go _ _ = False 74 | 75 | instance Ord1 Snoc where 76 | liftCompare compare = go 77 | where 78 | go Nil Nil = EQ 79 | go (s1:>a1) (s2:>a2) = compare a1 a2 <> go s1 s2 80 | go Nil _ = LT 81 | go _ _ = GT 82 | 83 | instance Show1 Snoc where 84 | liftShowsPrec _ sl p s = showParen (p > 10) $ showString "fromList" . showChar ' ' . sl (toList s) 85 | -------------------------------------------------------------------------------- /src/Sequoia/Span.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Span 2 | ( -- * Source positions 3 | Pos(..) 4 | , line_ 5 | , col_ 6 | -- * Source spans 7 | , Span(..) 8 | , start_ 9 | , end_ 10 | ) where 11 | 12 | import Fresnel.Lens 13 | 14 | -- Source positions 15 | 16 | data Pos = Pos { line :: {-# UNPACK #-} !Int, col :: {-# UNPACK #-} !Int } 17 | deriving (Eq, Ord, Show) 18 | 19 | line_, col_ :: Lens' Pos Int 20 | 21 | line_ = lens line (\ p line -> p{ line }) 22 | col_ = lens col (\ p col -> p{ col }) 23 | 24 | 25 | -- Source spans 26 | 27 | data Span = Span { start :: {-# UNPACK #-} !Pos, end :: {-# UNPACK #-} !Pos } 28 | deriving (Eq, Ord, Show) 29 | 30 | instance Semigroup Span where 31 | Span s1 e1 <> Span s2 e2 = Span (min s1 s2) (max e1 e2) 32 | 33 | 34 | start_, end_ :: Lens' Span Pos 35 | 36 | start_ = lens start (\ p start -> p{ start }) 37 | end_ = lens end (\ p end -> p{ end }) 38 | -------------------------------------------------------------------------------- /src/Sequoia/Spine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Sequoia.Spine 3 | ( -- * Spines 4 | Spine(..) 5 | , viewL 6 | , ViewL(..) 7 | , viewR 8 | , ViewR(..) 9 | ) where 10 | 11 | import qualified Control.Category as Cat 12 | 13 | -- Spines 14 | 15 | data Spine arr a b where 16 | Id :: Spine arr a a 17 | (:.) :: Spine arr a b -> arr b c -> Spine arr a c 18 | 19 | infixl 9 :. 20 | 21 | instance Cat.Category (Spine arr) where 22 | id = Id 23 | fs . gs = case fs of 24 | Id -> gs 25 | fs:.f -> (gs Cat.>>> fs) :. f 26 | 27 | 28 | viewL :: Spine arr a b -> ViewL arr a b 29 | viewL q = case viewR q of 30 | NilR -> NilL 31 | p :> l -> case viewL p of 32 | NilL -> l :< Id 33 | h :< t -> h :< (t :. l) 34 | 35 | data ViewL arr a b where 36 | NilL :: ViewL arr a a 37 | (:<) :: arr a b -> Spine arr b c -> ViewL arr a c 38 | 39 | 40 | viewR :: Spine arr a b -> ViewR arr a b 41 | viewR = \case 42 | Id -> NilR 43 | i :. l -> i :> l 44 | 45 | data ViewR arr a b where 46 | NilR :: ViewR arr a a 47 | (:>) :: Spine arr a b -> arr b c -> ViewR arr a c 48 | -------------------------------------------------------------------------------- /src/Sequoia/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Sequoia.Syntax 2 | ( NExpr(..) 3 | , PExpr(..) 4 | ) where 5 | 6 | import Control.Applicative (liftA2) 7 | import Control.Monad (ap) 8 | import Data.Distributive 9 | import Data.Profunctor 10 | import Sequoia.Calculus.Bottom 11 | import Sequoia.Conjunction 12 | import Sequoia.Connective.Negate as Negate 13 | import Sequoia.Connective.Not 14 | import Sequoia.Connective.NotUntrue 15 | import Sequoia.Connective.One 16 | import Sequoia.Connective.Par 17 | import Sequoia.Connective.Sum 18 | import Sequoia.Connective.Tensor 19 | import Sequoia.Connective.Top 20 | import Sequoia.Connective.True 21 | import Sequoia.Connective.With 22 | import Sequoia.Connective.Zero 23 | import Sequoia.Disjunction 24 | import Sequoia.Monad.Run 25 | import Sequoia.Profunctor.Command 26 | import Sequoia.Profunctor.Continuation 27 | import Sequoia.Profunctor.Value 28 | 29 | class NExpr rep where 30 | bottomL :: rep e r (Bottom r) -> rep e r a 31 | topR :: rep e r Top 32 | withL1 :: rep e r (a • r) -> rep e r ((a & b) • r) 33 | withL2 :: rep e r (b • r) -> rep e r ((a & b) • r) 34 | withR :: rep e r a -> rep e r b -> rep e r (a & b) 35 | parL :: rep e r (a • r) -> rep e r (b • r) -> rep e r ((a ⅋ b) • r) 36 | parR :: Either (rep e r a) (rep e r b) -> rep e r (a ⅋ b) 37 | funL :: rep e r a -> rep e r (b • r) -> rep e r (Fun e r a b • r) 38 | funR :: (rep e r a -> rep e r b) -> rep e r (Fun e r a b) 39 | notUntrueL :: rep e r (a • r) -> rep e r (NotUntrue e a • r) 40 | notUntrueR :: rep e r a -> rep e r (NotUntrue e a) 41 | notL :: rep e r a -> rep e r (Not a r • r) 42 | notR :: rep e r (a • r) -> rep e r (Not a r) 43 | 44 | class PExpr rep where 45 | zeroL :: rep e r Zero -> rep e r a 46 | oneR :: rep e r (One e) 47 | sumL :: rep e r (a • r) -> rep e r (b • r) -> rep e r ((a ⊕ b) • r) 48 | sumR1 :: rep e r a -> rep e r (a ⊕ b) 49 | sumR2 :: rep e r b -> rep e r (a ⊕ b) 50 | tensorL :: (rep e r a -> rep e r b -> rep e r r) -> rep e r ((a ⊗ b) • r) 51 | tensorR :: rep e r a -> rep e r b -> rep e r (a ⊗ b) 52 | subL :: (rep e r a -> rep e r b) -> rep e r (Sub r a b • r) 53 | subR :: rep e r a -> rep e r (b • r) -> rep e r (Sub r a b) 54 | trueL :: rep e r (a • r) -> rep e r (True r a • r) 55 | trueR :: rep e r a -> rep e r (True r a) 56 | negateL :: rep e r a -> rep e r (Negate e a r • r) 57 | negateR :: rep e r (a • r) -> rep e r (Negate e a r) 58 | 59 | 60 | runEval :: a • r -> Eval e r a -> e |- r 61 | runEval k m = getEval m k 62 | 63 | evalF :: (Eval e r a -> Eval e r b) -> Eval e r (b • r -> a • r) 64 | evalF f = env (\ e -> pure (\ k -> K ((<== e) . runEval k . f . pure))) 65 | 66 | elim :: (a -> Eval e r r) -> Eval e r (a • r) 67 | elim f = Eval (\ k -> C (\ e -> k • K (\ a -> runEval idK (f a) <== e))) 68 | 69 | newtype Eval e r a = Eval { getEval :: a • r -> e |- r } 70 | 71 | instance Functor (Eval e r) where 72 | fmap f = Eval . lmap (lmap f) . getEval 73 | 74 | instance Applicative (Eval e r) where 75 | pure a = Eval (pure . (• a)) 76 | (<*>) = ap 77 | 78 | instance Monad (Eval e r) where 79 | Eval m >>= f = Eval (\ k -> withRun (\ run -> m (K (run . runEval k . f)))) 80 | 81 | instance MonadEnv e (Eval e r) where 82 | env f = Eval (\ k -> env (runEval k . f)) 83 | 84 | instance MonadRes r (Eval e r) where 85 | res = Eval . const . pure 86 | liftRes f = Eval (\ k -> let run = runEval k in withRun (\ runC -> run (f (runC . run)))) 87 | 88 | instance NExpr Eval where 89 | bottomL b = Eval (\ _ -> runEval (K absurdN) b) 90 | topR = pure Top 91 | withL1 = fmap (lmap exl) 92 | withL2 = fmap (lmap exr) 93 | withR = liftA2 inlr 94 | parL f g = elim ((distribute f <••> distribute g) •) 95 | parR r = bisequenceDisj (coerceDisj r) 96 | funL a b = elim (\ f -> appFun f <$> a <*> b) 97 | funR f = Fun . fmap (Not . rmap Bottom) <$> evalF f 98 | notUntrueL a = env (\ e -> lmap ((e ∘) . runNotUntrue) <$> a) 99 | -- FIXME: this is always scoped statically 100 | notUntrueR = fmap (NotUntrue . pure) 101 | notL = fmap (runElim (rmap absurdN . getNot)) 102 | notR = fmap (Not . rmap Bottom) 103 | 104 | instance PExpr Eval where 105 | zeroL = fmap absurdP 106 | oneR = Eval (\ k -> C ((k •) . One)) 107 | sumL f g = elim (collect (•) f <--> collect (•) g) 108 | sumR1 = fmap InL 109 | sumR2 = fmap InR 110 | tensorL f = elim (\ (a :⊗ b) -> f (pure a) (pure b)) 111 | tensorR = liftA2 (:⊗) 112 | subL f = elim (\ s -> appSub s <$> evalF f) 113 | subR = liftA2 (:-<) 114 | trueL = fmap (lmap trueA) 115 | trueR = fmap true 116 | negateL = fmap (runElim negateK) 117 | negateR f = env (\ e -> Negate e <$> f) 118 | 119 | 120 | newtype Fun e r a b = Fun (b • r -> a ¬ r) 121 | 122 | instance Profunctor (Fun e r) where 123 | dimap f g (Fun r) = Fun (dimap (lmap g) (lmap f) r) 124 | 125 | appFun :: Fun e r a b -> a -> b • r -> r 126 | appFun (Fun f) a b = f b • a 127 | 128 | 129 | data Sub r a b = a :-< (b • r) 130 | 131 | appSub :: Sub r a b -> (b • r -> a • r) -> r 132 | appSub (a :-< k) f = f k • a 133 | 134 | 135 | runElim :: (a -> b • r) -> (b -> a • r) 136 | runElim = fmap K . flip . fmap (•) 137 | -------------------------------------------------------------------------------- /test/Cons/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Cons.Test 3 | ( tests 4 | ) where 5 | 6 | import Hedgehog 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | import Sequoia.Cons as List 10 | 11 | tests :: IO Bool 12 | tests = checkParallel $$(discover) 13 | 14 | prop_semigroup_associativity = property $ do 15 | (a, b, c) <- forAll ((,,) <$> genList Gen.alpha <*> genList Gen.alpha <*> genList Gen.alpha) 16 | ((a <> b) <> c) === (a <> (b <> c)) 17 | 18 | 19 | prop_zip_length_minimum = property $ do 20 | (as, bs) <- forAll ((,) <$> genList Gen.alpha <*> genList Gen.alpha) 21 | length (List.zip as bs) === length as `min` length bs 22 | 23 | 24 | prop_align_length_maximum = property $ do 25 | (as, bs) <- forAll ((,) <$> genList Gen.alpha <*> genList Gen.alpha) 26 | length (List.align as bs) === length as `max` length bs 27 | 28 | 29 | prop_equality = property $ do 30 | (as, bs) <- forAll ((,) <$> genList Gen.alpha <*> genList Gen.alpha) 31 | (as == bs) === (toList as == toList bs) 32 | 33 | 34 | genList :: Gen a -> Gen (List a) 35 | genList = fmap fromList . Gen.list (Range.linear 0 10) 36 | -------------------------------------------------------------------------------- /test/Line/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Line.Test 3 | ( tests 4 | ) where 5 | 6 | import Hedgehog 7 | import qualified Hedgehog.Gen as Gen 8 | import Sequoia.Line 9 | 10 | tests :: IO Bool 11 | tests = checkParallel $$(discover) 12 | 13 | 14 | prop_line_ending_semigroup_associativity = property $ do 15 | (a, b, c) <- forAll ((,,) <$> genLineEnding <*> genLineEnding <*> genLineEnding) 16 | ((a <> b) <> c) === (a <> (b <> c)) 17 | 18 | 19 | genLineEnding :: Gen LineEnding 20 | genLineEnding = Gen.enumBounded 21 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import Hedgehog.Main 6 | import qualified Cons.Test 7 | import qualified Line.Test 8 | 9 | main :: IO () 10 | main = defaultMain 11 | [ Cons.Test.tests 12 | , Line.Test.tests 13 | ] 14 | --------------------------------------------------------------------------------