├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cbpv.cabal ├── examples └── ex1.cbpv ├── exe └── Main.hs └── src ├── Compiler.hs ├── Parser.hs ├── Printer.hs ├── Semantics.hs ├── Syntax.hs └── Typecheck.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .ghc.* 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for cbpv 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Isaac Elliott 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 Isaac Elliott 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 | # cbpv 2 | 3 | A usable type system for call by push-value: 4 | 5 | * Kinds 6 | * The `*` kind is split in two: `Val` (values) and `Comp` (computations) 7 | * `U : Comp -> Val` 8 | * `F : Val -> Comp` 9 | * `(->) : Val -> Comp -> Comp` 10 | * etc. 11 | * Top-level definitions must be `Val`s 12 | * User-definable datatypes 13 | * Currently require kind annotations (but this is simple to remove) 14 | * Inductive datatypes inhabit the `Val` kind 15 | * Only carries around other values 16 | * Constructors are not functions (functions only return computations), 17 | so constructors must be fully applied 18 | * Generalised elimination using `case ... of` 19 | * Coinductive datatypes inhabit the `Comp` kind 20 | * Can only produce computations (unsure) 21 | * Destructors are not functions 22 | * Generalised introduction using `cocase ... of` 23 | 24 | * Syntax 25 | * `#` (thunk) takes a `a : Comp` and produces a `U a : Val` 26 | * `^` (force) takes a `U a : Val` and produces a `a : Comp` 27 | 28 | ## Examples 29 | 30 | (actual syntax) (braces are how I ignore layout rules) 31 | 32 | ``` 33 | data Sum (a : Val) (b : Val) = Left[a] | Right[b] 34 | 35 | sumElim = { 36 | # 37 | \@(a : Val) -> 38 | \@(b : Val) -> 39 | \@(r : Comp) -> 40 | \(f : U (a -> r)) -> 41 | \(g : U (b -> r)) -> 42 | \(x : Sum a b) -> 43 | case x of { 44 | Left[a] -> ^f a; 45 | Right[a] -> ^g a 46 | } 47 | } 48 | 49 | data Tensor (a : Val) (b : Val) = Tensor[a, b] 50 | 51 | tensorElim = { 52 | # 53 | \@(a : Val) -> 54 | \@(b : Val) -> 55 | \@(r : Comp) -> 56 | \(f : U (a -> b -> r)) -> 57 | \(x : Tensor a b) -> 58 | case x of { Tensor[a, b] -> ^f a b } 59 | } 60 | 61 | data Nat = Z[] | S[Nat] 62 | 63 | data List (a : Val) = Nil[] | Cons[a, List a] 64 | 65 | codata Pair (a : Comp) (b : Comp) where { 66 | fst : a; 67 | snd : b 68 | } 69 | 70 | codata Stream (a : Comp) where { 71 | head : a; 72 | tail : Stream a 73 | } 74 | 75 | takeS = { 76 | # 77 | \@(a : Comp) -> 78 | fix self : U (forall (a : Comp). Nat -> U (Stream a) -> F (List (U a))) in 79 | \(n : Nat) -> 80 | \(s : U (Stream a)) -> 81 | case n of { 82 | Z -> return[Nil[]]; 83 | S[k] -> 84 | bind 85 | rest = self k (# ^s.tail) 86 | in 87 | return[ Cons[ # ^s.head ], rest ] ] 88 | } 89 | } 90 | 91 | codata Infinity where { next : Infinity } 92 | 93 | infinity = # fix self : U Infinity in cocase Infinity of { next -> ^self } 94 | 95 | countFrom = { 96 | # 97 | fix self : U (Nat -> Stream (F Nat))) in 98 | \(n : Nat) -> 99 | cocase Stream (F Nat) of { 100 | head -> return[n]; 101 | tail -> ^self S[n] 102 | } 103 | } 104 | ``` 105 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cbpv.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | -- Initial package description 'cbpv.cabal' generated by 'cabal init'. For 3 | -- further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: cbpv 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | author: Isaac Elliott 13 | maintainer: isaace71295@gmail.com 14 | -- copyright: 15 | category: Language 16 | extra-source-files: CHANGELOG.md 17 | 18 | library 19 | exposed-modules: Syntax, Semantics, Typecheck, Printer, Parser, Compiler 20 | build-depends: base ^>=4.12.0.0 21 | , attoparsec 22 | , ansi-wl-pprint ^>=0.6 23 | , bytestring ^>=0.10 24 | , containers ^>=0.6 25 | , lens 26 | , mtl ^>=2.2 27 | , parsers ^>=0.12 28 | , semigroupoids 29 | , text ^>=1.2 30 | , trifecta ^>=2 31 | hs-source-dirs: src 32 | ghc-options: -Wall -Werror 33 | default-language: Haskell2010 34 | 35 | executable cbpv 36 | main-is: Main.hs 37 | build-depends: base ^>=4.12.0.0 38 | , cbpv 39 | ghc-options: -Wall -Werror 40 | hs-source-dirs: exe 41 | default-language: Haskell2010 -------------------------------------------------------------------------------- /examples/ex1.cbpv: -------------------------------------------------------------------------------- 1 | data Sum (a : Val) (b : Val) = Left[a] | Right[b] 2 | 3 | sumElim = { 4 | # 5 | \@(a : Val) -> 6 | \@(b : Val) -> 7 | \@(r : Comp) -> 8 | \(f : U (a -> r)) -> 9 | \(g : U (b -> r)) -> 10 | \(x : Sum a b) -> 11 | case x of { 12 | Left[a] -> ^f a; 13 | Right[a] -> ^g a 14 | } 15 | } 16 | 17 | data Tensor (a : Val) (b : Val) = Tensor[a, b] 18 | 19 | tensorElim = { 20 | # 21 | \@(a : Val) -> 22 | \@(b : Val) -> 23 | \@(r : Comp) -> 24 | \(f : U (a -> b -> r)) -> 25 | \(x : Tensor a b) -> 26 | case x of { Tensor[a, b] -> ^f a b } 27 | } 28 | 29 | data Nat = Z[] | S[Nat] 30 | 31 | data List (a : Val) = Nil[] | Cons[a, List a] 32 | 33 | codata Pair (a : Comp) (b : Comp) where { 34 | fst[] : a; 35 | snd[] : b 36 | } 37 | 38 | codata Stream (a : Comp) where { 39 | head[] : a; 40 | tail[] : Stream a 41 | } 42 | 43 | takeS = { 44 | # 45 | fix self : U (forall (a : Comp). Nat -> U (Stream a) -> F (List (U a))) in 46 | \@(a : Comp) -> 47 | \(n : Nat) -> 48 | \(s : U (Stream a)) -> 49 | case n of { 50 | Z[] -> return[Nil[] : List (U a)]; 51 | S[k] -> 52 | bind 53 | rest = ^self @a k (# ^s.tail[]) 54 | in 55 | return[ Cons[ thunk[ ^s.head[] ], rest ] : List (U a) ] 56 | } 57 | } 58 | 59 | codata AlephNull where { next[] : AlephNull } 60 | 61 | infinity = # fix self : U AlephNull in cocase AlephNull of { next[] -> ^self } 62 | 63 | countFrom = { 64 | # 65 | fix self : U (Nat -> Stream (F Nat)) in 66 | \(n : Nat) -> 67 | cocase Stream (F Nat) of { 68 | head[] -> return[n]; 69 | tail[] -> ^self S[n] 70 | } 71 | } -------------------------------------------------------------------------------- /exe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Compiler (run) 4 | 5 | main :: IO () 6 | main = run 7 | -------------------------------------------------------------------------------- /src/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Compiler where 2 | 3 | import System.Exit (exitFailure) 4 | import System.Environment (getArgs) 5 | import Text.Trifecta.Result (Result(..), _errDoc) 6 | 7 | import qualified Data.ByteString as ByteString 8 | 9 | import Parser 10 | import Typecheck 11 | 12 | run :: IO () 13 | run = do 14 | file:_ <- getArgs 15 | src <- ByteString.readFile file 16 | parseRes <- handleParseError $ parse file module_ src 17 | _ <- handleTypecheckError $ tc (checkModule parseRes) emptyTCEnv 18 | print parseRes 19 | where 20 | handleParseError :: Result a -> IO a 21 | handleParseError (Failure e) = do 22 | putStrLn $ "Parse error: \n" <> show (_errDoc e) 23 | exitFailure 24 | handleParseError (Success a) = pure a 25 | 26 | handleTypecheckError :: Either TCError a -> IO a 27 | handleTypecheckError (Left e) = do 28 | putStrLn $ "Typecheck error: " <> show (prettyTCError e) 29 | exitFailure 30 | handleTypecheckError (Right a) = pure a 31 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# language DataKinds #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language FlexibleInstances, MultiParamTypeClasses #-} 4 | {-# language GeneralizedNewtypeDeriving #-} 5 | {-# language LambdaCase #-} 6 | {-# language OverloadedLists #-} 7 | {-# language OverloadedStrings #-} 8 | {-# language RankNTypes #-} 9 | {-# language TypeFamilies #-} 10 | module Parser where 11 | 12 | import Control.Applicative (Alternative, (<|>), many, some, optional) 13 | import Control.Lens.Setter (over, mapped) 14 | import Data.ByteString (ByteString) 15 | import Data.Char (isSpace) 16 | import Data.List.NonEmpty (NonEmpty(..)) 17 | import Data.String (fromString) 18 | import Data.Text (Text) 19 | import Text.Parser.Combinators (Parsing, (), eof, sepBy, sepBy1, skipMany) 20 | import Text.Parser.Char (CharParsing, alphaNum, lower, upper, newline, satisfy) 21 | import Text.Parser.Token (TokenParsing, IdentifierStyle(..), Unlined(..)) 22 | import Text.Trifecta.Delta (Delta(..)) 23 | import Text.Trifecta.Parser (runParser) 24 | import Text.Trifecta.Result (Result) 25 | 26 | import qualified Text.Parser.Token as Token 27 | import qualified Text.Parser.Token.Highlight as Highlight 28 | 29 | import Syntax 30 | 31 | newtype Nesting m a = Nesting { runNesting :: m a } 32 | deriving (Parsing, CharParsing, Functor, Applicative, Alternative, Monad) 33 | 34 | instance TokenParsing m => TokenParsing (Nesting m) where 35 | someSpace = Nesting $ skipMany (satisfy isSpace) 36 | 37 | identStyle :: CharParsing m => IdentifierStyle m 38 | identStyle = 39 | IdentifierStyle 40 | { _styleName = "identifier" 41 | , _styleStart = lower 42 | , _styleLetter = alphaNum 43 | , _styleReserved = 44 | [ "force" 45 | , "return" 46 | , "thunk" 47 | , "let" 48 | , "fix" 49 | , "bind" 50 | , "in" 51 | , "forall" 52 | , "case" 53 | , "cocase" 54 | , "of" 55 | , "data" 56 | , "codata" 57 | , "where" 58 | ] 59 | , _styleHighlight = Highlight.Identifier 60 | , _styleReservedHighlight = Highlight.ReservedIdentifier 61 | } 62 | 63 | ctorStyle :: CharParsing m => IdentifierStyle m 64 | ctorStyle = 65 | IdentifierStyle 66 | { _styleName = "constructor" 67 | , _styleStart = upper 68 | , _styleLetter = alphaNum 69 | , _styleReserved = ["Val", "Comp"] 70 | , _styleHighlight = Highlight.Constructor 71 | , _styleReservedHighlight = Highlight.ReservedConstructor 72 | } 73 | 74 | ctor :: (Monad m, TokenParsing m) => m Text 75 | ctor = Token.ident ctorStyle 76 | 77 | ident :: (Monad m, TokenParsing m) => m Text 78 | ident = Token.ident identStyle 79 | 80 | keyword :: (Monad m, TokenParsing m) => Text -> m () 81 | keyword = Token.reserveText identStyle 82 | 83 | arrow :: TokenParsing m => m Text 84 | arrow = Token.textSymbol "->" 85 | 86 | val :: (Monad m, TokenParsing m) => m () 87 | val = Token.reserveText ctorStyle "Val" 88 | 89 | comp :: (Monad m, TokenParsing m) => m () 90 | comp = Token.reserveText ctorStyle "Comp" 91 | 92 | kind :: (Monad m, TokenParsing m) => m Kind 93 | kind = foldr KArr <$> atom <*> many (arrow *> atom) 94 | where 95 | atom = 96 | KVal <$ val <|> 97 | KComp <$ comp <|> 98 | Token.parens kind 99 | 100 | tyAtom :: (Monad m, TokenParsing m) => m Ty 101 | tyAtom = 102 | (\case; "U" -> U; "F" -> F; c -> TCtor c) <$> ctor <|> 103 | TName <$> ident <|> 104 | Token.parens (Arrow <$ arrow <|> ty) 105 | 106 | ty :: (Monad m, TokenParsing m) => m Ty 107 | ty = (fa <|> arr) "type" 108 | where 109 | fa = 110 | (\(a, b) -> TForall (Just a) b . abstractTy a) <$ keyword "forall" <*> 111 | Token.parens ((,) <$> ident <* Token.colon <*> kind) <* Token.dot <*> 112 | ty 113 | arr = (\a -> maybe a (TApp $ TApp Arrow a)) <$> app <*> optional (arrow *> arr) 114 | app = foldl TApp <$> tyAtom <*> many tyAtom 115 | 116 | pattern_ :: (Monad m, TokenParsing m) => m (Pattern, [Text]) 117 | pattern_ = 118 | (PWild, []) <$ Token.symbolic '_' <|> 119 | (\a -> (PVar $ Just a, [a])) <$> ident <|> 120 | (\a bs -> (PCtor a (length bs) (Just <$> bs), bs)) <$> 121 | ctor <*> 122 | Token.brackets (ident `sepBy` Token.comma) 123 | 124 | branch :: (Monad m, TokenParsing m) => m (Exp a) -> m (Branch a) 125 | branch ex = 126 | (\(p, vs) e -> Branch p $ foldr abstract e vs) <$> 127 | pattern_ <* arrow <*> 128 | ex 129 | 130 | cobranch :: (Monad m, TokenParsing m) => m CoBranch 131 | cobranch = 132 | (\n as e -> 133 | let (ns, ts) = unzip as in 134 | CoBranch n (length as) ts ns $ foldr abstract e ns) <$> 135 | ident <*> 136 | Token.brackets 137 | (sepBy ((,) <$> ident <* Token.colon <*> ty) Token.comma) <* arrow <*> 138 | computation 139 | 140 | braces :: TokenParsing m => Nesting m a -> m a 141 | braces m = runNesting (Token.symbolic '{' *> m) <* Token.symbolic '}' 142 | 143 | mkCase :: 144 | (Monad m, TokenParsing m) => 145 | (forall n. (Monad n, TokenParsing n) => n (Exp a)) -> 146 | m (Exp a) 147 | mkCase ex = 148 | Case <$ keyword "case" <*> 149 | value <* keyword "of" <*> 150 | braces ((:|) <$> branch ex <*> many (Token.semi *> branch ex)) 151 | 152 | mkLet :: 153 | (Monad m, TokenParsing m) => 154 | m (Exp a) -> 155 | m (Exp a) 156 | mkLet exbody = 157 | (\a b -> Let (Just a) b . abstract a) <$ keyword "let" <*> 158 | ident <* Token.symbolic '=' <*> 159 | value <* keyword "in" <*> 160 | exbody 161 | 162 | mkAnn :: 163 | (Monad m, TokenParsing m) => 164 | m (Exp a) -> 165 | m (Exp a) 166 | mkAnn ex = 167 | (\a -> maybe a (Ann a)) <$> ex <*> optional (Token.colon *> ty) 168 | 169 | computation :: (Monad m, TokenParsing m) => m (Exp 'C) 170 | computation = 171 | (lam "lambda") <|> 172 | ann <|> 173 | (case_ "case expression") <|> 174 | (cocase "cocase expression") <|> 175 | (let_ "let expression") <|> 176 | (fix "fixed point expression") <|> 177 | (bind "bind expression") 178 | "computation" 179 | where 180 | lam = 181 | either 182 | (\(a, b) -> Abs (Just a) b . abstract a) 183 | (\(a, b) -> AbsTy (Just a) b . abstractTyExp a) <$ Token.symbolic '\\' <*> 184 | (Left <$> Token.parens ((,) <$> ident <* Token.colon <*> ty) <|> 185 | Right <$ Token.symbolic '@' <*> 186 | Token.parens ((,) <$> ident <* Token.colon <*> kind)) <* arrow <*> 187 | computation 188 | 189 | let_ = mkLet computation 190 | 191 | bind = 192 | (\a b -> Bind (Just a) b . abstract a) <$ keyword "bind" <*> 193 | ident <* Token.symbolic '=' <*> 194 | computation <* keyword "in" <*> 195 | computation 196 | 197 | fix = 198 | (\n t -> Fix (Just n) t . abstract n) <$ keyword "fix" <*> 199 | ident <* Token.colon <*> 200 | ty <* keyword "in" <*> 201 | computation 202 | 203 | case_ = mkCase computation 204 | 205 | cocase = 206 | CoCase <$ keyword "cocase" <*> 207 | ty <* keyword "of" <*> 208 | braces ((:|) <$> cobranch <*> many (Token.semi *> cobranch)) 209 | 210 | ann = mkAnn app 211 | 212 | app = 213 | foldl (\b -> either (App b) (AppTy b)) <$> 214 | dtor <*> 215 | many (Left <$> value <|> Right <$ Token.symbolic '@' <*> tyAtom) 216 | 217 | dtor = 218 | foldl (\a (b, c) -> Dtor b c a) <$> 219 | atom <*> 220 | many ((,) <$ Token.dot <*> ident <*> Token.brackets (sepBy value Token.comma)) 221 | 222 | atom = 223 | Return <$ keyword "return" <*> Token.brackets value <|> 224 | Force <$ keyword "force" <*> Token.brackets value <|> 225 | Force <$ Token.symbolic '^' <*> value <|> 226 | Token.parens computation 227 | 228 | value :: (Monad m, TokenParsing m) => m (Exp 'V) 229 | value = 230 | (Thunk <$ Token.symbolic '#' <*> computation <|> 231 | case_ <|> 232 | let_ <|> 233 | ann <|> 234 | absTy) "value" 235 | where 236 | ann = mkAnn atom 237 | absTy = 238 | (\(a, b) -> AbsTy (Just a) b . abstractTyExp a) <$ Token.symbolic '\\' <* Token.symbolic '@' <*> 239 | Token.parens ((,) <$> ident <* Token.colon <*> kind) <* arrow <*> 240 | value 241 | let_ = mkLet value 242 | case_ = mkCase value 243 | atom = 244 | Thunk <$ keyword "thunk" <*> Token.brackets computation <|> 245 | Name <$> ident <|> 246 | Ctor <$> ctor <*> Token.brackets (sepBy value Token.comma) <|> 247 | Token.parens value 248 | 249 | indDecl :: (Monad m, TokenParsing m) => m IndDecl 250 | indDecl = 251 | (\n ps mctors -> 252 | let (pns, ks) = unzip ps in 253 | IndDecl n pns (foldr KArr KVal ks) $ 254 | maybe [] (over (mapped.indCtorArgs.mapped) (abstractTys pns)) mctors) <$ keyword "data" <*> 255 | ctor <*> 256 | many (Token.parens $ (,) <$> ident <* Token.colon <*> kind) <*> 257 | optional (Token.symbolic '=' *> sepBy1 ctorDecl (Token.symbolic '|')) 258 | where 259 | ctorDecl = 260 | (\n ps -> IndCtor n (length ps) ps) <$> 261 | ctor <*> 262 | Token.brackets (sepBy ty Token.comma) 263 | 264 | coIndDecl :: (Monad m, TokenParsing m) => m CoIndDecl 265 | coIndDecl = 266 | (\n ps mdtors -> 267 | let (pns, ks) = unzip ps in 268 | CoIndDecl n pns (foldr KArr KComp ks) $ 269 | maybe [] (over (mapped.coIndDtorType) (abstractTys pns)) mdtors) <$ keyword "codata" <*> 270 | ctor <*> 271 | many (Token.parens $ (,) <$> ident <* Token.colon <*> kind) <*> 272 | optional 273 | (keyword "where" *> braces (sepBy1 dtorDecl Token.semi)) 274 | where 275 | dtorDecl = 276 | (\n as -> CoIndDtor n (length as) as) <$> 277 | ident <*> 278 | Token.brackets (sepBy ty Token.comma) <* Token.colon <*> 279 | ty 280 | 281 | decl :: (Monad m, TokenParsing m) => m Decl 282 | decl = 283 | Decl <$> 284 | ident <* Token.symbolic '=' <*> 285 | (runNesting (Token.symbolic '{' *> value) <* Token.symbolic '}' <|> 286 | value) 287 | 288 | module_ :: (Monad m, TokenParsing m) => m Module 289 | module_ = 290 | runUnlined $ 291 | foldr (either (either MDecl MIndDecl) MCoIndDecl) MEmpty <$> 292 | sepBy 293 | (Left . Left <$> decl <|> 294 | Left . Right <$> indDecl <|> 295 | Right <$> coIndDecl) 296 | (some $ newline <|> Token.whiteSpace *> newline) 297 | 298 | parse :: 299 | String -> 300 | (forall m. (Monad m, TokenParsing m) => m a) -> 301 | ByteString -> Result a 302 | parse s m = runParser (m <* eof) (Directed (fromString s) 0 0 0 0) 303 | -------------------------------------------------------------------------------- /src/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | {-# language LambdaCase #-} 3 | module Printer where 4 | 5 | import Data.Foldable (fold) 6 | import Data.List (intersperse) 7 | import Data.Maybe (fromMaybe) 8 | import Text.PrettyPrint.ANSI.Leijen (Doc) 9 | import qualified Text.PrettyPrint.ANSI.Leijen as Pretty 10 | 11 | import qualified Data.List.NonEmpty as NonEmpty 12 | import qualified Data.Text as Text 13 | 14 | import Syntax 15 | 16 | prettyPat :: Pattern -> Doc 17 | prettyPat PWild = Pretty.char '_' 18 | prettyPat (PVar n) = 19 | Pretty.text $ maybe "" Text.unpack n 20 | prettyPat p@(PCtor n _ _) = 21 | Pretty.text (Text.unpack n) <> 22 | Pretty.brackets 23 | (fold . intersperse (Pretty.text ", ") $ 24 | Pretty.text . Text.unpack <$> patNames p) 25 | 26 | prettyExp :: (Int -> Maybe Doc) -> (Int -> Maybe Doc) -> Exp a -> Doc 27 | prettyExp names tyNames tm = 28 | case tm of 29 | AbsTy name k a -> 30 | let m_ndoc = Pretty.text . Text.unpack <$> name in 31 | Pretty.text "\\@" <> 32 | Pretty.parens (foldMap (<> Pretty.space) m_ndoc <> Pretty.text ": " <> prettyKind k) <> 33 | Pretty.text " -> " <> 34 | prettyExp names (\case; 0 -> m_ndoc; n -> tyNames (n-1)) a 35 | AppTy a t -> 36 | (case a of 37 | Abs{} -> Pretty.parens 38 | Let{} -> Pretty.parens 39 | Bind{} -> Pretty.parens 40 | Case{} -> Pretty.parens 41 | CoCase{} -> Pretty.parens 42 | _ -> id) 43 | (prettyExp names tyNames a) <> 44 | Pretty.text " @" <> 45 | (case t of 46 | TApp{} -> Pretty.parens 47 | _ -> id) 48 | (prettyTy tyNames t) 49 | Name a -> Pretty.text $ Text.unpack a 50 | Ann a b -> 51 | (case a of 52 | Abs{} -> Pretty.parens 53 | Case{} -> Pretty.parens 54 | CoCase{} -> Pretty.parens 55 | Let{} -> Pretty.parens 56 | Bind{} -> Pretty.parens 57 | _ -> id) 58 | (prettyExp names tyNames a) <> 59 | Pretty.text " : " <> 60 | prettyTy tyNames b 61 | Var a -> 62 | fromMaybe (Pretty.char '#' <> Pretty.int a) $ names a 63 | Thunk a -> 64 | Pretty.text "thunk" <> 65 | Pretty.brackets (prettyExp names tyNames a) 66 | Ctor a bs -> 67 | Pretty.text (Text.unpack a) <> 68 | Pretty.brackets 69 | (fold . intersperse (Pretty.text ", ") $ prettyExp names tyNames <$> bs) 70 | Return a -> 71 | Pretty.text "return" <> 72 | Pretty.brackets (prettyExp names tyNames a) 73 | Abs name a b -> 74 | let m_ndoc = Pretty.text . Text.unpack <$> name in 75 | Pretty.text "\\(" <> 76 | foldMap (<> Pretty.space) m_ndoc <> 77 | Pretty.text ": " <> 78 | prettyTy tyNames a <> 79 | Pretty.text ") -> " <> 80 | prettyExp (\case; 0 -> m_ndoc; n -> names (n-1)) tyNames b 81 | Bind name a b -> 82 | let m_ndoc = Pretty.text . Text.unpack <$> name in 83 | Pretty.text "bind" <> 84 | foldMap (\x -> Pretty.space <> x <> Pretty.space) m_ndoc <> 85 | Pretty.text "= " <> 86 | (case a of 87 | Let{} -> Pretty.parens 88 | Bind{} -> Pretty.parens 89 | _ -> id) 90 | (prettyExp names tyNames a) <> 91 | Pretty.text " in " <> 92 | prettyExp (\case; 0 -> m_ndoc; n -> names (n-1)) tyNames b 93 | Let name a b -> 94 | let m_ndoc = Pretty.text . Text.unpack <$> name in 95 | Pretty.text "let" <> 96 | foldMap (\x -> Pretty.space <> x <> Pretty.space) m_ndoc <> 97 | Pretty.text "= " <> 98 | prettyExp names tyNames a <> 99 | Pretty.text " in" Pretty.<$> 100 | prettyExp (\case; 0 -> m_ndoc; n -> names (n-1)) tyNames b 101 | Fix name t a -> 102 | let m_ndoc = Pretty.text . Text.unpack <$> name in 103 | Pretty.text "fix " <> 104 | fromMaybe (Pretty.text "") m_ndoc <> 105 | Pretty.text " : " <> prettyTy tyNames t <> 106 | Pretty.text " in " <> 107 | prettyExp (\case; 0 -> m_ndoc; n -> names (n-1)) tyNames a 108 | Force a -> 109 | Pretty.text "force" <> 110 | Pretty.brackets (prettyExp names tyNames a) 111 | Case a bs -> 112 | Pretty.text "case " <> 113 | prettyExp names tyNames a <> 114 | Pretty.text " of {" Pretty.<$> 115 | Pretty.indent 2 116 | (fold . intersperse (Pretty.char ';' <> Pretty.hardline) . 117 | NonEmpty.toList $ 118 | (\(Branch p e) -> 119 | let arity = patArity p in 120 | prettyPat p <> 121 | Pretty.text " -> " <> 122 | prettyExp 123 | (\n -> 124 | if n < arity 125 | then Just $ fmap (Pretty.text . Text.unpack) (patNames p) !! n 126 | else names (n-arity)) 127 | tyNames 128 | e) <$> bs) Pretty.<$> 129 | Pretty.char '}' 130 | Dtor a args b -> 131 | (case b of 132 | App{} -> Pretty.parens 133 | Abs{} -> Pretty.parens 134 | Let{} -> Pretty.parens 135 | Bind{} -> Pretty.parens 136 | Case{} -> Pretty.parens 137 | CoCase{} -> Pretty.parens 138 | _ -> id) 139 | (prettyExp names tyNames b) <> 140 | Pretty.dot <> 141 | Pretty.text (Text.unpack a) <> 142 | Pretty.brackets 143 | (fold . intersperse (Pretty.text ", ") $ 144 | prettyExp names tyNames <$> args) 145 | CoCase a bs -> 146 | Pretty.text "cocase " <> 147 | prettyTy tyNames a <> 148 | Pretty.text " of {" Pretty.<$> 149 | Pretty.indent 2 150 | (Pretty.vsep . NonEmpty.toList $ 151 | (\(CoBranch d arity tys names' e) -> 152 | Pretty.text (Text.unpack d) <> 153 | Pretty.brackets 154 | (fold . intersperse (Pretty.text ", ") $ 155 | (\(n, t) -> 156 | Pretty.hsep 157 | [ Pretty.text $ Text.unpack n 158 | , Pretty.char ':' 159 | , prettyTy names t 160 | ]) <$> 161 | zip names' tys) <> 162 | Pretty.text " -> " <> 163 | prettyExp 164 | (\n -> 165 | if n < arity 166 | then Just . Pretty.text . Text.unpack $ names' !! n 167 | else names (n-arity)) 168 | tyNames 169 | e) <$> 170 | bs) Pretty.<$> 171 | Pretty.char '}' 172 | App a b -> 173 | (case a of 174 | Abs{} -> Pretty.parens 175 | Let{} -> Pretty.parens 176 | Bind{} -> Pretty.parens 177 | Case{} -> Pretty.parens 178 | CoCase{} -> Pretty.parens 179 | _ -> id) 180 | (prettyExp names tyNames a) <> 181 | Pretty.space <> 182 | (case b of 183 | Let{} -> Pretty.parens 184 | Case{} -> Pretty.parens 185 | _ -> id) 186 | (prettyExp names tyNames b) 187 | 188 | prettyKind :: Kind -> Doc 189 | prettyKind k = 190 | case k of 191 | KArr a b -> 192 | (case a of 193 | KArr{} -> Pretty.parens 194 | _ -> id) 195 | (prettyKind a) <> 196 | Pretty.text " -> " <> 197 | prettyKind b 198 | KComp -> Pretty.text "Comp" 199 | KVal -> Pretty.text "Val" 200 | 201 | prettyTy :: (Int -> Maybe Doc) -> Ty -> Doc 202 | prettyTy names ty = 203 | case ty of 204 | TName a -> Pretty.text $ Text.unpack a 205 | TForall name k a -> 206 | let m_ndoc = Pretty.text . Text.unpack <$> name in 207 | Pretty.text "forall (" <> 208 | foldMap (<> Pretty.space) m_ndoc <> 209 | Pretty.text ": " <> 210 | prettyKind k <> 211 | Pretty.text "). " <> 212 | prettyTy (\case; 0 -> m_ndoc; n -> names (n-1)) a 213 | TApp (TApp Arrow a) b -> 214 | (case a of 215 | TApp (TApp Arrow _) _ -> Pretty.parens 216 | TForall{} -> Pretty.parens 217 | _ -> id) 218 | (prettyTy names a) <> 219 | Pretty.text " -> " <> 220 | prettyTy names b 221 | TApp a b -> 222 | (case a of 223 | TApp (TApp Arrow _) _ -> Pretty.parens 224 | TForall{} -> Pretty.parens 225 | _ -> id) 226 | (prettyTy names a) <> 227 | Pretty.space <> 228 | (case b of 229 | TApp{} -> Pretty.parens 230 | TForall{} -> Pretty.parens 231 | _ -> id) 232 | (prettyTy names b) 233 | U -> Pretty.char 'U' 234 | TCtor a -> Pretty.text $ Text.unpack a 235 | F -> Pretty.char 'F' 236 | Arrow -> Pretty.text "(->)" 237 | TVar a -> fromMaybe (Pretty.char '#' <> Pretty.int a) (names a) 238 | -------------------------------------------------------------------------------- /src/Semantics.hs: -------------------------------------------------------------------------------- 1 | {-# language DataKinds, GADTs #-} 2 | module Semantics where 3 | 4 | import Data.List.NonEmpty (NonEmpty(..)) 5 | import Data.Text (Text) 6 | 7 | import Syntax 8 | 9 | data Terminal 10 | = TReturn (Exp 'V) 11 | | TAbs (Exp 'C) 12 | | TAbsTy (Exp 'C) 13 | | TCoCase (NonEmpty CoBranch) 14 | deriving Show 15 | 16 | findBranch :: Text -> [Exp 'V] -> NonEmpty (Branch a) -> Exp a 17 | findBranch n args (b :| bs) = go (b : bs) 18 | where 19 | go [] = error "stuck: incomplete pattern match" 20 | go (Branch p e : xs) = 21 | case p of 22 | PWild -> e 23 | PVar _ -> inst e (Ctor n args) 24 | PCtor n' arity _ -> 25 | if n == n' 26 | then 27 | if arity == length args 28 | then subst (args !!) e 29 | else error "stuck: findBranch" 30 | else go xs 31 | 32 | findCoBranch :: Text -> [Exp 'V] -> NonEmpty CoBranch -> Exp 'C 33 | findCoBranch n args (b :| bs) = go (b:bs) 34 | where 35 | go [] = error "stuck: incomplete copattern match" 36 | go (CoBranch n' arity _ _ e : cs) = 37 | if n == n' 38 | then 39 | if arity == length args 40 | then subst (args !!) e 41 | else error "stuck: findCoBranch" 42 | else go cs 43 | 44 | eval :: Exp 'C -> Terminal 45 | eval c = 46 | case c of 47 | Ann a _ -> eval a 48 | Return a -> TReturn a 49 | Abs _ _ a -> TAbs a 50 | Bind _ a b -> 51 | case eval a of 52 | TReturn x -> eval $ inst b x 53 | _ -> error "stuck: bind" 54 | AbsTy _ _ a -> TAbsTy a 55 | AppTy a ty -> 56 | case eval a of 57 | TAbsTy b -> eval $ instTyExp b ty 58 | _ -> error "stuck: appTy" 59 | Let _ a b -> eval $ inst b a 60 | Fix _ _ a -> eval $ inst a (Thunk c) 61 | Force (Thunk x) -> eval x 62 | Force{} -> error "stuck: force" 63 | Case (Ctor n as) bs -> eval $ findBranch n as bs 64 | Case{} -> error "stuck: case" 65 | CoCase _ bs -> TCoCase bs 66 | Dtor n as b -> 67 | case eval b of 68 | TCoCase bs -> eval $ findCoBranch n as bs 69 | _ -> error "stuck: dtor" 70 | App a b -> 71 | case eval a of 72 | TAbs x -> eval $ inst x b 73 | _ -> error "stuck: app" -------------------------------------------------------------------------------- /src/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language DataKinds, GADTs, KindSignatures #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language OverloadedStrings #-} 5 | {-# language RankNTypes #-} 6 | {-# language StandaloneDeriving #-} 7 | {-# language TemplateHaskell #-} 8 | module Syntax where 9 | 10 | import Control.Lens.Lens (Lens') 11 | import Control.Lens.TH (makeLenses) 12 | import Data.Bifunctor (first) 13 | import Data.List (iterate) 14 | import Data.List.NonEmpty (NonEmpty(..)) 15 | import Data.Maybe (fromMaybe) 16 | import Data.Set (Set) 17 | import Data.Text (Text) 18 | 19 | import qualified Data.Set as Set 20 | 21 | data Sort = C | V 22 | 23 | data Module 24 | = MEmpty 25 | | MDecl Decl Module 26 | | MIndDecl IndDecl Module 27 | | MCoIndDecl CoIndDecl Module 28 | deriving Show 29 | 30 | data Decl 31 | = Decl 32 | { _declName :: !Text 33 | , _declBody :: Exp 'V 34 | } deriving Show 35 | 36 | data IndDecl 37 | = IndDecl 38 | { _indTypeName :: !Text 39 | , _indTypeParams :: [Text] 40 | , _indTypeKind :: Kind 41 | , _indCtors :: [IndCtor] 42 | } deriving Show 43 | 44 | data IndCtor 45 | = IndCtor 46 | { _indCtorName :: !Text 47 | , _indCtorArity :: !Int 48 | , _indCtorArgs :: [Ty] 49 | } deriving Show 50 | 51 | class HasIndDecls s where; indDecls :: Lens' s [IndDecl] 52 | instance e ~ IndDecl => HasIndDecls [e] where; indDecls = id 53 | 54 | data CoIndDecl 55 | = CoIndDecl 56 | { _coIndTypeName :: !Text 57 | , _coIndTypeParams :: [Text] 58 | , _coIndTypeKind :: Kind 59 | , _coIndDtors :: [CoIndDtor] 60 | } deriving Show 61 | 62 | data CoIndDtor 63 | = CoIndDtor 64 | { _coIndDtorName :: !Text 65 | , _coIndDtorArity :: !Int 66 | , _coIndDtorArgs :: [Ty] 67 | , _coIndDtorType :: Ty 68 | } deriving Show 69 | 70 | class HasCoIndDecls s where; coIndDecls :: Lens' s [CoIndDecl] 71 | instance e ~ CoIndDecl => HasCoIndDecls [e] where; coIndDecls = id 72 | 73 | data Kind 74 | = KArr Kind Kind 75 | | KComp 76 | | KVal 77 | deriving (Eq, Ord, Show) 78 | 79 | unfoldKArr :: Kind -> ([Kind], Kind) 80 | unfoldKArr (KArr a b) = first (a :) $ unfoldKArr b 81 | unfoldKArr a = ([], a) 82 | 83 | infixl 5 `TApp` 84 | data Ty where 85 | -- | f : (a -> b) /\\ x : a ==> f x : b 86 | TApp :: Ty -> Ty -> Ty 87 | {- 88 | inl3 : forall (a : Value). Sum Int a 89 | inl3 = inl 3 90 | 91 | inl' : forall (a : Value) (b : Value). a -> F (Sum a b) 92 | inl' = \x -> return (inl x) 93 | -} 94 | -- | k1 kind /\\ k1 |- b : k2 ==> ( forall (a : k1). b ) : k2 95 | TForall :: Maybe Text -> Kind -> Ty -> Ty 96 | 97 | -- value types 98 | 99 | -- | U : CType -> VType 100 | U :: Ty 101 | 102 | -- computation types 103 | 104 | -- | F : VType -> CType 105 | F :: Ty 106 | -- | Arrow : VType -> CType -> CType 107 | Arrow :: Ty 108 | 109 | -- | TVar : a 110 | TVar :: Int -> Ty 111 | TName :: Text -> Ty 112 | -- | SomeCtor : a 113 | TCtor :: Text -> Ty 114 | deriving (Eq, Show) 115 | 116 | abstractTy :: Text -> Ty -> Ty 117 | abstractTy n = go 0 118 | where 119 | go !depth ty = 120 | case ty of 121 | TApp a b -> TApp (go depth a) (go depth b) 122 | TForall name k a -> TForall name k $ go (depth+1) a 123 | TName n' | n == n' -> TVar depth 124 | TVar ix -> if ix >= depth then TVar (ix + 1) else TVar ix 125 | _ -> ty 126 | 127 | abstractTys :: [Text] -> Ty -> Ty 128 | abstractTys ns t = foldr abstractTy t ns 129 | 130 | tvars :: Ty -> Set Int 131 | tvars = go 132 | where 133 | go (TVar n) = Set.singleton n 134 | go (TApp a b) = go a <> go b 135 | go _ = mempty 136 | 137 | unfoldTApp :: Ty -> (Ty, [Ty]) 138 | unfoldTApp = go [] 139 | where 140 | go ts (TApp a b) = go (b : ts) a 141 | go ts b = (b, ts) 142 | 143 | renameTy :: (Int -> Int) -> Ty -> Ty 144 | renameTy f t = 145 | case t of 146 | U -> U 147 | TCtor a -> TCtor a 148 | TForall n k a -> TForall n k $ renameTy (rho f) a 149 | F -> F 150 | Arrow -> Arrow 151 | TApp a b -> TApp (renameTy f a) (renameTy f b) 152 | TVar a -> TVar (f a) 153 | TName a -> TName a 154 | 155 | sigmaTy :: (Int -> Ty) -> (Int -> Ty) 156 | sigmaTy _ 0 = TVar 0 157 | sigmaTy f n = renameTy (+1) $ f (n-1) 158 | 159 | substTy :: (Int -> Ty) -> Ty -> Ty 160 | substTy f t = 161 | case t of 162 | U -> U 163 | TCtor a -> TCtor a 164 | TForall n k a -> TForall n k $ substTy (sigmaTy f) a 165 | F -> F 166 | Arrow -> Arrow 167 | TApp a b -> TApp (substTy f a) (substTy f b) 168 | TVar a -> f a 169 | TName a -> TName a 170 | 171 | data Pattern 172 | = PWild 173 | | PVar (Maybe Text) 174 | | PCtor !Text !Int [Maybe Text] 175 | deriving (Eq, Show) 176 | 177 | patArity :: Pattern -> Int 178 | patArity PWild = 0 179 | patArity (PVar _) = 1 180 | patArity (PCtor _ n _) = n 181 | 182 | patNames :: Pattern -> [Text] 183 | patNames PWild = ["_"] 184 | patNames (PVar n) = maybe [""] pure n 185 | patNames (PCtor _ _ ns) = fromMaybe "" <$> ns 186 | 187 | data Branch a = Branch Pattern (Exp a) 188 | deriving Show 189 | 190 | data CoBranch = CoBranch !Text !Int [Ty] [Text] (Exp 'C) 191 | deriving Show 192 | 193 | data Exp (a :: Sort) where 194 | Ann :: Exp a -> Ty -> Exp a 195 | 196 | -- values 197 | Var :: !Int -> Exp 'V 198 | Thunk :: Exp 'C -> Exp 'V 199 | -- VType 200 | Ctor :: Text -> [Exp 'V] -> Exp 'V 201 | 202 | -- computations 203 | Return :: Exp 'V -> Exp 'C 204 | -- VType 205 | Abs :: Maybe Text -> Ty -> Exp 'C -> Exp 'C 206 | Bind :: Maybe Text -> Exp 'C -> Exp 'C -> Exp 'C 207 | Let :: Maybe Text -> Exp 'V -> Exp a -> Exp a 208 | Fix :: Maybe Text -> Ty -> Exp 'C -> Exp 'C 209 | Force :: Exp 'V -> Exp 'C 210 | Case :: Exp 'V -> NonEmpty (Branch a) -> Exp a 211 | CoCase :: Ty -> NonEmpty CoBranch -> Exp 'C 212 | Dtor :: Text -> [Exp 'V] -> Exp 'C -> Exp 'C 213 | App :: Exp 'C -> Exp 'V -> Exp 'C 214 | 215 | Name :: Text -> Exp 'V 216 | AbsTy :: Maybe Text -> Kind -> Exp a -> Exp a 217 | AppTy :: Exp a -> Ty -> Exp a 218 | deriving instance Show (Exp a) 219 | 220 | abstract :: Text -> Exp a -> Exp a 221 | abstract n = go 0 222 | where 223 | go :: Int -> Exp a -> Exp a 224 | go !depth tm = 225 | case tm of 226 | App a b -> App (go depth a) (go depth b) 227 | Abs name k a -> Abs name k $ go (depth+1) a 228 | Bind name v a -> Bind name (go depth v) $ go (depth+1) a 229 | Let name v a -> Let name (go depth v) $ go (depth+1) a 230 | Fix name t a -> Fix name t $ go (depth+1) a 231 | Name n' 232 | | n == n' -> Var depth 233 | | otherwise -> Name n' 234 | Var ix -> if ix >= depth then Var (ix + 1) else Var ix 235 | Ann a b -> Ann (go depth a) b 236 | Thunk a -> Thunk $ go depth a 237 | Force a -> Force $ go depth a 238 | Return a -> Return $ go depth a 239 | Ctor a b -> Ctor a $ go depth <$> b 240 | Dtor a b c -> Dtor a (go depth <$> b) (go depth c) 241 | Case a bs -> 242 | Case 243 | (go depth a) 244 | ((\(Branch p e) -> Branch p $ go (depth + patArity p) e) <$> bs) 245 | CoCase a bs -> 246 | CoCase a $ 247 | (\(CoBranch b arity tys names d) -> CoBranch b arity tys names $ go (depth+arity) d) <$> 248 | bs 249 | AbsTy name k a -> AbsTy name k $ go depth a 250 | AppTy a t -> AppTy (go depth a) t 251 | 252 | abstractTyExp :: Text -> Exp a -> Exp a 253 | abstractTyExp n = go 0 254 | where 255 | goTy !depth ty = 256 | case ty of 257 | TApp a b -> TApp (goTy depth a) (goTy depth b) 258 | TForall name k a -> TForall name k $ goTy (depth+1) a 259 | TName n' | n == n' -> TVar depth 260 | TVar ix -> if ix >= depth then TVar (ix + 1) else TVar ix 261 | _ -> ty 262 | 263 | go :: Int -> Exp a -> Exp a 264 | go !depth tm = 265 | case tm of 266 | App a b -> App (go depth a) (go depth b) 267 | Abs name t a -> Abs name (goTy depth t) (go depth a) 268 | Bind name v a -> Bind name (go depth v) (go depth a) 269 | Let name v a -> Let name (go depth v) (go depth a) 270 | Fix name t a -> Fix name (goTy depth t) $ go depth a 271 | Name a -> Name a 272 | Var ix -> Var ix 273 | Ann a t -> Ann (go depth a) (goTy depth t) 274 | Thunk a -> Thunk $ go depth a 275 | Force a -> Force $ go depth a 276 | Return a -> Return $ go depth a 277 | Ctor a b -> Ctor a $ go depth <$> b 278 | Dtor a b c -> Dtor a (go depth <$> b) (go depth c) 279 | Case a bs -> 280 | Case 281 | (go depth a) 282 | ((\(Branch p e) -> Branch p $ go depth e) <$> bs) 283 | CoCase a bs -> 284 | CoCase 285 | (goTy depth a) 286 | ((\(CoBranch b c tys d e) -> 287 | CoBranch b c (goTy depth <$> tys) d $ go depth e) <$> bs) 288 | AbsTy name k a -> AbsTy name k $ go (depth+1) a 289 | AppTy a t -> AppTy (go depth a) (goTy depth t) 290 | 291 | rho :: (Int -> Int) -> (Int -> Int) 292 | rho _ 0 = 0 293 | rho f n = f (n-1) + 1 294 | 295 | rename :: (Int -> Int) -> Exp a -> Exp a 296 | rename f c = 297 | case c of 298 | Ann a b -> Ann (rename f a) b 299 | 300 | Name a -> Name a 301 | Var a -> Var $ f a 302 | Thunk a -> Thunk $ rename f a 303 | Ctor a bs -> Ctor a (rename f <$> bs) 304 | 305 | Return a -> Return $ rename f a 306 | Abs n ty a -> Abs n ty (rename (rho f) a) 307 | Bind n a b -> Bind n (rename f a) (rename (rho f) b) 308 | Let n a b -> Let n (rename f a) (rename (rho f) b) 309 | Fix n t a -> Fix n t $ rename (rho f) a 310 | Force a -> Force $ rename f a 311 | Case a bs -> 312 | Case (rename f a) $ 313 | fmap 314 | (\(Branch p e) -> 315 | Branch p $ rename (iterate rho f !! patArity p) e) 316 | bs 317 | Dtor a b d -> Dtor a (rename f <$> b) (rename f d) 318 | CoCase a bs -> 319 | CoCase a $ 320 | (\(CoBranch b arity tys names e) -> CoBranch b arity tys names $ rename (iterate rho f !! arity) e) <$> bs 321 | App a b -> App (rename f a) (rename f b) 322 | 323 | AbsTy n k a -> AbsTy n k $ rename f a 324 | AppTy a t -> AppTy (rename f a) t 325 | 326 | renameTyExp :: (Int -> Int) -> Exp a -> Exp a 327 | renameTyExp f c = 328 | case c of 329 | Ann a b -> Ann (renameTyExp f a) (renameTy f b) 330 | 331 | Name a -> Name a 332 | Var a -> Var a 333 | Thunk a -> Thunk $ renameTyExp f a 334 | Ctor a bs -> Ctor a (renameTyExp f <$> bs) 335 | 336 | Return a -> Return $ renameTyExp f a 337 | Abs n ty a -> Abs n (renameTy f ty) (renameTyExp f a) 338 | Bind n a b -> Bind n (renameTyExp f a) (renameTyExp f b) 339 | Let n a b -> Let n (renameTyExp f a) (renameTyExp f b) 340 | Fix n t a -> Fix n (renameTy f t) $ renameTyExp f a 341 | Force a -> Force $ renameTyExp f a 342 | Case a bs -> 343 | Case (renameTyExp f a) $ 344 | (\(Branch p e) -> Branch p $ renameTyExp f e) <$> bs 345 | Dtor n b d -> Dtor n (renameTyExp f <$> b) (renameTyExp f d) 346 | CoCase t bs -> 347 | CoCase (renameTy f t) $ 348 | (\(CoBranch b arity tys names e) -> 349 | CoBranch b arity (renameTy f <$> tys)names $ renameTyExp f e) <$> bs 350 | App a b -> App (renameTyExp f a) (renameTyExp f b) 351 | 352 | AbsTy n k a -> AbsTy n k $ renameTyExp (rho f) a 353 | AppTy a t -> AppTy (renameTyExp f a) (renameTy f t) 354 | 355 | sigma :: (Int -> Exp 'V) -> (Int -> Exp 'V) 356 | sigma _ 0 = Var 0 357 | sigma f n = rename (+1) $ f (n-1) 358 | 359 | subst :: (Int -> Exp 'V) -> Exp a -> Exp a 360 | subst f c = 361 | case c of 362 | Ann a b -> Ann (subst f a) b 363 | 364 | Name a -> Name a 365 | Var a -> f a 366 | Thunk a -> Thunk $ subst f a 367 | Ctor a bs -> Ctor a (subst f <$> bs) 368 | 369 | Return a -> Return $ subst f a 370 | Abs n ty a -> Abs n ty $ subst (sigma f) a 371 | Bind n a b -> Bind n (subst f a) (subst (sigma f) b) 372 | Let n a b -> Let n (subst f a) (subst (sigma f) b) 373 | Fix n t a -> Fix n t $ subst (sigma f) a 374 | Force a -> Force $ subst f a 375 | Case a bs -> 376 | Case (subst f a) $ 377 | fmap 378 | (\(Branch p e) -> 379 | Branch p $ subst (iterate sigma f !! patArity p) e) 380 | bs 381 | Dtor a b d -> Dtor a (subst f <$> b) (subst f d) 382 | CoCase a bs -> 383 | CoCase a $ 384 | (\(CoBranch b arity tys names e) -> 385 | CoBranch b arity tys names $ subst (iterate sigma f !! arity) e) <$> bs 386 | App a b -> App (subst f a) (subst f b) 387 | 388 | AbsTy n k a -> AbsTy n k $ subst f a 389 | AppTy a t -> AppTy (subst f a) t 390 | 391 | substTyExp :: (Int -> Ty) -> Exp a -> Exp a 392 | substTyExp f c = 393 | case c of 394 | Ann a b -> Ann (substTyExp f a) (substTy f b) 395 | 396 | Name a -> Name a 397 | Var a -> Var a 398 | Thunk a -> Thunk $ substTyExp f a 399 | Ctor a bs -> Ctor a (substTyExp f <$> bs) 400 | 401 | Return a -> Return $ substTyExp f a 402 | Abs n ty a -> Abs n (substTy f ty) (substTyExp f a) 403 | Bind n a b -> Bind n (substTyExp f a) (substTyExp f b) 404 | Let n a b -> Let n (substTyExp f a) (substTyExp f b) 405 | Fix n t a -> Fix n (substTy f t) $ substTyExp f a 406 | Force a -> Force $ substTyExp f a 407 | Case a bs -> 408 | Case (substTyExp f a) $ 409 | (\(Branch p e) -> Branch p $ substTyExp f e) <$> bs 410 | Dtor n b d -> Dtor n (substTyExp f <$> b) (substTyExp f d) 411 | CoCase t bs -> 412 | CoCase (substTy f t) $ 413 | (\(CoBranch b arity tys names e) -> 414 | CoBranch b arity (substTy f <$> tys) names $ substTyExp f e) <$> bs 415 | App a b -> App (substTyExp f a) (substTyExp f b) 416 | 417 | AbsTy n k a -> AbsTy n k $ substTyExp (sigmaTy f) a 418 | AppTy a t -> AppTy (substTyExp f a) (substTy f t) 419 | 420 | inst :: Exp a -> Exp 'V -> Exp a 421 | inst a b = subst (\x -> if x == 0 then b else Var (x-1)) a 422 | 423 | instTyExp :: Exp a -> Ty -> Exp a 424 | instTyExp a b = substTyExp (\x -> if x == 0 then b else TVar (x-1)) a 425 | 426 | makeLenses ''IndCtor 427 | makeLenses ''CoIndDtor -------------------------------------------------------------------------------- /src/Typecheck.hs: -------------------------------------------------------------------------------- 1 | {-# language DataKinds, GADTs #-} 2 | {-# language BangPatterns #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language LambdaCase #-} 5 | {-# language OverloadedStrings #-} 6 | {-# language RankNTypes #-} 7 | {-# language TemplateHaskell #-} 8 | module Typecheck where 9 | 10 | import Control.Lens.Getter (view) 11 | import Control.Lens.Review ((#)) 12 | import Control.Lens.Setter (locally) 13 | import Control.Lens.TH (makeClassyPrisms, makeLenses, makePrisms) 14 | import Control.Monad (unless) 15 | import Control.Monad.Except 16 | (MonadError, runExcept, throwError, catchError) 17 | import Control.Monad.Reader (MonadReader, runReaderT, asks) 18 | import Data.Foldable (traverse_, for_) 19 | import Data.Map (Map) 20 | import Data.Maybe (fromMaybe) 21 | import Data.Semigroup.Foldable (foldlM1) 22 | import Data.Text (Text) 23 | import Data.Traversable (for) 24 | import Text.PrettyPrint.ANSI.Leijen (Doc) 25 | 26 | import qualified Data.Map as Map 27 | import qualified Data.Text as Text 28 | import qualified Text.PrettyPrint.ANSI.Leijen as Pretty 29 | 30 | import Syntax 31 | import Printer 32 | 33 | data ScopeError 34 | = InductiveNotInScope Text 35 | | CoinductiveNotInScope Text 36 | | TyCtorNotInScope Text 37 | | AmbiguousTyCtor Text 38 | | CtorNotInScope Text 39 | | DtorNotInScope Text 40 | | VarNotInScope (Int -> Maybe Doc) Int 41 | | UnboundName Text 42 | 43 | prettyScopeError :: ScopeError -> Doc 44 | prettyScopeError se = 45 | case se of 46 | InductiveNotInScope a -> 47 | Pretty.text "Inductive type '" <> 48 | Pretty.text (Text.unpack a) <> 49 | Pretty.text "' not in scope" 50 | CoinductiveNotInScope a -> 51 | Pretty.text "Coinductive type '" <> 52 | Pretty.text (Text.unpack a) <> 53 | Pretty.text "' not in scope" 54 | TyCtorNotInScope a -> 55 | Pretty.text "Type constructor '" <> 56 | Pretty.text (Text.unpack a) <> 57 | Pretty.text "' not in scope" 58 | AmbiguousTyCtor a -> 59 | Pretty.text "Ambiguous type constructor '" <> 60 | Pretty.text (Text.unpack a) <> 61 | Pretty.text "' - there is both an inductive and a coinductive type with that name" 62 | CtorNotInScope a -> 63 | Pretty.text "Constructor '" <> 64 | Pretty.text (Text.unpack a) <> 65 | Pretty.text "' not in scope" 66 | DtorNotInScope a -> 67 | Pretty.text "Destructor '" <> 68 | Pretty.text (Text.unpack a) <> 69 | Pretty.text "' not in scope" 70 | VarNotInScope exNames a -> 71 | Pretty.text "Variable '" <> 72 | fromMaybe (Pretty.char '#' <> Pretty.int a) (exNames a) <> 73 | Pretty.text "' not in scope" 74 | UnboundName a -> 75 | Pretty.text "Unbound name '" <> 76 | Pretty.text (Text.unpack a) <> 77 | Pretty.char '\'' 78 | 79 | data TypeError 80 | = ExpectedF (Int -> Maybe Doc) Ty 81 | | ExpectedU (Int -> Maybe Doc) Ty 82 | | ExpectedArrow (Int -> Maybe Doc) Ty 83 | | ExpectedInductive (Int -> Maybe Doc) Ty 84 | | ExpectedCoinductive (Int -> Maybe Doc) Ty 85 | | ExpectedForall (Int -> Maybe Doc) Ty 86 | | TypeMismatch (Int -> Maybe Doc) Ty Ty 87 | | CtorExpectedArity Int Int 88 | | Can'tInfer (Int -> Maybe Doc) (Int -> Maybe Doc) (Exp 'V) 89 | 90 | prettyTypeError :: TypeError -> Doc 91 | prettyTypeError te = 92 | case te of 93 | ExpectedF tyNames a -> 94 | tmismatch (Pretty.text "F ?") (prettyTy tyNames a) 95 | ExpectedU tyNames a -> 96 | tmismatch (Pretty.text "U ?") (prettyTy tyNames a) 97 | ExpectedArrow tyNames a -> 98 | tmismatch (Pretty.text "? -> ?") (prettyTy tyNames a) 99 | ExpectedInductive tyNames a -> 100 | Pretty.hsep [prettyTy tyNames a, Pretty.text "is not an inductive type"] 101 | ExpectedCoinductive tyNames a -> 102 | Pretty.hsep [prettyTy tyNames a, Pretty.text "is not a coinductive type"] 103 | ExpectedForall tyNames a -> 104 | tmismatch (Pretty.text "forall (? : ?). ?") (prettyTy tyNames a) 105 | TypeMismatch tyNames a b -> 106 | tmismatch (prettyTy tyNames a) (prettyTy tyNames b) 107 | CtorExpectedArity a b -> 108 | Pretty.hsep 109 | [ Pretty.text "Incorrect number of arguments to constructor: Expected" 110 | , Pretty.int a 111 | , Pretty.text "but got" 112 | , Pretty.int b 113 | ] 114 | Can'tInfer exNames tyNames a -> 115 | Pretty.hsep 116 | [ Pretty.text "Can't infer type for" 117 | , prettyExp exNames tyNames a 118 | ] 119 | where 120 | tmismatch t1 t2 = 121 | Pretty.hsep 122 | [ Pretty.text "Type mismatch: Expected '" <> t1 <> Pretty.text "', but got" 123 | , t2 <> Pretty.char '\'' 124 | ] 125 | 126 | makeClassyPrisms ''TypeError 127 | makeClassyPrisms ''ScopeError 128 | 129 | lookupIndDecl :: 130 | (HasIndDecls r, MonadReader r m, AsScopeError e, MonadError e m) => 131 | Text -> m IndDecl 132 | lookupIndDecl a = 133 | go <$> view indDecls >>= 134 | maybe (throwError $ _InductiveNotInScope # a) pure 135 | where 136 | go [] = Nothing 137 | go (i : is) = 138 | if _indTypeName i == a 139 | then Just i 140 | else go is 141 | 142 | lookupIndCtor :: 143 | (AsScopeError e, MonadError e m) => Text -> [IndCtor] -> m IndCtor 144 | lookupIndCtor a cs = 145 | maybe (throwError $ _CtorNotInScope # a) pure $ go cs 146 | where 147 | go [] = Nothing 148 | go (i : is) = 149 | if _indCtorName i == a 150 | then Just i 151 | else go is 152 | 153 | findIndCtor :: 154 | (HasIndDecls r, MonadReader r m, AsScopeError e, MonadError e m) => 155 | Text -> m (IndDecl, IndCtor) 156 | findIndCtor a = view indDecls >>= go 157 | where 158 | go [] = throwError $ _CtorNotInScope # a 159 | go (t : ts) = 160 | catchError 161 | ((,) t <$> lookupIndCtor a (_indCtors t)) 162 | (\_ -> go ts) 163 | 164 | lookupCoIndDtor :: 165 | (AsScopeError e, MonadError e m) => 166 | Text -> [CoIndDtor] -> m CoIndDtor 167 | lookupCoIndDtor a cs = 168 | maybe (throwError $ _CtorNotInScope # a) pure $ go cs 169 | where 170 | go [] = Nothing 171 | go (i : is) = 172 | if _coIndDtorName i == a 173 | then Just i 174 | else go is 175 | 176 | lookupCoIndDecl :: 177 | (HasCoIndDecls r, MonadReader r m, AsScopeError e, MonadError e m) => 178 | Text -> m CoIndDecl 179 | lookupCoIndDecl a = 180 | go <$> view coIndDecls >>= 181 | maybe (throwError $ _CoinductiveNotInScope # a) pure 182 | where 183 | go [] = Nothing 184 | go (i : is) = 185 | if _coIndTypeName i == a 186 | then Just i 187 | else go is 188 | 189 | findCoIndDtor :: 190 | (HasCoIndDecls r, MonadReader r m, AsScopeError e, MonadError e m) => 191 | Text -> m (CoIndDecl, CoIndDtor) 192 | findCoIndDtor a = view coIndDecls >>= go 193 | where 194 | go [] = throwError $ _DtorNotInScope # a 195 | go (t : ts) = 196 | catchError 197 | ((,) t <$> lookupCoIndDtor a (_coIndDtors t)) 198 | (\_ -> go ts) 199 | 200 | data KindError 201 | = ExpectedKArr (Int -> Maybe Doc) Ty Kind 202 | | KindMismatch (Int -> Maybe Doc) Ty Kind Kind 203 | | TypeNotInScope (Int -> Maybe Doc) Int 204 | | InductiveShouldBeVal Text Kind 205 | | CoinductiveShouldBeComp Text Kind 206 | makeClassyPrisms ''KindError 207 | 208 | prettyKindError :: KindError -> Doc 209 | prettyKindError ke = 210 | case ke of 211 | ExpectedKArr tyNames ty a -> 212 | Pretty.hsep 213 | [ Pretty.text "Kind mismatch: Type" 214 | , Pretty.squotes $ prettyTy tyNames ty 215 | , Pretty.text "should have kind '? -> ?', but it has kind" 216 | , Pretty.squotes $ prettyKind a 217 | ] 218 | KindMismatch tyNames ty a b -> 219 | Pretty.hsep 220 | [ Pretty.text "Kind mismatch: Type" 221 | , Pretty.squotes $ prettyTy tyNames ty 222 | , Pretty.text "should have kind" 223 | , Pretty.squotes $ prettyKind a 224 | , Pretty.text "but it has kind" 225 | , Pretty.squotes $ prettyKind b 226 | ] 227 | TypeNotInScope tyNames n -> 228 | fromMaybe (Pretty.char '#' <> Pretty.int n) (tyNames n) <> 229 | Pretty.text " not in scope" 230 | InductiveShouldBeVal n k -> 231 | Pretty.hsep 232 | [ Pretty.text "Inductive type" 233 | , Pretty.squotes . Pretty.text $ Text.unpack n 234 | , Pretty.text "should have kind 'Val'" 235 | , Pretty.text "but it has kind" 236 | , Pretty.squotes $ prettyKind k 237 | ] 238 | CoinductiveShouldBeComp n k -> 239 | Pretty.hsep 240 | [ Pretty.text "Coinductive type" 241 | , Pretty.squotes . Pretty.text $ Text.unpack n 242 | , Pretty.text "should have kind 'Comp'" 243 | , Pretty.text "but it has kind" 244 | , Pretty.squotes $ prettyKind k 245 | ] 246 | 247 | ix :: Int -> [a] -> Maybe a 248 | ix _ [] = Nothing 249 | ix 0 (x:_) = Just x 250 | ix n (_:xs) = ix (n-1) xs 251 | 252 | namesDoc :: (Int -> Maybe Text) -> Int -> Maybe Doc 253 | namesDoc f = fmap (Pretty.text . Text.unpack) . f 254 | 255 | data TCEnv 256 | = TCEnv 257 | { _envVarNames :: Int -> Maybe Text 258 | , _envTypes :: [Ty] 259 | , _envTyNames :: Int -> Maybe Text 260 | , _envKinds :: [Kind] 261 | , _envDecls :: Map Text (Exp 'V, Ty) 262 | , _envIndDecls :: [IndDecl] 263 | , _envCoIndDecls :: [CoIndDecl] 264 | } 265 | makeLenses ''TCEnv 266 | 267 | emptyTCEnv :: TCEnv 268 | emptyTCEnv = 269 | TCEnv 270 | { _envVarNames = const Nothing 271 | , _envTypes = mempty 272 | , _envTyNames = const Nothing 273 | , _envKinds = mempty 274 | , _envDecls = mempty 275 | , _envIndDecls = mempty 276 | , _envCoIndDecls = mempty 277 | } 278 | 279 | lookupDecl :: (MonadReader TCEnv m, AsScopeError e, MonadError e m) => Text -> m (Exp 'V, Ty) 280 | lookupDecl n = do 281 | res <- asks $ Map.lookup n . _envDecls 282 | case res of 283 | Nothing -> throwError $ _UnboundName # n 284 | Just a -> pure a 285 | 286 | instance HasIndDecls TCEnv where; indDecls = envIndDecls 287 | instance HasCoIndDecls TCEnv where; coIndDecls = envCoIndDecls 288 | 289 | inferKind :: 290 | (AsScopeError e, AsKindError e, MonadError e m, MonadReader TCEnv m) => 291 | Ty -> m Kind 292 | inferKind ty = 293 | case ty of 294 | TName a -> throwError $ _UnboundName # a 295 | TForall name k a -> 296 | locally envKinds (k :) . 297 | locally envTyNames (\f -> \case; 0 -> name; n -> f (n-1)) $ 298 | inferKind a 299 | U -> pure $ KArr KComp KVal 300 | TCtor n -> do 301 | mind <- 302 | catchError (Just <$> lookupIndDecl n) $ \_ -> pure Nothing 303 | mcoind <- 304 | catchError (Just <$> lookupCoIndDecl n) $ \_ -> pure Nothing 305 | case (mind, mcoind) of 306 | (Nothing, Nothing) -> throwError $ _TyCtorNotInScope # n 307 | (Just decl, Nothing) -> pure $ _indTypeKind decl 308 | (Nothing, Just decl) -> pure $ _coIndTypeKind decl 309 | (Just{}, Just{}) -> throwError $ _AmbiguousTyCtor # n 310 | F -> pure $ KArr KVal KComp 311 | Arrow -> pure $ KArr KVal (KArr KComp KComp) 312 | TVar n -> do 313 | kctx <- asks _envKinds 314 | case ix n kctx of 315 | Nothing -> do 316 | tyNames <- asks (namesDoc . _envTyNames) 317 | throwError $ _TypeNotInScope # (tyNames, n) 318 | Just k -> pure k 319 | TApp a b -> do 320 | aKind <- inferKind a 321 | case aKind of 322 | KArr x y -> y <$ checkKind b x 323 | _ -> do 324 | tyNames <- asks (namesDoc . _envTyNames) 325 | throwError $ _ExpectedKArr # (tyNames, a, aKind) 326 | 327 | checkKind :: 328 | (AsScopeError e, AsKindError e, MonadError e m, MonadReader TCEnv m) => 329 | Ty -> Kind -> m () 330 | checkKind ty k = do 331 | k' <- inferKind ty 332 | unless (k == k') $ do 333 | tyNames <- asks (namesDoc . _envTyNames) 334 | throwError $ _KindMismatch # (tyNames, ty, k, k') 335 | 336 | checkCtor :: 337 | (AsScopeError e, AsKindError e, AsTypeError e, MonadError e m, MonadReader TCEnv m) => 338 | Text -> [Exp 'V] -> 339 | Ty -> m () 340 | checkCtor name args ty = 341 | case unfoldTApp ty of 342 | (TCtor tname, targs) -> do 343 | decl <- lookupIndDecl tname 344 | ctor <- lookupIndCtor name (_indCtors decl) 345 | let 346 | actualArity = length args 347 | expectedArity = _indCtorArity ctor 348 | unless (expectedArity == actualArity) . throwError $ 349 | _CtorExpectedArity # (expectedArity, actualArity) 350 | let instTys = substTy (targs !!) <$> _indCtorArgs ctor 351 | traverse_ (uncurry check) (zip args instTys) 352 | _ -> do 353 | varNames <- asks (namesDoc . _envVarNames) 354 | throwError $ _ExpectedInductive # (varNames, ty) 355 | 356 | check :: 357 | (AsScopeError e, AsKindError e, AsTypeError e, MonadError e m, MonadReader TCEnv m) => 358 | Exp a -> Ty -> m () 359 | check a ty = 360 | case a of 361 | Ctor n as -> checkCtor n as ty 362 | _ -> do 363 | aTy <- infer a 364 | tyNames <- asks (namesDoc . _envTyNames) 365 | unless (aTy == ty) . throwError $ _TypeMismatch # (tyNames, ty, aTy) 366 | 367 | checkPattern :: 368 | (AsScopeError e, AsKindError e, AsTypeError e, MonadError e m, MonadReader TCEnv m) => 369 | Pattern -> Ty -> m ([Maybe Text], [Ty]) 370 | checkPattern PWild _ = pure ([], []) 371 | checkPattern (PVar n) ty = pure ([n], [ty]) 372 | checkPattern (PCtor n act ns) ty = 373 | case unfoldTApp ty of 374 | (TCtor nty, targs) -> do 375 | decl <- lookupIndDecl nty 376 | ctor <- lookupIndCtor n $ _indCtors decl 377 | let ex = _indCtorArity ctor 378 | unless (ex == act) . throwError $ _CtorExpectedArity # (ex, act) 379 | pure (ns, substTy (targs !!) <$> _indCtorArgs ctor) 380 | _ -> do 381 | tyNames <- asks (namesDoc . _envTyNames) 382 | throwError $ _ExpectedInductive # (tyNames, ty) 383 | 384 | infer :: 385 | (AsScopeError e, AsTypeError e, AsKindError e, MonadError e m, MonadReader TCEnv m) => 386 | Exp a -> m Ty 387 | infer c = 388 | case c of 389 | AppTy a t -> do 390 | aTy <- infer a 391 | case aTy of 392 | TForall _ k rest -> rest <$ checkKind t k 393 | _ -> do 394 | tyNames <- asks (namesDoc . _envTyNames) 395 | throwError $ _ExpectedForall # (tyNames, aTy) 396 | AbsTy name k a -> 397 | fmap (TForall name k) . 398 | locally envKinds (k :) . 399 | locally envTyNames (\f -> \case; 0 -> name; n -> f (n-1)) $ 400 | infer a 401 | Name n -> do 402 | (_, ty) <- lookupDecl n 403 | pure ty 404 | Var n -> do 405 | ctx <- asks _envTypes 406 | case ix n ctx of 407 | Nothing -> do 408 | varNames <- asks (namesDoc . _envVarNames) 409 | throwError $ _VarNotInScope # (varNames, n) 410 | Just t -> pure t 411 | Thunk a -> TApp U <$> infer a 412 | Return a -> TApp F <$> infer a 413 | Abs name ty a -> do 414 | checkKind ty KVal 415 | fmap (TApp (TApp Arrow ty)) . 416 | locally envTypes (ty :) . 417 | locally envVarNames (\f -> \case; 0 -> name; n -> f (n-1)) $ 418 | infer a 419 | Bind name a b -> do 420 | aTy <- infer a 421 | case aTy of 422 | TApp F i -> 423 | locally envTypes (i :) . 424 | locally envVarNames (\f -> \case; 0 -> name; n -> f (n-1)) $ 425 | infer b 426 | _ -> do 427 | tyNames <- asks (namesDoc . _envTyNames) 428 | throwError $ _ExpectedF # (tyNames, aTy) 429 | Let name a b -> do 430 | aTy <- infer a 431 | locally envTypes (aTy :) . 432 | locally envVarNames (\f -> \case; 0 -> name; n -> f (n-1)) $ 433 | infer b 434 | Fix name t a -> 435 | case t of 436 | TApp U t' -> do 437 | aTy <- 438 | locally envTypes (t :) . 439 | locally envVarNames (\f -> \case; 0 -> name; n -> f (n-1)) $ 440 | infer a 441 | unless (aTy == t') $ do 442 | tyNames <- asks (namesDoc . _envTyNames) 443 | throwError $ _TypeMismatch # (tyNames, t', aTy) 444 | pure aTy 445 | _ -> do 446 | tyNames <- asks (namesDoc . _envTyNames) 447 | throwError $ _ExpectedU # (tyNames, t) 448 | Force a -> do 449 | aTy <- infer a 450 | case aTy of 451 | TApp U i -> pure i 452 | _ -> do 453 | tyNames <- asks (namesDoc . _envTyNames) 454 | throwError $ _ExpectedU # (tyNames, aTy) 455 | Case a bs -> do 456 | aTy <- infer a 457 | ts <- for bs $ \(Branch p b) -> do 458 | (ns, vs) <- checkPattern p aTy 459 | let arity = patArity p 460 | locally envTypes (vs <>) . 461 | locally envVarNames (\f n -> if n < arity then ns !! n else f (n-arity)) $ 462 | infer b 463 | foldlM1 464 | (\x y -> do 465 | unless (x == y) $ do 466 | tyNames <- asks (namesDoc . _envTyNames) 467 | throwError $ _TypeMismatch # (tyNames, x, y) 468 | pure x) 469 | ts 470 | CoCase t bs -> do 471 | checkKind t KComp 472 | let (tc, targs) = unfoldTApp t 473 | case tc of 474 | TCtor name -> do 475 | decl <- lookupCoIndDecl name 476 | for_ bs $ \(CoBranch d arity tys names e) -> do 477 | dtor <- lookupCoIndDtor d $ _coIndDtors decl 478 | locally envTypes (tys ++) . 479 | locally envVarNames (\f n -> if n < arity then Just (names !! n) else f (n-arity)) . 480 | check e $ substTy (targs !!) (_coIndDtorType dtor) 481 | pure t 482 | _ -> do 483 | tyNames <- asks (namesDoc . _envTyNames) 484 | throwError $ _ExpectedCoinductive # (tyNames, tc) 485 | Dtor n bs a -> do 486 | (decl, dtor) <- findCoIndDtor n 487 | aTy <- infer a 488 | let 489 | (tc, targs) = unfoldTApp aTy 490 | ety = TCtor (_coIndTypeName decl) 491 | unless (tc == ety) $ do 492 | tyNames <- asks (namesDoc . _envTyNames) 493 | throwError $ _TypeMismatch # (tyNames, ety, tc) 494 | for_ (zip bs $ _coIndDtorArgs dtor) (uncurry check) 495 | let retTy = substTy (targs !!) (_coIndDtorType dtor) 496 | retTy <$ checkKind retTy KComp 497 | App f x -> do 498 | fTy <- infer f 499 | case fTy of 500 | TApp (TApp Arrow a) b -> b <$ check x a 501 | _ -> do 502 | tyNames <- asks (namesDoc . _envTyNames) 503 | throwError $ _ExpectedArrow # (tyNames, fTy) 504 | Ctor{} -> do 505 | varNames <- asks (namesDoc . _envVarNames) 506 | tyNames <- asks (namesDoc . _envTyNames) 507 | throwError $ _Can'tInfer # (varNames, tyNames, c) 508 | Ann a b -> b <$ check a b 509 | 510 | checkIndDecl :: 511 | ( AsScopeError e, AsKindError e, MonadError e m 512 | , MonadReader TCEnv m 513 | ) => 514 | IndDecl -> m () 515 | checkIndDecl decl = do 516 | unless (k == KVal) . throwError $ 517 | _InductiveShouldBeVal # (_indTypeName decl, k) 518 | for_ (_indCtors decl) $ \ctor -> 519 | locally envKinds (params <>) $ 520 | for_ (_indCtorArgs ctor) $ \argTy -> 521 | locally envIndDecls (decl :) $ checkKind argTy KVal 522 | where 523 | (params, k) = unfoldKArr (_indTypeKind decl) 524 | 525 | checkCoIndDecl :: 526 | ( AsScopeError e, AsKindError e, MonadError e m 527 | , MonadReader TCEnv m 528 | ) => 529 | CoIndDecl -> m () 530 | checkCoIndDecl decl = do 531 | unless (k == KComp) . throwError $ 532 | _CoinductiveShouldBeComp # (_coIndTypeName decl, k) 533 | for_ (_coIndDtors decl) $ \dtor -> 534 | locally envKinds (params <>) . 535 | locally envCoIndDecls (decl :) $ 536 | checkKind (_coIndDtorType dtor) KComp 537 | where 538 | (params, k) = unfoldKArr (_coIndTypeKind decl) 539 | 540 | checkDecl :: 541 | ( MonadReader TCEnv m 542 | , AsScopeError e, AsTypeError e, AsKindError e, MonadError e m 543 | ) => 544 | Decl -> m (Text, Exp 'V, Ty) 545 | checkDecl (Decl n e) = do 546 | ty <- infer e 547 | (n, e, ty) <$ checkKind ty KVal 548 | 549 | checkModule :: 550 | ( MonadReader TCEnv m 551 | , AsScopeError e, AsTypeError e, AsKindError e, MonadError e m 552 | ) => 553 | Module -> 554 | m () 555 | checkModule MEmpty = pure () 556 | checkModule (MDecl d rest) = do 557 | (n, e, ty) <- checkDecl d 558 | locally envDecls (Map.insert n (e, ty)) $ checkModule rest 559 | checkModule (MIndDecl d rest) = do 560 | checkIndDecl d 561 | locally envIndDecls (d :) $ checkModule rest 562 | checkModule (MCoIndDecl d rest) = do 563 | checkCoIndDecl d 564 | locally envCoIndDecls (d :) $ checkModule rest 565 | 566 | data TCError 567 | = TCScopeError ScopeError 568 | | TCompError TypeError 569 | | TCKindError KindError 570 | makePrisms ''TCError 571 | 572 | prettyTCError :: TCError -> Doc 573 | prettyTCError (TCKindError a) = prettyKindError a 574 | prettyTCError (TCompError a) = prettyTypeError a 575 | prettyTCError (TCScopeError a) = prettyScopeError a 576 | 577 | instance AsScopeError TCError where; _ScopeError = _TCScopeError 578 | instance AsTypeError TCError where; _TypeError = _TCompError 579 | instance AsKindError TCError where; _KindError = _TCKindError 580 | 581 | tc :: 582 | ( forall m e 583 | . ( AsScopeError e, AsTypeError e, AsKindError e, MonadError e m 584 | , MonadReader TCEnv m 585 | ) => 586 | m a 587 | ) -> 588 | TCEnv -> Either TCError a 589 | tc m e = runExcept (runReaderT m e) 590 | 591 | sumDecl :: IndDecl 592 | sumDecl = 593 | IndDecl 594 | { _indTypeName = "Sum" 595 | , _indTypeParams = ["a", "b"] 596 | , _indTypeKind = KArr KVal $ KArr KVal KVal 597 | , _indCtors = 598 | [ IndCtor 599 | { _indCtorName = "Left" 600 | , _indCtorArity = 1 601 | , _indCtorArgs = [TVar 0] 602 | } 603 | , IndCtor 604 | { _indCtorName = "Right" 605 | , _indCtorArity = 1 606 | , _indCtorArgs = [TVar 1] 607 | } 608 | ] 609 | } 610 | 611 | natDecl :: IndDecl 612 | natDecl = 613 | IndDecl 614 | { _indTypeName = "Nat" 615 | , _indTypeParams = [] 616 | , _indTypeKind = KVal 617 | , _indCtors = 618 | [ IndCtor 619 | { _indCtorName = "Z" 620 | , _indCtorArity = 0 621 | , _indCtorArgs = [] 622 | } 623 | , IndCtor 624 | { _indCtorName = "S" 625 | , _indCtorArity = 1 626 | , _indCtorArgs = [TCtor "Nat"] 627 | } 628 | ] 629 | } 630 | 631 | unitDecl :: IndDecl 632 | unitDecl = 633 | IndDecl 634 | { _indTypeName = "Unit" 635 | , _indTypeParams = [] 636 | , _indTypeKind = KVal 637 | , _indCtors = 638 | [ IndCtor 639 | { _indCtorName = "Unit" 640 | , _indCtorArity = 0 641 | , _indCtorArgs = [] 642 | } 643 | ] 644 | } 645 | 646 | streamDecl :: CoIndDecl 647 | streamDecl = 648 | CoIndDecl 649 | { _coIndTypeName = "Stream" 650 | , _coIndTypeParams = ["a"] 651 | , _coIndTypeKind = KArr KComp KComp 652 | , _coIndDtors = 653 | [ CoIndDtor 654 | { _coIndDtorName = "head" 655 | , _coIndDtorArity = 0 656 | , _coIndDtorArgs = [] 657 | , _coIndDtorType = TVar 0 658 | } 659 | , CoIndDtor 660 | { _coIndDtorName = "tail" 661 | , _coIndDtorArity = 0 662 | , _coIndDtorArgs = [] 663 | , _coIndDtorType = TApp (TCtor "Stream") (TVar 0) 664 | } 665 | ] 666 | } --------------------------------------------------------------------------------