├── setoidtt ├── flatparse │ ├── scalabench │ │ ├── project │ │ │ └── build.properties │ │ ├── build.sbt │ │ └── bench.scala │ ├── stack.yaml │ ├── rustbench │ │ ├── Cargo.toml │ │ └── benches │ │ │ └── bench.rs │ ├── bench │ │ ├── FPI.hs │ │ ├── Parsec.hs │ │ ├── Attoparsec.hs │ │ ├── FPIO.hs │ │ ├── FPEF.hs │ │ ├── Megaparsec.hs │ │ ├── Main.hs │ │ └── FP.hs │ ├── package.yaml │ └── Old │ │ └── Switch.hs ├── main │ └── Main.hs ├── src │ ├── Cxt.hs │ ├── StringTrie │ │ └── Trie.hs │ ├── FNV164.hs │ ├── Cxt │ │ ├── Types.hs │ │ └── Extension.hs │ ├── EvalInCxt.hs │ ├── LvlSet.hs │ ├── ElabState.hs │ ├── Exceptions.hs │ ├── Serialization │ │ └── Internal.hs │ ├── Presyntax.hs │ ├── Lexer.hs │ ├── Common.hs │ ├── Syntax.hs │ └── Values.hs ├── primdata │ ├── stack.yaml │ ├── Data │ │ ├── Array │ │ │ ├── UndefElem.hs │ │ │ ├── FM.hs │ │ │ ├── UI.hs │ │ │ ├── LM.hs │ │ │ ├── UM.hs │ │ │ ├── SM.hs │ │ │ └── FI.hs │ │ ├── Ref │ │ │ ├── U.hs │ │ │ ├── L.hs │ │ │ ├── F.hs │ │ │ └── UU.hs │ │ ├── Unlifted.hs │ │ ├── MachDeps.hs │ │ └── Flat.hs │ ├── IO.hs │ └── package.yaml ├── dynamic-array │ ├── stack.yaml │ ├── package.yaml │ └── Data │ │ └── Array │ │ └── Dynamic │ │ ├── U.hs │ │ └── L.hs ├── stack.yaml ├── bench │ └── Bench.hs ├── LICENSE ├── package.yaml └── notes.txt ├── README.md ├── .gitmodules ├── experiments ├── serialization-bench │ ├── stack.yaml │ ├── package.yaml │ ├── Serialize.hs │ ├── SerializeStrict.hs │ └── Main.hs ├── Inspection2.hs ├── THPre.hs ├── TextOps.hs ├── ActuallyUnsafeCoercion.hs ├── TH.hs ├── SumPacking.hs ├── Inspection.hs ├── Notes.hs ├── Tel.agda ├── MonoHaskell.hs ├── TypedEnv.hs ├── Cmm.hs ├── CompactSerialize.hs ├── IOBench.hs └── CachedEval.hs ├── proto ├── stack.yaml ├── EvalCxt.hs ├── Notes.agda ├── package.yaml ├── examples │ ├── CatCat.stt │ ├── Nats.stt │ ├── Impredicative.stt │ ├── Notes.stt │ └── setoidtt-impl-intro-notes.txt ├── Zonk.hs ├── ElabState.hs ├── Impredicative.agda ├── Errors.hs ├── Pretty.hs ├── Parser.hs ├── Main.hs └── README.md └── .gitignore /setoidtt/flatparse/scalabench/project/build.properties: -------------------------------------------------------------------------------- 1 | sbt.version=1.3.10 2 | -------------------------------------------------------------------------------- /setoidtt/main/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | main :: IO () 5 | main = pure () 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Prototype implementations of systems based on setoid type theory. 3 | 4 | Working small prototype: [proto](proto) 5 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "inspection-testing"] 2 | path = inspection-testing 3 | url = https://github.com/AndrasKovacs/inspection-testing 4 | -------------------------------------------------------------------------------- /experiments/serialization-bench/stack.yaml: -------------------------------------------------------------------------------- 1 | 2 | resolver: lts-16.11 3 | 4 | packages: 5 | - . 6 | 7 | extra-deps: 8 | - compact-0.2.0.0 9 | -------------------------------------------------------------------------------- /setoidtt/flatparse/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.19 2 | 3 | packages: 4 | - . 5 | 6 | ghc-options: 7 | "$everything": -split-sections 8 | -------------------------------------------------------------------------------- /setoidtt/src/Cxt.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Cxt (module Cxt.Types, module Cxt.Extension) where 4 | 5 | import Cxt.Types 6 | import Cxt.Extension 7 | -------------------------------------------------------------------------------- /setoidtt/primdata/stack.yaml: -------------------------------------------------------------------------------- 1 | 2 | resolver: lts-16.11 3 | 4 | packages: 5 | - . 6 | 7 | ghc-options: 8 | "$everything": -split-sections 9 | -------------------------------------------------------------------------------- /experiments/Inspection2.hs: -------------------------------------------------------------------------------- 1 | 2 | module Inspection2 where 3 | 4 | foo :: Int -> Int -> Int 5 | foo n m | even n = 0 6 | | otherwise = m 7 | -------------------------------------------------------------------------------- /proto/stack.yaml: -------------------------------------------------------------------------------- 1 | 2 | resolver: lts-15.9 3 | 4 | packages: 5 | - . 6 | 7 | # build: 8 | # library-profiling: true 9 | # executable-profiling: true 10 | -------------------------------------------------------------------------------- /setoidtt/dynamic-array/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.19 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - ../primdata 8 | 9 | ghc-options: 10 | "$everything": -split-sections 11 | -------------------------------------------------------------------------------- /experiments/THPre.hs: -------------------------------------------------------------------------------- 1 | {-# language TemplateHaskell #-} 2 | 3 | module THPre where 4 | 5 | import Language.Haskell.TH 6 | 7 | foo = [|| 10 + 300 ||] 8 | 9 | -- printf :: String -> Q Exp 10 | -- printf "" = [| \x -> 11 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/UndefElem.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.UndefElem where 3 | 4 | import GHC.Stack 5 | 6 | undefElem :: forall a. HasCallStack => a 7 | undefElem = error "undefined element" 8 | {-# noinline undefElem #-} 9 | -------------------------------------------------------------------------------- /setoidtt/stack.yaml: -------------------------------------------------------------------------------- 1 | 2 | resolver: lts-16.19 3 | 4 | packages: 5 | - . 6 | 7 | extra-deps: 8 | - ./primdata 9 | - ./dynamic-array 10 | - ./flatparse 11 | - ../inspection-testing 12 | 13 | ghc-options: 14 | "$everything": -split-sections 15 | -------------------------------------------------------------------------------- /setoidtt/primdata/IO.hs: -------------------------------------------------------------------------------- 1 | 2 | module IO (IO(..), runIO, unIO) where 3 | 4 | import GHC.Types 5 | import GHC.Prim 6 | import GHC.Magic 7 | 8 | runIO :: IO a -> a 9 | runIO (IO f) = runRW# (\s -> case f s of (# _, a #) -> a) 10 | {-# inline runIO #-} 11 | 12 | unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) 13 | unIO (IO f) = f 14 | {-# inline unIO #-} 15 | -------------------------------------------------------------------------------- /setoidtt/flatparse/rustbench/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "rustbench" 3 | version = "0.1.0" 4 | authors = ["kutta "] 5 | edition = "2018" 6 | 7 | # See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html 8 | 9 | [dependencies] 10 | nom = "5" 11 | bencher = "0.1.5" 12 | 13 | [[bench]] 14 | name = "bench" 15 | harness = false 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.agdai 3 | *.aux 4 | *.log 5 | *.out 6 | *.bbl 7 | *.blg 8 | *.fdb_latexmk 9 | *.fls 10 | *.toc 11 | *.nav 12 | *.snm 13 | *.vrb 14 | *.vtc 15 | *.ptb 16 | *.bbl 17 | comment.cut 18 | target/ 19 | 20 | *.hi 21 | *.o 22 | ./dist 23 | *# 24 | TAGS 25 | .stack-work/ 26 | *.cabal 27 | *.agdai 28 | *.vo 29 | *.aux 30 | *.glob 31 | *.lock 32 | *.dump-simpl 33 | *.dump-cmm 34 | *.dump-stg 35 | -------------------------------------------------------------------------------- /setoidtt/flatparse/scalabench/build.sbt: -------------------------------------------------------------------------------- 1 | 2 | libraryDependencies += "com.lihaoyi" %% "fastparse" % "2.2.2" 3 | 4 | resolvers += "Sonatype OSS Snapshots" at 5 | "https://oss.sonatype.org/content/repositories/releases" 6 | 7 | libraryDependencies += "com.storm-enroute" %% "scalameter" % "0.18" 8 | 9 | testFrameworks += new TestFramework("org.scalameter.ScalaMeterFramework") 10 | 11 | parallelExecution in Test := false 12 | -------------------------------------------------------------------------------- /setoidtt/bench/Bench.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Parser 5 | import Paths_setoidtt 6 | import Presyntax 7 | 8 | topLength :: TopLevel -> Int 9 | topLength = go 0 where 10 | go acc Nil = acc 11 | go acc (Define _ _ _ t) = go (acc + 1) t 12 | go acc (Postulate _ _ t) = go (acc + 1) t 13 | 14 | main :: IO () 15 | main = do 16 | path <- getDataFileName "bench/parse01.stt" 17 | res <- parseFile path 18 | print $ topLength res 19 | -------------------------------------------------------------------------------- /experiments/TextOps.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings, BangPatterns #-} 2 | 3 | module TextOps where 4 | 5 | import Data.Text 6 | import Control.Monad 7 | 8 | -- Text is crap for fast parsing, just look at the core.. 9 | foo :: Text -> Bool 10 | foo t = Data.Text.take 3 t == "foo" 11 | 12 | -- foo :: Text -> Maybe () 13 | -- foo t = do 14 | -- (c, t) <- uncons t 15 | -- guard (c == 'f') 16 | -- (c, t) <- uncons t 17 | -- guard (c == 'o') 18 | -- (c, t) <- uncons t 19 | -- guard (c == 'o') 20 | -- pure () 21 | -------------------------------------------------------------------------------- /setoidtt/src/StringTrie/Trie.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -Wno-unused-imports #-} 2 | 3 | module StringTrie.Trie where 4 | 5 | import Data.Char 6 | import Data.Bits 7 | import Data.Word 8 | 9 | newtype Prefix = Prefix Int 10 | 11 | instance Show Prefix where 12 | show = undefined 13 | 14 | data Node a = Node { 15 | _prefix :: Prefix, 16 | _value :: a, 17 | _child :: Trie a, 18 | _next :: Trie a 19 | } 20 | deriving Show 21 | 22 | data Trie a 23 | = Zero 24 | | One {-# unpack #-} (Node a) 25 | | Two {-# unpack #-} (Node a) {-# unpack #-} (Node a) 26 | deriving Show 27 | -------------------------------------------------------------------------------- /experiments/ActuallyUnsafeCoercion.hs: -------------------------------------------------------------------------------- 1 | {-# language MagicHash, UnboxedTuples, TypeApplications #-} 2 | 3 | import GHC.Prim 4 | import GHC.Types 5 | import GHC.Magic 6 | 7 | seq' :: a -> b -> b 8 | seq' a b = seq a b 9 | {-# noinline seq' #-} 10 | 11 | main :: IO () 12 | main = do 13 | let arr :: ByteArray# 14 | arr = runRW# $ \s -> case newByteArray# 0# s of 15 | (# s, marr #) -> case unsafeFreezeByteArray# marr s of 16 | (# s, arr #) -> arr 17 | arr' :: Any @(TYPE 'LiftedRep) 18 | arr' = unsafeCoerce# arr 19 | 20 | print $ seq' arr' True -- throws RTS exception 21 | -------------------------------------------------------------------------------- /setoidtt/src/FNV164.hs: -------------------------------------------------------------------------------- 1 | 2 | module FNV164 where 3 | 4 | import qualified Data.ByteString as B 5 | import qualified Data.ByteString.Internal as B 6 | import GHC.ForeignPtr 7 | import GHC.Exts 8 | 9 | fnv164 :: B.ByteString -> Int -> Int 10 | fnv164 (B.PS (ForeignPtr ptr _) (I# offset) (I# len)) (I# salt) = let 11 | go :: Addr# -> Addr# -> Int# -> Int# 12 | go ptr end hash = case eqAddr# ptr end of 13 | 1# -> hash 14 | _ -> go (plusAddr# ptr 1#) end 15 | (xorI# (hash *# 1099511628211#) (indexInt8OffAddr# ptr 0#)) 16 | start = plusAddr# ptr offset 17 | end = plusAddr# start len 18 | in I# (go start end salt) 19 | -------------------------------------------------------------------------------- /experiments/TH.hs: -------------------------------------------------------------------------------- 1 | {-# language TemplateHaskell #-} 2 | 3 | import Language.Haskell.TH 4 | import THPre 5 | 6 | import Control.Monad 7 | 8 | f = $(do 9 | nm1 <- newName "x" 10 | let nm2 = mkName "x" 11 | return (LamE [VarP nm1] (LamE [VarP nm2] (VarE nm1))) 12 | ) 13 | 14 | 15 | bar = $$( foo ) 16 | 17 | -- tmap :: Int -> Int -> Q Exp 18 | tmap i n = do 19 | f <- newName "f" 20 | as <- replicateM n (newName "a") 21 | lamE [varP f, tupP (map varP as)] $ 22 | tupE [ if i == i' 23 | then [| $(varE f) $a |] 24 | else a 25 | | (a,i') <- map varE as `zip` [1..] ] 26 | -------------------------------------------------------------------------------- /experiments/SumPacking.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language UnboxedTuples, UnboxedSums, MagicHash, Strict, BangPatterns #-} 3 | {-# options_ghc -fno-full-laziness #-} 4 | 5 | module Main where 6 | 7 | import GHC.Prim 8 | import GHC.Types 9 | 10 | 11 | i16 :: Int -> Int16# 12 | i16 (I# x) = narrowInt16# x 13 | {-# inline i16 #-} 14 | 15 | 16 | data Test = Nil | Cons Int16# Int16# Int16# Int16# Test 17 | data Test2 = Nil2 | Cons2 (# (# Int16#, Int16#, Int16#, Int16# #) | Int16# #) Test 18 | 19 | main :: IO () 20 | main = do 21 | print (I# (closureSize# (Cons (i16 0) (i16 0) (i16 0) (i16 0) Nil))) 22 | print (I# (closureSize# (Cons2 (# (# (i16 0), (i16 0), (i16 0), (i16 0) #) | #)Nil))) 23 | -------------------------------------------------------------------------------- /proto/EvalCxt.hs: -------------------------------------------------------------------------------- 1 | 2 | module EvalCxt 3 | (eval, force, quote, Eval.forceU, Eval.vProj1, Eval.vProj2, Eval.vApp, vEq, 4 | Eval.vAppSE, Eval.vAppSI, Eval.vAppPE, Eval.vAppPI) 5 | where 6 | 7 | import Lens.Micro.Platform 8 | 9 | import Types 10 | import qualified Evaluation as Eval 11 | 12 | eval :: Dbg => Cxt -> Tm -> Val 13 | eval cxt = Eval.eval (cxt^.vals) (cxt^.len) 14 | {-# inline eval #-} 15 | 16 | force :: Cxt -> Val -> Val 17 | force cxt = Eval.force (cxt^.len) 18 | {-# inline force #-} 19 | 20 | quote :: Cxt -> Val -> Tm 21 | quote cxt = Eval.quote (cxt^.len) 22 | {-# inline quote #-} 23 | 24 | vEq :: Dbg => Cxt -> Val -> Val -> Val -> Val 25 | vEq cxt = Eval.vEq (cxt^.len) 26 | {-# inline vEq #-} 27 | -------------------------------------------------------------------------------- /experiments/Inspection.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language TemplateHaskell, MagicHash #-} 3 | 4 | module Main where 5 | 6 | import Test.Inspection 7 | import Data.Maybe 8 | import GHC.Exts 9 | import System.IO.Unsafe 10 | import Inspection2 (foo) 11 | 12 | lhs, rhs :: (a -> b) -> Maybe a -> Bool 13 | lhs f x = isNothing (fmap f x) 14 | rhs f Nothing = True 15 | rhs f (Just _) = False 16 | 17 | fac :: Int -> Int 18 | fac 0 = 1 19 | fac n = n * foo n (fac (n - 1)) 20 | 21 | testFac :: Int# -> Int# 22 | testFac n = case fac (I# n) of I# n -> n 23 | 24 | test1 = $(inspectTest $ doesNotUse 'testFac 'I#) 25 | 26 | -- inspect $ coreOf 'testFac 27 | 28 | main :: IO () 29 | main = case test1 of 30 | Failure msg -> putStrLn msg 31 | Success msg -> putStrLn msg 32 | -------------------------------------------------------------------------------- /experiments/Notes.hs: -------------------------------------------------------------------------------- 1 | {-# language MagicHash, BangPatterns, UnboxedTuples, Strict, TemplateHaskell #-} 2 | 3 | module Notes where 4 | 5 | import GHC.Prim 6 | import GHC.Types 7 | 8 | 9 | f :: Int -> Int 10 | f n = n + 2000 11 | {-# noinline f #-} 12 | 13 | g :: Int -> [Int] 14 | g 0 = [] 15 | g n = ((:) $! f (f (f n))) $! g (n - 1) 16 | -- fact :: Int -> Bool -> Int 17 | -- fact 0 b = if b then 1 else 2 18 | -- fact n b = n * fact (n - 1) b 19 | 20 | -- test1 :: (Int -> Int) -> Int -> Int 21 | -- test1 f n = f (n + 100 + 100) 22 | 23 | -- test2 :: Int -> Int 24 | -- test2 n = test1 (flip fact False) (n + 1) 25 | 26 | -- test3 :: (Int -> Int -> Int) -> (Int -> Int) -> Int -> Int 27 | -- test3 g f n = test2 n 28 | 29 | -- data Pair a b = Pair a b 30 | -- test4 f x = Pair (f x) (f x) 31 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/FPI.hs: -------------------------------------------------------------------------------- 1 | 2 | module FPI where 3 | 4 | import Old.FlatParseIndent 5 | 6 | ws = manyTok_ ($(char ' ') $(char '\n')) 7 | open = $(char '(') >> ws 8 | close = $(char ')') >> ws 9 | 10 | ident = do 11 | i <- ask 12 | j <- get 13 | someTok_ (satisfyA isLatinLetter) >> ws 14 | if i == j then pure () else empty 15 | 16 | sexp = br open (some_ sexp >> close) ident 17 | src = sexp >> eof 18 | runSexp = runParser src 19 | 20 | longw = $(string "thisisalongkeyword") 21 | longws = someTok_ (longw >> ws) >> eof 22 | runLongws = runParser longws 23 | 24 | numeral = someTok_ (satisfyA \c -> '0' <= c && c <= '9') >> ws 25 | comma = $(char ',') >> ws 26 | numcsv = numeral >> manyBr_ comma numeral >> eof 27 | runNumcsv = runParser numcsv 28 | -------------------------------------------------------------------------------- /experiments/Tel.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | open import Data.Unit 4 | open import Data.Product 5 | open import Function 6 | 7 | data Tel : Set where 8 | ∙ : Tel 9 | _▶_ : (A : Set) → (A → Tel) → Tel 10 | infixl 3 _▶_ 11 | 12 | -- TelElim : 13 | 14 | -- Cat = Σ(Obj : Set, Mor : Obj → Obj → Set, id: {i} → Mor i i,.....) 15 | 16 | -- Universe polymorphism! 17 | -- Tel i → U i 18 | 19 | 20 | -- (∀ {i}(Γ : Tel i) → U (f Γ)) 21 | 22 | El : Tel → Set 23 | El ∙ = ⊤ 24 | El (A ▶ Γ) = Σ A (El ∘ Γ) 25 | 26 | infixr 4 _++_ 27 | _++_ : (Γ : Tel) → (El Γ → Tel) → Tel 28 | ∙ ++ Δ = Δ tt 29 | (A ▶ Γ) ++ Δ = A ▶ λ a → Γ a ++ (λ γ → Δ (a , γ)) 30 | 31 | pair : ∀ {Γ}{Δ : El Γ → Tel}(t : El Γ) → El (Δ t) → El (Γ ++ Δ) 32 | pair {∙} t u = u 33 | pair {A ▶ Γ} (t₀ , t₁) u = t₀ , pair t₁ u 34 | -------------------------------------------------------------------------------- /experiments/serialization-bench/package.yaml: -------------------------------------------------------------------------------- 1 | 2 | name: serialization-bench 3 | version: 0.1.0.0 4 | # license: BSD2 5 | category: Language 6 | description: "serialization benchmarks" 7 | 8 | ghc-options: 9 | - -Wall 10 | - -Wno-name-shadowing 11 | - -Wno-missing-signatures 12 | - -Wno-unused-do-bind 13 | - -Wno-unused-matches 14 | - -Wno-partial-type-signatures 15 | - -Wno-type-defaults 16 | - -Wno-missing-pattern-synonym-signatures 17 | - -O2 18 | - -fllvm 19 | - -rtsopts 20 | - -ddump-simpl 21 | - -dsuppress-all 22 | - -dno-suppress-type-signatures 23 | - -ddump-to-file 24 | - -ddump-stg 25 | - -ddump-cmm 26 | 27 | dependencies: 28 | - base 29 | - binary 30 | - bytestring 31 | - compact 32 | - persist 33 | - time 34 | - ghc-prim 35 | - gauge 36 | 37 | executables: 38 | serialization-bench: 39 | source-dirs: 40 | - . 41 | main: Main.hs 42 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/Parsec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Parsec (runSexp, runLongws, runNumcsv) where 3 | 4 | import Text.Parsec 5 | import Text.Parsec.ByteString 6 | 7 | isLatinLetter :: Char -> Bool 8 | isLatinLetter c = ('A' <= c && c <= 'Z') || ('a' <= c && c <= 'z') 9 | 10 | ws :: Parser () 11 | ws = skipMany (satisfy \c -> c == ' ' || c == '\n') 12 | open = char '(' >> ws 13 | close = char ')' >> ws 14 | ident = skipMany1 (satisfy isLatinLetter) <* ws 15 | sexp = (open *> skipMany1 sexp <* close) <|> ident 16 | runSexp = parse sexp "" 17 | 18 | longw = string "thisisalongkeyword" 19 | longws = skipMany1 (longw *> ws) <* eof 20 | runLongws = parse longws "" 21 | 22 | numeral = skipMany1 (satisfy \c -> '0' <= c && c <= '9') >> ws 23 | comma = char ',' >> ws 24 | numcsv = numeral >> skipMany1 (comma >> numeral) >> eof 25 | runNumcsv = parse numcsv "" 26 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/Attoparsec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Attoparsec (runSexp, runLongws, runNumcsv) where 3 | 4 | import Control.Applicative 5 | import Data.Attoparsec.ByteString.Char8 6 | 7 | isLatinLetter :: Char -> Bool 8 | isLatinLetter c = ('A' <= c && c <= 'Z') || ('a' <= c && c <= 'z') 9 | 10 | ws = skipMany (satisfy \c -> c == ' ' || c == '\n') 11 | open = char '(' >> ws 12 | close = char ')' >> ws 13 | ident = skipMany1 (satisfy isLatinLetter) <* ws 14 | sexp = (open *> skipMany1 sexp <* close) <|> ident 15 | runSexp = parseOnly sexp 16 | 17 | longw = string "thisisalongkeyword" 18 | longws = skipMany1 (longw *> ws) <* endOfInput 19 | runLongws = parseOnly longws 20 | 21 | numeral = skipMany1 (satisfy \c -> '0' <= c && c <= '9') >> ws 22 | comma = char ',' >> ws 23 | numcsv = numeral >> skipMany1 (comma >> numeral) >> endOfInput 24 | runNumcsv = parseOnly numcsv 25 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/FPIO.hs: -------------------------------------------------------------------------------- 1 | 2 | module FPIO 3 | ( 4 | runSexp, 5 | runLongws, 6 | runNumcsv 7 | ) 8 | where 9 | 10 | import Old.FlatParseIO 11 | 12 | ws = many_ do 13 | ensureBytes# 1 14 | c <- scanAny8# 15 | case c of 16 | 32 -> pure () 17 | 10 -> pure () 18 | _ -> empty 19 | 20 | open = $(char '(') >> ws 21 | close = $(char ')') >> ws 22 | ident = some_ (satisfyA isLatinLetter) >> ws 23 | sexp = br open (some_ sexp >> close) ident 24 | src = sexp >> eof 25 | runSexp = runParser src 26 | 27 | longw = $(string "thisisalongkeyword") 28 | longws = someBr_ longw ws >> eof 29 | runLongws = runParser longws 30 | 31 | numeral = some_ (satisfyA \c -> '0' <= c && c <= '9') >> ws 32 | comma = $(char ',') >> ws 33 | numcsv = numeral >> manyBr_ comma numeral >> eof 34 | runNumcsv = runParser numcsv 35 | -------------------------------------------------------------------------------- /setoidtt/src/Cxt/Types.hs: -------------------------------------------------------------------------------- 1 | 2 | module Cxt.Types where 3 | 4 | import qualified Data.HashMap.Strict as M 5 | 6 | import Common 7 | import qualified Syntax as S 8 | import qualified Values as V 9 | 10 | 11 | data NameInfo = 12 | NITopDef Lvl V.Ty S.U 13 | | NIPostulate Lvl V.Ty S.U 14 | | NILocal Lvl V.Ty S.U 15 | 16 | -- | Table of names used for scoping raw identifiers. Note: we have *more* names around 17 | -- than these, as elaboration can invent names and insert binders. This table only 18 | -- maps raw identifiers that are possibly referenced in source code. 19 | type NameTable = M.HashMap RawName NameInfo -- TODO: better Eq + Hashable for ByteString 20 | 21 | data Cxt = Cxt { 22 | _env :: V.Env, 23 | _lvl :: Lvl, 24 | _locals :: S.Locals, 25 | _nameTable :: NameTable, 26 | _src :: {-# unpack #-} RawName 27 | } 28 | 29 | instance Show Cxt where 30 | show cxt = show $ _locals cxt 31 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/FPEF.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module FPEF 4 | ( 5 | runSexp, 6 | runLongws, 7 | runNumcsv 8 | ) 9 | where 10 | 11 | import FlatParse 12 | 13 | ws = many_ do 14 | ensureBytes# 1 15 | c <- scanAny8# 16 | case c of 17 | 32 -> pure () 18 | 10 -> pure () 19 | _ -> empty 20 | 21 | open = $(char '(') >> ws 22 | close = $(char ')') >> ws 23 | ident = some_ (satisfyA isLatinLetter) >> ws 24 | sexp = br open (some_ sexp >> close) ident 25 | src = sexp >> eof 26 | runSexp = runParser src () 0 27 | 28 | longw = $(string "thisisalongkeyword") 29 | longws = some_ (longw >> ws) >> eof 30 | runLongws = runParser longws () 0 31 | 32 | 33 | numeral = some_ (satisfyA \c -> '0' <= c && c <= '9') >> ws 34 | comma = $(char ',') >> ws 35 | numcsv = numeral >> many_ (comma >> numeral) >> eof 36 | runNumcsv = runParser numcsv () 0 37 | -------------------------------------------------------------------------------- /setoidtt/dynamic-array/package.yaml: -------------------------------------------------------------------------------- 1 | name: dynamic-array 2 | version: 0.1.0.0 3 | license: BSD3 4 | author: "András Kovács" 5 | maintainer: "puttamalac@gmail.com" 6 | copyright: "2018-2020 András Kovács" 7 | 8 | dependencies: 9 | - base >= 4.7 && < 5 10 | 11 | default-extensions: 12 | - GeneralizedNewtypeDeriving 13 | - KindSignatures 14 | - LambdaCase 15 | - MagicHash 16 | - RankNTypes 17 | - RoleAnnotations 18 | - UndecidableInstances 19 | 20 | ghc-options: 21 | - -Wall 22 | - -Wno-missing-signatures 23 | - -Wno-name-shadowing 24 | - -Wno-unused-do-bind 25 | - -Wno-unused-matches 26 | - -Wno-partial-type-signatures 27 | - -O2 28 | - -fllvm 29 | 30 | library: 31 | source-dirs: . 32 | dependencies: 33 | - primdata 34 | # ghc-options: 35 | # - -ddump-simpl 36 | # - -dsuppress-all 37 | # - -dno-suppress-type-signatures 38 | # - -ddump-to-file 39 | -------------------------------------------------------------------------------- /setoidtt/primdata/package.yaml: -------------------------------------------------------------------------------- 1 | name: primdata 2 | version: 0.1.0.0 3 | license: BSD3 4 | author: "András Kovács" 5 | maintainer: "puttamalac@gmail.com" 6 | copyright: "2018-2020 András Kovács" 7 | 8 | dependencies: 9 | - base >= 4.7 && < 5 10 | 11 | default-extensions: 12 | - AllowAmbiguousTypes 13 | - BangPatterns 14 | - BlockArguments 15 | - CPP 16 | - DataKinds 17 | - FlexibleInstances 18 | - GeneralizedNewtypeDeriving 19 | - KindSignatures 20 | - MagicHash 21 | - PolyKinds 22 | - RankNTypes 23 | - RoleAnnotations 24 | - ScopedTypeVariables 25 | - TypeApplications 26 | - TypeFamilies 27 | - UnboxedTuples 28 | 29 | ghc-options: 30 | - -Wall 31 | - -Wno-missing-signatures 32 | - -Wno-name-shadowing 33 | - -Wno-unused-do-bind 34 | - -Wno-unused-matches 35 | - -Wno-partial-type-signatures 36 | - -O2 37 | - -fllvm 38 | # - -ddump-simpl 39 | # - -dsuppress-all 40 | # - -dno-suppress-type-signatures 41 | # - -ddump-to-file 42 | 43 | library: 44 | source-dirs: . 45 | dependencies: 46 | - ghc-prim 47 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Ref/U.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Ref.U where 3 | 4 | import GHC.Prim 5 | import Data.Unlifted 6 | 7 | import qualified Data.Array.UM as UM 8 | 9 | type role Ref representational representational 10 | newtype Ref a b = Ref (UM.Array a) 11 | 12 | instance (Unlifted a, Unlifted b) => Unlifted (Ref a b) where 13 | type Rep (Ref a b) = MutableArrayArray# RealWorld 14 | to# (Ref (UM.Array r)) = r 15 | {-# inline to# #-} 16 | from# r = Ref (UM.Array r) 17 | {-# inline from# #-} 18 | defaultElem = Ref defaultElem 19 | {-# inline defaultElem #-} 20 | 21 | new :: forall a b. (Unlifted a, Unlifted b) => a -> b -> IO (Ref a b) 22 | new a b = Ref <$> UM.new @a 1 a 23 | {-# inline new #-} 24 | 25 | read :: forall a b. (Unlifted a) => Ref a b -> IO a 26 | read (Ref arr) = UM.read arr 0 27 | {-# inline read #-} 28 | 29 | write :: forall a b. (Unlifted a) => Ref a b -> a -> IO () 30 | write (Ref arr) a = UM.write arr 0 a 31 | {-# inline write #-} 32 | 33 | modify :: forall a b. Unlifted a => Ref a b -> (a -> a) -> IO () 34 | modify (Ref arr) f = UM.modify arr 0 f 35 | {-# inline modify #-} 36 | -------------------------------------------------------------------------------- /setoidtt/src/EvalInCxt.hs: -------------------------------------------------------------------------------- 1 | 2 | module EvalInCxt ( 3 | eval, forceF, forceFU, forceFUE, forceFUE', quote, vEq 4 | , (Eval.$$), (Eval.$$$), Eval.vApp, Eval.vAppSE 5 | , Eval.vProj1, Eval.vProj2, Eval.vProjField) where 6 | 7 | import Common 8 | import Cxt 9 | import Syntax 10 | import Values 11 | 12 | import qualified Evaluation as Eval 13 | 14 | eval :: Cxt -> Tm -> Val 15 | eval cxt t = Eval.eval (_env cxt) (_lvl cxt) t 16 | {-# inline eval #-} 17 | 18 | forceF :: Cxt -> Val -> Val 19 | forceF cxt t = Eval.forceF (_lvl cxt) t 20 | {-# inline forceF #-} 21 | 22 | forceFU :: Cxt -> Val -> Val 23 | forceFU cxt t = Eval.forceFU (_lvl cxt) t 24 | {-# inline forceFU #-} 25 | 26 | forceFUE :: Cxt -> Val -> Val 27 | forceFUE cxt t = Eval.forceFUE (_lvl cxt) t 28 | {-# inline forceFUE #-} 29 | 30 | forceFUE' :: Cxt -> Val -> Val 31 | forceFUE' cxt t = Eval.forceFUE' (_lvl cxt) t 32 | {-# inline forceFUE' #-} 33 | 34 | quote :: Cxt -> Val -> Tm 35 | quote cxt t = Eval.quote (_lvl cxt) DontUnfold t 36 | {-# inline quote #-} 37 | 38 | vEq :: Cxt -> Val -> Val -> Val -> Val 39 | vEq cxt a t u = Eval.vEq (_lvl cxt) a t u 40 | {-# inline vEq #-} 41 | -------------------------------------------------------------------------------- /experiments/MonoHaskell.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language 3 | MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, DeriveAnyClass, 4 | RankNTypes, DeriveFunctor, UnboxedSums, MultiParamTypeClasses, 5 | FlexibleInstances, FlexibleContexts, FunctionalDependencies, UnicodeSyntax, 6 | NoImplicitPrelude, 7 | PatternSynonyms, DataKinds, PolyKinds, TypeFamilies #-} 8 | 9 | 10 | import Data.Kind 11 | import GHC.Types 12 | import GHC.Prim 13 | 14 | class Num (a ∷ TYPE r) where 15 | add ∷ a → a → a 16 | mul ∷ a → a → a 17 | 18 | -- ehhhh 19 | class IsList (r ∷ RuntimeRep) where 20 | data List (a ∷ TYPE r) ∷ Type 21 | nil ∷ ∀ (a ∷ TYPE r). List a 22 | cons ∷ ∀ (a ∷ TYPE r). a → List a → List a 23 | uncons ∷ ∀ (a ∷ TYPE r) r' (b ∷ TYPE r'). List a → (a → List a → b) → (() -> b) → b 24 | 25 | instance IsList LiftedRep where 26 | data List a = Nil | Cons a (List a) 27 | nil = Nil 28 | cons = Cons 29 | uncons Nil c n = n () 30 | uncons (Cons a as) c n = c a as 31 | 32 | -- {-# inline map #-} 33 | -- map ∷ ∀ r r' (a ∷ TYPE r)(b ∷ TYPE r'). (IsList r, IsList r') ⇒ (a → b) → List a → List b 34 | -- map f as = uncons as 35 | -- (\a as -> cons (f a) (map f as)) 36 | -- (\_ -> nil) 37 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/Megaparsec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Megaparsec (runSexp, runLongws, runNumcsv) where 3 | 4 | import Control.Applicative 5 | import qualified Data.ByteString as B 6 | import Text.Megaparsec 7 | import Data.Char 8 | 9 | type Parser = Parsec () B.ByteString 10 | 11 | isLatinLetter :: Char -> Bool 12 | isLatinLetter c = ('A' <= c && c <= 'Z') || ('a' <= c && c <= 'z') 13 | 14 | char8 :: Char -> Parser () 15 | char8 c = () <$ single (fromIntegral (ord c)) 16 | 17 | satisfy8 :: (Char -> Bool) -> Parser () 18 | satisfy8 f = () <$ satisfy (f . chr . fromIntegral) 19 | 20 | ws = skipMany (satisfy8 \c -> c == ' ' || c == '\n') 21 | open = char8 '(' >> ws 22 | close = char8 ')' >> ws 23 | ident = skipSome (satisfy8 isLatinLetter) <* ws 24 | sexp = (open *> skipSome sexp <* close) <|> ident 25 | runSexp = runParser sexp "" 26 | 27 | longw = chunk "thisisalongkeyword" 28 | longws = skipSome (longw *> ws) <* eof 29 | runLongws = runParser longws "" 30 | 31 | numeral = skipSome (satisfy8 \c -> '0' <= c && c <= '9') >> ws 32 | comma = single (fromIntegral (ord ',')) >> ws 33 | numcsv = numeral >> skipSome (comma >> numeral) >> eof 34 | runNumcsv = runParser numcsv "" 35 | 36 | -- instance ShowErrorComponent () where 37 | -- showErrorComponent = show 38 | -- errorComponentLen _ = 1 39 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Ref/L.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Ref.L where 3 | 4 | import GHC.Prim 5 | import GHC.Types 6 | import Data.Unlifted 7 | 8 | import IO 9 | import Data.Array.UndefElem 10 | 11 | type role Ref representational 12 | data Ref a = Ref (MutVar# RealWorld a) 13 | 14 | instance Unlifted (Ref a) where 15 | type Rep (Ref a) = MutVar# RealWorld a 16 | to# (Ref r) = r 17 | {-# inline to# #-} 18 | from# r = Ref r 19 | {-# inline from# #-} 20 | defaultElem = runIO (new undefElem) 21 | {-# noinline defaultElem #-} 22 | 23 | new :: a -> IO (Ref a) 24 | new a = IO (\s -> case newMutVar# a s of 25 | (# s , r #) -> (# s, Ref r #)) 26 | {-# inline new #-} 27 | 28 | write :: Ref a -> a -> IO () 29 | write (Ref r) a = IO (\s -> case writeMutVar# r a s of s -> (# s, () #)) 30 | {-# inline write #-} 31 | 32 | read :: Ref a -> IO a 33 | read (Ref r) = IO (readMutVar# r) 34 | {-# inline read #-} 35 | 36 | modify :: Ref a -> (a -> a) -> IO () 37 | modify (Ref r) f = IO (\s -> case readMutVar# r s of 38 | (# s, a #) -> case writeMutVar# r (f a) s of 39 | s -> (# s, () #)) 40 | {-# inline modify #-} 41 | 42 | modify' :: Ref a -> (a -> a) -> IO () 43 | modify' (Ref r) f = IO (\s -> case readMutVar# r s of 44 | (# s, a #) -> let !a' = f a in case writeMutVar# r a' s of 45 | s -> (# s, () #)) 46 | {-# inline modify' #-} 47 | -------------------------------------------------------------------------------- /setoidtt/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 András Kovács 2 | 3 | Redistribution and use in source and binary forms, with or without modification, 4 | are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation and/or 11 | other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 20 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /proto/Notes.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | module Notes where 4 | 5 | open import Data.Product 6 | open import Relation.Binary.PropositionalEquality 7 | 8 | module Parameters where 9 | Graph : Set 10 | Graph = Σ Set (λ A → A → A → Set) 11 | 12 | Hom : Graph → Graph → Set 13 | Hom (A , R) (A' , R') = 14 | Σ (A → A') λ f 15 | → (∀ {a a' fa fa'} → fa ≡ f a → fa' ≡ f a' → R a a' → R' fa fa') 16 | 17 | Id : ∀{A} → Hom A A 18 | Id {A , R} = (λ a → a) , λ {refl refl f → f} 19 | 20 | Comp : ∀ {A B C} → Hom B C → Hom A B → Hom A C 21 | Comp (F , R) (F' , R') = 22 | (λ a → F (F' a)) , λ {refl refl f → R refl refl (R' refl refl f)} 23 | 24 | -- inferable 25 | Idl : ∀ {A B}{F : Hom A B} → Comp F (Id {A}) ≡ F 26 | Idl = {!!} 27 | 28 | module Indices where 29 | 30 | Graph : Set 31 | Graph = Σ Set (λ A → A → A → Set) 32 | 33 | Hom : Graph → Graph → Set -- injective record types 34 | Hom (A , R) (A' , R') = 35 | Σ (A → A') λ f 36 | → (∀ {a a'} → R a a' → R' (f a) (f a')) 37 | × (R' ≡ R') 38 | 39 | Id : ∀{A} → Hom A A 40 | Id {A , R} = (λ a → a) , (λ f → f) , refl 41 | 42 | Comp : ∀ {A B C} → Hom B C → Hom A B → Hom A C 43 | Comp (F , R , _) (F' , R' , _) = 44 | (λ a → F (F' a)) , (λ f → R (R' f)) , refl 45 | 46 | Idl : ∀ {A B}{F : Hom A B} → Comp F (Id {A}) ≡ F 47 | Idl = {!!} 48 | -------------------------------------------------------------------------------- /proto/package.yaml: -------------------------------------------------------------------------------- 1 | 2 | name: setoidtt-proto 3 | version: 0.1.0.0 4 | license: BSD3 5 | category: Language 6 | description: "Exploratory implementation of a setoid type theory" 7 | 8 | default-extensions: 9 | - BangPatterns 10 | - BlockArguments 11 | - ConstraintKinds 12 | - DataKinds 13 | - DeriveAnyClass 14 | - DerivingStrategies 15 | - EmptyCase 16 | - ExplicitNamespaces 17 | - FlexibleContexts 18 | - FlexibleInstances 19 | - InstanceSigs 20 | - FunctionalDependencies 21 | - LambdaCase 22 | - MultiParamTypeClasses 23 | - NoMonomorphismRestriction 24 | - OverloadedStrings 25 | - PartialTypeSignatures 26 | - PatternSynonyms 27 | - PolyKinds 28 | - RankNTypes 29 | - RecordWildCards 30 | - ScopedTypeVariables 31 | - StandaloneDeriving 32 | - Strict 33 | - TemplateHaskell 34 | - TupleSections 35 | - TypeApplications 36 | - TypeFamilies 37 | - TypeOperators 38 | - UnicodeSyntax 39 | - ViewPatterns 40 | 41 | ghc-options: 42 | - -Wall 43 | - -Wno-name-shadowing 44 | - -Wno-missing-signatures 45 | - -Wno-unused-do-bind 46 | - -Wno-unused-matches 47 | - -Wno-partial-type-signatures 48 | - -Wno-type-defaults 49 | - -Wno-missing-pattern-synonym-signatures 50 | # - -ddump-simpl 51 | # - -dsuppress-all 52 | # - -dno-suppress-type-signatures 53 | # - -ddump-to-file 54 | 55 | dependencies: 56 | - base >= 4.7 && < 5 57 | - containers 58 | - megaparsec 59 | - microlens-platform 60 | 61 | source-dirs: . 62 | 63 | executable: 64 | main: Main.hs 65 | ghc-options: 66 | - -O2 67 | - -fllvm 68 | -------------------------------------------------------------------------------- /proto/examples/CatCat.stt: -------------------------------------------------------------------------------- 1 | 2 | -- The category of categories 3 | ------------------------------------------------------------ 4 | 5 | let Cat : Set 6 | = (Obj : Set) 7 | × (Mor : Obj → Obj → Set) 8 | × (id : {i} → Mor i i) 9 | × (comp : {i j k} → Mor j k → Mor i j → Mor i k) 10 | × (idl : {i j}{f : Mor i j} → Eq (comp id f) f) 11 | × (idr : {i j}{f : Mor i j} → Eq (comp f id) f) 12 | × (ass : {i j k l}{f : Mor k l}{g : Mor j k}{h : Mor i j} 13 | → Eq (comp (comp f g) h)(comp f (comp g h))) 14 | × ⊤ in 15 | 16 | let Functor : Cat → Cat → Set = λ C D. 17 | (Obj : C.Obj → D.Obj) 18 | × (Mor : {i j} → C.Mor i j → D.Mor (Obj i) (Obj j)) 19 | × (id : {i} → Eq (Mor (C.id {i})) (D.id)) 20 | × (comp : {i j k f g} → Eq (Mor (C.comp {i}{j}{k} f g)) (D.comp (Mor f) (Mor g))) 21 | × ⊤ in 22 | 23 | let Id : {C} → Functor C C 24 | = (λ i. i, (λ f. f, (refl, (refl, tt)))) in 25 | 26 | let Comp : {C D E} → Functor D E → Functor C D → Functor C E 27 | = λ F G. 28 | (λ i. F.Obj (G.Obj i) ,( 29 | λ f. F.Mor (G.Mor f) ,( 30 | trans (ap (F.Mor) (G.id)) (F.id) ,( 31 | trans (ap (F.Mor) (G.comp)) (F.comp) ,tt 32 | )))) in 33 | 34 | let CatCat : Cat 35 | = (Cat ,( 36 | Functor ,( 37 | Id ,( 38 | λ {C}{D}{E}. Comp {C}{D}{E} ,( -- TODO to get rid of this expansion. We need the same in Agda 39 | (refl, refl) ,( -- allowing refl instead of (refl,refl) needs better unification 40 | (refl, refl) ,( 41 | (refl, refl) ,tt 42 | ))))))) 43 | in 44 | 45 | Set 46 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Ref/F.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Ref.F where 3 | 4 | import GHC.Prim 5 | import GHC.Types 6 | import GHC.Magic 7 | 8 | import Data.Unlifted 9 | import Data.Flat (Flat) 10 | import qualified Data.Flat as F 11 | 12 | type role Ref representational 13 | data Ref a = Ref (MutableByteArray# RealWorld) 14 | 15 | instance Flat a => Unlifted (Ref a) where 16 | type Rep (Ref a) = MutableByteArray# RealWorld 17 | to# (Ref r) = r 18 | {-# inline to# #-} 19 | from# r = Ref r 20 | {-# inline from# #-} 21 | defaultElem = defaultRef 22 | {-# inline defaultElem #-} 23 | 24 | defaultRef :: forall a. Flat a => Ref a 25 | defaultRef = 26 | Ref (runRW# (\s -> case newByteArray# (F.size# @a proxy#) s of 27 | (# s, arr #) -> arr)) 28 | {-# specialize noinline defaultRef :: Ref Int #-} 29 | {-# specialize noinline defaultRef :: Ref Char #-} 30 | {-# specialize noinline defaultRef :: Ref Double #-} 31 | 32 | new :: forall a. Flat a => a -> IO (Ref a) 33 | new a = IO \s -> case newByteArray# (F.size# @a proxy#) s of 34 | (# s, arr #) -> case F.writeByteArray# @a arr 0# a s of 35 | s -> (# s, Ref arr #) 36 | {-# inline new #-} 37 | 38 | write :: forall a. Flat a => Ref a -> a -> IO () 39 | write (Ref r) a = IO (\s -> case F.writeByteArray# @a r 0# a s of 40 | s -> (# s , () #)) 41 | {-# inline write #-} 42 | 43 | read :: forall a. Flat a => Ref a -> IO a 44 | read (Ref r) = IO (F.readByteArray# @a r 0#) 45 | {-# inline read #-} 46 | 47 | modify :: forall a. Flat a => Ref a -> (a -> a) -> IO () 48 | modify (Ref r) f = IO (\s -> case F.readByteArray# @a r 0# s of 49 | (# s, a #) -> case F.writeByteArray# @a r 0# (f a) s of 50 | s -> (# s, () #)) 51 | {-# inline modify #-} 52 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Ref/UU.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Ref.UU where 3 | 4 | import GHC.Prim 5 | import Data.Unlifted 6 | import qualified Data.Array.UM as UM 7 | 8 | type role Ref representational representational 9 | newtype Ref a b = Ref (UM.Array a) 10 | 11 | instance (Unlifted a, Unlifted b) => Unlifted (Ref a b) where 12 | type Rep (Ref a b) = MutableArrayArray# RealWorld 13 | to# (Ref (UM.Array r)) = r 14 | {-# inline to# #-} 15 | from# r = Ref (UM.Array r) 16 | {-# inline from# #-} 17 | defaultElem = Ref defaultElem 18 | {-# inline defaultElem #-} 19 | 20 | new :: forall a b. (Unlifted a, Unlifted b) => a -> b -> IO (Ref a b) 21 | new a b = do 22 | arr <- UM.new @a 2 a 23 | UM.write @b (unsafeCoerce# arr) 1 b 24 | pure (Ref (unsafeCoerce# arr)) 25 | {-# inline new #-} 26 | 27 | readFst :: forall a b. (Unlifted a) => Ref a b -> IO a 28 | readFst (Ref arr) = UM.read arr 0 29 | {-# inline readFst #-} 30 | 31 | readSnd :: forall a b. (Unlifted b) => Ref a b -> IO b 32 | readSnd (Ref arr) = UM.read @b (unsafeCoerce# arr) 1 33 | {-# inline readSnd #-} 34 | 35 | writeFst :: forall a b. (Unlifted a) => Ref a b -> a -> IO () 36 | writeFst (Ref arr) a = UM.write arr 0 a 37 | {-# inline writeFst #-} 38 | 39 | writeSnd :: forall a b. (Unlifted b) => Ref a b -> b -> IO () 40 | writeSnd (Ref arr) b = UM.write @b (unsafeCoerce# arr) 1 b 41 | {-# inline writeSnd #-} 42 | 43 | modifyFst :: forall a b. Unlifted a => Ref a b -> (a -> a) -> IO () 44 | modifyFst (Ref arr) f = UM.modify arr 0 f 45 | {-# inline modifyFst #-} 46 | 47 | modifySnd :: forall a b. Unlifted b => Ref a b -> (b -> b) -> IO () 48 | modifySnd (Ref arr) f = UM.modify @b (unsafeCoerce# arr) 1 f 49 | {-# inline modifySnd #-} 50 | -------------------------------------------------------------------------------- /setoidtt/src/LvlSet.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Bitset for de Bruijn levels. It's currently just a 64-bit 'Int'. We throw an 3 | error when there are more than 64 local bound variables. If and when the need 4 | for more than 64 variables arises, we can switch to 128 bit or add a new 5 | constructor for large sets. 6 | -} 7 | 8 | module LvlSet where 9 | 10 | import Data.Coerce 11 | import Data.Bits 12 | import Data.List (foldl') 13 | import Common 14 | 15 | newtype LvlSet = LvlSet Int deriving (Eq, Bits) via Int 16 | 17 | instance Semigroup LvlSet where 18 | (<>) = (.|.) 19 | {-# inline (<>) #-} 20 | 21 | instance Monoid LvlSet where 22 | mempty = LvlSet 0 23 | {-# inline mempty #-} 24 | 25 | insert :: Lvl -> LvlSet -> LvlSet 26 | insert (Lvl x) (LvlSet s) 27 | | x > 63 = error "LvlSet.insert: element out of range" 28 | | otherwise = LvlSet (unsafeShiftL 1 x .|. s) 29 | {-# inline insert #-} 30 | 31 | single :: Lvl -> LvlSet 32 | single x = insert x mempty 33 | {-# inline single #-} 34 | 35 | delete :: Lvl -> LvlSet -> LvlSet 36 | delete (Lvl x) (LvlSet s) 37 | | x > 63 = error "LvlSet.delete: element out of range" 38 | | otherwise = LvlSet (complement (unsafeShiftL 1 x) .&. s) 39 | {-# inline delete #-} 40 | 41 | member :: Lvl -> LvlSet -> Bool 42 | member (Lvl x) (LvlSet s) 43 | | x > 63 = error "LvlSet.member: element out of range" 44 | | otherwise = (unsafeShiftL 1 x .&. s) /= 0 45 | {-# inline member #-} 46 | 47 | toList :: LvlSet -> [Lvl] 48 | toList s = filter (`member` s) (coerce [0..63::Int]) 49 | {-# inline toList #-} 50 | 51 | fromList :: [Lvl] -> LvlSet 52 | fromList = foldl' (flip insert) mempty 53 | {-# inline fromList #-} 54 | 55 | instance Show LvlSet where 56 | show = show . toList 57 | -------------------------------------------------------------------------------- /experiments/TypedEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# language RankNTypes, ScopedTypeVariables, TypeInType, DerivingVia, GADTs, 4 | LambdaCase, PatternSynonyms, MagicHash, UnboxedTuples #-} 5 | {-# options_ghc -Wincomplete-patterns #-} 6 | 7 | import Unsafe.Coerce 8 | import Data.Coerce 9 | 10 | data Nat = Z | S Nat 11 | 12 | newtype Lvl (e :: Nat) = Lvl Int 13 | deriving (Show, Num, Eq) via Int 14 | 15 | newtype Ix (e :: Nat) = Ix Int 16 | deriving (Show, Num, Eq) via Int 17 | 18 | pattern IZ :: forall n. Ix (S n) 19 | pattern IZ = Ix 0 20 | 21 | pattern IS :: forall n. Ix n -> Ix (S n) 22 | pattern IS x <- ((\case (Ix x) | x /= 0 -> Just (Ix (x - 1)); _ -> Nothing) -> Just x) 23 | {-# complete IZ, IS #-} 24 | 25 | wkLvl :: Lvl n -> Lvl (S n) 26 | wkLvl = coerce 27 | 28 | wkVal :: Val n -> Val (S n) 29 | wkVal = unsafeCoerce 30 | 31 | vVar :: Env n -> Ix n -> Val n 32 | vVar Nil x = case x of 33 | vVar (Def env v) IZ = v 34 | -- vVar (Def env v) (IS x) = undefined 35 | vVar (Skip env) IZ = undefined 36 | vVar (Skip env) (IS x) = wkVal (vVar env x) 37 | 38 | data Tm (e :: Nat) where 39 | Var :: Ix e -> Tm e 40 | Lam :: String -> Tm (S e) -> Tm e 41 | App :: Tm e -> Tm e -> Tm e 42 | 43 | data Env (e :: Nat) where 44 | Nil :: Env Z 45 | Def :: Env e -> Val e -> Env e 46 | Skip :: Env e -> Env (S e) 47 | 48 | data Val (e :: Nat) where 49 | VVar :: Lvl e -> Val e 50 | VApp :: Val e -> Val e -> Val e 51 | VLam :: String -> (Val e -> Val e) -> Val e 52 | 53 | -- eval :: Env e -> Tm e -> Val e 54 | -- eval env = \case 55 | -- Var x -> vVar env x 56 | -- Lam x t -> VLam x (\v -> eval undefined t) 57 | -- App t u -> _ 58 | -------------------------------------------------------------------------------- /setoidtt/flatparse/package.yaml: -------------------------------------------------------------------------------- 1 | name: flatparse 2 | version: 0.1.0.0 3 | license: BSD3 4 | author: "András Kovács" 5 | maintainer: "puttamalac@gmail.com" 6 | copyright: "2018-2020 András Kovács" 7 | 8 | dependencies: 9 | - base >= 4.7 && < 5 10 | - bytestring 11 | - containers 12 | - mtl 13 | - template-haskell 14 | - microlens-platform 15 | - ghc-prim 16 | - text-short 17 | 18 | default-extensions: 19 | - BangPatterns 20 | - BlockArguments 21 | - DerivingVia 22 | - ExplicitNamespaces 23 | - FlexibleInstances 24 | - FunctionalDependencies 25 | - GADTs 26 | - KindSignatures 27 | - LambdaCase 28 | - MagicHash 29 | - MultiParamTypeClasses 30 | - OverloadedStrings 31 | - PatternSynonyms 32 | - QuasiQuotes 33 | - RankNTypes 34 | - RoleAnnotations 35 | - ScopedTypeVariables 36 | - TemplateHaskell 37 | - TupleSections 38 | - TypeApplications 39 | - UnboxedTuples 40 | - ViewPatterns 41 | 42 | ghc-options: 43 | - -Wall 44 | - -Wno-missing-signatures 45 | - -Wno-name-shadowing 46 | - -Wno-unused-do-bind 47 | - -Wno-unused-matches 48 | - -Wno-partial-type-signatures 49 | - -O2 50 | - -fllvm 51 | # - -ddump-simpl 52 | # - -dsuppress-all 53 | # - -dno-suppress-type-signatures 54 | # - -ddump-to-file 55 | # - -ddump-opt-cmm 56 | # - -ddump-asm 57 | 58 | 59 | executables: 60 | bench: 61 | default-extensions: 62 | - OverloadedStrings 63 | source-dirs: bench 64 | main: Main.hs 65 | dependencies: 66 | - gauge 67 | - flatparse 68 | - attoparsec 69 | - megaparsec 70 | - parsec 71 | ghc-options: 72 | - -rtsopts 73 | 74 | library: 75 | source-dirs: . 76 | -------------------------------------------------------------------------------- /setoidtt/flatparse/scalabench/bench.scala: -------------------------------------------------------------------------------- 1 | 2 | package scalabench 3 | 4 | import fastparse._, NoWhitespace._ 5 | import org.scalameter.api._ 6 | 7 | object Main extends Bench.LocalTime { 8 | 9 | def ws[_: P] = P((" " | "\n").rep()) 10 | def isLatin(c : Char) = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') 11 | def open[_: P] = P("(" ~ ws) 12 | def close[_: P] = P(")" ~ ws) 13 | def ident[_: P] = P(CharPred(isLatin).rep(1) ~ ws) 14 | def sexp[_: P] : P[Unit] = P((open ~ sexp.rep(1) ~ close) | ident) 15 | def isDigit(c : Char) = ('0' <= c && c <= '9') 16 | def sexpInp = "(" + "(foo (foo (foo ((bar baza)))))" * 33333 + ")" 17 | 18 | def longw[_: P] = P("thisisalongkeyword") 19 | def longws[_: P] = P((longw ~ ws).rep(1) ~ End) 20 | def longwsInp = "thisisalongkeyword " * 55555 21 | 22 | def numeral[_: P] = P(CharPred(isDigit).rep(1) ~ ws) 23 | def comma[_: P] = P("," ~ ws) 24 | def numcsv[_: P] = P(numeral ~ (comma ~ numeral).rep() ~ End) 25 | def numcsvInp:String = (1 to 100000).map(n => ", " + n.toString()).mkString("") 26 | 27 | performance of "sexp" in { 28 | using(Gen.unit("")) in { 29 | _ => parse(sexpInp, sexp(_)) 30 | } 31 | } 32 | 33 | performance of "longws" in { 34 | using(Gen.unit("")) in { 35 | _ => parse(longwsInp, longws(_)) 36 | } 37 | } 38 | 39 | performance of "numcsv" in { 40 | using(Gen.unit("")) in { 41 | _ => parse(numcsvInp, numcsv(_)) 42 | } 43 | } 44 | } 45 | 46 | // ::Benchmark sexp:: 47 | // Parameters( -> ()): 30.108641 ms 48 | 49 | // ::Benchmark longws:: 50 | // Parameters( -> ()): 5.65306 ms 51 | 52 | // ::Benchmark numcsv:: 53 | // Parameters( -> ()): 12.507556 ms 54 | -------------------------------------------------------------------------------- /experiments/Cmm.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language MagicHash, UnboxedTuples, BangPatterns #-} 3 | 4 | module Cmm where 5 | 6 | import GHC.Exts 7 | import GHC.Prim 8 | 9 | foo f g s = catch# f g s 10 | 11 | 12 | 13 | -- data S a = S {unS :: !a} 14 | 15 | -- data Tree = Node !Tree !Tree | Leaf !Int 16 | 17 | -- inc :: S Tree -> Tree 18 | -- inc (S t) = case t of 19 | -- Leaf n -> Leaf (n + 1) 20 | -- Node l r -> Node (inc (S l)) (inc (S r)) 21 | 22 | -- test :: Int -> State# s -> (# State# s, ByteArray# #) 23 | -- test (I# n) s = case newByteArray# n s of 24 | -- (# s, marr #) -> unsafeFreezeByteArray# marr s 25 | 26 | 27 | -- test2 = unsafeFreezeByteArray# 28 | 29 | -- test3 f x = f (f x) 30 | 31 | -- test4 s = case newByteArray# 16# s of 32 | -- (# s, marr1 #) -> case newByteArray# 16# s of 33 | -- (# s, marr2 #) -> (# s, marr1, marr2 #) 34 | 35 | -- data Foo = F | G | H | I | J | K | L | A | B | C | D | E 36 | 37 | -- f A = B 38 | -- f B = C 39 | -- f C = D 40 | -- f D = E 41 | -- f E = F 42 | -- f F = G 43 | -- f G = H 44 | -- f H = I 45 | -- f I = J 46 | -- f J = K 47 | -- f K = L 48 | -- f L = A 49 | 50 | -- data Foo = Foo | Bar 51 | 52 | -- f :: Foo -> Foo -> Foo 53 | -- f x y = x 54 | 55 | 56 | 57 | 58 | 59 | -- data S a = S {unS :: a} 60 | 61 | -- data Tree = Node Tree Tree | Leaf Int# 62 | 63 | -- foo :: S Tree -> S Bool -> S Tree 64 | -- foo (S t) b = case t of 65 | -- Leaf n -> if unS b then S (Leaf n) else S (Leaf (n +# 1#)) 66 | -- Node l r -> S (Node (unS (foo (S l) b)) (unS (foo (S l) b))) 67 | 68 | 69 | 70 | 71 | 72 | 73 | -- sub :: Tree -> (Int# -> Tree) -> Tree 74 | -- sub (Node l r) ~f = Node (sub2 l f) (sub2 r f) 75 | -- sub (Leaf n) f = f n 76 | 77 | -- sub2 :: Tree -> (Int# -> Tree) -> Tree 78 | -- sub2 (Node l r) ~f = Node (sub l f) (sub r f) 79 | -- sub2 (Leaf n) f = f (n +# 1#) 80 | 81 | -- inc2 :: S Tree -> S Tree 82 | -- inc2 (S t) = case t of 83 | -- Node l r -> S (Node (unS (inc2 (S l))) (unS (inc2 (S r)))) 84 | -- Leaf n -> S (Leaf (n + 1)) 85 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Unlifted.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Unlifted where 3 | 4 | {-| Class for types that can be represented as elements of TYPE 'UnliftedRep. 5 | NOTE: this module is unsound to use in FFI: 6 | 7 | https://gitlab.haskell.org/ghc/ghc/issues/16650 8 | 9 | Do not pass any data to FFI which contains some unlifted value coerced to a 10 | different unlifted type! 11 | -} 12 | 13 | import GHC.Prim 14 | import GHC.Types 15 | 16 | writeUnlifted# :: 17 | forall (a :: TYPE 'UnliftedRep) s. MutableArrayArray# s -> Int# -> a -> State# s -> State# s 18 | writeUnlifted# marr i a s = writeArrayArrayArray# marr i (unsafeCoerce# a) s 19 | {-# inline writeUnlifted# #-} 20 | 21 | readUnlifted# :: forall (a :: TYPE 'UnliftedRep) s. 22 | MutableArrayArray# s -> Int# -> State# s -> (# State# s, a #) 23 | readUnlifted# marr i s = unsafeCoerce# (readArrayArrayArray# marr i s) 24 | {-# inline readUnlifted# #-} 25 | 26 | indexUnlifted# :: forall (a :: TYPE 'UnliftedRep). ArrayArray# -> Int# -> a 27 | indexUnlifted# arr i = unsafeCoerce# (indexArrayArrayArray# arr i) 28 | {-# inline indexUnlifted# #-} 29 | 30 | setUnlifted# :: 31 | forall (a :: TYPE 'UnliftedRep) s. MutableArrayArray# s -> a -> State# s -> State# s 32 | setUnlifted# marr a s = 33 | let go :: MutableArrayArray# s -> a -> State# s -> Int# -> Int# -> State# s 34 | go marr a s l i = case i ==# l of 35 | 1# -> s 36 | _ -> case writeUnlifted# marr i a s of s -> go marr a s l (i +# 1#) 37 | in go marr a s (sizeofMutableArrayArray# marr) 0# 38 | {-# inline setUnlifted# #-} 39 | 40 | newUnlifted# :: forall (a :: TYPE 'UnliftedRep) s. Int# -> a -> State# s -> (# State# s, MutableArrayArray# s #) 41 | newUnlifted# i a s = case newArrayArray# i s of 42 | (# s, marr #) -> case setUnlifted# marr a s of 43 | s -> (# s, marr #) 44 | {-# inline newUnlifted# #-} 45 | 46 | class Unlifted (a :: *) where 47 | type Rep a :: TYPE 'UnliftedRep 48 | to# :: a -> Rep a 49 | from# :: Rep a -> a 50 | defaultElem :: a 51 | -------------------------------------------------------------------------------- /experiments/CompactSerialize.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | BangPatterns, Strict, DeriveGeneric, FlexibleInstances, LambdaCase, 3 | TypeApplications #-} 4 | 5 | import Data.Compact 6 | import Data.Compact.Serialize 7 | import Data.Time.Clock 8 | import Data.Binary 9 | import GHC.Generics 10 | import qualified Data.Persist as P 11 | import qualified Data.ByteString as B 12 | import Data.Word 13 | 14 | data Tree a = Leaf a | Node (Tree a) (Tree a) 15 | deriving (Show, Generic, Eq) 16 | 17 | instance Binary (Tree Int) where 18 | put (Leaf a) = put True >> put a 19 | put (Node l r) = put False >> put l >> put r 20 | get = do 21 | get >>= \case 22 | True -> Leaf <$> get 23 | False -> Node <$> get <*> get 24 | 25 | instance P.Persist (Tree Int) where 26 | put (Leaf a) = P.put @Word8 0 >> P.put a 27 | put (Node l r) = P.put @Word8 1 >> P.put l >> P.put r 28 | get = do 29 | P.get @Word8 >>= \case 30 | 0 -> Leaf <$> P.get 31 | 1 -> Node <$> P.get <*> P.get 32 | 33 | -- instance Binary (Tree Int) 34 | 35 | full :: Int -> Tree Int 36 | full 0 = Leaf 128000 37 | full n = let t = full (n - 1) in Node t t 38 | 39 | timed :: String -> IO a -> IO a 40 | timed msg ma = do 41 | t1 <- getCurrentTime 42 | a <- ma 43 | t2 <- getCurrentTime 44 | putStrLn (msg ++ " " ++ show (diffUTCTime t2 t1)) 45 | pure a 46 | 47 | main :: IO () 48 | main = do 49 | let t = full 21 :: Tree Int 50 | timed "compact region write" $ do 51 | r <- compact t 52 | writeCompact "compact.tree" r 53 | 54 | timed "compact region read" $ do 55 | unsafeReadCompact @(Tree Int) "compact.tree" 56 | 57 | timed "Data.Binary write" $ do 58 | encodeFile "binary.tree" t 59 | 60 | timed "Data.Binary read" $ do 61 | r <- decodeFile @(Tree Int) "binary.tree" 62 | case r of Node{} -> print "foo"; _ -> print "kek" 63 | 64 | timed "persist write" $ do 65 | B.writeFile "persist.tree" $ P.encode t 66 | 67 | timed "persist read" $ do 68 | bstr <- B.readFile "persist.tree" 69 | case P.decode @(Tree Int) bstr of 70 | Left{} -> print "foo" 71 | _ -> print "kek" 72 | -------------------------------------------------------------------------------- /setoidtt/src/ElabState.hs: -------------------------------------------------------------------------------- 1 | 2 | module ElabState where 3 | 4 | import IO 5 | import qualified Data.Array.Dynamic.L as D 6 | import qualified Data.Array.LM as A 7 | import qualified Data.ByteString as B 8 | 9 | import Common 10 | import qualified Syntax as S 11 | import qualified Values as V 12 | 13 | 14 | 15 | -- Top scope 16 | -------------------------------------------------------------------------------- 17 | 18 | data TopEntry 19 | = TEDef ~V.WVal V.Ty S.Tm (Maybe S.Ty) B.ByteString 20 | | TEPostulate V.Ty S.Ty B.ByteString 21 | 22 | -- TODO: we'll implement top resizing and allocation later 23 | topSize :: Int 24 | topSize = 50000 25 | 26 | top :: A.Array TopEntry 27 | top = runIO (A.new topSize (error "top: undefined entry")) 28 | {-# noinline top #-} 29 | 30 | readTop :: Lvl -> IO TopEntry 31 | readTop (Lvl x) | 0 <= x && x < topSize = A.read top x 32 | | otherwise = error "index out of bounds" 33 | {-# inline readTop #-} 34 | 35 | -- Metacontext 36 | -------------------------------------------------------------------------------- 37 | 38 | data MetaEntry 39 | = MEUnsolved V.Ty S.U 40 | | MESolved V.Val V.Ty S.U 41 | 42 | metaCxt :: D.Array MetaEntry 43 | metaCxt = runIO D.empty 44 | {-# noinline metaCxt #-} 45 | 46 | readMeta :: MetaVar -> IO MetaEntry 47 | readMeta (MetaVar i) = D.read metaCxt i 48 | {-# inline readMeta #-} 49 | 50 | newMeta :: V.Ty -> S.U -> IO MetaVar 51 | newMeta a u = do 52 | s <- D.size metaCxt 53 | D.push metaCxt (MEUnsolved a u) 54 | pure (MetaVar s) 55 | {-# inline newMeta #-} 56 | 57 | -- Universe metacontext 58 | -------------------------------------------------------------------------------- 59 | 60 | data UMetaEntry 61 | = UMEUnsolved 62 | | UMESolved S.U 63 | 64 | uCxt :: D.Array UMetaEntry 65 | uCxt = runIO D.empty 66 | {-# noinline uCxt #-} 67 | 68 | readUMeta :: UMetaVar -> IO UMetaEntry 69 | readUMeta (UMetaVar i) = D.read uCxt i 70 | {-# inline readUMeta #-} 71 | 72 | newUMeta :: IO UMetaVar 73 | newUMeta = do 74 | s <- D.size uCxt 75 | D.push uCxt UMEUnsolved 76 | pure (UMetaVar s) 77 | {-# inline newUMeta #-} 78 | -------------------------------------------------------------------------------- /experiments/IOBench.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# language MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, 4 | DeriveAnyClass, RankNTypes, DeriveFunctor, UnboxedSums, 5 | PatternSynonyms #-} 6 | 7 | -- benchmarking whether specialized IO () makes a difference 8 | -- (it doesn't) 9 | 10 | import qualified Control.Exception as E 11 | import GHC.Prim 12 | import GHC.Types 13 | import Gauge 14 | import Control.Monad 15 | import Data.Bits 16 | 17 | data Tree = Leaf | Node !Tree !Tree 18 | 19 | data Ex = Ex 20 | deriving (Show, E.Exception) 21 | 22 | type RW = State# RealWorld 23 | 24 | unsafeThrowIO :: forall e a. e -> IO a 25 | unsafeThrowIO e = IO (raiseIO# e) 26 | {-# inline unsafeThrowIO #-} 27 | 28 | unsafeCatch :: IO a -> (e -> IO a) -> IO a 29 | unsafeCatch (IO io) f = IO (catch# io (\e -> case f e of IO f -> f)) 30 | {-# inline unsafeCatch #-} 31 | 32 | full :: Int -> Tree 33 | full 0 = Leaf 34 | full n = let t = full (n - 1) in Node t t 35 | 36 | eqPrimE :: Tree -> Tree -> IO Bool 37 | eqPrimE t t' = do 38 | let go :: Tree -> Tree -> IO () 39 | go Leaf Leaf = pure () 40 | go (Node l r) (Node l' r') = go l l' >> go r r' 41 | go _ _ = unsafeThrowIO Ex 42 | (True <$ go t t') `unsafeCatch` \(e :: Ex) -> pure False 43 | 44 | eqPrimE' :: Tree -> Tree -> IO Bool 45 | eqPrimE' t t' = do 46 | let go :: Tree -> Tree -> RW -> RW 47 | go Leaf Leaf s = s 48 | go (Node l r) (Node l' r') s = go r r' (go l l' s) 49 | go _ _ s = case raiseIO# Ex s of (# s, _ #) -> s 50 | IO (\s -> (# go t t' s, True #)) `unsafeCatch` \(e :: Ex) -> pure False 51 | 52 | -- No difference at least here. 53 | main :: IO () 54 | main = do 55 | let !t = full 24 56 | defaultMainWith (defaultConfig {displayMode = Condensed}) [ 57 | bench "eqPrimE'" $ whnfIO (eqPrimE' t t), 58 | bench "eqPrimE" $ whnfIO (eqPrimE t t), 59 | bench "eqPrimE'" $ whnfIO (eqPrimE' t t), 60 | bench "eqPrimE" $ whnfIO (eqPrimE t t), 61 | bench "eqPrimE'" $ whnfIO (eqPrimE' t t), 62 | bench "eqPrimE" $ whnfIO (eqPrimE t t) 63 | 64 | ] 65 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/FM.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.FM where 3 | 4 | import GHC.Types 5 | import GHC.Prim 6 | import GHC.Magic 7 | import Data.Flat 8 | 9 | import qualified Data.Array.FI as FI 10 | import Data.Unlifted 11 | 12 | type role Array representational 13 | data Array (a :: *) = Array (MutableByteArray# RealWorld) 14 | 15 | instance Unlifted (Array a) where 16 | type Rep (Array a) = MutableByteArray# RealWorld 17 | to# (Array arr) = arr 18 | from# = Array 19 | {-# inline to# #-} 20 | {-# inline from# #-} 21 | defaultElem = empty 22 | {-# inline defaultElem #-} 23 | 24 | new :: forall a. Flat a => Int -> IO (Array a) 25 | new (I# n) = IO \s -> case newByteArray# (n *# size# @a proxy#) s of 26 | (# s, marr #) -> (# s, Array marr #) 27 | {-# inline new #-} 28 | 29 | empty :: Array a 30 | empty = Array (runRW# \s -> case newByteArray# 0# s of 31 | (# s, arr #) -> arr) 32 | {-# noinline empty #-} 33 | 34 | read :: forall a. Flat a => Array a -> Int -> IO a 35 | read (Array arr) (I# i) = IO (readByteArray# arr i) 36 | {-# inline read #-} 37 | 38 | write :: forall a. Flat a => Array a -> Int -> a -> IO () 39 | write (Array arr) (I# i) a = IO \s -> 40 | case writeByteArray# arr i a s of 41 | s -> (# s, () #) 42 | {-# inline write #-} 43 | 44 | modify :: forall a. Flat a => Array a -> Int -> (a -> a) -> IO () 45 | modify (Array arr) (I# i) f = IO \s -> case readByteArray# arr i s of 46 | (# s, a #) -> let !v = f a in case writeByteArray# arr i v s of 47 | s -> (# s, () #) 48 | {-# inline modify #-} 49 | 50 | size :: forall a. Flat a => Array a -> Int 51 | size (Array arr) = I# (quotInt# (sizeofMutableByteArray# arr) (size# @a proxy#)) 52 | {-# inline size #-} 53 | 54 | thaw :: forall a. FI.Array a -> IO (Array a) 55 | thaw (FI.Array arr) = 56 | let n = sizeofByteArray# arr 57 | in IO \s -> case newByteArray# n s of 58 | (# s, marr #) -> case copyByteArray# arr 0# marr 0# n s of 59 | s -> (# s, Array marr #) 60 | {-# inline thaw #-} 61 | 62 | unsafeFreeze :: Array a -> IO (FI.Array a) 63 | unsafeFreeze (Array marr) = IO \s -> case unsafeFreezeByteArray# marr s of 64 | (# s, arr #) -> (# s, FI.Array arr #) 65 | {-# inline unsafeFreeze #-} 66 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -Wno-unused-imports #-} 2 | 3 | module Main where 4 | 5 | import Gauge 6 | import qualified Data.ByteString.Char8 as B 7 | 8 | import qualified FP 9 | import qualified FPI 10 | import qualified FPEF 11 | import qualified FPIO 12 | import qualified Attoparsec 13 | import qualified Megaparsec 14 | import qualified Parsec 15 | 16 | sexpInp :: B.ByteString 17 | sexpInp = 18 | B.concat $ "(" : replicate 33333 "(foo (foo (foo ((bar baza)))))" ++ [")"] 19 | 20 | longwsInp :: B.ByteString 21 | longwsInp = B.concat $ replicate 55555 "thisisalongkeyword " 22 | 23 | numcsvInp :: B.ByteString 24 | numcsvInp = B.concat ("0" : [B.pack (", " ++ show n) | n <- [1..100000::Int]]) 25 | 26 | main :: IO () 27 | main = defaultMain [ 28 | bgroup "sexp" [ 29 | bench "flatparse" $ whnf FP.runSexp sexpInp, 30 | bench "flatparseIO" $ whnf FPIO.runSexp sexpInp, 31 | bench "flatparseef" $ whnf FPEF.runSexp sexpInp, 32 | bench "flatparsei" $ whnf FPI.runSexp sexpInp, 33 | bench "attoparsec" $ whnf Attoparsec.runSexp sexpInp, 34 | bench "megaparsec" $ whnf Megaparsec.runSexp sexpInp, 35 | bench "parsec" $ whnf Parsec.runSexp sexpInp 36 | ], 37 | 38 | bgroup "long keyword" [ 39 | bench "flatparse" $ whnf FP.runLongws longwsInp, 40 | bench "flatparseio" $ whnf FPIO.runLongws longwsInp, 41 | bench "flatparseef" $ whnf FPEF.runLongws longwsInp, 42 | bench "flatparsei" $ whnf FPI.runLongws longwsInp, 43 | bench "attoparsec" $ whnf Attoparsec.runLongws longwsInp, 44 | bench "megaparsec" $ whnf Megaparsec.runLongws longwsInp, 45 | bench "parsec" $ whnf Parsec.runLongws longwsInp 46 | ], 47 | 48 | bgroup "numeral csv" [ 49 | bench "flatparse" $ whnf FP.runNumcsv numcsvInp, 50 | bench "flatparseio" $ whnf FPIO.runNumcsv numcsvInp, 51 | bench "flatparseef" $ whnf FPEF.runNumcsv numcsvInp, 52 | bench "flatparsei" $ whnf FPI.runNumcsv numcsvInp, 53 | bench "attoparsec" $ whnf Attoparsec.runNumcsv numcsvInp, 54 | bench "megaparsec" $ whnf Megaparsec.runNumcsv numcsvInp, 55 | bench "parsec" $ whnf Parsec.runNumcsv numcsvInp 56 | ] 57 | ] 58 | -------------------------------------------------------------------------------- /proto/Zonk.hs: -------------------------------------------------------------------------------- 1 | 2 | module Zonk where 3 | 4 | import Types 5 | import Evaluation 6 | import ElabState 7 | 8 | -- | Unfold all metas and evaluate meta-headed spines, but don't evaluate 9 | -- anything else. 10 | zonk :: Vals -> Lvl -> Tm -> Tm 11 | zonk vs l t = go t where 12 | 13 | goSp :: Tm -> Either Val Tm 14 | goSp = \case 15 | Meta m -> case runLookupMeta m of 16 | Solved v -> Left v 17 | _ -> Right (Meta m) 18 | App t u uu ni -> case goSp t of 19 | Left t -> Left (vApp t (eval vs l u) (forceU uu) ni) 20 | Right t -> Right $ App t (go u) (forceU uu) ni 21 | t -> Right (zonk vs l t) 22 | 23 | goBind = zonk (VSkip vs) (l + 1) 24 | 25 | go = \case 26 | Var x -> Var x 27 | Meta m -> case runLookupMeta m of 28 | Solved v -> quote (valsLen vs) v 29 | Unsolved{} -> Meta m 30 | U u -> U (forceU u) 31 | Pi x i a au b -> Pi x i (go a) (forceU au) (goBind b) 32 | App t u uu ni -> case goSp t of 33 | Left t -> quote (valsLen vs) (vApp t (eval vs l u) (forceU uu) ni) 34 | Right t -> App t (go u) (forceU uu) ni 35 | Lam x i a au t -> Lam x i (go a) (forceU au) (goBind t) 36 | Let x a au t u -> Let x (go a) (forceU au) (go t) (goBind u) 37 | Skip t -> Skip (goBind t) 38 | Top -> Top 39 | Tt -> Tt 40 | Bot -> Bot 41 | Exfalso u -> Exfalso (forceU u) 42 | Eq -> Eq 43 | Refl -> Refl 44 | Coe u -> Coe (forceU u) 45 | Sym -> Sym 46 | Trans -> Trans 47 | Ap -> Ap 48 | Sg x a au b bu -> Sg x (go a) (forceU au) (goBind b) (forceU bu) 49 | Proj1 t tu -> Proj1 (go t) (forceU tu) 50 | Proj2 t tu -> Proj2 (go t) (forceU tu) 51 | ProjField t x i tu -> ProjField (go t) x i (forceU tu) 52 | Pair t tu u uu -> Pair (go t) (forceU tu) (go u) (forceU uu) 53 | Ind u -> Ind (forceU u) 54 | Nat -> Nat 55 | Zero -> Zero 56 | Suc -> Suc 57 | -------------------------------------------------------------------------------- /setoidtt/flatparse/bench/FP.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -Wno-orphans #-} 2 | 3 | module FP 4 | ( 5 | runSexp, 6 | runLongws, 7 | runNumcsv, 8 | runTm 9 | ) where 10 | 11 | import Old.FlatParse 12 | import Old.Switch 13 | 14 | ws = manyTok_ $(switch [| case _ of "\n" -> pure (); " " -> pure () |]) 15 | open = $(char '(') >> ws 16 | close = $(char ')') >> ws 17 | ident = someTok_ (satisfyA isLatinLetter) >> ws 18 | sexp = br open (some_ sexp >> close) ident 19 | src = sexp >> eof 20 | runSexp = runParser src 21 | 22 | longw = $(string "thisisalongkeyword") 23 | longws = someTok_ (longw >> ws) >> eof 24 | runLongws = runParser longws 25 | 26 | numeral = someTok_ (satisfyA \c -> '0' <= c && c <= '9') >> ws 27 | comma = $(char ',') >> ws 28 | numcsv = numeral >> manyBr_ comma numeral >> eof 29 | runNumcsv = runParser numcsv 30 | 31 | ------------------------------------------------------------ 32 | 33 | type Name = Span 34 | data Tm = Var {-# unpack #-} !Name | Lam {-# unpack #-} !Name !Tm 35 | | Let {-# unpack #-} !Name !Tm !Tm | App !Tm !Tm 36 | 37 | type Parser' = Parser (Pos, String) 38 | 39 | instance Show Pos where 40 | show _ = "pos" 41 | 42 | err' :: Pos -> String -> Parser' a 43 | err' !p !str = err (p, str) 44 | 45 | bind :: Parser' Span 46 | bind = do 47 | (i, span) <- spanned (someTok_ (satisfyA isLatinLetter)) 48 | inSpan span do 49 | p <- getPos 50 | let kwerr kw = err' p $ "expected an identifier, got a keyword: " ++ kw 51 | $(switch [| case _ of 52 | "lam" -> kwerr "lam" 53 | "let" -> kwerr "let" 54 | "in" -> kwerr "in" 55 | _ -> pure () |]) 56 | ws 57 | pure span 58 | 59 | tok :: Parser' () -> String -> Parser' () 60 | tok p msg = do 61 | pos <- getPos 62 | br p ws (err' pos msg) 63 | {-# inline tok #-} 64 | 65 | atom :: Parser' Tm 66 | atom = (Var <$> bind) 67 | ($(char '(') *> ws *> tm <* $(char ')') <* ws) 68 | 69 | tm :: Parser' Tm 70 | tm = $(switch [| case _ of 71 | "lam" -> do 72 | ws 73 | x <- bind 74 | tok $(char '.') "expected a . in lambda expression" 75 | t <- tm 76 | pure (Lam x t) 77 | "let" -> do 78 | ws 79 | x <- bind 80 | tok $(char '=') "expected a = in let expression" 81 | t <- tm 82 | tok $(string "in") "expected an \"in\" in let expression" 83 | u <- tm 84 | pure (Let x t u) 85 | _ -> chainl App atom atom 86 | |]) 87 | 88 | runTm = runParser tm 89 | -------------------------------------------------------------------------------- /setoidtt/package.yaml: -------------------------------------------------------------------------------- 1 | 2 | name: setoidtt 3 | version: 0.1.0.0 4 | license: BSD2 5 | category: Language 6 | description: "Implementation of a variant of setoid type theory" 7 | 8 | default-extensions: 9 | - BangPatterns 10 | - BlockArguments 11 | - CPP 12 | - ConstraintKinds 13 | - DataKinds 14 | - DefaultSignatures 15 | - DeriveAnyClass 16 | - DerivingStrategies 17 | - DerivingVia 18 | - EmptyCase 19 | - ExplicitNamespaces 20 | - FlexibleContexts 21 | - FlexibleInstances 22 | - FunctionalDependencies 23 | - GADTs 24 | - GeneralizedNewtypeDeriving 25 | - InstanceSigs 26 | - LambdaCase 27 | - MagicHash 28 | - MultiParamTypeClasses 29 | - NoMonomorphismRestriction 30 | - OverloadedStrings 31 | - PartialTypeSignatures 32 | - PatternSynonyms 33 | - PolyKinds 34 | - RankNTypes 35 | - RecordWildCards 36 | - ScopedTypeVariables 37 | - StandaloneDeriving 38 | - Strict 39 | - TemplateHaskell 40 | - TupleSections 41 | - TypeApplications 42 | - TypeFamilies 43 | - TypeOperators 44 | - UnboxedTuples 45 | - UnicodeSyntax 46 | - ViewPatterns 47 | 48 | ghc-options: 49 | - -Wall 50 | - -Wno-name-shadowing 51 | - -Wno-missing-signatures 52 | - -Wno-unused-do-bind 53 | - -Wno-unused-matches 54 | - -Wno-partial-type-signatures 55 | - -Wno-type-defaults 56 | - -Wno-missing-pattern-synonym-signatures 57 | - -fplugin-opt=Test.Inspection.Plugin:skip-O0 58 | - -O 59 | - -fmax-worker-args=15 60 | # - -fllvm 61 | # - -ddump-simpl 62 | # - -dsuppress-all 63 | # - -dno-suppress-type-signatures 64 | # - -ddump-to-file 65 | # - -ddump-stg 66 | # - -ddump-cmm 67 | 68 | 69 | dependencies: 70 | - base 71 | 72 | data-files: 73 | - bench/parse01.stt 74 | 75 | library: 76 | source-dirs: 77 | - src 78 | dependencies: 79 | - bytestring 80 | - containers 81 | - directory 82 | - dynamic-array 83 | - flatparse 84 | - ghc-prim 85 | - hashable 86 | - inspection-testing 87 | - primdata 88 | - template-haskell 89 | - time 90 | - unordered-containers 91 | 92 | executables: 93 | setoidtt: 94 | source-dirs: 95 | - main 96 | main: Main.hs 97 | dependencies: 98 | - setoidtt 99 | ghc-options: 100 | - -rtsopts 101 | 102 | setoidtt-bench: 103 | source-dirs: 104 | - bench 105 | main: Bench.hs 106 | dependencies: 107 | - gauge 108 | - flatparse 109 | - setoidtt 110 | ghc-options: 111 | - -rtsopts 112 | -------------------------------------------------------------------------------- /setoidtt/src/Cxt/Extension.hs: -------------------------------------------------------------------------------- 1 | 2 | module Cxt.Extension where 3 | 4 | import qualified Data.HashMap.Strict as M 5 | 6 | import Common 7 | import Cxt.Types 8 | import Evaluation 9 | 10 | import qualified Syntax as S 11 | import qualified Values as V 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | emptyCxt :: RawName -> Cxt 16 | emptyCxt = Cxt V.Nil 0 S.Empty mempty 17 | {-# inline emptyCxt #-} 18 | 19 | bind :: RawName -> S.Ty -> S.U -> Cxt -> Cxt 20 | bind x a au (Cxt env l loc ntbl src) = 21 | Cxt (V.Skip env l) 22 | (l + 1) 23 | (S.Bind loc (NName x) a au) 24 | (M.insert x (NILocal l (eval env l a) au) ntbl) 25 | src 26 | {-# inline bind #-} 27 | 28 | bindEmpty :: S.Ty -> S.U -> Cxt -> Cxt 29 | bindEmpty a au (Cxt env l loc ntbl src) = 30 | Cxt (V.Skip env l) 31 | (l + 1) 32 | (S.Bind loc NEmpty a au) 33 | ntbl 34 | src 35 | {-# inline bindEmpty #-} 36 | 37 | bind' :: RawName -> S.Ty -> V.Ty -> S.U -> Cxt -> Cxt 38 | bind' x a va au (Cxt env l loc ntbl src) = 39 | Cxt (V.Skip env l) 40 | (l + 1) 41 | (S.Bind loc (NName x) a au) 42 | (M.insert x (NILocal l va au) ntbl) 43 | src 44 | {-# inline bind' #-} 45 | 46 | bindEmpty' :: S.Ty -> V.Ty -> S.U -> Cxt -> Cxt 47 | bindEmpty' a va au (Cxt env l loc ntbl src) = 48 | Cxt (V.Skip env l) 49 | (l + 1) 50 | (S.Bind loc NEmpty a au) 51 | ntbl 52 | src 53 | {-# inline bindEmpty' #-} 54 | 55 | newBinder :: Name -> S.Ty -> S.U -> Cxt -> Cxt 56 | newBinder x a au (Cxt env l loc ntbl src) = 57 | Cxt (V.Skip env l) 58 | (l + 1) 59 | (S.Bind loc x a au) 60 | ntbl 61 | src 62 | {-# inline newBinder #-} 63 | 64 | define :: RawName -> S.Tm -> S.Ty -> S.U -> Cxt -> Cxt 65 | define x t a au (Cxt env l loc ntbl src) = 66 | Cxt (V.Snoc env (unS (eval env l t))) 67 | (l + 1) 68 | (S.Define loc (NName x) t a au) 69 | (M.insert x (NILocal l (eval env l a) au) ntbl) 70 | src 71 | {-# inline define #-} 72 | 73 | define' :: RawName -> S.Tm -> V.WVal -> S.Ty -> V.Ty -> S.U -> Cxt -> Cxt 74 | define' x t ~vt a va au (Cxt env l loc ntbl src) = 75 | Cxt (V.Snoc env vt) 76 | (l + 1) 77 | (S.Define loc (NName x) t a au) 78 | (M.insert x (NILocal l va au) ntbl) 79 | src 80 | {-# inline define' #-} 81 | 82 | closeVal :: Cxt -> V.Val -> V.Closure 83 | closeVal cxt t = 84 | V.Close (_env cxt) (_lvl cxt) (quote (_lvl cxt + 1) DontUnfold t) 85 | {-# inline closeVal #-} 86 | -------------------------------------------------------------------------------- /setoidtt/src/Exceptions.hs: -------------------------------------------------------------------------------- 1 | 2 | module Exceptions ( 3 | Ex(..), throwIO, throw, catch, fenceEx, ElabError(..), 4 | ) where 5 | 6 | import GHC.Prim 7 | import GHC.Types 8 | import qualified Control.Exception as Ex 9 | 10 | import Common 11 | import Syntax 12 | import qualified Presyntax as P 13 | 14 | -------------------------------------------------------------------------------- 15 | 16 | throwIO :: forall a. Ex -> IO a 17 | throwIO e = IO (raiseIO# e) 18 | {-# inline throwIO #-} 19 | 20 | throw :: forall a. Ex -> a 21 | throw = raise# 22 | {-# inline throw #-} 23 | 24 | catch# :: forall a. IO a -> (Ex -> IO a) -> IO a 25 | catch# (IO io) f = IO (GHC.Prim.catch# io (\e -> case f e of IO f -> f)) 26 | {-# inline catch# #-} 27 | 28 | catch :: IO a -> (Ex -> IO a) -> IO a 29 | catch ma f = ma `Exceptions.catch#` \case 30 | SomeException e -> Ex.throw e 31 | e -> f e 32 | {-# inline catch #-} 33 | 34 | -- | This is a dirty hack which ensures that our monomorphized `catch` can also 35 | -- catch every standard `Control.Exception` exception potentially thrown by 36 | -- external library code or standard throwing operations such as incomplete 37 | -- matches or zero division. The trick is that the first variant in `Ex` has 38 | -- the same representation as the `Control.Exception` definition, and casing 39 | -- also works because of pointer tagged constructors. Why do we use this 40 | -- hack? The reason is performance: we use exceptions internally for control 41 | -- flow purposes, and avoiding the standard `Typeable` safety mechanism 42 | -- reduces overheads significantly. 43 | data Ex = 44 | forall e. Ex.Exception e => SomeException e -- ^ Standard exceptions. 45 | 46 | -- Conversion checking exceptions 47 | | ConvSame 48 | | ConvDiff 49 | | ConvMeta MetaVar 50 | | ConvMax UMax 51 | 52 | -- Unification exception 53 | | CantUnify 54 | 55 | -- Elaboration errors 56 | | ElabError Locals P.Tm ElabError 57 | 58 | -- | Don't let any non-standard `Ex` exception escape. This should be used on 59 | -- the top of the main function of the program. 60 | fenceEx :: Dbg => IO a -> IO a 61 | fenceEx act = act `Exceptions.catch#` \case 62 | SomeException e -> Ex.throw e 63 | _ -> impossible 64 | 65 | -------------------------------------------------------------------------------- 66 | 67 | data ElabError 68 | = UnifyError Tm Tm 69 | | NameNotInScope {-# unpack #-} RawName 70 | | NoSuchField {-# unpack #-} RawName 71 | | NoSuchArgument {-# unpack #-} RawName 72 | | IcitMismatch Icit Icit 73 | | NoNamedLambdaInference 74 | | ExpectedSg Tm 75 | deriving Show 76 | -------------------------------------------------------------------------------- /experiments/serialization-bench/Serialize.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language MagicHash, Strict, BangPatterns, UnboxedTuples, RankNTypes, BlockArguments, 3 | TypeApplications, ScopedTypeVariables #-} 4 | 5 | module Serialize where 6 | 7 | import qualified Data.ByteString as B 8 | import qualified Data.ByteString.Internal as B 9 | import qualified Data.ByteString.Unsafe as B 10 | import Foreign.Marshal.Alloc 11 | import GHC.Exts 12 | import GHC.ForeignPtr 13 | import GHC.Types 14 | import GHC.Word 15 | 16 | newtype Put = Put { 17 | runPut :: forall s. Addr# -> State# s -> (# State# s, Addr# #)} 18 | 19 | infixr 1 >>. 20 | (>>.) :: Put -> Put -> Put 21 | (>>.) (Put f) (Put g) = Put \p s -> case f p s of 22 | (# s, p #) -> g p s 23 | {-# inline (>>.) #-} 24 | 25 | newtype Get a = Get { 26 | runGet :: Addr# -> (# Addr#, a #)} 27 | 28 | instance Functor Get where 29 | fmap f (Get g) = Get \p -> case g p of 30 | (# p, a #) -> let !b = f a in (# p, b #) 31 | {-# inline fmap #-} 32 | 33 | instance Applicative Get where 34 | pure = return 35 | {-# inline pure #-} 36 | Get ff <*> Get fa = Get \p -> case ff p of 37 | (# p, f #) -> case fa p of 38 | (# p, a #) -> let !b = f a in (# p, b #) 39 | {-# inline (<*>) #-} 40 | 41 | instance Monad Get where 42 | return ~a = Get \p -> (# p, a #) 43 | {-# inline return #-} 44 | Get f >>= g = Get \p -> case f p of 45 | (# p, a #) -> runGet (g a) p 46 | {-# inline (>>=) #-} 47 | 48 | class Serialize a where 49 | size :: a -> Int 50 | put :: a -> Put 51 | get :: Get a 52 | 53 | instance Serialize Int where 54 | size _ = 8 55 | {-# inline size #-} 56 | put (I# n) = Put \p s -> case writeIntOffAddr# p 0# n s of 57 | s -> (# s, plusAddr# p 8# #) 58 | {-# inline put #-} 59 | get = Get \p -> (# plusAddr# p 8#, I# (indexIntOffAddr# p 0#) #) 60 | {-# inline get #-} 61 | 62 | instance Serialize Word8 where 63 | size _ = 1 64 | {-# inline size #-} 65 | put (W8# n) = Put \p s -> case writeWord8OffAddr# p 0# n s of 66 | s -> (# s, plusAddr# p 1# #) 67 | {-# inline put #-} 68 | get = Get \p -> (# plusAddr# p 1#, W8# (indexWord8OffAddr# p 0#) #) 69 | {-# inline get #-} 70 | 71 | toFile :: forall a. Serialize a => FilePath -> a -> IO () 72 | toFile path a = do 73 | let s = size a 74 | allocaBytes s \buf@(Ptr addr) -> do 75 | fp <- newForeignPtr_ buf 76 | IO (\s -> case runPut (put a) addr s of 77 | (# s, buf #) -> (# s, () #)) 78 | B.writeFile path (B.PS fp 0 s) 79 | 80 | fromFile :: forall a. Serialize a => FilePath -> IO a 81 | fromFile path = do 82 | bstr <- B.readFile path 83 | B.unsafeUseAsCString bstr \(Ptr addr) -> 84 | case runGet (get @a) addr of 85 | (# _, a #) -> pure a 86 | -------------------------------------------------------------------------------- /proto/ElabState.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Top-level mutable state involved in elaboration. We use actual mutable 3 | -- top-level references simply because it's convenient and our simple 4 | -- program does not call for anything more sophisticated. 5 | 6 | module ElabState where 7 | 8 | import Data.IORef 9 | import System.IO.Unsafe 10 | import qualified Data.IntMap.Strict as IM 11 | 12 | import Types 13 | 14 | runIO :: IO a -> a 15 | runIO = unsafeDupablePerformIO 16 | 17 | mcxt :: IORef MCxt 18 | mcxt = runIO (newIORef mempty) 19 | {-# noinline mcxt #-} 20 | 21 | nextMId :: IORef Int 22 | nextMId = runIO (newIORef 0) 23 | {-# noinline nextMId #-} 24 | 25 | lookupMeta :: MId -> IO MetaEntry 26 | lookupMeta m = do 27 | ms <- readIORef mcxt 28 | case IM.lookup m ms of 29 | Just e -> pure e 30 | _ -> error "impossible" 31 | 32 | runLookupMeta :: MId -> MetaEntry 33 | runLookupMeta m = runIO (lookupMeta m) 34 | 35 | alterMeta :: MId -> (Maybe MetaEntry -> Maybe MetaEntry) -> IO () 36 | alterMeta m f = modifyIORef' mcxt (IM.alter f m) 37 | 38 | modifyMeta :: MId -> (MetaEntry -> MetaEntry) -> IO () 39 | modifyMeta m f = alterMeta m (maybe (error "impossible") (Just . f)) 40 | 41 | writeMeta :: MId -> MetaEntry -> IO () 42 | writeMeta m e = modifyMeta m (const e) 43 | 44 | newMeta :: VTy -> U -> IO MId 45 | newMeta a au = do 46 | m <- readIORef nextMId 47 | writeIORef nextMId $! (m + 1) 48 | alterMeta m (maybe (Just (Unsolved a au)) (\_ -> error "impossible")) 49 | pure m 50 | 51 | ------------------------------------------------------------ 52 | 53 | ucxt :: IORef UCxt 54 | ucxt = runIO (newIORef mempty) 55 | {-# noinline ucxt #-} 56 | 57 | nextUId :: IORef Int 58 | nextUId = runIO (newIORef 0) 59 | {-# noinline nextUId #-} 60 | 61 | lookupU:: UId -> IO (Maybe U) 62 | lookupU m = do 63 | ms <- readIORef ucxt 64 | case IM.lookup m ms of 65 | Just e -> pure e 66 | _ -> error "impossible" 67 | 68 | runLookupU :: UId -> Maybe U 69 | runLookupU m = runIO (lookupU m) 70 | 71 | alterU :: UId -> (Maybe (Maybe U) -> Maybe (Maybe U)) -> IO () 72 | alterU m f = modifyIORef' ucxt (IM.alter f m) 73 | 74 | modifyU :: UId -> (Maybe U -> Maybe U) -> IO () 75 | modifyU m f = alterU m (maybe (error "impossible") (Just . f)) 76 | 77 | writeU :: UId -> Maybe U -> IO () 78 | writeU m e = modifyU m (const e) 79 | 80 | newU :: IO UId 81 | newU = do 82 | m <- readIORef nextUId 83 | writeIORef nextUId $! (m + 1) 84 | alterU m (maybe (Just Nothing) (\_ -> error "impossible")) 85 | pure m 86 | 87 | ------------------------------------------------------------ 88 | 89 | reset :: IO () 90 | reset = do 91 | writeIORef mcxt mempty 92 | writeIORef nextMId 0 93 | writeIORef ucxt mempty 94 | writeIORef nextUId 0 95 | -------------------------------------------------------------------------------- /experiments/serialization-bench/SerializeStrict.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language MagicHash, Strict, BangPatterns, UnboxedTuples, RankNTypes, BlockArguments, 3 | TypeApplications, ScopedTypeVariables #-} 4 | 5 | module SerializeStrict where 6 | 7 | import qualified Data.ByteString as B 8 | import qualified Data.ByteString.Internal as B 9 | import qualified Data.ByteString.Unsafe as B 10 | import Foreign.Marshal.Alloc 11 | import GHC.Exts 12 | import GHC.ForeignPtr 13 | import GHC.Types 14 | import GHC.Word 15 | 16 | newtype Put = Put { 17 | runPut :: forall s. Addr# -> State# s -> (# State# s, Addr# #)} 18 | 19 | infixr 1 >>. 20 | (>>.) :: Put -> Put -> Put 21 | (>>.) (Put f) (Put g) = Put \p s -> case f p s of 22 | (# s, p #) -> g p s 23 | {-# inline (>>.) #-} 24 | 25 | data GetRes a = GetRes Addr# !a 26 | 27 | newtype Get a = Get { 28 | runGet :: Addr# -> GetRes a} 29 | 30 | instance Functor Get where 31 | fmap f (Get g) = Get \p -> case g p of 32 | GetRes p a -> GetRes p (f a) 33 | {-# inline fmap #-} 34 | 35 | instance Applicative Get where 36 | pure a = Get \p -> GetRes p a 37 | {-# inline pure #-} 38 | Get ff <*> Get fa = Get \p -> case ff p of 39 | GetRes p f -> case fa p of 40 | GetRes p a -> GetRes p (f a) 41 | {-# inline (<*>) #-} 42 | 43 | instance Monad Get where 44 | return a = Get \p -> GetRes p a 45 | {-# inline return #-} 46 | Get f >>= g = Get \p -> case f p of 47 | GetRes p a -> runGet (g a) p 48 | {-# inline (>>=) #-} 49 | 50 | class Serialize a where 51 | size :: a -> Int 52 | put :: a -> Put 53 | get :: Get a 54 | 55 | instance Serialize Int where 56 | size _ = 8 57 | {-# inline size #-} 58 | put (I# n) = Put \p s -> case writeIntOffAddr# p 0# n s of 59 | s -> (# s, plusAddr# p 8# #) 60 | {-# inline put #-} 61 | get = Get \p -> GetRes (plusAddr# p 8#) (I# (indexIntOffAddr# p 0#)) 62 | {-# inline get #-} 63 | 64 | instance Serialize Word8 where 65 | size _ = 1 66 | {-# inline size #-} 67 | put (W8# n) = Put \p s -> case writeWord8OffAddr# p 0# n s of 68 | s -> (# s, plusAddr# p 1# #) 69 | {-# inline put #-} 70 | get = Get \p -> GetRes (plusAddr# p 1#) (W8# (indexWord8OffAddr# p 0#)) 71 | {-# inline get #-} 72 | 73 | toFile :: forall a. Serialize a => FilePath -> a -> IO () 74 | toFile path a = do 75 | let s = size a 76 | allocaBytes s \buf@(Ptr addr) -> do 77 | fp <- newForeignPtr_ buf 78 | IO (\s -> case runPut (put a) addr s of 79 | (# s, buf #) -> (# s, () #)) 80 | B.writeFile path (B.PS fp 0 s) 81 | 82 | fromFile :: forall a. Serialize a => FilePath -> IO a 83 | fromFile path = do 84 | bstr <- B.readFile path 85 | B.unsafeUseAsCString bstr \(Ptr addr) -> 86 | case runGet (get @a) addr of 87 | GetRes _ a -> pure a 88 | -------------------------------------------------------------------------------- /setoidtt/src/Serialization/Internal.hs: -------------------------------------------------------------------------------- 1 | 2 | module Serialization.Internal where 3 | 4 | import qualified Data.ByteString as B 5 | import qualified Data.ByteString.Internal as B 6 | import qualified Data.ByteString.Unsafe as B 7 | import Data.Word 8 | import Foreign.Marshal.Alloc 9 | import GHC.Exts 10 | import GHC.ForeignPtr 11 | import GHC.Types 12 | import Data.Foldable 13 | 14 | import qualified Data.Flat as F 15 | 16 | newtype Put = Put { 17 | runPut :: forall s. Addr# -> State# s -> (# State# s, Addr# #)} 18 | 19 | infixr 1 >>. 20 | (>>.) :: Put -> Put -> Put 21 | (>>.) (Put f) (Put g) = Put \p s -> case f p s of 22 | (# s, p #) -> g p s 23 | {-# inline (>>.) #-} 24 | 25 | newtype Get a = Get { 26 | runGet :: Addr# -> (# Addr#, a #)} 27 | 28 | instance Functor Get where 29 | fmap f (Get g) = Get \p -> case g p of 30 | (# p, a #) -> let !b = f a in (# p, b #) 31 | {-# inline fmap #-} 32 | 33 | instance Applicative Get where 34 | pure = return 35 | {-# inline pure #-} 36 | Get ff <*> Get fa = Get \p -> case ff p of 37 | (# p, f #) -> case fa p of 38 | (# p, a #) -> let !b = f a in (# p, b #) 39 | {-# inline (<*>) #-} 40 | 41 | instance Monad Get where 42 | return ~a = Get \p -> (# p, a #) 43 | {-# inline return #-} 44 | Get f >>= g = Get \p -> case f p of 45 | (# p, a #) -> runGet (g a) p 46 | {-# inline (>>=) #-} 47 | 48 | class Serialize a where 49 | size :: a -> Int 50 | put :: a -> Put 51 | get :: Get a 52 | 53 | default size :: F.Flat a => a -> Int 54 | size a = F.size @a 55 | {-# inline size #-} 56 | 57 | default put :: F.Flat a => a -> Put 58 | put a = Put \p s -> case F.writeOffAddr# p 0# a s of 59 | s -> (# s, plusAddr# p (F.size# @a proxy#) #) 60 | {-# inline put #-} 61 | 62 | default get :: F.Flat a => Get a 63 | get = Get \p -> (# plusAddr# p (F.size# @a proxy#), F.indexOffAddr# p 0# #) 64 | {-# inline get #-} 65 | 66 | instance Serialize Int 67 | instance Serialize Word8 68 | 69 | instance Serialize a => Serialize [a] where 70 | size = foldl' (\acc a -> 1 + acc + size a) 1 71 | get = do 72 | get @Word8 >>= \case 73 | 0 -> pure [] 74 | 1 -> (:) <$> get <*> get 75 | _ -> undefined 76 | put [] = put @Word8 0 77 | put (a:as) = put @Word8 1 >>. put a >>. put as 78 | 79 | toFile :: forall a. Serialize a => FilePath -> a -> IO () 80 | toFile path a = do 81 | let s = size a 82 | allocaBytes s \buf@(Ptr addr) -> do 83 | fp <- newForeignPtr_ buf 84 | IO (\s -> case runPut (put a) addr s of 85 | (# s, buf #) -> (# s, () #)) 86 | B.writeFile path (B.PS fp 0 s) 87 | 88 | fromFile :: forall a. Serialize a => FilePath -> IO a 89 | fromFile path = do 90 | bstr <- B.readFile path 91 | B.unsafeUseAsCString bstr \(Ptr addr) -> 92 | case runGet (get @a) addr of 93 | (# _, a #) -> pure a 94 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/UI.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.UI where 3 | 4 | import GHC.Types 5 | import GHC.Magic 6 | import GHC.Prim 7 | import Data.Unlifted 8 | 9 | type role Array representational 10 | data Array a = Array ArrayArray# 11 | 12 | instance Unlifted (Array a) where 13 | type Rep (Array a) = ArrayArray# 14 | to# (Array arr) = arr 15 | from# arr = Array arr 16 | {-# inline to# #-} 17 | {-# inline from# #-} 18 | defaultElem = empty 19 | {-# inline defaultElem #-} 20 | 21 | instance (Unlifted a, Show a) => Show (Array a) where 22 | show = show . Data.Array.UI.foldr (:) [] 23 | {-# inline show #-} 24 | 25 | new :: forall a. Unlifted a => Int -> a -> Array a 26 | new (I# i) a = case to# a of 27 | a -> Array (runRW# \s -> case newUnlifted# i a s of 28 | (# s, marr #) -> case unsafeFreezeArrayArray# marr s of 29 | (# s, arr #) -> arr) 30 | {-# inline new #-} 31 | 32 | empty :: Array a 33 | empty = Array (runRW# \s -> case newArrayArray# 0# s of 34 | (# s, marr #) -> case unsafeFreezeArrayArray# marr s of 35 | (# s, arr #) -> arr) 36 | {-# noinline empty #-} 37 | 38 | infixl 7 ! 39 | (!) :: Unlifted a => Array a -> Int -> a 40 | (!) (Array arr) (I# i) = from# (indexUnlifted# arr i) 41 | {-# inline (!) #-} 42 | 43 | size :: Array a -> Int 44 | size (Array arr) = I# (sizeofArrayArray# arr) 45 | {-# inline size #-} 46 | 47 | -- | Create a new array from a slice of the input array. 48 | -- `Int` arguments are: offset, slice length. 49 | clone :: Unlifted a => Array a -> Int -> Int -> Array a 50 | clone (Array arr) (I# i) (I# l) = 51 | Array (runRW# \s -> case newArrayArray# l s of 52 | (# s, marr #) -> case copyArrayArray# arr i marr 0# l s of 53 | s -> case unsafeFreezeArrayArray# marr s of 54 | (# s, arr #) -> arr) 55 | {-# inline clone #-} 56 | 57 | 58 | foldr :: forall a b. Unlifted a => (a -> b -> b) -> b -> Array a -> b 59 | foldr f z = \(Array arr) -> go 0# (sizeofArrayArray# arr) z arr where 60 | go :: Int# -> Int# -> b -> ArrayArray# -> b 61 | go i s z arr = case i <# s of 62 | 1# -> case indexUnlifted# arr i of 63 | a -> case from# a of 64 | !a -> f a (go (i +# 1#) s z arr) 65 | _ -> z 66 | {-# inline foldr #-} 67 | 68 | foldl' :: forall a b. Unlifted a => (b -> a -> b) -> b -> Array a -> b 69 | foldl' f z = \(Array arr) -> go 0# (sizeofArrayArray# arr) z arr where 70 | go i s z arr = case i <# s of 71 | 1# -> case indexUnlifted# arr i of 72 | a -> case from# a of 73 | !a -> let !b = f z a in go (i +# 1#) s b arr 74 | _ -> z 75 | {-# inline foldl' #-} 76 | 77 | fromList :: forall a. Unlifted a => [a] -> Array a 78 | fromList xs = case length xs of 79 | I# size -> Array (runRW# \s -> 80 | case newArrayArray# size s of 81 | (# s, marr #) -> go xs 0# s where 82 | go (x:xs) i s = case writeUnlifted# marr i (to# x) s of s -> go xs (i +# 1#) s 83 | go _ _ s = case unsafeFreezeArrayArray# marr s of 84 | (# _, arr #) -> arr) 85 | {-# inline fromList #-} 86 | -------------------------------------------------------------------------------- /setoidtt/src/Presyntax.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# options_ghc -funbox-strict-fields #-} 3 | 4 | module Presyntax where 5 | 6 | import Common 7 | import FlatParse 8 | 9 | data Bind 10 | = Bind Span 11 | | DontBind 12 | 13 | instance Show Bind where 14 | show (Bind x) = show x 15 | show DontBind = "_" 16 | 17 | data TopLevel 18 | = Nil 19 | | Define Span (Maybe Tm) Tm TopLevel 20 | | Postulate Span Tm TopLevel 21 | deriving Show 22 | 23 | data Tm 24 | = Var Span 25 | | App Tm Tm ArgInfo 26 | | Lam Pos Bind ArgInfo Tm 27 | | Pair Tm Tm 28 | | ProjField Tm Span 29 | | Let Pos Span (Maybe Tm) Tm Tm 30 | 31 | | Pi Pos Bind Icit Tm Tm 32 | | Sg Pos Bind Tm Tm 33 | | Proj1 Tm Pos 34 | | Proj2 Tm Pos 35 | 36 | | Set Span 37 | | Prop Span 38 | | Top Span 39 | | Tt Span 40 | | Bot Span 41 | 42 | | Exfalso Pos (Maybe Tm) Tm 43 | | Eq Tm Tm 44 | | Refl Span (Maybe Tm) (Maybe Tm) 45 | | Coe Pos (Maybe Tm) (Maybe Tm) Tm Tm 46 | | Sym Pos (Maybe Tm) (Maybe Tm) (Maybe Tm) Tm 47 | | Trans Pos (Maybe Tm) (Maybe Tm) (Maybe Tm) (Maybe Tm) Tm Tm 48 | | Ap Pos (Maybe Tm) (Maybe Tm) Tm (Maybe Tm) (Maybe Tm) Tm 49 | 50 | | Hole Span 51 | deriving Show 52 | 53 | -- | Get the source text spanned by a raw term. 54 | span :: Tm -> Span 55 | span t = Span (left t) (right t) where 56 | left :: Tm -> Pos 57 | left = \case 58 | Var (Span l _) -> l 59 | Let l _ _ _ _ -> l 60 | Pi l _ _ _ _ -> l 61 | App t _ _ -> left t 62 | Sg l _ _ _ -> l 63 | Pair t _ -> left t 64 | Proj1 t _ -> left t 65 | Proj2 t _ -> left t 66 | ProjField t _ -> left t 67 | Lam l _ _ _ -> l 68 | Set (Span l _) -> l 69 | Prop (Span l _) -> l 70 | Top (Span l _) -> l 71 | Tt (Span l _) -> l 72 | Bot (Span l _) -> l 73 | Exfalso l _ _ -> l 74 | Eq t u -> left t 75 | Refl (Span l _) _ _ -> l 76 | Coe l _ _ _ _ -> l 77 | Sym l _ _ _ _ -> l 78 | Trans l _ _ _ _ _ _ -> l 79 | Ap l _ _ _ _ _ _ -> l 80 | Hole (Span l _) -> l 81 | 82 | right :: Tm -> Pos 83 | right = \case 84 | Var (Span _ r) -> r 85 | Let _ _ _ _ u -> right u 86 | Pi _ _ _ _ b -> right b 87 | Sg _ _ _ b -> right b 88 | Pair _ u -> right u 89 | Proj1 _ r -> r 90 | Proj2 _ r -> r 91 | ProjField _ (Span _ r) -> r 92 | App _ u _ -> right u 93 | Lam _ _ _ t -> right t 94 | Set (Span _ r) -> r 95 | Prop (Span _ r) -> r 96 | Top (Span _ r) -> r 97 | Tt (Span _ r) -> r 98 | Bot (Span _ r) -> r 99 | Exfalso _ _ t -> right t 100 | Eq _ t -> right t 101 | Refl (Span _ r) _ t -> maybe r right t 102 | Coe _ _ _ _ t -> right t 103 | Sym _ _ _ _ t -> right t 104 | Trans _ _ _ _ _ _ t -> right t 105 | Ap _ _ _ _ _ _ t -> right t 106 | Hole (Span l r) -> r 107 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/LM.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.LM where 3 | 4 | import GHC.Types 5 | import GHC.Prim 6 | import GHC.Magic 7 | 8 | import Data.Unlifted 9 | import qualified Data.Array.LI as LI 10 | import Data.Array.UndefElem 11 | 12 | type role Array representational 13 | data Array a = Array (MutableArray# RealWorld a) 14 | 15 | instance Unlifted (Array a) where 16 | type Rep (Array a) = (MutableArray# RealWorld a) 17 | to# (Array arr) = arr 18 | from# = Array 19 | {-# inline to# #-} 20 | {-# inline from# #-} 21 | defaultElem = empty 22 | {-# inline defaultElem #-} 23 | 24 | new :: forall a. Int -> a -> IO (Array a) 25 | new (I# i) a = IO (\s -> case newArray# i a s of 26 | (# s, arr #) -> (# s, Array arr #)) 27 | 28 | empty :: Array a 29 | empty = Array (runRW# \s -> case newArray# 0# undefElem s of 30 | (# s, arr #) -> arr) 31 | {-# noinline empty #-} 32 | 33 | read :: forall a. Array a -> Int -> IO a 34 | read (Array arr) (I# i) = IO (readArray# arr i) 35 | {-# inline read #-} 36 | 37 | write :: forall a. Array a -> Int -> a -> IO () 38 | write (Array arr) (I# i) a = IO \s -> 39 | case writeArray# arr i a s of 40 | s -> (# s, () #) 41 | {-# inline write #-} 42 | 43 | modify :: forall a. Array a -> Int -> (a -> a) -> IO () 44 | modify (Array arr) (I# i) f = IO \s -> case readArray# arr i s of 45 | (# s, a #) -> case writeArray# arr i (f a) s of 46 | s -> (# s, () #) 47 | {-# inline modify #-} 48 | 49 | modify' :: forall a. Array a -> Int -> (a -> a) -> IO () 50 | modify' (Array arr) (I# i) f = IO \s -> case readArray# arr i s of 51 | (# s, a #) -> let !v = f a in case writeArray# arr i v s of 52 | s -> (# s, () #) 53 | {-# inline modify' #-} 54 | 55 | size :: Array a -> Int 56 | size (Array arr) = I# (sizeofMutableArray# arr) 57 | {-# inline size #-} 58 | 59 | thawSlice :: LI.Array a -> Int -> Int -> IO (Array a) 60 | thawSlice (LI.Array arr) (I# start) (I# len) = IO \s -> 61 | case thawArray# arr start len s of 62 | (# s, marr #) -> (# s, Array marr #) 63 | {-# inline thawSlice #-} 64 | 65 | thaw :: forall a. LI.Array a -> IO (Array a) 66 | thaw arr = thawSlice arr 0 (LI.size arr) 67 | {-# inline thaw #-} 68 | 69 | copySlice :: forall a. Array a -> Int -> Array a -> Int -> Int -> IO () 70 | copySlice (Array src) (I# i) (Array dst) (I# j) (I# len) = IO \s -> 71 | case copyMutableArray# src i dst j len s of 72 | s -> (# s, () #) 73 | {-# inline copySlice #-} 74 | 75 | sizedThaw :: forall a. Int -> LI.Array a -> IO (Array a) 76 | sizedThaw size arr = thawSlice arr 0 size 77 | {-# inline sizedThaw #-} 78 | 79 | unsafeFreeze :: Array a -> IO (LI.Array a) 80 | unsafeFreeze (Array marr) = IO \s -> case unsafeFreezeArray# marr s of 81 | (# s, arr #) -> (# s, LI.Array arr #) 82 | {-# inline unsafeFreeze #-} 83 | 84 | freezeSlice :: Array a -> Int -> Int -> IO (LI.Array a) 85 | freezeSlice (Array marr) (I# start) (I# len) = IO \s -> 86 | case freezeArray# marr start len s of 87 | (# s, arr #) -> (# s, (LI.Array arr) #) 88 | {-# inline freezeSlice #-} 89 | 90 | freeze :: Array a -> IO (LI.Array a) 91 | freeze arr = freezeSlice arr 0 (size arr) 92 | {-# inline freeze #-} 93 | 94 | sizedFreeze :: Int -> Array a -> IO (LI.Array a) 95 | sizedFreeze size arr = freezeSlice arr 0 size 96 | {-# inline sizedFreeze #-} 97 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/UM.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.UM where 3 | 4 | import GHC.Types 5 | import GHC.Prim 6 | import GHC.Magic 7 | 8 | import qualified Data.Array.UI as UI 9 | import Data.Unlifted 10 | 11 | type role Array representational 12 | data Array a = Array (MutableArrayArray# RealWorld) 13 | 14 | instance Unlifted (Array a) where 15 | type Rep (Array a) = (MutableArrayArray# RealWorld) 16 | to# (Array arr) = arr 17 | from# = Array 18 | {-# inline to# #-} 19 | {-# inline from# #-} 20 | defaultElem = empty 21 | {-# inline defaultElem #-} 22 | 23 | new :: forall a. Unlifted a => Int -> a -> IO (Array a) 24 | new (I# i) a = IO (\s -> case newUnlifted# i (to# a) s of 25 | (# s, arr #) -> (# s, Array arr #)) 26 | {-# inline new #-} 27 | 28 | empty :: Array a 29 | empty = Array (runRW# \s -> case newArrayArray# 0# s of 30 | (# s, arr #) -> arr) 31 | {-# noinline empty #-} 32 | 33 | read :: forall a. Unlifted a => Array a -> Int -> IO a 34 | read (Array arr) (I# i) = IO \s -> case readUnlifted# arr i s of 35 | (# s, a #) -> case from# a of 36 | !a -> (# s, a #) 37 | {-# inline read #-} 38 | 39 | write :: forall a. Unlifted a => Array a -> Int -> a -> IO () 40 | write (Array arr) (I# i) a = IO \s -> 41 | case writeUnlifted# arr i (to# a) s of 42 | s -> (# s, () #) 43 | {-# inline write #-} 44 | 45 | modify :: forall a. Unlifted a => Array a -> Int -> (a -> a) -> IO () 46 | modify (Array arr) (I# i) f = IO \s -> case readUnlifted# arr i s of 47 | (# s, a #) -> case from# a of 48 | !a -> case f a of 49 | !a -> case writeUnlifted# arr i (to# a) s of 50 | s -> (# s, () #) 51 | {-# inline modify #-} 52 | 53 | size :: Array a -> Int 54 | size (Array arr) = I# (sizeofMutableArrayArray# arr) 55 | {-# inline size #-} 56 | 57 | thawSlice :: UI.Array a -> Int -> Int -> IO (Array a) 58 | thawSlice (UI.Array arr) (I# start) (I# len) = IO \s -> 59 | case newArrayArray# len s of 60 | (# s , marr #) -> case copyArrayArray# arr start marr 0# len s of 61 | s -> (# s, Array marr #) 62 | {-# inline thawSlice #-} 63 | 64 | thaw :: forall a. UI.Array a -> IO (Array a) 65 | thaw arr = thawSlice arr 0 (UI.size arr) 66 | {-# inline thaw #-} 67 | 68 | copySlice :: forall a. Array a -> Int -> Array a -> Int -> Int -> IO () 69 | copySlice (Array src) (I# i) (Array dst) (I# j) (I# len) = IO \s -> 70 | case copyMutableArrayArray# src i dst j len s of 71 | s -> (# s, () #) 72 | {-# inline copySlice #-} 73 | 74 | sizedThaw :: forall a. Int -> UI.Array a -> IO (Array a) 75 | sizedThaw size arr = thawSlice arr 0 size 76 | {-# inline sizedThaw #-} 77 | 78 | unsafeFreeze :: Array a -> IO (UI.Array a) 79 | unsafeFreeze (Array marr) = IO \s -> case unsafeFreezeArrayArray# marr s of 80 | (# s, arr #) -> (# s, UI.Array arr #) 81 | {-# inline unsafeFreeze #-} 82 | 83 | freezeSlice :: Array a -> Int -> Int -> IO (UI.Array a) 84 | freezeSlice (Array src) (I# start) (I# len) = IO \s -> 85 | case newArrayArray# len s of 86 | (# s, marr #) -> case copyMutableArrayArray# src start marr 0# len s of 87 | s -> case unsafeFreezeArrayArray# marr s of 88 | (# s, arr #) -> (# s , UI.Array arr #) 89 | {-# inline freezeSlice #-} 90 | 91 | freeze :: Array a -> IO (UI.Array a) 92 | freeze arr = freezeSlice arr 0 (size arr) 93 | {-# inline freeze #-} 94 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/SM.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.SM where 3 | 4 | import GHC.Types 5 | import GHC.Prim 6 | import GHC.Magic 7 | 8 | import Data.Unlifted 9 | import Data.Array.UndefElem 10 | import qualified Data.Array.SI as SI 11 | 12 | type role Array representational 13 | data Array a = Array (SmallMutableArray# RealWorld a) 14 | 15 | instance Unlifted (Array a) where 16 | type Rep (Array a) = SmallMutableArray# RealWorld a 17 | to# (Array arr) = arr 18 | from# = Array 19 | {-# inline to# #-} 20 | {-# inline from# #-} 21 | defaultElem = empty 22 | {-# inline defaultElem #-} 23 | 24 | new :: forall a. Int -> a -> IO (Array a) 25 | new (I# i) a = IO (\s -> case newSmallArray# i a s of 26 | (# s, arr #) -> (# s, Array arr #)) 27 | 28 | empty :: Array a 29 | empty = runRW# \s -> case newSmallArray# 0# undefElem s of 30 | (# s, arr #) -> Array arr 31 | {-# noinline empty #-} 32 | 33 | read :: forall a. Array a -> Int -> IO a 34 | read (Array arr) (I# i) = IO (readSmallArray# arr i) 35 | {-# inline read #-} 36 | 37 | write :: forall a. Array a -> Int -> a -> IO () 38 | write (Array arr) (I# i) a = IO \s -> 39 | case writeSmallArray# arr i a s of 40 | s -> (# s, () #) 41 | {-# inline write #-} 42 | 43 | modify :: forall a. Array a -> Int -> (a -> a) -> IO () 44 | modify (Array arr) (I# i) f = IO \s -> case readSmallArray# arr i s of 45 | (# s, a #) -> case writeSmallArray# arr i (f a) s of 46 | s -> (# s, () #) 47 | {-# inline modify #-} 48 | 49 | modify' :: forall a. Array a -> Int -> (a -> a) -> IO () 50 | modify' (Array arr) (I# i) f = IO \s -> case readSmallArray# arr i s of 51 | (# s, a #) -> let !v = f a in case writeSmallArray# arr i v s of 52 | s -> (# s, () #) 53 | {-# inline modify' #-} 54 | 55 | size :: Array a -> Int 56 | size (Array arr) = I# (sizeofSmallMutableArray# arr) 57 | {-# inline size #-} 58 | 59 | thawSlice :: SI.Array a -> Int -> Int -> IO (Array a) 60 | thawSlice (SI.Array arr) (I# start) (I# len) = IO \s -> 61 | case thawSmallArray# arr start len s of 62 | (# s, marr #) -> (# s, Array marr #) 63 | {-# inline thawSlice #-} 64 | 65 | thaw :: forall a. SI.Array a -> IO (Array a) 66 | thaw arr = thawSlice arr 0 (SI.size arr) 67 | {-# inline thaw #-} 68 | 69 | copySlice :: forall a. Array a -> Int -> Array a -> Int -> Int -> IO () 70 | copySlice (Array src) (I# i) (Array dst) (I# j) (I# len) = IO \s -> 71 | case copySmallMutableArray# src i dst j len s of 72 | s -> (# s, () #) 73 | {-# inline copySlice #-} 74 | 75 | sizedThaw :: forall a. Int -> SI.Array a -> IO (Array a) 76 | sizedThaw size arr = thawSlice arr 0 size 77 | {-# inline sizedThaw #-} 78 | 79 | unsafeFreeze :: Array a -> IO (SI.Array a) 80 | unsafeFreeze (Array marr) = IO \s -> case unsafeFreezeSmallArray# marr s of 81 | (# s, arr #) -> (# s, SI.Array arr #) 82 | {-# inline unsafeFreeze #-} 83 | 84 | freezeSlice :: Array a -> Int -> Int -> IO (SI.Array a) 85 | freezeSlice (Array marr) (I# start) (I# len) = IO \s -> 86 | case freezeSmallArray# marr start len s of 87 | (# s, arr #) -> (# s, (SI.Array arr) #) 88 | {-# inline freezeSlice #-} 89 | 90 | freeze :: Array a -> IO (SI.Array a) 91 | freeze arr = freezeSlice arr 0 (size arr) 92 | {-# inline freeze #-} 93 | 94 | sizedFreeze :: Int -> Array a -> IO (SI.Array a) 95 | sizedFreeze size arr = freezeSlice arr 0 size 96 | {-# inline sizedFreeze #-} 97 | -------------------------------------------------------------------------------- /experiments/serialization-bench/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language 3 | BangPatterns, Strict, DeriveGeneric, FlexibleInstances, LambdaCase, 4 | TypeApplications 5 | #-} 6 | 7 | module Main where 8 | 9 | import Data.Compact 10 | import Data.Compact.Serialize 11 | import Data.Binary 12 | import qualified Data.Persist as P 13 | import qualified Data.ByteString as B 14 | import qualified Serialize as S 15 | import qualified SerializeStrict as SS 16 | 17 | import Gauge 18 | 19 | data Tree a = Leaf a | Node (Tree a) (Tree a) 20 | deriving (Show) 21 | 22 | instance Binary (Tree Int) where 23 | put (Leaf a) = put True >> put a 24 | put (Node l r) = put False >> put l >> put r 25 | get = do 26 | get >>= \case 27 | True -> Leaf <$> get 28 | False -> Node <$> get <*> get 29 | 30 | instance S.Serialize (Tree Int) where 31 | size t = go t 0 where 32 | go (Leaf n) acc = acc + S.size n + 1 33 | go (Node l r) acc = go l (go r (acc + 1)) 34 | put (Leaf n) = S.put @Word8 0 S.>>. S.put n 35 | put (Node l r) = S.put @Word8 1 S.>>. S.put l S.>>. S.put r 36 | get = do 37 | S.get @Word8 >>= \case 38 | 0 -> Leaf <$> S.get 39 | 1 -> Node <$> S.get <*> S.get 40 | _ -> undefined 41 | 42 | instance SS.Serialize (Tree Int) where 43 | size t = go t 0 where 44 | go (Leaf n) acc = acc + SS.size n + 1 45 | go (Node l r) acc = go l (go r (acc + 1)) 46 | put (Leaf n) = SS.put @Word8 0 SS.>>. SS.put n 47 | put (Node l r) = SS.put @Word8 1 SS.>>. SS.put l SS.>>. SS.put r 48 | get = do 49 | SS.get @Word8 >>= \case 50 | 0 -> Leaf <$> SS.get 51 | 1 -> Node <$> SS.get <*> SS.get 52 | _ -> undefined 53 | 54 | instance P.Persist (Tree Int) where 55 | put (Leaf a) = P.put @Word8 0 >> P.put a 56 | put (Node l r) = P.put @Word8 1 >> P.put l >> P.put r 57 | get = do 58 | P.get @Word8 >>= \case 59 | 0 -> Leaf <$> P.get 60 | 1 -> Node <$> P.get <*> P.get 61 | _ -> undefined 62 | 63 | full :: Int -> Tree Int 64 | full 0 = Leaf 128000 65 | full n = let t = full (n - 1) in Node t t 66 | 67 | main :: IO () 68 | main = do 69 | let t = full 21 :: Tree Int 70 | defaultMain [ 71 | bench "compact region write" $ whnfIO $ do 72 | r <- compact t 73 | writeCompact "compact.tree" r 74 | 75 | , bench "compact region read" $ whnfIO $ do 76 | unsafeReadCompact @(Tree Int) "compact.tree" 77 | 78 | , bench "Data.Binary write" $ whnfIO $ do 79 | encodeFile "binary.tree" t 80 | 81 | , bench "Data.Binary read" $ whnfIO $ do 82 | decodeFile @(Tree Int) "binary.tree" 83 | 84 | , bench "Serialize write" $ whnfIO $ do 85 | S.toFile "serialize.tree" t 86 | 87 | , bench "Serialize read" $ whnfIO $ do 88 | S.fromFile @(Tree Int) "serialize.tree" 89 | 90 | , bench "persist write" $ whnfIO $ do 91 | B.writeFile "persist.tree" $ P.encode t 92 | 93 | , bench "persist read" $ whnfIO $ do 94 | bstr <- B.readFile "persist.tree" 95 | pure $ P.decode @(Tree Int) bstr 96 | 97 | , bench "Strict Serialize write" $ whnfIO $ do 98 | SS.toFile "serialize.tree" t 99 | 100 | , bench "Strict Serialize read" $ whnfIO $ do 101 | SS.fromFile @(Tree Int) "serialize.tree" 102 | 103 | ] 104 | -------------------------------------------------------------------------------- /proto/Impredicative.agda: -------------------------------------------------------------------------------- 1 | 2 | {-# OPTIONS --type-in-type --rewriting --prop --show-irrelevant --injective-type-constructors #-} 3 | 4 | module Impredicative where 5 | 6 | open import Data.Product 7 | renaming (proj₁ to ₁; proj₂ to ₂) 8 | open import Data.Unit 9 | 10 | variable 11 | A B C : Set 12 | P Q R : Prop 13 | P₀ P₁ : Prop 14 | Q₀ : P₀ → Prop 15 | Q₁ : P₁ → Prop 16 | A₀ A₁ : Set 17 | B₀ : A₀ → Set 18 | B₁ : A₁ → Set 19 | 20 | record ΣPP (A : Prop)(B : A → Prop) : Prop where 21 | constructor _,_ 22 | field 23 | ₁ : A 24 | ₂ : B ₁ 25 | open ΣPP public 26 | 27 | record ΣSP (A : Set)(B : A → Prop) : Set where 28 | constructor _,_ 29 | field 30 | ₁ : A 31 | ₂ : B ₁ 32 | open ΣSP public 33 | 34 | _∧_ : Prop → Prop → Prop; infixr 4 _∧_ 35 | P ∧ Q = ΣPP P λ _ → Q 36 | 37 | data True : Prop where tt : True 38 | data False : Prop where 39 | 40 | record Prf (P : Prop) : Set where 41 | constructor prf 42 | field 43 | unprf : P 44 | open Prf public 45 | 46 | postulate 47 | _↦_ : {A : Set} → A → A → Set 48 | infix 3 _↦_ 49 | {-# BUILTIN REWRITE _↦_ #-} 50 | 51 | module _ {A : Set} where 52 | postulate 53 | _≡_ : A → A → Prop 54 | refl : ∀ a → a ≡ a 55 | infix 3 _≡_ 56 | 57 | postulate 58 | coe : A ≡ B → A → B 59 | ap : ∀ (f : A → B){x y} → x ≡ y → f x ≡ f y 60 | regularity : ∀ {p} → coe {A}{A} p ↦ (λ x → x) 61 | {-# REWRITE regularity #-} 62 | 63 | tr : ∀{A : Set}(P : A → Set){x y} → x ≡ y → P x → P y 64 | tr {A} P {x} {y} p px = coe (ap P p) px 65 | 66 | infixr 4 _◾_ 67 | infix 6 _⁻¹ 68 | postulate 69 | _◾_ : {A : Set}{x y z : A} → x ≡ y → y ≡ z → x ≡ z 70 | _⁻¹ : {A : Set}{x y : A} → x ≡ y → y ≡ x 71 | ext : {A : Set}{B : A → Set}{f g : ∀ x → B x} → (∀ x → f x ≡ g x) → f ≡ g 72 | 73 | -------------------------------------------------------------------------------- 74 | 75 | record NatAlg : Set where 76 | constructor natAlg 77 | field 78 | N : Set 79 | z : N 80 | s : N → N 81 | open NatAlg 82 | 83 | record NatTy (Γ : NatAlg) : Set where 84 | constructor natTy 85 | field 86 | N : N Γ → Set 87 | z : N (z Γ) 88 | s : ∀ {n} → N n → N (s Γ n) 89 | open NatTy 90 | 91 | record NatHom (Γ Δ : NatAlg) : Set where 92 | constructor natHom 93 | field 94 | N : N Γ → N Δ 95 | z : N (z Γ) ≡ z Δ 96 | s : ∀ n → N (s Γ n) ≡ s Δ (N n) 97 | open NatHom 98 | 99 | Nat : Set 100 | Nat = ΣSP ((Γ : NatAlg) → N Γ) λ f → 101 | ∀ {Γ Δ}(σ : NatHom Γ Δ) → N σ (f Γ) ≡ f Δ 102 | 103 | postulate 104 | Nat≡ : (n m : Nat) → ₁ n ≡ ₁ m → n ≡ m 105 | 106 | zero : Nat 107 | zero = z , z 108 | 109 | suc : Nat → Nat 110 | suc n = (λ Γ → s Γ (₁ n Γ)) , λ {Γ}{Δ} σ → s σ (₁ n Γ) ◾ ap (s Δ) (₂ n σ) 111 | 112 | syn : NatAlg 113 | syn = natAlg Nat zero suc 114 | 115 | rec : (Γ : NatAlg) → NatHom syn Γ 116 | rec Γ = natHom (λ n → ₁ n Γ) (refl _) (λ _ → refl _) 117 | 118 | ind : (A : NatTy syn) → ∀ n → N A n 119 | ind A n = 120 | let Γ = natAlg (Σ Nat (N A)) (zero , z A) λ np → suc (₁ np) , s A (₂ np) 121 | (res1 , res2) = ₁ n Γ 122 | 123 | proj1 : NatHom Γ syn 124 | proj1 = natHom ₁ (refl _) (λ _ → refl _) 125 | 126 | lem : res1 ≡ n 127 | lem = ₂ n proj1 ◾ Nat≡ (₁ n syn) n (ext λ Γ → ₂ n (rec Γ)) 128 | 129 | in tr (N A) lem res2 130 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/MachDeps.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.MachDeps where 3 | 4 | #include "MachDeps.h" 5 | 6 | sIZEOF_CHAR, 7 | aLIGNMENT_CHAR, 8 | sIZEOF_INT, 9 | aLIGNMENT_INT, 10 | sIZEOF_WORD, 11 | aLIGNMENT_WORD, 12 | sIZEOF_DOUBLE, 13 | aLIGNMENT_DOUBLE, 14 | sIZEOF_FLOAT, 15 | aLIGNMENT_FLOAT, 16 | sIZEOF_PTR, 17 | aLIGNMENT_PTR, 18 | sIZEOF_FUNPTR, 19 | aLIGNMENT_FUNPTR, 20 | sIZEOF_STABLEPTR, 21 | aLIGNMENT_STABLEPTR, 22 | sIZEOF_INT8, 23 | aLIGNMENT_INT8, 24 | sIZEOF_WORD8, 25 | aLIGNMENT_WORD8, 26 | sIZEOF_INT16, 27 | aLIGNMENT_INT16, 28 | sIZEOF_WORD16, 29 | aLIGNMENT_WORD16, 30 | sIZEOF_INT32, 31 | aLIGNMENT_INT32, 32 | sIZEOF_WORD32, 33 | aLIGNMENT_WORD32, 34 | sIZEOF_INT64, 35 | aLIGNMENT_INT64, 36 | sIZEOF_WORD64, 37 | aLIGNMENT_WORD64 :: Int 38 | 39 | 40 | sIZEOF_CHAR = SIZEOF_HSCHAR 41 | aLIGNMENT_CHAR = ALIGNMENT_HSCHAR 42 | sIZEOF_INT = SIZEOF_HSINT 43 | aLIGNMENT_INT = ALIGNMENT_HSINT 44 | sIZEOF_WORD = SIZEOF_HSWORD 45 | aLIGNMENT_WORD = ALIGNMENT_HSWORD 46 | sIZEOF_DOUBLE = SIZEOF_HSDOUBLE 47 | aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE 48 | sIZEOF_FLOAT = SIZEOF_HSFLOAT 49 | aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT 50 | sIZEOF_PTR = SIZEOF_HSPTR 51 | aLIGNMENT_PTR = ALIGNMENT_HSPTR 52 | sIZEOF_FUNPTR = SIZEOF_HSFUNPTR 53 | aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR 54 | sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR 55 | aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR 56 | sIZEOF_INT8 = SIZEOF_INT8 57 | aLIGNMENT_INT8 = ALIGNMENT_INT8 58 | sIZEOF_WORD8 = SIZEOF_WORD8 59 | aLIGNMENT_WORD8 = ALIGNMENT_WORD8 60 | sIZEOF_INT16 = SIZEOF_INT16 61 | aLIGNMENT_INT16 = ALIGNMENT_INT16 62 | sIZEOF_WORD16 = SIZEOF_WORD16 63 | aLIGNMENT_WORD16 = ALIGNMENT_WORD16 64 | sIZEOF_INT32 = SIZEOF_INT32 65 | aLIGNMENT_INT32 = ALIGNMENT_INT32 66 | sIZEOF_WORD32 = SIZEOF_WORD32 67 | aLIGNMENT_WORD32 = ALIGNMENT_WORD32 68 | sIZEOF_INT64 = SIZEOF_INT64 69 | aLIGNMENT_INT64 = ALIGNMENT_INT64 70 | sIZEOF_WORD64 = SIZEOF_WORD64 71 | aLIGNMENT_WORD64 = ALIGNMENT_WORD64 72 | 73 | 74 | {-# inline sIZEOF_CHAR #-} 75 | {-# inline aLIGNMENT_CHAR #-} 76 | {-# inline sIZEOF_INT #-} 77 | {-# inline aLIGNMENT_INT #-} 78 | {-# inline sIZEOF_WORD #-} 79 | {-# inline aLIGNMENT_WORD #-} 80 | {-# inline sIZEOF_DOUBLE #-} 81 | {-# inline aLIGNMENT_DOUBLE #-} 82 | {-# inline sIZEOF_FLOAT #-} 83 | {-# inline aLIGNMENT_FLOAT #-} 84 | {-# inline sIZEOF_PTR #-} 85 | {-# inline aLIGNMENT_PTR #-} 86 | {-# inline sIZEOF_FUNPTR #-} 87 | {-# inline aLIGNMENT_FUNPTR #-} 88 | {-# inline sIZEOF_STABLEPTR #-} 89 | {-# inline aLIGNMENT_STABLEPTR #-} 90 | {-# inline sIZEOF_INT8 #-} 91 | {-# inline aLIGNMENT_INT8 #-} 92 | {-# inline sIZEOF_WORD8 #-} 93 | {-# inline aLIGNMENT_WORD8 #-} 94 | {-# inline sIZEOF_INT16 #-} 95 | {-# inline aLIGNMENT_INT16 #-} 96 | {-# inline sIZEOF_WORD16 #-} 97 | {-# inline aLIGNMENT_WORD16 #-} 98 | {-# inline sIZEOF_INT32 #-} 99 | {-# inline aLIGNMENT_INT32 #-} 100 | {-# inline sIZEOF_WORD32 #-} 101 | {-# inline aLIGNMENT_WORD32 #-} 102 | {-# inline sIZEOF_INT64 #-} 103 | {-# inline aLIGNMENT_INT64 #-} 104 | {-# inline sIZEOF_WORD64 #-} 105 | {-# inline aLIGNMENT_WORD64 #-} 106 | -------------------------------------------------------------------------------- /proto/examples/Nats.stt: -------------------------------------------------------------------------------- 1 | 2 | ------------------------------------------------------------ 3 | 4 | let id : {A : Set} → A → A = λ x. x in 5 | let idP : {A : Prop} → A → A = λ x. x in 6 | let the : (A : Set) → A → A = λ A x. x in 7 | let theP : (A : Prop) → A → A = λ A x. x in 8 | 9 | let tr : {A:Set}(B : A → Set){x y} → Eq x y → B x → B y 10 | = λ B p. coe (ap B p) in 11 | 12 | let isContr : Set → Set 13 | = λ A. (a : A) × ((b : A) → Eq b a) in 14 | 15 | let Sing : {A : Set} → A → Set 16 | = λ a. (b : _) × Eq a b in 17 | 18 | let singContr : {A a} → isContr (Sing {A} a) 19 | = λ {A}{a}. ((a, refl), λ s. sym (s.₂)) in 20 | 21 | let Lift : Prop → Set = λ P. Sing Set × P in 22 | let lift : {P} → P → Lift P = λ p. ((Set, refl), p) in 23 | let lower : {P} → Lift P → P = λ lp. lp.₂ in 24 | 25 | let liftlower : {P}(p : Lift P) → Eq (lift (lower p)) p 26 | = λ p. p.₁.₂ in 27 | 28 | ------------------------------------------------------------ 29 | 30 | let rec : {A : Set} → A → (A → A) → Nat → A 31 | = λ {A} z s n. ind (λ _. A) z s n 32 | in 33 | 34 | let add : Nat → Nat → Nat 35 | = rec (λ x. x) (λ hyp x. suc (hyp x)) 36 | in 37 | 38 | let mul : Nat → Nat → Nat 39 | = rec (λ x. 0) (λ hyp x. add x (hyp x)) 40 | in 41 | 42 | let zero-add : {n} → Eq (add 0 n) n 43 | = refl 44 | in 45 | 46 | let add-zero 47 | = ind (λ n. Eq (add n 0) n) refl (λ hyp. hyp) 48 | in 49 | 50 | let add-assoc 51 | = ind (λ a. (b c : Nat) → Eq (add (add a b) c) (add a (add b c))) 52 | (λ _ _. refl) 53 | (λ hyp. hyp) 54 | in 55 | 56 | -- example which does not work in Agda 57 | let Nat-sym-lem : {a} → Eq zero (suc a) → Eq (suc a) zero 58 | = sym 59 | in 60 | 61 | ------------------------------------------------------------ 62 | 63 | let Vec : Set → Nat → Set 64 | = λ A n. rec (Lift ⊤) (λ B. A × B) n 65 | in 66 | 67 | let nil : {A} → Vec A 0 68 | = lift tt 69 | in 70 | 71 | let cons : {A n} → A → Vec A n → Vec A (suc n) 72 | = λ a as. (a, as) 73 | in 74 | 75 | -- in Agda, this works because of constructor-headed function inference 76 | -- (a form of injectivity analysis) 77 | -- let v1 : Vec Nat 1 78 | -- = cons 10 nil 79 | -- in 80 | 81 | let v3 : Vec Nat 3 82 | = (5, (5, (3, nil))) 83 | in 84 | 85 | let append : {A} (n m : _) → Vec A n → Vec A m → Vec A (add n m) 86 | = λ {A} n m xs ys. 87 | ind (λ n. Vec A n → Vec A m → Vec A (add n m)) 88 | (λ xs ys. ys) 89 | (λ {n} app xs ys. ((xs.₁), app (xs.₂) ys)) 90 | n xs ys 91 | in 92 | 93 | let coenil : 94 | {A B}(p : Eq {Set} A B) → Eq (coe (ap (λ A. Vec A 0) p) (nil {A})) (nil {B}) 95 | = λ p. tt 96 | in 97 | 98 | 99 | -- The problem is that (xs : Vec A 0) is not definitionally equal to (nil : Vec A 0) 100 | -- (Lift ⊤) only has propositional η 101 | 102 | -- let append-assoc : 103 | -- {A n m k xs ys zs} 104 | -- → Eq (coe (ap (Vec A) (add-assoc n m k)) 105 | -- (append (add n m) k (append n m xs ys) zs)) 106 | -- (append n (add m k) xs (append m k ys zs)) 107 | 108 | -- = λ {A}{n}{m}{k}{xs}{ys}{zs}. 109 | -- ind (λ n. (xs : Vec A n) → Eq (coe (ap (Vec A) (add-assoc n m k)) 110 | -- (append (add n m) k (append n m xs ys) zs)) 111 | -- (append n (add m k) xs (append m k ys zs))) 112 | -- (λ xs. _) 113 | -- _ 114 | -- n xs 115 | -- in 116 | 117 | 5 118 | -------------------------------------------------------------------------------- /setoidtt/src/Lexer.hs: -------------------------------------------------------------------------------- 1 | 2 | module Lexer where 3 | 4 | import FlatParse hiding (Parser, runParser, testParser, string, char, switch, cut, err) 5 | import qualified FlatParse 6 | 7 | import Language.Haskell.TH 8 | import qualified Data.ByteString as B 9 | 10 | -------------------------------------------------------------------------------- 11 | 12 | data ParseError = ParseError Pos String deriving Show 13 | type Parser = FlatParse.Parser Int ParseError 14 | 15 | runParser :: Parser a -> B.ByteString -> Result ParseError a 16 | runParser p = FlatParse.runParser p 0 0 17 | 18 | showError :: String -> B.ByteString -> ParseError -> String 19 | showError path str (ParseError pos msg) = let 20 | (!l, !c) = posLineCol str pos 21 | lnum = show l 22 | lpad = map (const ' ') lnum 23 | lines = linesUTF8 str 24 | in case lines of 25 | [] -> "empty input" 26 | _ -> 27 | let line = (lines !! l) 28 | in path ++ ":" ++ show l ++ ":" ++ show c ++ ":" ++ "\n" 29 | ++ lpad ++ " |\n" 30 | ++ lnum ++ " | " ++ line ++ "\n" 31 | ++ lpad ++ " | " ++ replicate c ' ' ++ "^\n" 32 | ++ msg 33 | {-# noinline showError #-} 34 | 35 | testParser :: Show a => Parser a -> String -> IO () 36 | testParser p str = let 37 | bstr = packUTF8 str 38 | in case FlatParse.testParser p 0 0 bstr of 39 | OK a _ _ -> print a 40 | Fail -> putStrLn "parser failure" 41 | Err e -> putStrLn (showError "(stdin)" bstr e) 42 | {-# noinline testParser #-} 43 | 44 | cut :: Parser a -> String -> Parser a 45 | cut (FlatParse.Parser f) msg = FlatParse.Parser \r eob s n -> case f r eob s n of 46 | Fail# -> Err# (ParseError (addr2Pos# eob s) msg) 47 | x -> x 48 | {-# inline cut #-} 49 | 50 | err :: String -> Parser a 51 | err msg = FlatParse.Parser \r eob s n -> Err# (ParseError (addr2Pos# eob s) msg) 52 | {-# inline err #-} 53 | 54 | -- OPTIMIZATION TODO: 55 | -- - try to read space in chunks (2/4) 56 | -- - implement another set of ws/comment functions which don't modify columns, 57 | -- only call the column-adjusting code after newlines 58 | ws :: Parser () 59 | ws = $(FlatParse.switch [| case _ of 60 | " " -> modify (+1) >> ws 61 | "\n" -> put 0 >> ws 62 | "\t" -> modify (+1) >> ws 63 | "\r" -> modify (+1) >> ws 64 | "--" -> lineComment 65 | "{-" -> modify (+2) >> multilineComment 66 | _ -> pure () |]) 67 | 68 | lineComment :: Parser () 69 | lineComment = 70 | br $(FlatParse.char '\n') (put 0 >> ws) $ 71 | br anyChar_ (modify (+1) >> lineComment) $ 72 | pure () 73 | 74 | -- TODO: nested multiline comments 75 | multilineComment :: Parser () 76 | multilineComment = $(FlatParse.switch [| case _ of 77 | "\n" -> put 0 >> multilineComment 78 | "-}" -> modify (+2) >> ws 79 | _ -> br anyChar_ (modify (+1) >> multilineComment) $ pure () |]) 80 | 81 | checkIndent :: Parser () 82 | checkIndent = do 83 | lvl <- ask 84 | currentLvl <- get 85 | if currentLvl < lvl 86 | then empty 87 | else pure () 88 | {-# inline checkIndent #-} 89 | 90 | lexeme :: Parser a -> Parser a 91 | lexeme p = checkIndent *> p <* ws 92 | {-# inline lexeme #-} 93 | 94 | char :: Char -> Q Exp 95 | char c = [| lexeme $(FlatParse.char c) |] 96 | 97 | string :: String -> Q Exp 98 | string str = [| lexeme $(FlatParse.string str) |] 99 | 100 | switch :: Q Exp -> Q Exp 101 | switch exp = [| do 102 | checkIndent 103 | $(FlatParse.switch' (Just [| ws |]) exp) |] 104 | -------------------------------------------------------------------------------- /proto/Errors.hs: -------------------------------------------------------------------------------- 1 | 2 | module Errors where 3 | 4 | import Control.Exception 5 | import Text.Printf 6 | 7 | import Lens.Micro.Platform 8 | import Types 9 | import Pretty 10 | 11 | -------------------------------------------------------------------------------- 12 | 13 | data SpineError 14 | = SpineNonVar 15 | | SpineProjection 16 | | SpineInd 17 | | NonLinearSpine Lvl 18 | deriving (Show, Exception) 19 | 20 | data StrengtheningError 21 | = ScopeError Lvl 22 | | OccursCheck 23 | deriving (Show, Exception) 24 | 25 | data UnifyError 26 | = UnifyError [Name] Tm Tm 27 | | SpineError [Name] Tm Tm SpineError 28 | | StrengtheningError [Name] Tm Tm StrengtheningError 29 | | RelevantMetaInIrrelevantMode MId 30 | deriving (Show, Exception) 31 | 32 | data ElabError 33 | = UnifyErrorWhile Tm Tm UnifyError 34 | | NameNotInScope Name 35 | | ExpectedFunction Tm 36 | | ExpectedType Tm Tm 37 | | IcitMismatch Icit Icit 38 | | ExpectedSg Tm 39 | | NoSuchField Name 40 | 41 | data Err = Err { 42 | errNames :: [Name], 43 | errErr :: ElabError, 44 | errPos :: Maybe SPos} 45 | 46 | instance Show Err where 47 | show _ = "Error" 48 | 49 | instance Exception Err 50 | 51 | report :: Cxt -> ElabError -> a 52 | report cxt e = throw (Err (cxt^.names) e Nothing) 53 | 54 | -- | Rethrow an `Err` with source position attached. 55 | addSrcPos :: SPos -> IO a -> IO a 56 | addSrcPos p act = act `catch` \case 57 | Err ns e Nothing -> throwIO (Err ns e (Just p)) 58 | e -> throwIO e 59 | 60 | showUnifyError :: [Name] -> UnifyError -> String 61 | showUnifyError ns e = case e of 62 | UnifyError ns lhs rhs -> printf 63 | ("Cannot unify\n\n" ++ 64 | " %s\n\n" ++ 65 | "with\n\n" ++ 66 | " %s\n\n") 67 | (showTm ns lhs) (showTm ns rhs) 68 | StrengtheningError ns lhs rhs e -> case e of 69 | ScopeError x -> printf ( 70 | "Variable %s is out of scope in equation\n\n" ++ 71 | " %s =? %s\n\n") 72 | (lvlName ns x) (showTm ns lhs) (showTm ns rhs) 73 | OccursCheck -> printf ( 74 | "Meta occurs cyclically in its solution candidate in equation:\n\n" ++ 75 | " %s =? %s\n\n") 76 | (showTm ns lhs) (showTm ns rhs) 77 | SpineError ns lhs rhs e -> case e of 78 | SpineNonVar -> printf ( 79 | "Non-bound-variable value in meta spine in equation:\n\n" ++ 80 | " %s =? %s\n\n") 81 | (showTm ns lhs) (showTm ns rhs) 82 | SpineProjection -> 83 | "Projection in meta spine\n\n" 84 | SpineInd -> 85 | "Nat eliminator in meta spine\n\n" 86 | NonLinearSpine x -> printf 87 | ("Nonlinear variable %s in meta spine in equation\n\n" ++ 88 | " %s =? %s\n\n") 89 | (lvlName ns x) 90 | (showTm ns lhs) (showTm ns rhs) 91 | RelevantMetaInIrrelevantMode m -> 92 | error (printf "Relevant meta cannot be solved in irrelevant mode: %s" (show m)) 93 | 94 | showError :: [Name] -> ElabError -> String 95 | showError ns = \case 96 | UnifyErrorWhile lhs rhs e -> 97 | let err1 = showUnifyError ns e 98 | in err1 ++ printf 99 | ("while trying to unify\n\n" ++ 100 | " %s\n\n" ++ 101 | "with\n\n" ++ 102 | " %s") (showTm ns lhs) (showTm ns rhs) 103 | NameNotInScope x -> 104 | "Name not in scope: " ++ x 105 | ExpectedFunction ty -> 106 | "Expected a function type, instead inferred:\n\n " ++ showTm ns ty 107 | ExpectedType a un -> printf ( 108 | "Expected type Set or Prop for expression:\n\n" ++ 109 | " %s\n\n" ++ 110 | "inferred type\n\n" ++ 111 | " %s") (showTm ns a) (showTm ns un) 112 | IcitMismatch i i' -> printf ( 113 | "Function icitness mismatch: expected %s, got %s.") 114 | (show i) (show i') 115 | ExpectedSg ty -> 116 | "Expected a pair type, instead inferred:\n\n " ++ showTm ns ty 117 | NoSuchField x -> 118 | "No such field: " ++ show x 119 | -------------------------------------------------------------------------------- /setoidtt/notes.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- String and name handling 4 | -------------------------------------------------------------------------------- 5 | 6 | A `Pos` is a byte offset into an implicit ByteString, a `Span` is a pair of 7 | `Pos`s. In parsing, it's more efficient to only store these, since it's obvious 8 | which ByteString we're operating on. During elaboration, spans are converted to 9 | bona fide ByteStrings. ByteStrings are used for scope indexing and module 10 | hierarchy indexing. 11 | 12 | In a serialized module, we deep-copy all ByteStrings for internally bound names, 13 | and also for all external (imported) names. I doubt that it makes a whole lot of 14 | difference to hash-cons names. After all, names are only stored at points of 15 | binding, and also once for each external name used in a module. 16 | 17 | In deserialization, we can simply take ByteString slices of the ByteString being 18 | deserialized, to read names. So we avoid allocating new strings for each name, 19 | we just slice the binary file. 20 | 21 | From bytestring-0.11.0.0, the representation is quite good: a ByteString only 22 | has a single word top-level overhead compared to Span. So we don't bother 23 | storing spans after elaboration. 24 | 25 | - TODO: newtype wrap ByteString to implement better Hashable and Eq instances. 26 | The current instances call out to C code, but for short strings it's obviously 27 | better to use inlined Haskell. 28 | 29 | What about names which are generated during elaboration, and do not come from 30 | any source file? We don't want to generate lots of ByteStrings, and we want names 31 | to be fast to generate (constant time, ideally). Since names are *not* compared 32 | or computed with, except in displaying, the solution is to use an ADT definition 33 | for generated names, such that leaves have ByteStrings, and nodes correspond to 34 | combining or decorating names. 35 | 36 | - QUESTION: what about using ByteString in parsing? I.e. can we build strings 37 | instead of spans? A string has a) a finalizer b) a start address c) a length. 38 | A parser keeps track of the current address and the end address. So we can get 39 | rather easily a string from a span, if we additionally keep around the 40 | finalizer in the Reader. This could be convenient. But it feels wasteful 41 | copying the finalizer all over the presyntax. 42 | 43 | - QUESTION: what about ghc-style FastString: 44 | 45 | https://hackage.haskell.org/package/ghc-8.10.1/docs/FastString.html 46 | 47 | I say we're doing the wrong thing if we need O(1) string comparison! Scope 48 | checking in elaboration converts every name into an index, the name of an 49 | index is only ever relevant for printing. The memory consumption of all 50 | identifiers is also practically irrelevant, since almost every string slices a 51 | source file or an interface file, which are loaded anyway. 52 | 53 | What about PtrString? (in the same module) This could make sense as an unsafe 54 | version of Span, but it feels like a big safety & memory management hassle for 55 | negligible efficiency. 56 | 57 | In general, an elaborator doesn't massage or compare strings a lot! The point 58 | of scope checking is to process each string *once*, then forget about them 59 | altogether, until pretty printing. 60 | 61 | -- Strictness at call and return sites 62 | -------------------------------------------------------------------------------- 63 | 64 | Consider the following type: 65 | 66 | data S a = S !a 67 | 68 | If we wrap all types of a function with S, we can observe in the generated Core 69 | that this eliminates all potential forcing from the worker function. The reason is 70 | that S disappears during worker-wrapping, turning into just an "a" in arguments and 71 | (# a #) in the result. The arguments are annotated with "Unf=OtherCon []": 72 | 73 | https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc-8.10.1/CoreSyn.html#v:OtherCon 74 | 75 | Meaning that Core knows that they're already forced. In theory, S should completely eliminate 76 | superfluous forcing from workers, by a) moving input forcing obligations to call sites b) returning 77 | forced values. 78 | 79 | In practice, does this work? I've done small-scale benchmark in github.com/AndrasKovacs/normalization-bench, 80 | but there's no conclusive evidence. It might be the case that STG/cmm passes kill all superfluous forcing. 81 | 82 | TODO: when setoidtt core works, benchmark S-wrapping in eval. 83 | -------------------------------------------------------------------------------- /proto/examples/Impredicative.stt: -------------------------------------------------------------------------------- 1 | 2 | -- Awodey-Frey-Speight encoding for natural numbers 3 | -- https://www.andrew.cmu.edu/user/awodey/preprints/impred.pdf 4 | 5 | -- The AWS-encoding works with funext and impredicative Set. We have Set:Set and 6 | -- funext, so it works here as well, but since our funext computes, our 7 | -- eliminators fully compute on closed values (elim β-rules for open canonical 8 | -- terms are not definitional though). 9 | 10 | -- lib 11 | -------------------------------------------------------------------------------- 12 | 13 | let id : {A : Set} → A → A = λ x. x in 14 | let idP : {A : Prop} → A → A = λ x. x in 15 | let the : (A : Set) → A → A = λ A x. x in 16 | let theP : (A : Prop) → A → A = λ A x. x in 17 | 18 | let tr : {A:Set}(B : A → Set){x y} → Eq x y → B x → B y 19 | = λ B p. coe (ap B p) in 20 | 21 | let isContr : Set → Set 22 | = λ A. (a : A) × ((b : A) → Eq b a) in 23 | 24 | let Sing : {A : Set} → A → Set 25 | = λ a. (b : _) × Eq a b in 26 | 27 | let singContr : {A a} → isContr (Sing {A} a) 28 | = λ {A}{a}. ((a, refl), λ s. sym (s.₂)) in 29 | 30 | 31 | -- Lifting Prop to Set 32 | 33 | let Lift : Prop → Set = λ P. Sing Set × P in 34 | let lift : {P} → P → Lift P = λ p. ((Set, refl), p) in 35 | let lower : {P} → Lift P → P = λ lp. lp.₂ in 36 | 37 | -- this direction is propositional, the other 38 | -- one is definitional (and cannot be even stated internally, using Eq) 39 | let liftlower : {P}(p : Lift P) → Eq (lift (lower p)) p 40 | = λ p. p.₁.₂ in 41 | 42 | -- AFS natural numbers 43 | -------------------------------------------------------------------------------- 44 | 45 | let Conᴺ : Set 46 | = (N : Set) × (z : N) × (s : N → N) × ⊤ in 47 | 48 | let Subᴺ : Conᴺ → Conᴺ → Set 49 | = λ Γ Δ. (N : Γ.N → Δ.N) 50 | × (z : Eq (N (Γ.z)) (Δ.z)) 51 | × (s : (n : Γ.N) → Eq (N (Γ.s n)) (Δ.s (N n))) 52 | × ⊤ in 53 | 54 | let Tyᴺ : Conᴺ → Set 55 | = λ Γ. (N : Γ.N → Set) 56 | × (z : N (Γ.z)) 57 | × (s : {n} → N n → N (Γ.s n)) 58 | × ⊤ in 59 | 60 | let nat : Set 61 | = (f : (Γ : Conᴺ) → Γ.N) 62 | × ((Γ Δ : Conᴺ)(σ : Subᴺ Γ Δ) → Eq (σ.N (f Γ)) (f Δ)) in 63 | 64 | let Z : nat 65 | = (λ Γ. Γ.z, λ _ _ σ. σ.z) in 66 | 67 | let S : nat → nat 68 | = λ n. (λ Γ. Γ.s (n.₁ Γ), 69 | λ Γ Δ σ. trans (σ.s (n.₁ Γ)) (ap (Δ.s) (n.₂ Γ Δ σ))) in 70 | 71 | let syn : Conᴺ 72 | = (nat, (Z, (S, _))) in 73 | 74 | let rec : (Γ : Conᴺ) → Subᴺ syn Γ 75 | = λ Γ. (λ n. n.₁ Γ, (refl, (λ _. refl, _))) in 76 | 77 | let recZβ : (Γ : Conᴺ) → Eq (rec Γ .₁ Z) (Γ.z) 78 | = λ _. refl in 79 | 80 | let recSβ : (Γ : Conᴺ)(n : nat) → Eq (rec Γ .₁ (S n)) (Γ.s (rec Γ .₁ n)) 81 | = λ _ _. refl in 82 | 83 | let Ind : (A : Tyᴺ syn) → (n : nat) → A.₁ n 84 | = λ A n. 85 | let Γ : Conᴺ 86 | = ((n : nat) × A.N n, ((Z, A.z), (λ np. (S (np.₁), A.s (np.₂)), _))) in 87 | let res = n.₁ Γ in 88 | let proj1 : Subᴺ Γ syn = (λ n. n.₁, (refl, (λ _. refl, _))) in 89 | let lem : Eq (res.₁) n = trans (n.₂ Γ syn proj1) (λ Γ. n.₂ syn Γ (rec Γ)) in 90 | coe (ap (A.N) lem) (res.₂) in 91 | 92 | -- injectivity of S + β for Ind are not definitional 93 | 94 | let add : nat → nat → nat 95 | = rec (nat → nat, (id, (λ f b. S (f b), _))) .₁ in 96 | 97 | let mul : nat → nat → nat 98 | = rec (nat → nat, (λ b. Z, (λ nmul b. add b (nmul b), _))) .₁ in 99 | 100 | let n5 : nat = S (S (S (S (S Z)))) in 101 | let n10 : nat = add n5 n5 in 102 | let n100 : nat = mul n10 n10 in 103 | 104 | -- proof about numbers!! 105 | -- it's probably the most practical to write functions using rec and irrelevant 106 | -- proofs using Ind 107 | let add0 : (n : nat) → Eq n (add n Z) 108 | = λ n. lower 109 | (Ind (λ n. Lift (Eq n (add n Z)), (lift refl, (λ p. lift (ap S (lower p)), _))) n) 110 | in 111 | 112 | -- Church naturals 113 | -------------------------------------------------------------------------------- 114 | 115 | let Cnat : Set = (N : Set) → N → (N → N) → N in 116 | let cZ : Cnat = λ N z s. z in 117 | let cS : Cnat → Cnat = λ a N z s. s (a N z s) in 118 | let cadd : Cnat → Cnat → Cnat = λ a b N z s. a N (b N z s) s in 119 | let cmul : Cnat → Cnat → Cnat = λ a b N z s. a N z (λ x. b N x s) in 120 | 121 | let c5 : Cnat = cS (cS (cS (cS (cS cZ)))) in 122 | let c10 : Cnat = cadd c5 c5 in 123 | let c100 : Cnat = cmul c10 c10 in 124 | 125 | let n2c : nat → Cnat 126 | = λ n. n .₁ (Cnat, (cZ, (λ n. cS n, _))) in 127 | 128 | n2c n100 129 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Array/FI.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.FI where 3 | 4 | import GHC.Types 5 | import GHC.Magic 6 | import GHC.Prim 7 | 8 | import Data.Flat 9 | import Data.Unlifted 10 | 11 | type role Array representational 12 | data Array a = Array ByteArray# 13 | 14 | instance Unlifted (Array a) where 15 | type Rep (Array a) = ByteArray# 16 | to# (Array arr) = arr 17 | from# = Array 18 | {-# inline to# #-} 19 | {-# inline from# #-} 20 | defaultElem = empty 21 | {-# inline defaultElem #-} 22 | 23 | instance (Flat a, Show a) => Show (Array a) where 24 | show = show . Data.Array.FI.foldr (:) [] 25 | {-# inline show #-} 26 | 27 | new# :: forall a. Flat a => Int# -> ByteArray# 28 | new# n = runRW# \s -> case newByteArray# (n *# Data.Flat.size# @a proxy#) s of 29 | (# s, marr #) -> case unsafeFreezeByteArray# marr s of 30 | (# _, arr #) -> arr 31 | {-# inline new# #-} 32 | 33 | new :: forall a. Flat a => Int -> Array a 34 | new (I# n) = Array (new# @a n) 35 | {-# inline new #-} 36 | 37 | empty :: Array a 38 | empty = Array (runRW# \s -> case newByteArray# 0# s of 39 | (# s, marr #) -> case unsafeFreezeByteArray# marr s of 40 | (# _, arr #) -> arr) 41 | {-# noinline empty #-} 42 | 43 | infixl 7 !# 44 | (!#) :: forall a. Flat a => ByteArray# -> Int# -> a 45 | (!#) arr i = indexByteArray# @a arr i 46 | {-# inline (!#) #-} 47 | 48 | infixl 7 ! 49 | (!) :: forall a. Flat a => Array a -> Int -> a 50 | (!) (Array arr) (I# i) = indexByteArray# @a arr i 51 | {-# inline (!) #-} 52 | 53 | size# :: forall a. Flat a => ByteArray# -> Int# 54 | size# arr = quotInt# (sizeofByteArray# arr) (Data.Flat.size# @a proxy#) 55 | {-# inline size# #-} 56 | 57 | size :: forall a. Flat a => Array a -> Int 58 | size (Array arr) = I# (Data.Array.FI.size# @a arr) 59 | {-# inline size #-} 60 | 61 | sizedMap# :: forall a b. (Flat a, Flat b) => Int# -> (a -> b) -> ByteArray# -> ByteArray# 62 | sizedMap# size f = \arr -> 63 | let go :: Int# -> MutableByteArray# s -> Int# -> State# s -> State# s 64 | go i marr size s = case i <# size of 65 | 1# -> case writeByteArray# marr i (f ((!#) @a arr i)) s of 66 | s -> go (i +# 1#) marr size s 67 | _ -> s 68 | in runRW# \s -> 69 | case newByteArray# (size *# (Data.Flat.size# @a proxy#)) s of 70 | (# s, marr #) -> case go 0# marr size s of 71 | s -> case unsafeFreezeByteArray# marr s of 72 | (# _, arr #) -> arr 73 | {-# inline sizedMap# #-} 74 | 75 | sizedMap :: forall a b. (Flat a, Flat b) => Int -> (a -> b) -> Array a -> Array b 76 | sizedMap (I# s) f = \(Array arr) -> Array (sizedMap# s f arr) 77 | {-# inline sizedMap #-} 78 | 79 | map :: forall a b. (Flat a, Flat b) => (a -> b) -> Array a -> Array b 80 | map f = \arr -> sizedMap @a @b (Data.Array.FI.size arr) f arr 81 | {-# inline map #-} 82 | 83 | foldr :: forall a b. Flat a => (a -> b -> b) -> b -> Array a -> b 84 | foldr f = \z (Array arr) -> go 0# (Data.Array.FI.size# @a arr) z arr where 85 | go i s z arr = case i <# s of 86 | 1# -> f (arr !# i :: a) (go (i +# 1#) s z arr) 87 | _ -> z 88 | {-# inline foldr #-} 89 | 90 | rfoldr :: forall a b. Flat a => (a -> b -> b) -> b -> Array a -> b 91 | rfoldr f = \z (Array arr) -> go (Data.Array.FI.size# @a arr -# 1#) z arr where 92 | go i z arr = case i >=# 0# of 93 | 1# -> f (arr !# i :: a) (go (i -# 1#) z arr) 94 | _ -> z 95 | {-# inline rfoldr #-} 96 | 97 | foldl' :: forall a b. Flat a => (b -> a -> b) -> b -> Array a -> b 98 | foldl' f = \z (Array arr) -> go 0# (Data.Array.FI.size# @a arr) z arr where 99 | go i s !z arr = case i <# s of 100 | 1# -> go (i +# 1#) s (f z (arr !# i :: a)) arr 101 | _ -> z 102 | {-# inline foldl' #-} 103 | 104 | rfoldl' :: forall a b. Flat a => (b -> a -> b) -> b -> Array a -> b 105 | rfoldl' f = \z (Array arr) -> go (Data.Array.FI.size# @a arr -# 1#) z arr where 106 | go i !z arr = case i >=# 0# of 107 | 1# -> go (i -# 1#) (f z (arr !# i :: a)) arr 108 | _ -> z 109 | {-# inline rfoldl' #-} 110 | 111 | fromList :: forall a. Flat a => [a] -> Array a 112 | fromList xs = case length xs of 113 | I# len -> Array (runRW# \s -> 114 | case newByteArray# (Data.Flat.size# @a proxy# *# len) s of 115 | (# s, marr #) -> go xs 0# s where 116 | go (x:xs) i s = case Data.Flat.writeByteArray# marr i x s of 117 | s -> go xs (i +# 1#) s 118 | go _ _ s = case unsafeFreezeByteArray# marr s of (# _, arr #) -> arr) 119 | {-# inline fromList #-} 120 | -------------------------------------------------------------------------------- /setoidtt/src/Common.hs: -------------------------------------------------------------------------------- 1 | 2 | module Common ( 3 | module Common 4 | , FlatParse.Span(..) 5 | , module Data.Coerce 6 | ) where 7 | 8 | import GHC.Exts 9 | import qualified Data.ByteString as B 10 | import qualified Language.Haskell.TH as TH 11 | 12 | import Data.Bits 13 | import Data.Hashable 14 | import FNV164 15 | import FlatParse 16 | import Data.Coerce 17 | -- import GHC.Stack 18 | import Test.Inspection 19 | 20 | -------------------------------------------------------------------------------- 21 | 22 | type Dbg = () :: Constraint 23 | -- type Dbg = HasCallStack 24 | 25 | impossible :: Dbg => a 26 | impossible = error "impossible" 27 | {-# noinline impossible #-} 28 | 29 | -- Wrapper for RealWorld in Type 30 | -------------------------------------------------------------------------------- 31 | 32 | data RW = RW (State# RealWorld) 33 | 34 | -- strictness/laziness 35 | -------------------------------------------------------------------------------- 36 | 37 | data Pair a b = a :*: b 38 | 39 | infixl 9 $$! 40 | ($$!) :: (a -> b) -> a -> b 41 | ($$!) f a = f $! a 42 | {-# inline ($$!) #-} 43 | 44 | data S a = S !a 45 | unS :: S a -> a 46 | unS (S a) = a 47 | {-# inline unS #-} 48 | 49 | sFun1 :: (a -> b) -> a -> S b 50 | sFun1 f ~a = S (f a) 51 | {-# inline sFun1 #-} 52 | 53 | unSFun1 :: (a -> S b) -> a -> b 54 | unSFun1 f ~a = unS (f a) 55 | {-# inline unSFun1 #-} 56 | 57 | instance Show a => Show (S a) where 58 | showsPrec n (S a) = showsPrec n a 59 | 60 | instance Eq a => Eq (S a) where 61 | S x == S y = x == y 62 | {-# inline (==) #-} 63 | 64 | data L a = L ~a 65 | unL :: L a -> a 66 | unL (L a) = a 67 | {-# inline unL #-} 68 | 69 | -------------------------------------------------------------------------------- 70 | 71 | newtype ConvState = ConvState# Int deriving Eq via Int 72 | pattern CSRigid = ConvState# 0 73 | pattern CSFlex = ConvState# 1 74 | pattern CSFull = ConvState# 2 75 | {-# complete CSRigid, CSFlex, CSFull #-} 76 | 77 | instance Show ConvState where 78 | show CSRigid = "Rigid" 79 | show CSFlex = "Flex" 80 | show CSFull = "Full" 81 | 82 | newtype Unfolding = Unfolding# Int deriving (Eq, Num) via Int 83 | pattern DoUnfold = Unfolding# 0 84 | pattern DontUnfold = Unfolding# 1 85 | {-# complete DoUnfold, DontUnfold #-} 86 | 87 | instance Show Unfolding where 88 | show DoUnfold = "DoUnfold" 89 | show DontUnfold = "DontUnfold" 90 | 91 | newtype Icit = Icit# Int deriving Eq 92 | pattern Impl = Icit# 0 93 | pattern Expl = Icit# 1 94 | {-# complete Impl, Expl #-} 95 | 96 | instance Show Icit where 97 | show Impl = "Impl" 98 | show Expl = "Expl" 99 | 100 | data ArgInfo 101 | = NoName Icit 102 | | Named {-# unpack #-} Span 103 | deriving Show 104 | 105 | newtype Ix = Ix Int 106 | deriving (Eq, Ord, Show, Num) via Int 107 | 108 | newtype Lvl = Lvl Int 109 | deriving (Eq, Ord, Show, Num, Bits) via Int 110 | 111 | newtype MetaVar = MetaVar Int 112 | deriving (Eq, Ord, Show, Num) via Int 113 | 114 | newtype UMetaVar = UMetaVar Int 115 | deriving (Eq, Ord, Show, Num) via Int 116 | 117 | lvlToIx :: Lvl -> Lvl -> Ix 118 | lvlToIx (Lvl envl) (Lvl l) = Ix (envl - l - 1) 119 | {-# inline lvlToIx #-} 120 | 121 | -------------------------------------------------------------------------------- 122 | 123 | newtype RawName = RawName {unRawName :: B.ByteString} 124 | deriving (Show, IsString, Eq) via B.ByteString 125 | 126 | instance Hashable RawName where 127 | hashWithSalt salt (RawName str) = fnv164 str salt 128 | {-# inline hashWithSalt #-} 129 | 130 | -------------------------------------------------------------------------------- 131 | 132 | type Name = S WName 133 | data WName 134 | = WNP 135 | | WNEmpty 136 | | WNX 137 | | WNName {-# unpack #-} RawName 138 | deriving (Eq, Show) 139 | pattern NP = S WNP 140 | pattern NEmpty = S WNEmpty 141 | pattern NX = S WNX 142 | pattern NName x = S (WNName x) 143 | 144 | -- | Pick the more informative name. 145 | pick :: Name -> Name -> Name 146 | pick x y = case x of 147 | NEmpty -> case y of 148 | NEmpty -> NX 149 | y -> y 150 | x -> x 151 | {-# inline pick #-} 152 | 153 | -- Inspection testing 154 | -------------------------------------------------------------------------------- 155 | 156 | -- | Check that a definition contains no `S` and `unS`. Note: we enable 157 | -- -fplugin-opt=Test.Inspection.Plugin:skip-O0 to stop interactive loading 158 | -- to be killed by inspection failure. 159 | inspectS :: TH.Name -> TH.Q [TH.Dec] 160 | inspectS name = inspect $ mkObligation name (NoUseOf ['S, 'unS]) 161 | 162 | 163 | -------------------------------------------------------------------------------- 164 | 165 | pickTest x y = unS (pick (S x) (S y)) 166 | inspect $ mkObligation 'pickTest (NoUseOf ['S, 'unS]) 167 | -------------------------------------------------------------------------------- /proto/examples/Notes.stt: -------------------------------------------------------------------------------- 1 | 2 | -- -- Prop and Set 3 | 4 | -- let foo : Set = Set in -- Set : Set 5 | -- let foo : Set = Prop in -- Prop : Set 6 | -- -- Prop is *not* a sub-universe of Set 7 | 8 | -- -- ⊤ : Prop 9 | -- -- ⊥ : Prop 10 | 11 | -- -- sigma types 12 | -- let foo : (A : Set) × A = (Set, Set) in 13 | 14 | -- let foo : (A : Set) × (B : Set) × (C : Set) × ⊤ 15 | -- = (Set, (Set, (Set, tt))) in 16 | 17 | -- let bar1 = foo.B in 18 | -- let bar2 = foo.C in 19 | 20 | -- -- (usual universe typing for (x : A) × B x) 21 | -- -- (for functions: h-level is h-level of codomain) 22 | -- let id : {A : Set} → A → A 23 | -- = λ x. x in 24 | -- let idP : {A : Prop} → A → A 25 | -- = λ x. x in 26 | -- id Set -- elaborated as id {Set} Set 27 | 28 | 29 | -- Evaluation + unification 30 | -- Do we want type-directed? 31 | -- With Strict Prop? 32 | 33 | -- Coq: everything is syntax-directed 34 | -- SProp is implemented with hacks (annotates binders with relevance) 35 | 36 | -- Agda: unification is fully type-directed, evaluation is not 37 | -- Agda tries to not compute irrelevant things (it is also a bit hacky) 38 | 39 | -- My version: eval in syntax-directed, conversion is *universe-directed* not type-directed 40 | 41 | -- Agda: f x y =? f x' y' 42 | -- lookup the type of f, which is an iterated Pi type 43 | -- (recomputing types all the time) 44 | 45 | -- I don't have eta for Unit : Set (Coq also doesn't have this) 46 | -- (eta for Unit is the *only* thing which absolutely requires type-directed conversion) 47 | -- (all other eta rules can be solved in other ways) 48 | 49 | f : Bool → Set 50 | f true = Nat 51 | f false = Lift ⊤ -- ⊤ : Prop (using subtyping of Prop ≤ Set) 52 | 53 | in unification , I only know that (Lift ⊤ : Set) 54 | 55 | t : ⊤ it is also the case t : Lift ⊤ (Sterling-style rules) 56 | 57 | 58 | 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 | -- Setoid tt implementation 101 | 102 | -- paper: Setoid Type Theory 103 | -- also : Observational Type Theory 104 | 105 | 106 | -- every closed type is a setoid (set + equivalence relation) 107 | 108 | -- every dependent type is a setoid fibration ("dependent setoid") 109 | -- (this means that we have coercion operation + "coherence") 110 | 111 | -- practical: 112 | -- - funext 113 | -- - propositional extensionality (univalence for propositions) 114 | -- - coercions compute 115 | -- - definitional proof irrelevance for Prop 116 | -- (A : Prop)(t u : A) → t ≡ u 117 | -- - Quotient types (QIIT) 118 | 119 | -- (Nicer setting for set-level math and programming) 120 | 121 | -- Alternative: MLTT + UIP + funext + PropExt 122 | -- ETT + PropExt (undecidable type checking, no normalization) 123 | -- (STT : a bit weaker PropExt) 124 | 125 | -- -- examples 126 | -- ------------------------------------------------------------ 127 | 128 | -- -- programming with lists 129 | 130 | -- nil : List A 131 | -- p : List A = List B 132 | -- (List A = List B) ≡ (A = B) -- (OTT) 133 | 134 | -- coe p (nil {A}) ≡ (nil {B}) -- my STT: holds 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | -- coe p (cons x xs) ≡ cons (coe p x) (coe p xs) -- 151 | 152 | -- -- sott (Bob Atkey) 153 | 154 | -- -- (split fibration equations) 155 | -- (p : A = A) → coe p x ≡ x 156 | -- (p : A = B)(q : B = C) → coe (p ◾ q) x ≡ coe q (coe p x) -- not in OTT 157 | 158 | 159 | -- -- my impl: 160 | -- ------------------------------------------------------------ 161 | 162 | -- versus STT: 163 | -- - only homogeneous equality 164 | 165 | -- notions of equality for *all* types: 166 | -- - A type, σ₀, σ₁ substitutions, σ₀ = σ₁ then A[σ₀] = A[σ₁] 167 | -- - coercions use this equality 168 | -- - doesn't require universes 169 | -- - semantics is ver nice & simple 170 | 171 | -- coe : returns in (A[σ₁]) if we only know coe return B type 172 | -- it's difficult to invent A and σ s.t. A[σ] ≡ B 173 | 174 | -- coe : (A : Ty Δ)(σ₀ σ₁ : Sub Γ Δ) → Tm Γ (El (Δ~ σ₀ σ₁)) → Tm Γ (A[σ₀]) → Tm Γ (A[σ₁]) 175 | -- B return type, invent A s.t. A[σ₁] ≡ B 176 | 177 | -- "local universes" 178 | -- Bool = Bool only makes sense Δ ≡ ∙ 179 | 180 | -- -- my change: 181 | 182 | -- - every type is in some universe 183 | -- - every type equality is an equality of type codes 184 | 185 | -- - A[σ₀] = A[σ₁] if every A is (El a) 186 | -- - El (a[σ₀]) = El (a[σ₁]) 187 | -- - type equality is _=_ : Set → Set → Prop (homogeneous) 188 | 189 | -- - (also have Pi in every universe) 190 | -- - all congruences given as "cong : (f : A → B) → x = y → f x = f y" 191 | -- - refl : x = x 192 | 193 | -- listing of my primitives: 194 | -- _=_ : {A : Set} → A → A → Prop 195 | -- coe : {A B : Set} → A = B → A → B 196 | -- refl : {A : Set}{x : A} → x = x 197 | -------------------------------------------------------------------------------- /setoidtt/src/Syntax.hs: -------------------------------------------------------------------------------- 1 | 2 | module Syntax where 3 | 4 | import IO 5 | import Data.Bits 6 | import qualified Data.IntSet.Internal as IS 7 | 8 | import Common 9 | 10 | -------------------------------------------------------------------------------- 11 | 12 | type UMax = IS.IntSet 13 | 14 | forUMax :: UMax -> (UMetaVar -> IO ()) -> IO () 15 | forUMax us f = 16 | let go :: RW -> Int -> RW 17 | go (RW s) (UMetaVar -> x) = case unIO (f x) s of (# s , _ #) -> RW s 18 | in IO \s -> case IS.foldl' go (RW s) us of 19 | RW s -> (# s , () #) 20 | {-# inline forUMax #-} 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | type U = S WU 25 | data U2 = U2 U U 26 | data WU 27 | = WSet 28 | | WProp 29 | | WMax UMax -- ^ Maximum of a non-empty set of universe metas. 30 | deriving (Eq, Show) 31 | pattern Set = S WSet 32 | pattern Prop = S WProp 33 | pattern Max xs = S (WMax xs) 34 | {-# complete Set, Prop, Max #-} 35 | 36 | instance Semigroup U where 37 | u <> u' = case u of 38 | Set -> Set 39 | Prop -> u' 40 | Max xs -> case u' of 41 | Set -> Set 42 | Prop -> Max xs 43 | Max xs' -> Max (xs <> xs') 44 | {-# inline (<>) #-} 45 | 46 | instance Monoid U where 47 | mempty = Prop 48 | {-# inline mempty #-} 49 | 50 | matchSingleton :: UMax -> Maybe UMetaVar 51 | matchSingleton xs = case xs of 52 | IS.Tip pref mask | popCount mask == 1 -> 53 | Just $! UMetaVar $! pref + countTrailingZeros mask 54 | _ -> 55 | Nothing 56 | {-# inline matchSingleton #-} 57 | 58 | pattern UVar :: UMetaVar -> U 59 | pattern UVar x <- ((\case Max xs -> matchSingleton xs; _ -> Nothing) -> Just x) where 60 | UVar (UMetaVar x) = Max (IS.singleton x) 61 | 62 | type Locals = S WLocals 63 | data WLocals 64 | = WEmpty 65 | | WDefine Locals Name Tm Ty U 66 | | WBind Locals Name Ty U 67 | deriving Show 68 | 69 | pattern Empty = S WEmpty 70 | pattern Define ls x t a u = S (WDefine ls x t a u) 71 | pattern Bind ls x a u = S (WBind ls x a u) 72 | {-# complete Empty, Define, Bind #-} 73 | 74 | type Ty = Tm 75 | type Tm = S WTm 76 | type WTy = WTm 77 | 78 | data WTm 79 | = WLocalVar Ix 80 | | WTopDef Lvl 81 | 82 | -- Note: we bring term constructors to the front because the first 6 consructors 83 | -- are dispatched on pointer tags, and the rest on info table, so we want 84 | -- the first 6 constructors to be the most commonly occurring. 85 | | WLam Name Icit Ty U Tm -- ^ λ(x : A : U).t or λ{x : A : U}.t 86 | | WApp Tm Tm U Icit -- ^ t u or t {u}, last Ty is u's universe 87 | 88 | | WPair Tm U Tm U 89 | | WProjField Tm Name Int 90 | | WProj1 Tm 91 | | WProj2 Tm 92 | 93 | | WPi Name Icit Ty U Ty -- ^ (x : A : U) → B) or {x : A : U} → B 94 | | WSg Name Ty U Ty U 95 | 96 | | WPostulate Lvl 97 | | WInsertedMeta MetaVar Locals 98 | | WMeta MetaVar 99 | | WLet Name Ty U Tm Tm 100 | 101 | | WU U -- ^ U u : Set 102 | | WTop -- ^ Top : Prop 103 | | WTt -- ^ Tt : Top 104 | | WBot -- ^ Bot : Prop 105 | | WEq Ty Tm Tm -- ^ {A : Set} → A → A → Prop 106 | | WCoe Ty Ty Tm Tm -- ^ {A B : Set} → Eq {Set} A B → A → B 107 | | WRefl Ty Tm -- ^ {A : Set}(x : A) → Eq x x 108 | | WSym Ty Tm Tm Tm -- ^ {A : Set}{x y : A} → Eq x y → Eq y x 109 | | WTrans Ty Tm Tm Tm Tm Tm -- ^ {A : Set}{x y z : A} → Eq x y → Eq y z → Eq x z 110 | | WAp Ty Ty Tm Tm Tm Tm -- ^ {A B : Set}(f : A → B){x y : A} → Eq x y → Eq (f x) (f y) 111 | | WExfalso U Ty Tm -- ^ {A : U i} → Bot → A 112 | deriving Show 113 | 114 | pattern LocalVar x = S (WLocalVar x) 115 | pattern TopDef x = S (WTopDef x) 116 | pattern Postulate x = S (WPostulate x) 117 | pattern Meta x = S (WMeta x) 118 | pattern InsertedMeta m ls = S (WInsertedMeta m ls) 119 | pattern Let x a au t u = S (WLet x a au t u ) 120 | pattern Pi x i a au b = S (WPi x i a au b) 121 | pattern Lam x i a au t = S (WLam x i a au t) 122 | pattern App t u uu i = S (WApp t u uu i) 123 | pattern Sg x a au b bu = S (WSg x a au b bu ) 124 | pattern Proj1 t = S (WProj1 t) 125 | pattern Proj2 t = S (WProj2 t) 126 | pattern ProjField t x n = S (WProjField t x n) 127 | pattern Pair t tu u uu = S (WPair t tu u uu) 128 | pattern U u = S (WU u) 129 | pattern Top = S (WTop) 130 | pattern Tt = S (WTt) 131 | pattern Bot = S (WBot) 132 | pattern Eq a t u = S (WEq a t u ) 133 | pattern Coe a b p t = S (WCoe a b p t) 134 | pattern Refl a t = S (WRefl a t ) 135 | pattern Sym a t u p = S (WSym a t u p) 136 | pattern Trans a t u v p q = S (WTrans a t u v p q) 137 | pattern Ap a b f t u p = S (WAp a b f t u p) 138 | pattern Exfalso u a t = S (WExfalso u a t) 139 | 140 | {-# complete 141 | LocalVar, TopDef, Postulate, Meta, Let, Pi, Lam, App, Sg, Proj1, InsertedMeta, 142 | Proj2, ProjField, Pair, U, Top, Tt, Bot, Eq, Coe, Refl, Sym, Trans, Ap, Exfalso #-} 143 | -------------------------------------------------------------------------------- /setoidtt/primdata/Data/Flat.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Flat ( 3 | Flat(..), size 4 | ) where 5 | 6 | {-| 7 | A class for types which can be naturally represented as uniform-sized pointer-free 8 | values. 9 | -} 10 | 11 | import Data.MachDeps 12 | import GHC.Int 13 | import GHC.Prim 14 | import GHC.Types 15 | import GHC.Word 16 | 17 | class Flat a where 18 | 19 | -- | Size of values of type @a@. 20 | size# :: Proxy# a -> Int# 21 | 22 | -- | Read a value from the array. The offset is in elements of type 23 | -- @a@ rather than in bytes. 24 | indexByteArray# :: ByteArray# -> Int# -> a 25 | 26 | -- | Read a value from the mutable array. The offset is in elements of type 27 | -- @a@ rather than in bytes. 28 | readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) 29 | 30 | -- | Write a value to the mutable array. The offset is in elements of type 31 | -- @a@ rather than in bytes. 32 | writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s 33 | 34 | -- | Read a value from a memory position given by an address and an offset. 35 | -- The memory block the address refers to must be immutable. The offset is in 36 | -- elements of type @a@ rather than in bytes. 37 | indexOffAddr# :: Addr# -> Int# -> a 38 | 39 | -- | Read a value from a memory position given by an address and an offset. 40 | -- The offset is in elements of type @a@ rather than in bytes. 41 | readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #) 42 | 43 | -- | Write a value to a memory position given by an address and an offset. 44 | -- The offset is in elements of type @a@ rather than in bytes. 45 | writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s 46 | 47 | size :: forall a. Flat a => Int 48 | size = I# (size# @a proxy#) 49 | {-# inline size #-} 50 | 51 | #define derivePrim(ty, ctr, sz, idx_arr, rd_arr, wr_arr, idx_addr, rd_addr, wr_addr) \ 52 | instance Flat (ty) where { \ 53 | size# _ = (case sz of I# sz -> sz) \ 54 | ; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \ 55 | ; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ 56 | { (# s1#, x# #) -> (# s1#, ctr x# #) } \ 57 | ; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ 58 | ; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ 59 | ; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ 60 | { (# s1#, x# #) -> (# s1#, ctr x# #) } \ 61 | ; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ 62 | ; {-# inline size# #-} \ 63 | ; {-# inline indexByteArray# #-} \ 64 | ; {-# inline readByteArray# #-} \ 65 | ; {-# inline writeByteArray# #-} \ 66 | ; {-# inline indexOffAddr# #-} \ 67 | ; {-# inline readOffAddr# #-} \ 68 | ; {-# inline writeOffAddr# #-} \ 69 | } 70 | 71 | 72 | derivePrim(Int, I#, sIZEOF_INT, 73 | indexIntArray#, readIntArray#, writeIntArray#, 74 | indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#) 75 | derivePrim(Word, W#, sIZEOF_WORD, 76 | indexWordArray#, readWordArray#, writeWordArray#, 77 | indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#) 78 | derivePrim(Double, D#, sIZEOF_DOUBLE, 79 | indexDoubleArray#, readDoubleArray#, writeDoubleArray#, 80 | indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#) 81 | derivePrim(Char, C#, sIZEOF_CHAR, 82 | indexWideCharArray#, readWideCharArray#, writeWideCharArray#, 83 | indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#) 84 | derivePrim(Word8, W8#, sIZEOF_WORD8, 85 | indexWord8Array#, readWord8Array#, writeWord8Array#, 86 | indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#) 87 | derivePrim(Word16, W16#, sIZEOF_WORD16, 88 | indexWord16Array#, readWord16Array#, writeWord16Array#, 89 | indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#) 90 | derivePrim(Word32, W32#, sIZEOF_WORD32, 91 | indexWord32Array#, readWord32Array#, writeWord32Array#, 92 | indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#) 93 | derivePrim(Word64, W64#, sIZEOF_WORD64, 94 | indexWord64Array#, readWord64Array#, writeWord64Array#, 95 | indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#) 96 | derivePrim(Int8, I8#, sIZEOF_INT8, 97 | indexInt8Array#, readInt8Array#, writeInt8Array#, 98 | indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#) 99 | derivePrim(Int16, I16#, sIZEOF_INT16, 100 | indexInt16Array#, readInt16Array#, writeInt16Array#, 101 | indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#) 102 | derivePrim(Int32, I32#, sIZEOF_INT32, 103 | indexInt32Array#, readInt32Array#, writeInt32Array#, 104 | indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#) 105 | derivePrim(Int64, I64#, sIZEOF_INT64, 106 | indexInt64Array#, readInt64Array#, writeInt64Array#, 107 | indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#) 108 | -------------------------------------------------------------------------------- /proto/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -Wno-orphans #-} 2 | 3 | module Pretty (showTm, showTopTm, showTm', showVal) where 4 | 5 | import Lens.Micro.Platform 6 | import qualified Data.IntSet as IS 7 | import Types 8 | import Evaluation 9 | 10 | -- | We specialcase printing of top lambdas, since they are usually used 11 | -- to postulate stuff. We use '*' in a somewhat hacky way to mark 12 | -- names bound in top lambdas, so that later we can avoid printing 13 | -- them in meta spines. 14 | topLams :: Bool -> String -> String -> [Name] -> Tm -> ShowS 15 | topLams p pre post ns (Lam (fresh ns -> x) i a _ t) = 16 | showParen p ( 17 | (pre++) 18 | . icit i bracket parens ( 19 | ((if null x then "_" else x)++) . (" : "++) . go False ns a) 20 | . topLams False "\n " ".\n\n" (('*':x):ns) t) -- note the '*' 21 | topLams _ pre post ns t = (post++) . go False ns t 22 | 23 | fresh :: [Name] -> Name -> Name 24 | fresh _ "_" = "_" 25 | fresh ns n | elem n ns = fresh ns (n++"'") 26 | | otherwise = n 27 | 28 | goU :: Bool -> U -> ShowS 29 | goU p Prop = ("Prop"++) 30 | goU p Set = ("Set"++) 31 | goU p (UMeta x) = (("U?"++show x)++) 32 | goU p (UMax xs) = (("UMax "++ show (IS.toList xs))++) 33 | 34 | goVar :: [Name] -> Ix -> ShowS 35 | goVar ns x = case safeIx ns x of 36 | Just ('*':n) -> (n++) 37 | Just n -> (n++) 38 | Nothing -> error (show (ns, x)) 39 | 40 | goArg :: [Name] -> Tm -> Icit -> ShowS 41 | goArg ns t i = icit i (bracket (go False ns t)) (go True ns t) 42 | 43 | goLamBind :: Name -> Icit -> ShowS 44 | goLamBind x i = icit i bracket id ((if null x then "_" else x) ++) 45 | 46 | bracket s = ('{':).s.('}':) 47 | parens s = ('(':).s.(')':) 48 | 49 | goLam :: [Name] -> Tm -> ShowS 50 | goLam ns (Lam (fresh ns -> x) i a _ t) = (' ':) . goLamBind x i . goLam (x:ns) t 51 | goLam ns t = (". "++) . go False ns t 52 | 53 | goPiBind :: [Name] -> Name -> Icit -> Tm -> U -> ShowS 54 | goPiBind ns x i a au = 55 | icit i bracket (showParen True) ( 56 | (x++) . (" : "++) . go False ns a 57 | -- . (" : "++) . (show au++) 58 | ) 59 | 60 | goPi :: [Name] -> Bool -> Tm -> ShowS 61 | goPi ns p (Pi (fresh ns -> x) i a au b) 62 | | x /= "_" = goPiBind ns x i a au . goPi (x:ns) True b 63 | | otherwise = 64 | (if p then (" → "++) else id) . 65 | go (case a of Pi{} -> True; Sg{} -> True; _ -> False) ns a . 66 | (" → "++) . go False (x:ns) b 67 | 68 | goPi ns p t = (if p then (" → "++) else id) . go False ns t 69 | 70 | isMetaSp :: Tm -> Bool 71 | isMetaSp Meta{} = True 72 | isMetaSp (App t _ _ _) = isMetaSp t 73 | isMetaSp _ = False 74 | 75 | goMetaSp :: [Name] -> Tm -> ShowS 76 | goMetaSp ns (App t (Var x) _ i) 77 | | Just ('*':_) <- safeIx ns x = goMetaSp ns t 78 | | Nothing <- safeIx ns x = error (show (ns, x)) 79 | goMetaSp ns (App t u _ i) = 80 | goMetaSp ns t . (' ':) . goArg ns u i 81 | goMetaSp ns (Meta m) = ("?"++).(show m++) 82 | goMetaSp _ _ = error "impossible" 83 | 84 | goSp :: [Name] -> Tm -> ShowS 85 | goSp ns (App t u _ Expl) = goSp ns t . (' ':) . goArg ns u Expl 86 | goSp ns (App t u _ Impl) = goSp ns t 87 | -- goSp ns (App t u _ Impl) = goSp ns t . (' ':) . goArg ns u Impl 88 | goSp ns t = go True ns t 89 | 90 | go :: Bool -> [Name] -> Tm -> ShowS 91 | go p ns = \case 92 | Var x -> goVar ns x 93 | Meta m -> ("?"++).(show m++) 94 | Let (fresh ns -> x) a _ t u -> 95 | ("let "++) . (x++) . (" : "++) . go False ns a . ("\n = "++) 96 | . go False ns t . ("\nin\n"++) . go False (x:ns) u 97 | t@App{} | isMetaSp t -> showParen p (goMetaSp ns t) 98 | | otherwise -> showParen p (goSp ns t) 99 | 100 | Lam (fresh ns -> x) i a _ t -> showParen p (("λ "++) . goLamBind x i . goLam (x:ns) t) 101 | t@Pi{} -> showParen p (goPi ns False t) 102 | U u -> goU p u 103 | Skip t -> go p ("_":ns) t 104 | Top -> ("⊤"++) 105 | Tt -> ("tt"++) 106 | Bot -> ("⊥"++) 107 | Exfalso u -> ("exfalso"++) 108 | Eq -> ("Eq"++) 109 | Refl -> ("refl"++) 110 | Coe u -> ("coe"++) 111 | Sym -> ("sym"++) 112 | Trans -> ("trans"++) 113 | Ap -> ("ap"++) 114 | 115 | Sg (fresh ns -> x) a au b bu 116 | | x == "_" -> 117 | showParen p ( 118 | go (case a of Sg{} -> True;Pi{} -> True;_ -> False) ns a .(" × "++). 119 | go (case b of Pi{} -> True; _ -> False) (x:ns) b) 120 | | otherwise -> 121 | showParen p 122 | (parens ((x++).(" : "++).go False ns a) 123 | .(" × "++). go (case b of Pi{} -> True; _ -> False) (x:ns) b) 124 | 125 | Proj1 t tu -> showParen p (go False ns t.(".₁"++)) 126 | Proj2 t tu -> showParen p (go False ns t.(".₂"++)) 127 | ProjField t x i tu -> showParen p (go True ns t.(("."++x)++)) 128 | Pair t tu u uu -> parens (go False ns t . (", "++) . go False ns u) 129 | 130 | Nat -> ("Nat"++) 131 | Zero -> ("zero"++) 132 | Suc -> ("suc"++) 133 | Ind u -> ("ind"++) 134 | 135 | showTm :: [Name] -> Tm -> String 136 | showTm ns t = go False ns t [] 137 | -- showTm ns t = show t 138 | -- deriving instance Show Tm 139 | instance Show Tm where show = showTopTm 140 | 141 | showTopTm :: Tm -> String 142 | showTopTm t = topLams False "λ" "" [] t [] 143 | 144 | showTm' :: Cxt -> Tm -> String 145 | showTm' cxt t = showTm (cxt^.names) t 146 | 147 | showVal :: Cxt -> Val -> String 148 | showVal cxt v = showTm' cxt (quote (cxt^.len) v) 149 | -------------------------------------------------------------------------------- /proto/Parser.hs: -------------------------------------------------------------------------------- 1 | 2 | module Parser ( 3 | parseString 4 | , parseStdin 5 | ) where 6 | 7 | import Control.Monad 8 | import Data.Char 9 | import Data.Void 10 | import System.Exit 11 | import Text.Megaparsec 12 | import Text.Printf 13 | 14 | import qualified Text.Megaparsec.Char as C 15 | import qualified Text.Megaparsec.Char.Lexer as L 16 | import qualified Data.Set as S 17 | 18 | import Types 19 | 20 | -------------------------------------------------------------------------------- 21 | 22 | type Parser = Parsec Void String 23 | 24 | ws :: Parser () 25 | ws = L.space C.space1 (L.skipLineComment "--") (L.skipBlockComment "{-" "-}") 26 | 27 | withPos' :: Parser a -> Parser (SPos, a) 28 | withPos' p = (,) <$> (SPos <$> getSourcePos) <*> p 29 | 30 | withPos :: Parser Raw -> Parser Raw 31 | withPos p = RSrcPos <$> (SPos <$> getSourcePos) <*> p 32 | 33 | lexeme = L.lexeme ws 34 | symbol s = lexeme (C.string s) 35 | char c = lexeme (C.char c) 36 | parens p = char '(' *> p <* char ')' 37 | braces p = char '{' *> p <* char '}' 38 | pArrow = symbol "→" <|> symbol "->" 39 | pBind = pIdent <|> symbol "_" 40 | natLit = lexeme L.decimal 41 | 42 | keywords :: S.Set String 43 | keywords = S.fromList [ 44 | "let", "in", "λ", "Set", "Prop", "trans", 45 | "⊤", "tt", "⊥", "exfalso", "Eq", "refl", "coe", "sym", "ap", "ind", 46 | "Nat", "zero", "suc"] 47 | 48 | pIdent :: Parser Name 49 | pIdent = try $ do 50 | start <- takeWhile1P Nothing isLetter 51 | rest <- takeWhileP Nothing (\c -> isAlphaNum c || c == '\'' || c == '-') 52 | let x = start ++ rest 53 | when (S.member x keywords) $ 54 | fail (printf "Expected an identifier, but \"%s\" is a keyword." x) 55 | x <$ ws 56 | 57 | pNatLit :: Parser Raw 58 | pNatLit = do 59 | (n :: Integer) <- natLit 60 | let go 0 = RZero 61 | go n = RAppE RSuc (go (n - 1)) 62 | pure (go n) 63 | 64 | pAtom :: Parser Raw 65 | pAtom = 66 | withPos ( (RVar <$> pIdent ) 67 | <|> (RSet <$ symbol "Set" ) 68 | <|> (RProp <$ symbol "Prop" ) 69 | <|> (RTop <$ symbol "⊤" ) 70 | <|> (RBot <$ symbol "⊥" ) 71 | <|> (RTt <$ symbol "tt" ) 72 | <|> (RExfalso <$ symbol "exfalso") 73 | <|> (REq <$ symbol "Eq" ) 74 | <|> (RRefl <$ symbol "refl" ) 75 | <|> (RCoe <$ symbol "coe" ) 76 | <|> (RSym <$ symbol "sym" ) 77 | <|> (RTrans <$ symbol "trans" ) 78 | <|> (RAp <$ symbol "ap" ) 79 | <|> (RInd <$ symbol "ind" ) 80 | <|> (RNat <$ symbol "Nat" ) 81 | <|> (RZero <$ symbol "zero" ) 82 | <|> (RSuc <$ symbol "suc" ) 83 | <|> (RHole <$ char '_' ) 84 | <|> pNatLit ) 85 | 86 | <|> do { 87 | char '('; 88 | t1 <- pTm; 89 | optional (char ',') >>= \case 90 | Nothing -> char ')' >> pure t1 91 | Just{} -> do {t2 <- pTm; char ')'; pure (RPair t1 t2)} 92 | } 93 | 94 | pProj :: Parser (SPos, RProj) 95 | pProj = 96 | withPos' ( 97 | (RProj1 <$ symbol ".₁") 98 | <|> (RProj2 <$ symbol ".₂") 99 | <|> (RProjField <$> (C.char '.' *> pIdent))) 100 | 101 | -- application or projection 102 | pArg :: Parser (Either (Icit,Raw) (SPos, RProj)) 103 | pArg = (Right <$> pProj) 104 | <|> (Left . (Impl,) <$> (char '{' *> pTm <* char '}')) 105 | <|> (Left. (Expl,) <$> pAtom) 106 | 107 | pSpine :: Parser Raw 108 | pSpine = do 109 | h <- pAtom 110 | args <- many pArg 111 | pure $ foldl (\t -> either (\(i, u) -> RApp t u i) 112 | (\(pos, p) -> RSrcPos pos (RProj t p))) 113 | h args 114 | 115 | pLamBinder :: Parser (Name, Maybe Raw, Icit) 116 | pLamBinder = 117 | ((,Nothing,Expl) <$> pBind) 118 | <|> parens ((,,Expl) <$> pBind <*> optional (char ':' *> pTm)) 119 | <|> (braces ((,,Impl) <$> pBind <*> optional (char ':' *> pTm))) 120 | 121 | pLam :: Parser Raw 122 | pLam = do 123 | char 'λ' <|> char '\\' 124 | xs <- some pLamBinder 125 | char '.' 126 | t <- pTm 127 | pure $ foldr (\(x, a, ni) t -> RLam x a ni t) t xs 128 | 129 | pPiBinder :: Parser ([Name], Raw, Icit) 130 | pPiBinder = 131 | braces ((,,Impl) <$> some pBind 132 | <*> ((char ':' *> pTm) <|> pure RHole)) 133 | <|> parens ((,,Expl) <$> some pBind 134 | <*> (char ':' *> pTm)) 135 | pPi :: Parser Raw 136 | pPi = do 137 | dom <- some pPiBinder 138 | pArrow 139 | cod <- pTm 140 | pure $ foldr (\(xs, a, i) t -> foldr (\x -> RPi x i a) t xs) cod dom 141 | 142 | pSg :: Parser Raw 143 | pSg = do 144 | (x, a) <- parens ((,) <$> pBind <*> (char ':' *> pTm)) 145 | char '×' 146 | b <- pTm 147 | pure (RSg x a b) 148 | 149 | pFunOrSpineOrPair :: Parser Raw 150 | pFunOrSpineOrPair = do 151 | sp <- pSpine 152 | optional pArrow >>= \case 153 | Just _ -> RPi "_" Expl sp <$> pTm 154 | Nothing -> optional (symbol "×") >>= \case 155 | Just _ -> RSg "_" sp <$> pTm 156 | Nothing -> pure sp 157 | 158 | pLet :: Parser Raw 159 | pLet = do 160 | symbol "let" 161 | x <- pIdent 162 | ann <- optional (char ':' *> pTm) 163 | char '=' 164 | t <- pTm 165 | symbol "in" 166 | u <- pTm 167 | pure $ RLet x (maybe RHole id ann) t u 168 | 169 | pTm :: Parser Raw 170 | pTm = withPos (pLam <|> pLet <|> try pPi <|> try pSg <|> pFunOrSpineOrPair) 171 | 172 | pSrc :: Parser Raw 173 | pSrc = ws *> pTm <* eof 174 | 175 | parseString :: String -> IO Raw 176 | parseString src = 177 | case parse pSrc "(stdin)" src of 178 | Left e -> do 179 | putStrLn $ errorBundlePretty e 180 | exitFailure 181 | Right t -> 182 | pure t 183 | 184 | parseStdin :: IO (Raw, String) 185 | parseStdin = do 186 | src <- getContents 187 | t <- parseString src 188 | pure (t, src) 189 | -------------------------------------------------------------------------------- /experiments/CachedEval.hs: -------------------------------------------------------------------------------- 1 | {-# language Strict, LambdaCase, UnicodeSyntax, PatternSynonyms #-} 2 | {-# options_ghc -Wincomplete-patterns #-} 3 | 4 | type Lvl = Int 5 | type Ix = Int 6 | type Env = [Val] 7 | type Con = Lvl 8 | type Ren = [Lvl] 9 | 10 | infixl 8 $$ 11 | ($$) = App 12 | 13 | pattern Let t u = App (Lam u) t 14 | 15 | instance Num Tm where 16 | fromInteger = Var . fromIntegral 17 | (+) = undefined; (*) = undefined; abs = undefined 18 | signum = undefined; negate = undefined 19 | 20 | data Tm = Var Ix | Lam Tm | App Tm Tm deriving Show 21 | data Val = VVar Lvl | VApp Val ~Val | VLam Con Env Tm ~Val deriving Show 22 | 23 | -- VVar : Var Γ A → Val Γ A 24 | -- VApp : Val Γ (Π A B) → (u : Val Γ A) → Val Γ (B[id,u]) 25 | -- VLam : (Γ' : Con){wk : Γ ≥ Γ'}{Δ : Con}(σ : Env Γ' Δ)(t : Tm (Δ, A) B) 26 | -- → Val (Γ', A[σ]) B[σ⁺] 27 | -- → Val Γ (Π A[σ∘wk] B[(σ∘wk)⁺]) 28 | 29 | -- weakening for Env/Val is still implicit, because {wk : Γ ≥ Γ'} is computationally irrelevant 30 | -- hence σ∘wk = σ 31 | 32 | -- eval : (Γ : Con)(σ : Env Γ Δ) → Tm Δ A → Val Γ A[σ] 33 | eval ∷ Con → Env → Tm → Val 34 | eval gamma σ = \case 35 | Var x → σ !! x 36 | App t u → case (eval gamma σ t, eval gamma σ u) of 37 | 38 | (VLam gamma' σ' t _ , u) → 39 | -- wk : Γ ≥ Γ' 40 | -- σ' : Env Γ' Δ 41 | -- t : Tm (Δ, A) B 42 | -- u : Val Γ A[σ] 43 | -- : Val Γ A[σ'] 44 | 45 | -- we know that A[σ] = A[σ'] and B[σ⁺] = B[σ'⁺] 46 | -- goal : Val Γ (B[σ, u]) 47 | 48 | -- σ'∘wk : Env Γ Δ 49 | -- σ'∘wk, u : Env Γ (Δ, A) 50 | -- eval Γ (σ'∘wk, u) : Tm (Δ, A) B → Val Γ B[σ'∘wk, u] 51 | -- eval Γ (σ'∘wk, u) t : Val Γ B[σ'∘wk, u] 52 | -- : Val Γ B[σ', u] 53 | -- : Val Γ B[σ'⁺][id, u] 54 | -- : Val Γ B[σ⁺][id, u] 55 | -- : Val Γ B[σ, u] OK 56 | eval gamma (u:σ') t 57 | 58 | (t, u) → VApp t u 59 | 60 | -- t : Tm (Δ, A) B 61 | -- σ : Env Γ Δ 62 | -- σ⁺ : Env (Γ,A[σ]) (Δ, A) 63 | -- eval σ⁺ t : Val (Γ,A[σ]) B[σ⁺] 64 | Lam t → VLam gamma {- id -} σ t (eval (gamma + 1) (VVar gamma:σ) t) 65 | 66 | -- rename : (Δ : Con)(σ : Ren Γ Δ) → Var Δ A → Var Γ A[σ] 67 | rename ∷ Con → Ren → Lvl → Lvl 68 | rename gamma r x = r !! (gamma - x - 1) 69 | 70 | -- conv : (Γ : Con) 71 | -- (Δ : Con)(r : Ren Γ Δ) (t : Val Δ A) 72 | -- (Δ' : Con)(r' : Ren Γ Δ')(t' : Val Δ' A') 73 | -- {p : A[r] = A'[r']} 74 | -- → Dec (t[r] = t[r']) 75 | conv ∷ Con → Con → Ren → Val → Con → Ren → Val → Bool 76 | conv gamma delta r t delta' r' t' = case (t, t') of 77 | (VLam gamma' σ _ t, VLam gamma'' σ' _ t') → 78 | 79 | -- t : Val (Γ' , A[σ]) B[σ⁺] 80 | -- t' : Val (Γ'', A'[σ']) B'[σ'⁺] 81 | -- wk : Δ ≥ Γ' 82 | -- wk': Δ' ≥ Γ'' 83 | -- r : Ren Γ Δ 84 | -- r' : Ren Γ Δ' 85 | 86 | -- wk∘r : Ren Γ Γ' (this is given by truncating r to the first Γ' entries) 87 | -- (wk∘r)⁺ : Ren (Γ, A[σ∘wk∘r]) (Γ', A[σ]) (given by (len(Γ) : (wk∘r))) 88 | -- t : Val (Γ', A[σ]) (B[σ⁺]) 89 | 90 | -- recursive call: 91 | -- conv (Γ, A[σ∘wk∘r]) 92 | -- (Γ', A[σ]) (wk∘r)⁺ t 93 | -- (Γ'',A'[σ']) (wk'∘r')⁺ t' 94 | 95 | conv (gamma + 1) 96 | (gamma' + 1) (gamma:drop (delta - gamma') r ) t 97 | (gamma'' + 1) (gamma:drop (delta' - gamma'') r') t' 98 | 99 | (VLam gamma' _ _ t, t') → 100 | conv (gamma + 1) (gamma' + 1) (gamma:drop (delta - gamma') r) t 101 | delta' r' (VApp t' (VVar gamma)) 102 | 103 | (t, VLam gamma'' _ _ t') → 104 | conv (gamma + 1) delta r (VApp t (VVar gamma)) 105 | (gamma'' + 1) (gamma:drop (delta' - gamma'') r') t' 106 | 107 | (VVar x, VVar x') → 108 | rename delta r x == rename delta' r' x' 109 | 110 | (VApp t u, VApp t' u') → 111 | conv gamma delta r t delta' r' t' && conv gamma delta r u delta' r' u' 112 | 113 | _ → False 114 | 115 | -- quote : (Γ : Con) → Val Γ A → Tm Γ A 116 | quote ∷ Con → Val → Tm 117 | quote gamma = \case 118 | VVar x → Var (gamma - x - 1) 119 | VApp t u → App (quote gamma t) (quote gamma u) 120 | VLam gamma' σ _ t → Lam (quote (gamma' + 1) t) 121 | -- wk : Γ ≥ Γ' 122 | -- t : Val (Γ', A[σ]) B[σ⁺] 123 | -- goal : Tm (Γ, A[σ∘wk]) B[(σ∘wk)⁺] 124 | -- : Tm (Γ', A[σ]) B[σ⁺] 125 | -- := quote (Γ', A[σ]) t 126 | 127 | nf0 ∷ Tm → Tm 128 | nf0 = quote 0 . eval 0 [] 129 | 130 | convTm0 :: Tm → Tm → Bool 131 | convTm0 t t' = conv 0 0 [] (eval 0 [] t) 0 [] (eval 0 [] t') 132 | 133 | test0 = 134 | Let (Lam $ Lam $ 1 $$ (1 $$ (1 $$ (1 $$ (1 $$ 0))))) $ 135 | Let (Lam $ Lam $ Lam $ Lam $ 3 $$ 1 $$ (2 $$ 1 $$ 0)) $ 136 | Let (Lam $ Lam $ Lam $ Lam $ 3 $$ (2 $$ 1) $$ 0) $ 137 | Let (1 $$ 2 $$ 2) $ 138 | Let (1 $$ 0 $$ 0) $ 139 | Let (2 $$ 1 $$ 0) $ 140 | 0 141 | -- "let λ λ 1 (1 (1 (1 (1 0)))) in", -- five = λ s z. s (s (s (s (s z)))) 142 | -- "let λ λ λ λ 3 1 (2 1 0) in", -- add = λ a b s z. a s (b s z) 143 | -- "let λ λ λ λ 3 (2 1) 0 in", -- mul = λ a b s z. a (b s) z 144 | -- "let 1 2 2 in", -- ten = add five five 145 | -- "let 1 0 0 in", -- hundred = mul ten ten 146 | -- "let 2 1 0 in", -- thousand = mul ten hundred 147 | -- "0" -- thousand 148 | 149 | test1 = 150 | Let (Lam $ Lam $ 1 $$ (1 $$ (1 $$ (1 $$ (1 $$ 0))))) $ 151 | Let (Lam $ Lam $ Lam $ Lam $ 3 $$ 1 $$ (2 $$ 1 $$ 0)) $ 152 | Let (Lam $ Lam $ Lam $ Lam $ 3 $$ (2 $$ 1) $$ 0) $ 153 | Let (1 $$ 2 $$ 2) $ 154 | Let (1 $$ 0 $$ 0) $ 155 | Let (2 $$ 0 $$ 1) $ 156 | 0 157 | 158 | convTest1 :: Bool 159 | convTest1 = convTm0 test0 test1 160 | -------------------------------------------------------------------------------- /setoidtt/dynamic-array/Data/Array/Dynamic/U.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.Dynamic.U ( 3 | empty 4 | , Array 5 | , clear 6 | , push 7 | , Data.Array.Dynamic.U.read 8 | , Data.Array.Dynamic.U.show 9 | , size 10 | , unsafeRead 11 | , unsafeWrite 12 | , write 13 | , unsafeLast 14 | , Data.Array.Dynamic.U.last 15 | , isEmpty 16 | -- , foldl' 17 | -- , foldlIx' 18 | -- , foldr' 19 | -- , foldrIx' 20 | -- , Data.Array.Dynamic.any 21 | -- , Data.Array.Dynamic.all 22 | -- , allIx 23 | -- , anyIx 24 | -- , forM_ 25 | -- , forMIx_ 26 | ) where 27 | 28 | import Data.Unlifted 29 | import Data.Array.UndefElem 30 | 31 | import qualified Data.Ref.UU as RUU 32 | import qualified Data.Ref.F as RF 33 | import qualified Data.Array.UM as UM 34 | 35 | type role Array representational 36 | newtype Array (a :: *) = Array (RUU.Ref (RF.Ref Int) (UM.Array a)) 37 | deriving Unlifted 38 | 39 | defaultCapacity :: Int 40 | defaultCapacity = 5 41 | {-# inline defaultCapacity #-} 42 | 43 | empty :: forall a. Unlifted a => IO (Array a) 44 | empty = do 45 | sizeRef <- RF.new 0 46 | arrRef <- UM.new defaultCapacity defaultElem 47 | Array <$> RUU.new sizeRef arrRef 48 | {-# inline empty #-} 49 | 50 | unsafeRead :: Unlifted a => Array a -> Int -> IO a 51 | unsafeRead (Array r) i = do 52 | elems <- RUU.readSnd r 53 | UM.read elems i 54 | {-# inline unsafeRead #-} 55 | 56 | read :: Unlifted a => Array a -> Int -> IO a 57 | read (Array r) i = do 58 | elems <- RUU.readSnd r 59 | if 0 <= i && i < UM.size elems then 60 | UM.read elems i 61 | else 62 | error "Data.Array.Dynamic.U.read: out of bounds" 63 | {-# inline read #-} 64 | 65 | unsafeWrite :: Unlifted a => Array a -> Int -> a -> IO () 66 | unsafeWrite (Array r) i a = do 67 | elems <- RUU.readSnd r 68 | UM.write elems i a 69 | {-# inline unsafeWrite #-} 70 | 71 | write :: Unlifted a => Array a -> Int -> a -> IO () 72 | write (Array r) i ~a = do 73 | s <- RF.read =<< RUU.readFst r 74 | if 0 <= i && i < s 75 | then unsafeWrite (Array r) i a 76 | else error "Data.Array.Dynamic.U.write: out of bounds" 77 | {-# inline write #-} 78 | 79 | push :: Unlifted a => Array a -> a -> IO () 80 | push (Array r) ~a = do 81 | sizeRef <- RUU.readFst r 82 | elems <- RUU.readSnd r 83 | size <- RF.read sizeRef 84 | let cap = UM.size elems 85 | RF.write sizeRef (size + 1) 86 | if (size == cap) then do 87 | let cap' = 2 * cap 88 | elems' <- UM.new cap' undefElem 89 | UM.copySlice elems 0 elems' 0 size 90 | UM.write elems' size a 91 | RUU.writeSnd r elems' 92 | else do 93 | UM.write elems size a 94 | {-# inline push #-} 95 | 96 | clear :: Unlifted a => Array a -> IO () 97 | clear (Array r) = do 98 | (`RF.write` 0) =<< RUU.readFst r 99 | RUU.writeSnd r =<< UM.new defaultCapacity undefElem 100 | {-# inline clear #-} 101 | 102 | size :: Array a -> IO Int 103 | size (Array r) = RF.read =<< RUU.readFst r 104 | {-# inline size #-} 105 | 106 | unsafeLast :: Unlifted a => Array a -> IO a 107 | unsafeLast arr = do 108 | i <- size arr 109 | Data.Array.Dynamic.U.unsafeRead arr (i - 1) 110 | {-# inline unsafeLast #-} 111 | 112 | isEmpty :: Array a -> IO Bool 113 | isEmpty arr = (==0) <$> size arr 114 | {-# inline isEmpty #-} 115 | 116 | last :: Unlifted a => Array a -> IO a 117 | last arr = do 118 | i <- size arr 119 | isEmpty arr >>= \case 120 | True -> error "Data.Array.Dynamic.last: empty array" 121 | _ -> unsafeRead arr (i - 1) 122 | {-# inline last #-} 123 | 124 | show :: (Show a, Unlifted a) => Array a -> IO String 125 | show (Array r) = do 126 | elems <- RUU.readSnd r 127 | size <- RF.read =<< RUU.readFst r 128 | elems' <- UM.freezeSlice elems 0 size 129 | pure (Prelude.show elems') 130 | {-# inlinable show #-} 131 | 132 | -- foldl' :: (b -> a -> b) -> b -> Array a -> IO b 133 | -- foldl' f b = \arr -> do 134 | -- s <- size arr 135 | -- let go i b | i == s = pure b 136 | -- | otherwise = do 137 | -- a <- unsafeRead arr i 138 | -- go (i + 1) $! f b a 139 | -- go 0 b 140 | -- {-# inline foldl' #-} 141 | 142 | -- foldlIx' :: (Int -> b -> a -> b) -> b -> Array a -> IO b 143 | -- foldlIx' f b = \arr -> do 144 | -- s <- size arr 145 | -- let go i b | i == s = pure b 146 | -- | otherwise = do 147 | -- a <- unsafeRead arr i 148 | -- go (i + 1) $! f i b a 149 | -- go 0 b 150 | -- {-# inline foldlIx' #-} 151 | 152 | -- foldr' :: (a -> b -> b) -> b -> Array a -> IO b 153 | -- foldr' f b = \arr -> do 154 | -- s <- size arr 155 | -- let go i b | i == (-1) = pure b 156 | -- | otherwise = do 157 | -- a <- unsafeRead arr i 158 | -- go (i - 1) $! f a b 159 | -- go (s - 1) b 160 | -- {-# inline foldr' #-} 161 | 162 | -- foldrIx' :: (Int -> a -> b -> b) -> b -> Array a -> IO b 163 | -- foldrIx' f b = \arr -> do 164 | -- s <- size arr 165 | -- let go i b | i == (-1) = pure b 166 | -- | otherwise = do 167 | -- a <- unsafeRead arr i 168 | -- go (i - 1) $! f i a b 169 | -- go (s - 1) b 170 | -- {-# inline foldrIx' #-} 171 | 172 | -- -- TODO: any + all with lazy fold 173 | -- any :: (a -> Bool) -> Array a -> IO Bool 174 | -- any f = foldl' (\b a -> f a || b) False 175 | -- {-# inline any #-} 176 | 177 | -- all :: (a -> Bool) -> Array a -> IO Bool 178 | -- all f = foldl' (\b a -> f a && b) True 179 | -- {-# inline all #-} 180 | 181 | -- anyIx :: (Int -> a -> Bool) -> Array a -> IO Bool 182 | -- anyIx f = foldlIx' (\i b a -> f i a || b) False 183 | -- {-# inline anyIx #-} 184 | 185 | -- allIx :: (Int -> a -> Bool) -> Array a -> IO Bool 186 | -- allIx f = foldlIx' (\i b a -> f i a && b) True 187 | -- {-# inline allIx #-} 188 | 189 | -- forM_ :: Array a -> (a -> IO b) -> IO () 190 | -- forM_ arr f = go (0 :: Int) where 191 | -- go i = do 192 | -- s <- size arr 193 | -- if i == s then pure () else do {x <- unsafeRead arr i; f x; go (i + 1)} 194 | -- {-# inline forM_ #-} 195 | 196 | -- forMIx_ :: Array a -> (Int -> a -> IO b) -> IO () 197 | -- forMIx_ arr f = go (0 :: Int) where 198 | -- go i = do 199 | -- s <- size arr 200 | -- if i == s then pure () else do {x <- unsafeRead arr i; f i x; go (i + 1)} 201 | -- {-# inline forMIx_ #-} 202 | -------------------------------------------------------------------------------- /proto/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception 4 | import System.Environment 5 | import System.Exit 6 | import Text.Printf 7 | 8 | import ElabState 9 | import Elaboration 10 | import Errors 11 | import EvalCxt 12 | import Parser 13 | import Types 14 | import Zonk 15 | 16 | 17 | helpMsg = unlines [ 18 | "usage: setoidtt [--help|elab|nf|type]", 19 | " --help : display this message", 20 | " elab : read & elaborate expression from stdin, print elaboration output", 21 | " nf : read & elaborate expression from stdin, print its normal form", 22 | " type : read & elaborate expression from stdin, print its (normal) type"] 23 | 24 | displayError :: String -> Err -> IO a 25 | displayError file (Err ns err (Just (SPos (SourcePos path (unPos -> linum) (unPos -> colnum))))) = do 26 | let lnum = show linum 27 | lpad = map (const ' ') lnum 28 | printf "%s:%d:%d:\n" path linum colnum 29 | printf "%s |\n" lpad 30 | printf "%s | %s\n" lnum (lines file !! (linum - 1)) 31 | printf "%s | %s\n" lpad (replicate (colnum - 1) ' ' ++ "^") 32 | printf "%s\n\n" (showError ns err) 33 | exitSuccess 34 | displayError file (Err _ _ Nothing) = 35 | error "impossible" 36 | 37 | 38 | mainWith :: IO [String] -> IO (Raw, String) -> IO () 39 | mainWith getOpt getTm = do 40 | let elab :: IO (Tm, Tm, Tm, U) 41 | elab = do 42 | reset 43 | (t, src) <- getTm 44 | (t, a, au) <- inferTopLams emptyCxt t `catch` displayError src 45 | t <- pure $ zonk VNil 0 t 46 | let ~nt = quote emptyCxt $ eval emptyCxt t 47 | let ~na = quote emptyCxt a 48 | pure (t, nt, na, forceU au) 49 | 50 | getOpt >>= \case 51 | ["--help"] -> putStrLn helpMsg 52 | ["nf"] -> do 53 | (t, nt, na, u) <- elab 54 | putStrLn $ show nt 55 | ["type"] -> do 56 | (t, nt, na, u) <- elab 57 | putStrLn $ show na 58 | ["univ"] -> do 59 | (t, nt, na, u) <- elab 60 | putStrLn $ show u 61 | ["elab"] -> do 62 | (t, nt, na, u) <- elab 63 | putStrLn $ show t 64 | _ -> putStrLn helpMsg 65 | 66 | main :: IO () 67 | main = mainWith getArgs parseStdin 68 | 69 | -- | Run main with inputs as function arguments. 70 | main' :: String -> String -> IO () 71 | main' mode src = mainWith (pure [mode]) ((,src) <$> parseString src) 72 | 73 | ------------------------------------------------------------ 74 | 75 | test = main' "nf" $ unlines [ 76 | "let add = ind (λ _. Nat → Nat) (λ x. x) (λ hyp x. suc (hyp x)) in", 77 | "let zero-add : {n} → Eq (add 0 n) n = refl in", 78 | "let add-zero", 79 | " = ind (λ n. Eq (add n 0) n)", 80 | " refl", 81 | " (λ {n} hyp. hyp)", 82 | " in", 83 | "add-zero" 84 | ] 85 | 86 | test2 = main' "elab" $ unlines [ 87 | "let foo : (p : Eq {Set} Set Prop)(A : Set) → Prop", 88 | " = λ p A. coe p A in", 89 | "let tr : {A : Set}(B : A → Set){x y} → Eq {A} x y → B x → B y", 90 | " = λ B p bx. coe (ap B p) bx in", 91 | 92 | "let regular : Eq (λ (A : Set)(p : Eq A A)(x : A). coe p x) (λ A p x. x) = λ _ _ _. refl in", 93 | "let comp : Eq (λ A B C (p : Eq {Set} A B)(q : Eq B C) x. coe q (coe p x))", 94 | " (λ A B C p q x. coe (trans p q) x) = λ _ _ _ _ _ _. refl in", 95 | 96 | "let picoe : (A B C D : Set)(p : Eq (A → B) (C → D))(f : A → B) → C → D", 97 | " = λ A B C D p f. coe p f in", 98 | 99 | "let foo : Eq {Set} Set Set = refl in", 100 | "let brek : Set × Set = coe (refl, λ _. refl) (Set, Set) in", 101 | "let brek2 : Set × Set = coe (ap (λ x. x) (sym (ap (λ x. x)(refl, λ _. refl)))) (Set, Set) in", 102 | "Set" 103 | 104 | ] 105 | 106 | test4 = main' "elab" $ unlines [ 107 | "λ(A : Set)", 108 | " (B : Set)", 109 | " (C : Set)", 110 | " (D : Set)", 111 | " (p : (p : Eq {Set} A C) × ((x : A) → Eq {Set} B D))", 112 | " (f : A → B)", 113 | " (x : C).", 114 | " coe {B} {D} ((p.₂) (coe {C} {A} (sym {Set} {A} {C} (p.₁)) x)) (f (coe {C} {A}", 115 | " (sym {Set} {A} {C} (p.₁)) x)) " 116 | ] 117 | 118 | test3 = main' "elab" $ unlines [ 119 | -- for testing proof irrelevance 120 | "let EqP : {A : Prop} → A → A → Set = λ {A} x y. (P : A → Set) → P x → P y in", 121 | "let reflP : {A x} → EqP {A} x x = λ P px. px in", 122 | 123 | "let theP : (A : Prop) → A → A = λ A x. x in", 124 | 125 | "let coeS : {A B : Set} → Eq A B → A → B = coe in", 126 | "let coeP : {A B : Prop} → Eq {Prop} A B → A → B = λ p. ₁ p in ", 127 | "let trS : {A : Set}(B : A → Set){x y} → Eq x y → B x → B y", 128 | " = λ {A} B {x}{y} p bx. coe (ap B p) bx in", 129 | "let trP : {A : Set}(B : A → Prop){x y} → Eq x y → B x → B y", 130 | " = λ {A} B {x}{y} p bx. coe (sym (sym (ap B p))) bx in", 131 | 132 | "let exfalsoS : {A : Set} → ⊥ → A = exfalso in", 133 | "let exfalsoP : {A : Prop} → ⊥ → A = exfalso in", 134 | "let trans2 : {A : Set}{x y z : A} → Eq x y → Eq y z → Eq x z", 135 | " = λ {_}{x} p q. trP (λ z. Eq x z) q p in", 136 | "let trans2 : {A : Set}{x y z : A} → Eq x y → Eq y z → Eq x z", 137 | " = trans in", 138 | 139 | "let irrel1 : Eq (λ (f : Set → ⊤ → Set) (x : ⊤) (y : ⊤). f Set x)", 140 | " (λ f x y. f Set y) =", 141 | " (λ _ _ _. refl) in", 142 | 143 | "let trans2 : {A}{a b c d : A} → Eq a b → Eq b c → Eq c d → Eq a d", 144 | " = λ p q r. trans (trans p q) r in", 145 | 146 | -- don't yet work! 147 | -- "let symex : {a b c d : Set} → Eq (a × b) (c × d) → Eq (c × d) (a × b)", 148 | -- " = λ p. sym p in", 149 | 150 | -- "let trans3 : {a b c d e f : Set} → Eq (a × b) (c × d) → Eq (c × d) (e × f) → Eq (a × b) (e × f)", 151 | -- " = λ p q r. trans (trans p q) r in", 152 | 153 | "let irrel2 : EqP (λ (x : ⊤)(y : ⊤). x) (λ x y. y) = reflP in", 154 | 155 | "let foo : (A : Set) × (A → Set) = (Set, λ A. A) in", 156 | 157 | "let sym2 : {A : Set}{x y : A} → Eq x y → Eq y x = sym in", 158 | 159 | "let foo : Eq ⊤ (⊤ × ⊤) = ((λ _. (tt, tt)), (λ _. tt)) in", 160 | "let bar : Eq (⊤ × ⊤) ⊤ = sym {Prop} {⊤}{⊤ × ⊤} foo in", 161 | 162 | -- type equality example 163 | "let bar : Eq (Set → Set) (Set → Set) = refl {Set}{Set → Set} in", 164 | "let bar2 : Eq (Set → Set) (Set → Set) = (tt, λ_.tt) in", 165 | "let bar3 : EqP bar bar2 = reflP in", 166 | 167 | "let foo : Eq (Eq Set Prop) ⊥ = refl {Prop}{⊥} in", 168 | 169 | 170 | "Set" 171 | ] 172 | -------------------------------------------------------------------------------- /setoidtt/flatparse/rustbench/benches/bench.rs: -------------------------------------------------------------------------------- 1 | #[macro_use] 2 | extern crate bencher; 3 | #[macro_use] 4 | extern crate nom; 5 | 6 | pub use bencher::Bencher; 7 | pub use nom::{ 8 | IResult, 9 | bytes::complete::{*}, 10 | character::complete::{*}, 11 | sequence::{*}, 12 | branch::{*}, 13 | error::{*} 14 | }; 15 | 16 | pub fn skip_many1(f: F) -> impl Fn(I) -> IResult 17 | where 18 | I: Clone + PartialEq, 19 | F: Fn(I) -> IResult, 20 | E: ParseError, 21 | { 22 | move |i: I| { 23 | let mut i = i.clone(); 24 | match f(i.clone()) { 25 | Err(nom::Err::Error(err)) => 26 | return Err(nom::Err::Error(E::append(i, ErrorKind::Many1, err))), 27 | Err(e) => return Err(e), 28 | Ok((i1, _)) => { 29 | i = i1; 30 | 31 | loop { 32 | match f(i.clone()) { 33 | Err(nom::Err::Error(_)) => return Ok((i, ())), 34 | Err(e) => return Err(e), 35 | Ok((i1, _)) => { 36 | if i1 == i { 37 | return Err(nom::Err::Error(E::from_error_kind(i, ErrorKind::Many1))); 38 | } 39 | i = i1; 40 | } 41 | } 42 | } 43 | } 44 | } 45 | } 46 | } 47 | 48 | pub fn skip_many0(f: F) -> impl Fn(I) -> IResult 49 | where 50 | I: Clone + PartialEq, 51 | F: Fn(I) -> IResult, 52 | E: ParseError, 53 | { 54 | move |i: I| { 55 | let mut i = i.clone(); 56 | loop { 57 | match f(i.clone()) { 58 | Err(nom::Err::Error(_)) => return Ok((i, ())), 59 | Err(e) => return Err(e), 60 | Ok((i1, _)) => { 61 | if i1 == i { 62 | return Err(nom::Err::Error(E::from_error_kind(i, ErrorKind::Many0))); 63 | } 64 | i = i1; 65 | } 66 | } 67 | } 68 | } 69 | } 70 | 71 | mod u8_bench { 72 | use super::{*}; 73 | 74 | named!{eof<&[u8],&[u8],()>, eof!()} 75 | 76 | fn ws(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 77 | take_while(|c| c == (' ' as u8) || c == ('\n' as u8))(i) 78 | } 79 | 80 | fn open(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 81 | preceded(char('('), ws)(i) 82 | } 83 | 84 | fn close(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 85 | preceded(char(')'), ws)(i) 86 | } 87 | 88 | fn ident(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 89 | preceded(alphanumeric1, ws)(i) 90 | } 91 | 92 | fn sexp(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 93 | alt((preceded(open, preceded(skip_many1(sexp), close)), ident))(i) 94 | } 95 | 96 | fn src(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 97 | preceded(sexp, eof)(i) 98 | } 99 | 100 | fn longw(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 101 | tag("thisisalongkeyword")(i) 102 | } 103 | 104 | fn longws(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 105 | preceded(skip_many1(preceded(longw, ws)), eof)(i) 106 | } 107 | 108 | fn numeral(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 109 | preceded(take_while1(|c| ('0' as u8) <= c && c <= ('9' as u8)), ws)(i) 110 | } 111 | 112 | fn numcsv(i : &[u8]) -> IResult<&[u8], &[u8], ()>{ 113 | preceded(numeral, preceded(skip_many0(preceded(char(','), preceded(ws, numeral))), eof))(i) 114 | } 115 | 116 | pub fn sexp_bench(bench: &mut Bencher) { 117 | let sexpinp = 118 | String::from("(") + 119 | "(foo (foo (foo ((bar baza)))))".repeat(33333).as_str() + 120 | ")"; 121 | bench.iter (|| { 122 | src(sexpinp.as_bytes()).is_ok() 123 | }); 124 | } 125 | 126 | pub fn numcsv_bench(bench: &mut Bencher) { 127 | let numcsv_inp : String = 128 | String::from("0") 129 | + (1..100000).map(|i| String::from(", ") + i.to_string().as_str()) 130 | .collect::>().join("").as_str(); 131 | bench.iter (|| { 132 | numcsv(numcsv_inp.as_bytes()).is_ok() 133 | }); 134 | } 135 | 136 | pub fn longws_bench(bench: &mut Bencher) { 137 | let longws_inp = "thisisalongkeyword ".repeat(55555); 138 | bench.iter (|| { 139 | longws(longws_inp.as_bytes()).is_ok() 140 | }); 141 | } 142 | } 143 | 144 | 145 | mod utf8_bench { 146 | 147 | use super::{*}; 148 | named!{eof<&str, &str, ()>, eof!()} 149 | 150 | fn ws(i : &str) -> IResult<&str, &str, ()>{ 151 | take_while(|c| c == ' ' || c == '\n')(i) 152 | } 153 | 154 | fn open(i : &str) -> IResult<&str, &str, ()>{ 155 | preceded(char('('), ws)(i) 156 | } 157 | 158 | fn close(i : &str) -> IResult<&str, &str, ()>{ 159 | preceded(char(')'), ws)(i) 160 | } 161 | 162 | fn ident(i : &str) -> IResult<&str, &str, ()>{ 163 | preceded(alphanumeric1, ws)(i) 164 | } 165 | 166 | fn sexp(i : &str) -> IResult<&str, &str, ()>{ 167 | alt((preceded(open, preceded(skip_many1(sexp), close)), ident))(i) 168 | } 169 | 170 | fn src(i : &str) -> IResult<&str, &str, ()>{ 171 | preceded(sexp, eof)(i) 172 | } 173 | 174 | fn longw(i : &str) -> IResult<&str, &str, ()>{ 175 | tag("thisisalongkeyword")(i) 176 | } 177 | 178 | fn longws(i : &str) -> IResult<&str, &str, ()>{ 179 | preceded(skip_many1(preceded(longw, ws)), eof)(i) 180 | } 181 | 182 | fn numeral(i : &str) -> IResult<&str, &str, ()>{ 183 | preceded(take_while1(|c| '0' <= c && c <= '9'), ws)(i) 184 | } 185 | 186 | fn numcsv(i : &str) -> IResult<&str, &str, ()>{ 187 | preceded(numeral, preceded(skip_many0(preceded(char(','), preceded(ws, numeral))), eof))(i) 188 | } 189 | 190 | pub fn sexp_bench(bench: &mut Bencher) { 191 | let sexpinp = 192 | String::from("(") + 193 | "(foo (foo (foo ((bar baza)))))".repeat(33333).as_str() + 194 | ")"; 195 | bench.iter (|| { 196 | src(sexpinp.as_str()).is_ok() 197 | }); 198 | } 199 | 200 | pub fn numcsv_bench(bench: &mut Bencher) { 201 | let numcsv_inp : String = 202 | String::from("0") 203 | + (1..100000).map(|i| String::from(", ") + i.to_string().as_str()) 204 | .collect::>().join("").as_str(); 205 | bench.iter (|| { 206 | numcsv(numcsv_inp.as_str()).is_ok() 207 | }); 208 | } 209 | 210 | pub fn longws_bench(bench: &mut Bencher) { 211 | let longws_inp = "thisisalongkeyword ".repeat(55555); 212 | bench.iter (|| { 213 | longws(longws_inp.as_str()).is_ok() 214 | }); 215 | } 216 | } 217 | 218 | 219 | benchmark_group!(u8_benches, u8_bench::sexp_bench, u8_bench::numcsv_bench, u8_bench::longws_bench); 220 | benchmark_group!(utf8_benches, utf8_bench::sexp_bench, utf8_bench::numcsv_bench, utf8_bench::longws_bench); 221 | benchmark_main!(utf8_benches, u8_benches); 222 | -------------------------------------------------------------------------------- /setoidtt/flatparse/Old/Switch.hs: -------------------------------------------------------------------------------- 1 | 2 | module Old.Switch where 3 | 4 | import Control.Monad 5 | import Data.Foldable 6 | import Data.Map.Strict (Map) 7 | import Old.FlatParse 8 | import GHC.Word 9 | import qualified Data.Map.Strict as M 10 | import Language.Haskell.TH 11 | 12 | data Trie a = Branch !a !(Map Word8 (Trie a)) 13 | deriving Show 14 | 15 | type Rule = Maybe Int 16 | 17 | nilTrie :: Trie Rule 18 | nilTrie = Branch Nothing mempty 19 | 20 | updRule :: Int -> Maybe Int -> Maybe Int 21 | updRule rule = Just . maybe rule (min rule) 22 | 23 | insert :: Int -> [Word8] -> Trie Rule -> Trie Rule 24 | insert rule = go where 25 | go [] (Branch rule' ts) = 26 | Branch (updRule rule rule') ts 27 | go (c:cs) (Branch rule' ts) = 28 | Branch rule' (M.alter (Just . maybe (go cs nilTrie) (go cs)) c ts) 29 | 30 | fromList :: [(Int, String)] -> Trie Rule 31 | fromList = foldl' (\t (r, s) -> insert r (charToBytes =<< s) t) nilTrie 32 | 33 | -- | Decorate a trie with the minimum lengths of non-empty paths. This 34 | -- is used later to place `ensureBytes#`. 35 | mindepths :: Trie Rule -> Trie (Rule, Int) 36 | mindepths (Branch rule ts) = 37 | if M.null ts then 38 | Branch (rule, 0) mempty 39 | else 40 | let !ts' = M.map mindepths ts in 41 | Branch ( 42 | rule, 43 | minimum (M.map (\(Branch (rule,d) _) -> maybe (d + 1) (\_ -> 1) rule) ts')) 44 | ts' 45 | 46 | data Trie' a 47 | = Branch' !a !(Map Word8 (Trie' a)) 48 | | Path !a ![Word8] !(Trie' a) 49 | deriving Show 50 | 51 | -- | Compress linear paths. 52 | pathify :: Trie (Rule, Int) -> Trie' (Rule, Int) 53 | pathify (Branch a ts) = case M.toList ts of 54 | [] -> Branch' a mempty 55 | [(w, t)] -> case pathify t of 56 | Path (Nothing, _) ws t -> Path a (w:ws) t 57 | t -> Path a [w] t 58 | _ -> Branch' a (M.map pathify ts) 59 | 60 | fallbacks :: Trie' (Rule, Int) -> Trie' (Rule, Int, Int) 61 | fallbacks = go Nothing 0 where 62 | go :: Rule -> Int -> Trie' (Rule, Int) -> Trie' (Rule, Int, Int) 63 | go !rule !n (Branch' (rule', d) ts) 64 | | M.null ts = Branch' (rule', 0, d) mempty 65 | | Nothing <- rule' = Branch' (rule, n, d) (go rule (n + 1) <$> ts) 66 | | otherwise = Branch' (rule, n, d) (go rule' 1 <$> ts) 67 | go rule n (Path (rule', d) ws t) 68 | | Nothing <- rule' = Path (rule, n, d) ws (go rule (n + 1) t) 69 | | otherwise = Path (rule', 0, d) ws (go rule' (length ws) t) 70 | 71 | -- | Decorate with `ensureBytes#` invocations, represented as 72 | -- `Maybe Int`. 73 | ensureBytes :: Trie' (Rule, Int, Int) -> Trie' (Rule, Int, Maybe Int) 74 | ensureBytes = go 0 where 75 | go :: Int -> Trie' (Rule, Int, Int) -> Trie' (Rule, Int, Maybe Int) 76 | go res = \case 77 | Branch' (r, n, d) ts 78 | | M.null ts -> Branch' (r, n, Nothing) mempty 79 | | res < 1 -> Branch' (r, n, Just d ) (go (d - 1) <$> ts) 80 | | otherwise -> Branch' (r, n, Nothing) (go (res - 1) <$> ts) 81 | Path (r, n, d) ws t -> case length ws of 82 | l | res < l -> Path (r, n, Just $! d - res) ws (go (d - l) t) 83 | | otherwise -> Path (r, n, Nothing ) ws (go (res - l) t) 84 | 85 | compileTrie :: [(Int, String)] -> Trie' (Rule, Int, Maybe Int) 86 | compileTrie = ensureBytes . fallbacks . pathify . mindepths . fromList 87 | 88 | genTrie :: (Map (Maybe Int) Exp, Trie' (Rule, Int, Maybe Int)) -> Q Exp 89 | genTrie (rules, t) = do 90 | branches <- traverse (\e -> (,) <$> (newName "rule") <*> pure e) rules 91 | 92 | let ix m k = case M.lookup k m of 93 | Nothing -> error ("key not in map: " ++ show k) 94 | Just a -> a 95 | 96 | let ensure :: Maybe Int -> Maybe (Q Exp) 97 | ensure = fmap (\n -> [| ensureBytes# n |]) 98 | 99 | fallback :: Rule -> Int -> Q Exp 100 | fallback rule 0 = pure $ VarE $ fst $ ix branches rule 101 | fallback rule n = [| setBack# n >> $(pure $ VarE $ fst $ ix branches rule) |] 102 | 103 | let go :: Trie' (Rule, Int, Maybe Int) -> Q Exp 104 | go = \case 105 | Branch' (r, n, alloc) ts 106 | | M.null ts -> pure $ VarE $ fst $ branches M.! r 107 | | otherwise -> do 108 | next <- (traverse . traverse) go (M.toList ts) 109 | fallb <- fallback r (n + 1) 110 | alloc <- maybe (pure []) (fmap $ \e -> [NoBindS e]) (ensure alloc) 111 | pure $ DoE $ 112 | alloc ++ 113 | [BindS (VarP (mkName "c")) (VarE 'scanAny8#), 114 | NoBindS (CaseE (VarE (mkName "c")) 115 | (map (\(w, t) -> 116 | Match (LitP (IntegerL (fromIntegral w))) 117 | (NormalB t) 118 | []) 119 | next 120 | ++ [Match WildP (NormalB fallb) []]))] 121 | Path (r, n, alloc) ws t -> 122 | case ensure alloc of 123 | Nothing -> [| br $(scanBytes# False ws) $(go t) $(fallback r n)|] 124 | Just alloc -> [| $alloc >> br $(scanBytes# False ws) $(go t) $(fallback r n) |] 125 | 126 | letE 127 | (map (\(x, rhs) -> valD (varP x) (normalB (pure rhs)) []) (toList branches)) 128 | (go t) 129 | 130 | parseSwitch :: Q Exp -> Q ([(String, Exp)], Maybe Exp) 131 | parseSwitch exp = exp >>= \case 132 | CaseE (UnboundVarE _) [] -> error "switch: empty clause list" 133 | CaseE (UnboundVarE _) cases -> do 134 | (cases, last) <- pure (init cases, last cases) 135 | cases <- forM cases \case 136 | Match (LitP (StringL str)) (NormalB rhs) [] -> pure (str, rhs) 137 | _ -> error "switch: expected a match clause on a string literal" 138 | (cases, last) <- case last of 139 | Match (LitP (StringL str)) (NormalB rhs) [] -> pure (cases ++ [(str, rhs)], Nothing) 140 | Match WildP (NormalB rhs) [] -> pure (cases, Just rhs) 141 | _ -> error "switch: expected a match clause on a string literal or a wildcard" 142 | pure (cases, last) 143 | _ -> error "switch: expected a \"case _ of\" expression" 144 | 145 | genSwitchTrie :: ([(String, Exp)], Maybe Exp) -> (Map (Maybe Int) Exp, Trie' (Rule, Int, Maybe Int)) 146 | genSwitchTrie (cases, fallback) = 147 | 148 | let (branches, strings) = unzip do 149 | (i, (str, rhs)) <- zip [0..] cases 150 | pure ((Just i, rhs), (i, str)) 151 | 152 | in ( M.fromList ((Nothing, maybe (VarE 'empty) id fallback) : branches) 153 | , compileTrie strings) 154 | 155 | switch :: Q Exp -> Q Exp 156 | switch exp = genTrie =<< (genSwitchTrie <$> parseSwitch exp) 157 | -------------------------------------------------------------------------------- /setoidtt/dynamic-array/Data/Array/Dynamic/L.hs: -------------------------------------------------------------------------------- 1 | 2 | module Data.Array.Dynamic.L ( 3 | empty 4 | , Array 5 | , clear 6 | , push 7 | , Data.Array.Dynamic.L.read 8 | , Data.Array.Dynamic.L.show 9 | , size 10 | , unsafeRead 11 | , unsafeWrite 12 | , write 13 | , modify' 14 | , unsafeLast 15 | , Data.Array.Dynamic.L.last 16 | , isEmpty 17 | -- , foldl' 18 | -- , foldlIx' 19 | -- , foldr' 20 | -- , foldrIx' 21 | -- , Data.Array.Dynamic.any 22 | -- , Data.Array.Dynamic.all 23 | -- , allIx 24 | -- , anyIx 25 | -- , forM_ 26 | -- , forMIx_ 27 | ) where 28 | 29 | import Data.Unlifted 30 | import Data.Array.UndefElem 31 | 32 | import qualified Data.Ref.UU as RUU 33 | import qualified Data.Ref.F as RF 34 | import qualified Data.Array.LM as LM 35 | 36 | type role Array representational 37 | newtype Array (a :: *) = Array (RUU.Ref (RF.Ref Int) (LM.Array a)) 38 | deriving Unlifted 39 | 40 | defaultCapacity :: Int 41 | defaultCapacity = 5 42 | {-# inline defaultCapacity #-} 43 | 44 | empty :: forall a. IO (Array a) 45 | empty = do 46 | sizeRef <- RF.new 0 47 | arrRef <- LM.new defaultCapacity undefElem 48 | Array <$> RUU.new sizeRef arrRef 49 | {-# inline empty #-} 50 | 51 | unsafeRead :: Array a -> Int -> IO a 52 | unsafeRead (Array r) i = do 53 | elems <- RUU.readSnd r 54 | LM.read elems i 55 | {-# inline unsafeRead #-} 56 | 57 | read :: Array a -> Int -> IO a 58 | read (Array r) i = do 59 | elems <- RUU.readSnd r 60 | if 0 <= i && i < LM.size elems then 61 | LM.read elems i 62 | else 63 | error "Data.Array.Dynamic.L.read: out of bounds" 64 | {-# inline read #-} 65 | 66 | unsafeWrite :: Array a -> Int -> a -> IO () 67 | unsafeWrite (Array r) i a = do 68 | elems <- RUU.readSnd r 69 | LM.write elems i a 70 | {-# inline unsafeWrite #-} 71 | 72 | write :: Array a -> Int -> a -> IO () 73 | write (Array r) i ~a = do 74 | s <- RF.read =<< RUU.readFst r 75 | if 0 <= i && i < s then 76 | unsafeWrite (Array r) i a 77 | else 78 | error "Data.Array.Dynamic.L.write: out of bounds" 79 | {-# inline write #-} 80 | 81 | modify' :: Array a -> Int -> (a -> a) -> IO () 82 | modify' (Array r) i f = do 83 | s <- RF.read =<< RUU.readFst r 84 | if 0 <= i && i < s then do 85 | elems <- RUU.readSnd r 86 | LM.modify' elems i f 87 | else 88 | error "Data.Array.Dynamic.L.write: out of bounds" 89 | {-# inline modify' #-} 90 | 91 | extendCapacity :: RUU.Ref (RF.Ref Int) (LM.Array a) -> a -> Int -> LM.Array a -> IO () 92 | extendCapacity r ~a cap elems = do 93 | let cap' = 2 * cap 94 | elems' <- LM.new cap' undefElem 95 | LM.copySlice elems 0 elems' 0 cap 96 | LM.write elems' cap a 97 | RUU.writeSnd r elems' 98 | {-# inlinable extendCapacity #-} 99 | 100 | push :: Array a -> a -> IO () 101 | push (Array r) ~a = do 102 | sizeRef <- RUU.readFst r 103 | elems <- RUU.readSnd r 104 | size <- RF.read sizeRef 105 | let cap = LM.size elems 106 | RF.write sizeRef (size + 1) 107 | if (size == cap) then do 108 | extendCapacity r a cap elems 109 | else do 110 | LM.write elems size a 111 | {-# inline push #-} 112 | 113 | clear :: Array a -> IO () 114 | clear (Array r) = do 115 | (`RF.write` 0) =<< RUU.readFst r 116 | RUU.writeSnd r =<< LM.new defaultCapacity undefElem 117 | {-# inline clear #-} 118 | 119 | size :: Array a -> IO Int 120 | size (Array r) = RF.read =<< RUU.readFst r 121 | {-# inline size #-} 122 | 123 | unsafeLast :: Array a -> IO a 124 | unsafeLast arr = do 125 | i <- size arr 126 | Data.Array.Dynamic.L.unsafeRead arr (i - 1) 127 | {-# inline unsafeLast #-} 128 | 129 | isEmpty :: Array a -> IO Bool 130 | isEmpty arr = (==0) <$> size arr 131 | {-# inline isEmpty #-} 132 | 133 | last :: Array a -> IO a 134 | last arr = do 135 | i <- size arr 136 | isEmpty arr >>= \case 137 | True -> error "Data.Array.Dynamic.last: empty array" 138 | _ -> unsafeRead arr (i - 1) 139 | {-# inline last #-} 140 | 141 | show :: Show a => Array a -> IO String 142 | show (Array r) = do 143 | elems <- RUU.readSnd r 144 | size <- RF.read =<< RUU.readFst r 145 | elems' <- LM.freezeSlice elems 0 size 146 | pure (Prelude.show elems') 147 | 148 | -- foldl' :: forall a b. (b -> a -> b) -> b -> Array a -> IO b 149 | -- foldl' f b = \arr -> _ 150 | 151 | -- foldl' f b = \arr -> do 152 | -- s <- size arr 153 | -- let go i b | i == s = pure b 154 | -- | otherwise = do 155 | -- a <- unsafeRead arr i 156 | -- go (i + 1) $! f b a 157 | -- go 0 b 158 | -- {-# inline foldl' #-} 159 | 160 | -- foldlIx' :: (Int -> b -> a -> b) -> b -> Array a -> IO b 161 | -- foldlIx' f b = \arr -> do 162 | -- s <- size arr 163 | -- let go i b | i == s = pure b 164 | -- | otherwise = do 165 | -- a <- unsafeRead arr i 166 | -- go (i + 1) $! f i b a 167 | -- go 0 b 168 | -- {-# inline foldlIx' #-} 169 | 170 | -- foldr' :: (a -> b -> b) -> b -> Array a -> IO b 171 | -- foldr' f b = \arr -> do 172 | -- s <- size arr 173 | -- let go i b | i == (-1) = pure b 174 | -- | otherwise = do 175 | -- a <- unsafeRead arr i 176 | -- go (i - 1) $! f a b 177 | -- go (s - 1) b 178 | -- {-# inline foldr' #-} 179 | 180 | -- foldrIx' :: (Int -> a -> b -> b) -> b -> Array a -> IO b 181 | -- foldrIx' f b = \arr -> do 182 | -- s <- size arr 183 | -- let go i b | i == (-1) = pure b 184 | -- | otherwise = do 185 | -- a <- unsafeRead arr i 186 | -- go (i - 1) $! f i a b 187 | -- go (s - 1) b 188 | -- {-# inline foldrIx' #-} 189 | 190 | -- -- TODO: any + all with lazy fold 191 | -- any :: (a -> Bool) -> Array a -> IO Bool 192 | -- any f = foldl' (\b a -> f a || b) False 193 | -- {-# inline any #-} 194 | 195 | -- all :: (a -> Bool) -> Array a -> IO Bool 196 | -- all f = foldl' (\b a -> f a && b) True 197 | -- {-# inline all #-} 198 | 199 | -- anyIx :: (Int -> a -> Bool) -> Array a -> IO Bool 200 | -- anyIx f = foldlIx' (\i b a -> f i a || b) False 201 | -- {-# inline anyIx #-} 202 | 203 | -- allIx :: (Int -> a -> Bool) -> Array a -> IO Bool 204 | -- allIx f = foldlIx' (\i b a -> f i a && b) True 205 | -- {-# inline allIx #-} 206 | 207 | -- forM_ :: Array a -> (a -> IO b) -> IO () 208 | -- forM_ arr f = go (0 :: Int) where 209 | -- go i = do 210 | -- s <- size arr 211 | -- if i == s then pure () else do {x <- unsafeRead arr i; f x; go (i + 1)} 212 | -- {-# inline forM_ #-} 213 | 214 | -- forMIx_ :: Array a -> (Int -> a -> IO b) -> IO () 215 | -- forMIx_ arr f = go (0 :: Int) where 216 | -- go i = do 217 | -- s <- size arr 218 | -- if i == s then pure () else do {x <- unsafeRead arr i; f i x; go (i + 1)} 219 | -- {-# inline forMIx_ #-} 220 | -------------------------------------------------------------------------------- /setoidtt/src/Values.hs: -------------------------------------------------------------------------------- 1 | 2 | module Values where 3 | 4 | import GHC.Types (Int(..)) 5 | import GHC.Prim (Int#, (/=#), unsafeCoerce#) 6 | import Common 7 | import qualified Syntax as S 8 | import GHC.Magic 9 | 10 | -------------------------------------------------------------------------------- 11 | 12 | switchClosure# :: Lvl -> (# Int#, Int# #) 13 | switchClosure# (Lvl (I# l)) = (# l, l /=# (-1#) #) 14 | {-# inline switchClosure# #-} 15 | 16 | data Closure = Closure# WEnv Lvl S.WTm 17 | 18 | pattern Close :: Env -> Lvl -> S.Tm -> Closure 19 | pattern Close env l t <- Closure# (S -> env) (switchClosure# -> (# ((\x -> Lvl (I# x)) -> l), 1# #)) (S -> t) where 20 | Close (S env) l (S t) = Closure# env l t 21 | 22 | pattern Fun :: (WVal -> Val) -> Closure 23 | pattern Fun f <- Closure# ((\x -> sFun1 (unsafeCoerce# x)) -> f) (switchClosure# -> (# _, 0# #)) _ where 24 | Fun f = Closure# (unsafeCoerce# (oneShot (unSFun1 (oneShot f)))) (-1) (unsafeCoerce# ()) 25 | {-# complete Close, Fun #-} 26 | 27 | type Env = S WEnv 28 | data WEnv 29 | = WNil 30 | | WSnoc Env ~WVal 31 | pattern Nil = S WNil 32 | pattern Snoc env v <- S (WSnoc env v) where Snoc env ~v = S (WSnoc env v) 33 | {-# complete Nil, Snoc #-} 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | data RigidHead 38 | = RHLocalVar Lvl 39 | | RHPostulate Lvl 40 | | RHCoe Val Val Val Val 41 | | RHRefl Ty Val 42 | | RHSym Val Val Val Val 43 | | RHTrans Val Val Val Val Val Val 44 | | RHAp Val Val Val Val Val Val 45 | | RHExfalso S.U Val Val 46 | 47 | data FlexHead 48 | -- blocking on Meta 49 | = FHMeta MetaVar 50 | | FHCoeRefl MetaVar Val Val Val Val 51 | 52 | -- blocking on Max 53 | | FHCoeMax S.UMax Val Val Val Val 54 | | FHEqMax S.UMax Val Val Val 55 | 56 | data UnfoldHead -- TODO: unpack 57 | = UHMeta MetaVar 58 | | UHTopDef Lvl 59 | 60 | -------------------------------------------------------------------------------- 61 | 62 | -- Blocking on Val in nested ways. 63 | type Spine = S WSpine 64 | data Spine2 = Spine2 Spine Spine 65 | data WSpine 66 | = WSNil 67 | | WSApp Spine Val S.U Icit 68 | 69 | | WSProj1 Spine 70 | | WSProj2 Spine 71 | | WSProjField Spine Name Int 72 | 73 | | WSCoeSrc Spine Val Val Val -- netural source type 74 | | WSCoeTgt Val Spine Val Val -- neutral target type 75 | | WSCoeComp Val Val Val Spine -- composition blocking on neutral coerced value 76 | 77 | | WSEqType Spine Val Val 78 | | WSEqSetLhs Spine Val 79 | | WSEqSetRhs Val Spine 80 | pattern SNil = S (WSNil) 81 | pattern SApp sp t u i = S (WSApp sp t u i) 82 | pattern SProj1 sp = S (WSProj1 sp) 83 | pattern SProj2 sp = S (WSProj2 sp) 84 | pattern SProjField sp x i = S (WSProjField sp x i) 85 | pattern SCoeSrc a b p t = S (WSCoeSrc a b p t) 86 | pattern SCoeTgt a b p t = S (WSCoeTgt a b p t) 87 | pattern SCoeComp a b p t = S (WSCoeComp a b p t) 88 | pattern SEqType a t u = S (WSEqType a t u) 89 | pattern SEqSetLhs a t = S (WSEqSetLhs a t) 90 | pattern SEqSetRhs a t = S (WSEqSetRhs a t) 91 | {-# complete SNil, SApp, SProj1, SProj2, SProjField, SCoeSrc, SCoeTgt, SCoeComp, 92 | SEqType, SEqSetLhs, SEqSetRhs #-} 93 | 94 | -------------------------------------------------------------------------------- 95 | 96 | type Ty = Val 97 | type WTy = WVal 98 | type Val = S WVal 99 | data Val2 = Val2 Val Val 100 | data WVal 101 | -- Rigidly stuck values 102 | = WRigid RigidHead Spine 103 | 104 | -- Flexibly stuck values 105 | | WFlex FlexHead Spine 106 | 107 | -- Non-deterministic values 108 | | WUnfold UnfoldHead Spine ~WVal -- unfolding choice (top/meta) 109 | | WEq Val Val Val Val -- Eq computation to non-Eq type 110 | 111 | -- Canonical values 112 | | WPair Val S.U Val S.U 113 | | WLam Name Icit Ty S.U {-# unpack #-} Closure 114 | | WSg Name Ty S.U {-# unpack #-} Closure S.U 115 | | WPi Name Icit Ty S.U {-# unpack #-} Closure 116 | | WU S.U 117 | | WTop 118 | | WTt 119 | | WBot 120 | 121 | pattern Rigid h sp = S (WRigid h sp) 122 | pattern Flex h sp = S (WFlex h sp) 123 | pattern Unfold h sp t <- S (WUnfold h sp t) where Unfold h sp ~t = S (WUnfold h sp t) 124 | pattern Eq a t u v <- S (WEq a t u v) where Eq a t u ~v = S (WEq a t u v) 125 | pattern U u = S (WU u) 126 | pattern Top = S (WTop) 127 | pattern Tt = S (WTt) 128 | pattern Bot = S (WBot) 129 | pattern Pair t tu u uu = S (WPair t tu u uu) 130 | pattern Sg x a au b bu = S (WSg x a au b bu) 131 | pattern Pi x i a au b = S (WPi x i a au b) 132 | pattern Lam x i a au t = S (WLam x i a au t) 133 | {-# complete Rigid, Flex, Unfold, Eq, U, Top, Tt, Bot, Pair, Sg, Pi, Lam #-} 134 | 135 | 136 | -------------------------------------------------------------------------------- 137 | 138 | pattern SAppIS sp t = SApp sp t S.Set Impl 139 | pattern SAppES sp t = SApp sp t S.Set Expl 140 | pattern SAppIP sp t = SApp sp t S.Prop Impl 141 | pattern SAppEP sp t = SApp sp t S.Prop Expl 142 | pattern LamIS x a b = Lam x Impl a S.Set (Fun b) 143 | pattern LamES x a b = Lam x Expl a S.Set (Fun b) 144 | pattern LamIP x a b = Lam x Impl a S.Prop (Fun b) 145 | pattern LamEP x a b = Lam x Expl a S.Prop (Fun b) 146 | pattern PiES x a b = Pi x Expl a S.Set (Fun b) 147 | pattern PiEP x a b = Pi x Expl a S.Prop (Fun b) 148 | pattern SgPP x a b = Sg x a S.Prop (Fun b) S.Prop 149 | pattern Meta m = Flex (FHMeta m) SNil 150 | pattern Set = U S.Set 151 | pattern Prop = U S.Prop 152 | pattern WSet = WU S.Set 153 | pattern WProp = WU S.Prop 154 | pattern Var x = Rigid (RHLocalVar x) SNil 155 | pattern Skip env l = Snoc env (WRigid (RHLocalVar l) SNil) 156 | pattern Exfalso u a t = Rigid (RHExfalso u a t) SNil 157 | pattern Refl a t = Rigid (RHRefl a t) SNil 158 | pattern Sym a x y p = Rigid (RHSym a x y p) SNil 159 | pattern Trans a x y z p q = Rigid (RHTrans a x y z p q) SNil 160 | pattern Ap a b f x y p = Rigid (RHAp a b f x y p) SNil 161 | 162 | andP :: Val -> Val -> Val 163 | andP a b = Sg NEmpty a S.Prop (Fun (\ ~_ -> b)) S.Prop 164 | {-# inline andP #-} 165 | 166 | implies :: Val -> Val -> Val 167 | implies a b = PiEP NEmpty a (\ ~_ -> b) 168 | {-# inline implies #-} 169 | 170 | -- | Non-dependent function type. 171 | fun :: Ty -> S.U -> Ty -> Ty 172 | fun a au b = Pi NEmpty Expl a au (Fun \ ~_ -> b) 173 | {-# inline fun #-} 174 | 175 | -- | Non-dependent pair type. 176 | prod :: Ty -> S.U -> Ty -> S.U -> Ty 177 | prod a au b bu = Sg NEmpty a au (Fun \ ~_ -> b) bu 178 | {-# inline prod #-} 179 | 180 | -- | Non-dependent pair type. 181 | wprod :: Ty -> S.U -> Ty -> S.U -> WTy 182 | wprod a au b bu = WSg NEmpty a au (Fun \ ~_ -> b) bu 183 | {-# inline wprod #-} 184 | -------------------------------------------------------------------------------- /proto/README.md: -------------------------------------------------------------------------------- 1 | # setoidtt-proto 2 | Prototype implementation for a variant of setoid type theory. This repository currently contains a stack package, whose source code is forked from [fcif](https://github.com/AndrasKovacs/icfp20sub/tree/master/fcif). 3 | 4 | The goal of the current `setoidtt` is to figure out various details in design choices, type inference, evaluation and ergonomics. Thus it lacks many features and it only operates on a file containing a single expression. Its pretty printing and error messages are also very rough. 5 | 6 | I plan to start a second "production-strength" implementation after basic design choices are hammered out. The second version will hopefully turn into a longer-term project where I throw in all kinds of advanced elaboration features. 7 | 8 | #### Features & inspiration 9 | 10 | Precedents: 11 | 12 | - [Observational Type Theory](https://www.researchgate.net/publication/248136193_Towards_Observational_Type_Theory), which is 13 | approximately implemented in [sott](https://github.com/bobatkey/sott). 14 | - [Setoid type theory](https://hal.inria.fr/hal-02281225/document). 15 | 16 | The current implementation differs from both of the above. However, my intended semantics is clearly in setoids, i.e. every closed type is a set together with a proof-irrelevant equivalence relation, and every dependent type is a setoid fibration. I also find "setoid" more precise than "observational", since the latter is perhaps also descriptive of homotopy type theories, and we explicitly disallow types above the h-level of sets. 17 | 18 | Core theory: 19 | 20 | - Strict `Prop` with [definitional proof irrelevance](https://dl.acm.org/doi/10.1145/3290316). 21 | - A universe `Set` of set(oid)s with `Prop : Set` and `Set : Set`. 22 | - `Prop` is *not* a subtype of `Set`. An embedding from `Prop` to `Set` is definable though, with sigmas and equality. 23 | - Sigma, Pi, `⊤` and `⊥` type formers. `⊤` and `⊥` are in `Prop`. Sigma is in `Prop` if both fields are in `Prop`, Pi is in `Prop` if the codomain is in `Prop`. We can eliminate from `⊥` to both `Prop` and `Set`. 24 | - Equality type `Eq : {A : Set} → A → A → Prop`. 25 | - `coe : {A B : Set} → Eq A B → A → B`. 26 | - `refl : {A : Set}{x : A} → Eq x x`. 27 | - `Eq` and `coe` compute on type/term structure, in particular we have 28 | - Propositional extensionality: `Eq {Prop} A B = ((A → B) ∧ (B → A))` 29 | - Function extensionality: `Eq {(x : A) → B} f g = ((x : A) → Eq (f x) (g x))`. This implies that congruence can be 30 | derived from `refl` at function type. 31 | - Injective type formers. 32 | - Besides the canonical cases for `coe` computation, we also have `coe (p : Eq A A) x = x` and `coe p (coe q x) = coe (trans q p) x`. Semantically, these correspond to open types being split fibrations, not just fibrations. 33 | 34 | That's it. In the actual implementation, a few additional convenient primitives are built in, which are nevertheless derivable in the above core theory: 35 | 36 | - `coe` for `Prop`, an overloading of `coe` as `Eq {Prop} A B → A → B`. 37 | - Symmetry, transitivity and congruence for `Eq`. 38 | 39 | Implementation features: 40 | 41 | - Implicit arguments, first-class implicit function types, metavariables, pattern unification with pruning. 42 | - Universe inference with simple but apparently effective universe unification, for universe polymorphic constructions 43 | such as functions, sigmas and `coe`. 44 | - Enhanced type inference for `Eq` and `coe`: extension of bidirectional discipline to also propagate information about equation sides + a variant of glued evaluation which tracks `Eq` types even after they are computed away. 45 | - Type-based field projections for right-nested sigma types. E.g. if `t : (A : Set) × (foo : A) × ⊤`, then 46 | `t.foo : t.A`. 47 | - A novel solution for unification with strict `Prop`, where unification is universe-directed but not type-directed. I find this a sweet spot between the full-blown type directed unification of Agda (which is powerful but adds complexity and performance overhead), and the fully syntax-directed unification of Coq, which is frankly rather ugly and fiddly for strict `Prop`. 48 | 49 | Difference from prior/related works: 50 | 51 | 1. Versus OTT: no heterogeneous equality. I think that HEq is an unnecessary complication with dubious practical benefits. The entire point of using HEq in usual MLTT+UIP is that we want to avoid proving and invoking coercion computation laws as much as possible, instead collecting every coercion into a single hidden coercion, which can be eliminated by UIP in one shot when we want to go back to homogeneous equality. Given computing coercion and proof-irrelevant equalities, the motivation for HEq is largely lost. While we can still try to base our system around HEq, as OTT did, we actually end up with more proof obligations and code duplication in general, as HEq-s require re-proving type equalities whenever we want to talk about value equalities. 52 | 53 | 2. Versus STT: no explicit substitutions, no "dependent" equality. The point here is that as soon as we have every type in some universe, type equality is *always* just equality of type codes, and coercion is always just over a single homogeneous equality of type codes. Hence, the "local universes"-style coercions with explicit substitutions are not necessary anymore, which is good news, since the STT-style coercion would be a major pain to implement in an ergonomic way. 54 | 55 | 3. Versus [XTT](https://arxiv.org/abs/1904.08562): XTT is a set-truncated cubical type theory. Compared to it, `setoidtt` is simpler in syntax and semantics, supports more computation rules (e.g. function equality is pointwise by definition) and supports propositional extensionality. `setoidtt` also has no need for the rather ugly typecasing construction in XTT. IMO, cubical type theory is oversized for set-level mathematics, and `setoidtt` seems to be practically better in this setting. 56 | 57 | Semantics: TODO, but I conjecture that a standard setoid model can be given similarly to STT (of course, assuming we have consistent universe setup without `Set : Set`). In the current system, the only dubious point is the strict computation of `Eq` on canonical type formers. This is semantically justified by a very general, hitherto undescribed form of induction-recursion. If injectivity of type formers is only given weakly as "projections", as in [sott](https://github.com/bobatkey/sott), that can be modeled with large induction-induction, see "Constructing a universe for the setoid model" [here](https://types2020.di.unito.it/abstracts/BookOfAbstractsTYPES2020.pdf). 58 | 59 | AFAIK, the interpretation of split fibration laws for general inductive types is also open research topic now, but we don't yet have such types here. 60 | 61 | #### Installation 62 | 63 | - Install Haskell Stack: https://docs.haskellstack.org/en/stable/README/ if you don't already have it 64 | - `stack install` from this directory 65 | - This copies the executable `setoidtt` to `~/.local/bin`. 66 | 67 | #### Usage 68 | 69 | The executable `setoidtt` reads an expression from standard input. 70 | 71 | - `setoidtt elab` prints elaboration output. 72 | - `setoidtt nf` prints the normal form of the input. 73 | - `setoidtt type` prints the normal form of the type of the input. 74 | -------------------------------------------------------------------------------- /proto/examples/setoidtt-impl-intro-notes.txt: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | 4 | QIIT, setoid TT, type inference / performance 5 | - demo implementations 6 | - practical implementation (platform for Your Ideas) 7 | 8 | -- short term goals (a couple of weeks), longer terms goals 9 | -- (infinite amount of work can be done) 10 | 11 | 12 | Motivation: (short term goals) 13 | - System for *set*-level mathematics & programming (no HoTT) 14 | - much better ergonomic & expressiveness if we're only focusing on set-level math 15 | - (cubical type theory) improves on std MLTT 16 | - even better is possible, if we are only focusing on sets (setoid-TT) 17 | - less general than cubical TT, but easier to use 18 | - (for *normal* math and programming, it's sufficient) 19 | - (Lean: push for large-scale formalization of *normal* math 20 | - they only use set-level type theory!) 21 | - Lean doesn't have setoid features! 22 | 23 | - Target group: - people who want to formalize normal math 24 | - people who want to formalize metatheory of TT/PL 25 | - setoid TT helps, QIIT, equality reflection, metaprogramming algebraic signatures 26 | - (also e.g. Carette et al. 27 | https://wiki.hh.se/wg211/images/c/cb/WG211_M19_Carette.pdf in Agda) 28 | 29 | (longer-term) 30 | (defining what a Monoid is ---> get for free the type of Monoid-homomorphisms) 31 | ---> get for the category of monoids) 32 | 33 | - Efficiency 34 | 35 | - (longer term goal) : add PL features / code generation 36 | - (not too difficult to outsource (pretty easy to write codegen for example)) 37 | - (... I have lots of PL feature ideas (staging, memory layouts, type classes)) 38 | 39 | - previous work observational type theory: https://github.com/bobatkey/sott 40 | - (non-practical) 41 | 42 | 43 | - Question about codegen and performance? 44 | 45 | - We could have a system, with *slower* evaluation than in Coq, but much better performance 46 | - Type checking with machine code evaluation for conversion checking: works 47 | - it's a huge amount of work to do it 48 | - interpreter in GHC: already in the ~5-10x performance ballpark 49 | 50 | 51 | - In Coq: I have a function f : Unit -> Unit -> Unit -> Unit .... -> Unit (N-times) 52 | - I have a term : f () () () () ..... () complexity of checking in N? 53 | (quadratic in N) 54 | 55 | - Jason Gross (PhD thesis on Coq performance) 56 | 57 | - (length-indexed Vector): cons True (cons True ...... nil) (N-times) (quadratic in Agda & Coq) 58 | 59 | - (in Agda: initiality conjecture: https://github.com/guillaumebrunerie/initiality) 60 | - HoTTest seminar: requires 24 Gb to type check 61 | 62 | 63 | - How to achieve performance: 64 | 65 | - principled approach (based Thierry Coquand's algorithm ~95) 66 | - boost: non-determenistic evaluation (nbe) (originally: glued evaluation) 67 | (better version: Olle Fredriksson) 68 | multiple evaluation strategies for different goals during checking 69 | - check whether two terms are equal (full-blown evaluation) 70 | - genereting terms which are as small as possible (avoids unfolding) 71 | (serialize a term) 72 | (display a term for the user) 73 | (fill a hole in source by inference) 74 | 75 | non-deterministic choice between different evaluation strategies 76 | 77 | eval :: Tm -> Val 78 | eval (TopLvlDef x) = Choice (eval (unfold x)) x -- lazy choice 79 | 80 | conversionCheck :: Val -> Val -> Bool 81 | conversionCheck (Choice v _) v' = conversionCheck v v' 82 | 83 | readBack :: Val -> Tm 84 | readBack (Choice _ x) = TopLvlDef x 85 | 86 | injectivity analysis + "forcing" analysis 87 | 88 | Example: list type: List : Set -> Set 89 | cons : {A : Set} -> A -> List A -> List A 90 | 91 | check conversion of (cons {A} x xs) (cons {A'} x' xs')? (of type List A) 92 | - (conversion checking only works on value of the same type) 93 | - don't have to compare A and A'! 94 | - Agda: any parameter to an inductive type is skipped during conversion (erased) 95 | 96 | To analyse *everything* for this kind "forcing" in conversion checking 97 | 1. Is a definition injective up to definitional equality? 98 | (f : Nat -> Nat 99 | f x = suc (suc (suc x))) (f x ≡ f y) → x ≡ y 100 | 2. Which arguments are completely determined by types? 101 | 102 | ( No benchmark yet !) 103 | 104 | 105 | Concrete feature set on short term: 106 | 107 | - basic setoidtt (as in proto (Pi, Sigma, Set, SProp, funext, propext, computation for coe)) 108 | 109 | - basic performance features: 110 | - non-det eval 111 | - injectivity/forcing analysis 112 | - fast supporting libraries (parsing, serialization) 113 | 114 | - modules (without params!) 115 | (Agda: modules with parameters, nested modules, namespace op: import with renaming, 116 | qualified imports, but no *first-class* modules (reasearch topic in ML-like langs)) 117 | - basic cmdline interaction 118 | 119 | Modules: 120 | 121 | - trade-off between evaluation efficiency and "flexibility" of module system 122 | - Type checking involves arbitrary code execution 123 | - (in normal PLs, if we execute code: we are executing a linked single executable) 124 | - single address space of every function (array of top-level definitions) 125 | 126 | - Idea: at all times, we have a single top-level address space 127 | - module loading: relocation of a position-indepedent (de Bruijn indices) code into address space 128 | - evaluator: every top-level lookup is just an array indexing 129 | (this is *not* the case in Agda and Coq) 130 | 131 | Modules vs type classes: 132 | - module is record + extra features (namespacing, configuration) 133 | - type class : is a code generator (a program in a restricted logic programming language 134 | - which generates code) 135 | 136 | Module params: 137 | 138 | - Simple way: create a new copy for every instantiation 139 | (conjecture: this is OK) 140 | (caching: in general I avoid caching/hash-consing like it's the plague) 141 | what are we caching: 142 | - normal forms? (problem: game over) 143 | - small representations? (problem: caching is imprecise) 144 | 145 | - Is it possible in realistic code to have really large parameters for modules? 146 | - Yes. 147 | - Metatheory of type theory: (parametrizing a module with a model of some type theory) 148 | 149 | - (BENCHMARK!) 150 | 151 | module Foo (A : Bar) where 152 | 153 | def1 : Nat 154 | def1 = ... 155 | 156 | def2 : Nat 157 | def2 = ... 158 | 159 | Strategy 1 (new copy) (A becomes defined in the new copy) 160 | 161 | import Foo barExp 162 | 163 | A = barExp 164 | def1 : Nat 165 | def1 = ... [still points to A] 166 | def2 : Nat 167 | def2 = ... [still points to A] 168 | 169 | Stratgy 2 (abstract over A everywhere) 170 | 171 | -} 172 | --------------------------------------------------------------------------------