├── examples ├── hello.ktn ├── hello-user.ktn ├── fizz-buzz.ktn ├── fibonacci.ktn ├── beer.ktn └── tictactoe.ktn ├── Setup.hs ├── stack.yaml ├── ftdetect └── kitten.vim ├── .gitignore ├── src ├── Report.hs ├── Main.hs └── Arguments.hs ├── lib ├── Kitten │ ├── Platform.hs │ ├── Entry │ │ ├── Category.hs │ │ ├── Merge.hs │ │ ├── Parent.hs │ │ ├── Type.hs │ │ ├── Parameter.hs │ │ └── Word.hs │ ├── Base.hs │ ├── Layoutness.hs │ ├── Indent.hs │ ├── IO.hs │ ├── Located.hs │ ├── Synonym.hs │ ├── Vocabulary.hs │ ├── Informer.hs │ ├── Quantify.hs │ ├── Declaration.hs │ ├── Queue.hs │ ├── Element.hs │ ├── DataConstructor.hs │ ├── Instantiated.hs │ ├── TypeDefinition.hs │ ├── Metadata.hs │ ├── Stack.hs │ ├── Bits.hs │ ├── Pretty.hs │ ├── Free.hs │ ├── Occurrences.hs │ ├── Kind.hs │ ├── Fragment.hs │ ├── Operator.hs │ ├── Parser.hs │ ├── Origin.hs │ ├── Instantiate.hs │ ├── TypeEnv.hs │ ├── Definition.hs │ ├── Regeneralize.hs │ ├── Substitute.hs │ ├── Zonk.hs │ ├── Literal.hs │ ├── Desugar │ │ ├── Data.hs │ │ ├── Quotations.hs │ │ └── Infix.hs │ ├── Signature.hs │ ├── Mangle.hs │ ├── Monad.hs │ ├── InstanceCheck.hs │ ├── Bracket.hs │ ├── Entry.hs │ ├── Linearize.hs │ ├── Name.hs │ ├── Dictionary.hs │ ├── Scope.hs │ └── Unify.hs └── Kitten.hs ├── test ├── Test │ ├── Common.hs │ ├── Zonk.hs │ ├── Parse.hs │ ├── InstanceCheck.hs │ ├── Origin.hs │ └── Interpret.hs └── Main.hs ├── .travis.yml ├── mini └── mini.cabal ├── syntax ├── Comments.tmPreferences ├── kitten.vim ├── kitten-mode.el ├── Kitten.JSON-tmLanguage └── Kitten.tmLanguage ├── LICENSE.md ├── doc ├── Architecture.md └── Yarn.md ├── CODE_OF_CONDUCT.md ├── README.md ├── Makefile ├── CONTRIBUTING.md └── Kitten.cabal /examples/hello.ktn: -------------------------------------------------------------------------------- 1 | "Hello, world!" say 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/hello-user.ktn: -------------------------------------------------------------------------------- 1 | "What is your name? " ask -> name; 2 | "Hello, " print 3 | name print 4 | "!" say 5 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.17 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - 'fail-4.9.0.0' 6 | flags: {} 7 | extra-package-dbs: [] 8 | -------------------------------------------------------------------------------- /ftdetect/kitten.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: Kitten 3 | " Maintainer: Jon Purdy 4 | 5 | autocmd BufNewFile,BufRead *.ktn setfiletype kitten 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.dSYM/ 2 | *.o 3 | *~ 4 | .* 5 | a.out 6 | **/cabal.sandbox.config 7 | 8 | /build 9 | /dist 10 | /test/*.actual 11 | /test/*.err.c 12 | /test/*.err.interpreted 13 | /test/*.ktn.built 14 | /test/*.ktn.c 15 | /test/*.ktn.info 16 | /test/*.out.c 17 | /test/*.out.interpreted 18 | 19 | !/.travis.yaml 20 | -------------------------------------------------------------------------------- /src/Report.hs: -------------------------------------------------------------------------------- 1 | module Report 2 | ( reportAll 3 | ) where 4 | 5 | import Kitten.Report (Report) 6 | import System.IO (hPutStrLn, stderr) 7 | import qualified Kitten.Report as Report 8 | import qualified Text.PrettyPrint as Pretty 9 | 10 | reportAll :: [Report] -> IO () 11 | reportAll = mapM_ $ hPutStrLn stderr . Pretty.render . Report.human 12 | -------------------------------------------------------------------------------- /lib/Kitten/Platform.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Platform 3 | Description : Target platform identifier 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Platform 12 | ( Platform(..) 13 | ) where 14 | 15 | data Platform = OSX 16 | -------------------------------------------------------------------------------- /test/Test/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Common 4 | ( Sign(..) 5 | , ioPermission 6 | ) where 7 | 8 | import Kitten.Name 9 | import qualified Kitten.Vocabulary as Vocabulary 10 | 11 | data Sign = Negative | Positive 12 | deriving (Eq, Ord, Show) 13 | 14 | ioPermission :: [GeneralName] 15 | ioPermission = [QualifiedName $ Qualified Vocabulary.global "IO"] 16 | -------------------------------------------------------------------------------- /lib/Kitten/Entry/Category.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry.Category 3 | Description : Types of dictionary entries 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Entry.Category 12 | ( Category(..) 13 | ) where 14 | 15 | data Category 16 | = Constructor 17 | | Instance 18 | | Permission 19 | | Word 20 | deriving (Eq, Show) 21 | -------------------------------------------------------------------------------- /examples/fizz-buzz.ktn: -------------------------------------------------------------------------------- 1 | define divisible (Int32, Int32 -> Bool +Fail): 2 | (%) 0 (=) 3 | 4 | define fizzbuzz (Int32 -> List): 5 | -> n; 6 | do (with (+Fail)): 7 | n 5 divisible 8 | n 3 divisible 9 | 10 | if: 11 | if: "FizzBuzz" 12 | else: "Fizz" 13 | else: 14 | if: "Buzz" 15 | else: n show 16 | 17 | define fizzbuzzes (Int32, Int32 -> +IO): 18 | -> c, m; 19 | c fizzbuzz say 20 | if (c < m): (c + 1) m fizzbuzzes 21 | 22 | 1 100 fizzbuzzes 23 | -------------------------------------------------------------------------------- /lib/Kitten/Base.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Base 3 | Description : Numeric literal bases 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Base 12 | ( Base(..) 13 | ) where 14 | 15 | -- | The radix of an integer literal. 16 | 17 | data Base 18 | -- | @0b@ 19 | = Binary 20 | -- | @0o@ 21 | | Octal 22 | -- | No prefix. 23 | | Decimal 24 | -- | @0x@ 25 | | Hexadecimal 26 | deriving (Show) 27 | -------------------------------------------------------------------------------- /lib/Kitten/Layoutness.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Layoutness 3 | Description : Whether a block is a layout block 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Layoutness 12 | ( Layoutness(..) 13 | ) where 14 | 15 | -- | A display hint for whether a block was originally written with 'Layout' 16 | -- (@:@) or 'Nonlayout' (@{}@) syntax. 17 | 18 | data Layoutness = Layout | Nonlayout 19 | deriving (Show) 20 | -------------------------------------------------------------------------------- /lib/Kitten/Indent.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Indent 3 | Description : Indent levels 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | 13 | module Kitten.Indent 14 | ( Indent(..) 15 | ) where 16 | 17 | import Text.Parsec (Column) 18 | 19 | -- | The indent level of a token, defined as the first column of the first token 20 | -- in the same line. 21 | 22 | newtype Indent = Indent Column 23 | deriving (Eq, Ord, Show) 24 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | branches: 4 | only: 5 | - master 6 | 7 | sudo: false 8 | 9 | cache: 10 | directories: 11 | - $HOME/.stack/ 12 | 13 | before_install: 14 | - mkdir -p ~/.local/bin 15 | - export PATH=~/.local/bin:$PATH 16 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 17 | - chmod a+x ~/.local/bin/stack 18 | 19 | install: 20 | - travis_wait stack +RTS -N2 -RTS setup 21 | - travis_wait stack +RTS -N2 -RTS build 22 | 23 | script: 24 | - stack --no-terminal --skip-ghc-check test 25 | -------------------------------------------------------------------------------- /lib/Kitten/IO.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.IO 3 | Description : I/O utilities 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.IO 12 | ( readFileUtf8 13 | ) where 14 | 15 | import Data.Text (Text) 16 | import qualified Data.ByteString as ByteString 17 | import qualified Data.Text.Encoding as Text 18 | 19 | -- | Read a UTF-8-encoded source file and decode it to UTF-16 'Text'. 20 | 21 | readFileUtf8 :: FilePath -> IO Text 22 | readFileUtf8 = fmap Text.decodeUtf8 . ByteString.readFile 23 | -------------------------------------------------------------------------------- /lib/Kitten/Entry/Merge.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry.Merge 3 | Description : Merge behavior for dictionary entries 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Entry.Merge 12 | ( Merge(..) 13 | ) where 14 | 15 | -- | When adding a definition to the dictionary, if an existing definition has 16 | -- the same name, the default 'Merge' behavior of 'Deny' raises an error, while 17 | -- 'Compose' composes the bodies of the two definitions. 18 | 19 | data Merge = Deny | Compose 20 | deriving (Eq, Show) 21 | -------------------------------------------------------------------------------- /lib/Kitten/Located.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Located 3 | Description : Imbuing a value with a location 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Located 12 | ( Located(..) 13 | ) where 14 | 15 | import Kitten.Indent (Indent) 16 | import Kitten.Origin (Origin) 17 | 18 | -- | Imbues a value (such as a 'Token') with an origin and indent level. 19 | 20 | data Located a = At 21 | { origin :: !Origin 22 | , indent :: !Indent 23 | , item :: a 24 | } 25 | 26 | instance (Show a) => Show (Located a) where 27 | show = show . item 28 | -------------------------------------------------------------------------------- /lib/Kitten/Synonym.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Synonym 3 | Description : Aliases 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Synonym 14 | ( Synonym(..) 15 | ) where 16 | 17 | import Kitten.Name (GeneralName, Qualified) 18 | import Kitten.Origin (Origin) 19 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 20 | 21 | data Synonym = Synonym !Qualified !GeneralName !Origin 22 | deriving (Show) 23 | 24 | -- FIXME: Real instance. 25 | instance Pretty Synonym where 26 | pPrint _ = "synonym" 27 | -------------------------------------------------------------------------------- /lib/Kitten/Vocabulary.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Vocabulary 3 | Description : Namespaces 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Vocabulary 14 | ( global 15 | , intrinsic 16 | , intrinsicName 17 | ) where 18 | 19 | import Data.Text (Text) 20 | import Kitten.Name (Qualifier(..), Root(..)) 21 | 22 | global :: Qualifier 23 | global = Qualifier Absolute [] 24 | 25 | intrinsic :: Qualifier 26 | intrinsic = Qualifier Absolute [intrinsicName] 27 | 28 | intrinsicName :: Text 29 | intrinsicName = "kitten" 30 | -------------------------------------------------------------------------------- /mini/mini.cabal: -------------------------------------------------------------------------------- 1 | -- Initial mini.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: mini 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | author: Jon Purdy 10 | maintainer: evincarofautumn@gmail.com 11 | -- copyright: 12 | category: Language 13 | build-type: Simple 14 | -- extra-source-files: 15 | cabal-version: >=1.10 16 | 17 | executable mini 18 | main-is: Main.hs 19 | build-depends: base >=4.8, transformers, containers, text, HUnit, hspec, parsec 20 | default-language: Haskell2010 21 | -------------------------------------------------------------------------------- /examples/fibonacci.ktn: -------------------------------------------------------------------------------- 1 | define fib_naive (UInt64 -> UInt64): 2 | -> n; 3 | if (n <= 1u64): 4 | 1u64 5 | else: 6 | (n - 2u64) fib_naive + (n - 1u64) fib_naive 7 | 8 | define fib_tailrec (UInt64 -> UInt64): 9 | 1u64 1u64 fib_tailrec_helper 10 | 11 | define fib_tailrec_helper (UInt64, UInt64, UInt64 -> UInt64): 12 | -> n, a, b; 13 | if (n = 0u64): 14 | a 15 | elif (n = 1u64): 16 | b 17 | else: 18 | (n - 1u64) b (a + b) fib_tailrec_helper 19 | 20 | define fib_fix (UInt64 -> UInt64): 21 | do (fix) -> n, rec: 22 | if (n <= 1u64): 23 | 1u64 24 | else: 25 | (n - 2u64) rec call -> a; 26 | (n - 1u64) rec call -> b; 27 | a + b 28 | 29 | define test ((UInt64 -> UInt64) -> +IO): 30 | 10u64 swap call say 31 | 32 | [\fib_naive, \fib_tailrec, \fib_fix] \test each 33 | -------------------------------------------------------------------------------- /lib/Kitten/Informer.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Informer 3 | Description : Error-reporting monad 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Informer 12 | ( Informer(..) 13 | ) where 14 | 15 | import Kitten.Origin (Origin) 16 | import Kitten.Report (Report) 17 | import qualified Text.PrettyPrint as Pretty 18 | 19 | -- | Class of error-reporting monads. 20 | 21 | class (Monad m) => Informer m where 22 | -- | Halt if there are any fatal reports. 23 | checkpoint :: m () 24 | -- | Halt the computation. 25 | halt :: m a 26 | -- | Add a report to the log. 27 | report :: Report -> m () 28 | -- | Add local context to reports. 29 | while :: Origin -> Pretty.Doc -> m a -> m a 30 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import Test.Hspec (Spec, describe, hspec) 6 | import qualified Test.Infer 7 | import qualified Test.InstanceCheck 8 | import qualified Test.Interpret 9 | import qualified Test.Origin 10 | import qualified Test.Parse 11 | import qualified Test.Resolve 12 | import qualified Test.Tokenize 13 | import qualified Test.Zonk 14 | 15 | main :: IO () 16 | main = hspec spec 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "tokenization" Test.Tokenize.spec 21 | describe "source locations" Test.Origin.spec 22 | describe "parsing" Test.Parse.spec 23 | describe "name resolution" Test.Resolve.spec 24 | describe "instance checking" Test.InstanceCheck.spec 25 | describe "type inference" Test.Infer.spec 26 | describe "zonking" Test.Zonk.spec 27 | describe "interpretation" Test.Interpret.spec 28 | -------------------------------------------------------------------------------- /lib/Kitten/Quantify.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Quantify 3 | Description : Quantifying generic terms 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Quantify 12 | ( term 13 | ) where 14 | 15 | import Kitten.Term (Term(..)) 16 | import Kitten.Type (Type(..), Var(..)) 17 | import qualified Kitten.Kind as Kind 18 | 19 | -- | Copies the top-level generic value-kinded type quantifiers from a polytype 20 | -- to an expression, thereby making the expression generic, e.g.: 21 | -- 22 | -- > dup, ∀α:ρ. ∀β:*. ∀γ:ε. (α × β → α × β × β) ε 23 | -- > 24 | -- > Λβ:*. dup 25 | 26 | term :: Type -> Term a -> Term a 27 | term (Forall origin (Var name x Kind.Value) t) e = Generic name x (term t e) origin 28 | term (Forall _ _ t) e = term t e 29 | term _ e = e 30 | -------------------------------------------------------------------------------- /lib/Kitten/Declaration.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Declaration 3 | Description : Declarations of intrinsics and traits 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Declaration 12 | ( Category(..) 13 | , Declaration(..) 14 | ) where 15 | 16 | import Kitten.Name (Qualified) 17 | import Kitten.Origin (Origin) 18 | import Kitten.Signature (Signature) 19 | 20 | -- | The type of declaration. 21 | 22 | data Category 23 | -- | @intrinsic@, a built-in/external function. 24 | = Intrinsic 25 | -- | @trait@, a generic function. 26 | | Trait 27 | deriving (Eq, Show) 28 | 29 | data Declaration = Declaration 30 | { category :: !Category 31 | , name :: !Qualified 32 | , origin :: !Origin 33 | , signature :: !Signature 34 | } deriving (Show) 35 | -------------------------------------------------------------------------------- /examples/beer.ktn: -------------------------------------------------------------------------------- 1 | 99 bottles_of_beer_on_the_wall 2 | 3 | define bottles_of_beer_on_the_wall (Int32 -> +IO): 4 | -> n; 5 | n th_verse 6 | if (n > 1): (n - 1) bottles_of_beer_on_the_wall 7 | 8 | define th_verse (Int32 -> +IO): 9 | -> n; 10 | n bottles_of_beer on_the_wall say 11 | n bottles_of_beer say 12 | take_one_down_pass_it_around say 13 | (n - 1) bottles_of_beer on_the_wall say 14 | newline 15 | 16 | define bottles_of_beer (Int32 -> List): 17 | bottles " of beer" cat 18 | 19 | define on_the_wall (List -> List): 20 | " on the wall" cat 21 | 22 | define take_one_down_pass_it_around (-> List): 23 | "take one down, pass it around" 24 | 25 | define bottles (Int32 -> List): 26 | -> n; 27 | if (n = 0): 28 | "no more bottles" 29 | elif (n = 1): 30 | "one bottle" 31 | else: 32 | n show " bottles" cat 33 | -------------------------------------------------------------------------------- /lib/Kitten/Queue.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Queue 3 | Description : Queue utilities 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Queue 12 | ( Queue 13 | , dequeue 14 | , empty 15 | , enqueue 16 | , fromList 17 | ) where 18 | 19 | -- | A generic queue with amortized O(1) enqueue/dequeue. 20 | 21 | data Queue a = Queue [a] [a] 22 | 23 | dequeue :: Queue a -> Maybe (a, Queue a) 24 | dequeue (Queue i (x : o)) = Just (x, Queue i o) 25 | dequeue (Queue i@(_ : _) []) = dequeue (Queue [] (reverse i)) 26 | dequeue (Queue [] []) = Nothing 27 | 28 | empty :: Queue a 29 | empty = Queue [] [] 30 | 31 | enqueue :: a -> Queue a -> Queue a 32 | enqueue x (Queue i o) = Queue (x : i) o 33 | 34 | fromList :: [a] -> Queue a 35 | fromList = Queue [] . reverse 36 | -------------------------------------------------------------------------------- /lib/Kitten/Entry/Parent.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry.Parent 3 | Description : Links to parent entries 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Entry.Parent 14 | ( Parent(..) 15 | ) where 16 | 17 | import Kitten.Name (Qualified) 18 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 19 | import qualified Kitten.Pretty as Pretty 20 | import qualified Text.PrettyPrint as Pretty 21 | 22 | -- | A parent trait (of an instance) or data type (of a constructor). 23 | 24 | data Parent 25 | = Trait !Qualified 26 | | Type !Qualified 27 | deriving (Show) 28 | 29 | instance Pretty Parent where 30 | pPrint parent = Pretty.hsep $ case parent of 31 | Trait name -> ["trait", Pretty.quote name] 32 | Type name -> ["type", Pretty.quote name] 33 | -------------------------------------------------------------------------------- /lib/Kitten/Element.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Element 3 | Description : Top-level program elements 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Element 12 | ( Element(..) 13 | ) where 14 | 15 | import Kitten.Declaration (Declaration) 16 | import Kitten.Definition (Definition) 17 | import Kitten.Metadata (Metadata) 18 | import Kitten.Synonym (Synonym) 19 | import Kitten.Term (Term) 20 | import Kitten.TypeDefinition (TypeDefinition) 21 | 22 | -- | A top-level program element. 23 | 24 | data Element a 25 | -- | @intrinsic@, @trait@ 26 | = Declaration !Declaration 27 | -- | @define@, @instance@ 28 | | Definition !(Definition a) 29 | -- | @about@ 30 | | Metadata !Metadata 31 | -- | @synonym@ 32 | | Synonym !Synonym 33 | -- | Top-level (@main@) code. 34 | | Term !(Term a) 35 | -- | @type@ 36 | | TypeDefinition !TypeDefinition 37 | -------------------------------------------------------------------------------- /lib/Kitten/DataConstructor.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.DataConstructor 3 | Description : Constructors of data types 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.DataConstructor 14 | ( DataConstructor(..) 15 | ) where 16 | 17 | import Kitten.Name (Unqualified) 18 | import Kitten.Origin (Origin) 19 | import Kitten.Signature (Signature) 20 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 21 | import qualified Text.PrettyPrint as Pretty 22 | 23 | -- | A single data constructor case, e.g., @case some (T)@. 24 | 25 | data DataConstructor = DataConstructor 26 | { fields :: [Signature] 27 | , name :: !Unqualified 28 | , origin :: !Origin 29 | } deriving (Show) 30 | 31 | -- FIXME: Support fields. 32 | instance Pretty DataConstructor where 33 | pPrint constructor = "case" 34 | Pretty.<+> pPrint (name constructor) 35 | -------------------------------------------------------------------------------- /test/Test/Zonk.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Zonk 4 | ( spec 5 | ) where 6 | 7 | import Kitten.Kind (Kind(..)) 8 | import Kitten.Type (Type(..), TypeId(..), Var(..)) 9 | import Test.Hspec (Spec, it, shouldBe) 10 | import qualified Data.Map as Map 11 | import qualified Kitten.Origin as Origin 12 | import qualified Kitten.TypeEnv as TypeEnv 13 | import qualified Kitten.Zonk as Zonk 14 | 15 | spec :: Spec 16 | spec = do 17 | it "does nothing to free type variables" $ do 18 | Zonk.type_ TypeEnv.empty va `shouldBe` va 19 | it "substitutes one level" $ do 20 | Zonk.type_ TypeEnv.empty { TypeEnv.tvs = Map.singleton ia vb } va `shouldBe` vb 21 | it "substitutes multiple levels" $ do 22 | Zonk.type_ TypeEnv.empty { TypeEnv.tvs = Map.fromList [(ia, vb), (ib, int)] } va `shouldBe` int 23 | where 24 | o = Origin.point "" 0 0 25 | ia = TypeId 0 26 | va = TypeVar o $ Var "A" ia kv 27 | ib = TypeId 1 28 | vb = TypeVar o $ Var "B" ib kv 29 | kv = Value 30 | int = TypeConstructor o "Int32" 31 | -------------------------------------------------------------------------------- /lib/Kitten/Entry/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry.Type 3 | Description : Type definition entries 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Entry.Type 12 | ( Entry(..) 13 | ) where 14 | 15 | import Data.HashMap.Strict (HashMap) 16 | import Kitten.Kind (Kind) 17 | import Kitten.Name (Qualified, Unqualified) 18 | import Kitten.Origin (Origin) 19 | import Kitten.Term (Term) 20 | 21 | data Entry = Entry 22 | 23 | -- The names of the constructors of this type. 24 | 25 | { constructors :: [Qualified] 26 | 27 | -- Whether this type is visible outside its vocabulary. 28 | 29 | , export :: !Bool 30 | 31 | -- User-defined metadata. 32 | 33 | , metadata :: !(HashMap Unqualified (Term ())) 34 | 35 | -- Source location. 36 | 37 | , origin :: !Origin 38 | 39 | -- Type parameters, for a generic definition. 40 | 41 | , parameters :: [(Unqualified, Kind, Origin)] 42 | 43 | } deriving (Show) 44 | -------------------------------------------------------------------------------- /lib/Kitten/Instantiated.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Instantiated 3 | Description : Fully qualified instantiated names 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Instantiated 14 | ( Instantiated(..) 15 | ) where 16 | 17 | import Data.Hashable (Hashable(..)) 18 | import Kitten.Name (Qualified) 19 | import Kitten.Type (Type) 20 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 21 | import qualified Kitten.Pretty as Pretty 22 | import qualified Text.PrettyPrint as Pretty 23 | 24 | data Instantiated = Instantiated 25 | { name :: !Qualified 26 | , types :: [Type] 27 | } deriving (Eq, Show) 28 | 29 | instance Hashable Instantiated where 30 | hashWithSalt s (Instantiated n ts) 31 | = hashWithSalt s (0 :: Int, n, ts) 32 | 33 | instance Pretty Instantiated where 34 | pPrint (Instantiated n ts) = Pretty.hcat 35 | [pPrint n, "::<", Pretty.list $ map pPrint ts, ">"] 36 | -------------------------------------------------------------------------------- /syntax/Comments.tmPreferences: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | name 6 | Comments 7 | scope 8 | source.kitten 9 | settings 10 | 11 | shellVariables 12 | 13 | 14 | name 15 | TM_COMMENT_START 16 | value 17 | // 18 | 19 | 20 | name 21 | TM_COMMENT_START_2 22 | value 23 | /* 24 | 25 | 26 | name 27 | TM_COMMENT_END_2 28 | value 29 | */ 30 | 31 | 32 | 33 | uuid 34 | 99FB23BA-DD49-447F-9F1A-FF07630CB940 35 | 36 | 37 | -------------------------------------------------------------------------------- /lib/Kitten/TypeDefinition.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.TypeDefinition 3 | Description : Definitions of types 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.TypeDefinition 14 | ( TypeDefinition(..) 15 | ) where 16 | 17 | import Kitten.DataConstructor (DataConstructor) 18 | import Kitten.Entry.Parameter (Parameter) 19 | import Kitten.Name (Qualified) 20 | import Kitten.Origin (Origin) 21 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 22 | import qualified Text.PrettyPrint as Pretty 23 | 24 | data TypeDefinition = TypeDefinition 25 | { constructors :: [DataConstructor] 26 | , name :: !Qualified 27 | , origin :: !Origin 28 | , parameters :: [Parameter] 29 | } deriving (Show) 30 | 31 | -- FIXME: Support parameters. 32 | instance Pretty TypeDefinition where 33 | pPrint definition = Pretty.vcat 34 | [ "type" 35 | Pretty.<+> pPrint (name definition) 36 | Pretty.<> ":" 37 | , Pretty.nest 4 $ Pretty.vcat $ map pPrint $ constructors definition 38 | ] 39 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Kitten is distributed under the terms of the MIT License. 2 | 3 | Copyright (C) 2012 Jon Purdy 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the “Software”), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /lib/Kitten/Entry/Parameter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry.Parameter 3 | Description : Type parameters 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Entry.Parameter 14 | ( Parameter(..) 15 | ) where 16 | 17 | import Kitten.Kind (Kind(..)) 18 | import Kitten.Name (Unqualified) 19 | import Kitten.Origin (Origin) 20 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 21 | import qualified Text.PrettyPrint as Pretty 22 | 23 | -- | A generic type parameter for a data type, like @T@ in @List@. 24 | 25 | data Parameter = Parameter !Origin !Unqualified !Kind 26 | deriving (Show) 27 | 28 | -- | Parameters are compared regardless of origin. 29 | 30 | instance Eq Parameter where 31 | Parameter _ a b == Parameter _ c d = (a, b) == (c, d) 32 | 33 | instance Pretty Parameter where 34 | pPrint (Parameter _ name kind) = case kind of 35 | Value -> pPrint name 36 | Stack -> Pretty.hcat [pPrint name, "..."] 37 | Label -> Pretty.hcat ["+", pPrint name] 38 | Permission -> Pretty.hcat ["+", pPrint name] 39 | _ :-> _ -> Pretty.hcat [pPrint name, "<_>"] 40 | -------------------------------------------------------------------------------- /lib/Kitten/Metadata.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Metadata 3 | Description : Metadata about identifiers in the dictionary 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Metadata 14 | ( Metadata(..) 15 | ) where 16 | 17 | import Data.HashMap.Strict (HashMap) 18 | import Kitten.Name (GeneralName, Unqualified) 19 | import Kitten.Origin (Origin) 20 | import Kitten.Term (Term) 21 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 22 | import qualified Data.HashMap.Strict as HashMap 23 | import qualified Text.PrettyPrint as Pretty 24 | 25 | -- | Untyped metadata from @about@ blocks. 26 | 27 | data Metadata = Metadata 28 | { fields :: !(HashMap Unqualified (Term ())) 29 | , name :: !GeneralName 30 | , origin :: !Origin 31 | } deriving (Show) 32 | 33 | instance Pretty Metadata where 34 | pPrint metadata = Pretty.vcat 35 | [ Pretty.hcat ["about ", pPrint $ name metadata, ":"] 36 | , Pretty.nest 4 $ Pretty.vcat $ map field $ HashMap.toList 37 | $ fields metadata 38 | ] 39 | where 40 | field (key, value) = Pretty.vcat 41 | [ Pretty.hcat [pPrint key, ":"] 42 | , Pretty.nest 4 $ pPrint value 43 | ] 44 | -------------------------------------------------------------------------------- /lib/Kitten/Stack.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Stack 3 | Description : Strict stack 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE DeriveFoldable #-} 12 | {-# LANGUAGE DeriveFunctor #-} 13 | 14 | module Kitten.Stack 15 | ( Stack(..) 16 | , empty 17 | , fromList 18 | , pop 19 | , pop' 20 | , pops 21 | , pushes 22 | ) where 23 | 24 | -- | A stack with strictly evaluated elements and spine. 25 | data Stack a = Bottom | !a ::: !(Stack a) 26 | deriving (Functor, Foldable) 27 | 28 | infixr 5 ::: 29 | 30 | empty :: Stack a -> Bool 31 | empty Bottom = True 32 | empty _ = False 33 | 34 | fromList :: [a] -> Stack a 35 | fromList = foldr (:::) Bottom 36 | 37 | pop :: Stack a -> Maybe (a, Stack a) 38 | pop Bottom = Nothing 39 | pop (a ::: s) = Just (a, s) 40 | 41 | pop' :: Stack a -> Stack a 42 | pop' Bottom = error "Kitten.Stack.drop: empty stack" 43 | pop' (_ ::: s) = s 44 | 45 | pushes :: [a] -> Stack a -> Stack a 46 | pushes xs s = foldr (:::) s xs 47 | 48 | pops :: Int -> Stack a -> ([a], Stack a) 49 | pops n s 50 | | n <= 0 = ([], s) 51 | | otherwise = case s of 52 | Bottom -> ([], s) 53 | a ::: s' -> let 54 | (as, s'') = pops (n - 1) s' 55 | in (a : as, s'') 56 | -------------------------------------------------------------------------------- /lib/Kitten/Bits.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Bits 3 | Description : Fixed-size Kitten types 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Bits 14 | ( FloatBits(..) 15 | , IntegerBits(..) 16 | ) where 17 | 18 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 19 | 20 | -- | Standard sizes of fixed-precision floating-point numbers. 21 | 22 | data FloatBits 23 | -- | @f32@ 24 | = Float32 25 | -- | @f64@ 26 | | Float64 27 | deriving (Eq, Show) 28 | 29 | -- | Standard sizes of fixed-precision integer numbers. 30 | 31 | data IntegerBits 32 | -- | @i8@ 33 | = Signed8 34 | | Signed16 35 | | Signed32 36 | | Signed64 37 | | Unsigned8 38 | | Unsigned16 39 | | Unsigned32 40 | | Unsigned64 41 | deriving (Eq, Show) 42 | 43 | instance Pretty IntegerBits where 44 | pPrint bits = case bits of 45 | Signed8 -> "i8" 46 | Signed16 -> "i16" 47 | Signed32 -> "i32" 48 | Signed64 -> "i64" 49 | Unsigned8 -> "u8" 50 | Unsigned16 -> "u16" 51 | Unsigned32 -> "u32" 52 | Unsigned64 -> "u64" 53 | 54 | instance Pretty FloatBits where 55 | pPrint bits = case bits of 56 | Float32 -> "f32" 57 | Float64 -> "f64" 58 | -------------------------------------------------------------------------------- /lib/Kitten/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Pretty 3 | Description : Pretty-printing utilities 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Pretty 14 | ( angles 15 | , asDefinition 16 | , list 17 | , oxford 18 | , quote 19 | , vsep 20 | ) where 21 | 22 | import Data.List (intersperse) 23 | import Text.PrettyPrint 24 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 25 | 26 | angles :: Doc -> Doc 27 | angles doc = hcat [char '<', doc, char '>'] 28 | 29 | list :: [Doc] -> Doc 30 | list = hcat . intersperse ", " 31 | 32 | oxford :: Doc -> [Doc] -> Doc 33 | oxford conjunction = go 34 | where 35 | go :: [Doc] -> Doc 36 | go [] = "" 37 | go [x] = x 38 | go [x, y] = hsep [x, conjunction, y] 39 | go [x, y, z] = hcat [x, ", ", y, ", ", conjunction, " ", z] 40 | go (x : xs) = hcat [x, ", ", go xs] 41 | 42 | quote :: (Pretty a) => a -> Doc 43 | quote = quotes . pPrint 44 | 45 | vsep :: [Doc] -> Doc 46 | vsep = vcat . intersperse "" 47 | 48 | asDefinition :: Doc -> Doc -> Doc-> Doc -> Doc 49 | asDefinition name signature body keyword = vcat 50 | [ hcat 51 | [hsep [keyword, name, signature], ":"] 52 | , nest 4 body 53 | ] 54 | -------------------------------------------------------------------------------- /lib/Kitten/Free.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Free 3 | Description : Free variables of a type 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Free 12 | ( tvs 13 | , tvks 14 | ) where 15 | 16 | import Data.Map (Map) 17 | import Data.Set (Set) 18 | import Kitten.Kind (Kind) 19 | import Kitten.Name (Unqualified) 20 | import Kitten.Type (Type(..), TypeId, Var(..)) 21 | import Kitten.TypeEnv (TypeEnv) 22 | import qualified Data.Map as Map 23 | import qualified Data.Set as Set 24 | import qualified Kitten.Zonk as Zonk 25 | 26 | -- | Just the free variables of a type, without their kinds. 27 | 28 | tvs :: TypeEnv -> Type -> Set TypeId 29 | tvs tenv0 = Set.fromList . Map.keys . tvks tenv0 30 | 31 | -- | Finds free variables (those not bound by any quantifier) and returns them 32 | -- along with their kinds. 33 | 34 | tvks :: TypeEnv -> Type -> Map TypeId (Unqualified, Kind) 35 | tvks tenv = go . Zonk.type_ tenv 36 | where 37 | go t = case t of 38 | TypeConstructor{} -> Map.empty 39 | TypeVar _ (Var name i k) -> Map.singleton i (name, k) 40 | TypeConstant{} -> Map.empty 41 | Forall _ (Var _name i _) t' -> Map.delete i $ go t' 42 | a :@ b -> Map.union (go a) (go b) 43 | TypeValue{} -> Map.empty 44 | -------------------------------------------------------------------------------- /lib/Kitten/Occurrences.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Occurrences 3 | Description : Occurrences of a variable in a type 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Occurrences 12 | ( occurrences 13 | , occurs 14 | ) where 15 | 16 | import Kitten.Type (Type(..), TypeId, Var(..)) 17 | import Kitten.TypeEnv (TypeEnv) 18 | import qualified Data.Map as Map 19 | import qualified Kitten.TypeEnv as TypeEnv 20 | 21 | -- | We need to be able to count occurrences of a type variable in a type, not 22 | -- just check for its presence. This is for two reasons: to prevent infinite 23 | -- types (the \"occurs check\"), and to determine whether a stack variable can 24 | -- be generalized to a higher rank. (See "Kitten.Regeneralize".) 25 | 26 | occurrences :: TypeEnv -> TypeId -> Type -> Int 27 | occurrences tenv0 x = recur 28 | where 29 | recur t = case t of 30 | TypeConstructor{} -> 0 31 | TypeValue{} -> error "TODO: occurrences type value" 32 | TypeVar _ (Var _name y _) -> case Map.lookup y (TypeEnv.tvs tenv0) of 33 | Nothing -> if x == y then 1 else 0 34 | Just t' -> recur t' 35 | TypeConstant{} -> 0 36 | Forall _ (Var _name x' _) t' -> if x == x' then 0 else recur t' 37 | a :@ b -> recur a + recur b 38 | 39 | occurs :: TypeEnv -> TypeId -> Type -> Bool 40 | occurs tenv0 x t = occurrences tenv0 x t > 0 41 | -------------------------------------------------------------------------------- /lib/Kitten/Kind.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Kind 3 | Description : The kinds of types 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Kind 14 | ( Kind(..) 15 | ) where 16 | 17 | import Data.Hashable (Hashable(..)) 18 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 19 | import qualified Text.PrettyPrint as Pretty 20 | 21 | -- | A kind (κ) is the type of a type. Types with the \"value\" kind (@*@) are 22 | -- inhabited by values; all other types are used only to enforce program 23 | -- invariants. These include: 24 | -- 25 | -- • The \"stack\" kind (ρ), used to enforce that the stack cannot contain 26 | -- other stacks. 27 | -- 28 | -- • The \"permission label\" kind (λ), used to identify a permission. 29 | -- 30 | -- • The \"permission\" kind (ε), denoting a set of permissions. 31 | -- 32 | -- • The \"function\" kind (κ → κ), used to describe type constructors. 33 | 34 | data Kind = Value | Stack | Label | Permission | !Kind :-> !Kind 35 | deriving (Eq, Show) 36 | 37 | instance Hashable Kind where 38 | hashWithSalt s kind = case kind of 39 | Value -> hashWithSalt s (0 :: Int) 40 | Stack -> hashWithSalt s (1 :: Int) 41 | Label -> hashWithSalt s (2 :: Int) 42 | Permission -> hashWithSalt s (3 :: Int) 43 | a :-> b -> hashWithSalt s (4 :: Int, a, b) 44 | 45 | instance Pretty Kind where 46 | pPrint kind = case kind of 47 | Value -> "value" 48 | Stack -> "stack" 49 | Label -> "label" 50 | Permission -> "permission" 51 | a :-> b -> Pretty.parens $ Pretty.hsep 52 | [pPrint a, "->", pPrint b] 53 | -------------------------------------------------------------------------------- /lib/Kitten/Fragment.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Fragment 3 | Description : Program fragments 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Fragment 12 | ( Fragment(..) 13 | ) where 14 | 15 | import Data.Semigroup (Semigroup (..)) 16 | import Kitten.Declaration (Declaration) 17 | import Kitten.Definition (Definition) 18 | import Kitten.Metadata (Metadata) 19 | import Kitten.Synonym (Synonym) 20 | import Kitten.TypeDefinition (TypeDefinition) 21 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 22 | import qualified Kitten.Pretty as Pretty 23 | 24 | -- | A program fragment, consisting of a bag of top-level program elements. 25 | 26 | data Fragment a = Fragment 27 | { declarations :: [Declaration] 28 | , definitions :: [Definition a] 29 | , metadata :: [Metadata] 30 | , synonyms :: [Synonym] 31 | , types :: [TypeDefinition] 32 | } deriving (Show) 33 | 34 | instance Monoid (Fragment a) where 35 | mempty = Fragment 36 | { declarations = [] 37 | , definitions = [] 38 | , metadata = [] 39 | , synonyms = [] 40 | , types = [] 41 | } 42 | mappend = (<>) 43 | 44 | instance Semigroup (Fragment a) where 45 | (<>) a b = Fragment 46 | { declarations = declarations a ++ declarations b 47 | , definitions = definitions a ++ definitions b 48 | , metadata = metadata a ++ metadata b 49 | , synonyms = synonyms a ++ synonyms b 50 | , types = types a ++ types b 51 | } 52 | 53 | instance Pretty (Fragment a) where 54 | pPrint fragment = Pretty.vsep $ concat 55 | [ map pPrint $ definitions fragment 56 | , map pPrint $ metadata fragment 57 | , map pPrint $ synonyms fragment 58 | , map pPrint $ types fragment 59 | ] 60 | -------------------------------------------------------------------------------- /lib/Kitten.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten 3 | Description : Compiler pipeline 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten 14 | ( Enter.fragmentFromSource 15 | , compile 16 | , runKitten 17 | , tokenize 18 | ) where 19 | 20 | import Control.Monad 21 | import Control.Monad.IO.Class 22 | import Kitten.CollectInstantiations (collectInstantiations) 23 | import Kitten.Dictionary (Dictionary) 24 | import Kitten.Monad (K, runKitten) 25 | import Kitten.Name 26 | import Kitten.Tokenize (tokenize) 27 | import Text.Parsec.Text () 28 | import qualified Kitten.Dictionary as Dictionary 29 | import qualified Kitten.Enter as Enter 30 | import qualified Kitten.IO as IO 31 | 32 | -- | This is a simple wrapper for the compiler pipeline. It adds a list of 33 | -- program fragments to the dictionary from a list of source paths. At each 34 | -- stage, errors and warnings (\"reports\") are accumulated, and reported to the 35 | -- programmer at the next checkpoint; see "Kitten.Monad" for details. 36 | 37 | compile 38 | :: [GeneralName] 39 | -- ^ List of permissions to grant to @main@. 40 | -> Maybe Qualified 41 | -- ^ Override the default name of @main@. 42 | -> [FilePath] 43 | -- ^ List of source file paths. 44 | -> K Dictionary 45 | -- ^ Resulting dictionary. 46 | compile mainPermissions mainName paths = do 47 | 48 | -- Source files must be encoded in UTF-8. 49 | 50 | sources <- liftIO $ mapM IO.readFileUtf8 paths 51 | parsed <- mconcat <$> zipWithM 52 | (Enter.fragmentFromSource mainPermissions mainName 1) 53 | paths sources 54 | -- dictionary <- 55 | Enter.fragment parsed Dictionary.empty 56 | -- collectInstantiations dictionary 57 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Arguments (Arguments, parseArguments) 6 | import Control.Monad (void) 7 | import Kitten (compile, runKitten) 8 | import Kitten.Interpret (interpret) 9 | import Kitten.Name (GeneralName(..), Qualified(..)) 10 | import Paths_Kitten 11 | import Report 12 | import System.Exit 13 | import System.IO 14 | import qualified Arguments 15 | import qualified Interact 16 | import qualified Kitten.Vocabulary as Vocabulary 17 | 18 | main :: IO () 19 | main = do 20 | hSetEncoding stdout utf8 21 | arguments <- parseArguments 22 | case Arguments.inputPaths arguments of 23 | [] -> case Arguments.compileMode arguments of 24 | Arguments.CheckMode -> do 25 | hPutStrLn stderr "Cannot run interactively in check mode." 26 | exitFailure 27 | Arguments.CompileMode{} -> do 28 | hPutStrLn stderr "Cannot run interactively in compile mode." 29 | exitFailure 30 | Arguments.InterpretMode -> Interact.run 31 | _ -> runBatch arguments 32 | 33 | runBatch :: Arguments -> IO () 34 | runBatch arguments = do 35 | let paths = Arguments.inputPaths arguments 36 | commonPath <- getDataFileName "common.ktn" 37 | result <- runKitten $ compile mainPermissions Nothing (commonPath : paths) 38 | case result of 39 | Left reports -> do 40 | reportAll reports 41 | exitFailure 42 | Right program -> case Arguments.compileMode arguments of 43 | Arguments.CheckMode -> return () 44 | Arguments.CompileMode _format -> return () 45 | Arguments.InterpretMode -> void $ interpret program 46 | Nothing [] stdin stdout stderr [] 47 | where 48 | mainPermissions = 49 | [ QualifiedName $ Qualified Vocabulary.global "IO" 50 | , QualifiedName $ Qualified Vocabulary.global "Fail" 51 | ] 52 | -------------------------------------------------------------------------------- /lib/Kitten/Entry/Word.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry.Word 3 | Description : Word definition entries 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Entry.Word 12 | ( Entry(..) 13 | ) where 14 | 15 | import Data.HashMap.Strict (HashMap) 16 | import Kitten.Entry.Category (Category) 17 | import Kitten.Entry.Parent (Parent) 18 | import Kitten.Name (Unqualified) 19 | import Kitten.Operator (Associativity, Precedence) 20 | import Kitten.Origin (Origin) 21 | import Kitten.Signature (Signature) 22 | import Kitten.Term (Term) 23 | import Kitten.Type (Type) 24 | 25 | data Entry = Entry 26 | 27 | -- If present, the associativity (leftward or rightward) of this operator; if 28 | -- not, defaults to non-associative. 29 | 30 | { associativity :: !(Maybe Associativity) 31 | 32 | -- Whether this is a word/instance, trait, or permission. 33 | 34 | , category :: !Category 35 | 36 | -- If present, the definition of the word; if not, this is a declaration. 37 | 38 | , body :: !(Maybe (Term Type)) 39 | 40 | -- Whether this word is visible outside its vocabulary. 41 | 42 | , export :: !Bool 43 | 44 | -- User-defined metadata. 45 | 46 | , metadata :: !(HashMap Unqualified (Term ())) 47 | 48 | -- Source location. 49 | 50 | , origin :: !Origin 51 | 52 | -- If present, the precedence of this operator; if not, defaults to 6. 53 | 54 | , precedence :: !(Maybe Precedence) 55 | 56 | -- The type signature of this definition or declaration. 57 | 58 | , signature :: !Signature 59 | 60 | -- If present, the trait declaration of which this definition is an instance, or 61 | -- the type of which this definition is a constructor; if not, this is a normal 62 | -- definition. 63 | 64 | , parent :: !(Maybe Parent) 65 | 66 | } deriving (Show) 67 | -------------------------------------------------------------------------------- /syntax/kitten.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: Kitten 3 | " Maintainer: Jon Purdy 4 | 5 | syn case match 6 | 7 | syn keyword kittenBool false true 8 | syn keyword kittenBuiltinType bool char float handle int 9 | syn keyword kittenKeyword abbrev case choice data define default else if infix infix import match option vocab 10 | syn keyword kittenTodo FIXME HACK NOTE TODO XXX 11 | 12 | syn match kittenEscape /\\["&'\\abfnrtv]/ contained 13 | syn match kittenIdent /[a-z_][0-9A-Za-z_]*/ 14 | syn match kittenCharacter /[^0-9A-Za-z_']'\([^\\]\|\\\([^']\+\|'\)\)'/lc=1 contains=kittenEscape 15 | syn match kittenCharacter /^'\([^\\]\|\\\([^']\+\|'\)\)'/ contains=kittenEscape 16 | syn match kittenDelimiter "(\|)\|,\|:\|;\|\[\|\]\|{\|}" 17 | syn match kittenIntrinsic /__[0-9a-z_]\+/ 18 | syn match kittenSymbol /[!#$%&\*+,-./<=>?@^|~]\+/ 19 | syn match kittenType /[A-Z][0-9A-Za-z_]*/ 20 | 21 | syn match kittenInt "\<[0-9]\+\>\|\<0x[0-9a-fA-F]\+\>\|\<0o[0-7]\+\>\|\<0b[01]\+\>" 22 | syn match kittenFloat "\<[0-9]\+\.[0-9]\+\>" 23 | 24 | syn region kittenComment start="//" end="$" contains=kittenTodo 25 | syn region kittenMultiComment start="/\*" end="\*/" contains=kittenTodo,kittenMultiComment 26 | syn region kittenString start='"' skip='\\\\\|\\"' end='"' contains=kittenEscape 27 | 28 | let b:current_syntax = "kitten" 29 | 30 | hi def link kittenBool Boolean 31 | hi def link kittenBuiltinType Type 32 | hi def link kittenCharacter Character 33 | hi def link kittenComment Comment 34 | hi def link kittenDelimiter Normal 35 | hi def link kittenEscape SpecialChar 36 | hi def link kittenFloat Float 37 | hi def link kittenIdent Identifier 38 | hi def link kittenInt Number 39 | hi def link kittenIntrinsic Keyword 40 | hi def link kittenKeyword Keyword 41 | hi def link kittenMultiComment Comment 42 | hi def link kittenString String 43 | hi def link kittenSymbol Normal 44 | hi def link kittenTodo Todo 45 | hi def link kittenType Type 46 | -------------------------------------------------------------------------------- /doc/Architecture.md: -------------------------------------------------------------------------------- 1 | # Architecture 2 | 3 | Kitten’s compiler has a fairly simple architecture, with some features inspired by Forth. 4 | 5 | The compiler acts as a kind of database server for a `Dictionary`, which maps a fully `Qualified`, fully `Instantiated` name to an `Entry` containing information about a single program element, such as a word, trait, synonym, or type. A request consists of attempting to `Enter` a program `Fragment` into the `Dictionary`. A `Fragment` usually comes from a source file or interactive input, and consists of a set of top-level declarations and definitions. This request may fail in the `K` monad, which can log a `Report` because it’s an `Informer`. 6 | 7 | To parse a `Fragment` from source, we `Tokenize` the input into a `Token` stream, where each token is `Located` at some `Origin` in the source. Here, we also insert curly brace tokens to desugar `Layout`-based syntax. Then we `Parse` each top-level program `Element` from the tokens, and collect them into a `Fragment`. 8 | 9 | When entering a `Fragment` into a `Dictionary`, we treat the `Fragment` as a series of smaller requests: forward-declaring, resolving names, and entering definitions. To enter a `Definition`, we `Resolve` the names in the `Definition` against the `Dictionary`, from `Unqualified` or relative `Qualified` names into absolute `Qualified` names and local indices. That allows us to desugar `Infix` operators into postfix function calls, and to resolve the `Scope` of local and closure variables, respectively. Then we `Infer` and check the type of the body, and finally lift `Quotations` into separate definitions. 10 | 11 | Currently, you can `Interpret` a `Dictionary`, and the `Interactive` mode provides a UI for this. Different compilation targets (ELF, PE, Mach-O; x86, x86-64, ARM) and source-processing tools (documentation generator, CTAGS generator, auto-formatter, syntax highlighter) will consist of different serialisations of the `Dictionary`. 12 | -------------------------------------------------------------------------------- /lib/Kitten/Operator.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Operator 3 | Description : Infix operator metadata 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | module Kitten.Operator 15 | ( Associativity(..) 16 | , Fixity(..) 17 | , Operator(..) 18 | , Precedence(..) 19 | ) where 20 | 21 | import Kitten.Name (Qualified) 22 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 23 | import qualified Text.PrettyPrint as Pretty 24 | 25 | -- | Operator metadata for infix desugaring. 26 | 27 | data Operator = Operator 28 | { associativity :: !Associativity 29 | , name :: !Qualified 30 | , precedence :: !Precedence 31 | } deriving (Show) 32 | 33 | -- | Whether a word was declared infix (@+@) or postfix (@plus@). 34 | 35 | data Fixity = Infix | Postfix 36 | deriving (Eq, Show) 37 | 38 | -- | Whether an operator associates leftward: 39 | -- 40 | -- > a + b + c = (a + b) + c 41 | -- 42 | -- Rightward: 43 | -- 44 | -- > a + b + c = a + (b + c) 45 | -- 46 | -- Or not at all: 47 | -- 48 | -- > a + b + c // error 49 | 50 | data Associativity = Nonassociative | Leftward | Rightward 51 | deriving (Show) 52 | 53 | -- | The precedence level (from 0 to 9) of an operator; higher-precedence 54 | -- operators bind more tightly than lower-precedence operators. 55 | 56 | newtype Precedence = Precedence Int 57 | deriving (Enum, Eq, Ord, Show, Pretty) 58 | 59 | instance Bounded Precedence where 60 | minBound = Precedence 0 61 | maxBound = Precedence 9 62 | 63 | instance Pretty Operator where 64 | pPrint operator = Pretty.hsep 65 | $ ("infix" :) 66 | $ (case associativity operator of 67 | Nonassociative -> id 68 | Leftward -> ("left" :) 69 | Rightward -> ("right" :)) 70 | [ pPrint $ precedence operator 71 | , pPrint $ name operator 72 | ] 73 | -------------------------------------------------------------------------------- /lib/Kitten/Parser.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Parser 3 | Description : Parsing utilities 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | 13 | module Kitten.Parser 14 | ( Bracketer 15 | , Parser 16 | , getTokenOrigin 17 | , parserMatch 18 | , parserMatch_ 19 | , tokenSatisfy 20 | ) where 21 | 22 | import Control.Monad (void) 23 | import Data.Functor.Identity (Identity) 24 | import Kitten.Layoutness (Layoutness(..)) 25 | import Kitten.Located (Located) 26 | import Kitten.Name (Qualifier) 27 | import Kitten.Origin (Origin) 28 | import Kitten.Token (Token) 29 | import Text.Parsec ((), ParsecT) 30 | import Text.Parsec.Pos (SourcePos) 31 | import qualified Kitten.Located as Located 32 | import qualified Kitten.Origin as Origin 33 | import qualified Text.Parsec as Parsec 34 | 35 | type Bracketer a = GeneralParser 'Layout a 36 | type Parser a = GeneralParser 'Nonlayout a 37 | type GeneralParser l a = ParsecT [Located (Token l)] Qualifier Identity a 38 | 39 | getTokenOrigin :: GeneralParser l Origin 40 | getTokenOrigin = Located.origin 41 | <$> Parsec.lookAhead (tokenSatisfy (const True)) 42 | 43 | tokenSatisfy 44 | :: (Located (Token l) -> Bool) 45 | -> GeneralParser l (Located (Token l)) 46 | tokenSatisfy predicate = Parsec.tokenPrim show advance 47 | (\token -> if predicate token then Just token else Nothing) 48 | where 49 | 50 | advance 51 | :: SourcePos 52 | -> Located (Token l) 53 | -> [Located (Token l)] 54 | -> SourcePos 55 | advance _ _ (token : _) = Origin.begin (Located.origin token) 56 | advance sourcePos _ _ = sourcePos 57 | 58 | parserMatch :: Token l -> GeneralParser l (Located (Token l)) 59 | parserMatch token = tokenSatisfy ((== token) . Located.item) show token 60 | 61 | parserMatch_ :: Token l -> GeneralParser l () 62 | parserMatch_ = void . parserMatch 63 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | In the interest of fostering an open and welcoming environment for contributors and users, all developers and maintainers of Kitten are asked to respect and help enforce reasonable standards of discourse and behavior. 4 | 5 | ## Rules 6 | 7 | * As the main developer of Kitten, I, Jon Purdy, have the last word in directing the project and its community. 8 | 9 | * You are my guest, joining me here in my workshop. Please be courteous and respectful toward my other guests. 10 | 11 | * Contributions will be considered on their own merit, regardless of the person submitting them, provided that the contributor uphold this Code of Conduct. 12 | 13 | * It is both off-topic and inappropriate to make comments or actions of a sexual, violent, disruptive, or discriminatory nature, to discuss irrelevant personal details, or to allow them to influence treatment of other contributors in any way. Such details include, but are not limited to: age, appearance, disability, ethnicity, gender, nationality, politics, sex, race, and religion. 14 | 15 | * We should all strive to be inclusive, welcoming, and empathetic toward each other; respectfully offer and graciously accept constructive criticism; and focus on objective technical discussion. 16 | 17 | * It’s just a programming language—chill. 18 | 19 | ## Enforcement 20 | 21 | Failure to uphold the spirit of Kitten and its Code of Conduct in good faith may result in repercussions as determined at my sole discretion. I reserve the right to remove, edit, or reject any contribution, or to temporarily suspend or permanently ban any contributor, for behaviors that I deem inappropriate or harmful. 22 | 23 | Any concerns pertaining to this Code should be raised by contacting me privately, so that I may confidentially address the issue at hand. Discussion of conduct issues in public project spaces is also considered a violation of this Code. I will review all complaints and respond as I see fit. 24 | 25 | ## Scope 26 | 27 | This Code of Conduct shall be upheld in project spaces, as well as in public spaces if a contributor is representing Kitten or speaking in an official capacity about it. 28 | -------------------------------------------------------------------------------- /lib/Kitten/Origin.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Origin 3 | Description : Source locations 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Origin 14 | ( Origin(..) 15 | , begin 16 | , end 17 | , point 18 | , pos 19 | , range 20 | ) where 21 | 22 | import Data.Text (Text) 23 | import Text.Parsec.Pos 24 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 25 | import qualified Data.Text as Text 26 | import qualified Text.PrettyPrint as Pretty 27 | 28 | -- | A source location, in the form of an origin name (typically a file path) 29 | -- and source span between two ('Line', 'Column') pairs. 30 | 31 | data Origin = Origin 32 | { name :: !Text 33 | , beginLine :: !Line 34 | , beginColumn :: !Column 35 | , endLine :: !Line 36 | , endColumn :: !Column 37 | } deriving (Eq, Show) 38 | 39 | -- | The starting 'SourcePos' of an 'Origin'. 40 | 41 | begin :: Origin -> SourcePos 42 | begin = newPos <$> Text.unpack . name <*> beginLine <*> beginColumn 43 | 44 | -- | The ending 'SourcePos' of an 'Origin'. 45 | 46 | end :: Origin -> SourcePos 47 | end = newPos <$> Text.unpack . name <*> endLine <*> endColumn 48 | 49 | -- | A zero-width 'Origin' at the given 'Line' and 'Column'. 50 | 51 | point :: SourceName -> Line -> Column -> Origin 52 | point path line column = Origin 53 | { name = Text.pack path 54 | , beginLine = line 55 | , beginColumn = column 56 | , endLine = line 57 | , endColumn = column 58 | } 59 | 60 | -- | Makes a zero-width 'Origin' from a 'SourcePos'. 61 | 62 | pos :: SourcePos -> Origin 63 | pos = point <$> sourceName <*> sourceLine <*> sourceColumn 64 | 65 | -- | Makes a range between two 'SourcePos' points. 66 | 67 | range :: SourcePos -> SourcePos -> Origin 68 | range a b = Origin 69 | { name = Text.pack $ sourceName a 70 | , beginLine = sourceLine a 71 | , beginColumn = sourceColumn a 72 | , endLine = sourceLine b 73 | , endColumn = sourceColumn b 74 | } 75 | 76 | instance Pretty Origin where 77 | pPrint origin = Pretty.hcat $ 78 | [ Pretty.text $ Text.unpack $ name origin 79 | , ":", pPrint al, ".", pPrint ac, "-" 80 | ] 81 | ++ (if al == bl then [pPrint bc] else [pPrint bl, ".", pPrint bc]) 82 | where 83 | al = beginLine origin 84 | bl = endLine origin 85 | ac = beginColumn origin 86 | bc = endColumn origin 87 | -------------------------------------------------------------------------------- /lib/Kitten/Instantiate.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Instantiate 3 | Description : Instantiating generic types 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Instantiate 14 | ( prenex 15 | , term 16 | , type_ 17 | ) where 18 | 19 | import Data.Foldable (foldlM) 20 | import Kitten.Informer (Informer(..)) 21 | import Kitten.Kind (Kind) 22 | import Kitten.Monad (K) 23 | import Kitten.Name (Unqualified) 24 | import Kitten.Origin (Origin) 25 | import Kitten.Term (Term(..)) 26 | import Kitten.Type (Type(..), TypeId, Var(..)) 27 | import Kitten.TypeEnv (TypeEnv, freshTypeId) 28 | import qualified Kitten.Pretty as Pretty 29 | import qualified Kitten.Report as Report 30 | import qualified Kitten.Substitute as Substitute 31 | import qualified Kitten.Zonk as Zonk 32 | import qualified Text.PrettyPrint as Pretty 33 | 34 | -- | To instantiate a type scheme, we simply replace all quantified variables 35 | -- with fresh ones and remove the quantifier, returning the types with which the 36 | -- variables were instantiated, in order. Because type identifiers are globally 37 | -- unique, we know a fresh type variable will never be erroneously captured. 38 | 39 | type_ 40 | :: TypeEnv 41 | -> Origin 42 | -> Unqualified 43 | -> TypeId 44 | -> Kind 45 | -> Type 46 | -> K (Type, Type, TypeEnv) 47 | type_ tenv0 origin name x k t = do 48 | ia <- freshTypeId tenv0 49 | let a = TypeVar origin $ Var name ia k 50 | replaced <- Substitute.type_ tenv0 x a t 51 | return (replaced, a, tenv0) 52 | 53 | -- | When generating an instantiation of a generic definition, we only want to 54 | -- instantiate the rank-1 quantifiers; all other quantifiers are irrelevant. 55 | 56 | prenex :: TypeEnv -> Type -> K (Type, [Type], TypeEnv) 57 | prenex tenv0 q@(Forall origin (Var name x k) t) 58 | = while origin (Pretty.hsep ["instantiating", Pretty.quote q]) $ do 59 | (t', a, tenv1) <- type_ tenv0 origin name x k t 60 | (t'', as, tenv2) <- prenex tenv1 t' 61 | return (t'', a : as, tenv2) 62 | prenex tenv0 t = return (t, [], tenv0) 63 | 64 | -- | Instantiates a generic expression with the given type arguments. 65 | 66 | term :: TypeEnv -> Term Type -> [Type] -> K (Term Type) 67 | term tenv t args = foldlM go t args 68 | where 69 | go (Generic _name x expr _origin) arg = Substitute.term tenv x arg expr 70 | go _ _ = do 71 | report $ Report.TypeArgumentCountMismatch t $ map (Zonk.type_ tenv) args 72 | halt 73 | -------------------------------------------------------------------------------- /lib/Kitten/TypeEnv.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.TypeEnv 3 | Description : Type inference environment 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.TypeEnv 14 | ( TypeEnv(..) 15 | , empty 16 | , freshTv 17 | , freshTypeId 18 | , getClosed 19 | ) where 20 | 21 | import Control.Monad.IO.Class (liftIO) 22 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 23 | import Data.Map (Map) 24 | import Kitten.Kind (Kind) 25 | import Kitten.Monad (K) 26 | import Kitten.Name 27 | import Kitten.Origin (Origin) 28 | import Kitten.Type (Type(..), TypeId(..), Var(..)) 29 | import System.IO.Unsafe (unsafePerformIO) 30 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 31 | import qualified Data.Map as Map 32 | import qualified Text.PrettyPrint as Pretty 33 | 34 | -- The typing environment tracks the state of inference. It answers the 35 | -- following questions: 36 | -- 37 | -- • What is the type of this type variable? 38 | -- • What is the type of this local variable? 39 | -- • What are the types of the current closure? 40 | -- • What is the signature of this definition? 41 | -- 42 | -- It also provides access to the state of globally unique ID generation. 43 | 44 | data TypeEnv = TypeEnv 45 | { tvs :: !(Map TypeId Type) 46 | , vs :: [Type] 47 | , closure :: [Type] 48 | , sigs :: !(Map Qualified Type) 49 | , currentType :: !(IORef TypeId) 50 | } 51 | 52 | empty :: TypeEnv 53 | empty = TypeEnv 54 | { tvs = Map.empty 55 | , vs = [] 56 | , closure = [] 57 | , sigs = Map.empty 58 | , currentType = currentTypeId 59 | } 60 | 61 | currentTypeId :: IORef TypeId 62 | currentTypeId = unsafePerformIO (newIORef (TypeId 0)) 63 | {-# NOINLINE currentTypeId #-} 64 | 65 | freshTv :: TypeEnv -> Unqualified -> Origin -> Kind -> K Type 66 | freshTv tenv name origin k 67 | = TypeVar origin <$> (Var name <$> freshTypeId tenv <*> pure k) 68 | 69 | freshTypeId :: TypeEnv -> K TypeId 70 | freshTypeId tenv = do 71 | x <- liftIO $ readIORef $ currentType tenv 72 | liftIO $ writeIORef (currentType tenv) $ succ x 73 | return x 74 | 75 | instance Pretty TypeEnv where 76 | pPrint tenv = Pretty.vcat 77 | $ map (\ (v, t) -> Pretty.hsep [pPrint v, "~", pPrint t]) 78 | $ Map.toList $ tvs tenv 79 | 80 | getClosed :: TypeEnv -> Closed -> Type 81 | getClosed tenv name = case name of 82 | ClosedLocal (LocalIndex index) -> vs tenv !! index 83 | ClosedClosure (ClosureIndex index) -> closure tenv !! index 84 | -------------------------------------------------------------------------------- /src/Arguments.hs: -------------------------------------------------------------------------------- 1 | module Arguments 2 | ( Arguments(..) 3 | , CompileMode(..) 4 | , OutputFormat(..) 5 | , parseArguments 6 | ) where 7 | 8 | import Control.Monad 9 | import System.Console.CmdArgs.Explicit 10 | import System.Exit 11 | 12 | data Arguments = Arguments 13 | { compileMode :: CompileMode 14 | , inputPaths :: [FilePath] 15 | , outputPath :: Maybe FilePath 16 | , showHelp :: Bool 17 | , showVersion :: Bool 18 | } 19 | 20 | data CompileMode 21 | = CheckMode 22 | | CompileMode !OutputFormat 23 | | InterpretMode 24 | 25 | data OutputFormat = OutputIr 26 | 27 | parseArguments :: IO Arguments 28 | parseArguments = do 29 | arguments <- processArgs argumentsMode 30 | when (showVersion arguments) $ do 31 | putStrLn "Kitten version 0.1" 32 | exitSuccess 33 | when (showHelp arguments) $ do 34 | print $ helpText [] HelpFormatDefault argumentsMode 35 | exitSuccess 36 | return arguments 37 | 38 | argumentsMode :: Mode Arguments 39 | argumentsMode = mode "kitten" defaultArguments 40 | "Compiles and interprets Kitten code." bareArgument options 41 | 42 | defaultArguments :: Arguments 43 | defaultArguments = Arguments 44 | { compileMode = InterpretMode 45 | , inputPaths = [] 46 | , outputPath = Nothing 47 | , showHelp = False 48 | , showVersion = False 49 | } 50 | 51 | bareArgument :: Arg Arguments 52 | bareArgument = flagArg inputPathArgument "input-paths" 53 | 54 | inputPathArgument 55 | :: FilePath -> Arguments -> Either e Arguments 56 | inputPathArgument path acc = Right 57 | $ acc { inputPaths = path : inputPaths acc } 58 | 59 | options :: [Flag Arguments] 60 | options = 61 | [ flagReq' ["c", "compile"] "ir" 62 | "Compile to the given output format." 63 | $ \ format acc -> case format of 64 | "ir" -> Right acc { compileMode = CompileMode OutputIr } 65 | _ -> Left $ "Unknown output format '" ++ format ++ "'." 66 | 67 | , flagBool' ["check"] 68 | "Check syntax and types without compiling or running." 69 | $ \ flag acc -> acc 70 | { compileMode = if flag then CheckMode else compileMode acc } 71 | 72 | , flagReq' ["o", "output"] "PATH" 73 | "File path for compile output." 74 | $ \ path acc -> case outputPath acc of 75 | Just{} -> Left "Only one output path is allowed." 76 | Nothing -> Right $ acc { outputPath = Just path } 77 | 78 | , flagHelpSimple $ \ acc -> acc { showHelp = True } 79 | , flagVersion $ \ acc -> acc { showVersion = True } 80 | ] 81 | 82 | flagReq' 83 | :: [Name] 84 | -> FlagHelp 85 | -> Help 86 | -> Update a 87 | -> Flag a 88 | flagReq' names sample description option 89 | = flagReq names option sample description 90 | 91 | flagBool' 92 | :: [Name] 93 | -> Help 94 | -> (Bool -> a -> a) 95 | -> Flag a 96 | flagBool' names description option 97 | = flagBool names option description 98 | -------------------------------------------------------------------------------- /test/Test/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Parse 4 | ( spec 5 | ) where 6 | 7 | import Data.Text (Text) 8 | import Kitten (fragmentFromSource) 9 | import Kitten.Monad (runKitten) 10 | import Test.Common 11 | import Test.HUnit (Assertion, assertFailure) 12 | import Test.Hspec (Spec, describe, it) 13 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 14 | import qualified Kitten.Report as Report 15 | import qualified Text.PrettyPrint as Pretty 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "with definitions" $ do 20 | 21 | it "accepts unqualified word as definition name" $ do 22 | testParse Positive "define word (->) {}" 23 | it "accepts qualified word as definition name" $ do 24 | testParse Positive "define vocabulary::word (->) {}" 25 | it "accepts unqualified word as definition name within vocab" $ do 26 | testParse Positive "vocab vocabulary { define word (->) {} }" 27 | it "accepts qualified word as definition name within vocab" $ do 28 | testParse Positive "vocab outer { define inner::word (->) {} }" 29 | 30 | it "accepts unqualified operator as definition name" $ do 31 | testParse Positive "define + (->) {}" 32 | it "accepts qualified operator as definition name" $ do 33 | testParse Positive "define vocabulary::+ (->) {}" 34 | it "accepts unqualified operator as definition name within vocab" $ do 35 | testParse Positive "vocab vocabulary { define + (->) {} }" 36 | it "accepts qualified operator as definition name within vocab" $ do 37 | testParse Positive "vocab outer { define inner::+ (->) {} }" 38 | 39 | it "accepts unqualified word as type name" $ do 40 | testParse Positive "type Word {}" 41 | it "accepts qualified word as type name" $ do 42 | testParse Positive "type vocabulary::Word {}" 43 | it "accepts unqualified word as type name within vocab" $ do 44 | testParse Positive "vocab vocabulary { type Word {} }" 45 | it "accepts qualified word as type name within vocab" $ do 46 | testParse Positive "vocab outer { type inner::Word {} }" 47 | 48 | it "rejects unqualified operator as type name" $ do 49 | testParse Negative "type + {}" 50 | it "rejects qualified operator as type name" $ do 51 | testParse Negative "type vocabulary::+ {}" 52 | 53 | testParse :: Sign -> Text -> Assertion 54 | testParse sign input = do 55 | result <- runKitten 56 | $ fragmentFromSource ioPermission Nothing 1 "" input 57 | case result of 58 | Left reports -> case sign of 59 | Positive -> assertFailure $ unlines 60 | $ map (Pretty.render . Report.human) reports 61 | -- TODO: Test error messages for negative tests. 62 | Negative -> pure () 63 | Right fragment -> case sign of 64 | Positive -> pure () 65 | Negative -> assertFailure $ Pretty.render $ pPrint fragment 66 | -------------------------------------------------------------------------------- /lib/Kitten/Definition.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Definition 3 | Description : Definitions of words, instances, and permissions 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Definition 14 | ( Definition(..) 15 | , isMain 16 | , main 17 | , mainName 18 | ) where 19 | 20 | import Data.Maybe (fromMaybe) 21 | import Kitten.Entry.Category (Category) 22 | import Kitten.Entry.Merge (Merge) 23 | import Kitten.Entry.Parameter (Parameter(..)) 24 | import Kitten.Entry.Parent (Parent) 25 | import Kitten.Kind (Kind(..)) 26 | import Kitten.Name (GeneralName(..), Qualified(..)) 27 | import Kitten.Operator (Fixity) 28 | import Kitten.Origin (Origin) 29 | import Kitten.Signature (Signature) 30 | import Kitten.Term (Term) 31 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 32 | import qualified Kitten.Entry.Category as Category 33 | import qualified Kitten.Entry.Merge as Merge 34 | import qualified Kitten.Operator as Operator 35 | import qualified Kitten.Pretty as Pretty 36 | import qualified Kitten.Signature as Signature 37 | import qualified Kitten.Term as Term 38 | import qualified Kitten.Token as Token 39 | import qualified Kitten.Vocabulary as Vocabulary 40 | 41 | data Definition a = Definition 42 | { body :: !(Term a) 43 | , category :: !Category 44 | , fixity :: !Fixity 45 | , inferSignature :: !Bool 46 | , merge :: !Merge 47 | , name :: !Qualified 48 | , origin :: !Origin 49 | , parent :: !(Maybe Parent) 50 | , signature :: !Signature 51 | } deriving (Show) 52 | 53 | instance Pretty (Definition a) where 54 | pPrint definition = Pretty.asDefinition 55 | (pPrint $ name definition) 56 | (pPrint $ signature definition) 57 | (pPrint $ body definition) 58 | (pPrint Token.Define) 59 | 60 | -- | The main definition, created implicitly from top-level code in program 61 | -- fragments. 62 | 63 | main 64 | :: [GeneralName] 65 | -- ^ List of permissions implicitly granted. 66 | -> Maybe Qualified 67 | -- ^ Override default name. 68 | -> Term a 69 | -- ^ Body. 70 | -> Definition a 71 | main permissions mName term = Definition 72 | { body = term 73 | , category = Category.Word 74 | , fixity = Operator.Postfix 75 | , inferSignature = True 76 | , merge = Merge.Compose 77 | , name = fromMaybe mainName mName 78 | , origin = o 79 | , parent = Nothing 80 | , signature = Signature.Quantified 81 | [Parameter o "R" Stack] 82 | (Signature.StackFunction 83 | (Signature.Variable "R" o) [] 84 | (Signature.Variable "R" o) [] 85 | permissions o) o 86 | } 87 | where o = Term.origin term 88 | 89 | -- | Default name of main definition. 90 | 91 | mainName :: Qualified 92 | mainName = Qualified Vocabulary.global "main" 93 | 94 | -- | Whether a given definition refers to (the default-named) @main@. 95 | 96 | isMain :: Definition a -> Bool 97 | isMain = (== Qualified Vocabulary.global "main") . name 98 | -------------------------------------------------------------------------------- /syntax/kitten-mode.el: -------------------------------------------------------------------------------- 1 | (defvar kitten-mode-hook nil) 2 | 3 | (defvar kitten-mode-map 4 | (let ((map (make-keymap))) 5 | (define-key map "\C-j" 'newline-and-indent) 6 | map) 7 | "Keymap for Kitten major mode") 8 | 9 | (add-to-list 'auto-mode-alist '("\\.ktn\\'" . kitten-mode)) 10 | 11 | (defvar kitten-font-lock-keywords 12 | (list 13 | '("\\<__[0-9a-z_]+\\>" . font-lock-builtin-face) 14 | '("\\<\\(true\\|false\\|0b[01]+\\|0o[0-7]+\\|0x[0-9A-Fa-f]+\\|[0-9]+\\(\\.[0-9]+\\)?\\)\\>" 15 | . font-lock-constant-face) 16 | '("'\\([^']\\|\\\\.[^']*\\)'" . font-lock-string-face) 17 | '("\\<\\([A-Z][0-9A-Za-z_]*'*\\)\\>" . font-lock-type-face) 18 | '("\\<\\(bool\\|char\\|float\\|handle\\|int\\)\\>" 19 | 0 font-lock-type-face) 20 | '("\\s_+" 0 font-lock-variable-name-face) 21 | '("\\<\\(abbrev\\|case\\|choice\\|data\\|define\\|default\\|else\\|if\\|infix\\|import\\|match\\|option\\|vocab\\)\\>" 22 | 0 font-lock-keyword-face) 23 | '("\\<\\([a-z][0-9A-Za-z_]*'*\\)\\>" 1 font-lock-function-name-face)) 24 | "Default highlighting for Kitten mode") 25 | 26 | ; (defun kitten-indent-line () 27 | ; "Indent current line as Kitten code" 28 | ; (interactive)) 29 | 30 | (defvar kitten-mode-syntax-table 31 | (let ((table (make-syntax-table))) 32 | ; Multi-line comment start/end (nestable). 33 | (modify-syntax-entry ?/ "_ 124b" table) 34 | ; Multi-line comment end. 35 | (modify-syntax-entry ?* "_ 23n" table) 36 | ; Single-line comment end. 37 | (modify-syntax-entry ?\n "> b" table) 38 | (modify-syntax-entry ?! "_" table) 39 | (modify-syntax-entry ?# "_" table) 40 | (modify-syntax-entry ?$ "_" table) 41 | (modify-syntax-entry ?% "_" table) 42 | (modify-syntax-entry ?& "_" table) 43 | ; Single quotes are also used for primes, so we can't use "/" 44 | ; (character quote). 45 | (modify-syntax-entry ?' "w" table) 46 | (modify-syntax-entry ?+ "_" table) 47 | (modify-syntax-entry ?- "_" table) 48 | (modify-syntax-entry ?. "_" table) 49 | ; (modify-syntax-entry ?; "_" table) 50 | (modify-syntax-entry ?< "_" table) 51 | (modify-syntax-entry ?= "_" table) 52 | (modify-syntax-entry ?> "_" table) 53 | (modify-syntax-entry ?? "_" table) 54 | (modify-syntax-entry ?@ "_" table) 55 | (modify-syntax-entry ?\\ "\\" table) 56 | (modify-syntax-entry ?^ "_" table) 57 | (modify-syntax-entry ?_ "w" table) 58 | (modify-syntax-entry ?| "_" table) 59 | (modify-syntax-entry ?~ "_" table) 60 | table) 61 | "Syntax table for Kitten mode") 62 | 63 | (defun kitten-mode () 64 | "Major mode for editing Kitten source files" 65 | (interactive) 66 | (kill-all-local-variables) 67 | (set-syntax-table kitten-mode-syntax-table) 68 | (use-local-map kitten-mode-map) 69 | (set (make-local-variable 'font-lock-defaults) '(kitten-font-lock-keywords)) 70 | ; (set (make-local-variable 'indent-line-function) 'kitten-indent-line) 71 | (setq major-mode 'kitten-mode) 72 | (setq mode-name "Kitten") 73 | (run-hooks 'kitten-mode-hook)) 74 | 75 | (provide 'kitten-mode) 76 | -------------------------------------------------------------------------------- /test/Test/InstanceCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.InstanceCheck 4 | ( spec 5 | ) where 6 | 7 | 8 | import Kitten.Informer (checkpoint) 9 | import Kitten.InstanceCheck (instanceCheck) 10 | import Kitten.Kind (Kind(..)) 11 | import Kitten.Monad (runKitten) 12 | import Kitten.Name (Qualified(..)) 13 | import Kitten.Type (Type(..), TypeId(..), Var(..)) 14 | import Test.Common 15 | import Test.HUnit (assertBool) 16 | import Test.Hspec (Spec, it) 17 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 18 | import qualified Kitten.Origin as Origin 19 | import qualified Kitten.Type as Type 20 | import qualified Kitten.Vocabulary as Vocabulary 21 | import qualified Text.PrettyPrint as Pretty 22 | 23 | spec :: Spec 24 | spec = do 25 | it "with concrete types" $ do 26 | 27 | -- Int32 28 | -- <: Int32 29 | testInstanceCheck Positive int int 30 | 31 | -- (T) 32 | -- <: Int32 33 | testInstanceCheck Positive (fx x) int 34 | 35 | -- (R... -> R..., T +P) 36 | -- <: (R... -> R..., Int32 +P) 37 | testInstanceCheck Positive 38 | (fr $ fe $ fx $ Type.fun o r (Type.prod o r x) e) 39 | (fr $ fe $ Type.fun o r (Type.prod o r int) e) 40 | 41 | it "with parameterized types" $ do 42 | 43 | -- (Pair) 44 | -- <: (Pair) 45 | testInstanceCheck Positive 46 | (fx $ fy $ pair :@ x :@ y) 47 | (fx $ pair :@ x :@ x) 48 | 49 | -- (Pair -> Pair) 50 | -- (Pair -> Pair) 51 | testInstanceCheck Negative 52 | (fr $ fx $ fy $ fe $ Type.fun o 53 | (Type.prod o r (pair :@ x :@ y)) 54 | (Type.prod o r (pair :@ y :@ x)) e) 55 | (fr $ fx $ fy $ fe $ Type.fun o 56 | (Type.prod o r (pair :@ x :@ y)) 57 | (Type.prod o r (pair :@ x :@ y)) e) 58 | 59 | where 60 | o = Origin.point "" 0 0 61 | r = TypeVar o rv 62 | s = TypeVar o sv 63 | x = TypeVar o xv 64 | y = TypeVar o yv 65 | e = TypeVar o ev 66 | rv = Var "R" (TypeId 0) Stack 67 | sv = Var "S" (TypeId 1) Stack 68 | xv = Var "X" (TypeId 2) Value 69 | yv = Var "Y" (TypeId 3) Value 70 | ev = Var "P" (TypeId 4) Permission 71 | fr = Type.Forall o rv 72 | fs = Type.Forall o sv 73 | fx = Type.Forall o xv 74 | fy = Type.Forall o yv 75 | fe = Type.Forall o ev 76 | ctor = TypeConstructor o . Type.Constructor 77 | . Qualified Vocabulary.global 78 | char = ctor "Char" 79 | int = ctor "Int32" 80 | io = ctor "IO" 81 | float = ctor "Float64" 82 | pair = ctor "Pair" 83 | 84 | testInstanceCheck :: Sign -> Type -> Type -> IO () 85 | testInstanceCheck sign a b = do 86 | result <- runKitten $ do 87 | instanceCheck "polymorphic" a "concrete" b 88 | checkpoint 89 | case sign of 90 | Positive -> assertBool (Pretty.render $ Pretty.hsep [pPrint a, "<:", pPrint b]) 91 | $ either (const False) (const True) result 92 | Negative -> assertBool (Pretty.render $ Pretty.hsep [pPrint a, " map :: ∀ρσαβ. ρ × List α × (σ × α → σ × β) → ρ × List β 42 | -- 43 | -- Can be regeneralized like so: 44 | -- 45 | -- > map :: ∀ραβ. ρ × List α × (∀σ. σ × α → σ × β) → ρ × List β 46 | -- 47 | -- In order to correctly regeneralize a type, it needs to contain no 48 | -- higher-ranked quantifiers. 49 | 50 | regeneralize :: TypeEnv -> Type -> Type 51 | regeneralize tenv t = let 52 | (t', vars) = runWriter $ go t 53 | in foldr addForall t' 54 | $ foldr (deleteBy ((==) `on` fst)) 55 | (Map.toList (Free.tvks tenv t')) 56 | vars 57 | where 58 | 59 | addForall :: (TypeId, (Unqualified, Kind)) -> Type -> Type 60 | addForall (i, (name, k)) = Forall (Type.origin t) (Var name i k) 61 | 62 | go :: Type -> Writer [(TypeId, (Unqualified, Kind))] Type 63 | go t' = case t' of 64 | TypeConstructor _ "Fun" :@ a :@ b :@ e 65 | | TypeVar origin (Var name c k) <- bottommost a 66 | , TypeVar _ (Var _name d _) <- bottommost b 67 | , c == d 68 | -> do 69 | when (occurrences tenv c t == 2) $ tell [(c, (name, k))] 70 | a' <- go a 71 | b' <- go b 72 | e' <- go e 73 | return $ Forall origin (Var name c k) $ Type.fun origin a' b' e' 74 | c@(TypeConstructor _ "Prod") :@ a :@ b -> do 75 | a' <- go a 76 | b' <- go b 77 | return $ c :@ a' :@ b' 78 | -- FIXME: This should descend into the quantified type. 79 | Forall{} -> return t' 80 | a :@ b -> (:@) <$> go a <*> go b 81 | _ -> return t' 82 | 83 | bottommost :: Type -> Type 84 | bottommost (TypeConstructor _ "Prod" :@ a :@ _) = bottommost a 85 | bottommost a = a 86 | -------------------------------------------------------------------------------- /lib/Kitten/Substitute.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Substitute 3 | Description : Substituting type variables 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Substitute 12 | ( term 13 | , type_ 14 | ) where 15 | 16 | import Kitten.Monad (K) 17 | import Kitten.Term (Case(..), Else(..), Term(..)) 18 | import Kitten.Type (Type(..), TypeId, Var(..)) 19 | import Kitten.TypeEnv (TypeEnv, freshTypeId) 20 | import qualified Data.Set as Set 21 | import qualified Kitten.Free as Free 22 | import qualified Kitten.Kind as Kind 23 | 24 | -- | Capture-avoiding substitution of a type variable α with a type τ throughout 25 | -- a type σ, [α ↦ τ]σ. 26 | 27 | type_ :: TypeEnv -> TypeId -> Type -> Type -> K Type 28 | type_ tenv0 x a = recur 29 | where 30 | recur t = case t of 31 | Forall origin var@(Var name x' k) t' 32 | | x == x' -> return t 33 | | x' `Set.notMember` Free.tvs tenv0 t' -> Forall origin var <$> recur t' 34 | | otherwise -> do 35 | z <- freshTypeId tenv0 36 | t'' <- type_ tenv0 x' (TypeVar origin $ Var name z k) t' 37 | Forall origin (Var name z k) <$> recur t'' 38 | TypeVar _ (Var _name x' _) | x == x' -> return a 39 | m :@ n -> (:@) <$> recur m <*> recur n 40 | _ -> return t 41 | 42 | term :: TypeEnv -> TypeId -> Type -> Term Type -> K (Term Type) 43 | term tenv x a = recur 44 | where 45 | recur t = case t of 46 | Coercion hint tref origin -> Coercion hint <$> go tref <*> pure origin 47 | Compose tref t1 t2 -> Compose <$> go tref <*> recur t1 <*> recur t2 48 | Generic name x' body origin -> do 49 | -- FIXME: Generics could eventually quantify over non-value kinds. 50 | let k = Kind.Value 51 | z <- freshTypeId tenv 52 | body' <- term tenv x' (TypeVar origin $ Var name z k) body 53 | Generic name z <$> recur body' <*> pure origin 54 | Group body -> recur body 55 | Lambda tref name varType body origin -> Lambda <$> go tref 56 | <*> pure name <*> go varType <*> recur body <*> pure origin 57 | Match hint tref cases else_ origin -> Match hint <$> go tref 58 | <*> mapM goCase cases <*> goElse else_ <*> pure origin 59 | where 60 | 61 | goCase :: Case Type -> K (Case Type) 62 | goCase (Case name body caseOrigin) 63 | = Case name <$> recur body <*> pure caseOrigin 64 | 65 | goElse :: Else Type -> K (Else Type) 66 | goElse (Else body elseOrigin) = Else <$> recur body <*> pure elseOrigin 67 | 68 | New tref index size origin -> New 69 | <$> go tref <*> pure index <*> pure size <*> pure origin 70 | NewClosure tref size origin -> NewClosure <$> go tref 71 | <*> pure size <*> pure origin 72 | NewVector tref size elemType origin -> NewVector <$> go tref 73 | <*> pure size <*> go elemType <*> pure origin 74 | Push tref value origin -> Push <$> go tref <*> pure value <*> pure origin 75 | Word tref fixity name args origin -> Word <$> go tref 76 | <*> pure fixity <*> pure name <*> mapM go args <*> pure origin 77 | 78 | go = type_ tenv x a 79 | -------------------------------------------------------------------------------- /lib/Kitten/Zonk.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Zonk 3 | Description : Fully substituting type variables 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Zonk 12 | ( type_ 13 | , term 14 | ) where 15 | 16 | import Kitten.Term (Case(..), Else(..), Term(..), Value(..)) 17 | import Kitten.Type (Type(..), Var(..)) 18 | import Kitten.TypeEnv (TypeEnv) 19 | import qualified Data.Map as Map 20 | import qualified Kitten.TypeEnv as TypeEnv 21 | 22 | -- | Zonking a type fully substitutes all type variables. That is, if you have: 23 | -- 24 | -- > t0 ~ t1 25 | -- > t1 ~ Int32 26 | -- 27 | -- Then zonking @t0@ gives you @Int32@. 28 | 29 | type_ :: TypeEnv -> Type -> Type 30 | type_ tenv0 = recur 31 | where 32 | recur t = case t of 33 | TypeConstructor{} -> t 34 | TypeValue{} -> error "TODO: zonk type value" 35 | TypeVar _origin (Var _name x _k) -> case Map.lookup x (TypeEnv.tvs tenv0) of 36 | -- FIXME: Is this necessary? 37 | -- Just (TypeVar _origin (Var x' _)) | x == x' -> TypeVar origin (Var x k) 38 | Just t' -> recur t' 39 | Nothing -> t 40 | TypeConstant{} -> t 41 | Forall origin var@(Var _ i _) t' -> Forall origin var 42 | $ type_ tenv0 { TypeEnv.tvs = Map.delete i $ TypeEnv.tvs tenv0 } t' 43 | a :@ b -> recur a :@ recur b 44 | 45 | -- | Zonking a term zonks all the annotated types of its subterms. This could be 46 | -- done more efficiently by sharing type references and updating them impurely, 47 | -- but this implementation is easier to get right and understand. 48 | 49 | term :: TypeEnv -> Term Type -> Term Type 50 | term tenv0 = go 51 | where 52 | zonk = type_ tenv0 53 | go t = case t of 54 | Coercion hint tref origin 55 | -> Coercion hint (zonk tref) origin 56 | Compose tref a b 57 | -> Compose (zonk tref) (go a) (go b) 58 | Generic name i a origin 59 | -> Generic name i (go a) origin 60 | Group a 61 | -> go a 62 | Lambda tref name varType body origin 63 | -> Lambda (zonk tref) name (zonk varType) (go body) origin 64 | Match hint tref cases else_ origin 65 | -> Match hint (zonk tref) (map goCase cases) (goElse else_) origin 66 | where 67 | goCase (Case name body caseOrigin) 68 | = Case name (go body) caseOrigin 69 | goElse (Else body elseOrigin) 70 | = Else (go body) elseOrigin 71 | New tref index size origin 72 | -> New (zonk tref) index size origin 73 | NewClosure tref index origin 74 | -> NewClosure (zonk tref) index origin 75 | NewVector tref size elemType origin 76 | -> NewVector (zonk tref) size (zonk elemType) origin 77 | Push tref value' origin 78 | -> Push (zonk tref) (value tenv0 value') origin 79 | Word tref fixity name params origin 80 | -> Word (zonk tref) fixity name params origin 81 | 82 | value :: TypeEnv -> Value Type -> Value Type 83 | value tenv0 = go 84 | where 85 | go v = case v of 86 | Capture names body -> Capture names $ term tenv0 body 87 | Character{} -> v 88 | Closed{} -> v 89 | Float{} -> v 90 | Integer{} -> v 91 | Local{} -> v 92 | Name{} -> v 93 | Quotation body -> Quotation $ term tenv0 body 94 | Text{} -> v 95 | -------------------------------------------------------------------------------- /lib/Kitten/Literal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Literal 3 | Description : Representations of literal values 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Literal 14 | ( FloatLiteral(..) 15 | , IntegerLiteral(..) 16 | , floatValue 17 | ) where 18 | 19 | import Data.Ratio ((%)) 20 | import Kitten.Base (Base(..)) 21 | import Kitten.Bits (FloatBits(..), IntegerBits(..)) 22 | import Numeric 23 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 24 | import qualified Text.PrettyPrint as Pretty 25 | 26 | data IntegerLiteral = IntegerLiteral 27 | { integerValue :: !Integer 28 | , integerBase :: !Base 29 | , integerBits :: !IntegerBits 30 | } deriving (Show) 31 | 32 | -- Integer literals compare equality regardless of base and bits. 33 | instance Eq IntegerLiteral where 34 | IntegerLiteral a _baseA _bitsA == IntegerLiteral b _baseB _bitsB = a == b 35 | 36 | instance Pretty IntegerLiteral where 37 | pPrint literal = Pretty.hcat 38 | [ if value < 0 then "-" else "" 39 | , prefix 40 | , Pretty.text $ showIntAtBase base (digits !!) (abs value) "" 41 | , suffix 42 | ] 43 | where 44 | value = integerValue literal 45 | bits = integerBits literal 46 | (base, prefix, digits) = case integerBase literal of 47 | Binary -> (2, "0b", "01") 48 | Octal -> (8, "0o", ['0'..'7']) 49 | Decimal -> (10, "", ['0'..'9']) 50 | Hexadecimal -> (16, "0x", ['0'..'9'] ++ ['A'..'F']) 51 | suffix = case bits of 52 | Signed32 -> "" 53 | _ -> pPrint bits 54 | 55 | data FloatLiteral = FloatLiteral 56 | { floatSignificand :: !Integer 57 | , floatFractional :: !Int 58 | , floatExponent :: !Int 59 | , floatBits :: !FloatBits 60 | } deriving (Show) 61 | 62 | -- Float literals compar equality regardless of bits. 63 | instance Eq FloatLiteral where 64 | FloatLiteral a b c _bitsA == FloatLiteral d e f _bitsB = (a, c - b) == (d, f - e) 65 | 66 | instance Pretty FloatLiteral where 67 | pPrint literal 68 | = Pretty.hcat 69 | [ if value < 0 then "-" else "" 70 | , Pretty.double value 71 | , case bits of 72 | Float64 -> "" 73 | Float32 -> pPrint bits 74 | ] 75 | where 76 | bits = floatBits literal 77 | value = floatValue literal 78 | 79 | -- Note [Float Literals]: 80 | -- 81 | -- Floating-point literals are represented as a pair of an arbitrary-precision 82 | -- integer significand and exponent, so that: 83 | -- 84 | -- Float a b c 85 | -- 86 | -- Denotes the floating point number (a × 10^(c - b)). This representation was 87 | -- chosen to avoid loss of precision until the token is converted into a machine 88 | -- floating-point format. The exponent is split into two parts to indicate which 89 | -- part of the literal that exponent came from: the fractional part, or the 90 | -- exponent in scientific notation. 91 | 92 | floatValue :: Fractional a => FloatLiteral -> a 93 | floatValue (FloatLiteral a b c _bits) = let 94 | e = c - b 95 | -- The intermediate rational step is necessary to preserve precision. 96 | shift = if e < 0 then 1 % 10 ^ negate e else 10 ^ e 97 | in fromRational $ (fromIntegral a :: Rational) * shift 98 | -------------------------------------------------------------------------------- /lib/Kitten/Desugar/Data.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Desugar.Data 3 | Description : Desugaring data type constructors 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Desugar.Data 12 | ( desugar 13 | ) where 14 | 15 | import Data.List (foldl') 16 | import Kitten.DataConstructor (DataConstructor) 17 | import Kitten.Definition (Definition(Definition)) 18 | import Kitten.Entry.Parameter (Parameter(Parameter)) 19 | import Kitten.Fragment (Fragment) 20 | import Kitten.Name (ConstructorIndex(..), GeneralName(..), Qualified(..)) 21 | import Kitten.Term (Term(..)) 22 | import Kitten.TypeDefinition (TypeDefinition) 23 | import qualified Kitten.DataConstructor as DataConstructor 24 | import qualified Kitten.Definition as Definition 25 | import qualified Kitten.Entry.Category as Category 26 | import qualified Kitten.Entry.Merge as Merge 27 | import qualified Kitten.Entry.Parent as Parent 28 | import qualified Kitten.Fragment as Fragment 29 | import qualified Kitten.Operator as Operator 30 | import qualified Kitten.Signature as Signature 31 | import qualified Kitten.TypeDefinition as TypeDefinition 32 | 33 | -- | Desugars data type constructors into word definitions, e.g.: 34 | -- 35 | -- > type Optional: 36 | -- > case none 37 | -- > case some (T) 38 | -- > 39 | -- > // => 40 | -- > 41 | -- > define none (-> Optional) { ... } 42 | -- > define some (T -> Optional) { ... } 43 | 44 | desugar :: Fragment () -> Fragment () 45 | desugar fragment = fragment 46 | { Fragment.definitions = Fragment.definitions fragment 47 | ++ concatMap desugarTypeDefinition (Fragment.types fragment) } 48 | 49 | desugarTypeDefinition :: TypeDefinition -> [Definition ()] 50 | desugarTypeDefinition definition 51 | = zipWith (desugarConstructor definition) [0..] 52 | $ TypeDefinition.constructors definition 53 | 54 | desugarConstructor :: TypeDefinition -> Int -> DataConstructor -> Definition () 55 | desugarConstructor definition index constructor = Definition 56 | { Definition.body = New () 57 | (ConstructorIndex index) 58 | (length $ DataConstructor.fields constructor) 59 | $ DataConstructor.origin constructor 60 | , Definition.category = Category.Constructor 61 | , Definition.fixity = Operator.Postfix 62 | , Definition.inferSignature = False 63 | , Definition.merge = Merge.Deny 64 | , Definition.name = Qualified qualifier 65 | $ DataConstructor.name constructor 66 | , Definition.origin = origin 67 | , Definition.parent = Just $ Parent.Type 68 | $ TypeDefinition.name definition 69 | , Definition.signature = constructorSignature 70 | } 71 | where 72 | resultSignature = foldl' 73 | (\ a b -> Signature.Application a b origin) 74 | (Signature.Variable (QualifiedName $ TypeDefinition.name definition) 75 | $ TypeDefinition.origin definition) 76 | $ map (\ (Parameter parameterOrigin parameter _kind) 77 | -> Signature.Variable (UnqualifiedName parameter) parameterOrigin) 78 | $ TypeDefinition.parameters definition 79 | constructorSignature = Signature.Quantified 80 | (TypeDefinition.parameters definition) 81 | (Signature.Function 82 | (DataConstructor.fields constructor) [resultSignature] [] origin) 83 | origin 84 | origin = DataConstructor.origin constructor 85 | qualifier = qualifierName $ TypeDefinition.name definition 86 | -------------------------------------------------------------------------------- /syntax/Kitten.JSON-tmLanguage: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Kitten", 3 | "scopeName": "source.kitten", 4 | "fileTypes": ["ktn"], 5 | "repository": { 6 | "general": { 7 | "patterns": [ 8 | { "include": "#linecomment" }, 9 | { "include": "#blockcomment" }, 10 | { "include": "#functiondef" }, 11 | { "include": "#builtin" }, 12 | { "include": "#keyword" }, 13 | { "include": "#boolean" }, 14 | { "include": "#numeric" }, 15 | { "include": "#singlequotestring" }, 16 | { "include": "#doublequotestring" }, 17 | { "include": "#operator" } 18 | ] 19 | }, 20 | "typesignature": { 21 | "patterns": [ 22 | { "include": "#linecomment" }, 23 | { "include": "#blockcomment" }, 24 | { "include": "#typename" }, 25 | { "include": "#operator" } 26 | ] 27 | }, 28 | "linecomment": { 29 | "name": "comment.line.kitten", 30 | "match": "//.*$" 31 | }, 32 | "blockcomment": { 33 | "name": "comment.block.kitten", 34 | "begin": "/\\*", 35 | "end": "\\*/" 36 | }, 37 | "functiondef": { 38 | "name": "meta.functiondef.kitten", 39 | "begin": "^\\s*(def)\\s*([a-z][0-9A-Za-z_]*|[!#$%&*+./;<=>?@^\\|~-]+)\\s*\\(", 40 | "beginCaptures": { 41 | "1": { "name": "keyword.control.kitten" }, 42 | "2": { "name": "entity.name.function.kitten" } 43 | }, 44 | "end": "\\)\\s*[:{]", 45 | "patterns": [ 46 | { "include": "#typesignature" } 47 | ] 48 | }, 49 | "builtin": { 50 | "name": "support.function.builtin.kitten", 51 | "match": "\\b__[a-z_]+\\b" 52 | }, 53 | "keyword": { 54 | "name": "keyword.control.kitten", 55 | "match": "\\b(choice|def|else|if|import|option)\\b" 56 | }, 57 | "boolean": { 58 | "name": "constant.language.kitten", 59 | "match": "\\b(true|false)\\b" 60 | }, 61 | "numeric": { 62 | "name": "constant.numeric.kitten", 63 | "match": "\\b[+-]?[0-9]+(?:\\.[0-9]+)?\\b" 64 | }, 65 | "singlequotestring": { 66 | "name": "string.quoted.single.kitten", 67 | "begin": "'", 68 | "beginCaptures": { 69 | "0": { "name": "punctuation.definition.string.begin.kitten" } 70 | }, 71 | "end": "'", 72 | "endCaptures": { 73 | "0": { "name": "punctuation.definition.string.end.kitten" } 74 | }, 75 | "patterns": [ 76 | { 77 | "match": "\\\\.", 78 | "name": "constant.character.escape.kitten" 79 | } 80 | ] 81 | }, 82 | "doublequotestring": { 83 | "name": "string.quoted.double.kitten", 84 | "begin": "\"", 85 | "beginCaptures": { 86 | "0": { "name": "punctuation.definition.string.begin.kitten" } 87 | }, 88 | "end": "\"", 89 | "endCaptures": { 90 | "0": { "name": "punctuation.definition.string.end.kitten" } 91 | }, 92 | "patterns": [ 93 | { 94 | "match": "\\\\.", 95 | "name": "constant.character.escape.kitten" 96 | } 97 | ] 98 | }, 99 | "operator": { 100 | "name": "keyword.operator.kitten", 101 | "match": "[!#$%&*+./;<=>?@^\\|~-]+" 102 | }, 103 | "typename": { 104 | "name": "storage.type.kitten", 105 | "match": "\\b[A-Z][0-9A-Za-z_]*\\b" 106 | } 107 | }, 108 | "patterns": [ 109 | { "include": "#general" } 110 | ], 111 | "uuid": "23d5cf35-7a0f-4f60-bfb3-84d0bf5fdab4" 112 | } -------------------------------------------------------------------------------- /lib/Kitten/Signature.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Signature 3 | Description : Type signatures 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Signature 14 | ( Signature(..) 15 | , origin 16 | ) where 17 | 18 | import Kitten.Entry.Parameter (Parameter(Parameter)) 19 | import Kitten.Kind (Kind(..)) 20 | import Kitten.Name (GeneralName) 21 | import Kitten.Origin (Origin) 22 | import Kitten.Type (Type) 23 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 24 | import qualified Kitten.Pretty as Pretty 25 | import qualified Kitten.Type as Type 26 | import qualified Text.PrettyPrint as Pretty 27 | 28 | -- | A parsed type signature. 29 | 30 | data Signature 31 | -- | @List\@ 32 | = Application Signature Signature !Origin 33 | -- | An empty stack. 34 | | Bottom !Origin 35 | -- | @A, B -> C, D +P +Q@ 36 | | Function [Signature] [Signature] [GeneralName] !Origin 37 | -- | @\ (...)@ 38 | | Quantified [Parameter] !Signature !Origin 39 | -- | @T@ 40 | | Variable !GeneralName !Origin 41 | -- | @R..., A, B -> S..., C, D +P +Q@ 42 | | StackFunction 43 | Signature [Signature] 44 | Signature [Signature] 45 | [GeneralName] 46 | !Origin 47 | -- | Produced when generating signatures for lifted quotations after 48 | -- typechecking. 49 | | Type !Type 50 | deriving (Show) 51 | 52 | -- | Signatures are compared regardless of origin. 53 | 54 | instance Eq Signature where 55 | Application a b _ == Application c d _ = (a, b) == (c, d) 56 | Function a b c _ == Function d e f _ = (a, b, c) == (d, e, f) 57 | Quantified a b _ == Quantified c d _ = (a, b) == (c, d) 58 | Variable a _ == Variable b _ = a == b 59 | StackFunction a b c d e _ == StackFunction f g h i j _ 60 | = (a, b, c, d, e) == (f, g, h, i, j) 61 | _ == _ = False 62 | 63 | origin :: Signature -> Origin 64 | origin signature = case signature of 65 | Application _ _ o -> o 66 | Bottom o -> o 67 | Function _ _ _ o -> o 68 | Quantified _ _ o -> o 69 | Variable _ o -> o 70 | StackFunction _ _ _ _ _ o -> o 71 | Type t -> Type.origin t 72 | 73 | instance Pretty Signature where 74 | pPrint signature = case signature of 75 | Application a b _ -> Pretty.hcat 76 | [pPrint a, Pretty.angles $ pPrint b] 77 | Bottom _ -> "" 78 | Function as bs es _ -> Pretty.parens $ Pretty.hsep $ 79 | [ Pretty.list $ map pPrint as 80 | , "->" 81 | , Pretty.list $ map pPrint bs 82 | ] ++ map ((Pretty.char '+' Pretty.<>) . pPrint) es 83 | Quantified names type_ _ -> Pretty.hsep 84 | [ Pretty.angles $ Pretty.list $ map prettyVar names 85 | , pPrint type_ 86 | ] 87 | where 88 | 89 | prettyVar :: Parameter -> Pretty.Doc 90 | prettyVar (Parameter _ name kind) = case kind of 91 | Value -> pPrint name 92 | Stack -> pPrint name Pretty.<> "..." 93 | Permission -> Pretty.char '+' Pretty.<> pPrint name 94 | _ -> error "quantified signature contains variable of invalid kind" 95 | 96 | Variable name _ -> pPrint name 97 | StackFunction r as s bs es _ -> Pretty.parens $ Pretty.hsep 98 | $ (pPrint r Pretty.<> "...") 99 | : map pPrint as ++ ["->"] 100 | ++ ((pPrint s Pretty.<> "...") : map pPrint bs) 101 | ++ map ((Pretty.char '+' Pretty.<>) . pPrint) es 102 | Type t -> pPrint t 103 | -------------------------------------------------------------------------------- /lib/Kitten/Mangle.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Mangle 3 | Description : Name mangling 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Mangle 14 | ( name 15 | ) where 16 | 17 | import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit) 18 | import Data.Monoid ((<>)) 19 | import Data.Text (Text) 20 | import Kitten.Instantiated (Instantiated(Instantiated)) 21 | import Kitten.Name (Qualified(..), Qualifier(..), Unqualified(..)) 22 | import Kitten.Type (Constructor(..), Type(..), Var(..)) 23 | import qualified Data.Text as Text 24 | import qualified Kitten.Vocabulary as Vocabulary 25 | 26 | -- | Mangles a fully qualified, fully saturated name into a linker symbol. 27 | -- 28 | -- FIXME: This should use the platform C++ name mangling scheme, if possible. 29 | 30 | name :: Instantiated -> Text 31 | name (Instantiated n args) = Text.concat 32 | -- kitten 33 | $ ["_K", qualified n] 34 | ++ if null args 35 | then [] 36 | else 37 | -- instantiate 38 | "_I" : map type_ args 39 | -- end 40 | ++ ["_E"] 41 | 42 | -- TODO: Use root. 43 | qualified :: Qualified -> Text 44 | qualified (Qualified (Qualifier _root parts) (Unqualified unqualified)) 45 | = Text.concat 46 | -- nested 47 | $ "_N" : map (lengthPrefix . normalize) (parts ++ [unqualified]) 48 | -- end 49 | ++ ["_E"] 50 | 51 | lengthPrefix :: Text -> Text 52 | lengthPrefix t = Text.pack (show (Text.length t)) <> t 53 | 54 | normalize :: Text -> Text 55 | normalize = Text.concatMap go 56 | where 57 | go :: Char -> Text 58 | go c = case c of 59 | '@' -> "_a" -- at 60 | '\\' -> "_b" -- backslash 61 | '^' -> "_c" -- circumflex 62 | '.' -> "_d" -- dot 63 | '=' -> "_e" -- equal 64 | '/' -> "_f" -- fraction 65 | '>' -> "_g" -- greater 66 | '#' -> "_h" -- hash 67 | -- "_i" 68 | -- "_j" 69 | -- "_k" 70 | '<' -> "_l" -- less 71 | '-' -> "_m" -- minus 72 | '&' -> "_n" -- and ('n') 73 | -- "_o" 74 | '+' -> "_p" -- plus 75 | '?' -> "_q" -- question 76 | '%' -> "_r" -- remainder 77 | '*' -> "_s" -- star (asterisk) 78 | '~' -> "_t" -- tilde 79 | -- "_u" 80 | '|' -> "_v" -- vertical bar 81 | -- "_w" 82 | '!' -> "_x" -- exclamation 83 | -- "_y" 84 | -- "_z" 85 | '_' -> "__" -- underscore 86 | 87 | _ 88 | | isDigit c || isAsciiLower c || isAsciiUpper c 89 | -> Text.singleton c 90 | | otherwise -> Text.concat 91 | -- unicode 92 | ["_U", Text.pack $ show $ ord c, "_"] 93 | 94 | type_ :: Type -> Text 95 | type_ t = case t of 96 | a :@ b -> Text.concat 97 | -- apply 98 | ["_A", type_ a, type_ b] 99 | TypeConstructor _ (Constructor constructor) 100 | | qualifierName constructor == Vocabulary.global 101 | -> case unqualifiedName constructor of 102 | "Bool" -> "_B" -- bool 103 | "Char" -> "_C" -- char 104 | "Float32" -> "_F4" -- float 105 | "Float64" -> "_F8" 106 | "Int8" -> "_I1" -- integer 107 | "Int16" -> "_I2" 108 | "Int32" -> "_I4" 109 | "Int64" -> "_I8" 110 | "List" -> "_L" -- list 111 | "UInt8" -> "_U1" -- unsigned 112 | "UInt16" -> "_U2" 113 | "UInt32" -> "_U4" 114 | "UInt64" -> "_U8" 115 | _ -> qualified constructor 116 | | otherwise 117 | -> qualified constructor 118 | TypeVar _ (Var _name i _kind) 119 | -- variable 120 | -> Text.concat ["_V", Text.pack $ show i] 121 | TypeValue{} -> error "TODO: mangle type value" 122 | TypeConstant _ (Var _name i _) 123 | -- constant 124 | -> Text.concat ["_K", Text.pack $ show i] 125 | Forall _ (Var _name i _) t' 126 | -- quantified 127 | -> Text.concat ["_Q", Text.pack $ show i, type_ t', "_E"] 128 | -------------------------------------------------------------------------------- /lib/Kitten/Monad.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Monad 3 | Description : Error-reporting I/O monad 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | module Kitten.Monad 12 | ( K 13 | , KT 14 | , attempt 15 | , runKitten 16 | ) where 17 | 18 | import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) 19 | import Control.Monad.Fail (MonadFail (..)) 20 | import Control.Monad.Fix (MonadFix(..)) 21 | import Control.Monad.IO.Class 22 | import Kitten.Informer (Informer(..)) 23 | import Kitten.Origin (Origin) 24 | import Kitten.Report (Report(..)) 25 | import System.IO.Unsafe (unsafeInterleaveIO) 26 | import qualified Text.PrettyPrint as Pretty 27 | 28 | -- | A Kitten action atop a 'Monad' 'm', returning a result of type 'a', which 29 | -- maintains a 'Context' stack and can fail with a list of 'Reports'. 30 | 31 | newtype KT m a = KT 32 | { unKT :: Context -> Reports -> m (Either Reports (a, Reports)) } 33 | 34 | type Context = [(Origin, Pretty.Doc)] 35 | 36 | type Reports = [Report] 37 | 38 | type K = KT IO 39 | 40 | -- | Runs a nested action, returning whether it completed successfully, that is, 41 | -- without generating any reports. 42 | 43 | attempt :: (Monad m) => KT m a -> KT m Bool 44 | attempt action = KT $ \ context reports -> do 45 | mr <- unKT action context reports 46 | return $ Right $ case mr of 47 | Left reports' -> (False, reports') 48 | Right (_, reports') -> (True, reports') 49 | 50 | -- | Runs an action, returning the accumulated reports (if any) or final result. 51 | 52 | runKitten :: (Monad m) => KT m a -> m (Either [Report] a) 53 | runKitten (KT m) = do 54 | mr <- m [] [] 55 | return $ case mr of 56 | Left reports -> Left reports 57 | Right (result, _) -> Right result 58 | 59 | instance (Monad m) => Functor (KT m) where 60 | fmap f (KT ax) = KT $ \ context reports -> do 61 | mr <- ax context reports 62 | case mr of 63 | Left reports' -> return $ Left reports' 64 | Right (x, reports') -> return $ Right (f x, reports') 65 | 66 | instance (Monad m) => Applicative (KT m) where 67 | pure x = KT $ \ _context reports -> return $ Right (x, reports) 68 | KT af <*> KT ax = KT $ \ context reports -> do 69 | mf <- af context reports 70 | case mf of 71 | Right (f, reports') -> do 72 | mx <- ax context reports' 73 | case mx of 74 | Right (x, reports'') -> return $ Right (f x, reports'') 75 | Left reports'' -> return $ Left reports'' 76 | Left reports' -> return $ Left reports' 77 | 78 | instance (Monad m) => Monad (KT m) where 79 | return x = KT $ \ _context reports -> return $ Right (x, reports) 80 | KT ax >>= f = KT $ \ context reports -> do 81 | mx <- ax context reports 82 | case mx of 83 | Left reports' -> return $ Left reports' 84 | Right (x, reports') -> unKT (f x) context reports' 85 | 86 | instance Monad m => MonadFail (KT m) where 87 | fail = error "do not use 'fail'" 88 | 89 | instance (MonadIO m) => MonadFix (KT m) where 90 | mfix k = KT $ \ context reports -> do 91 | m <- liftIO newEmptyMVar 92 | a <- liftIO $ unsafeInterleaveIO $ takeMVar m 93 | mx <- unKT (k a) context reports 94 | case mx of 95 | Left{} -> return mx 96 | Right (x, _) -> do 97 | liftIO $ putMVar m x 98 | return mx 99 | 100 | instance (MonadIO m) => MonadIO (KT m) where 101 | liftIO m = KT $ \ _context reports -> do 102 | x <- liftIO m 103 | return $ Right (x, reports) 104 | 105 | instance (Monad m) => Informer (KT m) where 106 | checkpoint = KT $ \ _context reports -> return 107 | $ if null reports then Right ((), reports) else Left reports 108 | halt = KT $ \ _context reports -> return $ Left reports 109 | report r = KT $ \ context reports -> return . Right . (,) () $ case context of 110 | [] -> r : reports 111 | _ -> Context context r : reports 112 | while origin message action = KT $ \ context reports 113 | -> unKT action ((origin, message) : context) reports 114 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Kitten Programming Language 2 | 3 | [![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.png)][gitter] [![Build Status](https://travis-ci.org/evincarofautumn/kitten.svg?branch=master)](https://travis-ci.org/evincarofautumn/kitten) 4 | 5 | **Kitten** is a statically typed, [stack-based functional programming language][concatenative] designed for simplicity, speed, and safety. This is an in-progress implementation of that language, including: 6 | 7 | * An interactive console for testing code 8 | 9 | * An interpreter 10 | 11 | * A native-code compiler producing static executables (incomplete) 12 | 13 | ## Contributing 14 | 15 | I need help to make Kitten a reality! If you’re interested in helping in any way, you’re more than welcome, even if you’re not experienced with Haskell or compiler development. You can look at the project for the [initial release] to see what I’m working on, and check out the [contribution guidelines][contributing] for suggestions on how you can help. 16 | 17 | ## Resources 18 | 19 | * Browse some [examples][examples] to get a feel for the language 20 | 21 | * Join the [chat room][gitter] to ask questions 22 | 23 | * Skim a quick [intro][intro] on the [official site][site] 24 | 25 | * Read the most recent updates to the [ebook][ebook] 26 | 27 | * Read my article introducing some interesting things about concatenative programming, [Why Concatenative Programming Matters][wcpm] 28 | 29 | * Watch my lecture describing the theory, history, and implementation techniques of the paradigm, [Concatenative Programming: From Ivory to Metal][cpim] 30 | 31 | ## Building and Installing 32 | 33 | If you’re building the compiler just to try it out or work on it, you can follow the preferred build method of using [Stack]: 34 | 35 | ``` 36 | git clone https://github.com/evincarofautumn/kitten.git 37 | cd kitten 38 | stack setup # only necessary on first build 39 | stack build 40 | 41 | stack exec kitten 42 | stack exec kitten -- 43 | ``` 44 | 45 | However, if you want to *install* Kitten in a standard location outside the build directory, due to a deficiency in Stack’s support for Cabal’s `data-files` feature, it is **not** recommended to use `stack install` to install a copy of the executable, because this will not install the *common vocabulary* `common.ktn` containing Kitten’s standard library. 46 | 47 | There are two workarounds. One is to forgo Stack, and build and install Kitten using Cabal directly: 48 | 49 | ``` 50 | cabal sandbox init 51 | cabal install --only-dependencies 52 | cabal install --prefix="$HOME/.local" 53 | ``` 54 | 55 | This will correctly install the common vocab so that Kitten can find it. The preferred install location for Kitten is `~/.local` on Unix-like systems (so the executable resides at `~/.local/bin/kitten`) or `%APPDATA%\local` on Windows (resp. `%APPDATA%\local\bin\kitten.exe`). 56 | 57 | The other option is to manually copy `common.ktn` to the install directory: 58 | 59 | ``` 60 | stack install 61 | cp common.ktn ~/.local/bin/ 62 | ``` 63 | 64 | It’s also recommended to add the install directory (`~/.local/bin` or `%APPDATA\local\bin`) to your `PATH` so that you can invoke `kitten` directly without a path prefix. 65 | 66 | These are the only files installed by Kitten, so to uninstall it, you only need to delete the compiler and common vocab from the install directory. 67 | 68 | ## Miscellany 69 | 70 | Kitten is distributed under the terms of the [MIT license][license]. Contributors should agree to abide by the [code of conduct]. 71 | 72 | [concatenative]: http://concatenative.org/ 73 | [examples]: https://github.com/evincarofautumn/kitten/tree/master/examples 74 | [intro]: http://kittenlang.org/intro/ 75 | [site]: http://kittenlang.org/ 76 | [Stack]: https://docs.haskellstack.org/en/stable/README/ 77 | [license]: https://github.com/evincarofautumn/kitten/blob/master/LICENSE.md 78 | [code of conduct]: https://github.com/evincarofautumn/kitten/blob/master/CODE_OF_CONDUCT.md 79 | [wcpm]: http://evincarofautumn.blogspot.com/2012/02/why-concatenative-programming-matters.html 80 | [cpim]: https://www.youtube.com/watch?v=_IgqJr8jG8M 81 | [ebook]: https://evincarofautumn.gitbooks.io/programming-with-kitten/ 82 | [initial release]: https://github.com/evincarofautumn/kitten/projects/1 83 | [contributing]: https://github.com/evincarofautumn/kitten/blob/master/CONTRIBUTING.md 84 | [gitter]: https://gitter.im/kittenlang/Lobby 85 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default : 2 | 3 | HLINT ?= hlint 4 | CABAL ?= cabal 5 | 6 | CABALFLAGS += --enable-tests 7 | MAKEFLAGS += --warn-undefined-variables 8 | .SECONDARY : 9 | 10 | BUILDDIR = ./dist/build/kitten 11 | EXAMPLES = $(wildcard examples/*.ktn) 12 | KITTEN = $(BUILDDIR)/kitten 13 | PRELUDE = $(BUILDDIR)/Prelude.ktn 14 | RUNTIME = kitten.o 15 | TESTER = ./test/run.sh 16 | TESTS = $(basename $(notdir $(wildcard test/*.ktn))) 17 | 18 | PHONY_TARGETS = \ 19 | deps \ 20 | configure \ 21 | build \ 22 | unit \ 23 | example \ 24 | test \ 25 | prelude \ 26 | sandbox \ 27 | lint \ 28 | loc \ 29 | clean 30 | 31 | # Declares a soft dependency such that, given: 32 | # 33 | # test : 34 | # build : 35 | # $(call SOFT_DEP_RULE_WITH,test,build,$(MAKECMDGOALS)) 36 | # 37 | # 'test' will depend upon 'build' if 'test' is specified in 38 | # the 'make' invocation. 39 | # 40 | # N.B. You must specify transitive dependencies. 41 | define SOFT_DEP_RULE_WITH 42 | $1 : | $(filter $2,$3) 43 | endef 44 | 45 | dev_DEPS = build prelude unit example test 46 | default_DEPS = sandbox deps configure $(dev_DEPS) 47 | 48 | BUILDING_PHONY_TARGETS = $(filter $(PHONY_TARGETS),$(MAKECMDGOALS)) 49 | ifeq ($(MAKECMDGOALS)$(filter-out dev,$(MAKECMDGOALS)),) 50 | BUILDING_PHONY_TARGETS += $(dev_DEPS) 51 | else 52 | ifeq ($(filter-out default,$(MAKECMDGOALS)),) 53 | BUILDING_PHONY_TARGETS += $(default_DEPS) 54 | endif 55 | endif 56 | 57 | define SOFT_DEP_RULE 58 | $(call SOFT_DEP_RULE_WITH,$1,$2,$(BUILDING_PHONY_TARGETS)) 59 | endef 60 | 61 | # Soft dependencies between .PHONY targets. 62 | deps_DEPS = clean 63 | configure_DEPS = clean $(deps_DEPS) deps 64 | build_DEPS = clean $(configure_DEPS) configure 65 | unit_DEPS = clean $(build_DEPS) build 66 | example_DEPS = clean $(build_DEPS) build $(prelude_DEPS) prelude 67 | test_DEPS = clean $(build_DEPS) build $(prelude_DEPS) prelude 68 | prelude_DEPS = clean $(build_DEPS) build 69 | lint_DEPS = clean 70 | loc_DEPS = clean 71 | clean_DEPS = 72 | $(foreach PHONY_TARGET,$(PHONY_TARGETS),$(eval $(call \ 73 | SOFT_DEP_RULE,$(PHONY_TARGET),$($(PHONY_TARGET)_DEPS)))) 74 | 75 | .PHONY : default 76 | default : $(default_DEPS) 77 | 78 | .PHONY : dev 79 | dev : $(dev_DEPS) 80 | 81 | .PHONY : build 82 | build : $(KITTEN) $(RUNTIME) 83 | 84 | .PHONY : $(KITTEN) 85 | $(KITTEN) : 86 | $(CABAL) build 87 | $(call SOFT_DEP_RULE,$(KITTEN),$(build_DEPS)) 88 | 89 | $(RUNTIME) : 90 | $(CC) -c kitten.c -I . -o $(RUNTIME) -Wall -Werror -Wextra -std=c99 91 | 92 | .PHONY : clean 93 | clean : 94 | $(CABAL) clean 95 | rm -f test/*.built 96 | rm -f test/*.err.c 97 | rm -f test/*.err.interpreted 98 | rm -f test/*.out.c 99 | rm -f test/*.out.interpreted 100 | rm -f $(RUNTIME) 101 | 102 | .PHONY : configure 103 | configure : 104 | $(CABAL) configure $(CABALFLAGS) 105 | 106 | .PHONY : sandbox 107 | sandbox : 108 | $(CABAL) sandbox init 109 | 110 | .PHONY : deps 111 | deps : sandbox 112 | $(CABAL) install $(CABALFLAGS) --only-dependencies 113 | 114 | .PHONY : prelude 115 | prelude : $(PRELUDE) 116 | 117 | $(PRELUDE) : $(KITTEN) lib/Prelude.ktn 118 | cp lib/Prelude.ktn $(PRELUDE) 119 | cp lib/Prelude_*.ktn $(BUILDDIR) 120 | $(KITTEN) --no-implicit-prelude $(PRELUDE) 121 | $(call SOFT_DEP_RULE,$(PRELUDE),$(prelude_DEPS)) 122 | 123 | .PHONY : unit 124 | unit : 125 | $(CABAL) test 126 | 127 | define EXAMPLE_RULE 128 | example-$1 : $(KITTEN) $(PRELUDE) 129 | @$(KITTEN) --check "$1" 130 | $(call SOFT_DEP_RULE,example-$1,$(example_DEPS)) 131 | example : example-$1 132 | endef 133 | 134 | .PHONY : $(foreach EXAMPLE,$(EXAMPLES),example-$(EXAMPLE)) 135 | $(foreach EXAMPLE,$(EXAMPLES),$(eval $(call EXAMPLE_RULE,$(EXAMPLE)))) 136 | 137 | .PHONY : test 138 | 139 | define TEST_RULE 140 | test-$1 : $(KITTEN) $(PRELUDE) $(TESTER) $(RUNTIME) 141 | @$(TESTER) $$(realpath $(KITTEN)) "$1" 142 | $(call SOFT_DEP_RULE,test-$1,$(test_DEPS)) 143 | test : test-$1 144 | endef 145 | 146 | .PHONY : $(foreach TEST,$(TESTS),test-$(TEST)) 147 | $(foreach TEST,$(TESTS),$(eval $(call TEST_RULE,$(TEST)))) 148 | 149 | .PHONY : lint 150 | lint : 151 | @ if which $(HLINT) 2>&1 >/dev/null; then \ 152 | $(HLINT) src lib; \ 153 | else \ 154 | echo "No HLint found."; \ 155 | fi 156 | 157 | .PHONY : loc 158 | loc : 159 | @ find . \ 160 | -type f \ 161 | -not -path './dist/*' \ 162 | -not -path './test/*.c' \ 163 | \( -name '*.hs' \ 164 | -o -name '*.ktn' \ 165 | -o -name '*.h' \ 166 | -o -name '*.c' \) \ 167 | -exec wc -l {} + \ 168 | | sort -n 169 | -------------------------------------------------------------------------------- /lib/Kitten/InstanceCheck.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.InstanceCheck 3 | Description : Checking types against signatures 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.InstanceCheck 14 | ( instanceCheck 15 | ) where 16 | 17 | import Control.Monad (forM_, unless) 18 | import Data.List (find) 19 | import Data.Set (Set) 20 | import Kitten.Informer (Informer(..)) 21 | import Kitten.Monad (K, attempt) 22 | import Kitten.Origin (Origin) 23 | import Kitten.Type (Constructor(..), Type(..), TypeId, Var(..)) 24 | import Kitten.TypeEnv (TypeEnv, freshTypeId) 25 | import qualified Data.Map as Map 26 | import qualified Data.Set as Set 27 | import qualified Kitten.Free as Free 28 | import qualified Kitten.Instantiate as Instantiate 29 | import qualified Kitten.Report as Report 30 | import qualified Kitten.Substitute as Substitute 31 | import qualified Kitten.Type as Type 32 | import qualified Kitten.TypeEnv as TypeEnv 33 | import qualified Kitten.Unify as Unify 34 | import qualified Kitten.Zonk as Zonk 35 | import qualified Text.PrettyPrint as Pretty 36 | 37 | -- | Checks whether one type is a generic instance of another, used for checking 38 | -- type signatures. Remember, when using this function, which way the subtyping 39 | -- relation goes: @∀α. α → α@ is a generic instance of @int → int@, not the 40 | -- other way around! 41 | 42 | instanceCheck :: Pretty.Doc -> Type -> Pretty.Doc -> Type -> K () 43 | instanceCheck aSort aScheme bSort bScheme = do 44 | let tenv0 = TypeEnv.empty 45 | let aType = aScheme 46 | (ids, bType) <- skolemize tenv0 bScheme 47 | let envTypes = Map.elems (TypeEnv.tvs tenv0) 48 | success <- attempt $ subsumptionCheck tenv0 aType bType 49 | unless success failure 50 | let escaped = Set.unions $ map (Free.tvs tenv0) (aScheme : bScheme : envTypes) 51 | -- Free.tvs tenv0 aScheme `Set.union` Free.tvs tenv0 bScheme 52 | let bad = Set.filter (`Set.member` escaped) ids 53 | unless (Set.null bad) failure 54 | return () 55 | where 56 | failure = report $ Report.FailedInstanceCheck aScheme bScheme 57 | 58 | -- | Skolemization replaces each quantified type variable with a type constant 59 | -- that unifies only with itself. 60 | 61 | skolemize :: TypeEnv -> Type -> K (Set TypeId, Type) 62 | skolemize tenv0 t = case t of 63 | Forall origin (Var name x k) t' -> do 64 | c <- freshTypeId tenv0 65 | substituted <- Substitute.type_ tenv0 x 66 | (TypeConstant origin $ Var name c k) t' 67 | (c', t'') <- skolemize tenv0 substituted 68 | return (Set.insert c c', t'') 69 | -- TForall _ t' -> skolemize tenv0 t' 70 | TypeConstructor origin "Fun" :@ a :@ b :@ e -> do 71 | (ids, b') <- skolemize tenv0 b 72 | return (ids, Type.fun origin a b' e) 73 | _ -> return (Set.empty, t) 74 | 75 | -- | Subsumption checking is largely the same as unification, accounting for 76 | -- function type variance: if @(a -> b) <: (c -> d)@ then @b <: d@ (covariant) 77 | -- but @c <: a@ (contravariant). 78 | 79 | subsumptionCheck :: TypeEnv -> Type -> Type -> K TypeEnv 80 | subsumptionCheck tenv0 (Forall origin (Var name x k) t) t2 = do 81 | (t1, _, tenv1) <- Instantiate.type_ tenv0 origin name x k t 82 | subsumptionCheck tenv1 t1 t2 83 | subsumptionCheck tenv0 t1 (TypeConstructor _ "Fun" :@ a' :@ b' :@ e') = do 84 | (a, b, e, tenv1) <- Unify.function tenv0 t1 85 | subsumptionCheckFun tenv1 a b e a' b' e' 86 | subsumptionCheck tenv0 (TypeConstructor _ "Fun" :@ a :@ b :@ e) t2 = do 87 | (a', b', e', tenv1) <- Unify.function tenv0 t2 88 | subsumptionCheckFun tenv1 a b e a' b' e' 89 | subsumptionCheck tenv0 t1 t2 = Unify.type_ tenv0 t1 t2 90 | 91 | subsumptionCheckFun 92 | :: TypeEnv -> Type -> Type -> Type -> Type -> Type -> Type -> K TypeEnv 93 | subsumptionCheckFun tenv0 a b e a' b' e' = do 94 | tenv1 <- subsumptionCheck tenv0 a' a 95 | tenv2 <- subsumptionCheck tenv1 b b' 96 | let 97 | labels = permissionList $ Zonk.type_ tenv2 e 98 | labels' = permissionList $ Zonk.type_ tenv2 e' 99 | forM_ labels $ \ (origin, label) -> case find ((label ==) . snd) labels' of 100 | Just{} -> return () 101 | Nothing -> report $ Report.MissingPermissionLabel e e' origin label 102 | return tenv2 103 | where 104 | 105 | permissionList :: Type -> [(Origin, Constructor)] 106 | permissionList (TypeConstructor _ "Join" :@ TypeConstructor origin label :@ es) 107 | = (origin, label) : permissionList es 108 | permissionList _ = [] 109 | -------------------------------------------------------------------------------- /lib/Kitten/Bracket.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Bracket 3 | Description : Whitespace-sensitive syntax desugaring 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | 13 | module Kitten.Bracket 14 | ( bracket 15 | ) where 16 | 17 | import Control.Applicative 18 | import Kitten.Indent (Indent(..)) 19 | import Kitten.Informer (Informer(..)) 20 | import Kitten.Layoutness (Layoutness(..)) 21 | import Kitten.Located (Located(..)) 22 | import Kitten.Parser (Bracketer, parserMatch, tokenSatisfy) 23 | import Kitten.Token (Token(..)) 24 | import Text.Parsec (()) 25 | import qualified Kitten.Located as Located 26 | import qualified Kitten.Origin as Origin 27 | import qualified Kitten.Report as Report 28 | import qualified Kitten.Token as Token 29 | import qualified Kitten.Vocabulary as Vocabulary 30 | import qualified Text.Parsec as Parsec 31 | 32 | -- | Desugars layout-based syntax into explicit brace-delimited blocks according 33 | -- to the *layout rule*: 34 | -- 35 | -- A layout block begins with a colon followed by a token whose source column is 36 | -- greater than the indent level of the colon token, and contains all tokens 37 | -- (and bracket-delimited groups of tokens) whose source column is greater than 38 | -- or equal to that of the first token. 39 | 40 | bracket 41 | :: (Informer m) 42 | => FilePath 43 | -> [Located (Token 'Layout)] 44 | -> m [Located (Token 'Nonlayout)] 45 | bracket path tokens 46 | = case Parsec.runParser insertBraces Vocabulary.global path tokens of 47 | Left parseError -> do 48 | report $ Report.parseError parseError 49 | halt 50 | Right result -> return result 51 | 52 | insertBraces :: Bracketer [Located (Token 'Nonlayout)] 53 | insertBraces = (concat <$> many unit) <* Parsec.eof 54 | where 55 | 56 | unit :: Bracketer [Located (Token 'Nonlayout)] 57 | unit = unitWhere (const True) 58 | 59 | unitWhere 60 | :: (Located (Token 'Layout) -> Bool) 61 | -> Bracketer [Located (Token 'Nonlayout)] 62 | unitWhere predicate 63 | = Parsec.try (Parsec.lookAhead (tokenSatisfy predicate)) *> Parsec.choice 64 | [ between BlockBegin BlockEnd 65 | , between GroupBegin GroupEnd 66 | , between VectorBegin VectorEnd 67 | , layoutBlock 68 | , (:[]) <$> (fromLayout =<< tokenSatisfy nonbracket) 69 | ] "layout item" 70 | 71 | between 72 | :: Token 'Layout 73 | -> Token 'Layout 74 | -> Bracketer [Located (Token 'Nonlayout)] 75 | between open close = do 76 | begin <- fromLayout =<< parserMatch open 77 | inner <- concat <$> many unit 78 | end <- fromLayout =<< parserMatch close 79 | return (begin : inner ++ [end]) 80 | 81 | nonbracket :: Located (Token 'Layout) -> Bool 82 | nonbracket = not . (`elem` brackets) . Located.item 83 | 84 | brackets :: [Token 'Layout] 85 | brackets = blockBrackets ++ 86 | [ GroupBegin 87 | , GroupEnd 88 | , VectorBegin 89 | , VectorEnd 90 | ] 91 | 92 | blockBrackets :: [Token 'Layout] 93 | blockBrackets = 94 | [ BlockBegin 95 | , BlockEnd 96 | , Colon 97 | ] 98 | 99 | layoutBlock :: Bracketer [Located (Token 'Nonlayout)] 100 | layoutBlock = do 101 | colon <- parserMatch Colon 102 | let 103 | colonOrigin = Located.origin colon 104 | Indent colonIndent = Located.indent colon 105 | validFirst = (> colonIndent) 106 | . Parsec.sourceColumn . Origin.begin . Located.origin 107 | firstToken <- Parsec.lookAhead (tokenSatisfy validFirst) 108 | "a token with a source column greater than \ 109 | \the start of the layout block" 110 | let 111 | firstOrigin = Origin.begin (Located.origin firstToken) 112 | inside = (>= Parsec.sourceColumn firstOrigin) 113 | . Parsec.sourceColumn . Origin.begin . Located.origin 114 | 115 | body <- concat <$> many (unitWhere inside) 116 | return $ At colonOrigin (Indent colonIndent) BlockBegin 117 | : body ++ [At colonOrigin (Indent colonIndent) BlockEnd] 118 | 119 | fromLayout 120 | :: Located (Token 'Layout) 121 | -> Bracketer (Located (Token 'Nonlayout)) 122 | fromLayout located = case Token.fromLayout (Located.item located) of 123 | Just nonlayout -> pure located { Located.item = nonlayout } 124 | Nothing -> Parsec.unexpected "colon not beginning valid layout block" 125 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | Thanks for your interest in contributing to Kitten! I hope this guide will give you an idea of ways that you can have a positive impact and help you get up to speed. 4 | 5 | ## Ways to Contribute 6 | 7 | A programming language is a large undertaking, and we need many different kinds of help from many different kinds of people. Even if you’re not experienced with programming language implementation, Haskell, or concatenative programming, you can still make a difference for everyone who comes after you. 8 | 9 | Follow the directions in the [README] to build the Kitten compiler, then try out the interactive interpreter by running `kitten`, or the batch interpreter by running `kitten filename.ktn`. I encourage you to try developing small programs, while keeping track of problems you encounter. It’s a new programming language, so I won’t sugar-coat it: you should be prepared to run into bugs. However, every problem we find and fix is a frustration that the next person doesn’t have to suffer. 10 | 11 | As you go along, feel free to submit [issues] or pull requests. Here are some examples of areas I’d like to hear about: 12 | 13 | * **Documentation** — If you find errors or incomplete information in Kitten’s documentation, such as the [README], [examples], and [wiki]. For issues about [kittenlang.org], head over to the [kittenlang.org repo] and file an issue there. You can build the internal compiler documentation with `stack haddock`; I’d appreciate patches to keep this documentation up to date and correctly formatted. 14 | 15 | * **Error Messages** — If you encounter unclear or misleading error messages, especially if they point to weird source locations. Bad error messages are considered bugs; the goal is to have the compiler help you *learn* the language as you use it. 16 | 17 | * **Examples** — If you’ve written a short, self-contained program in Kitten that you think would make a good example to demonstrate the language, such as a [Rosetta Code] solution; or if you find an error in the existing examples. 18 | 19 | * **Tooling** — If you find the tooling awkward or incomplete in any way, or you have an idea for a nice usability improvement, such as an interactive mode command, type system feature, or syntax change. 20 | 21 | * **Standard Library** — If you find yourself missing a useful utility function that you think should go in the [common vocabulary]. 22 | 23 | * **Performance** — If you encounter poor performance in the form of excessive run time, memory usage, or compile time, particularly with simple code that you would expect to be fast. 24 | 25 | * **Design** — If you have suggestions for improving the visual design of Kitten resources such as [kittenlang.org]. 26 | 27 | * **Accessibility** — If you encounter accessibility issues with the tooling or documentation, for example as a person with a visual impairment or limited mobility. 28 | 29 | Contributors must agree to the [Contributor License Agreement] and to abide by the guidelines for respectful collaboration set out in the [Code of Conduct]. 30 | 31 | ## Style Guidelines 32 | 33 | As a rule of thumb, when contributing Haskell or Kitten code, try to follow the style of the surrounding code, unless it sucks, in which case defer to your best judgement. 34 | 35 | The Haskell code uses 2-space indents and (usually) an 80-column limit, breaks lines before infix operators and after layout keywords such as `do` & `let`, rarely aligns things across lines, and prefers explicit or qualified imports. Otherwise, it generally follows [Johan Tibell’s Haskell Style Guide](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md), such as using `UpperCamelCase` for type and constructor names and `lowerCamelCase` names for functions and variables. It uses Haddock for internal documentation. 36 | 37 | The Kitten code also uses 2-space indents and an 80-column limit, with layout (`:`) for multi-line blocks and brackets `{}` for single-line blocks. By convention, type names and type variables are `UpperCamelCase`, while function names and local variables are `lower_underscore_case`. Documentation in Kitten code should be written in the `docs` section of metadata (`about`) blocks using Markdown formatting. 38 | 39 | Both the Haskell and Kitten code lean toward point-free style where reasonable. 40 | 41 | [Code of Conduct]: https://github.com/evincarofautumn/kitten/blob/master/CODE_OF_CONDUCT.md 42 | [Contributor License Agreement]: https://www.clahub.com/agreements/evincarofautumn/kitten 43 | [README]: https://github.com/evincarofautumn/kitten/blob/master/README.md 44 | [Rosetta Code]: http://rosettacode.org/ 45 | [common vocabulary]: https://github.com/evincarofautumn/kitten/blob/master/common.ktn 46 | [examples]: https://github.com/evincarofautumn/kitten/tree/master/examples 47 | [issues]: https://github.com/evincarofautumn/kitten/issues 48 | [kittenlang.org repo]: https://github.com/evincarofautumn/kittenlang.org 49 | [kittenlang.org]: http://kittenlang.org 50 | [wiki]: https://github.com/evincarofautumn/kitten/wiki 51 | -------------------------------------------------------------------------------- /lib/Kitten/Entry.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Entry 3 | Description : Dictionary entries 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Entry 14 | ( Entry(..) 15 | ) where 16 | 17 | import Data.List (intersperse) 18 | import Kitten.DataConstructor (DataConstructor) 19 | import Kitten.Entry.Category (Category) 20 | import Kitten.Entry.Merge (Merge) 21 | import Kitten.Entry.Parameter (Parameter) 22 | import Kitten.Entry.Parent (Parent) 23 | import Kitten.Name (Qualified) 24 | import Kitten.Origin (Origin) 25 | import Kitten.Signature (Signature) 26 | import Kitten.Term (Term) 27 | import Kitten.Type (Type) 28 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 29 | import qualified Kitten.DataConstructor as DataConstructor 30 | import qualified Kitten.Entry.Category as Category 31 | import qualified Kitten.Pretty as Pretty 32 | import qualified Text.PrettyPrint as Pretty 33 | 34 | -- | An entry in the dictionary. 35 | -- 36 | -- FIXME: This could use significant cleaning up. We could possibly make each 37 | -- constructor into a separate 'HashMap' in the 'Dictionary'. 38 | 39 | data Entry 40 | 41 | -- | A word definition. If the implementation is 'Nothing', this is a 42 | -- declaration: it can be used for type checking and name resolution, but not 43 | -- compilation. If the parent is a trait, this is a trait instance, with 44 | -- instance mangling. If the parent is a type, this is a constructor. 45 | -- Definitions without signatures are disallowed by the surface syntax, but 46 | -- they are generated for lifted lambdas, as those have already been 47 | -- typechecked by the time quotations are flattened into top-level definitions 48 | -- ("Kitten.Desugar.Quotations"). 49 | = Word !Category !Merge !Origin !(Maybe Parent) !(Maybe Signature) 50 | !(Maybe (Term Type)) 51 | 52 | -- | Untyped metadata from @about@ blocks. Used internally for operator 53 | -- precedence and associativity. 54 | | Metadata !Origin !(Term ()) 55 | 56 | -- | A link to another entry in the dictionary. Generated by imports and 57 | -- synonym declarations. 58 | | Synonym !Origin !Qualified 59 | 60 | -- | A trait to which other entries can link. 61 | | Trait !Origin !Signature 62 | 63 | -- | A data type with some generic parameters. 64 | | Type !Origin [Parameter] [DataConstructor] 65 | 66 | -- | An instantiation of a data type, with the given size. 67 | | InstantiatedType !Origin !Int 68 | 69 | deriving (Show) 70 | 71 | instance Pretty Entry where 72 | pPrint entry = case entry of 73 | 74 | Word category _merge origin mParent mSignature _body -> Pretty.vcat 75 | [ case category of 76 | Category.Constructor -> "constructor" -- of type 77 | Category.Instance -> "instance" -- of trait 78 | Category.Permission -> "permission" 79 | Category.Word -> "word" 80 | , Pretty.hsep ["defined at", pPrint origin] 81 | , case mSignature of 82 | Just signature -> Pretty.hsep 83 | ["with signature", Pretty.quote signature] 84 | Nothing -> "with no signature" 85 | , case mParent of 86 | Just parent -> Pretty.hsep 87 | ["with parent", pPrint parent] 88 | Nothing -> "with no parent" 89 | ] 90 | 91 | Metadata origin term -> Pretty.vcat 92 | [ "metadata" 93 | , Pretty.hsep ["defined at", pPrint origin] 94 | , Pretty.hsep ["with contents", pPrint term] 95 | ] 96 | 97 | Synonym origin name -> Pretty.vcat 98 | [ "synonym" 99 | , Pretty.hsep ["defined at", pPrint origin] 100 | , Pretty.hsep ["standing for", pPrint name] 101 | ] 102 | 103 | Trait origin signature -> Pretty.vcat 104 | [ "trait" 105 | , Pretty.hsep ["defined at", pPrint origin] 106 | , Pretty.hsep ["with signature", pPrint signature] 107 | ] 108 | 109 | Type origin parameters ctors -> Pretty.vcat 110 | [ "type" 111 | , Pretty.hsep ["defined at", pPrint origin] 112 | , Pretty.hcat $ "with parameters <" 113 | : intersperse ", " (map pPrint parameters) 114 | ++ [">"] 115 | , Pretty.vcat 116 | [ "and data constructors" 117 | , Pretty.nest 4 $ Pretty.vcat 118 | $ map constructor ctors 119 | ] 120 | ] 121 | where 122 | constructor ctor = Pretty.hcat 123 | [ pPrint $ DataConstructor.name ctor 124 | , " with fields (" 125 | , Pretty.hcat $ intersperse ", " 126 | $ map pPrint $ DataConstructor.fields ctor 127 | , ")" 128 | ] 129 | 130 | InstantiatedType origin size -> Pretty.vcat 131 | [ "instantiated type" 132 | , Pretty.hsep ["defined at", pPrint origin] 133 | , Pretty.hcat ["with size", pPrint size] 134 | ] 135 | -------------------------------------------------------------------------------- /lib/Kitten/Desugar/Quotations.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Desugar.Quotations 3 | Description : Lifting anonymous functions 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | 12 | module Kitten.Desugar.Quotations 13 | ( desugar 14 | ) where 15 | 16 | import Control.Monad.Trans.Class (lift) 17 | import Control.Monad.Trans.State (StateT, gets, modify, runStateT) 18 | import Data.Foldable (foldrM) 19 | import Kitten.Dictionary (Dictionary) 20 | import Kitten.Infer (inferType0) 21 | import Kitten.Instantiated (Instantiated(Instantiated)) 22 | import Kitten.Monad (K) 23 | import Kitten.Name (Closed(..), Qualified(..), Qualifier, Unqualified(..)) 24 | import Kitten.Term (Case(..), Else(..), Term(..), Value(..)) 25 | import Kitten.Type (Type(..), Var(..)) 26 | import Kitten.TypeEnv (TypeEnv) 27 | import qualified Data.Map as Map 28 | import qualified Data.Text as Text 29 | import qualified Kitten.Dictionary as Dictionary 30 | import qualified Kitten.Entry as Entry 31 | import qualified Kitten.Entry.Category as Category 32 | import qualified Kitten.Entry.Merge as Merge 33 | import qualified Kitten.Free as Free 34 | import qualified Kitten.Signature as Signature 35 | import qualified Kitten.Term as Term 36 | import qualified Kitten.TypeEnv as TypeEnv 37 | 38 | newtype LambdaIndex = LambdaIndex Int 39 | 40 | -- | Lifts quotations in a 'Term' into top-level definitions, within the 41 | -- vocabulary referenced by a 'Qualifier', adding them to the 'Dictionary'. 42 | 43 | desugar 44 | :: Dictionary 45 | -> Qualifier 46 | -> Term Type 47 | -> K (Term Type, Dictionary) 48 | desugar dictionary qualifier term0 = do 49 | ((term', _), (_, dictionary')) <- flip runStateT (LambdaIndex 0, dictionary) 50 | $ go TypeEnv.empty term0 51 | return (term', dictionary') 52 | where 53 | 54 | go 55 | :: TypeEnv 56 | -> Term Type 57 | -> StateT (LambdaIndex, Dictionary) K (Term Type, TypeEnv) 58 | go tenv0 term = case term of 59 | Coercion{} -> done 60 | Compose type_ a b -> do 61 | (a', tenv1) <- go tenv0 a 62 | (b', tenv2) <- go tenv1 b 63 | return (Compose type_ a' b', tenv2) 64 | Generic name type_ a origin -> do 65 | (a', tenv1) <- go tenv0 a 66 | return (Generic name type_ a' origin, tenv1) 67 | Group{} -> error "group should not appear after infix desugaring" 68 | Lambda type_ name varType a origin -> do 69 | let 70 | oldLocals = TypeEnv.vs tenv0 71 | localEnv = tenv0 { TypeEnv.vs = varType : TypeEnv.vs tenv0 } 72 | (a', tenv1) <- go localEnv a 73 | let tenv2 = tenv1 { TypeEnv.vs = oldLocals } 74 | return (Lambda type_ name varType a' origin, tenv2) 75 | Match hint type_ cases else_ origin -> do 76 | (cases', tenv1) <- foldrM 77 | (\ (Case name a caseOrigin) (acc, tenv) -> do 78 | (a', tenv') <- go tenv a 79 | return (Case name a' caseOrigin : acc, tenv')) ([], tenv0) cases 80 | (else', tenv2) <- case else_ of 81 | Else a elseOrigin -> do 82 | (a', tenv') <- go tenv1 a 83 | return (Else a' elseOrigin, tenv') 84 | return (Match hint type_ cases' else' origin, tenv2) 85 | New{} -> done 86 | NewClosure{} -> done 87 | NewVector{} -> done 88 | Push _type (Capture closed a) origin -> do 89 | let 90 | types = map (TypeEnv.getClosed tenv0) closed 91 | oldClosure = TypeEnv.closure tenv0 92 | localEnv = tenv0 { TypeEnv.closure = types } 93 | (a', tenv1) <- go localEnv a 94 | let tenv2 = tenv1 { TypeEnv.closure = oldClosure } 95 | LambdaIndex index <- gets fst 96 | let 97 | name = Qualified qualifier 98 | $ Unqualified $ Text.pack $ "lambda" ++ show index 99 | modify $ \ (_, d) -> (LambdaIndex $ succ index, d) 100 | let 101 | deducedType = Term.type_ a 102 | type_ = foldr addForall deducedType 103 | $ Map.toList $ Free.tvks tenv2 deducedType 104 | addForall (i, (n, k)) = Forall origin (Var n i k) 105 | modify $ \ (l, d) -> let 106 | entry = Entry.Word 107 | Category.Word 108 | Merge.Deny 109 | (Term.origin a') 110 | Nothing 111 | (Just (Signature.Type type_)) 112 | (Just a') 113 | in (l, Dictionary.insert (Instantiated name []) entry d) 114 | dict <- gets snd 115 | (typechecked, _) <- lift $ inferType0 dict tenv2 Nothing 116 | $ Term.compose () origin $ map pushClosed closed ++ 117 | [ Push () (Name name) origin 118 | , NewClosure () (length closed) origin 119 | ] 120 | return (typechecked, tenv2) 121 | where 122 | 123 | pushClosed :: Closed -> Term () 124 | pushClosed name = Push () (case name of 125 | ClosedLocal index -> Local index 126 | ClosedClosure index -> Closed index) origin 127 | 128 | Push{} -> done 129 | Word{} -> done 130 | where 131 | done = return (term, tenv0) 132 | -------------------------------------------------------------------------------- /lib/Kitten/Linearize.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Linearize 3 | Description : Instrumentation of copies and drops 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Linearize 14 | ( linearize 15 | ) where 16 | 17 | import Control.Arrow (first) 18 | import Data.List (transpose) 19 | import Kitten.Name (GeneralName(..), LocalIndex(..), Qualified(..)) 20 | import Kitten.Origin (Origin) 21 | import Kitten.Term (Case(..), Else(..), Term(..), Value(..)) 22 | import Kitten.Type (Type) 23 | import qualified Kitten.Operator as Operator 24 | import qualified Kitten.Term as Term 25 | import qualified Kitten.Vocabulary as Vocabulary 26 | 27 | -- | Linearization replaces all copies and drops with explicit invocations of 28 | -- the @_::copy@ and @_::drop@ words. A value is copied if it appears twice or 29 | -- more in its scope; it's dropped if it doesn't appear at all, or if an 30 | -- explicit @drop@ is present due to an ignored local (@_@). If it only appears 31 | -- once, it is moved, and no special word is invoked. 32 | -- 33 | -- FIXME: This is experimental and subject to change. 34 | 35 | linearize :: Term Type -> Term Type 36 | linearize = snd . go [] 37 | where 38 | 39 | go :: [Int] -> Term Type -> ([Int], Term Type) 40 | go counts0 term = case term of 41 | Coercion{} -> (counts0, term) 42 | Compose type_ a b -> let 43 | (counts1, a') = go counts0 a 44 | (counts2, b') = go counts1 b 45 | in (counts2, Compose type_ a' b') 46 | Generic name x body origin -> let 47 | (counts1, body') = go counts0 body 48 | in (counts1, Generic name x body' origin) 49 | Group{} -> error "group should not appear after desugaring" 50 | Lambda type_ x varType body origin -> let 51 | (n : counts1, body') = go (0 : counts0) body 52 | body'' = case n of 53 | 0 -> instrumentDrop origin varType body' 54 | 1 -> body' 55 | _ -> instrumentCopy varType body' 56 | in (counts1, Lambda type_ x varType body'' origin) 57 | -- FIXME: count usages for each branch & take maximum 58 | Match hint type_ cases else_ origin -> let 59 | 60 | (counts1, mElse') = goElse counts0 else_ 61 | (counts2, cases') = first (map maximum . transpose) 62 | $ unzip $ map (goCase counts0) cases 63 | in (zipWith max counts1 counts2, Match hint type_ cases' mElse' origin) 64 | where 65 | 66 | goCase :: [Int] -> Case Type -> ([Int], Case Type) 67 | goCase counts (Case name body caseOrigin) = let 68 | (counts1, body') = go counts body 69 | in (counts1, Case name body' caseOrigin) 70 | 71 | goElse :: [Int] -> Else Type -> ([Int], Else Type) 72 | goElse counts (Else body elseOrigin) = let 73 | (counts1, body') = go counts body 74 | in (counts1, Else body' elseOrigin) 75 | 76 | New{} -> (counts0, term) 77 | NewClosure{} -> (counts0, term) 78 | NewVector{} -> (counts0, term) 79 | Push _ (Local (LocalIndex index)) _ -> let 80 | (h, t : ts) = splitAt index counts0 81 | in (h ++ succ t : ts, term) 82 | Push _ Capture{} _ -> error 83 | "pushing of capture should not appear after desugaring" 84 | Push _ Quotation{} _ -> error 85 | "pushing of quotation should not appear after desugaring" 86 | Push{} -> (counts0, term) 87 | Word{} -> (counts0, term) 88 | 89 | instrumentDrop :: Origin -> Type -> Term Type -> Term Type 90 | instrumentDrop origin type_ a = Term.compose todoTyped origin 91 | [ a 92 | , Push todoTyped (Local (LocalIndex 0)) origin 93 | , Word todoTyped Operator.Postfix 94 | (QualifiedName (Qualified Vocabulary.global "drop")) [type_] origin 95 | ] 96 | 97 | instrumentCopy :: Type -> Term Type -> Term Type 98 | instrumentCopy varType = go 0 99 | where 100 | 101 | go :: Int -> Term Type -> Term Type 102 | go n term = case term of 103 | Coercion{} -> term 104 | Compose type_ a b -> Compose type_ (go n a) (go n b) 105 | Generic name i body origin -> Generic name i (go n body) origin 106 | Group{} -> error "group should not appear after desugaring" 107 | Lambda type_ name varType' body origin 108 | -> Lambda type_ name varType' (go (succ n) body) origin 109 | Match hint type_ cases else_ origin 110 | -> Match hint type_ (map goCase cases) (goElse else_) origin 111 | where 112 | 113 | goCase :: Case Type -> Case Type 114 | goCase (Case name body caseOrigin) = Case name (go n body) caseOrigin 115 | 116 | goElse :: Else Type -> Else Type 117 | goElse (Else body elseOrigin) = Else (go n body) elseOrigin 118 | 119 | New{} -> term 120 | NewClosure{} -> term 121 | NewVector{} -> term 122 | Push _ (Local (LocalIndex index)) origin 123 | | index == n 124 | -> Compose todoTyped term $ Word todoTyped Operator.Postfix 125 | (QualifiedName (Qualified Vocabulary.global "copy")) [varType] origin 126 | Push{} -> term 127 | Word{} -> term 128 | 129 | todoTyped :: a 130 | todoTyped = error "TODO: generate typed terms" 131 | -------------------------------------------------------------------------------- /test/Test/Origin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Origin 4 | ( spec 5 | ) where 6 | 7 | import Data.Functor.Identity (runIdentity) 8 | import Data.List (foldl') 9 | import Kitten.Monad (runKitten) 10 | import Kitten.Origin (Origin(Origin)) 11 | import Kitten.Tokenize (tokenize) 12 | import Test.Hspec (Expectation, Spec, it, shouldBe) 13 | import Text.Parsec.Pos (Column, Line) 14 | import qualified Data.Text as Text 15 | import qualified Kitten.Located as Located 16 | import qualified Kitten.Origin as Origin 17 | 18 | spec :: Spec 19 | spec = do 20 | it "literals" $ do 21 | testOrigin 22 | [ "0" 23 | , "^" 24 | ] 25 | testOrigin 26 | [ "0xFF" 27 | , "<-->" 28 | ] 29 | testOrigin 30 | [ "0o777" 31 | , "<--->" 32 | ] 33 | testOrigin 34 | [ "0b1010" 35 | , "<---->" 36 | ] 37 | testOrigin 38 | [ "\"\"" 39 | , ".<.>" 40 | ] 41 | testOrigin 42 | [ "\"\\ \"" 43 | , ".<.-----.>" 44 | ] 45 | it "hello world" $ do 46 | testOrigin 47 | [ "\"meow\" say" 48 | , ".<----.> <->" 49 | ] 50 | testOrigin 51 | [ "\"meow\"" 52 | , ".<----.>" 53 | , "say" 54 | , "<->" 55 | ] 56 | testOrigin 57 | [ "\"meow\"say" 58 | , ".<----.><->" 59 | ] 60 | testOrigin 61 | [ "define greet (-> +io) { \"meow\" say }" 62 | , "<----> <---> ^<> ^<>^ ^ .<----.> <-> ^" 63 | ] 64 | testOrigin 65 | [ "define greet (-> +io) {" 66 | , "<----> <---> ^<> ^<>^ ^" 67 | , " \"meow\" say" 68 | , " .<----.> <->" 69 | , "}" 70 | , "^" 71 | ] 72 | testOrigin 73 | [ "define greet<+E> (-> +io +E) {" 74 | , "<----> <--->^^^^ ^<> ^<> ^^^ ^" 75 | , " \"meow\" say" 76 | , " .<----.> <->" 77 | , "}" 78 | , "^" 79 | ] 80 | testOrigin 81 | [ "define greet (R... -> R... +io +E) {" 82 | , "<----> <--->^^<->^ ^^^ ^^<-> <> ^<-> ^<> ^^^ ^" 83 | , " \"meow\" say" 84 | , " .<----.> <->" 85 | , "}" 86 | , "^" 87 | ] 88 | testOrigin 89 | [ "define greet(R...->R...+io+E){\"meow\"say}" 90 | , "<----> <--->^^<->^^^^^^<-><>^<->^<>^^^^.<----.><->^" 91 | ] 92 | 93 | testOrigin :: [String] -> Expectation 94 | testOrigin test = let 95 | (input, origins) = deinterleave test 96 | in (fmap (map Located.origin) $ runIdentity $ runKitten $ tokenize 1 "test" 97 | $ Text.unlines $ map Text.pack input) 98 | `shouldBe` Right (parseOrigins origins) 99 | 100 | deinterleave :: [a] -> ([a], [a]) 101 | deinterleave = go ([], []) 102 | where 103 | go (as, bs) (a : b : xs) = go (a : as, b : bs) xs 104 | go _ [_] = error "deinterleave: uneven input" 105 | go (as, bs) [] = (reverse as, reverse bs) 106 | 107 | data Span = Span !Column !Column 108 | 109 | data Env = Env 110 | { envPoint :: !Column 111 | , envSpans :: [Span] 112 | } 113 | 114 | parseOrigins :: [String] -> [Origin] 115 | parseOrigins = concatMap (uncurry goLine) . zip [1..] 116 | where 117 | 118 | goLine :: Line -> String -> [Origin] 119 | goLine line = map (toOrigin line) . reverse . envSpans . foldl' go Env 120 | { envPoint = 1 121 | , envSpans = [] 122 | } 123 | 124 | toOrigin :: Line -> Span -> Origin 125 | toOrigin line (Span begin end) = Origin 126 | { Origin.name = "test" 127 | , Origin.beginLine = line 128 | , Origin.beginColumn = begin 129 | , Origin.endLine = line 130 | , Origin.endColumn = end 131 | } 132 | 133 | go :: Env -> Char -> Env 134 | go env@Env { envPoint = point, envSpans = spans } char = case char of 135 | '^' -> Env 136 | { envPoint = point + 1 137 | , envSpans = Span point (point + 1) : spans 138 | } 139 | '<' -> Env 140 | { envPoint = point + 1 141 | , envSpans = Span point point : spans 142 | } 143 | '-' -> case spans of 144 | Span begin end : spans' -> Env 145 | { envPoint = point + 1 146 | , envSpans = Span begin (end + 1) : spans' 147 | } 148 | [] -> malformed 149 | '>' -> case spans of 150 | Span begin end : spans' -> Env 151 | { envPoint = point + 1 152 | , envSpans = Span begin (end + 2) : spans' 153 | } 154 | [] -> malformed 155 | '|' -> case spans of 156 | Span begin end : spans' -> Env 157 | { envPoint = point + 1 158 | , envSpans = Span point point : Span begin (end + 1) : spans' 159 | } 160 | [] -> malformed 161 | ' ' -> env { envPoint = point + 1 } 162 | '.' -> env 163 | _ -> malformed 164 | where 165 | malformed = error $ concat 166 | [ "malformed origin string at (" 167 | , show point 168 | , "): '" 169 | , [char] 170 | , "'" 171 | ] 172 | 173 | -- "." -> [(1, 1)-(1, 1)] 174 | -- ".-" -> [(1, 1)-(1, 2)] 175 | -- ".." -> [(1, 1)-(1, 1), (1, 2)-(1, 2)] 176 | -- ".-." -> [(1, 1)-(1, 2), (1, 3)-(1, 3)] 177 | -- ".:" -> [(1, 1)-(1, 2), (1, 2)-(1, 2)] 178 | -- ".:-" -> [(1, 1)-(1, 2), (1, 2)-(1, 3)] 179 | -- ".\n." -> [(1, 1)-(1, 1), (2, 1)-(2, 1)] 180 | -------------------------------------------------------------------------------- /lib/Kitten/Name.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Name 3 | Description : Program identifiers 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | module Kitten.Name 15 | ( GeneralName(..) 16 | , Closed(..) 17 | , ClosureIndex(..) 18 | , ConstructorIndex(..) 19 | , LocalIndex(..) 20 | , Qualified(..) 21 | , Qualifier(..) 22 | , Root(..) 23 | , Unqualified(..) 24 | , isOperatorName 25 | , toParts 26 | , qualifiedFromQualifier 27 | , qualifierFromName 28 | ) where 29 | 30 | import Control.Applicative (liftA2) 31 | import Data.Char (isLetter) 32 | import Data.Hashable (Hashable(..)) 33 | import Data.Text (Text) 34 | import GHC.Exts (IsString(..)) 35 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 36 | import qualified Data.Text as Text 37 | import qualified Text.PrettyPrint as Pretty 38 | 39 | -- | A dynamic name, which might be 'Qualified', 'Unqualified', or local. 40 | 41 | data GeneralName 42 | = QualifiedName !Qualified 43 | | UnqualifiedName !Unqualified 44 | | LocalName !LocalIndex 45 | deriving (Eq, Ord, Show) 46 | 47 | instance IsString GeneralName where 48 | fromString = UnqualifiedName . fromString 49 | 50 | -- | A qualified name is an unqualified name (@x@) plus a qualifier (@q::@). 51 | 52 | data Qualified = Qualified 53 | { qualifierName :: !Qualifier 54 | , unqualifiedName :: !Unqualified 55 | } deriving (Eq, Ord, Show) 56 | 57 | -- | A qualifier is a list of vocabulary names, rooted globally or within the 58 | -- current vocabulary. 59 | 60 | data Qualifier = Qualifier !Root [Text] 61 | deriving (Eq, Ord, Show) 62 | 63 | -- | A 'Relative' qualifier refers to a sub-vocabulary of the current one. An 64 | -- 'Absolute' qualifier refers to the global vocabulary. 65 | 66 | data Root = Relative | Absolute 67 | deriving (Eq, Ord, Show) 68 | 69 | -- | An unqualified name is an ordinary symbol. 70 | 71 | data Unqualified = Unqualified Text 72 | deriving (Eq, Ord, Show) 73 | 74 | -- | A closed name is a local or closure variable that was captured by a 75 | -- quotation. FIXME: this can be removed if closure variables are rewritten into 76 | -- implicit locals. 77 | 78 | data Closed 79 | = ClosedLocal !LocalIndex 80 | | ClosedClosure !ClosureIndex 81 | deriving (Eq, Show) 82 | 83 | -- | An index into a closure. 84 | 85 | newtype ClosureIndex = ClosureIndex Int 86 | deriving (Eq, Ord, Show) 87 | 88 | -- | The index of a data type constructor. 89 | 90 | newtype ConstructorIndex = ConstructorIndex Int 91 | deriving (Eq, Ord, Show) 92 | 93 | -- | The De Bruijn index of a local variable. 94 | 95 | newtype LocalIndex = LocalIndex Int 96 | deriving (Eq, Ord, Show) 97 | 98 | -- TODO: Use types, not strings. 99 | isOperatorName :: Qualified -> Bool 100 | isOperatorName = match . unqualifiedName 101 | where 102 | match (Unqualified name) = not 103 | $ liftA2 (||) (Text.all isLetter) (== "_") 104 | $ Text.take 1 name 105 | 106 | toParts :: Qualified -> [Text] 107 | toParts (Qualified (Qualifier _root parts) (Unqualified part)) 108 | = parts ++ [part] 109 | 110 | qualifiedFromQualifier :: Qualifier -> Qualified 111 | qualifiedFromQualifier qualifier = case qualifier of 112 | Qualifier _ [] -> error "qualifiedFromQualifier: empty qualifier" 113 | Qualifier root parts -> Qualified 114 | (Qualifier root $ init parts) $ Unqualified $ last parts 115 | 116 | qualifierFromName :: Qualified -> Qualifier 117 | qualifierFromName (Qualified (Qualifier root parts) (Unqualified name)) 118 | = Qualifier root (parts ++ [name]) 119 | 120 | instance Hashable Qualified where 121 | hashWithSalt s (Qualified qualifier unqualified) 122 | = hashWithSalt s (0 :: Int, qualifier, unqualified) 123 | 124 | instance Hashable Qualifier where 125 | hashWithSalt s (Qualifier root parts) 126 | = hashWithSalt s (0 :: Int, root, Text.concat parts) 127 | 128 | instance Hashable Root where 129 | hashWithSalt s root = hashWithSalt s $ case root of 130 | Relative -> 0 :: Int 131 | Absolute -> 1 :: Int 132 | 133 | instance Hashable Unqualified where 134 | hashWithSalt s (Unqualified name) = hashWithSalt s (0 :: Int, name) 135 | 136 | instance IsString Unqualified where 137 | fromString = Unqualified . Text.pack 138 | 139 | instance Pretty Qualified where 140 | pPrint qualified = pPrint (qualifierName qualified) 141 | Pretty.<> "::" Pretty.<> pPrint (unqualifiedName qualified) 142 | 143 | instance Pretty Qualifier where 144 | pPrint (Qualifier Absolute parts) = pPrint $ Qualifier Relative $ "_" : parts 145 | pPrint (Qualifier Relative parts) = Pretty.text 146 | $ Text.unpack $ Text.intercalate "::" parts 147 | 148 | instance Pretty Unqualified where 149 | pPrint (Unqualified unqualified) = Pretty.text $ Text.unpack unqualified 150 | 151 | instance Pretty GeneralName where 152 | pPrint name = case name of 153 | QualifiedName qualified -> pPrint qualified 154 | UnqualifiedName unqualified -> pPrint unqualified 155 | LocalName (LocalIndex i) -> "local." Pretty.<> Pretty.int i 156 | 157 | instance Pretty Closed where 158 | pPrint (ClosedLocal (LocalIndex index)) = Pretty.hcat 159 | ["local.", Pretty.int index] 160 | pPrint (ClosedClosure (ClosureIndex index)) = Pretty.hcat 161 | ["closure.", Pretty.int index] 162 | -------------------------------------------------------------------------------- /Kitten.cabal: -------------------------------------------------------------------------------- 1 | name: Kitten 2 | version: 0.1.0.0 3 | synopsis: Kitten Programming Language 4 | homepage: http://kittenlang.org/ 5 | license: MIT 6 | author: Jon Purdy 7 | maintainer: evincarofautumn@gmail.com 8 | category: Language 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | data-files: common.ktn 13 | 14 | executable kitten 15 | build-depends: 16 | 17 | base >=4.8, 18 | 19 | Kitten, 20 | bytestring, 21 | cmdargs, 22 | containers, 23 | hashable, 24 | haskeline, 25 | parsec, 26 | pretty, 27 | text, 28 | transformers, 29 | unordered-containers, 30 | vector 31 | 32 | default-language: Haskell2010 33 | ghc-options: -Wall -O2 34 | hs-source-dirs: src 35 | main-is: Main.hs 36 | 37 | other-modules: 38 | Arguments 39 | Interact 40 | Paths_Kitten 41 | Report 42 | 43 | library 44 | 45 | build-depends: 46 | 47 | base >=4.8, 48 | 49 | JuicyPixels, 50 | base64-bytestring, 51 | bytestring, 52 | containers, 53 | hashable, 54 | parsec, 55 | pretty, 56 | text, 57 | transformers, 58 | unordered-containers, 59 | vector 60 | 61 | if !impl(ghc >= 8.0) 62 | build-depends: 63 | fail, 64 | semigroups 65 | 66 | default-language: Haskell2010 67 | 68 | exposed-modules: 69 | 70 | Kitten 71 | Kitten.Amd64 72 | Kitten.Base 73 | Kitten.Bits 74 | Kitten.Bracket 75 | Kitten.CollectInstantiations 76 | Kitten.DataConstructor 77 | Kitten.Declaration 78 | Kitten.Definition 79 | Kitten.Desugar.Data 80 | Kitten.Desugar.Infix 81 | Kitten.Desugar.Quotations 82 | Kitten.Dictionary 83 | Kitten.Element 84 | Kitten.Enter 85 | Kitten.Entry 86 | Kitten.Entry.Category 87 | Kitten.Entry.Merge 88 | Kitten.Entry.Parameter 89 | Kitten.Entry.Parent 90 | Kitten.Fragment 91 | Kitten.Free 92 | Kitten.IO 93 | Kitten.Indent 94 | Kitten.Infer 95 | Kitten.Informer 96 | Kitten.InstanceCheck 97 | Kitten.Instantiate 98 | Kitten.Instantiated 99 | Kitten.Interpret 100 | Kitten.Kind 101 | Kitten.Layoutness 102 | Kitten.Linearize 103 | Kitten.Literal 104 | Kitten.Located 105 | Kitten.Mangle 106 | Kitten.Metadata 107 | Kitten.Monad 108 | Kitten.Name 109 | Kitten.Occurrences 110 | Kitten.Operator 111 | Kitten.Origin 112 | Kitten.Parse 113 | Kitten.Parser 114 | Kitten.Platform 115 | Kitten.Pretty 116 | Kitten.Quantify 117 | Kitten.Queue 118 | Kitten.Regeneralize 119 | Kitten.Report 120 | Kitten.Resolve 121 | Kitten.Scope 122 | Kitten.Signature 123 | Kitten.Stack 124 | Kitten.Substitute 125 | Kitten.Synonym 126 | Kitten.Term 127 | Kitten.Token 128 | Kitten.Tokenize 129 | Kitten.Type 130 | Kitten.TypeDefinition 131 | Kitten.TypeEnv 132 | Kitten.Unify 133 | Kitten.Vocabulary 134 | Kitten.Zonk 135 | 136 | ghc-options: -Wall -O2 137 | 138 | hs-source-dirs: lib 139 | 140 | test-suite test 141 | build-depends: 142 | 143 | base >=4.8, 144 | 145 | HUnit, 146 | JuicyPixels, 147 | Kitten, 148 | base64-bytestring, 149 | bytestring, 150 | containers, 151 | hashable, 152 | hspec, 153 | knob, 154 | parsec, 155 | pretty, 156 | text, 157 | transformers, 158 | unordered-containers, 159 | vector 160 | 161 | default-language: Haskell2010 162 | ghc-options: -Wall 163 | hs-source-dirs: test, lib 164 | 165 | other-modules: 166 | 167 | Kitten 168 | Kitten.Amd64 169 | Kitten.Base 170 | Kitten.Bits 171 | Kitten.Bracket 172 | Kitten.CollectInstantiations 173 | Kitten.DataConstructor 174 | Kitten.Declaration 175 | Kitten.Definition 176 | Kitten.Desugar.Data 177 | Kitten.Desugar.Infix 178 | Kitten.Desugar.Quotations 179 | Kitten.Dictionary 180 | Kitten.Element 181 | Kitten.Enter 182 | Kitten.Entry 183 | Kitten.Entry.Category 184 | Kitten.Entry.Merge 185 | Kitten.Entry.Parameter 186 | Kitten.Entry.Parent 187 | Kitten.Fragment 188 | Kitten.Free 189 | Kitten.IO 190 | Kitten.Indent 191 | Kitten.Infer 192 | Kitten.Informer 193 | Kitten.InstanceCheck 194 | Kitten.Instantiate 195 | Kitten.Instantiated 196 | Kitten.Interpret 197 | Kitten.Kind 198 | Kitten.Layoutness 199 | Kitten.Linearize 200 | Kitten.Literal 201 | Kitten.Located 202 | Kitten.Mangle 203 | Kitten.Metadata 204 | Kitten.Monad 205 | Kitten.Name 206 | Kitten.Occurrences 207 | Kitten.Operator 208 | Kitten.Origin 209 | Kitten.Parse 210 | Kitten.Parser 211 | Kitten.Platform 212 | Kitten.Pretty 213 | Kitten.Quantify 214 | Kitten.Queue 215 | Kitten.Regeneralize 216 | Kitten.Report 217 | Kitten.Resolve 218 | Kitten.Scope 219 | Kitten.Signature 220 | Kitten.Stack 221 | Kitten.Substitute 222 | Kitten.Synonym 223 | Kitten.Term 224 | Kitten.Token 225 | Kitten.Tokenize 226 | Kitten.Type 227 | Kitten.TypeDefinition 228 | Kitten.TypeEnv 229 | Kitten.Unify 230 | Kitten.Vocabulary 231 | Kitten.Zonk 232 | Test.Common 233 | Test.Infer 234 | Test.InstanceCheck 235 | Test.Interpret 236 | Test.Origin 237 | Test.Parse 238 | Test.Resolve 239 | Test.Tokenize 240 | Test.Zonk 241 | 242 | main-is: Main.hs 243 | type: exitcode-stdio-1.0 244 | -------------------------------------------------------------------------------- /doc/Yarn.md: -------------------------------------------------------------------------------- 1 | > **Note:** this document applies to an older version of the compiler; this IR is no longer used. 2 | 3 | # Yarn 4 | 5 | Yarn is the name for Kitten’s virtual machine and the assembly language for that machine. It is a low-level assembly language designed to be produced and consumed primarily by machines, not humans. 6 | 7 | # Execution Model 8 | 9 | Yarn is a stack-based runtime with four conceptual stacks. In an actual implementation, some of these might be merged, stored in registers, or optimized away. 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 |
Stack NameDescription
DataStores the parameters and return values of functions.
LocalStores local variables moved from the data stack.
ClosureStores local values captured by function activations.
ReturnStores the return address for a function call.
43 | 44 | # Instruction Set 45 | 46 | By convention, instructions produced from the AST are capitalized while builtins are lowercase. 47 | 48 | ## Labels 49 | 50 | ### `Label LABEL` 51 | 52 | Creates a label named `LABEL`, an unsigned integer. 53 | 54 | ## Pushing 55 | 56 | ### `Push HINT VALUE` 57 | 58 | Pushes a scalar value to `Data`. The format of `VALUE` depends on the type hint `HINT`: 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 |
HINTVALUE
Bool0 or 1
CharUTF-32 code point as decimal integer
IntSigned 64-bit integer
FloatDouble-precision floating-point number
LabelLabel (function pointer)
Nil0
102 | 103 | ## Tuples 104 | 105 | ### `Pair` 106 | 107 | Wraps the top two elements of `Data` in a cons pair. 108 | 109 | ## Vectors 110 | 111 | ### `Vec SIZE` 112 | 113 | Wraps the top `SIZE` elements of `Data` in a new vector, where `SIZE` is an unsigned integer. 114 | 115 | ## Calling and Branching 116 | 117 | ### `Branch LABEL` 118 | 119 | Pops a value from `Data`. If the value is `false`, jumps to `LABEL`. 120 | 121 | ### `Call LABEL` 122 | 123 | Saves the return address on `Return` and jumps to `LABEL`. 124 | 125 | ### `Jump LABEL` 126 | 127 | Jumps unconditionally to `LABEL`. 128 | 129 | ### `Ret` 130 | 131 | Pops an address from `Return` and jumps to it. 132 | 133 | ## Locals and Closures 134 | 135 | ### `Act LABEL VALUE*` 136 | 137 | Pushes a function activation to `Data` consisting of a `LABEL` and zero or more values addressed in the format `STACK:INDEX`, where `STACK` is either `Local` or `Closure` and `INDEX` is an offset onto that stack. For example: 138 | 139 | ``` 140 | Act 42 Local:0 Closure:1 141 | ``` 142 | 143 | This creates an activation addressing label `42`, whose closure contains value `0` from `Local` and value `1` from `Closure`. 144 | 145 | ### `Closure INDEX` 146 | 147 | Copies the value at `INDEX` in `Closure` to `Data`. 148 | 149 | ### `Enter` 150 | 151 | Pops a value from `Data` and pushes it to `Local`. 152 | 153 | ### `Leave` 154 | 155 | Drops the top value from `Local`. 156 | 157 | ### `Local INDEX` 158 | 159 | Copies the value at `INDEX` in `Local` to `Data`. 160 | 161 | ## Builtins 162 | 163 | This list is subject to change. Many instructions are of the form `NAME HINT` where `HINT` is the type of operand to expect and/or result to produce, both on `Data`. The prelude contains type signatures for all of these. 164 | 165 | ### Arithmetic 166 | 167 | * `add float` 168 | * `add int` 169 | * `add vector` (Concatenation) 170 | * `div float` 171 | * `div int` 172 | * `mod float` 173 | * `mod int` 174 | * `mul float` 175 | * `mul int` 176 | * `neg float` 177 | * `neg int` 178 | * `sub float` 179 | * `sub int` 180 | 181 | ### Relational 182 | 183 | Vectors are lexicographically ordered, starting from the topmost element. 184 | 185 | * `eq char` 186 | * `eq float` 187 | * `eq int` 188 | * `eq vector` 189 | * `ge char` 190 | * `ge float` 191 | * `ge int` 192 | * `ge vector` 193 | * `gt char` 194 | * `gt float` 195 | * `gt int` 196 | * `gt vector` 197 | * `le char` 198 | * `le float` 199 | * `le int` 200 | * `le vector` 201 | * `lt char` 202 | * `lt float` 203 | * `lt int` 204 | * `lt vector` 205 | * `ne char` 206 | * `ne float` 207 | * `ne int` 208 | * `ne vector` 209 | 210 | ### Logical and Bitwise 211 | 212 | * `and bool` 213 | * `and int` 214 | * `not bool` 215 | * `not int` 216 | * `or bool` 217 | * `or int` 218 | * `xor bool` 219 | * `xor int` 220 | 221 | ### Increment and Decrement 222 | 223 | * `dec float` 224 | * `dec int` 225 | * `inc float` 226 | * `inc int` 227 | 228 | ### Vectors 229 | 230 | * `bottom`—`[x, _, _, _]` 231 | * `down`—`[x, x, x, _]` 232 | * `empty` 233 | * `get` 234 | * `length` 235 | * `set` 236 | * `top`—`[_, _, _, x]` 237 | * `up`—`[_, x, x, x]` 238 | * `vector` 239 | 240 | ### Functions 241 | 242 | * `apply` 243 | * `compose` 244 | * `function` 245 | 246 | ### Stack 247 | 248 | * `drop` 249 | * `dup` 250 | * `swap` 251 | 252 | ### Tuples 253 | 254 | * `first` 255 | * `rest` 256 | 257 | ### I/O 258 | 259 | * `close` 260 | * `get_line` 261 | * `open_in` 262 | * `open_out` 263 | * `print` 264 | * `show float` 265 | * `show int` 266 | * `stderr` 267 | * `stdin` 268 | * `stdout` 269 | -------------------------------------------------------------------------------- /lib/Kitten/Dictionary.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Dictionary 3 | Description : Program database 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE PatternGuards #-} 13 | 14 | module Kitten.Dictionary 15 | ( Dictionary 16 | , empty 17 | , fromList 18 | , insert 19 | , lookup 20 | , member 21 | , operatorMetadata 22 | , signatures 23 | , toList 24 | , typeNames 25 | , wordNames 26 | ) where 27 | 28 | import Control.Applicative (liftA2) 29 | import Data.HashMap.Strict (HashMap) 30 | import Data.Maybe (mapMaybe) 31 | import Kitten.Entry (Entry) 32 | import Kitten.Informer (Informer(..)) 33 | import Kitten.Instantiated (Instantiated(Instantiated)) 34 | import Kitten.Literal (IntegerLiteral(IntegerLiteral)) 35 | import Kitten.Name 36 | import Kitten.Operator (Operator(Operator)) 37 | import Kitten.Signature (Signature) 38 | import Prelude hiding (lookup) 39 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 40 | import qualified Data.HashMap.Strict as HashMap 41 | import qualified Kitten.Entry as Entry 42 | import qualified Kitten.Entry.Category as Category 43 | import qualified Kitten.Operator as Operator 44 | import qualified Kitten.Report as Report 45 | import qualified Kitten.Term as Term 46 | 47 | -- | A key-value store mapping an 'Instantiated' name to a dictionary 'Entry'. 48 | 49 | data Dictionary = Dictionary 50 | { entries :: !(HashMap Instantiated Entry) 51 | } deriving (Show) 52 | 53 | instance Pretty Dictionary where 54 | pPrint = pPrint . HashMap.keys . entries 55 | 56 | empty :: Dictionary 57 | empty = Dictionary 58 | { entries = HashMap.empty 59 | } 60 | 61 | fromList :: [(Instantiated, Entry)] -> Dictionary 62 | fromList = Dictionary . HashMap.fromList 63 | 64 | -- | Directly inserts into the dictionary. This is somewhat unsafe, as it can 65 | -- lead to an invalid dictionary state. 66 | 67 | insert :: Instantiated -> Entry -> Dictionary -> Dictionary 68 | insert name entry dictionary = dictionary 69 | { entries = HashMap.insert name entry $ entries dictionary } 70 | 71 | lookup :: Instantiated -> Dictionary -> Maybe Entry 72 | lookup name = HashMap.lookup name . entries 73 | 74 | -- | Whether a name is present in the dictionary. 75 | 76 | member :: Instantiated -> Dictionary -> Bool 77 | member name = (name `HashMap.member`) . entries 78 | 79 | -- | Compiles all operator metadata for infix desugaring. 80 | 81 | operatorMetadata 82 | :: (Informer m) => Dictionary -> m (HashMap Qualified Operator) 83 | operatorMetadata dictionary = HashMap.fromList <$> mapM getMetadata 84 | (filter isOperatorName $ wordNames dictionary) 85 | where 86 | 87 | getMetadata :: (Informer m) => Qualified -> m (Qualified, Operator) 88 | getMetadata name = let 89 | key = Qualified (qualifierFromName name) (Unqualified "operator") 90 | in case HashMap.lookup (Instantiated key []) $ entries dictionary of 91 | -- TODO: Report invalid metadata. 92 | -- TODO: Avoid redundant decomposition. 93 | Just (Entry.Metadata _ term) 94 | 95 | -- Just associativity. 96 | | [Term.Word _ _ (UnqualifiedName (Unqualified assoc)) _ _] 97 | <- Term.decompose term 98 | , Just associativity <- associativityFromName assoc 99 | -> yield associativity defaultPrecedence 100 | 101 | -- Just precedence. 102 | | [Term.Push _ (Term.Integer (IntegerLiteral prec _base _bits)) _] 103 | <- Term.decompose term 104 | , validPrecedence prec 105 | -> yield defaultAssociativity 106 | $ Operator.Precedence $ fromInteger prec 107 | 108 | -- Associativity and precedence. 109 | | [ Term.Word _ _ (UnqualifiedName (Unqualified assoc)) _ _ 110 | , Term.Push _ (Term.Integer (IntegerLiteral prec _base _bits)) _ 111 | ] <- Term.decompose term 112 | , Just associativity <- associativityFromName assoc 113 | , validPrecedence prec 114 | -> yield associativity 115 | $ Operator.Precedence $ fromInteger prec 116 | 117 | | otherwise -> do 118 | report $ Report.InvalidOperatorMetadata 119 | (Term.origin term) name term 120 | yield defaultAssociativity defaultPrecedence 121 | 122 | _ -> yield defaultAssociativity defaultPrecedence 123 | 124 | where 125 | 126 | associativityFromName "left" = Just Operator.Leftward 127 | associativityFromName "right" = Just Operator.Rightward 128 | associativityFromName _ = Nothing 129 | 130 | validPrecedence = liftA2 (&&) (>= 0) (<= 9) 131 | 132 | defaultPrecedence = Operator.Precedence 6 133 | defaultAssociativity = Operator.Nonassociative 134 | 135 | yield associativity precedence = return (name, Operator 136 | { Operator.associativity = associativity 137 | , Operator.name = name 138 | , Operator.precedence = precedence 139 | }) 140 | 141 | -- | All type signatures (for words or traits) in the dictionary. 142 | 143 | signatures :: Dictionary -> [(Qualified, Signature)] 144 | signatures = mapMaybe getSignature . HashMap.toList . entries 145 | where 146 | getSignature :: (Instantiated, Entry) -> Maybe (Qualified, Signature) 147 | getSignature (Instantiated name [], Entry.Word _ _ _ _ (Just signature) _) 148 | = Just (name, signature) 149 | getSignature (Instantiated name [], Entry.Trait _ signature) 150 | = Just (name, signature) 151 | getSignature _ = Nothing 152 | 153 | toList :: Dictionary -> [(Instantiated, Entry)] 154 | toList = HashMap.toList . entries 155 | 156 | -- | All type names (for data types or permissions) in the dictionary. 157 | 158 | typeNames :: Dictionary -> [Qualified] 159 | typeNames = mapMaybe typeName . HashMap.toList . entries 160 | where 161 | typeName (Instantiated name _, Entry.Word Category.Permission _ _ _ _ _) 162 | = Just name 163 | typeName (Instantiated name _, Entry.Type{}) = Just name 164 | typeName _ = Nothing 165 | 166 | -- | All word names (for words or traits) in the dictionary. 167 | 168 | wordNames :: Dictionary -> [Qualified] 169 | wordNames = mapMaybe wordName . HashMap.toList . entries 170 | where 171 | wordName (Instantiated name [], Entry.Word{}) = Just name 172 | -- TODO: Figure out how to get mangled names out of this... 173 | wordName (Instantiated name _, Entry.Trait{}) = Just name 174 | wordName _ = Nothing 175 | -------------------------------------------------------------------------------- /lib/Kitten/Scope.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Scope 3 | Description : Scope resolution 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | 13 | module Kitten.Scope 14 | ( scope 15 | ) where 16 | 17 | import Control.Monad.Trans.Class (lift) 18 | import Control.Monad.Trans.Reader (ReaderT, asks, local, runReaderT) 19 | import Control.Monad.Trans.State (State, get, put, runState) 20 | import Data.List (elemIndex) 21 | import Kitten.Name (Closed(..), ClosureIndex(..), GeneralName(..), LocalIndex(..)) 22 | import Kitten.Term (Case(..), Else(..), Term(..), Value(..)) 23 | 24 | -- | Whereas name resolution is concerned with resolving references to 25 | -- definitions, scope resolution resolves local names to relative (De Bruijn) 26 | -- indices, and converts 'Quotation's to explicit 'Capture's. 27 | 28 | scope :: Term () -> Term () 29 | scope = scopeTerm [0] 30 | where 31 | 32 | scopeTerm :: [Int] -> Term () -> Term () 33 | scopeTerm stack = recur 34 | where 35 | 36 | recur :: Term () -> Term () 37 | recur term = case term of 38 | Coercion{} -> term 39 | Compose _ a b -> Compose () (recur a) (recur b) 40 | Generic{} -> error 41 | "generic expression should not appear before scope resolution" 42 | Group{} -> error 43 | "group expression should not appear after infix desugaring" 44 | Lambda _ name _ a origin -> Lambda () name () 45 | (scopeTerm (mapHead succ stack) a) origin 46 | Match hint _ cases else_ origin -> Match hint () 47 | (map (\ (Case name a caseOrigin) 48 | -> Case name (recur a) caseOrigin) cases) 49 | ((\ (Else a elseOrigin) 50 | -> Else (recur a) elseOrigin) else_) 51 | origin 52 | New{} -> term 53 | NewClosure{} -> term 54 | NewVector{} -> term 55 | Push _ value origin -> Push () (scopeValue stack value) origin 56 | Word _ _ (LocalName index) _ origin 57 | -> Push () (scopeValue stack (Local index)) origin 58 | Word{} -> term 59 | 60 | scopeValue :: [Int] -> Value () -> Value () 61 | scopeValue stack value = case value of 62 | Capture{} -> error "capture should not appear before scope resolution" 63 | Character{} -> value 64 | Closed{} -> error "closed name should not appear before scope resolution" 65 | Float{} -> value 66 | Integer{} -> value 67 | Local{} -> value 68 | Name{} -> value 69 | Quotation body -> Capture (map ClosedLocal capturedNames) capturedTerm 70 | where 71 | 72 | capturedTerm :: Term () 73 | capturedNames :: [LocalIndex] 74 | (capturedTerm, capturedNames) = runCapture stack' $ captureTerm scoped 75 | 76 | scoped :: Term () 77 | scoped = scopeTerm stack' body 78 | 79 | stack' :: [Int] 80 | stack' = 0 : stack 81 | 82 | Text{} -> value 83 | 84 | data ScopeEnv = ScopeEnv 85 | { scopeStack :: [ScopeDepth] 86 | , scopeDepth :: !ScopeDepth 87 | } 88 | 89 | type ScopeDepth = Int 90 | 91 | type Captured a = ReaderT ScopeEnv (State [LocalIndex]) a 92 | 93 | runCapture :: [Int] -> Captured a -> (a, [LocalIndex]) 94 | runCapture stack = flip runState [] 95 | . flip runReaderT ScopeEnv { scopeStack = stack, scopeDepth = 0 } 96 | 97 | captureTerm :: Term () -> Captured (Term ()) 98 | captureTerm term = case term of 99 | Coercion{} -> return term 100 | Compose _ a b -> Compose () <$> captureTerm a <*> captureTerm b 101 | Generic{} -> error 102 | "generic expression should not appear before scope resolution" 103 | Group{} -> error 104 | "group expression should not appear after infix desugaring" 105 | Lambda _ name _ a origin -> let 106 | inside env = env 107 | { scopeStack = mapHead succ (scopeStack env) 108 | , scopeDepth = succ (scopeDepth env) 109 | } 110 | in Lambda () name () 111 | <$> local inside (captureTerm a) <*> pure origin 112 | Match hint _ cases else_ origin -> Match hint () 113 | <$> mapM captureCase cases <*> captureElse else_ <*> pure origin 114 | where 115 | 116 | captureCase :: Case () -> Captured (Case ()) 117 | captureCase (Case name a caseOrigin) 118 | = Case name <$> captureTerm a <*> pure caseOrigin 119 | 120 | captureElse :: Else () -> Captured (Else ()) 121 | captureElse (Else a elseOrigin) 122 | = Else <$> captureTerm a <*> pure elseOrigin 123 | 124 | New{} -> return term 125 | NewClosure{} -> return term 126 | NewVector{} -> return term 127 | Push _ value origin -> Push () <$> captureValue value <*> pure origin 128 | Word{} -> return term 129 | 130 | captureValue :: Value () -> Captured (Value ()) 131 | captureValue value = case value of 132 | Capture names term -> Capture <$> mapM close names <*> pure term 133 | where 134 | 135 | close :: Closed -> Captured Closed 136 | close original = case original of 137 | ClosedLocal index -> do 138 | closed <- closeLocal index 139 | return $ case closed of 140 | Nothing -> original 141 | Just index' -> ClosedClosure index' 142 | ClosedClosure{} -> return original 143 | Character{} -> return value 144 | Closed{} -> return value 145 | Float{} -> return value 146 | Integer{} -> return value 147 | Local index -> do 148 | closed <- closeLocal index 149 | return $ case closed of 150 | Nothing -> value 151 | Just index' -> Closed index' 152 | Name{} -> return value 153 | Quotation term -> let 154 | inside env = env { scopeStack = 0 : scopeStack env } 155 | in Quotation <$> local inside (captureTerm term) 156 | Text{} -> return value 157 | 158 | closeLocal :: LocalIndex -> Captured (Maybe ClosureIndex) 159 | closeLocal (LocalIndex index) = do 160 | stack <- asks scopeStack 161 | depth <- asks scopeDepth 162 | case stack of 163 | here : _ 164 | | index >= here 165 | -> fmap Just $ addName $ LocalIndex $ index - depth 166 | _ -> return Nothing 167 | where 168 | 169 | addName :: LocalIndex -> Captured ClosureIndex 170 | addName name = do 171 | names <- lift get 172 | case elemIndex name names of 173 | Just existing -> return $ ClosureIndex existing 174 | Nothing -> do 175 | lift $ put $ names ++ [name] 176 | return $ ClosureIndex $ length names 177 | 178 | mapHead :: (a -> a) -> [a] -> [a] 179 | mapHead _ [] = [] 180 | mapHead f (x : xs) = f x : xs 181 | -------------------------------------------------------------------------------- /lib/Kitten/Unify.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Unify 3 | Description : Unification of types 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Unify 14 | ( function 15 | , type_ 16 | ) where 17 | 18 | import Kitten.Informer (Informer(..)) 19 | import Kitten.Kind (Kind(..)) 20 | import Kitten.Monad (K) 21 | import Kitten.Occurrences (occurs) 22 | import Kitten.Origin (Origin) 23 | import Kitten.Type (Type(..), TypeId, Var(..)) 24 | import Kitten.TypeEnv (TypeEnv, freshTv) 25 | import qualified Data.Map as Map 26 | import qualified Kitten.Instantiate as Instantiate 27 | import qualified Kitten.Report as Report 28 | import qualified Kitten.Type as Type 29 | import qualified Kitten.TypeEnv as TypeEnv 30 | import qualified Kitten.Zonk as Zonk 31 | 32 | -- | There are two kinds of unification going on here: basic logical unification 33 | -- for value types, and row unification for permission types. 34 | 35 | type_ :: TypeEnv -> Type -> Type -> K TypeEnv 36 | type_ tenv0 t1 t2 = case (t1', t2') of 37 | _ | t1' == t2' -> return tenv0 38 | (TypeVar origin x, t) -> unifyTv tenv0 origin x t 39 | (_, TypeVar{}) -> commute 40 | -- FIXME: Unify the kinds here? 41 | (a, Forall origin (Var name x k) t) -> do 42 | (b, _, tenv1) <- Instantiate.type_ tenv0 origin name x k t 43 | type_ tenv1 a b 44 | (Forall{}, _) -> commute 45 | 46 | (TypeConstructor _ "Join" :@ l :@ r, s) -> do 47 | ms <- rowIso tenv0 l s (permissionTail r) 48 | case ms of 49 | Just (s', substitution, tenv1) 50 | -> case substitution of 51 | Just (x, t) -> let 52 | tenv2 = tenv1 { TypeEnv.tvs = Map.insert x t $ TypeEnv.tvs tenv1 } 53 | in type_ tenv2 r s' 54 | Nothing -> type_ tenv1 r s' 55 | 56 | Nothing -> do 57 | report $ Report.TypeMismatch t1' t2' 58 | halt 59 | 60 | (_, TypeConstructor _ "Join" :@ _ :@ _) -> commute 61 | 62 | -- We fall back to regular unification for value type constructors. This makes 63 | -- the somewhat iffy assumption that there is no higher-kinded polymorphism 64 | -- going on between value type constructors and permission type constructors. 65 | 66 | (a :@ b, c :@ d) -> do 67 | tenv1 <- type_ tenv0 a c 68 | type_ tenv1 b d 69 | 70 | _ -> do 71 | report $ Report.TypeMismatch t1' t2' 72 | halt 73 | 74 | -- Unification is commutative. If we fail to handle a case, this can result in 75 | -- an infinite loop. 76 | 77 | where 78 | t1' = Zonk.type_ tenv0 t1 79 | t2' = Zonk.type_ tenv0 t2 80 | commute = type_ tenv0 t2 t1 81 | permissionTail (TypeConstructor _ "Join" :@ _ :@ a) = permissionTail a 82 | permissionTail t = t 83 | 84 | -- Unification of a type variable with a type simply looks up the current value 85 | -- of the variable and unifies it with the type; if the variable does not exist, 86 | -- it is added to the environment and unified with the type. 87 | -- 88 | -- The only interesting bits here are the occurs check, which prevents 89 | -- constructing infinite types, and the condition that prevents declaring a 90 | -- variable as equal to itself. Without both of these, zonking could fail to 91 | -- terminate. 92 | -- 93 | -- See: Occurs Checks 94 | 95 | unifyTv :: TypeEnv -> Origin -> Var -> Type -> K TypeEnv 96 | unifyTv tenv0 origin v@(Var _name x _) t = case t of 97 | TypeVar _origin (Var _name y _) | x == y -> return tenv0 98 | TypeVar{} -> declare 99 | _ -> if occurs tenv0 x (Zonk.type_ tenv0 t) 100 | then let t' = Zonk.type_ tenv0 t in do 101 | report $ Report.Chain $ 102 | [ Report.TypeMismatch (TypeVar origin v) t' 103 | , Report.OccursCheckFailure (TypeVar origin v) t' 104 | ] ++ case t' of 105 | TypeConstructor _ "Prod" :@ _ :@ _ -> [Report.StackDepthMismatch (Type.origin t')] 106 | _ -> [] 107 | halt 108 | else declare 109 | where 110 | declare = return tenv0 { TypeEnv.tvs = Map.insert x t $ TypeEnv.tvs tenv0 } 111 | 112 | -- | A convenience function for unifying a type with a function type. 113 | 114 | function :: TypeEnv -> Type -> K (Type, Type, Type, TypeEnv) 115 | function tenv0 t = case t of 116 | TypeConstructor _ "Fun" :@ a :@ b :@ e -> return (a, b, e, tenv0) 117 | _ -> do 118 | let origin = Type.origin t 119 | a <- freshTv tenv0 "A" origin Stack 120 | b <- freshTv tenv0 "B" origin Stack 121 | e <- freshTv tenv0 "P" origin Permission 122 | tenv1 <- type_ tenv0 t $ Type.fun origin a b e 123 | return (a, b, e, tenv1) 124 | 125 | -- Row unification is essentially unification of sets. The row-isomorphism 126 | -- operation (as described in [1]) takes a permission label and a permission 127 | -- row, and asserts that the row can be rewritten to begin with that label under 128 | -- some substitution. It returns the substitution and the tail of the rewritten 129 | -- row. The substitution is always either empty (∅) or a singleton substitution 130 | -- (x ↦ τ), so we represent this as a 'Maybe'. 131 | 132 | rowIso 133 | :: TypeEnv -> Type -> Type -> Type 134 | -> K (Maybe (Type, Maybe (TypeId, Type), TypeEnv)) 135 | 136 | -- The "head" rule: a row which already begins with the label is trivially 137 | -- rewritten by the identity substitution. 138 | 139 | rowIso tenv0 l (TypeConstructor _ "Join" :@ l' :@ r') _ 140 | | l == l' = return $ Just (r', Nothing :: Maybe (TypeId, Type), tenv0) 141 | 142 | -- The "swap" rule: a row which contains the label somewhere within, can be 143 | -- rewritten to place that label at the head. 144 | 145 | rowIso tenv0 l (TypeConstructor origin "Join" :@ l' :@ r') rt 146 | | l /= l' = do 147 | ms <- rowIso tenv0 l r' rt 148 | return $ case ms of 149 | Just (r'', substitution, tenv1) -> Just 150 | (Type.join origin l' r'', substitution, tenv1) 151 | Nothing -> Nothing 152 | 153 | -- The "var" rule: no label is present, so we cannot test for equality, and must 154 | -- return a fresh variable for the row tail. Here we enforce a side condition 155 | -- that ensures termination by preventing unification of rows with a common tail 156 | -- but distinct prefixes. 157 | 158 | rowIso tenv0 l r@(TypeVar origin (Var name a _)) rt 159 | | r /= rt = do 160 | -- FIXME: Should this use 'name' or a distinct name? 161 | b <- freshTv tenv0 name origin Permission 162 | return $ Just (b, Just (a, Type.join origin l b), tenv0) 163 | 164 | -- In any other case, the rows are not isomorphic. 165 | 166 | rowIso _ _ _ _ = return Nothing 167 | -------------------------------------------------------------------------------- /syntax/Kitten.tmLanguage: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | fileTypes 6 | 7 | ktn 8 | 9 | name 10 | Kitten 11 | patterns 12 | 13 | 14 | include 15 | #general 16 | 17 | 18 | repository 19 | 20 | blockcomment 21 | 22 | begin 23 | /\* 24 | end 25 | \*/ 26 | name 27 | comment.block.kitten 28 | 29 | boolean 30 | 31 | match 32 | \b(true|false)\b 33 | name 34 | constant.language.kitten 35 | 36 | builtin 37 | 38 | match 39 | \b__[a-z_]+\b 40 | name 41 | support.function.builtin.kitten 42 | 43 | doublequotestring 44 | 45 | begin 46 | " 47 | beginCaptures 48 | 49 | 0 50 | 51 | name 52 | punctuation.definition.string.begin.kitten 53 | 54 | 55 | end 56 | " 57 | endCaptures 58 | 59 | 0 60 | 61 | name 62 | punctuation.definition.string.end.kitten 63 | 64 | 65 | name 66 | string.quoted.double.kitten 67 | patterns 68 | 69 | 70 | match 71 | \\. 72 | name 73 | constant.character.escape.kitten 74 | 75 | 76 | 77 | functiondef 78 | 79 | begin 80 | ^\s*(def)\s*([a-z][0-9A-Za-z_]*|[!#$%&*+./;<=>?@^\|~-]+)\s*\( 81 | beginCaptures 82 | 83 | 1 84 | 85 | name 86 | keyword.control.kitten 87 | 88 | 2 89 | 90 | name 91 | entity.name.function.kitten 92 | 93 | 94 | end 95 | \)\s*[:{] 96 | name 97 | meta.functiondef.kitten 98 | patterns 99 | 100 | 101 | include 102 | #typesignature 103 | 104 | 105 | 106 | general 107 | 108 | patterns 109 | 110 | 111 | include 112 | #linecomment 113 | 114 | 115 | include 116 | #blockcomment 117 | 118 | 119 | include 120 | #functiondef 121 | 122 | 123 | include 124 | #builtin 125 | 126 | 127 | include 128 | #keyword 129 | 130 | 131 | include 132 | #boolean 133 | 134 | 135 | include 136 | #numeric 137 | 138 | 139 | include 140 | #singlequotestring 141 | 142 | 143 | include 144 | #doublequotestring 145 | 146 | 147 | include 148 | #operator 149 | 150 | 151 | 152 | keyword 153 | 154 | match 155 | \b(choice|def|else|if|import|option)\b 156 | name 157 | keyword.control.kitten 158 | 159 | linecomment 160 | 161 | match 162 | //.*$ 163 | name 164 | comment.line.kitten 165 | 166 | numeric 167 | 168 | match 169 | \b[+-]?[0-9]+(?:\.[0-9]+)?\b 170 | name 171 | constant.numeric.kitten 172 | 173 | operator 174 | 175 | match 176 | [!#$%&*+./;<=>?@^\|~-]+ 177 | name 178 | keyword.operator.kitten 179 | 180 | singlequotestring 181 | 182 | begin 183 | ' 184 | beginCaptures 185 | 186 | 0 187 | 188 | name 189 | punctuation.definition.string.begin.kitten 190 | 191 | 192 | end 193 | ' 194 | endCaptures 195 | 196 | 0 197 | 198 | name 199 | punctuation.definition.string.end.kitten 200 | 201 | 202 | name 203 | string.quoted.single.kitten 204 | patterns 205 | 206 | 207 | match 208 | \\. 209 | name 210 | constant.character.escape.kitten 211 | 212 | 213 | 214 | typename 215 | 216 | match 217 | \b[A-Z][0-9A-Za-z_]*\b 218 | name 219 | storage.type.kitten 220 | 221 | typesignature 222 | 223 | patterns 224 | 225 | 226 | include 227 | #linecomment 228 | 229 | 230 | include 231 | #blockcomment 232 | 233 | 234 | include 235 | #typename 236 | 237 | 238 | include 239 | #operator 240 | 241 | 242 | 243 | 244 | scopeName 245 | source.kitten 246 | uuid 247 | 23d5cf35-7a0f-4f60-bfb3-84d0bf5fdab4 248 | 249 | 250 | -------------------------------------------------------------------------------- /lib/Kitten/Desugar/Infix.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Kitten.Desugar.Infix 3 | Description : Desugaring infix operators to postfix 4 | Copyright : (c) Jon Purdy, 2016 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | Stability : experimental 8 | Portability : GHC 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Kitten.Desugar.Infix 14 | ( desugar 15 | ) where 16 | 17 | import Control.Applicative 18 | import Data.Functor.Identity (Identity) 19 | import Kitten.Definition (Definition) 20 | import Kitten.Dictionary (Dictionary) 21 | import Kitten.Informer (Informer(..)) 22 | import Kitten.Monad (K) 23 | import Kitten.Name (GeneralName(..)) 24 | import Kitten.Operator (Operator) 25 | import Kitten.Origin (Origin) 26 | import Kitten.Term (Case(..), Else(..), Term(..), Value(..)) 27 | import Text.Parsec ((), ParsecT, SourcePos) 28 | import qualified Data.HashMap.Strict as HashMap 29 | import qualified Kitten.Definition as Definition 30 | import qualified Kitten.Dictionary as Dictionary 31 | import qualified Kitten.Operator as Operator 32 | import qualified Kitten.Origin as Origin 33 | import qualified Kitten.Report as Report 34 | import qualified Kitten.Term as Term 35 | import qualified Text.Parsec as Parsec 36 | import qualified Text.Parsec.Expr as Expr 37 | 38 | type Rewriter a = ParsecT [Term ()] () Identity a 39 | 40 | -- | Desugars infix operators into postfix calls in the body of a 'Definition', 41 | -- according to the definitions and operator metadata in the 'Dictionary'. 42 | 43 | desugar :: Dictionary -> Definition () -> K (Definition ()) 44 | desugar dictionary definition = do 45 | operatorMetadata <- Dictionary.operatorMetadata dictionary 46 | let 47 | operatorTable :: [[Expr.Operator [Term ()] () Identity (Term ())]] 48 | operatorTable = map (map toOperator) rawOperatorTable 49 | 50 | rawOperatorTable :: [[Operator]] 51 | rawOperatorTable = map 52 | (\ p -> HashMap.elems 53 | $ HashMap.filter ((== p) . Operator.precedence) operatorMetadata) 54 | $ reverse [minBound .. maxBound] 55 | 56 | expression :: Rewriter (Term ()) 57 | expression = Expr.buildExpressionParser operatorTable operand 58 | where 59 | operand = ( "operand") $ do 60 | origin <- getTermOrigin 61 | results <- Parsec.many1 $ termSatisfy $ \ term -> case term of 62 | Word _ Operator.Infix _ _ _ -> False 63 | Lambda{} -> False 64 | _ -> True 65 | return $ Term.compose () origin results 66 | 67 | desugarTerms :: [Term ()] -> K (Term ()) 68 | desugarTerms terms = do 69 | terms' <- mapM desugarTerm terms 70 | let 71 | expression' = infixExpression <* Parsec.eof 72 | infixExpression = do 73 | desugaredTerms <- many $ expression <|> lambda 74 | let 75 | origin = case desugaredTerms of 76 | term : _ -> Term.origin term 77 | _ -> Definition.origin definition 78 | return $ Term.compose () origin desugaredTerms 79 | case Parsec.runParser expression' () "" terms' of 80 | Left parseError -> do 81 | report $ Report.parseError parseError 82 | let 83 | origin = case terms of 84 | term : _ -> Term.origin term 85 | _ -> Definition.origin definition 86 | return $ Term.compose () origin terms 87 | Right result -> return result 88 | 89 | desugarTerm :: Term () -> K (Term ()) 90 | desugarTerm term = case term of 91 | Coercion{} -> return term 92 | Compose _ a b -> desugarTerms (Term.decompose a ++ Term.decompose b) 93 | Generic{} -> error 94 | "generic expression should not appear before infix desugaring" 95 | Group a -> desugarTerms' a 96 | Lambda _ name _ body origin -> Lambda () name () 97 | <$> desugarTerms' body <*> pure origin 98 | Match hint _ cases else_ origin -> Match hint () 99 | <$> mapM desugarCase cases <*> desugarElse else_ <*> pure origin 100 | where 101 | 102 | desugarCase :: Case () -> K (Case ()) 103 | desugarCase (Case name body caseOrigin) 104 | = Case name <$> desugarTerms' body <*> pure caseOrigin 105 | 106 | desugarElse :: Else () -> K (Else ()) 107 | desugarElse (Else body elseOrigin) 108 | = Else <$> desugarTerms' body <*> pure elseOrigin 109 | 110 | New{} -> return term 111 | NewClosure{} -> return term 112 | NewVector{} -> return term 113 | Push _ value origin -> Push () <$> desugarValue value <*> pure origin 114 | Word{} -> return term 115 | 116 | desugarTerms' :: Term () -> K (Term ()) 117 | desugarTerms' = desugarTerms . Term.decompose 118 | 119 | desugarValue :: Value () -> K (Value ()) 120 | desugarValue value = case value of 121 | Capture names body -> Capture names <$> desugarTerms' body 122 | Character{} -> return value 123 | Closed{} -> error "closed name should not appear before infix desugaring" 124 | Float{} -> return value 125 | Integer{} -> return value 126 | Local{} -> error "local name should not appear before infix desugaring" 127 | Name{} -> return value 128 | Quotation body -> Quotation <$> desugarTerms' body 129 | Text{} -> return value 130 | 131 | desugared <- desugarTerms' $ Definition.body definition 132 | return definition { Definition.body = desugared } 133 | where 134 | 135 | lambda :: Rewriter (Term ()) 136 | lambda = termSatisfy $ \ term -> case term of 137 | Lambda{} -> True 138 | _ -> False 139 | 140 | toOperator :: Operator -> Expr.Operator [Term ()] () Identity (Term ()) 141 | toOperator operator = Expr.Infix 142 | (binaryOperator (QualifiedName (Operator.name operator))) 143 | $ case Operator.associativity operator of 144 | Operator.Nonassociative -> Expr.AssocNone 145 | Operator.Leftward -> Expr.AssocRight 146 | Operator.Rightward -> Expr.AssocLeft 147 | 148 | binaryOperator :: GeneralName -> Rewriter (Term () -> Term () -> Term ()) 149 | binaryOperator name = mapTerm $ \ term -> case term of 150 | Word _ Operator.Infix name' _ origin 151 | | name == name' -> Just $ binary name origin 152 | _ -> Nothing 153 | 154 | binary :: GeneralName -> Origin -> Term () -> Term () -> Term () 155 | binary name origin x y = Term.compose () origin 156 | [x, y, Word () Operator.Postfix name [] origin] 157 | 158 | mapTerm :: (Term () -> Maybe a) -> Rewriter a 159 | mapTerm = Parsec.tokenPrim show advanceTerm 160 | 161 | termSatisfy :: (Term () -> Bool) -> Rewriter (Term ()) 162 | termSatisfy predicate = Parsec.tokenPrim show advanceTerm 163 | (\ token -> if predicate token then Just token else Nothing) 164 | 165 | advanceTerm :: SourcePos -> t -> [Term a] -> SourcePos 166 | advanceTerm _ _ (term : _) = Origin.begin $ Term.origin term 167 | advanceTerm sourcePos _ _ = sourcePos 168 | 169 | getTermOrigin = Term.origin 170 | <$> Parsec.lookAhead (termSatisfy (const True)) 171 | -------------------------------------------------------------------------------- /test/Test/Interpret.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NegativeLiterals #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Test.Interpret 5 | ( spec 6 | ) where 7 | 8 | import Data.ByteString (ByteString) 9 | import Data.Text (Text) 10 | import Kitten (fragmentFromSource) 11 | import Kitten.Dictionary (Dictionary) 12 | import Kitten.Interpret (Rep(..), interpret) 13 | import Kitten.Monad (runKitten) 14 | import Kitten.Name 15 | import System.IO (IOMode(..), hClose) 16 | import Test.Common 17 | import Test.HUnit (assertEqual, assertFailure) 18 | import Test.Hspec (Spec, describe, it, runIO) 19 | import Text.PrettyPrint.HughesPJClass (Pretty(..)) 20 | import qualified Data.ByteString as ByteString 21 | import qualified Data.Knob as Knob 22 | import qualified Data.Vector as Vector 23 | import qualified Kitten.Dictionary as Dictionary 24 | import qualified Kitten.Enter as Enter 25 | import qualified Kitten.IO as IO 26 | import qualified Kitten.Report as Report 27 | import qualified Text.PrettyPrint as Pretty 28 | 29 | spec :: Spec 30 | spec = do 31 | testInterpretWithHandles <- runIO $ do 32 | commonSource <- IO.readFileUtf8 "common.ktn" 33 | mDictionary <- runKitten $ do 34 | common <- fragmentFromSource 35 | ioPermission Nothing 1 "common.ktn" commonSource 36 | Enter.fragment common Dictionary.empty 37 | case mDictionary of 38 | Left reports -> error $ Pretty.render $ Pretty.vcat 39 | $ "unable to set up interpreter tests:" : map Report.human reports 40 | Right dictionary -> return $ testInterpretFull dictionary 41 | 42 | let testInterpret = testInterpretWithHandles "" Nothing Nothing 43 | 44 | describe "with trivial programs" $ do 45 | it "interprets literals" $ do 46 | testInterpret "0" [Int32 0] 47 | testInterpret "0.0" [Float64 0.0] 48 | testInterpret "1 2" 49 | [ Int32 2 50 | , Int32 1 51 | ] 52 | testInterpret "\"meow\"" 53 | [Array $ Vector.fromList 54 | [Character 'm', Character 'e', Character 'o', Character 'w']] 55 | it "interprets 'hello world'" $ do 56 | testInterpret "\"meow\" say" [] 57 | 58 | describe "with operators" $ do 59 | it "interprets Int32 operators" $ do 60 | testInterpret "2 + 3" [Int32 5] 61 | testInterpret "2 - 3" [Int32 -1] 62 | testInterpret "2 * 3" [Int32 6] 63 | testInterpret "2 / 3" [Int32 0] 64 | testInterpret "2 % 3" [Int32 2] 65 | it "interprets chains of Int32 operators" $ do 66 | testInterpret "2 + 3 + 4" [Int32 9] 67 | testInterpret "2 + 3 * 4" [Int32 14] 68 | testInterpret "2 * 3 + 4" [Int32 10] 69 | testInterpret "2 * 3 * 4" [Int32 24] 70 | it "wraps Int32" $ do 71 | testInterpret "2147483647 + 1" [Int32 -2147483648] 72 | testInterpret "-2147483648 - 1" [Int32 2147483647] 73 | it "interprets Float64 operators" $ do 74 | testInterpret "2.0 + 3.0" [Float64 5] 75 | testInterpret "2.0 - 3.0" [Float64 -1] 76 | testInterpret "2.0 * 3.0" [Float64 6] 77 | testInterpret "2.0 / 4.0" [Float64 0.5] 78 | testInterpret "2.0 % 3.0" [Float64 2] 79 | it "interprets Bool operators" $ do 80 | let 81 | false = Algebraic (ConstructorIndex 0) [] 82 | true = Algebraic (ConstructorIndex 1) [] 83 | testInterpret "false & false" [false] 84 | testInterpret "false & true" [false] 85 | testInterpret "true & false" [false] 86 | testInterpret "true & true" [true] 87 | testInterpret "false | false" [false] 88 | testInterpret "false | true" [true] 89 | testInterpret "true | false" [true] 90 | testInterpret "true | true" [true] 91 | testInterpret "false ~ false" [false] 92 | testInterpret "false ~ true" [true] 93 | testInterpret "true ~ false" [true] 94 | testInterpret "true ~ true" [false] 95 | testInterpret "false --> false" [true] 96 | testInterpret "false --> true" [true] 97 | testInterpret "true --> false" [false] 98 | testInterpret "true --> true" [true] 99 | 100 | describe "with scope" $ do 101 | it "looks up locals and closure values correctly" $ do 102 | testInterpretWithHandles 103 | "" 104 | (Just "1110\n1110\n") 105 | Nothing 106 | "1000 -> x1;\n\ 107 | \100 -> y1;\n\ 108 | \10\n\ 109 | \{\n\ 110 | \ -> a1;\n\ 111 | \ (a1 + x1)\n\ 112 | \ {\n\ 113 | \ -> b1;\n\ 114 | \ b1 + y1\n\ 115 | \ } call\n\ 116 | \} call\n\ 117 | \say\n\ 118 | \1000 -> x2;\n\ 119 | \100 -> y2;\n\ 120 | \10\n\ 121 | \{\n\ 122 | \ -> a2;\n\ 123 | \ (a2 + y2)\n\ 124 | \ {\n\ 125 | \ -> b2;\n\ 126 | \ b2 + x2\n\ 127 | \ } call\n\ 128 | \} call\n\ 129 | \say\n\ 130 | \\&" 131 | [] 132 | 133 | describe "with common math words" $ do 134 | it "computes absolute values" $ do 135 | testInterpret "0 abs" [Int32 0] 136 | testInterpret "+0 abs" [Int32 0] 137 | testInterpret "-0 abs" [Int32 0] 138 | testInterpret "1 abs" [Int32 1] 139 | testInterpret "+1 abs" [Int32 1] 140 | testInterpret "1000 abs" [Int32 1000] 141 | testInterpret "+1000 abs" [Int32 1000] 142 | testInterpret "-1000 abs" [Int32 1000] 143 | testInterpret "2147483647 abs" [Int32 2147483647] 144 | testInterpret "-2147483648 abs" [Int32 -2147483648] 145 | 146 | describe "with functional combinators" $ do 147 | it "computes fixed points" $ do 148 | testInterpret 149 | "5 {\n\ 150 | \ -> n, rec;\n\ 151 | \ if (n <= 0):\n\ 152 | \ 1\n\ 153 | \ else:\n\ 154 | \ (n - 1) rec call * n\n\ 155 | \} fix" 156 | [Int32 120] 157 | 158 | testInterpretFull 159 | :: Dictionary 160 | -> ByteString 161 | -> Maybe ByteString 162 | -> Maybe ByteString 163 | -> Text 164 | -> [Rep] 165 | -> IO () 166 | testInterpretFull commonDictionary standardInput 167 | mExpectedStdout mExpectedStderr input expectedStack = do 168 | result <- runKitten $ do 169 | fragment <- fragmentFromSource ioPermission Nothing 1 "" input 170 | Enter.fragment fragment commonDictionary 171 | (_stdinKnob, stdin) <- do 172 | knob <- Knob.newKnob standardInput 173 | (,) knob <$> Knob.newFileHandle knob "stdin" ReadMode 174 | (stdoutKnob, stdout) <- do 175 | knob <- Knob.newKnob $ ByteString.pack [] 176 | (,) knob <$> Knob.newFileHandle knob "stdout" WriteMode 177 | (stderrKnob, stderr) <- do 178 | knob <- Knob.newKnob $ ByteString.pack [] 179 | (,) knob <$> Knob.newFileHandle knob "stderr" WriteMode 180 | case result of 181 | Right dictionary -> do 182 | actualStack <- interpret dictionary Nothing [] stdin stdout stderr [] 183 | hClose stdin 184 | hClose stdout 185 | hClose stderr 186 | assertEqual 187 | (Pretty.render $ Pretty.hsep 188 | ["stack", pPrint expectedStack, "=", pPrint actualStack]) 189 | expectedStack actualStack 190 | case mExpectedStdout of 191 | Just expectedStdout -> do 192 | actualStdout <- Knob.getContents stdoutKnob 193 | assertEqual 194 | (Pretty.render $ Pretty.hsep 195 | [ "stdout" 196 | , Pretty.text $ show expectedStdout 197 | , "=" 198 | , Pretty.text $ show actualStdout 199 | ]) 200 | expectedStdout actualStdout 201 | Nothing -> return () 202 | case mExpectedStderr of 203 | Just expectedStderr -> do 204 | actualStderr <- Knob.getContents stderrKnob 205 | assertEqual 206 | (Pretty.render $ Pretty.hsep 207 | [ "stderr" 208 | , Pretty.text $ show expectedStderr 209 | , "=" 210 | , Pretty.text $ show actualStderr 211 | ]) 212 | expectedStderr actualStderr 213 | Nothing -> return () 214 | Left reports -> assertFailure $ unlines 215 | $ map (Pretty.render . Report.human) reports 216 | -------------------------------------------------------------------------------- /examples/tictactoe.ktn: -------------------------------------------------------------------------------- 1 | play_game 2 | 3 | //////////////////////////////////////////////////////////////////////////////// 4 | // Types 5 | //////////////////////////////////////////////////////////////////////////////// 6 | 7 | type Board: 8 | case board_of_cells (List) 9 | 10 | type Cell: 11 | case vacant 12 | case occupied (Player) 13 | 14 | type Player: 15 | case player_x 16 | case player_o 17 | 18 | type Move: 19 | case mark (Int32, Int32) 20 | case forfeit 21 | 22 | type Outcome: 23 | case continue_playing 24 | case tied 25 | case wins (Player) 26 | 27 | //////////////////////////////////////////////////////////////////////////////// 28 | // Gameplay 29 | //////////////////////////////////////////////////////////////////////////////// 30 | 31 | define play_game (-> +IO +Exit): 32 | do (while) { play_round maybe_play_again } 33 | 34 | define play_round (-> +IO +Exit): 35 | new_game take_turns announce_winner print 36 | 37 | define maybe_play_again (-> Bool +IO): 38 | "Play another game? [yN] " ask -> response; 39 | if (response is_yes): 40 | true 41 | elif (response empty | response is_no): 42 | false 43 | else: 44 | maybe_play_again 45 | 46 | define take_turns (Board, Player -> Board, Optional +IO +Exit): 47 | -> current_player; 48 | match (dup outcome) 49 | case continue_playing: 50 | current_player take_turn 51 | current_player end_turn 52 | take_turns 53 | case wins: some 54 | case tied: none 55 | 56 | define take_turn (Board, Player -> Board +IO +Exit): 57 | -> board, current_player; 58 | board print 59 | current_player announce_turn 60 | match (enter_move) 61 | case some: 62 | match 63 | case mark -> x, y: 64 | board x y current_player mark_board 65 | match 66 | case some {} 67 | case none: 68 | "Not a valid move." say 69 | board current_player take_turn 70 | case forfeit: 71 | 0 exit 72 | case none: 73 | "I didn't understand that. Type, e.g., \"a3\" to \ 74 | move in the bottom-left cell. Type \"q\" to exit." say 75 | board current_player take_turn 76 | 77 | define end_turn (Player -> Player): 78 | match case player_x { player_o } case player_o { player_x } 79 | 80 | define enter_move (-> Optional +IO): 81 | "Enter your move: " ask parse_move 82 | 83 | define announce_turn (Player -> +IO): 84 | show ", it's your turn." cat say 85 | 86 | define announce_winner (Optional -> +IO): 87 | match case none { "It's a tie!" } case some { show " wins!" cat } say 88 | 89 | //////////////////////////////////////////////////////////////////////////////// 90 | // Board Operations 91 | //////////////////////////////////////////////////////////////////////////////// 92 | 93 | define outcome (Board -> Outcome): 94 | -> board; 95 | possible_wins { board possible_winner } map concat_optionals -> winners; 96 | if (winners empty): 97 | continue_playing 98 | elif (winners \(= player_x) all): 99 | player_x wins 100 | elif (winners \(= player_o) all): 101 | player_o wins 102 | else: 103 | tied 104 | 105 | define possible_winner (List, Board -> Optional): 106 | board_cells swap get_all concat_optionals -> players; 107 | if (players \(= player_x occupied) all): 108 | player_x some 109 | elif (players \(= player_o occupied) all): 110 | player_o some 111 | else: 112 | none 113 | 114 | define possible_wins (-> List>): 115 | [ 116 | [0, 1, 2], [3, 4, 5], [6, 7, 8], // Rows 117 | [0, 3, 6], [1, 4, 7], [2, 5, 8], // Columns 118 | [0, 4, 8], [2, 4, 6], // Diagonals 119 | ] 120 | 121 | define mark_board (Board, Int32, Int32, Player -> Optional): 122 | -> current_player; 123 | cell_number -> number; 124 | number board_index -> index; 125 | board_cells 126 | do (with (+Fail)): 127 | match (dup index get "invalid index" from_some) 128 | case vacant: 129 | (current_player occupied) index set 130 | "invalid index" from_some board_of_cells some 131 | case occupied: 132 | drop2 none 133 | 134 | //////////////////////////////////////////////////////////////////////////////// 135 | // Input 136 | //////////////////////////////////////////////////////////////////////////////// 137 | 138 | define parse_move (List -> Optional): 139 | -> chars; 140 | do (with (+Fail)): 141 | if (chars length = 2): 142 | (chars 0 get "invalid move" from_some) 143 | (chars 1 get "invalid move" from_some) 144 | read_x_y 145 | // HACK: Needs generic instances. 146 | elif (chars length = 1 && { chars 0 get "invalid move" from_some = 'q' }): 147 | forfeit some 148 | else: 149 | none 150 | 151 | define read_x_y (Char, Char -> Optional): 152 | match (dup2 try_read_x_y) 153 | case some: \drop2 dip some 154 | case none: swap try_read_x_y 155 | 156 | define try_read_x_y (Char, Char -> Optional): 157 | \read_x \read_y both \mark lift_optional_2 158 | 159 | define read_x (Char -> Optional): 160 | -> c; 161 | if (c "aA" elem): 0 some 162 | elif (c "bB" elem): 1 some 163 | elif (c "cC" elem): 2 some 164 | else: none 165 | 166 | define read_y (Char -> Optional): 167 | -> c; 168 | if (c "1!" elem): 0 some 169 | elif (c "2@" elem): 1 some 170 | elif (c "3#" elem): 2 some 171 | else: none 172 | 173 | //////////////////////////////////////////////////////////////////////////////// 174 | // Output 175 | //////////////////////////////////////////////////////////////////////////////// 176 | 177 | instance show (Board -> List +Fail): 178 | -> board; 179 | " --+-+--\n" -> divider; 180 | " A B C\n" -> heading; 181 | [ 182 | heading, "1 ", board 0 show_row, "\n", 183 | divider, "2 ", board 1 show_row, "\n", 184 | divider, "3 ", board 2 show_row, "\n", 185 | ] concat 186 | 187 | define show_row (Board, Int32 -> List +Fail): 188 | (* 3) -> row_index; 189 | -> board; 190 | [ 191 | " ", board (0 + row_index) show_cell, 192 | "|", board (1 + row_index) show_cell, 193 | "|", board (2 + row_index) show_cell, 194 | ] concat 195 | 196 | define show_cell (Board, Int32 -> List +Fail): 197 | \board_cells dip board_index get 198 | "invalid board index" from_some show 199 | 200 | instance show (Player -> List): 201 | match 202 | case player_x: "X" 203 | case player_o: "O" 204 | 205 | instance show (Cell -> List): 206 | match 207 | case vacant: " " 208 | case occupied: show 209 | 210 | //////////////////////////////////////////////////////////////////////////////// 211 | // Constants and Helpers 212 | //////////////////////////////////////////////////////////////////////////////// 213 | 214 | define new_game (-> Board, Player): 215 | empty_board first_player 216 | 217 | define empty_board (-> Board): 218 | vacant 9 replicate board_of_cells 219 | 220 | define first_player (-> Player): 221 | player_x 222 | 223 | define is_yes (List -> Bool): 224 | { "yY" elem } any 225 | 226 | define is_no (List -> Bool): 227 | { "nN" elem } any 228 | 229 | define board_cells (Board -> List): 230 | match case board_of_cells {} 231 | 232 | // Converts an (x, y) position to a cell number. 233 | define cell_number (Int32, Int32 -> Int32): 234 | -> x, y; 3 * y + x 235 | 236 | // Converts a cell number to a board index. 237 | define board_index (Int32 -> Int32): 238 | (8 -) 239 | 240 | //////////////////////////////////////////////////////////////////////////////// 241 | // Hacks and Workarounds 242 | //////////////////////////////////////////////////////////////////////////////// 243 | 244 | // HACK: Should be derived automatically. 245 | instance = (Player, Player -> Bool): 246 | match 247 | case player_x: match case player_x { true } case player_o { false } 248 | case player_o: match case player_x { false } case player_o { true } 249 | 250 | // HACK: Should be derived automatically. 251 | instance = (Cell, Cell -> Bool): 252 | -> cx, cy; 253 | match (cx) 254 | case occupied -> x: match (cy) case occupied -> y { x = y } else { false } 255 | case vacant: match (cy) case vacant { true } else { false } 256 | --------------------------------------------------------------------------------