├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── hoas.cabal ├── package.yaml ├── src ├── AsEval.hs ├── AsTerm.hs ├── AsView.hs ├── Global.hs ├── HasCoexp.hs ├── HasDomain.hs ├── HasProduct.hs ├── HasSum.hs ├── Hoas.hs ├── Hoas │ ├── AsBound.hs │ └── Bound.hs ├── Id.hs ├── Mal.hs └── Type.hs ├── stack.yaml ├── stack.yaml.lock └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hoas 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | It is well known one can compile higher order abstract syntax to a 2 | closed cartesian category. This project flips the arrows compiling 3 | the higher order abstract syntax to the categorical dual. I'm not 4 | sure of the best interpretation of a category but I eventually settled 5 | on trying to make it work something like a logic programming languaage. 6 | 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE NoStarIsType #-} 6 | 7 | module Main where 8 | 9 | import AsEval 10 | import qualified AsTerm 11 | import AsView 12 | import Control.Category 13 | import Control.Monad.Cont 14 | import Data.Dynamic 15 | import Data.Set (Set) 16 | import qualified Data.Set as Set 17 | import qualified Data.Void as Void 18 | import Data.Word 19 | import HasProduct 20 | import HasSum 21 | import Hoas 22 | import Hoas.AsBound 23 | import Hoas.Bound (Bound) 24 | import qualified Id 25 | import Mal (Mal) 26 | import Type 27 | import Prelude hiding (id, succ, (.), (<*>)) 28 | 29 | main :: IO () 30 | main = do 31 | x <- Id.stream 32 | 33 | putStrLn "The Program" 34 | putStrLn (view (bound x)) 35 | 36 | putStrLn "" 37 | putStrLn "Point-Free Program" 38 | putStrLn (view (malP x)) 39 | 40 | putStrLn "" 41 | putStrLn "Result" 42 | putStrLn (show (result x)) 43 | 44 | type TYPE = U64 45 | 46 | program :: Hoas t => t (U64 -< Unit) Void 47 | program = st inferT $ \x -> 48 | (x `constrain` (st inferT $ \y -> y <<< u64 5)) 49 | `amb` (x `constrain` (st inferT $ \y -> y <<< u64 5)) 50 | 51 | full :: Hoas t => t (TYPE -< Unit) Void 52 | full = program 53 | 54 | bound :: Bound t => Id.Stream -> t (TYPE -< Unit) Void 55 | bound str = bindPoints str full 56 | 57 | malP :: Mal k => Id.Stream -> k (TYPE -< Unit) Void 58 | malP str = AsTerm.pointFree (bound str) 59 | 60 | compiled :: MonadCont m => Id.Stream -> m (Value m TYPE) 61 | compiled str = callCC $ \k -> do 62 | abs <- AsEval.asEval (malP str) $ Coin :- \x -> k x 63 | case abs of 64 | 65 | result :: Id.Stream -> Word64 66 | result str = flip runCont id $ do 67 | val <- compiled str 68 | case val of 69 | Value64 x -> pure x 70 | -------------------------------------------------------------------------------- /hoas.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: b1f94a12d1c147ce3a361753aaa5c4d3b4aecbda7cbff9c050535f2645eddf2d 8 | 9 | name: hoas 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/hoas#readme 13 | bug-reports: https://github.com/githubuser/hoas/issues 14 | author: Author name here 15 | maintainer: example@example.com 16 | copyright: 2020 Author name here 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/githubuser/hoas 27 | 28 | library 29 | exposed-modules: 30 | AsEval 31 | AsTerm 32 | AsView 33 | Global 34 | HasCoexp 35 | HasDomain 36 | HasProduct 37 | HasSum 38 | Hoas 39 | Hoas.AsBound 40 | Hoas.Bound 41 | Id 42 | Mal 43 | Type 44 | other-modules: 45 | Paths_hoas 46 | hs-source-dirs: 47 | src 48 | build-depends: 49 | atomic-primops >=0.8 && <0.9 50 | , base >=4.7 && <5 51 | , containers >=0.6 && <0.7 52 | , mtl >=2.2 && <3 53 | default-language: Haskell2010 54 | 55 | executable hoas-exe 56 | main-is: Main.hs 57 | other-modules: 58 | Paths_hoas 59 | hs-source-dirs: 60 | app 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 62 | build-depends: 63 | atomic-primops >=0.8 && <0.9 64 | , base >=4.7 && <5 65 | , containers >=0.6 && <0.7 66 | , hoas 67 | , mtl >=2.2 && <3 68 | default-language: Haskell2010 69 | 70 | test-suite hoas-test 71 | type: exitcode-stdio-1.0 72 | main-is: Spec.hs 73 | other-modules: 74 | Paths_hoas 75 | hs-source-dirs: 76 | test 77 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 78 | build-depends: 79 | atomic-primops >=0.8 && <0.9 80 | , base >=4.7 && <5 81 | , containers >=0.6 && <0.7 82 | , hoas 83 | , mtl >=2.2 && <3 84 | default-language: Haskell2010 85 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: hoas 2 | version: 0.1.0.0 3 | github: "githubuser/hoas" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 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 | - mtl >= 2.2 && < 3 25 | - atomic-primops >= 0.8 && <0.9 26 | - containers >= 0.6 && <0.7 27 | 28 | library: 29 | source-dirs: src 30 | 31 | executables: 32 | hoas-exe: 33 | main: Main.hs 34 | source-dirs: app 35 | ghc-options: 36 | - -threaded 37 | - -rtsopts 38 | - -with-rtsopts=-N 39 | dependencies: 40 | - hoas 41 | 42 | tests: 43 | hoas-test: 44 | main: Spec.hs 45 | source-dirs: test 46 | ghc-options: 47 | - -threaded 48 | - -rtsopts 49 | - -with-rtsopts=-N 50 | dependencies: 51 | - hoas 52 | -------------------------------------------------------------------------------- /src/AsEval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE Strict #-} 6 | {-# LANGUAGE StrictData #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeFamilyDependencies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE NoStarIsType #-} 11 | 12 | -- | Strict / Strict Data are not for performance but simply to 13 | -- emphasize the semantics don't depend on laziness 14 | module AsEval (Expr, asEval, Value (..)) where 15 | 16 | import Control.Category 17 | import Control.Monad.Cont 18 | import Data.Kind 19 | import qualified Data.Void as Void 20 | import Data.Word 21 | import Global 22 | import HasCoexp 23 | import HasProduct 24 | import HasSum 25 | import Mal 26 | import Type 27 | import Prelude hiding (Bool (..), Either (..), id, (.)) 28 | 29 | asEval :: Expr m a b -> Value m a -> m (Value m b) 30 | asEval (E x) = x 31 | 32 | data family Value (m :: Type -> Type) (a :: T) 33 | 34 | data instance Value m (a + b) = Left (Value m a) | Right (Value m b) 35 | 36 | data instance Value m (a * b) = Value m a ::: Value m b 37 | 38 | data instance Value m (a -< b) = Value m b :- (Value m a -> m Void.Void) 39 | 40 | data instance Value m B = True | False 41 | 42 | infixl 9 :- 43 | 44 | data instance Value m Unit = Coin 45 | 46 | data instance Value m Void 47 | 48 | newtype instance Value m U64 = Value64 Word64 49 | 50 | newtype Expr m a b = E (Value m a -> m (Value m b)) 51 | 52 | instance Monad m => Category (Expr m) where 53 | id = E pure 54 | E f . E g = E $ \x -> do 55 | y <- g x 56 | f y 57 | 58 | instance Monad m => HasProduct (Expr m) where 59 | unit = E $ const $ pure Coin 60 | 61 | E f &&& E g = E $ \x -> do 62 | f' <- f x 63 | g' <- g x 64 | pure $ f' ::: g' 65 | first = E $ \(x ::: _) -> pure x 66 | second = E $ \(_ ::: x) -> pure x 67 | 68 | instance Monad m => HasSum (Expr m) where 69 | absurd = E $ \x -> case x of 70 | 71 | E f ||| E g = E $ \x -> case x of 72 | Left l -> f l 73 | Right r -> g r 74 | left = E (pure . Left) 75 | right = E (pure . Right) 76 | 77 | instance MonadCont m => HasCoexp (Expr m) where 78 | st (E f) = E $ \(x :- k) -> do 79 | y <- f x 80 | case y of 81 | Left l -> do 82 | abs <- k l 83 | Void.absurd abs 84 | Right r -> pure r 85 | try (E f) = E $ \b -> callCC $ \k -> do 86 | env <- f $ b :- \x -> k (Left x) 87 | pure (Right env) 88 | 89 | instance MonadCont m => Mal (Expr m) where 90 | true = E $ \Coin -> pure True 91 | false = E $ \Coin -> pure False 92 | u64 x = E $ \Coin -> pure $ Value64 x 93 | 94 | global (Global (SU64 :*: SU64) SU64 "core" "add") = E $ \(Value64 x ::: Value64 y) -> pure $ Value64 (x + y) 95 | global (Global SU64 SU64 "core" "succ") = E $ \(Value64 x) -> pure $ Value64 (x + 1) 96 | -------------------------------------------------------------------------------- /src/AsTerm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeFamilyDependencies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE NoStarIsType #-} 8 | 9 | module AsTerm (PointFree, pointFree) where 10 | 11 | import Control.Category 12 | import Data.Kind 13 | import Data.Maybe 14 | import Data.Typeable ((:~:) (..)) 15 | import Global 16 | import HasCoexp 17 | import HasProduct 18 | import HasSum 19 | import qualified Hoas.Bound as Bound 20 | import Id (Id) 21 | import Mal 22 | import Type 23 | import Prelude hiding (curry, id, uncurry, (.), (<*>)) 24 | 25 | pointFree :: PointFree k a b -> k a b 26 | pointFree (E x) = out x 27 | 28 | data PointFree (k :: T -> T -> Type) a b = E (Pf k (a) (b)) 29 | 30 | instance Mal k => Category (PointFree k) where 31 | E f . E g = E (f . g) 32 | id = E id 33 | 34 | instance Mal k => Bound.Bound (PointFree k) where 35 | st n t f = E me 36 | where 37 | k = Label t n 38 | E body = f (E (mkLabel k)) 39 | 40 | me = case removeLabel body k of 41 | Nothing -> mal (right . body) 42 | Just y -> y 43 | try (E f) (E x) = E (f <*> x) 44 | 45 | E x `amb` E y = E (x `amb` y) 46 | 47 | true = E (true . unit) 48 | false = E (false . unit) 49 | 50 | u64 x = E (u64 x . unit) 51 | global g = E (global g) 52 | 53 | instance Mal k => HasSum (PointFree k) where 54 | absurd = E absurd 55 | E f ||| E x = E (f ||| x) 56 | 57 | instance Mal k => HasProduct (PointFree k) where 58 | E f &&& E x = E (f &&& x) 59 | first = E first 60 | second = E second 61 | 62 | instance Mal k => Category (Pf k) where 63 | id = lift0 id 64 | f . g = me 65 | where 66 | me = 67 | V 68 | { out = out f . out g, 69 | removeLabel = \v -> case (removeLabel f v, removeLabel g v) of 70 | (Just f', Just g') -> Just $ mal ((left ||| try f') . try g') 71 | (_, Just g') -> Just $ f . g' 72 | (Just f', _) -> Just $ mal (try f' . g) 73 | _ -> Nothing 74 | } 75 | 76 | instance Mal k => HasSum (Pf k) where 77 | absurd = lift0 absurd 78 | left = lift0 left 79 | right = lift0 right 80 | x ||| y = me 81 | where 82 | me = 83 | V 84 | { out = out x ||| out y, 85 | removeLabel = \v -> case (removeLabel x v, removeLabel y v) of 86 | (Just x', Just y') -> Just $ mal (try x' ||| try y') 87 | (_, Just y') -> Just $ mal ((right . x) ||| try y') 88 | (Just x', _) -> Just $ mal (try x' ||| (right . y)) 89 | _ -> Nothing 90 | } 91 | 92 | instance Mal k => HasProduct (Pf k) where 93 | unit = lift0 unit 94 | first = lift0 first 95 | second = lift0 second 96 | x &&& y = me 97 | where 98 | me = 99 | V 100 | { out = out x &&& out y, 101 | removeLabel = \v -> case (removeLabel x v, removeLabel y v) of 102 | (Just x', Just y') -> Just (x' &&& y') 103 | (_, Just y') -> Just (mal (right . x) &&& y') 104 | (Just x', _) -> Just (x' &&& mal (right . y)) 105 | _ -> Nothing 106 | } 107 | 108 | instance Mal k => HasCoexp (Pf k) where 109 | st f = me 110 | where 111 | me = 112 | V 113 | { out = st $ out f, 114 | removeLabel = \v -> case removeLabel f v of 115 | Just f' -> Just $ mal $ mal (shuffleSum (try f')) 116 | _ -> Nothing 117 | } 118 | try f = me 119 | where 120 | me = 121 | V 122 | { out = try $ out f, 123 | removeLabel = \v -> case removeLabel f v of 124 | Just f' -> Just $ mal (shuffleSum (try (try f'))) 125 | _ -> Nothing 126 | } 127 | 128 | shuffleSum :: HasSum k => k b (a + (v + c)) -> k b (v + (a + c)) 129 | shuffleSum x = ((right . left) ||| (left ||| (right . right))) . x 130 | 131 | instance Mal k => Mal (Pf k) where 132 | x `amb` y = me 133 | where 134 | me = 135 | V 136 | { out = out x `amb` out y, 137 | removeLabel = \v -> case (removeLabel x v, removeLabel y v) of 138 | (Just x', Just y') -> Just (x' `amb` y') 139 | (_, Just y') -> Just (mal (right . x) `amb` y') 140 | (Just x', _) -> Just (x' `amb` mal (right . y)) 141 | _ -> Nothing 142 | } 143 | 144 | true = lift0 true 145 | false = lift0 false 146 | global g = lift0 $ global g 147 | u64 x = lift0 $ u64 x 148 | 149 | data Pf k (a :: T) (b :: T) = V 150 | { out :: k a b, 151 | removeLabel :: forall v. Label v -> Maybe (Pf k (v -< a) b) 152 | } 153 | 154 | data Label a = Label (ST a) Id 155 | 156 | eqLabel :: Label a -> Label b -> Maybe (a :~: b) 157 | eqLabel (Label t m) (Label t' n) 158 | | m == n = eqT t t' 159 | | otherwise = Nothing 160 | 161 | mkLabel :: HasCoexp k => Label a -> Pf k (a) Void 162 | mkLabel v@(Label _ n) = me 163 | where 164 | me = 165 | V 166 | { out = error ("free label " ++ show n), 167 | removeLabel = \maybeV -> case eqLabel v maybeV of 168 | Nothing -> Nothing 169 | Just Refl -> Just (lift0 (mal left)) 170 | } 171 | 172 | lift0 :: k a b -> Pf k a b 173 | lift0 x = me 174 | where 175 | me = 176 | V 177 | { out = x, 178 | removeLabel = const Nothing 179 | } 180 | -------------------------------------------------------------------------------- /src/AsView.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module AsView (View, view) where 6 | 7 | import Control.Category 8 | import Global 9 | import HasCoexp 10 | import HasProduct 11 | import HasSum 12 | import Hoas.Bound 13 | import Mal 14 | import Type 15 | 16 | data View (a :: T) (b :: T) = V String 17 | 18 | view :: View a b -> String 19 | view (V v) = v 20 | 21 | instance Category View where 22 | id = V "id" 23 | 24 | -- not sure which direction is best ⊊ or ⊋ 25 | V f . V g = V (f ++ " ⊊ " ++ g) 26 | 27 | instance Bound View where 28 | st n t f = V ("{" ++ v ++ ": " ++ show t ++ " | ⊥ ← " ++ body ++ "}") 29 | where 30 | v = "x" ++ show n 31 | V body = f (V v) 32 | 33 | V f `try` V x = V $ "(" ++ x ++ " \\ " ++ f ++ ")" 34 | 35 | V x `amb` V y = V $ "(" ++ x ++ " amb " ++ y ++ ")" 36 | 37 | true = V "true" 38 | false = V "false" 39 | 40 | u64 n = V $ "{" ++ show n ++ "}" 41 | global g = V (show g) 42 | 43 | instance HasProduct View where 44 | unit = V "unit" 45 | 46 | V f &&& V x = V ("⟨" ++ f ++ " , " ++ x ++ "⟩") 47 | first = V "π₁" 48 | second = V "π₂" 49 | 50 | instance HasSum View where 51 | absurd = V "∅" 52 | 53 | V f ||| V x = V ("[" ++ f ++ " ; " ++ x ++ "]") 54 | left = V "i₁" 55 | right = V "i₂" 56 | 57 | instance HasCoexp View where 58 | st (V f) = V ("(← " ++ f ++ ")") 59 | try (V f) = V ("(\\ " ++ f ++ ")") 60 | 61 | instance Mal View where 62 | V x `amb` V y = V $ "(" ++ x ++ " amb " ++ y ++ ")" 63 | 64 | global g = V (show g) 65 | 66 | true = V "true" 67 | false = V "false" 68 | 69 | u64 x = V $ "{" ++ show x ++ "}" 70 | -------------------------------------------------------------------------------- /src/Global.hs: -------------------------------------------------------------------------------- 1 | module Global (Global (..)) where 2 | 3 | import Type 4 | 5 | data Global a b = Global 6 | { domain :: ST a, 7 | codomain :: ST b, 8 | package :: String, 9 | name :: String 10 | } 11 | 12 | instance Show (Global a b) where 13 | show g = package g ++ "/" ++ name g 14 | -------------------------------------------------------------------------------- /src/HasCoexp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE NoStarIsType #-} 3 | 4 | module HasCoexp (mal, HasCoexp (..)) where 5 | 6 | import Control.Category 7 | import HasSum 8 | import Type 9 | import Prelude hiding (curry, id, uncurry, (.), (<*>)) 10 | 11 | -- | The categorical definition of an exponential (function type.) 12 | class HasSum k => HasCoexp k where 13 | (<*>) :: k (a -< b) env -> k a env -> k b env 14 | f <*> x = (x ||| id) . try f 15 | 16 | st :: k b (a + env) -> k (a -< b) env 17 | try :: k (a -< b) env -> k b (a + env) 18 | 19 | -- | deprecated alias 20 | mal :: HasCoexp k => k b (a + env) -> k (a -< b) env 21 | mal = st 22 | -------------------------------------------------------------------------------- /src/HasDomain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE NoStarIsType #-} 3 | 4 | module HasDomain (HasDomain (..)) where 5 | 6 | import Control.Category 7 | import Data.Proxy 8 | import Type 9 | import Prelude hiding (curry, id, uncurry, (.), (<*>)) 10 | 11 | class Category k => HasDomain k where 12 | domain :: Proxy (k a b) -> ST a 13 | range :: Proxy (k a b) -> ST b 14 | -------------------------------------------------------------------------------- /src/HasProduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE NoStarIsType #-} 4 | 5 | module HasProduct (HasProduct (..)) where 6 | 7 | import Control.Category 8 | import Type 9 | 10 | class Category k => HasProduct k where 11 | unit :: k x Unit 12 | 13 | (&&&) :: k env a -> k env b -> k env (a * b) 14 | first :: k (a * b) a 15 | second :: k (a * b) b 16 | 17 | infixl 9 &&& 18 | -------------------------------------------------------------------------------- /src/HasSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module HasSum (HasSum (..)) where 4 | 5 | import Control.Category 6 | import Type 7 | 8 | class Category k => HasSum k where 9 | absurd :: k Void x 10 | 11 | (|||) :: k a c -> k b c -> k (a + b) c 12 | left :: k a (a + b) 13 | right :: k b (a + b) 14 | 15 | infixl 9 ||| 16 | -------------------------------------------------------------------------------- /src/Hoas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE NoStarIsType #-} 6 | 7 | module Hoas (Hoas (..)) where 8 | 9 | import Control.Category 10 | import Data.Kind 11 | import Data.Word (Word64) 12 | import Global 13 | import HasProduct 14 | import HasSum 15 | import Type 16 | import Prelude hiding (id, (.), (<*>)) 17 | 18 | class (HasSum t, HasProduct t) => Hoas t where 19 | -- | set of values such that ... 20 | st :: ST c -> (t c Void -> t b a) -> t (c -< b) a 21 | 22 | constrain :: t b x -> t (b -< c) x -> t c x 23 | 24 | try :: t (b -< c) x -> t b x -> t c x 25 | try = flip constrain 26 | 27 | true :: t x B 28 | false :: t x B 29 | 30 | amb :: t x Void -> t x Void -> t x Void 31 | 32 | isUnit :: t Unit x -> t y x 33 | isUnit = (. unit) 34 | 35 | isTrue :: t B x -> t y x 36 | isTrue = (. true) 37 | 38 | -- fixme ... move to HasProduct ? 39 | isFirst :: t a x -> t (a * b) x 40 | isFirst = (. first) 41 | isSecond :: t b x -> t (a * b) x 42 | isSecond = (. second) 43 | 44 | global :: Global a b -> t a b 45 | u64 :: Word64 -> t x U64 46 | 47 | succ :: t U64 U64 48 | succ = global $ Global inferT inferT "core" "succ" 49 | 50 | add :: t (U64 * U64) U64 51 | add = global $ Global inferT inferT "core" "add" 52 | -------------------------------------------------------------------------------- /src/Hoas/AsBound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Hoas.AsBound (Expr, bindPoints) where 6 | 7 | import Id (Stream (..)) 8 | import Hoas.Bound 9 | import qualified Hoas 10 | import HasSum 11 | import HasProduct 12 | import Type 13 | import Control.Category 14 | import Prelude hiding ((.), id, curry, uncurry, (<*>), break) 15 | 16 | data Expr t (a :: T) (b :: T) = E (Stream -> t a b) 17 | 18 | bindPoints :: Stream -> Expr t a b -> t a b 19 | bindPoints str (E x) = x str 20 | 21 | instance Category t => Category (Expr t) where 22 | id = E $ const id 23 | E f . E x = E $ \(Stream _ fs xs) -> f fs . x xs 24 | 25 | instance Bound t => HasSum (Expr t) where 26 | absurd = E $ const absurd 27 | E f ||| E x = E $ \(Stream _ fs xs) -> f xs ||| x xs 28 | 29 | instance Bound t => HasProduct (Expr t) where 30 | E f &&& E x = E $ \(Stream _ fs xs) -> f xs &&& x xs 31 | first = E $ const first 32 | second = E $ const second 33 | 34 | instance Bound t => Hoas.Hoas (Expr t) where 35 | st t f = E $ \(Stream n _ ys) -> st n t $ \x -> case f (E $ \_ -> x) of 36 | E y -> y ys 37 | E x `constrain` E f = E $ \(Stream _ fs xs) -> f fs `try` x xs 38 | 39 | E x `amb` E y = E $ \(Stream _ xs ys) -> x xs `amb` y ys 40 | 41 | true = E $ const true 42 | false = E $ const false 43 | 44 | u64 x = E $ const (u64 x) 45 | 46 | global g = E $ const (global g) 47 | -------------------------------------------------------------------------------- /src/Hoas/Bound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE NoStarIsType #-} 6 | 7 | module Hoas.Bound (Bound (..)) where 8 | 9 | import Type 10 | import Prelude hiding ((.), id, (<*>), uncurry) 11 | import Id (Id) 12 | import Global 13 | import Data.Kind 14 | import Data.Word (Word64) 15 | import Control.Category 16 | import HasSum 17 | import HasProduct 18 | 19 | class (HasSum t, HasProduct t) => Bound t where 20 | st :: Id -> ST c -> (t c Void -> t b a) -> t (c -< b) a 21 | try :: t (b -< c) x -> t b x -> t c x 22 | 23 | amb :: t x Void -> t x Void -> t x Void 24 | 25 | true :: t x B 26 | false :: t x B 27 | 28 | global :: Global a b -> t a b 29 | u64 :: Word64 -> t x U64 30 | -------------------------------------------------------------------------------- /src/Id.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Use the trick from functional pearl "On generating unique names by 4 | -- Lennart Augustsson, Mikael Rittri and Dan Synek" to generate a unique 5 | -- stream of ids. 6 | module Id (Id, stream, Stream (..)) where 7 | 8 | import Data.Atomics.Counter 9 | import System.IO.Unsafe 10 | 11 | data Stream = Stream Id Stream Stream 12 | 13 | stream :: IO Stream 14 | stream = do 15 | counter <- newCounter 0 16 | stream' counter 17 | 18 | stream' :: AtomicCounter -> IO Stream 19 | stream' counter = unsafeInterleaveIO $ do 20 | u <- unique counter 21 | x <- stream' counter 22 | y <- stream' counter 23 | return (Stream u x y) 24 | 25 | unique :: AtomicCounter -> IO Id 26 | unique counter = do 27 | x <- incrCounter 1 counter 28 | return (Id (x - 1)) 29 | 30 | newtype Id = Id Int deriving (Eq, Ord) 31 | 32 | instance Show Id where 33 | show (Id n) = show n 34 | -------------------------------------------------------------------------------- /src/Mal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE NoStarIsType #-} 3 | 4 | -- | 5 | -- 6 | -- Export the final type class of the simple lambda calculus language. 7 | -- Here we finish the Lambda type class off with some basic operations on 8 | -- integers. 9 | module Mal (Mal (..)) where 10 | 11 | import Control.Category 12 | import Data.Word (Word64) 13 | import Global 14 | import HasCoexp 15 | import HasProduct 16 | import HasSum 17 | import Type 18 | import Prelude hiding (curry, id, uncurry, (.)) 19 | 20 | class (HasSum k, HasProduct k, HasCoexp k) => Mal k where 21 | true :: k Unit B 22 | false :: k Unit B 23 | 24 | amb :: k x Void -> k x Void -> k x Void 25 | 26 | u64 :: Word64 -> k Unit U64 27 | 28 | global :: Global a b -> k a b 29 | 30 | commuteSum :: k (a + b) (b + a) 31 | commuteSum = right ||| left 32 | 33 | factorIn :: k (v * (a + b)) ((v * a) + (v * b)) 34 | factorIn = try (mal (right . first) &&& mal (commuteSum . (try (mal (right . first) &&& mal (commuteSum . second))))) 35 | 36 | factorOut :: k ((a * b) + (a * c)) (a * (b + c)) 37 | factorOut = (first ||| first) &&& ((left . second) ||| (right . second)) 38 | -------------------------------------------------------------------------------- /src/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE NoStarIsType #-} 7 | 8 | module Type 9 | ( inferT, 10 | eqT, 11 | ST (..), 12 | T, 13 | Void, 14 | Unit, 15 | type B, 16 | type (-), 17 | type (-<), 18 | type (+), 19 | type (*), 20 | type U64, 21 | ) 22 | where 23 | 24 | import Data.Maybe 25 | import Data.Typeable ((:~:) (..)) 26 | import Type.Reflection 27 | 28 | type (-<) = 'Coexp 29 | 30 | type (-) = 'Coexp 31 | 32 | infixr 9 - 33 | 34 | infixr 9 -< 35 | 36 | type (+) = 'Sum 37 | 38 | infixr 9 + 39 | 40 | type (*) = 'Prod 41 | 42 | infixr 9 * 43 | 44 | type B = 'B 45 | 46 | type Void = 'Void 47 | 48 | type Unit = 'Unit 49 | 50 | type U64 = 'U64 51 | 52 | data T 53 | = B 54 | | Void 55 | | Unit 56 | | Prod T T 57 | | Sum T T 58 | | Coexp T T 59 | | U64 60 | 61 | data ST a where 62 | SB :: ST B 63 | SVoid :: ST Void 64 | SUnit :: ST Unit 65 | (:+:) :: ST a -> ST b -> ST (a + b) 66 | (:*:) :: ST a -> ST b -> ST (a * b) 67 | (:-<) :: ST a -> ST b -> ST (a -< b) 68 | SU64 :: ST U64 69 | 70 | eqT :: ST a -> ST b -> Maybe (a :~: b) 71 | eqT l r = case (l, r) of 72 | (SU64, SU64) -> Just Refl 73 | (SB, SB) -> Just Refl 74 | (SVoid, SVoid) -> Just Refl 75 | (SUnit, SUnit) -> Just Refl 76 | (x :*: y, x' :*: y') -> do 77 | Refl <- eqT x x' 78 | Refl <- eqT y y' 79 | return Refl 80 | (x :+: y, x' :+: y') -> do 81 | Refl <- eqT x x' 82 | Refl <- eqT y y' 83 | return Refl 84 | (x :-< y, x' :-< y') -> do 85 | Refl <- eqT x x' 86 | Refl <- eqT y y' 87 | return Refl 88 | _ -> Nothing 89 | 90 | instance Show (ST a) where 91 | show expr = case expr of 92 | SU64 -> "u64" 93 | SB -> "b" 94 | SVoid -> "void" 95 | SUnit -> "unit" 96 | x :+: y -> "(" ++ show x ++ " + " ++ show y ++ ")" 97 | x :*: y -> "(" ++ show x ++ " * " ++ show y ++ ")" 98 | x :-< y -> "(" ++ show x ++ " - " ++ show y ++ ")" 99 | 100 | inferT :: Typeable a => ST a 101 | inferT = fromTypeRep typeRep 102 | 103 | fromTypeRep :: TypeRep a -> ST a 104 | fromTypeRep expr = 105 | head $ 106 | catMaybes $ 107 | [ do 108 | HRefl <- eqTypeRep expr (typeRep @U64) 109 | pure SU64, 110 | do 111 | HRefl <- eqTypeRep expr (typeRep @B) 112 | pure SB, 113 | do 114 | HRefl <- eqTypeRep expr (typeRep @Unit) 115 | pure SUnit, 116 | do 117 | HRefl <- eqTypeRep expr (typeRep @Void) 118 | pure SVoid, 119 | case expr of 120 | App (App f x) y -> do 121 | HRefl <- eqTypeRep (typeRep @'Sum) f 122 | pure (fromTypeRep x :+: fromTypeRep y) 123 | _ -> Nothing, 124 | case expr of 125 | App (App f x) y -> do 126 | HRefl <- eqTypeRep (typeRep @'Prod) f 127 | pure (fromTypeRep x :*: fromTypeRep y) 128 | _ -> Nothing, 129 | case expr of 130 | App (App f x) y -> do 131 | HRefl <- eqTypeRep (typeRep @'Coexp) f 132 | pure (fromTypeRep x :-< fromTypeRep y) 133 | _ -> Nothing 134 | ] 135 | -------------------------------------------------------------------------------- /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 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-16.10 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 532383 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/10.yaml 11 | sha256: 469d781ab6d2a4eceed6b31b6e4ec842dcd3cd1d11577972e86902603dce24df 12 | original: lts-16.10 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------