├── src ├── Theseus │ ├── Tc.hs │ ├── Debug.hs │ ├── Repl.hs │ ├── Eval.hs │ ├── AbstractSyntax.hs │ ├── Pretty.hs │ ├── Semantics.hs │ ├── Parse.hs │ └── Coverage.hs └── Theseus.hs ├── papers ├── theseus.pdf └── information-effects.pdf ├── repl └── Main.hs ├── .gitignore ├── shell.nix ├── examples ├── ordering.ths ├── partial.ths ├── binary.ths ├── tree.ths ├── byte.ths ├── bool.ths ├── pi.ths ├── sort.ths └── peano.ths ├── nix ├── haskell │ ├── theseus.nix │ ├── parsix.nix │ └── deriving-compat.nix └── fetchNixpkgs.nix ├── theseus.cabal ├── default.nix └── README.md /src/Theseus/Tc.hs: -------------------------------------------------------------------------------- 1 | module Theseus.Tc 2 | ( 3 | ) where 4 | 5 | 6 | -------------------------------------------------------------------------------- /papers/theseus.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chessai/theseus/HEAD/papers/theseus.pdf -------------------------------------------------------------------------------- /papers/information-effects.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chessai/theseus/HEAD/papers/information-effects.pdf -------------------------------------------------------------------------------- /repl/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Theseus as T 4 | 5 | main :: IO () 6 | main = T.main 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.ghc* 2 | *dist* 3 | *dist-newstyle* 4 | *.swo 5 | *.swp 6 | *.swa 7 | *.ps 8 | result* 9 | *.hi 10 | *.o -------------------------------------------------------------------------------- /src/Theseus/Debug.hs: -------------------------------------------------------------------------------- 1 | module Theseus.Debug 2 | ( debug 3 | ) where 4 | 5 | debug :: Bool 6 | debug = False 7 | -- debug = True 8 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { package ? "theseus", compiler ? "ghc822" }: 2 | 3 | (import ./default.nix { 4 | inherit package compiler; 5 | }).theseus 6 | -------------------------------------------------------------------------------- /examples/ordering.ths: -------------------------------------------------------------------------------- 1 | -- Haskell style ordering type 2 | data Ordering 3 | = LT 4 | | EQ 5 | | GT 6 | 7 | iso orderUp : Ordering = Ordering 8 | | EQ = GT 9 | | LT = EQ 10 | | GT = LT 11 | 12 | iso orderDown : Ordering = Ordering 13 | | orderUp x = x 14 | 15 | -------------------------------------------------------------------------------- /nix/haskell/theseus.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bound, constrictor, containers, mtl, parsec 2 | , parsix, prettyprinter, prettyprinter-ansi-terminal, stdenv 3 | , transformers, vector 4 | }: 5 | mkDerivation { 6 | pname = "theseus"; 7 | version = "0.0.0.1"; 8 | src = ./.; 9 | libraryHaskellDepends = [ 10 | base bound constrictor containers mtl parsec parsix prettyprinter 11 | prettyprinter-ansi-terminal transformers vector 12 | ]; 13 | homepage = "https://github.com/chessai/theseus.git"; 14 | description = "lang"; 15 | license = stdenv.lib.licenses.mit; 16 | } 17 | -------------------------------------------------------------------------------- /examples/partial.ths: -------------------------------------------------------------------------------- 1 | # Important partial maps 2 | 3 | # Infinite steps (is isomorphic to Peano numbers) 4 | data Inf 5 | = Start 6 | | Step Inf 7 | 8 | data Maybe 9 | = Nothing 10 | | Just 0 11 | 12 | # increases the state-space by 1. 13 | iso just : a = 1 + a 14 | | x = inR x 15 | | iter $ Start = inL () 16 | | iter $ Step n = iter $ n 17 | where iter : Inf 18 | 19 | eval just () 20 | 21 | # this will diverge on any input. This is the empty map. 22 | iso diverge : a = 0 23 | | x = iter $ x, Start 24 | | iter $ x, n = iter $ x, Step n 25 | where iter : a * Inf 26 | 27 | # this will diverge 28 | # eval diverge True 29 | -------------------------------------------------------------------------------- /examples/binary.ths: -------------------------------------------------------------------------------- 1 | -- This is a base 2 number enconding. 2 | -- 0 = E 3 | -- 1 = N (False, E) 4 | -- 2 = N (True, E) 5 | -- 3 = N (False, N (False, E)) 6 | -- 4 = N (False, N (True, E)) 7 | 8 | import Bool 9 | import Peano 10 | 11 | data Binary = E 12 | | N (Bool * Binary) 13 | 14 | 15 | 16 | iso num2bin :: Num <-> Binary 17 | | x <-> iter $ x, E 18 | | iter $ Z, bin <-> bin 19 | | iter $ S x, bin <-> div $ div2 x, bin 20 | | div $ x, bool, bin <-> iter $ x, N (bool, bin) 21 | where iter :: Num * Binary 22 | div :: Num * Bool * Binary 23 | 24 | eval num2bin Z 25 | eval num2bin S Z 26 | eval num2bin S S Z 27 | eval num2bin S S S Z 28 | eval num2bin S S S S Z 29 | 30 | -------------------------------------------------------------------------------- /src/Theseus.hs: -------------------------------------------------------------------------------- 1 | module Theseus 2 | ( main 3 | ) 4 | where 5 | 6 | --import Theseus.Eval (run) 7 | import Theseus.Repl (repl) 8 | import System.IO (hFlush, getLine, stdout) 9 | 10 | main :: IO () 11 | main = repl 12 | 13 | {- 14 | replRead :: IO String 15 | replRead = do 16 | putStr "> " 17 | hFlush stdout 18 | getLine 19 | 20 | repl :: IO () 21 | repl = do 22 | input <- replRead 23 | case parseCommand (words input) of 24 | Load file -> do 25 | run file 26 | repl 27 | BadCmd -> do 28 | putStrLn "Bad command!" 29 | repl 30 | 31 | 32 | data Command = Load FilePath | BadCmd 33 | 34 | parseCommand :: [String] -> Command 35 | parseCommand ["load", f] = Load f 36 | parseCommand _ = BadCmd 37 | -} 38 | -------------------------------------------------------------------------------- /examples/tree.ths: -------------------------------------------------------------------------------- 1 | import Bool 2 | import Peano 3 | 4 | data Tree = Leaf Num 5 | | Node (Tree * Tree) 6 | 7 | data Ctxt = Empty 8 | | L (Ctxt * Tree) 9 | | R (Tree * Ctxt) 10 | 11 | iso treeWalk : f:(Num = Num) -> Tree = Tree 12 | | tr = walk $ tr, Empty 13 | | walk $ Leaf b, ctxt = reconst $ ctxt, Leaf (f b) 14 | | walk $ Node (b1, b2), ctxt = walk $ b1, L (ctxt, b2) 15 | | reconst $ Empty, tr = tr 16 | | reconst $ L (ctxt, b2), b1 = walk $ b2, R (b1, ctxt) 17 | | reconst $ R (b1, ctxt), b2 = reconst $ ctxt, Node (b1, b2) 18 | where walk : Tree * Ctxt 19 | reconst : Ctxt * Tree 20 | 21 | eval treeWalk ~f:add1 (Leaf Z) 22 | eval treeWalk ~f:add1 (Node (Leaf Z, Leaf Z)) 23 | -------------------------------------------------------------------------------- /nix/haskell/parsix.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, containers, fetchgit, fingertree 2 | , mtl, parsers, prettyprinter, prettyprinter-ansi-terminal 3 | , QuickCheck, stdenv, tasty, tasty-hunit, tasty-quickcheck, text 4 | , transformers 5 | }: 6 | mkDerivation { 7 | pname = "parsix"; 8 | version = "0.1.0.0"; 9 | src = fetchgit { 10 | url = "https://github.com/ollef/parsix"; 11 | sha256 = "13g0r8jd5iylyinzc7m11lykv3gvs91bq3209f1g9a4zaw910kxw"; 12 | rev = "b0e0597ee0947181e40939ab7a77a3b6ba496b21"; 13 | }; 14 | libraryHaskellDepends = [ 15 | base bytestring containers fingertree mtl parsers prettyprinter 16 | prettyprinter-ansi-terminal text transformers 17 | ]; 18 | testHaskellDepends = [ 19 | base QuickCheck tasty tasty-hunit tasty-quickcheck text 20 | ]; 21 | homepage = "https://github.com/ollef/parsix"; 22 | license = stdenv.lib.licenses.bsd3; 23 | } 24 | -------------------------------------------------------------------------------- /examples/byte.ths: -------------------------------------------------------------------------------- 1 | import Bool 2 | 3 | iso up : f:(a = a) -> a * Bool = a * Bool 4 | | a, False = a, True 5 | | a, True = f a, False 6 | 7 | data Byte = Byte (Bool * Bool * Bool * Bool * Bool * Bool * Bool * Bool) 8 | 9 | iso next : Byte = Byte 10 | | Byte x = Byte (up ~f:(up ~f:(up ~f:(up ~f:(up ~f:(up ~f:(up ~f:not)))))) x) 11 | 12 | eval next Byte (True, True, True, True, True, True, True, True) 13 | eval next Byte (True, True, True, True, True, True, True, False) 14 | eval next Byte (True, True, True, True, True, True, False, True) 15 | eval next Byte (False, True, True, True, True, True, True, True) 16 | 17 | iso prev : Byte = Byte 18 | | next x = x 19 | 20 | eval prev Byte (True, True, True, True, True, True, True, True) 21 | eval prev Byte (True, True, True, True, True, True, True, False) 22 | eval prev Byte (True, True, True, True, True, True, False, True) 23 | eval prev Byte (False, True, True, True, True, True, True, True) 24 | -------------------------------------------------------------------------------- /examples/bool.ths: -------------------------------------------------------------------------------- 1 | use Partial 2 | 3 | data Bool = True | False 4 | 5 | # identity 6 | iso id : a = a 7 | | x = x 8 | 9 | # boolean not 10 | iso not : Bool = Bool 11 | | True = False 12 | | False = True 13 | 14 | # conditionals over bool 15 | iso if : then:(a = a) -> else:(a = a) -> (Bool * a = Bool * a) 16 | | True, x = True, then x 17 | | False, x = False, else x 18 | 19 | # controlled not 20 | iso cnot : Bool * Bool = Bool * Bool 21 | | x = if ~then:not ~else:id x 22 | 23 | # toffoli gate 24 | iso toffoli : Bool * (Bool * Bool) = Bool * (Bool * Bool) 25 | | x = if ~then:cnot ~else:id x 26 | 27 | eval toffoli True, (True, True) 28 | eval toffoli True, (True, False) 29 | eval toffoli True, (False, True) 30 | eval toffoli True, (False, False) 31 | 32 | iso makeTrue : 1 = Bool 33 | | () = let $ just () 34 | | let $ inL () = False 35 | | let $ inR () = True 36 | where let : 1 + 1 37 | 38 | iso makeFalse : 1 = Bool 39 | | () = not (makeTrue ()) 40 | 41 | # make constants 42 | eval makeTrue () 43 | eval makeFalse () 44 | -------------------------------------------------------------------------------- /nix/haskell/deriving-compat.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, base-compat, base-orphans, containers 2 | , fetchgit, ghc-boot-th, ghc-prim, hspec, hspec-discover 3 | , QuickCheck, stdenv, tagged, template-haskell, th-abstraction 4 | , transformers, transformers-compat 5 | }: 6 | mkDerivation { 7 | pname = "deriving-compat"; 8 | version = "0.4.1"; 9 | src = fetchgit { 10 | url = "https://github.com/haskell-compat/deriving-compat.git"; 11 | sha256 = "1m1hfyrhkhgr25bp90082rrgh062dfyixx0q4j0f91r443qib4yy"; 12 | rev = "ba03150271a664f7659ac824304453ecbaf353f4"; 13 | }; 14 | libraryHaskellDepends = [ 15 | base containers ghc-boot-th ghc-prim template-haskell 16 | th-abstraction transformers transformers-compat 17 | ]; 18 | testHaskellDepends = [ 19 | base base-compat base-orphans hspec QuickCheck tagged 20 | template-haskell transformers transformers-compat 21 | ]; 22 | testToolDepends = [ hspec-discover ]; 23 | homepage = "https://github.com/haskell-compat/deriving-compat"; 24 | description = "Backports of GHC deriving extensions"; 25 | license = stdenv.lib.licenses.bsd3; 26 | } 27 | -------------------------------------------------------------------------------- /theseus.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | theseus 4 | version: 5 | 0.0.0.1 6 | synopsis: 7 | lang 8 | description: 9 | Theseus, functional language with fully reversible computation 10 | homepage: 11 | https://github.com/chessai/theseus.git 12 | license: 13 | MIT 14 | license-file: 15 | LICENSE 16 | author: 17 | chessai 18 | maintainer: 19 | chessai1996@gmail.com 20 | copyright: 21 | (c) 2018 chessai 22 | category: 23 | Language 24 | build-type: 25 | Simple 26 | extra-source-files: 27 | ChangeLog.md 28 | 29 | library 30 | hs-source-dirs: 31 | src 32 | exposed-modules: 33 | Theseus 34 | Theseus.AbstractSyntax 35 | Theseus.Coverage 36 | Theseus.Eval 37 | Theseus.Parse 38 | Theseus.Pretty 39 | Theseus.Repl 40 | Theseus.Semantics 41 | Theseus.Tc 42 | build-depends: 43 | , base >=4.10 && <5 44 | , pretty 45 | , parsec 46 | , transformers 47 | , mtl 48 | , repline 49 | default-language: Haskell2010 50 | ghc-options: 51 | -Wall 52 | -O2 53 | 54 | executable thci 55 | main-is: Main.hs 56 | hs-source-dirs: repl 57 | default-language: Haskell2010 58 | build-depends: base, theseus 59 | ghc-options: -Wall -Werror -O2 60 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { package ? "theseus", compiler ? "ghc822" }: 2 | let fetchNixpkgs = import ./nix/fetchNixpkgs.nix; 3 | nixpkgs = fetchNixpkgs { 4 | rev = "7513208cd33e87eb1d66e4663232a3242e6818dd"; 5 | sha256 = "0hh50spx97nnzcj4ph40prkalwmb6ayffg7gyvzrfhia1c9pb7hb"; 6 | sha256unpacked = "0cbdy2rn6a9vvpcajfkix1czcg12b8xv0902sjhlzgvr73y49r1c"; 7 | }; 8 | pkgs = import nixpkgs { config = {}; overlays = []; }; 9 | inherit (pkgs) haskell; 10 | 11 | filterPredicate = p: type: 12 | let path = baseNameOf p; in !( 13 | (type == "directory" && path == "dist") 14 | || (type == "symlink" && path == "result") 15 | || (type == "directory" && path == ".git") 16 | || (type == "symlink" && pkgs.lib.hasPrefix "result" path) 17 | || pkgs.lib.hasSuffix "~" path 18 | || pkgs.lib.hasSuffix ".o" path 19 | || pkgs.lib.hasSuffix ".so" path 20 | || pkgs.lib.hasSuffix ".nix" path); 21 | 22 | overrides = haskell.packages.${compiler}.override { 23 | overrides = self: super: 24 | with haskell.lib; 25 | with { cp = file: (self.callPackage (./nix/haskell + "/${file}.nix") {}); 26 | build = name: path: self.callCabal2nix name (builtins.filterSource filterPredicate path) {}; 27 | }; 28 | { 29 | parsix = dontCheck (cp "parsix"); 30 | theseus = cp "theseus"; 31 | }; 32 | }; 33 | in rec { 34 | drv = overrides.${package}; 35 | theseus = if pkgs.lib.inNixShell then drv.env else drv; 36 | } 37 | -------------------------------------------------------------------------------- /examples/pi.ths: -------------------------------------------------------------------------------- 1 | import Bool -- Note: Pi doesn't resuppose Bool, but its handy for unit 2 | -- tests using "eval" 3 | 4 | ----------------------------------------------- 5 | -- Pi primitives 6 | 7 | iso swapPlus : a + b = b + a 8 | | inL a = inR a 9 | | inR b = inL b 10 | 11 | iso swapTimes : a * b = b * a 12 | | x, y = y, x 13 | 14 | iso distrib : a * (b + c) = a * b + a * c 15 | | a, inL b = inL (a, b) 16 | | a, inR c = inR (a, c) 17 | 18 | iso factor : a * b + a * c = a * (b + c) 19 | | distrib x = x 20 | 21 | ----------------------------------------------- 22 | -- Various Composition Forms 23 | 24 | -- adjoints 25 | iso adjoint : f:(a = b) -> (b = a) 26 | | f x = x 27 | 28 | eval adjoint ~f:(if ~then:not ~else:id) (True, True) 29 | eval adjoint ~f:(if ~then:not ~else:id) (False, True) 30 | 31 | -- sequencing 32 | iso fseq : f:(a = b) -> g:(b = c) -> (a = c) 33 | | x = g (f x) 34 | 35 | eval fseq ~f:not ~g:not True 36 | 37 | -- multiplicative parallel 38 | iso ftimes : f:(a = b) -> g:(c = d) -> (a * c = b * d) 39 | | x, y = f x, g y 40 | 41 | eval ftimes ~f:not ~g:not True, True 42 | 43 | -- additive parallel 44 | iso fplus : f:(a = b) -> g:(c = d) -> (a + c = b + d) 45 | | inL x = inL f x 46 | | inR y = inR g y 47 | 48 | eval fplus ~f:not ~g:not (inL True) 49 | eval fplus ~f:not ~g:not (inR True) 50 | 51 | -- additive trace 52 | iso trace : f:(a + b = a + c) -> (b = c) 53 | | x = trace $ inR x 54 | | trace $ x = ret $ f x 55 | | ret $ inL a = trace $ inL a 56 | | ret $ inR c = c 57 | where trace : a + b 58 | ret : a + c 59 | 60 | -- trace ~f:swapPlus = id 61 | eval trace ~f:swapPlus True 62 | -------------------------------------------------------------------------------- /nix/fetchNixpkgs.nix: -------------------------------------------------------------------------------- 1 | { rev # The Git revision of nixpkgs to fetch 2 | , sha256 # The SHA256 of the downloaded .tar 3 | , sha256unpacked # The SHA256 of the downloaded .nar 4 | , system ? builtins.currentSystem # This is overridable if necessary 5 | }: 6 | 7 | with { 8 | ifThenElse = { bool, thenValue, elseValue }: ( 9 | if bool then thenValue else elseValue); 10 | }; 11 | 12 | ifThenElse { 13 | bool = (0 <= builtins.compareVersions builtins.nixVersion "1.12"); 14 | 15 | # In Nix 1.12, we can just give a `sha256` to `builtins.fetchTarball`. 16 | thenValue = ( 17 | builtins.fetchTarball { 18 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 19 | sha256 = sha256unpacked; 20 | }); 21 | 22 | # This hack should at least work for Nix 1.11 23 | elseValue = ( 24 | (rec { 25 | tarball = import { 26 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 27 | inherit sha256; 28 | }; 29 | 30 | builtin-paths = import ; 31 | 32 | script = builtins.toFile "nixpkgs-unpacker" '' 33 | "$coreutils/mkdir" "$out" 34 | cd "$out" 35 | "$gzip" --decompress < "$tarball" | "$tar" -x --strip-components=1 36 | ''; 37 | 38 | nixpkgs = builtins.derivation { 39 | name = "nixpkgs-${builtins.substring 0 6 rev}"; 40 | 41 | builder = builtins.storePath builtin-paths.shell; 42 | 43 | args = [ script ]; 44 | 45 | inherit tarball system; 46 | 47 | tar = builtins.storePath builtin-paths.tar; 48 | gzip = builtins.storePath builtin-paths.gzip; 49 | coreutils = builtins.storePath builtin-paths.coreutils; 50 | }; 51 | }).nixpkgs); 52 | } 53 | -------------------------------------------------------------------------------- /src/Theseus/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# language ScopedTypeVariables #-} 2 | {-# language ViewPatterns #-} 3 | 4 | module Theseus.Repl 5 | ( repl 6 | ) where 7 | 8 | import System.Console.Repline 9 | import Control.Monad.IO.Class 10 | import Data.List 11 | import System.Exit 12 | import Text.Parsec (runParser) 13 | 14 | import Theseus.Coverage 15 | import Theseus.Eval (run) 16 | import Theseus.Parse (progParser) 17 | 18 | type Repl a = HaskelineT IO a 19 | 20 | data Line = Load FilePath | BadCmd 21 | 22 | parseCommand :: [String] -> Line 23 | parseCommand ["load", f] = Load f 24 | parseCommand _ = BadCmd 25 | 26 | banner :: Repl String 27 | banner = pure ">>> " 28 | 29 | initialiser :: Repl () 30 | initialiser = liftIO $ putStrLn "Welcome to THCi" 31 | 32 | commandF :: String -> Repl () 33 | commandF input = parseOneLine input 34 | 35 | optionsList :: [(String, [String] -> Repl ())] 36 | optionsList = 37 | [ ("help", help), ("h", help) 38 | , ("load", load), ("l", load) 39 | , ("quit", quit), ("q", quit) 40 | ] 41 | 42 | help :: [String] -> Repl () 43 | help = const (pure ()) 44 | 45 | load :: [String] -> Repl () 46 | load cmdStr = case parseCommand cmdStr of 47 | Load f -> tryAction $ do 48 | liftIO $ run f 49 | BadCmd -> do 50 | liftIO $ putStrLn $ "unknown command" 51 | 52 | quit :: [String] -> Repl () 53 | quit = const $ do 54 | liftIO $ do 55 | putStrLn "Exiting TCHi." 56 | exitSuccess 57 | 58 | completer :: WordCompleter IO 59 | completer n = do 60 | let names = ["kirk", "spock", "mccoy"] 61 | pure $ filter (isPrefixOf n) names 62 | 63 | repl :: IO () 64 | repl = evalRepl 65 | banner 66 | commandF 67 | optionsList 68 | (Just ':') 69 | (Word completer) 70 | initialiser 71 | 72 | parseOneLine :: String -> Repl () 73 | parseOneLine parseThis = case runParser progParser () "" parseThis of 74 | Left err -> liftIO $ do 75 | print err 76 | Right tcThis -> case tProg tcThis of 77 | [] -> do 78 | pure () 79 | errs -> do 80 | liftIO $ reportErrors errs 81 | -------------------------------------------------------------------------------- /src/Theseus/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Theseus.Eval 4 | ( run 5 | ) where 6 | 7 | import Data.Char as Char 8 | import Text.Parsec (runParser) 9 | 10 | import Theseus.AbstractSyntax 11 | import Theseus.Pretty 12 | import Theseus.Parse 13 | import Theseus.Coverage 14 | import Theseus.Semantics 15 | 16 | -- this is not exactly right since all the defs are put 17 | -- into one big list. This will cause different things to be available 18 | -- in scope. For now I am going to ignore this. 19 | loadImports :: [Def] -> [String]-> IO [Def] 20 | loadImports [] _files = return [] 21 | loadImports (x@(DataTyp _ _) : rest) files = 22 | do defs <- loadImports rest files 23 | return $ x:defs 24 | loadImports (x@(Iso _ _ _ _ _) : rest) files = 25 | do defs <- loadImports rest files 26 | return $ x:defs 27 | loadImports (x@(Eval _ _) : rest) files = 28 | do defs <- loadImports rest files 29 | return $ x:defs 30 | loadImports (Import [] : rest) _files = pure rest 31 | loadImports (Import (f:fs) : rest) files = 32 | do let filename = ((Char.toLower f) : fs) ++ ".ths" 33 | if elem filename files 34 | then do defs <- loadImports rest files 35 | return $ defs 36 | else do 37 | putStr $ "-- {Loading " ++ filename ++ "}\n"; 38 | input <- readFile filename 39 | case runParser progParser () filename input of 40 | Left err -> do 41 | print err 42 | return [] 43 | Right newdefs -> do 44 | defs <- loadImports (newdefs ++ rest) (filename:files) 45 | return defs 46 | 47 | ------------------------------------------------------------------------ 48 | -- Read, process, print 49 | 50 | type Filename = String 51 | 52 | repIO :: Filename -> (Prog -> IO ()) -> IO () 53 | repIO ifile processProg = do 54 | input <- readFile ifile 55 | either print processProg (runParser progParser () ifile input) 56 | 57 | -- typecheck and evaluate 58 | run :: Filename -> IO () 59 | run ifile = repIO ifile $ \initial -> do 60 | p <- loadImports initial [ifile] 61 | putStr "Typechecking...\n" 62 | case tProg p of 63 | [] -> do 64 | putStr "Evaluating...\n" 65 | (_fenv, res) <- evalProg p (FEnv []) True 66 | print_each res 67 | errs -> reportErrors errs 68 | where 69 | print_each = \case 70 | [] -> return () 71 | ((func, val, res):rs) -> do 72 | putStr $ 73 | "eval " ++ show (ppFunc func) ++ " " ++ show (ppVal val) 74 | ++ " = " ++ show (curVal res) ++ "\n" 75 | print_each rs 76 | 77 | 78 | -------------------------------------------------------------------------------- /examples/sort.ths: -------------------------------------------------------------------------------- 1 | import Peano 2 | import Bool 3 | 4 | -- have a way of talking about 'x : 0' explicitely. 5 | 6 | -- iso acc : Num * Num * Num = Num * Num * Num 7 | -- | x, y = lab $ inL (x, y) 8 | -- | lab $ inL (x, y) = iter $ x, y, Z 9 | -- | lab $ inR (diverge (n, m, x)) = S n, S m, x 10 | -- | iter $ S n, S m, x = iter $ n, m, S x 11 | -- | iter $ Z, Z, x = Z, Z, x 12 | -- | iter $ S n, Z, x = S n, Z, x 13 | -- | iter $ Z, S n, x = Z, S n, x 14 | -- where lab : x + 0 15 | -- iter : Num * Num * Num 16 | 17 | iso lessOrEq : Num * Num = Num * Num * Bool 18 | | x, y = down $ x, y, Z 19 | | down $ S n, S m, x = down $ n, m, S x 20 | | down $ Z, S m, x = up $ Z, S m, x, makeFalse () 21 | | down $ Z, Z, x = up $ Z, Z, x, makeFalse () 22 | | down $ S n, Z, x = up $ S n, Z, x, makeTrue () 23 | | up $ x, y, S n, b = up $ S x, S y, n, b 24 | | up $ x, y, Z, b = x, y, b 25 | where down : Num * Num * Num 26 | up : Num * Num * Num * Bool 27 | 28 | eval lessOrEq Z, Z 29 | eval lessOrEq S Z, Z 30 | eval lessOrEq Z, S Z 31 | 32 | -- sort 2 nums 33 | iso sort2 : Num * Num = Num * Num * Bool 34 | | x, y = ret $ lessOrEq (x, y) 35 | | ret $ x, y, True = y, x, True 36 | | ret $ x, y, False = x, y, False 37 | where ret : Num * Num * Bool 38 | 39 | eval sort2 Z, Z 40 | eval sort2 S Z, Z 41 | eval sort2 Z, S Z 42 | 43 | -- sort 3 nums 44 | iso sort3 : Num * Num * Num = Num * Num * Num * (Bool * Bool * Bool) 45 | | x, y, z = r1 $ (sort2 (x, y)), z 46 | | r1 $ (x, y, b1), z = r2 $ x, b1, (sort2 (y, z)) 47 | | r2 $ x, b1, (y, z, b2) = r3 $ (sort2 (x, y)), z, b1, b2 48 | | r3 $ (x, y, b3), z, b1, b2 = x, y, z, (b1, b2, b3) 49 | where r1 : (Num * Num * Bool) * Num 50 | r2 : Num * Bool * (Num * Num * Bool) 51 | r3 : (Num * Num * Bool) * Num * Bool * Bool 52 | 53 | eval sort3 Z, Z, Z 54 | eval sort3 S Z, Z, S S Z 55 | eval sort3 Z, S Z, S S Z 56 | eval sort3 S S Z, S Z, Z 57 | 58 | -- extensible tuple sort 59 | iso sortN : s:(ns * Num = ns * Num * bs) 60 | -> (ns * Num * Num = ns * Num * Num * (bs * Bool * bs)) 61 | | ns, m = r1 $ m, s ns 62 | | r1 $ m, ((ns, n), bs) = r2 $ sort2 (n, m), ns, bs 63 | | r2 $ (n, m, b), ns, bs = r3 $ s (ns, n), m, (bs, b) 64 | | r3 $ (ns1, bs1), m, (bs, b) = ns1, m, (bs, b, bs1) 65 | where r1 : Num * ((ns * Num) *bs) 66 | r2 : (Num * Num * Bool) * ns * bs 67 | r3 : ((ns * Num) * bs) * Num * (bs * Bool) 68 | 69 | -- sort 3 nums 70 | eval sortN ~s:sort2 Z, Z, Z 71 | eval sortN ~s:sort2 S Z, Z, S S Z 72 | eval sortN ~s:sort2 Z, S Z, S S Z 73 | eval sortN ~s:sort2 S S Z, S Z, Z 74 | 75 | -- sort 4 nums 76 | eval sortN ~s:(sortN ~s:sort2) Z, Z, Z, Z 77 | eval sortN ~s:(sortN ~s:sort2) S Z, Z, S S S Z, S S Z 78 | eval sortN ~s:(sortN ~s:sort2) Z, S Z, S S Z, S S S Z 79 | eval sortN ~s:(sortN ~s:sort2) S S S Z, S S Z, S Z, Z 80 | -------------------------------------------------------------------------------- /src/Theseus/AbstractSyntax.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Theseus.AbstractSyntax 4 | ( Prog, Constr, TName, FName, Var, LName, ModuleName, Formals, Val 5 | , PVal(..) 6 | , Def(..) 7 | , Typ(..) 8 | , ITyp(..) 9 | , Func(..) 10 | , Clause(..) 11 | ) where 12 | 13 | type Prog = [Def] 14 | 15 | -- TODO: the case of various identifiers is not enforced 16 | type Constr = String -- constructor name (start with caps) 17 | type TName = String -- type name (start with caps) 18 | type FName = String -- function names (start with lowercase) 19 | type Var = String -- ordinary pattern variables (start with lowercase) 20 | type LName = String -- Label names 21 | type ModuleName = String -- Module names are filenames without ".ths" 22 | -- and with the first letter capitalized 23 | 24 | data Def 25 | = DataTyp TName [(Constr,Typ)] 26 | | Iso FName Formals ITyp [(LName, Typ)] [Clause] 27 | | Eval Func PVal 28 | | Import ModuleName 29 | deriving (Eq, Ord, Show) 30 | 31 | type Formals = [(FName, ITyp)] 32 | 33 | data Typ 34 | = One 35 | | Zero 36 | | Times Typ Typ 37 | | Plus Typ Typ 38 | | TName TName 39 | | Neg Typ 40 | deriving (Eq, Ord, Show) 41 | 42 | -- | Isomorphisms, `a = b`. 43 | data ITyp = ITyp Typ Typ 44 | deriving (Eq, Ord, Show) 45 | 46 | data PVal 47 | = Unit -- ^ unit 48 | | Pair PVal PVal -- ^ pairs 49 | | LeftE PVal -- ^ sum (left con) 50 | | RightE PVal -- ^ sum (right con) 51 | | Constr Constr PVal -- ^ pattern starting with constructor 52 | | Minus PVal -- ^ a negative value 53 | | Var Var -- ^ pattern variable (cannot show up in values) 54 | | App Func PVal -- ^ function call (cannot show up in values) 55 | deriving (Eq, Show) 56 | 57 | ordSeq :: Ordering -> Ordering -> Ordering 58 | ordSeq = \case 59 | EQ -> id 60 | x -> const x 61 | 62 | ctorNum :: PVal -> Int 63 | ctorNum = \case 64 | Unit -> 0 65 | Pair{} -> 1 66 | LeftE{} -> 2 67 | RightE{} -> 3 68 | Constr{} -> 4 69 | Minus{} -> 5 70 | Var{} -> -1 71 | App{} -> -1 72 | 73 | instance Ord PVal where 74 | compare p p' = 75 | (compare (ctorNum p) (ctorNum p')) `ordSeq` (comp p p') 76 | where 77 | comp Unit Unit = EQ 78 | comp (Pair p1 p2) (Pair p1' p2') = 79 | (compare p1 p1') `ordSeq` (compare p2 p2') 80 | comp (LeftE p1) (LeftE p2) = compare p1 p2 81 | comp (RightE p1) (RightE p2) = compare p1 p2 82 | comp (Constr c1 p1) (Constr c2 p2) = 83 | (compare c1 c2) `ordSeq` (compare p1 p2) 84 | comp (Minus p1) (Minus p2) = compare p1 p2 85 | comp (Var _) (Var _) = EQ 86 | comp (Var _) (App _ _) = EQ 87 | comp (App _ _) (Var _) = EQ 88 | comp (App _ _) (App _ _) = EQ 89 | comp p1 p2 = compare (ctorNum p1) (ctorNum p2) 90 | 91 | -- we intend this to mean just the value fragement of PVal, but there 92 | -- is no nice way of saying that right now. 93 | type Val = PVal 94 | 95 | data Func = Func FName [(String, Maybe Func)] 96 | deriving (Show, Eq, Ord) 97 | 98 | data Clause = Clause (Maybe LName, PVal) (Maybe LName, PVal) 99 | deriving (Show, Eq, Ord) 100 | 101 | -------------------------------------------------------------------------------- /examples/peano.ths: -------------------------------------------------------------------------------- 1 | -- This a Peano style unary number encoding 2 | -- 0 = Z 3 | -- 1 = S Z 4 | -- 2 = S S Z 5 | -- 3 = S S S Z 6 | import Bool 7 | import Ordering 8 | import Partial 9 | 10 | data Num = Z 11 | | S Num 12 | 13 | iso parity :: Num * Bool <-> Num * Bool 14 | | n, x <-> lab $ n, Z, x 15 | | lab $ S n, m, x <-> lab $ n, S m, not x 16 | | lab $ Z, m, x <-> m, x 17 | where lab :: Num * Num * Bool 18 | 19 | -- Note: Application of constructors is right associative. This makes 20 | -- sense in this language since (1) we don't have any first class 21 | -- functions and (2) All constructors behave like unary operators. 22 | 23 | -- Run one or more expressions like this. We should think some more 24 | -- about what the top level interface should be. Writing eval 25 | -- expressions like this is clearly not ideal. Maybe we should have a 26 | -- Theseus REPL. 27 | eval parity S S S Z, True 28 | eval parity S S Z, True 29 | eval parity S Z, True 30 | eval parity Z, True 31 | 32 | -- add1 x <-> S x 33 | iso add1 :: Num <-> Num 34 | | x <-> ret $ just x 35 | | ret $ inL () <-> Z 36 | | ret $ inR n <-> S n 37 | where ret :: 1 + Num 38 | 39 | -- just for reference, this is the fully inlined version of add1. 40 | iso add1_inlined :: Num <-> Num 41 | | x <-> ret $ inR x 42 | | lab $ Z <-> ret $ inL () 43 | | lab $ S n <-> lab $ n 44 | | ret $ inL () <-> Z 45 | | ret $ inR n <-> S n 46 | where ret :: 1 + Num 47 | lab :: Num 48 | 49 | -- sub1 S x <-> x 50 | -- sub1 0 <-> undef 51 | iso sub1 :: Num <-> Num 52 | | add1 x <-> x 53 | 54 | eval add1 Z 55 | eval add1 S Z 56 | eval sub1 S Z 57 | eval sub1 S S Z 58 | 59 | -- add (x, y) <-> (x, x+y) 60 | iso add :: Num * Num <-> Num * Num 61 | | x, y <-> iter $ x, Z, y 62 | | iter $ Z, m, n <-> m, n 63 | | iter $ S x, m, n <-> iter $ x, S m, add1 n 64 | where iter :: Num * Num * Num 65 | 66 | eval add Z, Z 67 | eval add S Z, Z 68 | eval add S S Z, S S Z 69 | 70 | -- times x, y, z <-> x, y, (z + x * y) 71 | iso times :: Num * Num * Num <-> Num * Num * Num 72 | | x, y, z <-> iter $ x, Z, (y, z) 73 | | iter $ Z, c, (y, z) <-> c, y, z 74 | | iter $ S x, c, (y, z) <-> iter $ x, S c, add (y, z) 75 | where iter :: Num * Num * (Num * Num) 76 | 77 | eval times S S Z, S S Z, Z 78 | 79 | iso compare :: Num * Num * Ordering <-> Num * Num * Ordering 80 | | x, y, ord <-> iter $ x, y, Z, ord 81 | | iter $ Z, S n, c, ord <-> unwind $ c, Z, S n, orderDown ord 82 | | iter $ Z, Z, c, ord <-> unwind $ c, Z, Z, ord 83 | | iter $ S m, Z, c, ord <-> unwind $ c, S m, Z, orderUp ord 84 | | iter $ S m, S n, c, ord <-> iter $ m, n, S c, ord 85 | | unwind $ S c, x, y, ord <-> unwind $ c, S x, S y, ord 86 | | unwind $ Z, x, y, ord <-> x, y, ord 87 | where iter :: Num * Num * Num * Ordering 88 | unwind :: Num * Num * Num * Ordering 89 | 90 | eval compare S Z, S S Z, EQ 91 | eval compare S Z, S Z, EQ 92 | eval compare S S Z, S Z, EQ 93 | 94 | iso div2 :: Num <-> Num * Bool 95 | | x <-> iter $ x, Z 96 | | iter $ Z, n <-> n, False 97 | | iter $ S Z, n <-> n, True 98 | | iter $ S S x, n <-> iter $ x, S n 99 | where iter :: Num * Num 100 | 101 | eval div2 Z 102 | eval div2 S Z 103 | eval div2 S S Z 104 | eval div2 S S S Z 105 | eval div2 S S S S Z 106 | 107 | -- -- I would like to write this. 108 | -- iso makeZero :: 1 <-> Num 109 | -- | () <-> Z 110 | -- | diverge n <-> S n 111 | -------------------------------------------------------------------------------- /src/Theseus/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Theseus.Pretty 4 | ( ppProg 5 | , ppDef 6 | , ppFunc 7 | , ppVal 8 | ) where 9 | 10 | import Text.PrettyPrint.HughesPJ hiding (char,comma,parens,integer,space) 11 | import qualified Text.PrettyPrint.HughesPJ as PP 12 | 13 | import Theseus.AbstractSyntax 14 | 15 | ppProg :: Prog -> Doc 16 | ppProg = \case 17 | [] -> PP.space 18 | (d:ds) -> PP.space $+$ ppDef d $+$ ppProg ds 19 | 20 | ppDef :: Def -> Doc 21 | ppDef = \case 22 | DataTyp t alts -> 23 | hsep [text "data", text t, equals, ppAlts alts] 24 | Iso name args ityp labels clauses -> 25 | vcat 26 | [ hsep [text "iso", text name, text ":", ppFArgs args, ppITyp ityp] 27 | , vcat (map ppClause clauses) 28 | , ppLabels labels 29 | ] 30 | Eval func val -> 31 | hsep [text "eval", ppFunc func, ppVal val] 32 | Import modname -> 33 | hsep [text "use", text modname] 34 | 35 | ppAlts :: [(Constr,Typ)] -> Doc 36 | ppAlts = \case 37 | [] -> PP.space 38 | [(constr,One)] -> 39 | hsep [text constr] -- drop unit args of ctors 40 | [(constr,typ)] -> 41 | hsep [text constr, ppTyp typ] 42 | ((constr,One):alts) -> 43 | hsep [text constr, text "|", ppAlts alts] 44 | ((constr,typ):alts) -> 45 | hsep [text constr, ppTyp typ, text "|", ppAlts alts] 46 | 47 | ppFArgs :: [(FName, ITyp)] -> Doc 48 | ppFArgs = \case 49 | [] -> empty 50 | ((fname, ityp):args) -> 51 | hsep [ hcat [text fname, text ":", text "(", ppITyp ityp, text ")"] 52 | , text "->", ppFArgs args 53 | ] 54 | 55 | ppTyp :: Typ -> Doc 56 | ppTyp = \case 57 | One -> text "1" 58 | Zero -> text "0" 59 | TName t -> text t 60 | Neg t -> hcat [text "-", ppTyp t] 61 | Times t1 t2 -> hsep [ppTypParen t1, text "*", ppTypParen t2] 62 | Plus t1 t2 -> hsep [ppTypParen t1, text "+", ppTypParen t2] 63 | 64 | ppITyp :: ITyp -> Doc 65 | ppITyp (ITyp b1 b2) = hsep [ppTyp b1, text "=", ppTyp b2] 66 | 67 | 68 | ppTypParen :: Typ -> Doc 69 | ppTypParen = \case 70 | t@Times{} -> PP.parens (ppTyp t) 71 | t@Plus{} -> PP.parens (ppTyp t) 72 | t -> ppTyp t 73 | 74 | ppLabels :: [(LName, Typ)] -> Doc 75 | ppLabels = \case 76 | [] -> empty 77 | ((label, typ):labels) -> 78 | vcat [ hsep [text "where", text label, text ":", ppTyp typ] 79 | , ppLabels labels 80 | ] 81 | 82 | ppVal :: PVal -> Doc 83 | ppVal = \case 84 | Unit -> text "()" 85 | LeftE v -> hsep [text "inL", ppValParen v] 86 | RightE v -> hsep [text "inR", ppValParen v] 87 | Pair v1 v2 -> sep [ hcat [ppVal v1, PP.comma] 88 | , nest 2 $ ppValParen v2 89 | ] 90 | Constr c Unit -> text c 91 | Constr c p -> hsep [text c, ppValParen p] 92 | Var x -> text x 93 | App func v -> hsep [ppFunc func, ppVal v] 94 | Minus v -> hcat [text "-", ppVal v] 95 | 96 | ppValParen :: PVal -> Doc 97 | ppValParen = \case 98 | v@Pair{} -> PP.parens (ppVal v) 99 | v -> ppVal v 100 | 101 | 102 | ppFunc :: Func -> Doc 103 | ppFunc (Func fname params) = hsep [ text fname, ppFParams params] 104 | where 105 | ppFParams [] = empty 106 | ppFParams ((name, Nothing):params') = 107 | hsep [ hcat [ text "~", text name], ppFParams params'] 108 | ppFParams ((name, Just val):params') = 109 | hsep [ hcat [ text "~", text name , text ":", ppFuncParens val] 110 | , ppFParams params' 111 | ] 112 | 113 | ppFuncParens :: Func -> Doc 114 | ppFuncParens = \case 115 | Func fname [] -> text fname 116 | f -> PP.parens (ppFunc f) 117 | 118 | ppClause :: Clause -> Doc 119 | ppClause (Clause p1 p2) = hsep [text "|", pp p1, text "=", pp p2] 120 | where 121 | pp = \case 122 | (Nothing, p) -> ppVal p 123 | (Just label, p) -> hsep [text label, text "$", ppVal p] 124 | 125 | 126 | -------------------------------------------------------------------------------- /src/Theseus/Semantics.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Theseus.Semantics 4 | ( FEnv(..) 5 | , Cur(..) 6 | , evalProg 7 | ) where 8 | 9 | import Theseus.AbstractSyntax 10 | import Theseus.Coverage 11 | 12 | -- the value environment collects declared constants and isomorphisms 13 | type VEnv = [(Var, Val)] 14 | type Clauses = [Clause] 15 | newtype FEnv = FEnv [(FName, (Clauses, FEnv))] 16 | 17 | data Dir = L | R 18 | deriving Show 19 | 20 | opp :: Dir -> Dir 21 | opp = \case { L -> R; R -> L }; 22 | 23 | projPattern :: Clause -> Dir -> (Maybe LName, PVal) 24 | projPattern (Clause lhs _ ) L = lhs 25 | projPattern (Clause _ rhs) R = rhs 26 | 27 | projPattern2 :: Clause -> Dir -> ((Maybe LName, PVal), (Maybe LName, PVal)) 28 | projPattern2 cl dir = (projPattern cl dir, projPattern cl (opp dir)) 29 | 30 | data Cur = Cur 31 | { curDir :: Dir 32 | , curLabel :: Maybe LName 33 | , curVal :: Val 34 | } deriving Show 35 | 36 | -- Deconstruct a value using a pattern. This builds an environment 37 | -- binding the variables introduced by the pattern and their values. 38 | deconst :: FEnv -> PVal -> Val -> VEnv -> Maybe VEnv 39 | deconst _fenv Unit Unit env = Just env 40 | deconst fenv (LeftE p) (LeftE v) env = deconst fenv p v env 41 | deconst fenv (RightE p) (RightE v) env = deconst fenv p v env 42 | deconst fenv (Pair p1 p2) (Pair v1 v2) env = f (deconst fenv p1 v1 env) 43 | where 44 | f Nothing = Nothing 45 | f (Just env') = deconst fenv p2 v2 env' 46 | deconst fenv (Constr c p) (Constr c1 v) env | c == c1 = deconst fenv p v env 47 | deconst _fenv (Var x) v env = Just ((x, v):env) 48 | deconst fenv (App func p) v env = 49 | let (Cur {curVal=v'}) = evalFunc func fenv (Cur {curVal=v, curDir=R, curLabel=Nothing}) in 50 | deconst fenv p v' env 51 | deconst _ _ _ _ = Nothing 52 | 53 | -- Reconstruct a value from a pattern and an environment that supplies 54 | -- the values of the variables in the pattern. 55 | reconst :: FEnv -> VEnv -> PVal -> Maybe (VEnv, PVal) 56 | reconst _fenv env Unit = return (env, Unit) 57 | reconst fenv env (LeftE p) = 58 | do (env1, v) <- reconst fenv env p 59 | return (env1, LeftE v) 60 | reconst fenv env (RightE p) = 61 | do (env1, v) <- reconst fenv env p 62 | return (env1, RightE v) 63 | reconst fenv env (Pair p1 p2) = 64 | do (env1, v1) <- reconst fenv env p1 65 | (env2, v2) <- reconst fenv env1 p2 66 | return (env2, (Pair v1 v2)) 67 | reconst fenv env (Constr c p) = 68 | do (env1, v) <- reconst fenv env p 69 | return (env1, (Constr c v)) 70 | reconst fenv env (App func p) = 71 | do (env1, v) <- reconst fenv env p 72 | let (Cur {curVal=v'}) = evalFunc func fenv (Cur {curVal=v, curDir=L, curLabel=Nothing}) 73 | return (env1, v') 74 | reconst _fenv env (Var x) = extract env x 75 | where 76 | extract [] _ = Nothing 77 | extract ((x1, v1):env') x' 78 | | x1 == x' = return (env', v1) 79 | | otherwise = do 80 | (env1, v) <- extract env' x 81 | return ((x1, v1):env1, v) 82 | 83 | evalClauses :: [Clause] -> FEnv -> Cur -> Cur 84 | evalClauses clauses fenv cur = apply clauses 85 | where 86 | apply [] = error $ "none of the patterns matched " ++ (show cur) 87 | apply (cl:cls) = 88 | let ((lopt1, p1), (lopt2, p2)) = projPattern2 cl (curDir cur) in 89 | case (lopt1 == (curLabel cur), deconst fenv p1 (curVal cur) []) of 90 | (True, Just env) -> 91 | let v = ret cl (reconst fenv env p2) in 92 | let cur1 = cur { curVal = v, curLabel = lopt2 } in 93 | maybeIter cur1 94 | _ -> apply cls 95 | ret _cl (Just ([], v)) = v 96 | ret cl Nothing = error $ "reconstruction failed " ++ (show cl) ++ " value " ++ (show cur) 97 | ret cl (Just (env, _)) = error $ "non-empty env returned : " ++ (show env) ++ " " ++ show cl ++ " " ++ show cur 98 | maybeIter cur'@(Cur { curLabel = Nothing } ) = cur' 99 | maybeIter cur' = evalClauses clauses fenv cur' 100 | 101 | evalFuncArgs :: Func -> FEnv -> (Clauses, FEnv) 102 | evalFuncArgs (Func fname args) fenv0 = evalArgs args fenv0 103 | where 104 | evalArgs [] (FEnv env) = lookup_exn fname env 105 | evalArgs ((name, Nothing):args') fenv' = evalArgs ((name, Just (Func name [])):args') fenv' 106 | evalArgs ((name, Just func):args') fenv = 107 | let closure = evalFuncArgs func fenv in 108 | let (clauses, FEnv fenv') = evalArgs args' fenv in 109 | (clauses, FEnv ((name, closure):fenv')) 110 | 111 | evalFunc :: Func -> FEnv -> Cur -> Cur 112 | evalFunc func fenv cur = -- for now the args are ignored 113 | -- trace ("eval " ++ (show func) ++ (show cur)) $ 114 | let (clauses, fenv') = evalFuncArgs func fenv in 115 | let res = evalClauses clauses fenv' cur in 116 | -- seq res (trace ("ret from " ++ (show func) ++ show res) res) 117 | res 118 | 119 | -- remove all the IO from here. 120 | evalProg :: [Def] -> FEnv -> Bool -> IO (FEnv, [(Func, Val, Cur)]) 121 | evalProg [] fenv do_eval = 122 | return (fenv, []) 123 | evalProg (DataTyp _ _ : defs) env do_eval = 124 | evalProg defs env do_eval 125 | evalProg (Iso name params ityp labels clauses : defs) (FEnv env) do_eval = 126 | evalProg defs (FEnv ((name, (clauses, FEnv env)):env)) do_eval 127 | evalProg ((Eval func val) : defs) env do_eval = 128 | do (newfenv, rest) <- evalProg defs env do_eval 129 | if do_eval 130 | then 131 | let cur = evalFunc func env (Cur {curLabel = Nothing, curDir = L, curVal = val}) in 132 | return $ (newfenv, (func, val, cur):rest) 133 | else 134 | return (newfenv, rest) 135 | evalProg ((Import (f:fs)) : defs) (FEnv fenv) do_eval = 136 | error "Unexpected import" 137 | 138 | -------------------------------------------------------------------------------- /src/Theseus/Parse.hs: -------------------------------------------------------------------------------- 1 | module Theseus.Parse 2 | ( progParser 3 | ) where 4 | 5 | import Control.Monad.Identity 6 | import Control.Monad.Trans.Reader 7 | import Data.Char as Char 8 | import Data.Foldable (asum) 9 | import Data.Functor (($>)) 10 | import Data.List as List 11 | import Debug.Trace 12 | import Text.Parsec 13 | import Text.Parsec.Expr 14 | import Text.Parsec.Language 15 | import Text.Parsec.String 16 | import Text.Parsec.Token 17 | import Text.PrettyPrint.HughesPJ hiding (char,comma,parens,integer,space) 18 | import Text.Printf 19 | import qualified Control.Monad.State as ST 20 | import qualified Text.PrettyPrint.HughesPJ as PP (char,comma,parens,integer,space) 21 | 22 | import Theseus.AbstractSyntax 23 | import Theseus.Pretty 24 | 25 | ------------------------------------------------------------------------ 26 | -- Parsing 27 | 28 | lexer :: GenTokenParser String a Identity 29 | lexer = makeTokenParser $ 30 | emptyDef { commentStart = "{-" 31 | , commentEnd = "-}" 32 | , commentLine = "#" 33 | , identStart = letter <|> char '_' 34 | , identLetter = alphaNum <|> char '_' 35 | , reservedNames = ["data", "inL", "inR", "eval", "where", "iso"] 36 | , reservedOpNames = ["+","*",",", ";", "=", ":", "()"] 37 | , caseSensitive = True 38 | } 39 | 40 | progParser :: Parsec String () Prog 41 | progParser = do 42 | whiteSpace lexer 43 | defs <- many defParser 44 | eof 45 | return defs 46 | 47 | dataParser :: Parsec String () Def 48 | dataParser = do 49 | t <- reserved lexer "data" >> identifier lexer 50 | symbol lexer "=" 51 | args <- sepBy 52 | (do ctor <- identifier lexer 53 | typ <- option One typParser 54 | return (ctor, typ)) 55 | (symbol lexer "|") 56 | pure (DataTyp t (List.sort args)) 57 | 58 | isoParser :: Parsec String () Def 59 | isoParser = do 60 | reserved lexer "iso" 61 | fname <- try $ do 62 | fname <- identifier lexer 63 | reserved lexer ":" 64 | return fname 65 | fparams <- many $ try $ do 66 | arg <- identifier lexer 67 | symbol lexer ":" 68 | ityp <- itypParser 69 | symbol lexer "->" 70 | return (arg, ityp) 71 | ityp <- itypParser 72 | clauses <- many $ do 73 | symbol lexer "|" 74 | p1 <- valParserWithLabel 75 | symbol lexer "=" 76 | p2 <- valParserWithLabel 77 | return (Clause p1 p2) 78 | labels <- option [] $ do -- now I need a "where" per label. 79 | reserved lexer "where" 80 | many1 $ do 81 | label <- identifier lexer 82 | symbol lexer ":" 83 | typ <- typParser 84 | return (label, typ) 85 | return (Iso fname fparams ityp labels clauses) 86 | 87 | evalParser :: Parsec String () Def 88 | evalParser = do 89 | reserved lexer "eval" 90 | func <- funcParser 91 | v <- valParser 92 | return (Eval func v) 93 | 94 | importParser :: Parsec String () Def 95 | importParser = do 96 | reserved lexer "use" 97 | modname <- lowercaseParse "module name" 98 | return (Import modname) 99 | 100 | defParser :: Parsec String () Def 101 | defParser = asum 102 | [ dataParser 103 | , isoParser 104 | , evalParser 105 | , importParser 106 | ] 107 | 108 | funcParser :: Parsec String () Func 109 | funcParser = do 110 | name <- lowercaseParse "iso name" 111 | args <- many $ do 112 | symbol lexer "~" 113 | label <- lowercaseParse "label" 114 | opt <- option Nothing $ do 115 | symbol lexer ":" 116 | arg <- simpleParser 117 | return (Just arg) 118 | return (label, opt) 119 | return (Func name args) 120 | where 121 | simpleParser = 122 | (do name <- lowercaseParse "iso name" 123 | return (Func name [])) 124 | <|> (parens lexer funcParser) 125 | 126 | typParser :: Parsec String () Typ 127 | typParser = buildExpressionParser typTable simpleTypParser 128 | where 129 | simpleTypParser = 130 | (symbol lexer "0" $> Zero) 131 | <|> 132 | (symbol lexer "1" $> One) 133 | <|> 134 | (TName <$> identifier lexer) 135 | <|> 136 | (parens lexer typParser) 137 | typTable = 138 | [ [ Prefix (reservedOp lexer "-" $> Neg)] 139 | , [ Infix (reservedOp lexer "*" $> Times) AssocLeft] 140 | , [Infix (reservedOp lexer "+" $> Plus) AssocLeft] 141 | ] 142 | 143 | valParser :: Parsec String () PVal 144 | valParser = buildExpressionParser valTable simpleValParser 145 | where 146 | simpleValParser = 147 | (reservedOp lexer "()" $> Unit) 148 | <|> 149 | (try (do fname <- funcParser 150 | val <- simpleValParser 151 | return (App fname val))) 152 | <|> 153 | (do name <- lowercaseParse "variable" 154 | return (Var name)) 155 | <|> 156 | (do name <- uppercaseParse "constructor"; 157 | val <- option Unit simpleValParser 158 | return (Constr name val)) 159 | <|> 160 | (parens lexer valParser) 161 | valTable = 162 | [ [ Prefix (reserved lexer "inL" $> LeftE) 163 | , Prefix (reserved lexer "inR" $> RightE) 164 | ] 165 | , [ Infix (reservedOp lexer "," $> Pair) AssocLeft ] 166 | ] 167 | 168 | valParserWithLabel :: Parsec String () (Maybe LName, PVal) 169 | valParserWithLabel = do 170 | label <- option Nothing $ do 171 | try $ do 172 | l <- identifier lexer 173 | symbol lexer "$" 174 | return (Just l) 175 | val <- valParser 176 | return (label, val) 177 | 178 | itypParser :: Parsec String () ITyp 179 | itypParser = try parse <|> parens lexer parse 180 | where 181 | parse = do 182 | t1 <- typParser 183 | symbol lexer "=" 184 | t2 <- typParser 185 | return (ITyp t1 t2) 186 | 187 | startsWithUpper :: String -> Bool 188 | startsWithUpper [] = False 189 | startsWithUpper (x:_) = Char.isUpper x 190 | 191 | uppercaseParse :: String -> Parsec String () String 192 | uppercaseParse msg = try $ do 193 | name <- identifier lexer 194 | if startsWithUpper name 195 | then return name 196 | else fail msg 197 | 198 | lowercaseParse :: String -> Parsec String () String 199 | lowercaseParse msg = try $ do 200 | name <- identifier lexer 201 | if startsWithUpper name 202 | then fail msg 203 | else return name 204 | 205 | -------------------------------------------------------------------------------- /src/Theseus/Coverage.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Theseus.Coverage 4 | ( lookup_exn 5 | , reportErrors 6 | , tProg 7 | ) where 8 | 9 | import Data.List as List 10 | import Debug.Trace 11 | 12 | import Theseus.AbstractSyntax 13 | import Theseus.Debug 14 | 15 | type TypEnv = [(TName, [(Constr, Typ)])] 16 | type CurTyp = (Typ, TypEnv) 17 | 18 | lookup_exn :: (Eq a, Show a) => a -> [(a, b)] -> b 19 | lookup_exn v0 as = f (lookup v0 as) 20 | where 21 | f (Just v) = v 22 | f Nothing = error ("can't find " ++ (show v0)) 23 | 24 | matchesAny :: PVal -> Bool 25 | matchesAny = \case 26 | Var{} -> True 27 | App{} -> True 28 | _ -> False 29 | 30 | -- expand out patterns of the type till the granularity of the 31 | -- specified pattern is achieved. 32 | expand :: PVal -> CurTyp -> [PVal] 33 | expand Unit (One, _) = [Unit] 34 | expand x (One, _) | matchesAny x = [Unit] -- just for better errors 35 | expand x (_, _) | matchesAny x = [x] 36 | expand (Pair p1 p2) (Times t1 t2, env) = 37 | [Pair v1 v2 | v1 <- expand p1 (t1, env), 38 | v2 <- expand p2 (t2, env)] 39 | expand (LeftE p) (Plus t1 t2, env) = 40 | [LeftE v | v <- expand p (t1, env)] ++ [RightE (Var "_")] 41 | expand (RightE p) (Plus t1 t2, env) = 42 | [LeftE (Var "_")] ++ [RightE v | v <- expand p (t2, env)] 43 | expand (Constr c p) (TName t, env) = 44 | concatMap 45 | (\(c', t') -> if c == c' 46 | then [Constr c' v | v <- expand p (t', env)] 47 | else if t' == One 48 | then [Constr c' Unit] 49 | else [Constr c' (Var "_")]) 50 | (lookup_exn t env) 51 | expand _ _ = [] -- fails only if the pattern doesn't match the type. 52 | 53 | -- check if two patterns are the same 54 | -- if they will satisfy exactly the same values, then they are returned. 55 | -- if one is more general than the other, then it is split up into 56 | -- more specific subpatterns 57 | -- if they can't be reconciled then no patterns are returned 58 | reconcile :: PVal -> PVal -> CurTyp -> ([PVal], [PVal]) 59 | reconcile x y typ | matchesAny x && matchesAny y = ([x], [y]) 60 | reconcile x p typ | matchesAny x = (expand p typ, [p]) 61 | reconcile p x typ | matchesAny x = ([p], expand p typ) 62 | reconcile (Unit) (Unit) (One, _) = ([Unit], [Unit]) 63 | reconcile (Pair p1 p2) (Pair p1' p2') (Times t1 t2, env) = 64 | ([Pair v1 v2 | v1 <- r1, v2 <- r2], 65 | [Pair v1 v2 | v1 <- r1', v2 <- r2']) 66 | where 67 | (r1, r1') = reconcile p1 p1' (t1, env) 68 | (r2, r2') = reconcile p2 p2' (t2, env) 69 | reconcile (LeftE p1) (LeftE p2) (Plus t1 t2, env) = 70 | ([LeftE v | v <- r1], [LeftE v | v <- r2]) 71 | where (r1, r2) = reconcile p1 p2 (t1, env) 72 | reconcile (RightE p1) (RightE p2) (Plus t1 t2, env) = 73 | ([RightE v | v <- r1], [RightE v | v <- r2]) 74 | where (r1, r2) = reconcile p1 p2 (t2, env) 75 | reconcile (Constr c1 p1) (Constr c2 p2) (TName t, env) | c1 == c2 = 76 | let cs = lookup_exn t env in 77 | let t1 = lookup_exn c1 cs in 78 | let (r1, r2) = reconcile p1 p2 (t1, env) in 79 | ([Constr c1 v | v <- r1], 80 | [Constr c2 v | v <- r2]) 81 | reconcile _ _ _ = ([], []) 82 | 83 | -- errors 84 | data CoverageError 85 | = NoMatches String PVal 86 | | MultipleMatches String PVal 87 | 88 | reportErrors :: [CoverageError] -> IO () 89 | reportErrors [] = return () 90 | reportErrors (MultipleMatches msg p:ps) = 91 | do putStr $ "Error: " ++ msg ++ ": Multiple patterns match values of the form : " ++ (show p) ++ "\n" 92 | reportErrors ps 93 | reportErrors (NoMatches msg p:ps) = 94 | do putStr $ "Error: " ++ msg ++ ": No patterns match values of the form : " ++ (show p) ++ "\n" 95 | reportErrors ps 96 | 97 | -- check if two lists of patterns exactly cover each other 98 | covers :: String -> [PVal] -> [PVal] -> CurTyp -> [CoverageError] 99 | covers msg [] [] _ = [] 100 | covers msg [] ps@(p:_) _ = map (MultipleMatches msg) ps 101 | covers msg ps@(p:_) [] _ = map (NoMatches msg) ps 102 | covers msg (a:as) (b:bs) ct = trace_next (reconcile a b ct) 103 | where 104 | trace_covers as bs ct = 105 | if debug 106 | then trace ("| cover (" ++ show as ++ ") (" ++ show bs ++ ")") (covers msg as bs ct) 107 | else covers msg as bs ct 108 | trace_next vs = 109 | if debug 110 | then trace ("| next " ++ (show vs)) next vs 111 | else next vs 112 | next ([a], [b]) = trace_covers as bs ct 113 | next (a1:as1, b1:bs1) = trace_covers (a1:as1 ++ as) (b1:bs1 ++ bs) ct 114 | next (_, _) = 115 | if a < b 116 | then (NoMatches msg a):(covers msg as (b:bs) ct) 117 | else (MultipleMatches msg b):(covers msg (a:as) bs ct) 118 | 119 | -- check if a list of patterns are axhaustive for a type. 120 | exhaustive :: String -> [PVal] -> CurTyp -> [CoverageError] 121 | exhaustive context ps ct = 122 | let ps' = List.sort ps in 123 | let res = covers context [Var "_"] ps' ct in 124 | if debug 125 | then trace ("| Checking " ++ context ++ " : " ++ (show ps')) res 126 | else res 127 | 128 | extend :: [(Maybe LName, [PVal])] -> (Maybe LName, PVal) -> [(Maybe LName, [PVal])] 129 | extend [] (x, val) = [(x, [val])] 130 | extend ((x,ls):env) (x1, val1) 131 | | x == x1 = (x, val1:ls):env 132 | | otherwise = (x, ls):(extend env (x1, val1)) 133 | 134 | -- this only checks coverage of LHS and RHS clauses of each ISO 135 | -- at a minimum we need to type check each clause also. 136 | tProg :: [Def] -> [CoverageError] 137 | tProg defs = loop defs emptyEnv 138 | where 139 | emptyEnv = [] 140 | loop [] _ = [] 141 | loop ((DataTyp name args):defs) env = loop defs ((name, List.sort args):env) 142 | loop ((Import modname):defs) env = loop defs env -- ignoring imports for now 143 | loop ((Eval name val):defs) env = loop defs env -- ignoring the main 144 | loop ((Iso name params ityp labels clauses):defs) env = 145 | let types = packTypes ityp labels in 146 | (process name clauses types env (\(Clause lhs _) -> lhs) (\(ITyp t1 t2)->t1) "LHS") 147 | ++ (process name clauses types env (\(Clause _ rhs) -> rhs) (\(ITyp t1 t2)->t2) "RHS") 148 | ++ (loop defs env) 149 | classifyClauses clauses f = foldl (\env clause -> extend env (f clause)) [] clauses 150 | nameOf dir name (Just label) = dir ++ " of " ++ name ++ " $ " ++ label 151 | nameOf dir name (Nothing) = dir ++ " of " ++ name 152 | packTypes ityp labels = 153 | (Nothing, ityp):(map (\(lbl, typ) -> (Just lbl, ITyp typ typ)) labels) 154 | process name clauses types env fc ft dir = 155 | concatMap (\(lopt, cls) -> 156 | let str = nameOf dir name lopt in 157 | let typ = ft $ lookup_exn lopt types in 158 | exhaustive str cls (typ, env)) 159 | (classifyClauses clauses fc) 160 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Credit: 2 | Credit for design and original implementation of Theseus goes to 3 | Roshan P. James and Amr Sabry of Indiana University. This is my fork 4 | of their implementation, which I intend to keep as a pet project. 5 | 6 | The original project can be found [here](https://bitbucket.org/roshanjames/theseus). 7 | 8 | # Theseus, the programming language. 9 | 10 | Why create another programming language in this time and age? And why 11 | make such an obscure finicky one wherein it's not obvious how one can 12 | write a web server or an iphone app? Theseus exists due to a certain 13 | philosophical point of view on computation. What follows is a casual 14 | overview. 15 | 16 | The paradox of the Ship of Theseus was originally proposed by Plutarch 17 | in the setting of the ship that the Greek hero Theseus used for his 18 | adventures. Since the Athenians admired Theseus they took on the task 19 | of preserving the ship in his memory. Over time, as parts of the ship 20 | got spoiled, they replaced them with equivalent new parts. Thus the 21 | ship was always in good shape. 22 | 23 | However one day, many years later, someone makes the observation that 24 | the ship no longer had any original parts. The entirety of the ship 25 | had been replaced piece by piece. This raises the question: is this 26 | ship really still the ship of Theseus? 27 | 28 | And, if not, when does the change take place? When the first part is 29 | replaced? When the last one is replaced? When about half the parts are 30 | replaced? 31 | 32 | Further, to compound the question, Thomas Hobbes added the following 33 | corollary: Imagine a junk yard outside Athens where all the discarded 34 | parts of the ship had been collected. If the proprietor of the junk 35 | assembled the parts into a ship, which ship is now the real ship of 36 | Theseus? 37 | 38 | This is a philosophical paradox about the nature of equality and 39 | identity. The question also applies to people. Since we are constantly 40 | changing, cells and thought patterns continuously being replaced, is 41 | any person the same person they were some time ago? Can anyone ever 42 | not change? Is a lactose free, sugar free, gluten free cupcake still a 43 | cupcake? 44 | 45 | Our programming language is named Theseus because, like in the 46 | paradox, the main computation step involves replacing a value by an 47 | isomorphic value. Since isomorphic things really are the same, have we 48 | changed the value? And if not, what have we computed? Have we computed 49 | at all? As we keep doing these replacement in our program we will have 50 | transformed the value that was the input to the value that is the 51 | output. 52 | 53 | There are many answers to the paradox of the ship of Theseus. The 54 | obvious answers of saying either 'yes, it is the same ship' or 'no 55 | it's not' have their justifications. Other answers exist too. One is 56 | to say that the question is wrong and that it meaningless to ask this 57 | sort of question about identity. Like a river whose very nature is to 58 | flow and change from moment to moment, so is nature of the ship. Over 59 | time the ship changes, just like the river, and it is meaningless to 60 | ask if is the same ship. It is our flawed notion of time and identity 61 | that makes us assume that the ship is not like the river and to expect 62 | one to have static identity and the other one to not. 63 | 64 | Theseus owes its design to a certain philosophical point of view about 65 | computation. Turing machines and the lambda-calculus are abstract 66 | models of computation. They were invented by people as mental models 67 | of how computation may be expressed. These are meant to serve as 68 | conceptual entities and we may think of them as being free of physical 69 | constraints, i.e. it does not matter if you have the latest laptop, a 70 | whole data center or no computer at all, the ideas underlying the 71 | abstract models apply equally well. However there is something wrong 72 | with this view. 73 | 74 | Abstract models of computation are meant to apply to our physical 75 | reality. We might be constrained by the resources we have at hand to 76 | do some computations. For instance, we might not have enough memory to 77 | run some programs. However, we do expect that models are compatible 78 | with our physics. For example, if we imagined that each step of a 79 | Turing machine took only half the amount of time the previous step 80 | took to execute, after 2 units of time time all Turing machines would 81 | have observable results. Such a machine is impossible to build (except 82 | maybe in the movie Inception where you could fall asleep causing time 83 | to speed up in each recursive dream step). Its not just the difficulty 84 | of building it thats at issue here. This violates the our notion of 85 | space and time in a deep way. Futher it gives rise to issues in our 86 | mathemaics and formal logics since it resolves the halting problem. We 87 | think of such models of computations that violate physics merely as 88 | curiosities and not as modeling computation in the physical world. 89 | 90 | The line of work that Theseus comes from stems from the idea that 91 | abstract models of computation, must in their essence be compatible 92 | with our physics. Mordern physics at the level of quantum mechanics 93 | describes a universe where every fundamental action is reversible and 94 | fundamental quantities such as energy, matter and information are 95 | conserved. The notion of conservation of information stems from a line 96 | of thought originating from Maxwell's paradox of the "demon" that 97 | seemed to violate the Second law of Thermodynamics and its current 98 | accepted resolution set forth by Ralph Landauer. Landauer argued 99 | that the demon must do thermodynamic work to forget the information 100 | that its learns about the speed of each particle. This act of 101 | forgetting information implied that information should be treated as a 102 | physical quantity subject to conservation laws. In more recent years, 103 | Pasquele Malacaria and others wrote about the entropy of computation 104 | and Eric Lutz and others experimentally verified Landauer's 105 | principle. ("Maxwell's Demon 2" by Leff and Rex is a pretty good read 106 | on the general topic; the first part of the book is pretty accessible 107 | and the later part is largely a collection of historically relevant 108 | papers.) 109 | 110 | So the physics that Theseus is concerned with is this strange new 111 | physics where information is not longer a concept of the human mind, 112 | like love and peace, but a physical entity. This has happened to 113 | computation before; before Turing worked out that computation itself 114 | had a formal notion that can be cpatured by abstract computational 115 | models, computation itself was considered an activity of the human 116 | mind not subject to the rigors of mathematics and logic. 117 | 118 | The model of computation that was originally devised in this regard 119 | came out under the longish name of 'dagger symmetric traced bimonoidal 120 | categories'. The name was too long, was somewhat imprecise and didn't 121 | really say much at all. The underlying idea was that we could look for 122 | computation in the rules of equality. 123 | 124 | If every allowed operation is a transformation of one quantity for 125 | another equivalent quantity, then computation should preserve 126 | information. However, can we even compute like this? After all, our 127 | conventional models of computation allows us to do "logical or" and 128 | "logical and" reducing two bools into one bool. Changing the value of 129 | a variable means loosing the information in that variable 130 | forever. Conditional statements and loops seem to inherently be lossy 131 | operations because it is unclear how to execute them in reverse 132 | without knowing which banches were originally taken. And more 133 | importantly, in the words of Barry Mazur, when is one thing equal to 134 | some other thing? 135 | 136 | We settled on simplest notions of equality, those familiar from 137 | arithmetic. Rules like: 138 | 139 | ``` 140 | 0 + x = x 141 | x + y = y + x 142 | (x + y) + z = x + (y + z) 143 | 144 | 1 * x = x 145 | x * y = y * x 146 | (x * y) * z = x * (y * z) 147 | 148 | x * 0 = 0 149 | x * (y + z) = x * y + x * y 150 | 151 | if x = y and y = z, then x = z 152 | if x = y and w = z, then x + w = y + z 153 | if x = y and w = z, then x * w = y * z 154 | if x + y = x + z, then y = z 155 | ``` 156 | 157 | We then took the numbers represented by `x`, `y` etc to be a measure 158 | of the "amount" of information and we only allowed operation that 159 | corresponded to these equalities. Thus each operation preserved the 160 | amount of information. 161 | 162 | For a while it was unclear that what we had was even a model of 163 | computation, i.e. it took us a while to learn to express programs in 164 | it. Figuring out how to do the equivalent of a conditional took a long 165 | time in that setting. The resulting model of computation was one where 166 | every primitive operation was a sort of type isomorphism. When we add 167 | recursive types to the mix, the model becomes Turing 168 | complete. Programs in this early model were easier to represent as 169 | diagrams. Each program was essntially a complex wiring diagram where 170 | each wire had a type and process of "running" the program was the 171 | process of tracing the flow of particles through these wires. In the 172 | references below you can find lots of details about all this. 173 | 174 | ## A Gentle Introduction to Theseus 175 | 176 | While all of this worked out in theory, it was tedious constructing 177 | programs. For attempts of programming directly in the above model see 178 | [PDF](http://www.cs.indiana.edu/~sabry/papers/cat-rev.pdf), 179 | [PDF](http://dl.acm.org/citation.cfm?id=2103667&dl=ACM&coll=DL&CFID=370820997&CFTOKEN=65718506) 180 | and [PDF](http://link.springer.com/chapter/10.1007%2F978-3-642-36315-3_5). 181 | This was when Theseus happened and we realized that we could express 182 | the computations of the above information preserving model in a format 183 | that looked somewhat like a regular functional programming 184 | language. Much like the situation of replacing ship parts with other 185 | equivalent ship parts, Theseus computes by replacing values with 186 | equivalent values. 187 | 188 | All the programs in Theseus are reversible and the type system will 189 | prevent you from writing anything that isnt. You can program in 190 | Theseus without knowing anything about the body of theory that 191 | motivated it. 192 | 193 | ```haskell 194 | -- booleans 195 | data Bool = True | False 196 | 197 | -- boolean not 198 | iso not :: Bool <-> Bool 199 | | True <-> False 200 | | False <-> True 201 | ``` 202 | 203 | Theseus has algebraic data types. It has no GADTs or polymorphism yet, 204 | but those are boring and can be added later. For the purpose of this 205 | presentation I will pretend that we do have polymorphism though. The 206 | equivalent of functions in Theseus are the things called `iso`. The 207 | `iso` called `not` maps `Bool` to `Bool`. In a coventional functional 208 | language the part on the left hand side of the `<->` is called the 209 | pattern and the part on the right is called the expression. In 210 | Theseus, both the LHS and the RHS of the `<->` are called patterns. In 211 | Theseus patterns and expressions are the same thing. 212 | 213 | Now here is the interesting bit: The patterns on the right hand side 214 | and the patterns on the left hand side should entirely cover the 215 | type. On the RHS we have 216 | 217 | ``` 218 | :: Bool <-> 219 | | True <-> 220 | | False <-> 221 | ``` 222 | 223 | which do indeed cover all the cases of the type `Bool`. On the LHS we 224 | have 225 | 226 | ``` 227 | :: <-> Bool 228 | | <-> False 229 | | <-> True 230 | ``` 231 | 232 | which also covers the type bool. Patterns cover a type, when every 233 | value of the type is matched by one and only one pattern. So the 234 | following single pattern does not cover the type `Bool` since there 235 | the value `True` is unmatched. 236 | 237 | ``` 238 | :: Bool 239 | | False 240 | ``` 241 | 242 | The following also does not cover the type `Bool` since the value 243 | `False` can be matched by both patterns. Here the variable `x` is a 244 | pattern that matches any value. 245 | 246 | ``` 247 | :: Bool 248 | | False 249 | | x 250 | ``` 251 | 252 | The following does cover the type `Bool`: 253 | 254 | ```haskell 255 | :: Bool 256 | | x 257 | ``` 258 | 259 | Here is another type definition and another `iso`: 260 | 261 | ```haskell 262 | data Num = Z | S Num 263 | 264 | iso parity :: Num * Bool <-> Num * Bool 265 | | n, x <-> lab $ n, Z, x 266 | | lab $ S n, m, x <-> lab $ n, S m, not x 267 | | lab $ Z, m, x <-> m, x 268 | where lab :: Num * Num * Bool 269 | ``` 270 | 271 | Here the `lab` is called a label and labels are followed by a `$` 272 | sign. All the patterns that have no label should cover the type of the 273 | corresponding side of the function. 274 | 275 | ```haskell 276 | :: Num * Bool <-> Num * Bool 277 | | n, x <-> 278 | | <-> 279 | | <-> m, x 280 | ``` 281 | 282 | Here `n, x` on the LHS do cover the type `Num * Bool`. The variable 283 | `n` matches any `Num` and the variable `x` matches any `Bool`. The RHS 284 | is covered similalry by `m, x`. The label `lab` has the type `Num * 285 | Num * Bool` and the intention is that the patterns of the label on the 286 | LHS and the RHS must each should cover the type of label. 287 | 288 | ```haskell 289 | :: Num * Num * Bool <-> 290 | | <-> 291 | | lab $ S n, m, x <-> 292 | | lab $ Z, m, x <-> 293 | ``` 294 | 295 | On the LHS we see that every value of the type `Num * Num * Bool` is 296 | matched by one of the two patterns. The same applies to the RHS 297 | patterns of the `lab` label. 298 | 299 | Labels are a way of doing loops. When a pattern on the LHS results in 300 | a label application on the RHS, control jumps to the LHS again and we 301 | try to match the resulting value against a pattern of teh label on the 302 | RHS. This continues till we end up in a non-labelled pattern on the 303 | right. So lets trace the execution of `parity` when we given it the 304 | input `S S S Z, True` of the type `Num * Bool`. 305 | 306 | ``` 307 | S S S Z, True -> lab $ S S S Z, Z, True 308 | lab $ S S S Z, Z, True -> lab $ S S Z, S Z, False 309 | lab $ S S Z, S Z, False -> lab $ S Z, S S Z, True 310 | lab $ S Z, S S Z, True -> lab $ Z, S S S Z, False 311 | lab $ Z, S S S Z, False -> S S S Z, False 312 | ``` 313 | 314 | So parity of `S S S Z, True` applied `not` to `True` three times, 315 | resulting in `S S S Z, False`. Here is one more `iso`: 316 | 317 | ```haskell 318 | iso add1 :: Num <-> Num 319 | | x <-> ret $ inR x 320 | | lab $ Z <-> ret $ inL () 321 | | lab $ S n <-> lab $ n 322 | | ret $ inL () <-> Z 323 | | ret $ inR n <-> S n 324 | where ret :: 1 + Num 325 | lab :: Num 326 | ``` 327 | 328 | This `iso` has two labels `lab` and `ret` and one can verify that the 329 | same coverage contraints hold. Here the type `1 + Num` would be 330 | written as `Either () Num` in Haskell, i.e. `1` is the unit type that 331 | has only one value. The value is denoted by `()` and is read as 332 | "unit". One can run `add1` on any `n` of type `Num` and verify that 333 | we get `S n` back as the result. 334 | 335 | Now here is the next interesting bit: For any Theseus iso, we can get 336 | its inverse iso by simply swapping the LHS and RHS of the 337 | clauses. This also get at the essence of the idea of information 338 | preservation: if we have a program and an input to it, we can run the 339 | input through the program and get the program and the output. Using 340 | the program and the output, we can recover the input. 341 | 342 | Some programs may not terminate on some inputs and in such cases it is 343 | meaningless to ask about reverse execution. Given that Theseus is a 344 | Turing complete language it is not surprising that some executions are 345 | non-terminating. What however may be surprising that information 346 | preservation holds in the presence of non-termination. 347 | 348 | Here the reverse execution of `add1`, lets call it `sub1` does indeed 349 | diverge on the input `Z`. For every other value of the form `S n` it 350 | returns `n`. Its worth tracing this execution and thinking about why 351 | this comes about in Theseus. 352 | 353 | Theseus also supports the notion of parametrizing an iso with another 354 | one. For example: 355 | 356 | ```haskell 357 | iso if :: then:(a <-> b) -> else:(a <-> b) -> (Bool * a <-> Bool * b) 358 | | True, x <-> True, then x 359 | | False, x <-> False, else x 360 | ``` 361 | 362 | Here the iso called `if` takes two arguments, `then` and `else`, and 363 | decides which one to call depending on the value of the boolean 364 | argument. Theseus doesn't really have higher-order or first-class 365 | functions. The parameter isos are expected to be fully inlined before 366 | transofrmation of the value starts. Theseus will only run a value 367 | `v:t1` on an iso of type `t1 <-> t2`, and the `->` types in the above 368 | should be fully instantiated away. 369 | 370 | Running `if ~then:add1 ~else:sub1` on the input `True, S Z` gives us 371 | the output `True, S S Z` and running the same function with input 372 | `False, S Z` gives us `False, Z`. The syntax of labelled arguments is 373 | similar to that used by OCaml. 374 | 375 | Reverse evaluation works by flipping LHS and RHS in the same way as 376 | before. However, you wonder, what happens when there is a function 377 | call in a left hand side pattern? Here is a simple example: 378 | 379 | ```haskell 380 | iso adjoint :: f:(a <-> b) -> (b <-> a) 381 | | f x <-> x 382 | ``` 383 | 384 | Here is the interesting bit again: An iso call on the left side 385 | pattern is the dual of an iso call on the right hand side. When `f x` 386 | appears on the right we know that we have an `x` in hand and the 387 | result we want is the result of the application `f x`. When `f x` 388 | appears on the left it means that we have the result of the 389 | application `f x` and we want to determine `x`. We can infer the value 390 | of `x` by tracing the flow of the given value backwards through `f` 391 | and the result of the this backward execution of `f` is `x`. We can do 392 | this because isos represent information preserving transformations. 393 | 394 | So if we had `add1` and its inverse `sub1`, then `adjoint ~f:add1` is 395 | equivalent to `sub1` and `adjoint ~f:(adjoint ~f:add1)` is equivalent 396 | to `add1`. 397 | 398 | Some references for additional reading. 399 | 400 | * Roshan P. James and Amr Sabry. Theseus: A High Level Language for 401 | Reversible Computing. Work-in-progress report in the Conference on 402 | Reversible Computation, 2014. 403 | [PDF](http://www.cs.indiana.edu/~sabry/papers/theseus.pdf) 404 | 405 | This is the paper that introduces Theseus. The syntax of Theseus as 406 | presented here differs somewhat from what is in the paper, but most 407 | of the these syntactic differences are superficial and largely an 408 | artifact of the difficulty of having Parsec understand location 409 | sensitive syntax. Please see below for some notes on how the 410 | implementation of Theseus differs from that in the paper. For more 411 | of the academically relevant citations, you can chase the references 412 | at the end of the paper. 413 | 414 | * Harvey Leff and Andrew F. Rex. Maxwell's Demon 2 Entropy, Classical 415 | and Quantum Information, Computing. CRC Press, 2002. 416 | [Amazon](http://www.amazon.com/Maxwells-Entropy-Classical-Information-Computing/dp/0750307595) 417 | 418 | This book is a survey of about a century and a half of thought about 419 | Maxwell's demon with significant focus on Landauer's principle and 420 | the work surrounding it. 421 | 422 | # Running Theseus Programs 423 | 424 | For now Theseus does not have a well developed REPL and is still work 425 | in progress. We use the Haskell REPL to run it. Roughly: 426 | 427 | ```shell 428 | $ cd examples/ 429 | $ ghci ../src/Theseus.hs 430 | [...] 431 | Ok, modules loaded: Theseus. 432 | *Theseus> run "peano.ths" 433 | [...] 434 | -- {Loading bool.ths} 435 | Typechecking... 436 | Evaluating... 437 | eval toffoli True, (True, True) = True, (True, False) 438 | eval toffoli True, (True, False) = True, (True, True) 439 | [...] 440 | *Theseus> 441 | ``` 442 | 443 | Like the `run` function above, we also have `echo` which parses the 444 | given file and echoes it on screen and `echoT` which prints out all 445 | the definitions after parsing the given file and inlining all the 446 | imports. `echoT` also checks for violations of non-overlapping and 447 | exhaustive pattern coverage and reports these. For instance: 448 | 449 | ```shell 450 | *Theseus> echoT "test.ths" 451 | [...] 452 | iso f :: Bool <-> Bool 453 | | True <-> False 454 | | x <-> True 455 | 456 | Error: LHS of f: Multiple patterns match values of the form : True 457 | *Theseus> 458 | ``` 459 | 460 | # Differences between the implementation and the RC 2014 paper 461 | 462 | The current implementation of Theseus is of experimental status. There 463 | are many niceties and tools required for a proper programming language 464 | that are not available as yet. When editing Theseus programs turn on 465 | Haskell mode in Emacs and that tends to work out ok. 466 | 467 | Here are some notable differences from that of the paper. 468 | 469 | * The type checker is not yet implmented. However, Theseus will check 470 | strict coverage and complain if there are clauses that are 471 | overlapping or non-exhaustve. It does not check types of the 472 | variables or that they are used exaclty once. The strict coverage of 473 | function call contexts is also not checked. 474 | 475 | * We need to specify a keyword called `iso` when defining maps. 476 | 477 | * The import and file load semantics currently creates one flat list 478 | of definitions. This can violate the expected static scope of top 479 | level definitions. 480 | 481 | * The paper allows for dual definitions as shown below. The current 482 | implementation does not handle simulataneous definition of the 483 | inverse function `:: sub1` 484 | 485 | ``` 486 | add1 :: Num <-> Num :: sub1 487 | | ... 488 | ``` 489 | 490 | * All constructors take only one type or value arugment, similar to 491 | OCaml constructor definitions. Hence one has to write 492 | 493 | ``` 494 | data List = E | Cons (Num * List) 495 | 496 | f :: ... 497 | | ... Cons (n, ls) ... 498 | ``` 499 | 500 | instead of 501 | ``` 502 | data List = E | Cons Num List 503 | 504 | f :: ... 505 | | ... (Cons n ls) ... 506 | ``` 507 | 508 | --------------------------------------------------------------------------------