├── .gitignore ├── Setup.hs ├── ChangeLog.md ├── test └── Spec.hs ├── README.md ├── src ├── Lib.hs ├── Cat.hs ├── Rewrite.hs └── CCC.hs ├── package.yaml ├── LICENSE ├── stack.yaml └── app └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | not-bad-ccc.cabal 3 | *~ -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for not-bad-ccc 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # not-bad-ccc 2 | 3 | http://www.philipzucker.com/compiling-to-categories-3-a-bit-cuter/ 4 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: not-bad-ccc 2 | version: 0.1.0.0 3 | github: "githubuser/not-bad-ccc" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2018 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | ghc-options: 28 | - -O 29 | - -fenable-rewrite-rules 30 | - -ddump-rule-rewrites 31 | 32 | 33 | executables: 34 | not-bad-ccc-exe: 35 | main: Main.hs 36 | source-dirs: app 37 | ghc-options: 38 | - -threaded 39 | - -rtsopts 40 | - -with-rtsopts=-N 41 | - -ddump-rule-rewrites 42 | - -O 43 | - -fenable-rewrite-rules 44 | dependencies: 45 | - not-bad-ccc 46 | 47 | tests: 48 | not-bad-ccc-test: 49 | main: Spec.hs 50 | source-dirs: test 51 | ghc-options: 52 | - -threaded 53 | - -rtsopts 54 | - -with-rtsopts=-N 55 | dependencies: 56 | - not-bad-ccc 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.24 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /src/Cat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, StandaloneDeriving, NoImplicitPrelude, FlexibleInstances #-} 2 | 3 | module Cat where 4 | import Control.Category 5 | import Prelude hiding ((.), id) 6 | 7 | 8 | class Category k => Monoidal k where 9 | parC :: k a c -> k b d -> k (a,b) (c,d) 10 | 11 | 12 | class Monoidal k => Cartesian k where 13 | fstC :: k (a,b) a 14 | sndC :: k (a,b) b 15 | dupC :: k a (a,a) 16 | 17 | class Cartesian k => Closed k where 18 | applyC :: k (k a b,a) b 19 | curryC :: k (a,b) c -> k a (k b c) 20 | uncurryC :: k a (k b c) -> k (a,b) c 21 | 22 | fanC f g = (parC f g) . dupC 23 | 24 | idC :: Category k => k a a 25 | idC = id 26 | 27 | data FreeCat a b where 28 | Comp :: FreeCat b c -> FreeCat a b -> FreeCat a c 29 | Id :: FreeCat a a 30 | Fst :: FreeCat (a,b) a 31 | Snd :: FreeCat (a,b) b 32 | Dup :: FreeCat a (a,a) 33 | Par :: FreeCat a b -> FreeCat c d -> FreeCat (a,c) (b,d) 34 | Add :: FreeCat (a,a) a 35 | Mul :: FreeCat (a,a) a 36 | Apply :: FreeCat (FreeCat a b, a) b 37 | Curry :: FreeCat (a,b) c -> FreeCat a (FreeCat b c) 38 | Uncurry :: FreeCat a (FreeCat b c) -> FreeCat (a,b) c 39 | 40 | instance Closed FreeCat where 41 | applyC = Apply 42 | curryC = Curry 43 | uncurryC = Uncurry 44 | 45 | deriving instance Show (FreeCat a b) 46 | 47 | instance Category FreeCat where 48 | (.) = Comp 49 | id = Id 50 | 51 | instance Monoidal FreeCat where 52 | parC = Par 53 | 54 | instance Cartesian FreeCat where 55 | fstC = Fst 56 | sndC = Snd 57 | dupC = Dup 58 | 59 | instance Monoidal (->) where 60 | parC f g = \(x,y) -> (f x, g y) 61 | 62 | instance Cartesian (->) where 63 | fstC (x,y) = x 64 | sndC (x,y) = y 65 | dupC x = (x,x) 66 | 67 | class Cartesian k => NumCat k where 68 | mulC :: Num a => k (a,a) a 69 | negateC :: Num a => k a a 70 | addC :: Num a => k (a,a) a 71 | subC :: Num a => k (a,a) a 72 | absC :: Num a => k a a 73 | 74 | instance NumCat (->) where 75 | mulC = uncurry (*) 76 | negateC = negate 77 | addC = uncurry (+) 78 | subC = uncurry (-) 79 | absC = abs 80 | 81 | instance NumCat FreeCat where 82 | mulC = Mul 83 | negateC = error "TODO" 84 | addC = Add 85 | subC = error "TODO" 86 | absC = error "TODO" 87 | 88 | instance (NumCat k, Num a) => Num (k z a) where 89 | f + g = addC . (fanC f g) 90 | f * g = mulC . (fanC f g) 91 | negate f = negateC . f 92 | f - g = subC . (fanC f g) 93 | abs f = absC . f 94 | signum = error "TODO" 95 | fromInteger = error "TODO" 96 | 97 | 98 | {- 99 | 100 | class BoolLike a where 101 | (&&) :: a -> a -> a 102 | (||) :: a -> a -> a 103 | not :: a -> a 104 | ite :: a -> b -> c -> Either b c 105 | 106 | -} 107 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes, TypeApplications, PartialTypeSignatures, NoMonomorphismRestriction, FlexibleContexts, NoImplicitPrelude 4 | #-} 5 | -- NoMonomorphismRestriction, 6 | module Main where 7 | 8 | import Lib 9 | import CCC 10 | import Cat 11 | import Control.Category 12 | import Prelude hiding ((.), id) 13 | import Rewrite 14 | main :: IO () 15 | main = someFunc 16 | 17 | example2 = toCCC @FreeCat (\(x,y)->(y,x)) 18 | 19 | -- You need to give the type sginature unfortunately. k is too ambiguous otherwise 20 | -- example3 :: Cartesian k => k _ _ 21 | example3 = toCCC (\(z,y)->(z,z)) 22 | 23 | example4 = toCCC @FreeCat (\((x,y),z) -> x) 24 | 25 | example5 = toCCC @FreeCat (\(x,y) -> x + y) 26 | 27 | example6 = toCCC @FreeCat (\(x,y) -> y + (x * y)) 28 | 29 | -- example7 :: Cartesian k => k _ _ 30 | example7 = toCCC (\(x,(y,z)) -> (x,(y,z))) 31 | 32 | myconst = \x -> \y -> x 33 | example8 = toCCC @FreeCat myconst -- const -- (\x -> \y -> x) 34 | example9 = let f = (\x y -> x) in toCCC @FreeCat f 35 | example10 = toCCC @FreeCat (\x -> x) 36 | example11 = toCCC @FreeCat f where f = (\x y -> y) 37 | 38 | -- raw const is failing, but when you give it a name it doesn't. Very alarming. 39 | -- This is almost certainly because of something in the Incoherent 40 | 41 | 42 | --example12 :: Cartesian k => k (k a b) b 43 | example12 = toCCC @FreeCat ((\x y -> y) :: a -> b -> b) 44 | 45 | -- the following incorrectly fails. Early picking of incoherentinstamce seems to send it into case 3 of CCC rather than curry case 2. 46 | -- This isn't producing incorrect code, but it does suck. 47 | -- doesnotwork = toCCC @FreeCat (\x y -> y) 48 | 49 | -- Even this is fine 50 | -- example16 = toCCC @FreeCat ((\x y -> y) :: _ -> _ -> _) 51 | example13 = toCCC @FreeCat (\x y -> (x,y)) 52 | example14 = toCCC @FreeCat f where f = (\x y z -> z) 53 | example15 = toCCC @FreeCat f where f = (\x y z -> x) 54 | 55 | --example13 = toCCC (\(x,y) -> y) 56 | example1 = toCCC @FreeCat id 57 | 58 | example16 = toCCC @FreeCat (+) 59 | 60 | example17 = toCCC @FreeCat (*) 61 | -- fails. appears to be another inocherent hiccup. ($) is weird anyway 62 | -- example18 = toCCC @FreeCat ($) 63 | 64 | example18 = toCCC @FreeCat f where f = \g x -> g x 65 | example19 = toCCC @FreeCat (\(g, x) -> g x) 66 | 67 | -- fails confusingly. This might mean something is fundmanetally wrong somehwere. 68 | -- example20 = toCCC @FreeCat f where f = (\x -> (x, \y -> x)) 69 | --helper = (\x -> (x, \y -> x)) 70 | --example20 = toCCC @FreeCat helper 71 | 72 | -- can't tell if this one is correct. It is too big. revisit when I have optimizations 73 | example21 = toCCC @FreeCat f where f = \h g x -> h g x 74 | 75 | 76 | -- you can throw catagorocial literals in there if you want 77 | example22 = toCCC @FreeCat (\x -> Id . x) 78 | example23 = toCCC @FreeCat (\(x,y) -> Dup . x) 79 | -- could define helper functions with preapplied (.). dup = (.) Dup 80 | -- then (\x -> dup x) looks more nautral 81 | example24 = toCCC @FreeCat (\(x,y) -> dup x) where dup = (.) Dup 82 | 83 | 84 | example25 = toCCC @FreeCat (\(x,y) -> (x,y)) 85 | example26 = toCCC @FreeCat (\(x,(y,z)) -> (y,z)) 86 | -- or perhaps f $$ x = applyC . (fanC f x). This makes sense in that f and x are extractors. 87 | -- And then. 88 | -- \x -> mysquare x. 89 | 90 | -- this all may be just asking to get confused. 91 | 92 | 93 | 94 | -- we could also compile FreeCat as a seperate language, then dump the output to a file and recompile with ghc. Pretty goofy workflow. 95 | -- we can also perhaps find a way to push to an external solver. That would be prettty cool. 96 | 97 | -- We could super optimize functions if we have a cetagory equivalence test. Just enumerate all possible functions and find the bets one that matches. 98 | -- Z3? 99 | -- There might be 100 | 101 | -- Other possible heurisitcs: 102 | -- Simulated Annealing Maybe. 103 | 104 | 105 | -- GLobal optimization: 106 | -- Dynamic Programming? 107 | -- MIP ? 108 | -- CSP ? 109 | 110 | 111 | -------------------------------------------------------------------------------- /src/Rewrite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ImpredicativeTypes, RankNTypes, NoImplicitPrelude #-} 2 | module Rewrite where 3 | 4 | import Cat 5 | import Control.Category 6 | import Prelude hiding ((.), id) 7 | -- a dead dumb simple rewrite system 8 | -- it is expecially easy since our ctagoerical lnauggae has no names in it 9 | 10 | -- even if I get GHC rewrite rules to work. this will be useful for comparison. 11 | -- with a test suite for example. Would give us clues as to which rewrite rules are not firing. 12 | 13 | 14 | -- we can just abuse haskell pattern matching to do most of the work for us 15 | 16 | 17 | -- we should move the definition of FreeCat here. 18 | -- Add a literal constructor 19 | -- Lit :: k a b -> FreeCat a b... No this hides k.... 20 | -- well, we'l;l figure out that problem later 21 | 22 | 23 | -- Maybe we want to check out that TTT tool. 24 | -- dev.stephendiehl.com/rewrite.pdf 25 | 26 | -- Either (FreeCat a b) (FreeCat a b) -- return original argyument if fails? 27 | 28 | type Rule = forall a b. FreeCat a b -> Maybe (FreeCat a b) 29 | -- stop using prefix rule. It is annoying 30 | rule_paren :: Rule -- FreeCat a b -> Maybe (FreeCat a b) 31 | rule_paren (Comp (Comp f g) h) = Just (Comp f (Comp g h)) 32 | rule_paren _ = Nothing 33 | 34 | rule_fstsndpar :: FreeCat a b -> Maybe (FreeCat a b) 35 | rule_fstsndpar (Comp (Par Fst Snd) Dup) = Just Id 36 | rule_fstsndpar _ = Nothing 37 | 38 | rule_fst_dup :: FreeCat a b -> Maybe (FreeCat a b) 39 | rule_fst_dup (Comp Fst Dup) = Just Id 40 | rule_fst_dup _ = Nothing 41 | 42 | rule_snd_dup :: FreeCat a b -> Maybe (FreeCat a b) 43 | rule_snd_dup (Comp Snd Dup) = Just Id 44 | rule_snd_dup _ = Nothing 45 | 46 | rule_par_dup :: FreeCat a b -> Maybe (FreeCat a b) 47 | rule_par_dup (Comp (Par (Comp f Fst) (Comp g Snd)) Dup) = Just (Par f g) 48 | rule_par_dup _ = Nothing 49 | 50 | rule_par_dup' :: FreeCat a b -> Maybe (FreeCat a b) 51 | rule_par_dup' (Comp (Par (Comp f Fst) (Comp g Fst)) Dup) = Just (((Par f g) . Dup) . Fst) 52 | rule_par_dup' _ = Nothing 53 | 54 | rule_par_dup'' :: FreeCat a b -> Maybe (FreeCat a b) 55 | rule_par_dup'' (Comp (Par (Comp f Snd) (Comp g Snd)) Dup) = Just (((Par f g) . Dup) . Snd) 56 | rule_par_dup'' _ = Nothing 57 | 58 | -- parC dupC" forall f. (_parC f f) . _dupC = _dupC . f 59 | {- -- needs equality. 60 | rule_par_dup_eq :: FreeCat a b -> Maybe (FreeCat a b) 61 | rule_par_dup_eq (Comp (Par f f) Dup) | f == f = Dup . f 62 | -} 63 | 64 | 65 | -- build the curry rules. 66 | 67 | 68 | 69 | rule_id_left :: FreeCat a b -> Maybe (FreeCat a b) 70 | rule_id_left (Comp Id f) = Just f 71 | rule_id_left _ = Nothing 72 | 73 | rule_id_right :: FreeCat a b -> Maybe (FreeCat a b) 74 | rule_id_right (Comp f Id) = Just f 75 | rule_id_right _ = Nothing 76 | 77 | allRules :: [Rule] 78 | allRules = [rule_fstsndpar, rule_id_right, rule_id_left, rule_fst_dup, rule_snd_dup, rule_par_dup, rule_par_dup', rule_par_dup''] -- rule-paren 79 | -- turned off rule_paren because it actually hurts the ability to compress the nasty fanout behavior. 80 | 81 | -- yeah. Easily possible to get nasty infinite loops 82 | recurseMatch :: Rule -> FreeCat a b -> Maybe (FreeCat a b) 83 | recurseMatch rule x = case rule x of 84 | Nothing -> goDown (recurseMatch rule) x -- This rule didn't match. Try going down and matching there. 85 | Just x' -> Just x' -- travFree rule x' -- or can keep trying while we're already there. 86 | 87 | 88 | goDown :: Rule -> FreeCat a b -> Maybe (FreeCat a b) 89 | goDown z (Comp f g) = case (z f) of 90 | Nothing -> case (z g) of 91 | Nothing -> Nothing 92 | Just x -> Just (Comp f x) 93 | Just x -> Just (Comp x g) 94 | goDown z (Par f g) = case (z f) of 95 | Nothing -> case (z g) of 96 | Nothing -> Nothing -- nothing in either subtree macthed 97 | Just x -> Just (Par f x) -- 98 | Just x -> Just (Par x g) -- something in f matched the rule 99 | goDown _ _ = Nothing -- can't go down 100 | {- 101 | goDown z (Par f g) = Par (z f) (z g) 102 | goDown z Dup = Dup 103 | goDown _ Fst = Fst 104 | goDown _ Snd = Snd 105 | goDown _ f = f 106 | -} 107 | 108 | {- 109 | travFree rule x@(Comp f g) = case rule x of 110 | Nothing -> Comp (travFree rule f) (travFree rule g) 111 | Just x' -> travFree rule x' 112 | travFree rule Id = case rule Id of 113 | Nothing -> Id 114 | Just x' -> travFree rule x' 115 | -} 116 | -- can recursively go down rules until onew hits, then start all over. Put common rules first. 117 | 118 | type Rule' a b = FreeCat a b -> Maybe (FreeCat a b) 119 | 120 | rewrite' :: [Rule] -> [Rule] -> FreeCat a b -> FreeCat a b 121 | rewrite' _ [] k = k -- no rules matched 122 | rewrite' allrules (rule : rules) k = case recurseMatch rule k of 123 | Nothing -> rewrite' allrules rules k -- try the next rule 124 | Just k' -> rewrite' allrules allrules k' -- start over from the beginning 125 | 126 | rewrite rules k = rewrite' rules rules k 127 | simplify k = rewrite allRules k 128 | 129 | 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /src/CCC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, 2 | AllowAmbiguousTypes, 3 | TypeFamilies, 4 | TypeOperators, 5 | MultiParamTypeClasses, 6 | FunctionalDependencies, 7 | PolyKinds, 8 | FlexibleInstances, 9 | UndecidableInstances, 10 | TypeApplications, 11 | NoImplicitPrelude, 12 | ScopedTypeVariables, 13 | FlexibleContexts #-} 14 | module CCC ( 15 | toCCC )where 16 | 17 | import Control.Category 18 | import Prelude hiding ((.), id) 19 | import Cat 20 | 21 | 22 | -- not IsTup anymore. IsArrTup 23 | class IsTup a b | a -> b 24 | instance {-# INCOHERENT #-} (c ~ 'True) => IsTup (a,b) c 25 | instance {-# INCOHERENT #-} (c ~ 'True) => IsTup (a -> b) c 26 | instance {-# INCOHERENT #-} (b ~ 'False) => IsTup a b 27 | 28 | 29 | -- class IsCurry a b | a -> b 30 | -- instance {-# INCOHERENT #-} (d ~ 'True) => IsCurry (a -> (b -> c)) d 31 | -- instance {-# INCOHERENT #-} (b ~ 'False) => IsCurry a b 32 | 33 | 34 | 35 | class CCC (flag :: Bool) input out | flag input -> out where -- 36 | toCCC' :: input -> out 37 | 38 | -- toCCC reduces to the case of (stuff) -> single thing that is not -> or (,) 39 | -- curry and fan 40 | toCCC :: forall k a b a' b' fb. ( 41 | Category k, 42 | CCC fb (a -> b) (k a' b'), 43 | IsTup b fb ) => (a -> b) -> k a' b' 44 | toCCC f = toCCC' @fb @(a -> b) @(k a' b') f 45 | 46 | instance (Cartesian k, 47 | IsTup b fb, 48 | IsTup c fc, 49 | CCC fb (a -> b) (k a' b'), 50 | CCC fc (a -> c) (k a' c')) => CCC 'True (a -> (b,c)) (k a' (b', c')) where 51 | toCCC' f = fanC (toCCC' @fb (fst . f)) (toCCC' @fc (snd . f)) 52 | 53 | -- curry and then uncurry result 54 | instance (Closed k, 55 | IsTup c fc, 56 | CCC fc ((a,b)->c) (k (a',b') c') 57 | ) => CCC 'True (a -> (b -> c)) (k a' (k b' c')) where 58 | toCCC' f = curryC (toCCC' @fc (uncurry f)) 59 | 60 | -- base case actually builds the input once the output cannot be detructed more 61 | -- input can be anything, arrow tuple or polymorphic. Output has to be polymorphic 62 | instance (Cartesian k, 63 | IsTup a fa, 64 | BuildInput a fa (k a' a'), 65 | (k a' b') ~ b) => CCC 'False (a -> b) (k a' b') where 66 | toCCC' f = f input where 67 | input = (buildInput @a @fa (idC @k @a')) 68 | 69 | 70 | {- 71 | instance (Cartesian k, 72 | IsTup a fa, 73 | IsTup b fb, 74 | BuildInput a fa (k a' a'), 75 | FanOutput fb b (k a' b')) => CCC 'False (a -> b) (k a' b') where 76 | toCCC' f = fanOutput @fb output where 77 | input = (buildInput @a @fa (idC @k @a')) 78 | output = f input 79 | 80 | -} 81 | 82 | 83 | 84 | 85 | -- does path actuall need to be here? Maybe it does. because we need to be able to extract from it or not 86 | class BuildInput tup (flag :: Bool) path where 87 | buildInput :: path -> tup 88 | -- buildInput :: forall k. Cartesian k => k a b -> tup 89 | 90 | instance (Cartesian k, 91 | IsTup a fa, 92 | IsTup b fb, 93 | BuildInput a fa (k x a'), 94 | BuildInput b fb (k x b'), 95 | ((k x (a',b')) ~ cat)) => BuildInput (a,b) 'True cat where 96 | buildInput path = (buildInput @a @fa patha, buildInput @b @fb pathb) where 97 | patha = fstC . path 98 | pathb = sndC . path 99 | 100 | instance (Closed k, 101 | cat ~ k x (k a' b'), -- cat extract morphisms from input tuple 102 | FanOutput fa a cat', 103 | cat' ~ k x a', -- ? Is this acceptable? 104 | cat'' ~ k x b', -- the type of path' 105 | IsTup b fb, 106 | IsTup a fa, 107 | BuildInput b fb cat'') => BuildInput (a -> b) 'True cat where -- toCCC x? 108 | -- path is location of input morphism in question inside of tuple 109 | -- x may be a tuple to be deucosturcted 110 | -- or x may be arrow to be toCCC ed 111 | buildInput path = \x -> let path' = applyC . (fanC path (fanOutput @fa x)) in buildInput @b @fb path' 112 | 113 | 114 | instance (Category k, a ~ k a' b') => BuildInput a 'False (k a' b') where 115 | buildInput path = path 116 | 117 | {- 118 | class BuildInputArr (flag :: Bool) arr where 119 | buildArr :: path -> arr 120 | instance BuildInputArr 'True (a -> b) where -- toCCC x? 121 | buildArr path = \x -> let path' = applyC . (fanC path (autoUncurry x)) in buildInput @b path' 122 | -} 123 | 124 | -- 'a' could be a tuple value, or it could be an arrow value. or a raw morphism 125 | -- seperate type classe instances? for all of them? 126 | 127 | 128 | 129 | -- Does FanOput even need the flag? 130 | -- isn't it all directed now? 131 | -- it doesn't need the incoherent version. A regular overlapping instance. 132 | 133 | class FanOutput (flag :: Bool) out cat where -- | out flag -> cat 134 | fanOutput :: out -> cat 135 | 136 | instance (Category k, 137 | IsTup b fb, 138 | CCC fb (a -> b) (k a' b') 139 | ) => FanOutput 'True (a -> b) (k a' b') where 140 | fanOutput f = toCCC' @fb f 141 | 142 | instance (Category k, kab ~ k a b) => FanOutput 'False kab (k a b) where 143 | fanOutput f = f 144 | 145 | instance (Cartesian k, 146 | IsTup a fa, 147 | IsTup b fb, 148 | FanOutput fa a (k x a'), 149 | FanOutput fb b (k x b'), 150 | k x (a', b') ~ cat 151 | ) 152 | => FanOutput 'True (a, b) cat where 153 | fanOutput (x,y) = fanC (fanOutput @fa x) (fanOutput @fb y) 154 | 155 | {- 156 | class DestructOutput (flag :: Bool) out cat path | out flag path -> cat where 157 | destructOutput :: path -> out -> cat 158 | 159 | instance DesctructOutput 'True (a -> b) cat path where 160 | destructOutput p f = destructOutput (post . curryC) (sndC . pre) output where 161 | input = buildInput @a @fa (fstC . p) 162 | output = f input 163 | 164 | -} 165 | 166 | 167 | {- 168 | toCCC :: forall k a b a' b' fa fb x. (IsTup a fa, IsTup b fb, Cartesian k, BuildInput a fa (k a' a'), FanOutput fb b (k a' b')) => (a -> b) -> k a' b' 169 | toCCC f = fanOutput @fb output where 170 | input = buildInput @a @fa (idC @k @a') 171 | output = f input 172 | 173 | class AutoUncurry (flag :: Bool) a b | a flag -> b where 174 | autoUncurry :: a -> b 175 | 176 | instance ( IsCurry c f, 177 | AutoUncurry f ((a,b) -> c) d) => AutoUncurry 'True (a -> (b -> c)) d where 178 | autoUncurry f = autoUncurry @f (uncurry f) -- postprocess' = curryC . postprocess 179 | 180 | instance (a ~ d) => AutoUncurry 'False a d where 181 | autoUncurry f = f -- Actually recurse into BuildTup and FanOutput here. and then apply post processing 182 | -- autoUncurry post f = post (f buildInput) 183 | -- autoUncurry post f = (post, f) -- to be put together later after fanning 184 | -- toCCC' path post f 185 | -- positive and negative position, do different thing, 186 | -- for positive tuple, fan 187 | -- for positive arrow, uncrry 188 | -- for negative arrow, apply 189 | -- for negative tuple, path 190 | -} 191 | -- (( -> ) -> ) -> . 192 | -- means that the function is going to give us another function, which we'll have to build the input for 193 | -- That's recursive toCCC call? Or partial toCCC without postprocessing. 194 | 195 | -- combine BuildInputTup and BuildInputArr into single typeclass 196 | -- think about it in terms of k a b -> (, , ) 197 | 198 | 199 | 200 | -- autoCPS. CPS in the category layer? forall b. k (k a b) b 201 | 202 | -- what if output is (a, a -> b)? -> ( a , k a b). I guess we call toCCC on it again? but we need 203 | {- (a -> (b -> a) 204 | curry fstC 205 | parC i -} --------------------------------------------------------------------------------