├── Setup.hs ├── TODO.org ├── README.md ├── test ├── Functions.hs └── Main.hs ├── package.yaml ├── LICENSE ├── src └── Categorical │ ├── Gather.hs │ ├── Program.hs │ ├── Template.hs │ ├── NonDet.hs │ └── AST.hs └── categorical.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | * If V is a newtype, plugin error about missing coercion 2 | * If V is a type, even AltCat inlines ProgramCat 3 | * Getting a ccc residual trying to use Z3Cat 4 | :OUTPUT: 5 | [ccc @ Z3Cat @ p @ Bool (\ (p1 :: p) -> main (g p1))] 6 | :END: 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A testing library for ConCat 2 | 3 | This repository is a testing grounds for use of Conal Elliott's ConCat 4 | library. The only useful thing it provides so far is a reification of 5 | categorical terms into an AST, for purposes of runtime analysis of such 6 | structures. 7 | -------------------------------------------------------------------------------- /test/Functions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | {-# OPTIONS_GHC -fplugin=ConCat.Plugin #-} 8 | {-# OPTIONS_GHC -fsimpl-tick-factor=2800 #-} 9 | {-# OPTIONS_GHC -fexpose-all-unfoldings #-} 10 | 11 | {-# OPTIONS_GHC -dsuppress-idinfo #-} 12 | {-# OPTIONS_GHC -dsuppress-uniques #-} 13 | {-# OPTIONS_GHC -dsuppress-module-prefixes #-} 14 | 15 | module Functions where 16 | 17 | equation :: Num a => a -> a -> a 18 | equation x y = x - 3 + 7 * y 19 | {-# INLINE equation #-} 20 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: categorical 2 | version: 0.1.0.0 3 | synopsis: Compiling to categories 4 | author: John Wiegley 5 | maintainer: johnw@newartisans.com 6 | license: MIT 7 | github: jwiegley/categorical 8 | category: System 9 | 10 | dependencies: 11 | - base >= 4.9 && < 4.10 12 | - base-orphans 13 | - concat-classes 14 | - concat-plugin 15 | - concat-examples 16 | - containers 17 | - free 18 | - ghc-prim 19 | - newtype 20 | - mtl >= 2.2.1 21 | - profunctors >= 5.2 && < 5.3 22 | - transformers 23 | - z3 24 | - z3cat 25 | 26 | library: 27 | source-dirs: src 28 | exposed-modules: 29 | - Categorical.AST 30 | - Categorical.Gather 31 | - Categorical.NonDet 32 | - Categorical.Program 33 | - Categorical.Template 34 | 35 | tests: 36 | categorical: 37 | main: Main.hs 38 | source-dirs: test 39 | dependencies: 40 | - hspec == 2.* 41 | - categorical 42 | - quickcheck-io 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 John Wiegley 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /src/Categorical/Gather.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Categorical.Gather where 7 | 8 | import ConCat.Category 9 | import ConCat.Rep 10 | import Prelude hiding (id, (.), curry, uncurry, const) 11 | 12 | newtype Gather a b = Gather { runGather :: Int } 13 | 14 | gather :: Gather a b -> Int 15 | gather = runGather 16 | 17 | instance Category Gather where 18 | id = Gather 0 19 | Gather f . Gather g = Gather (f + g) 20 | 21 | instance ProductCat Gather where 22 | exl = Gather 0 23 | exr = Gather 0 24 | Gather f &&& Gather g = Gather (max f g) 25 | 26 | instance ClosedCat Gather where 27 | curry (Gather f) = Gather f 28 | uncurry (Gather f) = Gather f 29 | 30 | instance Num a => NumCat Gather a where 31 | negateC = Gather 0 32 | addC = Gather 0 33 | subC = Gather 0 34 | mulC = Gather 0 35 | powIC = Gather 0 36 | 37 | instance ConstCat Gather Int where 38 | const = Gather 39 | 40 | instance (HasRep a, r ~ Rep a) => RepCat Gather a r where 41 | reprC = Gather 0 42 | abstC = Gather 0 43 | -------------------------------------------------------------------------------- /categorical.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.18.1. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | 5 | name: categorical 6 | version: 0.1.0.0 7 | synopsis: Compiling to categories 8 | homepage: https://github.com/jwiegley/categorical#readme 9 | bug-reports: https://github.com/jwiegley/categorical/issues 10 | license: MIT 11 | license-file: LICENSE 12 | author: John Wiegley 13 | maintainer: johnw@newartisans.com 14 | category: System 15 | build-type: Simple 16 | cabal-version: >= 1.10 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/jwiegley/categorical 21 | 22 | library 23 | exposed-modules: 24 | Categorical.AST 25 | Categorical.Gather 26 | Categorical.NonDet 27 | Categorical.Program 28 | Categorical.Template 29 | other-modules: 30 | Paths_categorical 31 | build-depends: 32 | base >= 4.9 && < 4.10 33 | , base-orphans 34 | , concat-classes 35 | , concat-plugin 36 | , concat-examples 37 | , containers 38 | , free 39 | , ghc-prim 40 | , newtype 41 | , mtl >= 2.2.1 42 | , profunctors >= 5.2 && < 5.3 43 | , transformers 44 | , z3 45 | , z3cat 46 | hs-source-dirs: 47 | src 48 | default-language: Haskell2010 49 | 50 | test-suite categorical 51 | type: exitcode-stdio-1.0 52 | main-is: Main.hs 53 | hs-source-dirs: 54 | test 55 | build-depends: 56 | base >= 4.9 && < 4.10 57 | , base-orphans 58 | , concat-classes 59 | , concat-plugin 60 | , concat-examples 61 | , containers 62 | , free 63 | , ghc-prim 64 | , newtype 65 | , mtl >= 2.2.1 66 | , profunctors >= 5.2 && < 5.3 67 | , transformers 68 | , z3 69 | , z3cat 70 | , hspec == 2.* 71 | , categorical 72 | , quickcheck-io 73 | other-modules: 74 | Functions 75 | default-language: Haskell2010 76 | -------------------------------------------------------------------------------- /src/Categorical/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PackageImports #-} 9 | {-# LANGUAGE PartialTypeSignatures #-} 10 | {-# LANGUAGE PatternSynonyms #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TupleSections #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE UndecidableSuperClasses #-} 18 | 19 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 20 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 21 | {-# OPTIONS_GHC -Wno-unused-matches #-} 22 | {-# OPTIONS_GHC -Wno-incomplete-patterns #-} 23 | 24 | module Categorical.Program where 25 | 26 | -- #define COERCE_BUG 0 27 | 28 | import Categorical.Gather 29 | import Categorical.NonDet 30 | import ConCat.Category 31 | import ConCat.Syntactic (Syn, app0) 32 | import Data.Coerce 33 | import Prelude hiding ((.), id, curry, uncurry, const) 34 | 35 | data Position 36 | = V1 37 | | V2 38 | | V3 39 | deriving (Eq, Ord, Enum, Show, Read) 40 | 41 | #ifdef COERCE_BUG 42 | newtype V (l :: Position) v = V v 43 | #else 44 | type V (l :: Position) v = v 45 | #endif 46 | 47 | class Ok k v => ProgramCat k v where 48 | xfer :: forall s t. V s v `k` V t v 49 | load :: Int `k` V t v 50 | mov :: Prod k (V s v) (V s v) `k` V s v 51 | add :: Prod k (V s v) (V s v) `k` V s v 52 | ret :: V s v `k` v 53 | 54 | #ifdef COERCE_BUG 55 | instance ProgramCat (->) Int where 56 | xfer = coerce 57 | load = pack 58 | mov (V _x, V y) = V y 59 | add (V x, V y) = V (x + y) 60 | ret = unpack 61 | #else 62 | instance ProgramCat (->) Int where 63 | xfer = coerce 64 | {-# NOINLINE xfer #-} 65 | load = id 66 | {-# NOINLINE load #-} 67 | mov (_x, y) = y 68 | {-# NOINLINE mov #-} 69 | add (x, y) = x + y 70 | {-# NOINLINE add #-} 71 | ret x = x 72 | {-# NOINLINE ret #-} 73 | #endif 74 | 75 | instance ProgramCat Syn Int where 76 | xfer = app0 "xfer" 77 | {-# NOINLINE xfer #-} 78 | load = app0 "load" 79 | {-# NOINLINE load #-} 80 | mov = app0 "mov" 81 | {-# NOINLINE mov #-} 82 | add = app0 "add" 83 | {-# NOINLINE add #-} 84 | ret = app0 "ret" 85 | {-# NOINLINE ret #-} 86 | 87 | instance ProgramCat k Int => ProgramCat (NonDet k) Int where 88 | xfer = NonDet (\(l :: Int) -> (if l < 10 then xfer else xfer)) 89 | add = NonDet (\(l :: Int) -> (if l < 10 then add else add)) 90 | mov = NonDet (\(l :: Int) -> (if l < 10 then mov else mov)) 91 | load = NonDet (\(l :: Int) -> (if l < 10 then load else load)) 92 | ret = NonDet (\(l :: Int) -> (if l < 10 then ret else ret)) 93 | 94 | instance ProgramCat Gather Int where 95 | xfer = Gather 5 96 | add = Gather 10 97 | mov = Gather 10 98 | load = Gather 5 99 | ret = Gather 1 100 | -------------------------------------------------------------------------------- /src/Categorical/Template.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE UndecidableSuperClasses #-} 12 | {-# LANGUAGE UnicodeSyntax #-} 13 | 14 | {-# OPTIONS_GHC -Wall #-} 15 | 16 | module Categorical.Template where 17 | 18 | import ConCat.Category 19 | import ConCat.Rep 20 | import Data.Coerce 21 | import Prelude hiding (id, (.), curry, uncurry, const) 22 | 23 | newtype MyCat a b = MyCat (a -> b) 24 | 25 | instance Category MyCat where 26 | id = MyCat id 27 | MyCat f . MyCat g = MyCat (f . g) 28 | 29 | instance ProductCat MyCat where 30 | exl = MyCat fst 31 | exr = MyCat snd 32 | MyCat f &&& MyCat g = MyCat (f &&& g) 33 | 34 | instance TerminalCat MyCat where 35 | it = MyCat (\_ -> ()) 36 | 37 | instance ConstCat MyCat b where 38 | const b = MyCat (\_ -> b) 39 | 40 | instance BottomCat MyCat a b where 41 | bottomC = MyCat undefined 42 | 43 | instance UnknownCat MyCat a b where 44 | unknownC = MyCat (error "unknown") 45 | 46 | instance Coercible a b => CoerceCat MyCat a b where 47 | coerceC = MyCat coerce 48 | 49 | instance ClosedCat MyCat where 50 | curry (MyCat f) = MyCat (curry f) 51 | uncurry (MyCat f) = MyCat (uncurry f) 52 | 53 | instance CoproductCat MyCat where 54 | inl = MyCat Left 55 | inr = MyCat Right 56 | MyCat f ||| MyCat g = MyCat (f ||| g) 57 | 58 | instance Eq a => EqCat MyCat a where 59 | equal = MyCat (uncurry (==)) 60 | notEqual = MyCat (uncurry (/=)) 61 | 62 | instance Ord a => OrdCat MyCat a where 63 | lessThan = MyCat (uncurry (<)) 64 | greaterThan = MyCat (uncurry (>)) 65 | lessThanOrEqual = MyCat (uncurry (<=)) 66 | greaterThanOrEqual = MyCat (uncurry (<=)) 67 | 68 | instance Fractional a => FractionalCat MyCat a where 69 | recipC = MyCat recip 70 | divideC = MyCat (uncurry (/)) 71 | 72 | instance (RealFrac a, Integral b) => RealFracCat MyCat a b where 73 | floorC = MyCat floor 74 | ceilingC = MyCat ceiling 75 | 76 | instance Floating a => FloatingCat MyCat a where 77 | expC = MyCat exp 78 | cosC = MyCat cos 79 | sinC = MyCat sin 80 | 81 | instance (Integral a, Num b) => FromIntegralCat MyCat a b where 82 | fromIntegralC = MyCat fromIntegral 83 | 84 | instance DistribCat MyCat where 85 | distl = MyCat $ \(x, e) -> case e of 86 | Left y -> Left (x, y) 87 | Right z -> Right (x, z) 88 | distr = MyCat $ \(e, x) -> case e of 89 | Left y -> Left (y, x) 90 | Right z -> Right (z, x) 91 | 92 | instance (HasRep a, r ~ Rep a) => RepCat MyCat a r where 93 | reprC = MyCat repr 94 | abstC = MyCat abst 95 | 96 | instance (Enum a, Show a) => EnumCat MyCat a where 97 | succC = MyCat succ 98 | predC = MyCat pred 99 | 100 | instance BoolCat MyCat where 101 | notC = MyCat not 102 | andC = MyCat (uncurry (&&)) 103 | orC = MyCat (uncurry (||)) 104 | xorC = MyCat (uncurry (/=)) 105 | 106 | instance IfCat MyCat a where 107 | ifC = MyCat (\(b, (t, e)) -> if b then t else e) 108 | 109 | instance Num a => NumCat MyCat a where 110 | negateC = MyCat negate 111 | addC = MyCat (uncurry (+)) 112 | subC = MyCat (uncurry (-)) 113 | mulC = MyCat (uncurry (*)) 114 | powIC = MyCat (uncurry (^)) 115 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PartialTypeSignatures #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TupleSections #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# LANGUAGE UndecidableSuperClasses #-} 15 | 16 | {-# OPTIONS_GHC -Wall #-} 17 | {-# OPTIONS_GHC -Wno-orphans #-} 18 | {-# OPTIONS_GHC -Wno-type-defaults #-} 19 | 20 | {-# OPTIONS_GHC -fplugin=ConCat.Plugin #-} 21 | -- {-# OPTIONS_GHC -fplugin-opt=ConCat.Plugin:trace #-} 22 | {-# OPTIONS_GHC -fsimpl-tick-factor=1000 #-} 23 | {-# OPTIONS_GHC -fexpose-all-unfoldings #-} 24 | {-# OPTIONS_GHC -funfolding-creation-threshold=450 #-} 25 | {-# OPTIONS_GHC -funfolding-use-threshold=80 #-} 26 | 27 | -- {-# OPTIONS_GHC -dverbose-core2core #-} 28 | {-# OPTIONS_GHC -dsuppress-idinfo #-} 29 | -- {-# OPTIONS_GHC -dsuppress-uniques #-} 30 | {-# OPTIONS_GHC -dsuppress-module-prefixes #-} 31 | 32 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 33 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 34 | {-# OPTIONS_GHC -Wno-unused-imports #-} 35 | 36 | module Main where 37 | 38 | import qualified Categorical.AST as AST 39 | import Categorical.Gather 40 | import Categorical.NonDet 41 | import Categorical.Program 42 | import qualified Data.Set as S 43 | -- import ConCat.AltCat (ccc) 44 | -- import ConCat.Category 45 | -- jww (2017-04-22): Switching to AltCat instances result in a plugin error 46 | import ConCat.AltCat 47 | import ConCat.Syntactic (render) 48 | import Control.Arrow (Kleisli(..)) 49 | import Control.Monad.State 50 | import Control.Monad.Writer 51 | import Data.Functor.Identity 52 | import Data.Monoid 53 | import Data.Coerce 54 | import Functions 55 | import Prelude hiding ((.), id, curry, uncurry, const) 56 | import Z3.Category 57 | import Z3.Monad 58 | 59 | default (Int) 60 | 61 | program :: ((Int, Int), Int) -> Int 62 | program ((x, y), z) = 63 | let v2 :: V 'V2 Int = load x in 64 | let v1 :: V 'V1 Int = load y in 65 | let v3 :: V 'V3 Int = load z in 66 | let v2' :: V 'V2 Int = curry add (xfer v1) v2 in 67 | let v1' :: V 'V1 Int = load 2 in 68 | let v2'' :: V 'V2 Int = curry add (xfer v1') v2' in 69 | let v2''' :: V 'V2 Int = curry add (xfer v3) v2'' in 70 | ret v2''' 71 | {-# INLINE program #-} 72 | 73 | main :: IO () 74 | main = do 75 | -- putStrLn "Hello, Haskell!" 76 | 77 | -- print $ ccc @(->) (uncurry (equation @Int)) (10, 20) 78 | 79 | -- print $ render (ccc (uncurry (equation @Int))) 80 | -- print $ gather (ccc (uncurry (equation @Int))) 81 | 82 | -- print $ ccc @AST.Cat (uncurry (equation @Int)) 83 | -- print $ AST.eval (ccc @AST.Cat (uncurry (equation @Int))) (10, 20) 84 | 85 | -- putStrLn "Goodbye, Haskell!" 86 | 87 | putStrLn "Display program rendering..." 88 | print $ render (ccc program) 89 | 90 | putStrLn "Run the program directly..." 91 | print $ ccc program ((10, 20), 30) 92 | 93 | let (k :**: x) = ccc @((->) :**: Gather) program 94 | putStrLn $ "Solution bound: " ++ show (runGather x) 95 | putStrLn $ "Solution value: " ++ show (k ((10, 20), 30)) 96 | 97 | -- jww (2017-04-22): Uncommenting this gets a residual error 98 | -- putStrLn "Solve for a trivially satisfied constraint..." 99 | -- Just (k :: ((Int, Int), Int) -> Int) <- 100 | -- case ccc @(NonDet ((->) :**: Gather)) program of 101 | -- NonDet g -> 102 | -- fmap (fmap ((\(p :**: _) -> p) . g)) 103 | -- $ runZ3 $ ccc @Z3Cat $ \(x :: p) -> 104 | -- let _ :**: Gather s = g x in s < 100 105 | -- -- putStrLn $ "Solution bound: " ++ show (runGather x) 106 | -- putStrLn $ "Solution value: " ++ show (k ((10, 20), 30)) 107 | 108 | -- jww (2017-04-22): Uncommenting this gets a residual error 109 | -- putStrLn "Solve for a trivially satisfied constraint..." 110 | -- Just (k :**: x) <- 111 | -- resolve (ccc @(NonDet ((->) :**: Gather)) program) $ \(_ :**: Gather s) -> 112 | -- s < 100 113 | -- putStrLn $ "Solution bound: " ++ show (runGather x) 114 | -- putStrLn $ "Solution value: " ++ show (k ((10, 20), 30)) 115 | 116 | -- jww (2017-04-22): Uncommenting this causes a hang in GHC 117 | -- putStrLn "Solve for a latency bound..." 118 | -- Just k <- resolve (ccc @(NonDet (Kleisli (Writer (Sum Int)))) program) $ \p -> 119 | -- getSum (execWriter (runKleisli p (10, 20, 30))) < 50 120 | -- print $ runKleisli k (10, 20, 30) 121 | -------------------------------------------------------------------------------- /src/Categorical/NonDet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PartialTypeSignatures #-} 8 | {-# LANGUAGE PatternSynonyms #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TupleSections #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | {-# LANGUAGE UndecidableSuperClasses #-} 18 | 19 | {-# OPTIONS_GHC -fplugin=ConCat.Plugin #-} 20 | -- {-# OPTIONS_GHC -fplugin-opt=ConCat.Plugin:trace #-} 21 | {-# OPTIONS_GHC -fsimpl-tick-factor=1000 #-} 22 | {-# OPTIONS_GHC -fexpose-all-unfoldings #-} 23 | 24 | {-# OPTIONS_GHC -dsuppress-idinfo #-} 25 | {-# OPTIONS_GHC -dsuppress-uniques #-} 26 | {-# OPTIONS_GHC -dsuppress-module-prefixes #-} 27 | 28 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 29 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 30 | {-# OPTIONS_GHC -Wno-unused-imports #-} 31 | 32 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 33 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 34 | {-# OPTIONS_GHC -Wno-unused-matches #-} 35 | {-# OPTIONS_GHC -Wno-incomplete-patterns #-} 36 | 37 | module Categorical.NonDet where 38 | 39 | import ConCat.AltCat (ccc) 40 | import ConCat.Category 41 | import ConCat.Rep 42 | import Data.Monoid 43 | import Prelude hiding ((.), id, curry, uncurry, const) 44 | import Z3.Category 45 | 46 | data NonDet k a b where 47 | NonDet :: (EvalE p, GenE p) => (p -> a `k` b) -> NonDet k a b 48 | 49 | runNonDet :: NonDet k a b -> (forall p. (p -> a `k` b) -> a `k` b) -> a `k` b 50 | runNonDet (NonDet f) k = k f 51 | {-# INLINE runNonDet #-} 52 | 53 | deriving instance Functor (k a) => Functor (NonDet k a) 54 | 55 | instance Category k => Category (NonDet k) where 56 | type Ok (NonDet k) = Ok k 57 | id = NonDet (\() -> id) 58 | NonDet f . NonDet g = NonDet $ \(p1, p2) -> f p1 . g p2 59 | 60 | instance ProductCat k => ProductCat (NonDet k) where 61 | exl = NonDet (\() -> exl) 62 | exr = NonDet (\() -> exr) 63 | NonDet f &&& NonDet g = NonDet $ \(p1, p2) -> f p1 &&& g p2 64 | 65 | instance TerminalCat k => TerminalCat (NonDet k) where 66 | it = NonDet (\() -> it) 67 | 68 | instance ConstCat k b => ConstCat (NonDet k) b where 69 | const b = NonDet (\() -> const b) 70 | 71 | instance BottomCat k a b => BottomCat (NonDet k) a b where 72 | bottomC = NonDet (\() -> bottomC) 73 | 74 | instance UnknownCat k a b => UnknownCat (NonDet k) a b where 75 | unknownC = NonDet (\() -> unknownC) 76 | 77 | instance ClosedCat k => ClosedCat (NonDet k) where 78 | curry (NonDet f) = NonDet $ \p -> curry (f p) 79 | uncurry (NonDet f) = NonDet $ \p -> uncurry (f p) 80 | 81 | instance CoproductCat k => CoproductCat (NonDet k) where 82 | inl = NonDet (\() -> inl) 83 | inr = NonDet (\() -> inr) 84 | NonDet f ||| NonDet g = NonDet $ \(p1, p2) -> f p1 ||| g p2 85 | 86 | instance (EqCat k a, Eq a) => EqCat (NonDet k) a where 87 | equal = NonDet (\() -> equal) 88 | notEqual = NonDet (\() -> notEqual) 89 | 90 | instance (OrdCat k a, Ord a) => OrdCat (NonDet k) a where 91 | lessThan = NonDet (\() -> lessThan) 92 | greaterThan = NonDet (\() -> greaterThan) 93 | lessThanOrEqual = NonDet (\() -> lessThanOrEqual) 94 | greaterThanOrEqual = NonDet (\() -> greaterThanOrEqual) 95 | 96 | instance (FractionalCat k a, Fractional a) => FractionalCat (NonDet k) a where 97 | recipC = NonDet (\() -> recipC) 98 | divideC = NonDet (\() -> divideC) 99 | 100 | instance (RealFracCat k a b, RealFrac a, Integral b) => RealFracCat (NonDet k) a b where 101 | floorC = NonDet (\() -> floorC) 102 | ceilingC = NonDet (\() -> ceilingC) 103 | 104 | instance (FloatingCat k a, Floating a) => FloatingCat (NonDet k) a where 105 | expC = NonDet (\() -> expC) 106 | cosC = NonDet (\() -> cosC) 107 | sinC = NonDet (\() -> sinC) 108 | 109 | instance (FromIntegralCat k a b, Integral a, Num b) => FromIntegralCat (NonDet k) a b where 110 | fromIntegralC = NonDet (\() -> fromIntegralC) 111 | 112 | instance (DistribCat k) => DistribCat (NonDet k) where 113 | distl = NonDet (\() -> distl) 114 | distr = NonDet (\() -> distr) 115 | 116 | instance RepCat k a r => RepCat (NonDet k) a r where 117 | reprC = NonDet (\() -> reprC) 118 | abstC = NonDet (\() -> abstC) 119 | 120 | instance (EnumCat k a, Enum a) => EnumCat (NonDet k) a where 121 | succC = NonDet (\() -> succC) 122 | predC = NonDet (\() -> predC) 123 | 124 | instance BoolCat k => BoolCat (NonDet k) where 125 | notC = NonDet (\() -> notC) 126 | andC = NonDet (\() -> andC) 127 | orC = NonDet (\() -> orC) 128 | xorC = NonDet (\() -> xorC) 129 | 130 | instance IfCat k a => IfCat (NonDet k) a where 131 | ifC = NonDet (\() -> ifC) 132 | 133 | instance (NumCat k a, Num a) => NumCat (NonDet k) a where 134 | negateC = NonDet (\() -> negateC) 135 | addC = NonDet (\() -> addC) 136 | subC = NonDet (\() -> subC) 137 | mulC = NonDet (\() -> mulC) 138 | powIC = NonDet (\() -> powIC) 139 | 140 | resolve :: NonDet k a b -> ((a `k` b) -> Bool) -> IO (Maybe (a `k` b)) 141 | resolve (NonDet g) f = fmap g <$> runZ3 (ccc @Z3Cat (f . g)) 142 | {-# INLINE resolve #-} 143 | -------------------------------------------------------------------------------- /src/Categorical/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE UndecidableSuperClasses #-} 10 | {-# LANGUAGE UnicodeSyntax #-} 11 | 12 | module Categorical.AST where 13 | 14 | import ConCat.Category 15 | import ConCat.Rep 16 | import Data.Coerce 17 | import Data.Tuple (swap) 18 | import Prelude hiding (id, (.), curry, uncurry, const) 19 | 20 | type (~>) = Cat 21 | type (×) = Prod Cat 22 | type (+) = Coprod Cat 23 | 24 | data Cat a b where 25 | -- Category 26 | Id :: a ~> a 27 | Compose :: b ~> c -> a ~> b -> a ~> c 28 | 29 | -- TerminalCat 30 | It :: a ~> () 31 | 32 | -- BottomCat 33 | Bottom :: a ~> b 34 | 35 | -- UnknownCat 36 | Unknown :: a ~> b 37 | 38 | -- CoerceCat 39 | Coerce :: Coercible a b => a ~> b 40 | 41 | -- RepCat 42 | Repr :: a ~> r 43 | Abst :: r ~> a 44 | 45 | -- EqCat 46 | Equal :: Eq a => a × a ~> BoolOf Cat 47 | NotEqual :: Eq a => a × a ~> BoolOf Cat 48 | 49 | -- OrdCat 50 | LessThan :: Ord a => a × a ~> BoolOf Cat 51 | GreaterThan :: Ord a => a × a ~> BoolOf Cat 52 | LessThanOrEqual :: Ord a => a × a ~> BoolOf Cat 53 | GreaterThanOrEqual :: Ord a => a × a ~> BoolOf Cat 54 | 55 | -- DistribCat 56 | Distl :: (a × (u + v)) ~> ((a × u) + (a × v)) 57 | Distr :: ((u + v) × b) ~> ((u × b) + (v × b)) 58 | 59 | -- BoolCat 60 | Not :: BoolOf Cat ~> BoolOf Cat 61 | And :: BoolOf Cat × BoolOf Cat ~> BoolOf Cat 62 | Or :: BoolOf Cat × BoolOf Cat ~> BoolOf Cat 63 | Xor :: BoolOf Cat × BoolOf Cat ~> BoolOf Cat 64 | 65 | -- IfCat 66 | If :: BoolOf k × (a × a) ~> a 67 | 68 | -- ProductCat 69 | Exl :: (a × b) ~> a 70 | Exr :: (a × b) ~> b 71 | Dup :: a ~> (a × a) 72 | SwapP :: (a × b) ~> (b × a) 73 | Cross :: (a ~> c) -> (b ~> d) -> (a × b) ~> (c × d) 74 | Fork :: (a ~> c) -> (a ~> d) -> a ~> (c × d) 75 | 76 | -- CoproductCat 77 | Inl :: a ~> (a + b) 78 | Inr :: b ~> (a + b) 79 | Jam :: (a + a) ~> a 80 | SwapS :: (a + b) ~> (b + a) 81 | Across :: (c ~> a) -> (d ~> b) -> (c + d) ~> (a + b) 82 | Split :: (c ~> a) -> (d ~> a) -> (c + d) ~> a 83 | 84 | -- ConstCat 85 | Const :: Show b => b -> a ~> b 86 | 87 | -- ClosedCat 88 | Apply :: (Exp Cat a b × a) ~> b 89 | Curry :: ((a × b) ~> c) -> (a ~> Exp Cat b c) 90 | Uncurry :: (a ~> Exp Cat b c) -> ((a × b) ~> c) 91 | 92 | -- ENumCat 93 | Succ :: Enum a => a ~> a 94 | Pred :: Enum a => a ~> a 95 | 96 | -- NumCat 97 | Negate :: Num a => a ~> a 98 | Add :: Num a => a × a ~> a 99 | Sub :: Num a => a × a ~> a 100 | Mul :: Num a => a × a ~> a 101 | PowI :: Num a => a × Int ~> a 102 | 103 | -- FractionalCat 104 | Recip :: Fractional a => a ~> a 105 | Divide :: Fractional a => (a × a) ~> a 106 | 107 | -- RealFracCat 108 | Floor :: (RealFrac a, Integral b) => a ~> b 109 | Ceiling :: (RealFrac a, Integral b) => a ~> b 110 | 111 | -- FloatingCat 112 | Exp :: Floating a => a ~> a 113 | Cos :: Floating a => a ~> a 114 | Sin :: Floating a => a ~> a 115 | 116 | -- FromIntegralCat 117 | FromIntegral :: (Integral a, Num b) => a ~> b 118 | 119 | instance Show (Cat a b) where 120 | show = \case 121 | Id -> "Id" 122 | Compose f g -> "(" ++ show f ++ " ∘ " ++ show g ++ ")" 123 | It -> "It" 124 | Bottom -> "Bottom" 125 | Unknown -> "Unknown" 126 | Equal -> "Equal" 127 | NotEqual -> "NotEqual" 128 | LessThan -> "LessThan" 129 | GreaterThan -> "GreaterThan" 130 | LessThanOrEqual -> "LessThanOrEqual" 131 | GreaterThanOrEqual -> "GreaterThanOrEqual" 132 | Distl -> "Distl" 133 | Distr -> "Distr" 134 | Coerce -> "Coerce" 135 | Repr -> "Repr" 136 | Abst -> "Abst" 137 | Not -> "Not" 138 | And -> "And" 139 | Or -> "Or" 140 | Xor -> "Xor" 141 | If -> "If" 142 | Exl -> "Exl" 143 | Exr -> "Exr" 144 | Dup -> "Dup" 145 | SwapP -> "SwapP" 146 | Cross f g -> "(" ++ show f ++ " *** " ++ show g ++ ")" 147 | Fork f g -> "(" ++ show f ++ " &&& " ++ show g ++ ")" 148 | Inl -> "Inl" 149 | Inr -> "Inr" 150 | Jam -> "Jam" 151 | SwapS -> "Swaps" 152 | Across f g -> "(" ++ show f ++ " +++ " ++ show g ++ ")" 153 | Split f g -> "(" ++ show f ++ " ||| " ++ show g ++ ")" 154 | Const b -> "Const " ++ show b 155 | Apply -> "Apply" 156 | Curry f -> "(Curry " ++ show f ++ ")" 157 | Uncurry f -> "(Uncurry " ++ show f ++ ")" 158 | Succ -> "Succ" 159 | Pred -> "Pred" 160 | Negate -> "Negate" 161 | Add -> "Add" 162 | Sub -> "Sub" 163 | Mul -> "Mul" 164 | PowI -> "PowI" 165 | Recip -> "Recip" 166 | Divide -> "Divide" 167 | Floor -> "Floor" 168 | Ceiling -> "Ceiling" 169 | Exp -> "Exp" 170 | Cos -> "Cos" 171 | Sin -> "Sin" 172 | FromIntegral -> "FromIntegral" 173 | 174 | eval :: a ~> b -> a -> b 175 | eval = \case 176 | Id -> id 177 | Compose f g -> eval f . eval g 178 | It -> const () 179 | Bottom -> undefined 180 | Unknown -> error "unknown!" 181 | Equal -> uncurry (==) 182 | NotEqual -> uncurry (/=) 183 | LessThan -> uncurry (<) 184 | GreaterThan -> uncurry (>) 185 | LessThanOrEqual -> uncurry (<=) 186 | GreaterThanOrEqual -> uncurry (>=) 187 | Distl -> \(a, p) -> case p of Left x -> Left (a, x) 188 | Right x -> Right (a, x) 189 | Distr -> \(p, b) -> case p of Left x -> Left (x, b) 190 | Right x -> Right (x, b) 191 | Coerce -> coerce 192 | Repr -> error "repr" 193 | Abst -> error "abst" 194 | Not -> not 195 | And -> uncurry (&&) 196 | Or -> uncurry (||) 197 | Xor -> uncurry (/=) 198 | If -> \(x, (y, z)) -> if x then y else z 199 | Exl -> fst 200 | Exr -> snd 201 | Dup -> \x -> (x, x) 202 | SwapP -> swap 203 | Cross f g -> eval f *** eval g 204 | Fork f g -> eval f &&& eval g 205 | Inl -> Left 206 | Inr -> Right 207 | Jam -> either id id 208 | SwapS -> \case Left x -> Right x 209 | Right x -> Left x 210 | Across f g -> eval f +++ eval g 211 | Split f g -> eval f ||| eval g 212 | Const b -> const b 213 | Apply -> uncurry ($) 214 | Curry f -> curry (eval f) 215 | Uncurry f -> uncurry (eval f) 216 | Succ -> succ 217 | Pred -> pred 218 | Negate -> negate 219 | Add -> uncurry (+) 220 | Sub -> uncurry (-) 221 | Mul -> uncurry (*) 222 | PowI -> uncurry (^) 223 | Recip -> recip 224 | Divide -> uncurry (/) 225 | Floor -> floor 226 | Ceiling -> ceiling 227 | Exp -> exp 228 | Cos -> cos 229 | Sin -> sin 230 | FromIntegral -> fromIntegral 231 | 232 | instance Category Cat where 233 | id = Id 234 | (.) = Compose 235 | 236 | instance TerminalCat Cat where 237 | it = It 238 | 239 | instance BottomCat Cat a b where 240 | bottomC = Bottom 241 | 242 | instance UnknownCat Cat a b where 243 | unknownC = Unknown 244 | 245 | instance Eq a => EqCat Cat a where 246 | equal = Equal 247 | notEqual = NotEqual 248 | 249 | instance Ord a => OrdCat Cat a where 250 | lessThan = LessThan 251 | greaterThan = GreaterThan 252 | lessThanOrEqual = LessThanOrEqual 253 | greaterThanOrEqual = GreaterThanOrEqual 254 | 255 | instance Fractional a => FractionalCat Cat a where 256 | recipC = Recip 257 | divideC = Divide 258 | 259 | instance (RealFrac a, Integral b) => RealFracCat Cat a b where 260 | floorC = Floor 261 | ceilingC = Ceiling 262 | 263 | instance Floating a => FloatingCat Cat a where 264 | expC = Exp 265 | cosC = Cos 266 | sinC = Sin 267 | 268 | instance (Integral a, Num b) => FromIntegralCat Cat a b where 269 | fromIntegralC = FromIntegral 270 | 271 | instance DistribCat Cat where 272 | distl = Distl 273 | distr = Distr 274 | 275 | instance Coercible a b => CoerceCat Cat a b where 276 | coerceC = Coerce 277 | 278 | instance (r ~ Rep a) => RepCat Cat a r where 279 | reprC = Repr 280 | abstC = Abst 281 | 282 | instance (Enum a, Show a) => EnumCat Cat a where 283 | succC = Succ 284 | predC = Pred 285 | 286 | instance BoolCat Cat where 287 | notC = Not 288 | andC = And 289 | orC = Or 290 | xorC = Xor 291 | 292 | instance IfCat Cat a where 293 | ifC = If 294 | 295 | instance ProductCat Cat where 296 | exl = Exl 297 | exr = Exr 298 | dup = Dup 299 | swapP = SwapP 300 | (***) = Cross 301 | (&&&) = Fork 302 | 303 | instance CoproductCat Cat where 304 | inl = Inl 305 | inr = Inr 306 | jam = Jam 307 | swapS = SwapS 308 | (+++) = Across 309 | (|||) = Split 310 | 311 | instance Show a => ConstCat Cat a where 312 | const = Const 313 | 314 | instance ClosedCat Cat where 315 | apply = Apply 316 | curry = Curry 317 | uncurry = Uncurry 318 | 319 | instance Num a => NumCat Cat a where 320 | negateC = Negate 321 | addC = Add 322 | subC = Sub 323 | mulC = Mul 324 | powIC = PowI 325 | --------------------------------------------------------------------------------