├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── abt.cabal ├── src └── Abt │ ├── Class.hs │ ├── Class │ ├── Abt.hs │ ├── HEq1.hs │ ├── Monad.hs │ └── Show1.hs │ ├── Concrete │ └── LocallyNameless.hs │ ├── Tutorial.hs │ ├── Types.hs │ └── Types │ ├── Nat.hs │ └── View.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | *.aux 5 | *.log 6 | *.toc 7 | *~ 8 | .stack-work 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | ghc: 8.0.2 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ### v0.1.1.1 2 | 3 | - Added storing names of bound variables. 4 | 5 | 6 | ### v0.1.1.0 7 | 8 | - Added `Typeable` instances for the main types. 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Jonathan Sterling 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 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /abt.cabal: -------------------------------------------------------------------------------- 1 | name: abt 2 | version: 0.1.1.1 3 | synopsis: Abstract binding trees for Haskell 4 | description: A Haskell port of the Carnegie Mellon ABT library (SML), with some improvements. 5 | license: MIT 6 | license-file: LICENSE 7 | author: Jonathan Sterling 8 | maintainer: jon@jonmsterling.com 9 | category: Language 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | extra-source-files: CHANGELOG.md 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/jonsterling/hs-abt.git 17 | 18 | library 19 | exposed-modules: Abt.Class, 20 | Abt.Class.Show1, 21 | Abt.Class.HEq1, 22 | Abt.Class.Monad, 23 | Abt.Class.Abt, 24 | Abt.Types, 25 | Abt.Types.Nat, 26 | Abt.Types.View, 27 | Abt.Concrete.LocallyNameless 28 | Abt.Tutorial 29 | build-depends: base >=4.7 && <4.10, 30 | vinyl >=0.5, 31 | profunctors >=4.3.2, 32 | transformers >=0.2, 33 | transformers-compat >=0.3 34 | ghc-options: -Wall 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | -------------------------------------------------------------------------------- /src/Abt/Class.hs: -------------------------------------------------------------------------------- 1 | -- | The core signatures used to define abstract binding trees. 2 | -- 3 | module Abt.Class 4 | ( module Abt.Class.Abt 5 | , module Abt.Class.Monad 6 | , module Abt.Class.Show1 7 | , module Abt.Class.HEq1 8 | ) where 9 | 10 | import Abt.Class.Abt 11 | import Abt.Class.Monad 12 | import Abt.Class.Show1 13 | import Abt.Class.HEq1 -------------------------------------------------------------------------------- /src/Abt/Class/Abt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | module Abt.Class.Abt 8 | ( Abt(..) 9 | ) where 10 | 11 | import Abt.Types.Nat 12 | import Abt.Types.View 13 | import Abt.Class.Monad 14 | import Abt.Class.Show1 15 | 16 | import Data.Vinyl 17 | import Data.Vinyl.Functor 18 | import qualified Data.List as L 19 | 20 | -- | The 'Abt' signature represents mediation between an arbitrary (possibly 21 | -- nameless) term representaion, and a simple one (the 'View'). Based on 22 | -- the (effectful) ismorphism @'into' / 'out'@ between representations, many 23 | -- operations can be defined generically for arbitrary operator sets, including 24 | -- substitution and aggregation of free variables. 25 | -- 26 | class (Show1 o, Show v) => Abt (v :: *) (o :: [Nat] -> *) (t :: Nat -> *) | t -> v o where 27 | -- | Convert a 'View' into a term. 28 | -- 29 | into 30 | :: View v o n t 31 | -> t n 32 | 33 | -- | Convert a term into a simple 'View'. 34 | -- 35 | out 36 | :: MonadVar v m 37 | => t n 38 | -> m (View v o n t) 39 | 40 | -- | The injection from variables to terms. 41 | -- 42 | var 43 | :: v 44 | -> t 'Z 45 | var = into . V 46 | 47 | -- | Construct an abstraction. 48 | -- 49 | (\\) 50 | :: v 51 | -> t n 52 | -> t ('S n) 53 | v \\ e = into $ v :\ e 54 | 55 | -- | Construct an operator term. 56 | -- 57 | ($$) 58 | :: o ns 59 | -> Rec t ns 60 | -> t 'Z 61 | o $$ es = into $ o :$ es 62 | infixl 1 $$ 63 | 64 | -- | Substitute a term for a variable. 65 | -- 66 | subst 67 | :: MonadVar v m 68 | => t 'Z 69 | -> v 70 | -> t n 71 | -> m (t n) 72 | subst e v e' = do 73 | oe' <- out e' 74 | case oe' of 75 | V v' -> return $ if v == v' then e else e' 76 | v' :\ e'' -> (v' \\) <$> subst e v e'' 77 | o :$ es -> (o $$) <$> subst e v `rtraverse` es 78 | 79 | -- | Instantiate the bound variable of an abstraction. 80 | -- 81 | (//) 82 | :: MonadVar v m 83 | => t ('S n) 84 | -> t 'Z 85 | -> m (t n) 86 | xe // e' = do 87 | v :\ e <- out xe 88 | subst e' v e 89 | 90 | -- | Compute the free variables of a term. 91 | -- 92 | freeVars 93 | :: MonadVar v m 94 | => t n 95 | -> m [v] 96 | freeVars e = do 97 | oe <- out e 98 | case oe of 99 | V v -> return [v] 100 | v :\ e' -> 101 | L.delete v <$> 102 | freeVars e' 103 | _ :$ es -> 104 | fmap concat . sequence . recordToList $ 105 | Const . freeVars <<$>> es 106 | 107 | -- | Render a term into a human-readable string. 108 | -- 109 | toString 110 | :: MonadVar v m 111 | => t n 112 | -> m String 113 | toString e = do 114 | vu <- out e 115 | case vu of 116 | V v -> return $ show v 117 | v :\ e' -> do 118 | estr <- toString e' 119 | return $ show v ++ "." ++ estr 120 | o :$ RNil -> return $ show1 o 121 | o :$ es -> do 122 | es' <- sequence . recordToList $ Const . toString <<$>> es 123 | return $ show1 o ++ "[" ++ L.intercalate ";" es' ++ "]" 124 | 125 | -------------------------------------------------------------------------------- /src/Abt/Class/HEq1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Abt.Class.HEq1 where 6 | 7 | import Data.Vinyl 8 | 9 | -- | Essentially, Martin-Löf's identity type. 10 | -- 11 | data a :=: b where 12 | Refl :: a :=: a 13 | 14 | -- | Type constructors are extensional. 15 | -- 16 | cong :: a :=: b -> f a :=: f b 17 | cong Refl = Refl 18 | 19 | -- | Uniform variant of 'Eq' for indexed types. This is different from 20 | -- 'Data.Functor.Eq1' in that it is properly kind polymorphic and crucially 21 | -- heterogeneous, and it places no constraint on the index. Because it is 22 | -- heterogeneous, it is useful to project equality in the base space from 23 | -- equality in the total space. 24 | -- 25 | class HEq1 f where 26 | -- | When both sides are equal, give in addition a proof that their indices 27 | -- are equal; otherwise return 'Nothing'. 28 | -- 29 | heq1 :: f i -> f j -> Maybe (i :=: j) 30 | 31 | -- | A boolean version of 'heq1', which must agree with it. 32 | -- 33 | (===) :: f i -> f j -> Bool 34 | x === y = maybe False (const True) $ heq1 x y 35 | 36 | instance HEq1 el => HEq1 (Rec el) where 37 | heq1 RNil RNil = Just Refl 38 | heq1 (x :& xs) (y :& ys) 39 | | Just Refl <- heq1 x y = cong <$> heq1 xs ys 40 | heq1 _ _ = Nothing 41 | -------------------------------------------------------------------------------- /src/Abt/Class/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Abt.Class.Monad where 5 | 6 | class (Ord v, Eq v, Show v, Monad m, Applicative m) => MonadVar v m | m -> v where 7 | -- | Generates a fresh variable 8 | fresh :: m v 9 | 10 | -- | Generates a fresh variable tagged with a name 11 | named :: String -> m v 12 | 13 | -- | Clones a variable with a name 14 | clone :: v -> m v -------------------------------------------------------------------------------- /src/Abt/Class/Show1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | 3 | module Abt.Class.Show1 where 4 | 5 | -- | Uniform variant of 'Show' for indexed types. This is different from 6 | -- 'Data.Functor.Show1' in that it is properly kind polymorphic. 7 | -- 8 | class Show1 f where 9 | showsPrec1 :: Int -> f i -> ShowS 10 | showsPrec1 _ x = (show1 x ++) 11 | 12 | show1 :: f i -> String 13 | show1 x = showsPrec1 0 x "" 14 | 15 | -------------------------------------------------------------------------------- /src/Abt/Concrete/LocallyNameless.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | 10 | module Abt.Concrete.LocallyNameless 11 | ( Tm(..) 12 | , Tm0 13 | , _TmOp 14 | , Var(..) 15 | , varName 16 | , varIndex 17 | ) where 18 | 19 | import Abt.Types.Nat 20 | import Abt.Types.View 21 | import Abt.Class.HEq1 22 | import Abt.Class.Show1 23 | import Abt.Class.Abt 24 | import Abt.Class.Monad 25 | 26 | import Data.Profunctor 27 | import Data.Typeable hiding (Refl) 28 | import Data.Vinyl 29 | 30 | -- | A variable is a De Bruijn index, optionally decorated with a display name. 31 | data Var 32 | = Var 33 | { _varName :: !(Maybe String) 34 | , _varIndex :: !Int 35 | } deriving Typeable 36 | 37 | instance Show Var where 38 | show (Var (Just v) _) = v 39 | show (Var Nothing i) = "@" ++ show i 40 | 41 | instance Eq Var where 42 | (Var _ i) == (Var _ j) = i == j 43 | 44 | instance Ord Var where 45 | compare (Var _ i) (Var _ j) = compare i j 46 | 47 | -- | A lens for '_varName'. 48 | -- 49 | -- @ 50 | -- 'varName' :: Lens' 'Var' ('Maybe' 'String') 51 | -- @ 52 | -- 53 | varName 54 | :: Functor f 55 | => (Maybe String -> f (Maybe String)) 56 | -> Var 57 | -> f Var 58 | varName i (Var n j) = 59 | (\n' -> Var n' j) 60 | <$> i n 61 | 62 | -- | A lens for '_varIndex'. 63 | -- 64 | -- @ 65 | -- 'varIndex' :: Lens' 'Var' 'Int' 66 | -- @ 67 | -- 68 | varIndex 69 | :: Functor f 70 | => (Int -> f Int) 71 | -> Var 72 | -> f Var 73 | varIndex i (Var n j) = 74 | (\j' -> Var n j') 75 | <$> i j 76 | 77 | -- | Locally nameless terms with operators in @o@ at order @n@. 78 | -- 79 | data Tm (o :: [Nat] -> *) (n :: Nat) where 80 | Free :: Var -> Tm0 o 81 | Bound :: Int -> Tm0 o 82 | Abs :: Var -> Tm o n -> Tm o ('S n) 83 | App :: o ns -> Rec (Tm o) ns -> Tm0 o 84 | 85 | deriving instance Typeable Tm 86 | 87 | -- | First order terms (i.e. terms not headed by abstractions). 88 | -- 89 | type Tm0 o = Tm o 'Z 90 | 91 | instance HEq1 o => HEq1 (Tm o) where 92 | heq1 (Free v1) (Free v2) | v1 == v2 = Just Refl 93 | heq1 (Bound m) (Bound n) | m == n = Just Refl 94 | heq1 (Abs _ e1) (Abs _ e2) = cong <$> heq1 e1 e2 95 | heq1 (App o1 es1) (App o2 es2) 96 | | Just Refl <- heq1 o1 o2 97 | , Just Refl <- heq1 es1 es2 = Just Refl 98 | heq1 _ _ = Nothing 99 | 100 | shiftVar 101 | :: Var 102 | -> Int 103 | -> Tm o n 104 | -> Tm o n 105 | shiftVar v n = \case 106 | Free v' -> if v == v' then Bound n else Free v' 107 | Bound m -> Bound m 108 | Abs x e -> Abs x $ shiftVar v (n + 1) e 109 | App p es -> App p $ shiftVar v n <<$>> es 110 | 111 | addVar 112 | :: Var 113 | -> Int 114 | -> Tm o n 115 | -> Tm o n 116 | addVar v n = \case 117 | Free v' -> Free v' 118 | Bound m -> if m == n then Free v else Bound m 119 | Abs x e -> Abs x $ addVar v (n + 1) e 120 | App p es -> App p $ addVar v n <<$>> es 121 | 122 | instance Show1 o => Abt Var o (Tm o) where 123 | into = \case 124 | V v -> Free v 125 | v :\ e -> Abs v $ shiftVar v 0 e 126 | v :$ es -> App v es 127 | 128 | out = \case 129 | Free v -> return $ V v 130 | Bound _ -> fail "bound variable occured in out" 131 | Abs x e -> do 132 | x' <- clone x 133 | return $ x' :\ addVar x' 0 e 134 | App p es -> return $ p :$ es 135 | 136 | -- | A prism to extract arguments from a proposed operator. 137 | -- 138 | -- @ 139 | -- '_TmOp' :: 'HEq1' o => o ns -> Prism' ('Tm0' o) ('Rec' ('Tm0' o) ns) 140 | -- @ 141 | -- 142 | _TmOp 143 | :: ( Choice p 144 | , Applicative f 145 | , HEq1 o 146 | ) 147 | => o ns 148 | -> p (Rec (Tm o) ns) (f (Rec (Tm o) ns)) 149 | -> p (Tm0 o) (f (Tm0 o)) 150 | _TmOp o = dimap fro (either pure (fmap (App o))) . right' 151 | where 152 | fro = \case 153 | App o' es | Just Refl <- heq1 o o' -> Right es 154 | e -> Left e 155 | -------------------------------------------------------------------------------- /src/Abt/Tutorial.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | module Abt.Tutorial where 12 | 13 | import Abt.Class 14 | import Abt.Types 15 | import Abt.Concrete.LocallyNameless 16 | 17 | import Control.Applicative 18 | import Control.Monad.Trans.State.Strict 19 | import Control.Monad.Trans.Maybe 20 | import Control.Monad.Trans.Except 21 | import Data.Vinyl 22 | import Prelude hiding (pi) 23 | 24 | -- | We'll start off with a monad in which to manipulate ABTs; we'll need some 25 | -- state for fresh variable generation. 26 | -- 27 | newtype M a 28 | = M 29 | { _M :: State Int a 30 | } deriving (Functor, Applicative, Monad) 31 | 32 | -- | We'll run an ABT computation by starting the variable counter at @0@. 33 | -- 34 | runM :: M a -> a 35 | runM (M m) = evalState m 0 36 | 37 | -- | Check out the source to see fresh variable generation. 38 | -- 39 | instance MonadVar Var M where 40 | fresh = M $ do 41 | n <- get 42 | let n' = n + 1 43 | put n' 44 | return $ Var Nothing n' 45 | 46 | named a = do 47 | v <- fresh 48 | return $ v { _varName = Just a } 49 | 50 | clone v = 51 | case _varName v of 52 | Just s -> named s 53 | _ -> fresh 54 | 55 | -- | Next, we'll define the operators for a tiny lambda calculus as a datatype 56 | -- indexed by arities. 57 | -- 58 | data Lang ns where 59 | LAM :: Lang '[ 'S 'Z] 60 | APP :: Lang '[ 'Z, 'Z] 61 | PI :: Lang '[ 'Z, 'S 'Z] 62 | UNIT :: Lang '[] 63 | AX :: Lang '[] 64 | 65 | instance Show1 Lang where 66 | show1 = \case 67 | LAM -> "lam" 68 | APP -> "ap" 69 | PI -> "pi" 70 | UNIT -> "unit" 71 | AX -> "<>" 72 | 73 | instance HEq1 Lang where 74 | heq1 LAM LAM = Just Refl 75 | heq1 APP APP = Just Refl 76 | heq1 PI PI = Just Refl 77 | heq1 UNIT UNIT = Just Refl 78 | heq1 AX AX = Just Refl 79 | heq1 _ _ = Nothing 80 | 81 | lam :: Tm Lang ('S 'Z) -> Tm0 Lang 82 | lam e = LAM $$ e :& RNil 83 | 84 | app :: Tm0 Lang -> Tm0 Lang -> Tm0 Lang 85 | app m n = APP $$ m :& n :& RNil 86 | 87 | ax :: Tm0 Lang 88 | ax = AX $$ RNil 89 | 90 | unit :: Tm0 Lang 91 | unit = UNIT $$ RNil 92 | 93 | pi :: Tm0 Lang -> Tm Lang ('S 'Z) -> Tm0 Lang 94 | pi a xb = PI $$ a :& xb :& RNil 95 | 96 | -- | A monad transformer for small step operational semantics. 97 | -- 98 | newtype StepT m a 99 | = StepT 100 | { runStepT :: MaybeT m a 101 | } deriving (Monad, Functor, Applicative, Alternative) 102 | 103 | -- | To indicate that a term is in normal form. 104 | -- 105 | stepsExhausted 106 | :: Applicative m 107 | => StepT m a 108 | stepsExhausted = StepT . MaybeT $ pure Nothing 109 | 110 | instance MonadVar Var m => MonadVar Var (StepT m) where 111 | fresh = StepT . MaybeT $ Just <$> fresh 112 | named str = StepT . MaybeT $ Just <$> named str 113 | clone v = StepT . MaybeT $ Just <$> clone v 114 | 115 | -- | A single evaluation step. 116 | -- 117 | step 118 | :: Tm0 Lang 119 | -> StepT M (Tm0 Lang) 120 | step tm = 121 | out tm >>= \case 122 | APP :$ m :& n :& RNil -> 123 | out m >>= \case 124 | LAM :$ xe :& RNil -> xe // n 125 | _ -> app <$> step m <*> pure n <|> app <$> pure m <*> step n 126 | PI :$ a :& xb :& RNil -> pi <$> step a <*> pure xb 127 | _ -> stepsExhausted 128 | 129 | -- | The reflexive-transitive closure of a small-step operational semantics. 130 | -- 131 | star 132 | :: Monad m 133 | => (a -> StepT m a) 134 | -> (a -> m a) 135 | star f a = 136 | runMaybeT (runStepT $ f a) >>= 137 | return a `maybe` star f 138 | 139 | -- | Evaluate a term to normal form 140 | -- 141 | eval :: Tm0 Lang -> Tm0 Lang 142 | eval = runM . star step 143 | 144 | newtype JudgeT m a 145 | = JudgeT 146 | { runJudgeT :: ExceptT String m a 147 | } deriving (Monad, Functor, Applicative, Alternative) 148 | 149 | instance MonadVar Var m => MonadVar Var (JudgeT m) where 150 | fresh = JudgeT . ExceptT $ Right <$> fresh 151 | named str = JudgeT . ExceptT $ Right <$> named str 152 | clone v = JudgeT . ExceptT $ Right <$> clone v 153 | 154 | type Ctx = [(Var, Tm0 Lang)] 155 | 156 | raise :: Monad m => String -> JudgeT m a 157 | raise = JudgeT . ExceptT . return . Left 158 | 159 | checkTy 160 | :: Ctx 161 | -> Tm0 Lang 162 | -> Tm0 Lang 163 | -> JudgeT M () 164 | checkTy g tm ty = do 165 | let ntm = eval tm 166 | nty = eval ty 167 | (,) <$> out ntm <*> out nty >>= \case 168 | (LAM :$ xe :& RNil, PI :$ a :& yb :& RNil) -> do 169 | z <- fresh 170 | ez <- xe // var z 171 | bz <- yb // var z 172 | checkTy ((z,a):g) ez bz 173 | (AX :$ RNil, UNIT :$ RNil) -> return () 174 | _ -> do 175 | ty' <- inferTy g tm 176 | if ty' === nty 177 | then return () 178 | else raise "Type error" 179 | 180 | inferTy 181 | :: Ctx 182 | -> Tm0 Lang 183 | -> JudgeT M (Tm0 Lang) 184 | inferTy g tm = do 185 | out (eval tm) >>= \case 186 | V v | Just (eval -> ty) <- lookup v g -> return ty 187 | | otherwise -> raise "Ill-scoped variable" 188 | APP :$ m :& n :& RNil -> do 189 | inferTy g m >>= out >>= \case 190 | PI :$ a :& xb :& RNil -> do 191 | checkTy g n a 192 | eval <$> xb // n 193 | _ -> raise "Expected pi type for lambda abstraction" 194 | _ -> raise "Only infer neutral terms" 195 | 196 | -- | @λx.x@ 197 | -- 198 | identityTm :: M (Tm0 Lang) 199 | identityTm = do 200 | x <- named "x" 201 | return $ lam (x \\ var x) 202 | 203 | -- | @(λx.x)(λx.x)@ 204 | -- 205 | appTm :: M (Tm0 Lang) 206 | appTm = do 207 | tm <- identityTm 208 | return $ app tm tm 209 | 210 | -- | A demonstration of evaluating (and pretty-printing). Output: 211 | -- 212 | -- @ 213 | -- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] 214 | -- @ 215 | -- 216 | main :: IO () 217 | main = do 218 | -- Try out the type checker 219 | either fail print . runM . runExceptT . runJudgeT $ do 220 | x <- fresh 221 | checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) 222 | 223 | print . runM $ do 224 | im <- identityTm 225 | imStr <- toString im 226 | return imStr 227 | 228 | print . runM $ do 229 | mm <- appTm 230 | mmStr <- toString mm 231 | mmStr' <- toString $ eval mm 232 | return $ mmStr ++ " ~>* " ++ mmStr' 233 | 234 | -------------------------------------------------------------------------------- /src/Abt/Types.hs: -------------------------------------------------------------------------------- 1 | -- | The core structures used to define the Abt signatures. 2 | -- 3 | module Abt.Types 4 | ( module Abt.Types.Nat 5 | , module Abt.Types.View 6 | ) where 7 | 8 | import Abt.Types.Nat 9 | import Abt.Types.View -------------------------------------------------------------------------------- /src/Abt/Types/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | 5 | module Abt.Types.Nat where 6 | 7 | import Data.Typeable 8 | 9 | data Nat 10 | = Z 11 | | S !Nat 12 | deriving Typeable 13 | 14 | deriving instance Typeable Z 15 | deriving instance Typeable S 16 | 17 | -------------------------------------------------------------------------------- /src/Abt/Types/View.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | 9 | module Abt.Types.View 10 | ( View(..) 11 | , View0 12 | , _ViewOp 13 | , mapView 14 | ) where 15 | 16 | import Abt.Class.HEq1 17 | import Abt.Types.Nat 18 | 19 | import Data.Profunctor 20 | import Data.Typeable hiding (Refl) 21 | import Data.Vinyl 22 | 23 | -- | @v@ is the type of variables; @o@ is the type of operators parameterized 24 | -- by arities; @n@ is the "higher type"/valence of the term (i.e. a term has 25 | -- @n=0@, a single binding has @n=1@, etc.); @phi@ is the functor which 26 | -- interprets the inner structure of the view. 27 | -- 28 | data View (v :: *) (o :: [Nat] -> *) (n :: Nat) (phi :: Nat -> *) where 29 | V :: v -> View0 v o phi 30 | (:\) :: v -> phi n -> View v o ('S n) phi 31 | (:$) :: o ns -> Rec phi ns -> View0 v o phi 32 | 33 | deriving instance Typeable View 34 | 35 | infixl 2 :$ 36 | 37 | -- | First order term views. 38 | -- 39 | type View0 v o phi = View v o 'Z phi 40 | 41 | -- | Views are a (higher) functor. 42 | -- 43 | mapView 44 | :: (forall j . phi j -> psi j) -- ^ a natural transformation @phi -> psi@ 45 | -> View v o n phi -- ^ a view at @phi@ 46 | -> View v o n psi 47 | mapView η = \case 48 | V v -> V v 49 | v :\ e -> v :\ η e 50 | o :$ es -> o :$ η <<$>> es 51 | 52 | -- | A prism to extract arguments from a proposed operator. 53 | -- 54 | -- @ 55 | -- '_ViewOp' :: 'HEq1' o => o ns -> Prism' ('View0' v o phi) ('Rec' phi ns) 56 | -- @ 57 | -- 58 | _ViewOp 59 | :: ( Choice p 60 | , Applicative f 61 | , HEq1 o 62 | ) 63 | => o ns 64 | -> p (Rec phi ns) (f (Rec phi ns)) 65 | -> p (View0 v o phi) (f (View0 v o phi)) 66 | _ViewOp o = dimap fro (either pure (fmap (o :$))) . right' 67 | where 68 | fro = \case 69 | o' :$ es | Just Refl <- heq1 o o' -> Right es 70 | e -> Left e 71 | -------------------------------------------------------------------------------- /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 | # http://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 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.17 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 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: ">=1.4" 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 --------------------------------------------------------------------------------