├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── README.md ├── agda2scheme.cabal ├── app └── Main.hs ├── src ├── Agda │ └── Compiler │ │ ├── Erase.hs │ │ └── ToScheme.hs └── Main.hs └── test ├── Erasure.agda ├── Erasure.ss ├── First.agda ├── First.ss ├── Nats.agda ├── Nats.ss ├── Triples.agda ├── Triples.ss ├── TriplesFO.agda ├── formalize-all-the-things.agda └── formalize-all-the-things.ss /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | on: [push] 2 | name: build 3 | jobs: 4 | runhaskell: 5 | name: agda2scheme 6 | runs-on: ubuntu-latest 7 | steps: 8 | - name: Checks-out repository 9 | uses: actions/checkout@v4 10 | 11 | - name: Set up GHC 12 | uses: haskell-actions/setup@v2 13 | id: setup 14 | with: 15 | ghc-version: '9.0' 16 | # Defaults, added for clarity: 17 | cabal-version: 'latest' 18 | cabal-update: true 19 | 20 | - name: Configure the build 21 | run: | 22 | cabal configure --enable-tests --enable-benchmarks --disable-documentation 23 | cabal build --dry-run 24 | # The last step generates dist-newstyle/cache/plan.json for the cache key. 25 | 26 | - name: Restore cached dependencies 27 | uses: actions/cache/restore@v3 28 | id: cache 29 | env: 30 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} 31 | with: 32 | path: ${{ steps.setup.outputs.cabal-store }} 33 | key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} 34 | restore-keys: ${{ env.key }}- 35 | 36 | - name: Install dependencies 37 | # If we had an exact cache hit, the dependencies will be up to date. 38 | if: ${{ steps.cache.outputs.cache-hit != 'true' }} 39 | run: cabal build all --only-dependencies 40 | 41 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 42 | - name: Save cached dependencies 43 | uses: actions/cache/save@v3 44 | # If we had an exact cache hit, trying to save the cache would error because of key clash. 45 | if: ${{ steps.cache.outputs.cache-hit != 'true' }} 46 | with: 47 | path: ${{ steps.setup.outputs.cabal-store }} 48 | key: ${{ steps.cache.outputs.cache-primary-key }} 49 | 50 | - name: Build 51 | run: cabal build all 52 | 53 | - name: Run tests 54 | run: cabal test all 55 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | *.agdai 4 | MAlonzo 5 | *.prof 6 | *.treeless 7 | *.hi 8 | *.o 9 | *.agda# 10 | *~ 11 | .#*.agda 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | agda2scheme: An Agda backend for Chez Scheme 2 | ============================================ 3 | 4 | This is a work in progress on compiling Agda to Chez Scheme. 5 | -------------------------------------------------------------------------------- /agda2scheme.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: agda2scheme 3 | version: 0.1.0.0 4 | synopsis: Agda backend for Chez Scheme 5 | description: - 6 | 7 | -- A URL where users can report bugs. 8 | -- bug-reports: 9 | 10 | -- The license under which the package is released. 11 | -- license: 12 | author: Jesper Cockx 13 | maintainer: jesper@sikanda.be 14 | 15 | -- A copyright notice. 16 | -- copyright: 17 | -- category: 18 | extra-source-files: 19 | 20 | executable agda2scheme 21 | main-is: Main.hs 22 | 23 | -- Modules included in this executable, other than Main. 24 | other-modules: Agda.Compiler.ToScheme 25 | Agda.Compiler.Erase 26 | 27 | -- LANGUAGE extensions used by modules in this package. 28 | -- other-extensions: 29 | build-depends: base ^>=4.15.0.0 30 | , Agda >= 2.6.2.1 && < 2.6.3 31 | , containers >= 0.5.7.1 32 | , deepseq >= 1.4.5 33 | , mtl >= 2.2.2 34 | , pretty >= 1.1.3.3 35 | , s-cargot >= 0.1.4 36 | , text >= 1.2.3.1 37 | hs-source-dirs: src 38 | default-language: Haskell2010 39 | 40 | default-extensions: BlockArguments 41 | , ConstraintKinds 42 | , DefaultSignatures 43 | , DeriveAnyClass 44 | , DeriveFoldable 45 | , DeriveFunctor 46 | , DeriveGeneric 47 | , DeriveTraversable 48 | , ExistentialQuantification 49 | , FlexibleContexts 50 | , FlexibleInstances 51 | , FunctionalDependencies 52 | , GeneralizedNewtypeDeriving 53 | , LambdaCase 54 | , MultiParamTypeClasses 55 | , MultiWayIf 56 | , NamedFieldPuns 57 | , OverloadedStrings 58 | , PatternSynonyms 59 | , RankNTypes 60 | , RecordWildCards 61 | , ScopedTypeVariables 62 | , StandaloneDeriving 63 | , TupleSections 64 | , TypeSynonymInstances 65 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn "Hello, Haskell!" 5 | -------------------------------------------------------------------------------- /src/Agda/Compiler/Erase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | -- This is a copy of the module Agda.Compiler.Treeless.Erase from the 4 | -- main Agda repository, but without an export list so all functions 5 | -- can be used. 6 | 7 | module Agda.Compiler.Erase where 8 | 9 | import Control.Arrow (first, second) 10 | import Control.Monad 11 | import Control.Monad.State 12 | import Data.Map (Map) 13 | import qualified Data.Map as Map 14 | import qualified Data.List as List 15 | 16 | import Agda.Syntax.Common 17 | import Agda.Syntax.Internal as I 18 | import Agda.Syntax.Position 19 | import Agda.Syntax.Treeless 20 | import Agda.Syntax.Literal 21 | 22 | import Agda.TypeChecking.Substitute 23 | import Agda.TypeChecking.Monad as I 24 | import Agda.TypeChecking.Telescope 25 | import Agda.TypeChecking.Datatypes 26 | import Agda.TypeChecking.Pretty 27 | import Agda.TypeChecking.Primitive 28 | 29 | import Agda.Compiler.Backend 30 | import Agda.Compiler.Treeless.Subst 31 | import Agda.Compiler.Treeless.Unused 32 | 33 | import Agda.Utils.Functor 34 | import Agda.Utils.Lens 35 | import Agda.Utils.Maybe 36 | import Agda.Utils.Memo 37 | import Agda.Utils.Monad 38 | import Agda.Utils.Pretty (prettyShow) 39 | import Agda.Utils.IntSet.Infinite (IntSet) 40 | import qualified Agda.Utils.IntSet.Infinite as IntSet 41 | 42 | import Agda.Utils.Impossible 43 | 44 | -- | State of the eraser. 45 | data ESt = ESt 46 | { _funMap :: Map QName FunInfo 47 | -- ^ Memoize computed `FunInfo` for functions/constructors/... `QName`. 48 | , _typeMap :: Map QName TypeInfo 49 | -- ^ Memoize computed `TypeInfo` for data/record types `QName`. 50 | } 51 | 52 | funMap :: Lens' (Map QName FunInfo) ESt 53 | funMap f r = f (_funMap r) <&> \ a -> r { _funMap = a } 54 | 55 | typeMap :: Lens' (Map QName TypeInfo) ESt 56 | typeMap f r = f (_typeMap r) <&> \ a -> r { _typeMap = a } 57 | 58 | -- | Eraser monad. 59 | type E = StateT ESt TCM 60 | 61 | runE :: E a -> TCM a 62 | runE m = evalStateT m (ESt Map.empty Map.empty) 63 | 64 | data TypeInfo = Empty | Erasable | NotErasable 65 | deriving (Eq, Show) 66 | 67 | sumTypeInfo :: [TypeInfo] -> TypeInfo 68 | sumTypeInfo is = foldr plus Empty is 69 | where 70 | plus Empty r = r 71 | plus r Empty = r 72 | plus Erasable r = r 73 | plus r Erasable = r 74 | plus NotErasable NotErasable = NotErasable 75 | 76 | erasable :: TypeInfo -> Bool 77 | erasable Erasable = True 78 | erasable Empty = True 79 | erasable NotErasable = False 80 | 81 | type FunInfo = ([TypeInfo], TypeInfo) 82 | 83 | getFunInfo :: QName -> E FunInfo 84 | getFunInfo q = memo (funMap . key q) $ getInfo q 85 | where 86 | getInfo :: QName -> E FunInfo 87 | getInfo q = do 88 | (rs, t) <- do 89 | (tel, t) <- lift $ typeWithoutParams q 90 | is <- mapM (getTypeInfo . snd . dget) tel 91 | used <- lift $ (++ repeat ArgUsed) . fromMaybe [] <$> getCompiledArgUse q 92 | forced <- lift $ (++ repeat NotForced) <$> getForcedArgs q 93 | return (zipWith3 (uncurry . mkR . getModality) tel (zip forced used) is, t) 94 | h <- if isAbsurdLambdaName q then pure Erasable else getTypeInfo t 95 | lift $ reportSLn "treeless.opt.erase.info" 50 $ "type info for " ++ prettyShow q ++ ": " ++ show rs ++ " -> " ++ show h 96 | lift $ setErasedConArgs q $ map erasable rs 97 | return (rs, h) 98 | 99 | -- Treat empty, erasable, or unused arguments as Erasable 100 | mkR :: Modality -> IsForced -> ArgUsage -> TypeInfo -> TypeInfo 101 | mkR m f u i 102 | | not (usableModality m) = Erasable 103 | | ArgUnused <- u = Erasable 104 | | Forced <- f = Erasable 105 | | otherwise = i 106 | 107 | telListView :: Type -> TCM (ListTel, Type) 108 | telListView t = do 109 | TelV tel t <- telViewPath t 110 | return (telToList tel, t) 111 | 112 | typeWithoutParams :: QName -> TCM (ListTel, Type) 113 | typeWithoutParams q = do 114 | def <- getConstInfo q 115 | let d = case I.theDef def of 116 | Function{ funProjection = Just Projection{ projIndex = i } } -> i - 1 117 | Constructor{ conPars = n } -> n 118 | _ -> 0 119 | first (drop d) <$> telListView (defType def) 120 | 121 | getTypeInfo :: Type -> E TypeInfo 122 | getTypeInfo t0 = do 123 | (tel, t) <- lift $ telListView t0 124 | et <- case I.unEl t of 125 | I.Def d _ -> do 126 | -- #2916: Only update the memo table for d. Results for other types are 127 | -- under the assumption that d is erasable! 128 | oldMap <- use typeMap 129 | dInfo <- typeInfo d 130 | typeMap .= Map.insert d dInfo oldMap 131 | return dInfo 132 | Sort{} -> return Erasable 133 | _ -> return NotErasable 134 | is <- mapM (getTypeInfo . snd . dget) tel 135 | let e | Empty `elem` is = Erasable 136 | | null is = et -- TODO: guard should really be "all inhabited is" 137 | | et == Empty = Erasable 138 | | otherwise = et 139 | lift $ reportSDoc "treeless.opt.erase.type" 50 $ prettyTCM t0 <+> text ("is " ++ show e) 140 | return e 141 | where 142 | typeInfo :: QName -> E TypeInfo 143 | typeInfo q = ifM (erasureForbidden q) (return NotErasable) $ {-else-} do 144 | memoRec (typeMap . key q) Erasable $ do -- assume recursive occurrences are erasable 145 | mId <- lift $ getName' builtinId 146 | msizes <- lift $ mapM getBuiltinName 147 | [builtinSize, builtinSizeLt] 148 | def <- lift $ getConstInfo q 149 | let mcs = case I.theDef def of 150 | I.Datatype{ dataCons = cs } -> Just cs 151 | I.Record{ recConHead = c } -> Just [conName c] 152 | _ -> Nothing 153 | case mcs of 154 | _ | Just q == mId -> return NotErasable 155 | _ | Just q `elem` msizes -> return Erasable 156 | Just [c] -> do 157 | (ts, _) <- lift $ typeWithoutParams c 158 | let rs = map getModality ts 159 | is <- mapM (getTypeInfo . snd . dget) ts 160 | let er = and [ erasable i || not (usableModality r) | (i, r) <- zip is rs ] 161 | return $ if er then Erasable else NotErasable 162 | Just [] -> return Empty 163 | Just (_:_:_) -> return NotErasable 164 | Nothing -> 165 | case I.theDef def of 166 | I.Function{ funClauses = cs } -> 167 | sumTypeInfo <$> mapM (maybe (return Empty) (getTypeInfo . El __DUMMY_SORT__) . clauseBody) cs 168 | _ -> return NotErasable 169 | -- The backend also has a say whether a type is eraseable or not. 170 | erasureForbidden :: QName -> E Bool 171 | erasureForbidden q = lift $ not <$> activeBackendMayEraseType q 172 | -------------------------------------------------------------------------------- /src/Agda/Compiler/ToScheme.hs: -------------------------------------------------------------------------------- 1 | module Agda.Compiler.ToScheme where 2 | 3 | import Prelude hiding ( null , empty ) 4 | 5 | import Agda.Compiler.Common 6 | import Agda.Compiler.Erase ( runE , erasable , getFunInfo ) 7 | import Agda.Compiler.ToTreeless 8 | import Agda.Compiler.Treeless.EliminateLiteralPatterns 9 | import Agda.Compiler.Treeless.Erase 10 | import Agda.Compiler.Treeless.GuardsToPrims 11 | 12 | import Agda.Syntax.Abstract.Name 13 | import Agda.Syntax.Common 14 | import Agda.Syntax.Internal as I 15 | import Agda.Syntax.Literal 16 | import Agda.Syntax.Treeless 17 | 18 | import Agda.TypeChecking.Monad 19 | import Agda.TypeChecking.Pretty 20 | import Agda.TypeChecking.Primitive.Base 21 | 22 | import Agda.Utils.Impossible 23 | import Agda.Utils.Lens 24 | import Agda.Utils.List 25 | import Agda.Utils.Maybe 26 | import Agda.Utils.Monad 27 | import Agda.Utils.Null 28 | import qualified Agda.Utils.Pretty as P 29 | import Agda.Utils.Singleton 30 | 31 | import Control.Arrow ( first , second ) 32 | import Control.DeepSeq ( NFData ) 33 | 34 | import Control.Monad 35 | import Control.Monad.Except 36 | import Control.Monad.Reader 37 | import Control.Monad.State 38 | 39 | import Data.Char 40 | import Data.SCargot.Repr 41 | import Data.Map (Map) 42 | import qualified Data.Map as Map 43 | import Data.Set (Set) 44 | import qualified Data.Set as Set 45 | import Data.Text (Text) 46 | import qualified Data.Text as T 47 | 48 | import GHC.Generics ( Generic ) 49 | 50 | type SchAtom = Text 51 | type SchForm = RichSExpr SchAtom 52 | 53 | schDefine :: SchAtom -> [SchAtom] -> SchForm -> SchForm 54 | schDefine f xs body = RSList 55 | ["define", RSList (map RSAtom (f:xs)), body] 56 | 57 | schError :: Text -> SchForm 58 | schError msg = RSList 59 | [ "begin" 60 | , RSList ["display", RSAtom ("\"" <> msg <> "\\n\"")] 61 | , RSList ["exit", "1"] 62 | ] 63 | 64 | schAxiom :: SchAtom -> SchForm 65 | schAxiom f = schDefine f [] $ schError $ "encountered axiom: " <> f 66 | 67 | schLambda :: [SchAtom] -> SchForm -> SchForm 68 | schLambda args body = RSList 69 | [ RSAtom "lambda" 70 | , RSList $ map RSAtom args 71 | , body 72 | ] 73 | 74 | -- Bind each argument individually instead of all at once. 75 | schLambdas :: [SchAtom] -> SchForm -> SchForm 76 | schLambdas args body = foldr (schLambda . singleton) body args 77 | 78 | -- Apply to each argument individually instead of all at once. 79 | schApps :: SchForm -> [SchForm] -> SchForm 80 | schApps f args = foldl (\x y -> RSList [x,y]) f args 81 | 82 | schLet :: [(SchAtom,SchForm)] -> SchForm -> SchForm 83 | schLet binds body = RSList 84 | [ RSAtom "let" 85 | , RSList $ map (\(x,v) -> RSList [RSAtom x,v]) binds 86 | , body 87 | ] 88 | 89 | schConAtom :: SchAtom -> SchAtom 90 | schConAtom x = T.singleton '\'' <> x 91 | 92 | schCase :: SchForm -> [SchForm] -> Maybe SchForm -> SchForm 93 | schCase x cases maybeFallback = RSList $ 94 | [ RSAtom "record-case" 95 | , x 96 | ] ++ cases ++ 97 | [ RSList [ RSAtom "else" , fallback ] | fallback <- maybeToList maybeFallback 98 | ] 99 | 100 | schUnit :: SchForm 101 | schUnit = RSList [RSAtom "list"] 102 | 103 | schInt :: Int -> SchForm 104 | schInt i = RSAtom $ T.pack $ show i 105 | 106 | schDelay :: SchForm -> SchForm 107 | schDelay x 108 | | RSList [RSAtom "force", y] <- x = y 109 | | otherwise = RSList [RSAtom "delay", x] 110 | 111 | schForce :: SchForm -> SchForm 112 | schForce x 113 | | RSList [RSAtom "delay", y] <- x = y 114 | | otherwise = RSList [RSAtom "force", x] 115 | 116 | schLookupList :: SchForm -> SchForm -> SchForm 117 | schLookupList xs k = RSList [RSAtom "list-ref", xs, k] 118 | 119 | dropArgs :: [Bool] -> [a] -> [a] 120 | dropArgs bs xs = map snd $ filter (not . fst) $ zip bs xs 121 | 122 | -- Apply a function symbol of given arity and erasure info to a list of arguments, 123 | -- inserting lambdas or applications where needed to match the 124 | -- symbol's arity. 125 | schApp :: Int -> [Bool] -> SchForm -> [SchForm] -> ToSchemeM SchForm 126 | schApp n bs f args = do 127 | let m = n - length args 128 | if | m >= 0 -> withFreshVars m $ \vars -> do 129 | let args2 = map RSAtom vars 130 | return $ schLambdas vars $ RSList $ f : dropArgs bs (args ++ args2) 131 | | otherwise -> do 132 | let (args1,args2) = splitAt n args 133 | return $ schApps (RSList (f : dropArgs bs args1)) args2 134 | 135 | schConApp :: SchAtom -> Int -> Bool -> [Bool] -> [SchForm] -> ToSchemeM SchForm 136 | schConApp c n b bs args = do 137 | let tag = if b then id else (RSAtom (schConAtom c) :) 138 | m = n - length args 139 | unless (m >= 0) __IMPOSSIBLE__ 140 | force <- makeForce 141 | withFreshVars m $ \vars -> do 142 | let args2 = map (force . RSAtom) vars 143 | return $ schLambdas vars $ 144 | RSList $ RSAtom "list" : tag (dropArgs bs (args ++ args2)) 145 | 146 | schOp :: Int -> Text -> [SchForm] -> ToSchemeM SchForm 147 | schOp n op args = schApp n (replicate n False) (RSAtom op) args 148 | 149 | schPrimOp :: TPrim -> [SchForm] -> ToSchemeM SchForm 150 | schPrimOp p args = case p of 151 | PAdd -> schOp 2 "+" args 152 | PSub -> schOp 2 "-" args 153 | PMul -> schOp 2 "*" args 154 | PQuot -> schOp 2 "div" args 155 | PRem -> schOp 2 "mod" args 156 | PIf -> schOp 3 "if" args 157 | PEqI -> schOp 2 "=" args 158 | PGeq -> schOp 2 ">=" args 159 | PLt -> schOp 2 "<" args 160 | PSeq -> schOp 2 "seq" args 161 | _ -> fail $ "not yet supported: primitive " ++ show p 162 | 163 | schPreamble :: ToSchemeM [SchForm] 164 | schPreamble = do 165 | force <- makeForce 166 | strat <- getEvaluationStrategy 167 | return 168 | [ RSList 169 | [ RSAtom "import" 170 | , RSList [ RSAtom "only" , RSList [RSAtom "chezscheme"] , RSAtom "record-case" ] 171 | ] 172 | -- TODO: put this in a separate file and import it here 173 | , schDefine "monus" ["x","y"] $ 174 | RSList [RSAtom "max", RSAtom "0", RSList [RSAtom "-", force (RSAtom "x"), force (RSAtom "y")]] 175 | , schDefine "seq" ["x","y"] $ case strat of 176 | EagerEvaluation -> RSAtom "y" 177 | LazyEvaluation -> RSList [RSAtom "begin", force (RSAtom "x"), RSAtom "y"] 178 | ] 179 | 180 | deriving instance Generic EvaluationStrategy 181 | deriving instance NFData EvaluationStrategy 182 | 183 | data SchOptions = SchOptions 184 | { schEvaluation :: EvaluationStrategy 185 | } 186 | deriving (Generic, NFData) 187 | 188 | data ToSchemeEnv = ToSchemeEnv 189 | { toSchemeOptions :: SchOptions 190 | , toSchemeVars :: [SchForm] 191 | } 192 | 193 | initToSchemeEnv :: SchOptions -> ToSchemeEnv 194 | initToSchemeEnv opts = ToSchemeEnv opts [] 195 | 196 | addBinding :: SchForm -> ToSchemeEnv -> ToSchemeEnv 197 | addBinding x env = env { toSchemeVars = x : toSchemeVars env } 198 | 199 | data ToSchemeDef = ToSchemeDef SchAtom Int [Bool] -- Scheme name + arity + erased args 200 | 201 | data ToSchemeCon = ToSchemeCon SchAtom Int Bool [Bool] -- Scheme name + arity + erased tag + erased args 202 | 203 | data ToSchemeState = ToSchemeState 204 | { toSchemeFresh :: [SchAtom] -- Used for locally bound named variables 205 | , toSchemeDefs :: Map QName ToSchemeDef 206 | , toSchemeCons :: Map QName ToSchemeCon 207 | , toSchemeUsedNames :: Set SchAtom -- Names that are already in use (both variables and definitions) 208 | } 209 | 210 | -- This is an infinite supply of variable names 211 | -- a, b, c, ..., z, a1, b1, ..., z1, a2, b2, ... 212 | -- We never reuse variable names to make the code easier to 213 | -- understand. 214 | freshVars :: [SchAtom] 215 | freshVars = concat [ map (<> i) xs | i <- "":(map (T.pack . show) [1..]) ] 216 | where 217 | xs = map T.singleton $ ['a'..'z'] 218 | 219 | -- These are names that should not be used by the code we generate 220 | reservedNames :: Set SchAtom 221 | reservedNames = Set.fromList $ map T.pack 222 | [ "define" , "lambda", "let", "let*", "letrec", "letrec*" 223 | , "let-values", "let*-values", "case" 224 | , "record-case", "else" 225 | , "let-syntax", "letrec-syntax" 226 | , "define-syntax", "syntax-rules" 227 | , "#t" , "#f" , "if" , "=", "eqv?" 228 | , "+", "-", "*", "/" 229 | , "list", "car", "cdr" 230 | , "vector-ref", "string-ref" 231 | , "begin", "display", "put-bytes", "exit" 232 | , "library", "import", "export", "only" 233 | , "force", "delay" 234 | , "call-with-values", "call-with-current-continuation" 235 | , "add", "sub", "mul", "quot", "rem" 236 | , "iff", "eq", "monus", "seq" 237 | -- TODO: add more 238 | ] 239 | 240 | initToSchemeState :: ToSchemeState 241 | initToSchemeState = ToSchemeState 242 | { toSchemeFresh = freshVars 243 | , toSchemeDefs = Map.empty 244 | , toSchemeCons = Map.empty 245 | , toSchemeUsedNames = reservedNames 246 | } 247 | 248 | type ToSchemeM a = StateT ToSchemeState (ReaderT ToSchemeEnv TCM) a 249 | 250 | runToSchemeM :: SchOptions -> ToSchemeM a -> TCM a 251 | runToSchemeM opts = 252 | (`runReaderT` initToSchemeEnv opts) 253 | . (`evalStateT` initToSchemeState) 254 | 255 | freshSchAtom :: ToSchemeM SchAtom 256 | freshSchAtom = do 257 | names <- gets toSchemeFresh 258 | case names of 259 | [] -> fail "No more variables!" 260 | (x:names') -> do 261 | modify $ \st -> st { toSchemeFresh = names' } 262 | ifM (isNameUsed x) freshSchAtom $ {-otherwise-} do 263 | setNameUsed x 264 | return x 265 | 266 | getEvaluationStrategy :: ToSchemeM EvaluationStrategy 267 | getEvaluationStrategy = reader $ schEvaluation . toSchemeOptions 268 | 269 | makeDelay :: ToSchemeM (SchForm -> SchForm) 270 | makeDelay = delayIfLazy <$> getEvaluationStrategy 271 | 272 | makeForce :: ToSchemeM (SchForm -> SchForm) 273 | makeForce = forceIfLazy <$> getEvaluationStrategy 274 | 275 | delayIfLazy :: EvaluationStrategy -> SchForm -> SchForm 276 | delayIfLazy strat = case strat of 277 | EagerEvaluation -> id 278 | LazyEvaluation -> schDelay 279 | 280 | forceIfLazy :: EvaluationStrategy -> SchForm -> SchForm 281 | forceIfLazy strat = case strat of 282 | EagerEvaluation -> id 283 | LazyEvaluation -> schForce 284 | 285 | getVar :: Int -> ToSchemeM SchForm 286 | getVar i = reader $ (!! i) . toSchemeVars 287 | 288 | withFreshVar :: (SchAtom -> ToSchemeM a) -> ToSchemeM a 289 | withFreshVar f = do 290 | strat <- getEvaluationStrategy 291 | withFreshVar' strat f 292 | 293 | withFreshVar' :: EvaluationStrategy -> (SchAtom -> ToSchemeM a) -> ToSchemeM a 294 | withFreshVar' strat f = do 295 | x <- freshSchAtom 296 | local (addBinding $ forceIfLazy strat $ RSAtom x) $ f x 297 | 298 | withFreshVars :: Int -> ([SchAtom] -> ToSchemeM a) -> ToSchemeM a 299 | withFreshVars i f = do 300 | strat <- getEvaluationStrategy 301 | withFreshVars' strat i f 302 | 303 | withFreshVars' :: EvaluationStrategy -> Int -> ([SchAtom] -> ToSchemeM a) -> ToSchemeM a 304 | withFreshVars' strat i f 305 | | i <= 0 = f [] 306 | | otherwise = withFreshVar' strat $ \x -> withFreshVars' strat (i-1) (f . (x:)) 307 | 308 | lookupSchemeDef :: QName -> ToSchemeM ToSchemeDef 309 | lookupSchemeDef n = do 310 | r <- Map.lookup n <$> gets toSchemeDefs 311 | case r of 312 | Nothing -> fail $ "unbound name " <> show (P.pretty n) 313 | Just a -> return a 314 | 315 | lookupSchemeCon :: QName -> ToSchemeM ToSchemeCon 316 | lookupSchemeCon n = do 317 | r <- Map.lookup n <$> gets toSchemeCons 318 | case r of 319 | Nothing -> fail $ "unbound name " <> show (P.pretty n) 320 | Just a -> return a 321 | 322 | setSchemeDef :: QName -> ToSchemeDef -> ToSchemeM () 323 | setSchemeDef n def = do 324 | modify $ \s -> s { toSchemeDefs = Map.insert n def (toSchemeDefs s) } 325 | 326 | setSchemeCon :: QName -> ToSchemeCon -> ToSchemeM () 327 | setSchemeCon n con = do 328 | modify $ \s -> s { toSchemeCons = Map.insert n con (toSchemeCons s) } 329 | 330 | newSchemeDef :: QName -> Int -> [Bool] -> ToSchemeM SchAtom 331 | newSchemeDef n i bs = do 332 | a <- makeSchemeName n 333 | setSchemeDef n (ToSchemeDef a i bs) 334 | setNameUsed a 335 | return a 336 | 337 | newSchemeCon :: QName -> Int -> Bool -> [Bool] -> ToSchemeM SchAtom 338 | newSchemeCon n i b bs = do 339 | a <- makeSchemeName n 340 | setSchemeCon n (ToSchemeCon a i b bs) 341 | setNameUsed a 342 | return a 343 | 344 | isNameUsed :: SchAtom -> ToSchemeM Bool 345 | isNameUsed x = Set.member x <$> gets toSchemeUsedNames 346 | 347 | setNameUsed :: SchAtom -> ToSchemeM () 348 | setNameUsed x = modify $ \s -> 349 | s { toSchemeUsedNames = Set.insert x (toSchemeUsedNames s) } 350 | 351 | -- Extended alphabetic characters that are allowed to appear in 352 | -- a Scheme identifier 353 | schemeExtendedAlphaChars :: Set Char 354 | schemeExtendedAlphaChars = Set.fromList 355 | [ '!' , '$' , '%' , '&' , '*' , '+' , '-' , '.' , '/' , ':' , '<' , '=' , '>' 356 | , '?' , '@' , '^' , '_' , '~' 357 | ] 358 | 359 | -- Categories of unicode characters that are allowed to appear in 360 | -- a Scheme identifier 361 | schemeAllowedUnicodeCats :: Set GeneralCategory 362 | schemeAllowedUnicodeCats = Set.fromList 363 | [ UppercaseLetter , LowercaseLetter , TitlecaseLetter , ModifierLetter 364 | , OtherLetter , NonSpacingMark , SpacingCombiningMark , EnclosingMark 365 | , DecimalNumber , LetterNumber , OtherNumber , ConnectorPunctuation 366 | , DashPunctuation , OtherPunctuation , CurrencySymbol , MathSymbol 367 | , ModifierSymbol , OtherSymbol , PrivateUse 368 | ] 369 | 370 | -- True if the character is allowed to be used in a Scheme identifier 371 | isValidSchemeChar :: Char -> Bool 372 | isValidSchemeChar x 373 | | isAscii x = isAlphaNum x || x `Set.member` schemeExtendedAlphaChars 374 | | otherwise = generalCategory x `Set.member` schemeAllowedUnicodeCats 375 | 376 | -- Creates a valid Scheme name from a (qualified) Agda name. 377 | -- Precondition: the given name is not already in toSchemeDefs. 378 | makeSchemeName :: QName -> ToSchemeM SchAtom 379 | makeSchemeName n = go $ fixName $ P.prettyShow $ qnameName n 380 | where 381 | nextName = ('z':) -- TODO: do something smarter 382 | 383 | go s = ifM (isNameUsed $ T.pack s) (go $ nextName s) (return $ T.pack s) 384 | 385 | fixName s = 386 | let s' = concat (map fixChar s) in 387 | if | isNumber (head s') -> "z" ++ s' 388 | | otherwise -> s' 389 | 390 | fixChar c 391 | | isValidSchemeChar c = [c] 392 | | otherwise = "\\x" ++ toHex (ord c) ++ ";" 393 | 394 | toHex 0 = "" 395 | toHex i = toHex (i `div` 16) ++ [fourBitsToChar (i `mod` 16)] 396 | 397 | fourBitsToChar :: Int -> Char 398 | fourBitsToChar i = "0123456789ABCDEF" !! i 399 | {-# INLINE fourBitsToChar #-} 400 | 401 | class ToScheme a b | a -> b where 402 | toScheme :: a -> ToSchemeM b 403 | 404 | -- We first convert all definitions to treeless and calculate their 405 | -- arity and erasure info, before doing the actual translation to Scheme. 406 | defToTreeless :: Definition -> ToSchemeM (Maybe (Int, [Bool], SchAtom, TTerm)) 407 | defToTreeless def 408 | | defNoCompilation def || 409 | not (usableModality $ getModality def) = return Nothing 410 | | otherwise = do 411 | let f = defName def 412 | reportSDoc "toScheme" 5 $ "Compiling definition:" <> prettyTCM f 413 | case theDef def of 414 | Axiom{} -> do 415 | f' <- newSchemeDef f 0 [] 416 | return Nothing 417 | GeneralizableVar{} -> return Nothing 418 | d@Function{} | d ^. funInline -> return Nothing 419 | Function{} -> do 420 | strat <- getEvaluationStrategy 421 | maybeCompiled <- liftTCM $ toTreeless strat f 422 | case maybeCompiled of 423 | Just body -> do 424 | let (n, body') = lambdaView body 425 | er <- erasureInfo f 426 | case er of 427 | Nothing -> return Nothing 428 | Just bs -> do 429 | reportSDoc "toScheme" 15 $ "Erasure info: " <> text (show bs) 430 | unless (length bs >= n) __IMPOSSIBLE__ 431 | f' <- newSchemeDef f n (take n bs) 432 | return $ Just (n, bs, f', body') 433 | Nothing -> return Nothing 434 | Primitive{} -> do 435 | f' <- newSchemeDef f 0 [] 436 | return Nothing -- TODO! 437 | PrimitiveSort{} -> return Nothing 438 | Datatype{ dataCons = cs } -> do 439 | let eraseTag = length cs == 1 440 | forM_ cs $ \c -> do 441 | cdef <- theDef <$> getConstInfo c 442 | case cdef of 443 | Constructor{ conSrcCon = chead, conArity = nargs } -> 444 | processCon chead nargs eraseTag 445 | _ -> __IMPOSSIBLE__ 446 | return Nothing 447 | Record{ recConHead = chead, recFields = fs } -> do 448 | processCon chead (length fs) True 449 | return Nothing 450 | Constructor{} -> return Nothing 451 | AbstractDefn{} -> __IMPOSSIBLE__ 452 | DataOrRecSig{} -> __IMPOSSIBLE__ 453 | where 454 | processCon :: ConHead -> Int -> Bool -> ToSchemeM () 455 | processCon chead nargs b = do 456 | er <- erasureInfo (conName chead) 457 | whenJust er $ \bs -> do 458 | reportSDoc "toScheme" 15 $ "Erasure info: " <> text (show bs) 459 | void $ newSchemeCon (conName chead) nargs b bs 460 | 461 | 462 | lambdaView :: TTerm -> (Int, TTerm) 463 | lambdaView v = case v of 464 | TLam w -> first (1+) $ lambdaView w 465 | TCoerce w -> lambdaView w 466 | _ -> (0, v) 467 | 468 | -- `Just bs` means that the arguments for which the corresponding 469 | -- position in `bs` is True can be erased 470 | -- `Nothing` means that the entire function can be erased. 471 | erasureInfo :: QName -> ToSchemeM (Maybe [Bool]) 472 | erasureInfo f = liftTCM $ runE $ do 473 | (bs, b) <- getFunInfo f 474 | if erasable b 475 | then return Nothing 476 | else return (Just $ map erasable bs) 477 | 478 | instance ToScheme (Int, [Bool], SchAtom, TTerm) SchForm where 479 | toScheme (n, bs, f, body) = 480 | withFreshVars n $ \xs -> 481 | schDefine f (dropArgs bs xs) <$> toScheme body 482 | 483 | instance ToScheme TTerm SchForm where 484 | toScheme v = do 485 | v <- liftTCM $ eliminateLiteralPatterns (convertGuards v) 486 | toScheme $ tAppView v 487 | 488 | instance ToScheme (TTerm, [TTerm]) SchForm where 489 | toScheme (TCoerce w, args) = toScheme (w, args) 490 | toScheme (TApp w args1, args2) = toScheme (w, args1 ++ args2) 491 | toScheme (w, args) = do 492 | delay <- makeDelay 493 | args <- traverse toScheme args 494 | let lazyArgs = map delay args 495 | case w of 496 | TVar i -> do 497 | x <- getVar i 498 | return $ schApps x lazyArgs 499 | TPrim p -> schPrimOp p args 500 | TDef d -> do 501 | special <- isSpecialDefinition d 502 | case special of 503 | Nothing -> do 504 | ToSchemeDef d' i bs <- lookupSchemeDef d 505 | schApp i bs (RSAtom d') lazyArgs 506 | Just (i, v) -> schApp i (replicate i False) v lazyArgs 507 | TLam v -> withFreshVar $ \x -> do 508 | unless (null args) __IMPOSSIBLE__ 509 | body <- toScheme v 510 | return $ schLambda [x] body 511 | TLit l -> do 512 | unless (null args) __IMPOSSIBLE__ 513 | toScheme l 514 | TCon c -> do 515 | special <- isSpecialConstructor c 516 | case special of 517 | Nothing -> do 518 | ToSchemeCon c' i b bs <- lookupSchemeCon c 519 | schConApp c' i b bs args 520 | Just v -> do 521 | unless (null args) __IMPOSSIBLE__ 522 | return v 523 | TLet u v -> do 524 | unless (null args) __IMPOSSIBLE__ 525 | delay <- makeDelay 526 | expr <- delay <$> toScheme u 527 | withFreshVar $ \x -> do 528 | body <- toScheme v 529 | return $ schLet [(x,expr)] body 530 | TCase i info v bs -> do 531 | unless (null args) __IMPOSSIBLE__ 532 | x <- getVar i 533 | special <- isSpecialCase info 534 | case special of 535 | Nothing | [TACon c nargs v] <- bs -> do 536 | withFreshVars' EagerEvaluation nargs $ \xs -> do 537 | ToSchemeCon c' i b bs <- lookupSchemeCon c 538 | let mkProj i = schLookupList x (schInt $ if b then i else i+1) 539 | binds = zip (dropArgs bs xs) (map mkProj [0..]) 540 | body <- toScheme v 541 | return $ schLet binds body 542 | Nothing -> do 543 | cases <- traverse toScheme bs 544 | fallback <- if isUnreachable v 545 | then return Nothing 546 | else Just <$> toScheme v 547 | return $ schCase x cases fallback 548 | Just BoolCase -> case bs of 549 | [] -> __IMPOSSIBLE__ 550 | (TACon c1 _ v1 : bs') -> do 551 | Con trueC _ _ <- primTrue 552 | Con falseC _ _ <- primFalse 553 | v1' <- toScheme v1 554 | v2' <- case bs' of 555 | [] -> toScheme v 556 | (TACon _ _ v2 : _) -> toScheme v2 557 | _ -> __IMPOSSIBLE__ 558 | let (thenBranch,elseBranch) 559 | | c1 == conName trueC = (v1',v2') 560 | | c1 == conName falseC = (v2',v1') 561 | | otherwise = __IMPOSSIBLE__ 562 | return $ RSList [RSAtom "if", x, thenBranch, elseBranch] 563 | TUnit -> do 564 | unless (null args) __IMPOSSIBLE__ 565 | return schUnit 566 | TSort -> do 567 | unless (null args) __IMPOSSIBLE__ 568 | return schUnit 569 | TErased -> return schUnit 570 | TError err -> toScheme err 571 | 572 | where 573 | isUnreachable v = v == TError TUnreachable 574 | 575 | instance ToScheme Literal SchForm where 576 | toScheme lit = case lit of 577 | LitNat x -> return $ RSAtom (T.pack (show x)) 578 | LitWord64 x -> return $ schError "not yet supported: Word64 literals" 579 | LitFloat x -> return $ schError "not yet supported: Float literals" 580 | LitString x -> return $ schError "not yet supported: String literals" 581 | LitChar x -> return $ schError "not yet supported: Char literals" 582 | LitQName x -> return $ schError "not yet supported: QName literals" 583 | LitMeta p x -> return $ schError "not yet supported: Meta literals" 584 | 585 | instance ToScheme TAlt SchForm where 586 | toScheme alt = case alt of 587 | TACon c nargs v -> withFreshVars' EagerEvaluation nargs $ \xs -> do 588 | ToSchemeCon c' i b bs <- lookupSchemeCon c 589 | when b __IMPOSSIBLE__ 590 | body <- toScheme v 591 | return $ RSList [RSList [RSAtom c'], RSList (dropArgs bs (map RSAtom xs)), body] 592 | 593 | TAGuard{} -> __IMPOSSIBLE__ 594 | TALit{} -> __IMPOSSIBLE__ 595 | 596 | instance ToScheme TError SchForm where 597 | toScheme err = case err of 598 | TUnreachable -> return $ schError "Panic!" 599 | TMeta s -> return $ schError $ "encountered unsolved meta: " <> T.pack s 600 | 601 | isSpecialConstructor :: QName -> ToSchemeM (Maybe SchForm) 602 | isSpecialConstructor c = do 603 | let getConName (Just (Con c _ _)) = Just (conName c) 604 | getConName _ = Nothing 605 | mTrue <- getConName <$> getBuiltin' builtinTrue 606 | mFalse <- getConName <$> getBuiltin' builtinFalse 607 | if | Just c == mTrue -> return $ Just (RSAtom "#t") 608 | | Just c == mFalse -> return $ Just (RSAtom "#f") 609 | | otherwise -> return Nothing 610 | 611 | isSpecialDefinition :: QName -> ToSchemeM (Maybe (Int, SchForm)) 612 | isSpecialDefinition f = do 613 | minusDef <- getBuiltinName builtinNatMinus 614 | if | Just f == minusDef -> return $ Just (2 , RSAtom "monus") 615 | | otherwise -> return Nothing 616 | 617 | -- Some kinds of case statements are treated in a special way. 618 | -- Currently, matches on Bool are translated to an `if` statement. 619 | data SpecialCase = BoolCase 620 | 621 | isSpecialCase :: CaseInfo -> ToSchemeM (Maybe SpecialCase) 622 | isSpecialCase (CaseInfo lazy (CTData q cty)) = do 623 | mBool <- getBuiltin' builtinBool 624 | if mBool == Just (Def cty []) 625 | then return (Just BoolCase) 626 | else return Nothing 627 | specialCase _ = return Nothing 628 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding ( null , empty ) 4 | 5 | import Agda.Compiler.Backend 6 | import Agda.Compiler.Common 7 | 8 | import Agda.Main ( runAgda ) 9 | 10 | import Agda.Compiler.ToScheme 11 | 12 | import Agda.Interaction.Options ( OptDescr(..) , ArgDescr(..) ) 13 | 14 | import Agda.Syntax.Treeless ( EvaluationStrategy(..) ) 15 | 16 | import Agda.TypeChecking.Pretty 17 | 18 | import Agda.Utils.Either 19 | import Agda.Utils.Functor 20 | import Agda.Utils.Null 21 | import Agda.Utils.Pretty ( prettyShow ) 22 | 23 | import Control.DeepSeq ( NFData ) 24 | 25 | import Control.Monad.Reader 26 | import Control.Monad.State 27 | import Control.Monad.Writer 28 | 29 | import Data.Function 30 | import Data.Map (Map) 31 | import qualified Data.Map as Map 32 | import Data.Maybe 33 | import Data.SCargot 34 | import Data.SCargot.Repr 35 | import Data.Text (Text) 36 | import qualified Data.Text as T 37 | import qualified Data.Text.IO as T 38 | 39 | import GHC.Generics ( Generic ) 40 | 41 | main :: IO () 42 | main = runAgda [backend] 43 | 44 | backend :: Backend 45 | backend = Backend backend' 46 | 47 | backend' :: Backend' SchOptions SchOptions () () (IsMain, Definition) 48 | backend' = Backend' 49 | { backendName = "agda2scheme" 50 | , options = SchOptions EagerEvaluation 51 | , commandLineFlags = schFlags 52 | , isEnabled = \ _ -> True 53 | , preCompile = schPreCompile 54 | , postCompile = \ _ _ _ -> return () 55 | , preModule = \ _ _ _ _ -> return $ Recompile () 56 | , compileDef = \ _ _ isMain def -> return (isMain,def) 57 | , postModule = schPostModule 58 | , backendVersion = Nothing 59 | , scopeCheckingSuffices = False 60 | , mayEraseType = \ _ -> return True 61 | } 62 | 63 | schFlags :: [OptDescr (Flag SchOptions)] 64 | schFlags = 65 | [ Option [] ["lazy-evaluation"] (NoArg $ evaluationFlag LazyEvaluation) 66 | "Insert delay and force operations to enable lazy evaluation" 67 | , Option [] ["strict-evaluation"] (NoArg $ evaluationFlag EagerEvaluation) 68 | "Do not insert delay and force operations (default)" 69 | ] 70 | 71 | schPreCompile :: SchOptions -> TCM SchOptions 72 | schPreCompile opts = return opts 73 | 74 | schPostModule :: SchOptions -> () -> IsMain -> ModuleName -> [(IsMain, Definition)] -> TCM () 75 | schPostModule opts _ isMain modName defs = do 76 | let defToText = encodeOne printer . fromRich 77 | fileName = prettyShow (last $ mnameToList modName) ++ ".ss" 78 | 79 | modText <- runToSchemeM opts $ do 80 | ps <- schPreamble 81 | ts <- catMaybes <$> traverse defToTreeless (map snd defs) 82 | ds <- traverse toScheme ts 83 | return $ T.intercalate "\n\n" $ map defToText $ ps ++ ds 84 | 85 | liftIO $ T.writeFile fileName modText 86 | 87 | where 88 | printer :: SExprPrinter Text (SExpr Text) 89 | printer = basicPrint id 90 | 91 | evaluationFlag :: EvaluationStrategy -> Flag SchOptions 92 | evaluationFlag s o = return $ o { schEvaluation = s } 93 | -------------------------------------------------------------------------------- /test/Erasure.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Agda.Builtin.Bool 3 | open import Agda.Builtin.Nat 4 | 5 | not : Bool → Bool 6 | not true = false 7 | not false = true 8 | 9 | data D : Set where 10 | c : @0 Bool → Bool → D 11 | 12 | f : D → D 13 | f (c x y) = c (not x) (not y) 14 | 15 | data Vec (@0 A : Set) : @0 Nat → Set where 16 | [] : Vec A zero 17 | _∷_ : {@0 n : Nat} → A → Vec A n → Vec A (suc n) 18 | 19 | 20 | map : {@0 A B : Set} {@0 n : Nat} → (A → B) → Vec A n → Vec B n 21 | map f [] = [] 22 | map f (x ∷ xs) = f x ∷ map f xs 23 | 24 | test1 = map f (c true true ∷ (c false false ∷ [])) 25 | -------------------------------------------------------------------------------- /test/Erasure.ss: -------------------------------------------------------------------------------- 1 | (import (only (chezscheme) record-case)) 2 | 3 | (define (monus x y) (max 0 (- x y))) 4 | 5 | (define (seq x y) y) 6 | 7 | (define (not a) (if a #f 8 | #t)) 9 | 10 | (define (f b) (let ((e (list-ref b 0))) (list (not e)))) 11 | 12 | (define (map j k) (record-case k ((\x5B;\x5D;) () k) 13 | ((_∷_) (m n) (list '_∷_ (j m) 14 | (map j n))))) 15 | 16 | (define 17 | (test1) 18 | (map (lambda (o) (f o)) (list '_∷_ (list #t) 19 | (list '_∷_ (list #f) 20 | (list '\x5B;\x5D;))))) -------------------------------------------------------------------------------- /test/First.agda: -------------------------------------------------------------------------------- 1 | postulate A : Set 2 | 3 | id : A → A 4 | id x = x 5 | 6 | data Bool : Set where 7 | true false : Bool 8 | 9 | not : Bool → Bool 10 | not true = false 11 | not false = true 12 | 13 | ite : {A : Set} → Bool → A → A → A 14 | ite true x y = x 15 | ite false x y = y 16 | 17 | {-# NON_TERMINATING #-} 18 | loop : Bool 19 | loop = loop 20 | 21 | test1 = ite false loop true 22 | 23 | data Nat : Set where 24 | zero : Nat 25 | suc : Nat → Nat 26 | 27 | one = suc zero 28 | two = suc one 29 | three = suc two 30 | 31 | pred : Nat → Nat 32 | pred zero = zero 33 | pred (suc n) = n 34 | 35 | 36 | _+_ : Nat → Nat → Nat 37 | zero + n = n 38 | (suc m) + n = suc (m + n) 39 | 40 | twice : Nat → Nat 41 | twice zero = zero 42 | twice (suc n) = suc (suc (twice n)) 43 | 44 | pow2 : Nat → Nat 45 | pow2 zero = suc zero 46 | pow2 (suc n) = twice (pow2 n) 47 | 48 | consume : Nat → Nat 49 | consume zero = zero 50 | consume (suc n) = consume n 51 | 52 | test2 = consume (pow2 (twice (twice (twice three)))) 53 | 54 | 55 | data Vec (@0 A : Set) : @0 Nat → Set where 56 | nil : Vec A zero 57 | con : {@0 n : Nat} → A → Vec A n → Vec A (suc n) 58 | 59 | head : {@0 A : Set} {@0 n : Nat} → Vec A (suc n) → A 60 | head (con x xs) = x 61 | 62 | tail : {@0 A : Set} {@0 n : Nat} → Vec A (suc n) → Vec A n 63 | tail (con x xs) = xs 64 | 65 | map : {@0 A B : Set} {@0 n : Nat} → (A → B) → Vec A n → Vec B n 66 | map f nil = nil 67 | map f (con x xs) = con (f x) (map f xs) 68 | 69 | test3 = head (tail (map suc (con zero (con (suc zero) (con (suc (suc zero)) nil))))) 70 | 71 | -- Testing that names are properly sanitized 72 | 123'#|H\x65llo = zero 73 | 74 | test4 = 123'#|H\x65llo 75 | 76 | module M (n : Nat) where 77 | fie : Nat 78 | fie = suc n 79 | 80 | foe : Nat 81 | foe = suc fie 82 | 83 | open M (suc (suc zero)) 84 | 85 | fun : Nat 86 | fun = fie + foe 87 | -------------------------------------------------------------------------------- /test/First.ss: -------------------------------------------------------------------------------- 1 | (import (only (chezscheme) record-case)) 2 | 3 | (define (monus x y) (max 0 (- (force x) (force y)))) 4 | 5 | (define (seq x y) (begin (force x) y)) 6 | 7 | (define (id a) (force a)) 8 | 9 | (define (not b) (record-case (force b) ((true) () (list 'false)) 10 | ((false) () (list 'true)))) 11 | 12 | (define (ite d e 13 | f) (record-case (force d) ((true) () (force e)) 14 | ((false) () (force f)))) 15 | 16 | (define (loop) (loop)) 17 | 18 | (define (test1) (ite (delay (list 'false)) (delay (loop)) 19 | (delay (list 'true)))) 20 | 21 | (define (one) (list 'suc (list 'zero))) 22 | 23 | (define (two) (list 'suc (one))) 24 | 25 | (define (three) (list 'suc (two))) 26 | 27 | (define (pred g) (record-case (force g) ((zero) () (force g)) 28 | ((suc) (h) h))) 29 | 30 | (define (_+_ i j) (record-case (force i) ((zero) () (force j)) 31 | ((suc) (k) (list 'suc (_+_ (delay k) j))))) 32 | 33 | (define 34 | (twice l) 35 | (record-case (force l) ((zero) () (force l)) 36 | ((suc) (m) (list 'suc (list 'suc (twice (delay m))))))) 37 | 38 | (define 39 | (pow2 n) 40 | (record-case (force n) ((zero) () (list 'suc (force n))) 41 | ((suc) (o) (twice (delay (pow2 (delay o))))))) 42 | 43 | (define (consume p) (record-case (force p) ((zero) () (force p)) 44 | ((suc) (q) (consume (delay q))))) 45 | 46 | (define (test2) (consume (delay (pow2 (delay (twice (delay (twice (delay (twice (delay (three)))))))))))) 47 | 48 | (define (head t) (let ((v (list-ref (force t) 1)) (w (list-ref (force t) 2))) v)) 49 | 50 | (define (tail z) (let ((b1 (list-ref (force z) 1)) (c1 (list-ref (force z) 2))) c1)) 51 | 52 | (define 53 | (map g1 h1) 54 | (record-case 55 | (force h1) 56 | ((nil) () (force h1)) 57 | ((con) (j1 k1) (list 'con ((force g1) (delay j1)) 58 | (map g1 (delay k1)))))) 59 | 60 | (define 61 | (test3) 62 | (head 63 | (delay 64 | (tail 65 | (delay 66 | (map 67 | (delay (lambda (l1) (list 'suc (force l1)))) 68 | (delay 69 | (list 70 | 'con 71 | (list 'zero) 72 | (list 73 | 'con 74 | (list 'suc (list 'zero)) 75 | (list 'con (list 'suc (list 'suc (list 'zero))) 76 | (list 'nil))))))))))) 77 | 78 | (define (z123\x27;\x23;\x7C;H\x5C;x65llo) (list 'zero)) 79 | 80 | (define (test4) (z123\x27;\x23;\x7C;H\x5C;x65llo)) 81 | 82 | (define (fie m1) (list 'suc (force m1))) 83 | 84 | (define (foe n1) (list 'suc (fie n1))) 85 | 86 | (define 87 | (fun) 88 | (_+_ 89 | (delay (fie (delay (list 'suc (list 'suc (list 'zero)))))) 90 | (delay (foe (delay (list 'suc (list 'suc (list 'zero)))))))) -------------------------------------------------------------------------------- /test/Nats.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Agda.Builtin.Nat using (Nat; zero; suc; _+_; _-_; _*_) 3 | 4 | plus3 : Nat → Nat 5 | plus3 n = suc (suc (suc n)) 6 | 7 | pred : Nat → Nat 8 | pred zero = zero 9 | pred (suc n) = n 10 | 11 | test1 = pred (suc (pred (plus3 40))) 12 | 13 | twice : Nat → Nat 14 | twice n = 2 * n 15 | 16 | pow2 : Nat → Nat 17 | pow2 zero = 1 18 | pow2 (suc n) = twice (pow2 n) 19 | 20 | consume : Nat → Nat 21 | consume zero = zero 22 | consume (suc n) = consume n 23 | 24 | test2 = consume (pow2 24) 25 | -------------------------------------------------------------------------------- /test/Nats.ss: -------------------------------------------------------------------------------- 1 | (import (only (chezscheme) record-case)) 2 | 3 | (define (plus3) (lambda (a) (+ 3 (force a)))) 4 | 5 | (define (pred) (lambda (a) (if (= 0 (force a)) 0 6 | (- (force a) 1)))) 7 | 8 | (define (test1) ((pred) (delay (+ 1 ((pred) (delay ((plus3) (delay 40)))))))) 9 | 10 | (define (twice) (lambda (a) (* 2 (force a)))) 11 | 12 | (define (pow2) (lambda (a) (if (= 0 (force a)) 1 13 | (let ((b (delay (- (force a) 1)))) ((twice) (delay ((pow2) b))))))) 14 | 15 | (define (consume) (lambda (a) (if (= 0 (force a)) 0 16 | (let ((b (delay (- (force a) 1)))) ((consume) b))))) 17 | 18 | (define (test2) ((consume) (delay ((pow2) (delay 24))))) -------------------------------------------------------------------------------- /test/Triples.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Agda.Builtin.Bool 3 | open import Agda.Builtin.Nat 4 | 5 | variable A B : Set 6 | 7 | data List (A : Set) : Set where 8 | [] : List A 9 | _::_ : A → List A → List A 10 | 11 | infixr 5 _::_ 12 | 13 | if_then_else_ : Bool → A → A → A 14 | if true then x else y = x 15 | if false then x else y = y 16 | 17 | id : A → A 18 | id x = x 19 | 20 | filter : (A → Bool) → List A → List A 21 | filter p [] = [] 22 | filter p (x :: xs) = (if p x then (x ::_) else id) (filter p xs) 23 | 24 | _++_ : List A → List A → List A 25 | [] ++ ys = ys 26 | (x :: xs) ++ ys = x :: (xs ++ ys) 27 | 28 | _>>=_ : List A → (A → List B) → List B 29 | [] >>= f = [] 30 | (x :: xs) >>= f = f x ++ (xs >>= f) 31 | 32 | range : Nat → Nat → List Nat 33 | range x y = go (suc y - x) x 34 | where 35 | go : Nat → Nat → List Nat 36 | go zero _ = [] 37 | go (suc m) n = n :: go m (suc n) 38 | 39 | record Triple : Set where 40 | constructor triple 41 | field fst snd trd : Nat 42 | 43 | alltriples : Nat → List Triple 44 | alltriples top = range 1 top >>= λ z → range 1 z >>= λ y → range 1 y >>= λ x → (triple x y z) :: [] 45 | 46 | pythagorean : Triple → Bool 47 | pythagorean (triple x y z) = x * x + y * y == z * z 48 | 49 | triples : Nat → List Triple 50 | triples top = filter pythagorean (alltriples top) 51 | 52 | sumall : List Triple → Nat 53 | sumall [] = 0 54 | sumall (triple x y z :: xs) = x + y + z + sumall xs 55 | 56 | test1 = sumall (triples 200) -- evaluates to 33638 57 | -------------------------------------------------------------------------------- /test/Triples.ss: -------------------------------------------------------------------------------- 1 | (import (only (chezscheme) record-case)) 2 | 3 | (define (monus x y) (max 0 (- (force x) (force y)))) 4 | 5 | (define (seq x y) (begin (force x) y)) 6 | 7 | (define (if_then_else_ b c 8 | d) (if (force b) (force c) 9 | (force d))) 10 | 11 | (define (id f) (force f)) 12 | 13 | (define 14 | (filter h i) 15 | (record-case 16 | (force i) 17 | ((\x5B;\x5D;) () (force i)) 18 | ((_::_) 19 | (j k) 20 | ((if_then_else_ 21 | (delay ((force h) (delay j))) 22 | (delay (lambda (l) (list '_::_ j 23 | (force l)))) 24 | (delay (lambda (m) (force m)))) 25 | (delay (filter h (delay k))))))) 26 | 27 | (define 28 | (_++_ o p) 29 | (record-case (force o) ((\x5B;\x5D;) () (force p)) 30 | ((_::_) (q r) (list '_::_ q 31 | (_++_ (delay r) p))))) 32 | 33 | (define 34 | (_>>=_ u v) 35 | (record-case 36 | (force u) 37 | ((\x5B;\x5D;) () (force u)) 38 | ((_::_) (w x) (_++_ (delay ((force v) (delay w))) (delay (_>>=_ (delay x) v)))))) 39 | 40 | (define (range y z) (go (delay (monus (delay (+ 1 (force z))) y)) y)) 41 | 42 | (define 43 | (go c1 d1) 44 | (if 45 | (= 0 (force c1)) 46 | (list '\x5B;\x5D;) 47 | (let ((e1 (delay (- (force c1) 1)))) (list '_::_ (force d1) 48 | (go e1 (delay (+ 1 (force d1)))))))) 49 | 50 | (define 51 | (fst f1) 52 | (let ((g1 (list-ref (force f1) 0)) (h1 (list-ref (force f1) 1)) (i1 (list-ref (force f1) 2))) g1)) 53 | 54 | (define 55 | (snd j1) 56 | (let ((k1 (list-ref (force j1) 0)) (l1 (list-ref (force j1) 1)) (m1 (list-ref (force j1) 2))) l1)) 57 | 58 | (define 59 | (trd n1) 60 | (let ((o1 (list-ref (force n1) 0)) (p1 (list-ref (force n1) 1)) (q1 (list-ref (force n1) 2))) q1)) 61 | 62 | (define 63 | (alltriples r1) 64 | (_>>=_ 65 | (delay (range (delay 1) r1)) 66 | (delay 67 | (lambda 68 | (s1) 69 | (_>>=_ 70 | (delay (range (delay 1) s1)) 71 | (delay 72 | (lambda 73 | (t1) 74 | (_>>=_ 75 | (delay (range (delay 1) t1)) 76 | (delay 77 | (lambda 78 | (u1) 79 | (list '_::_ (list (force u1) (force t1) 80 | (force s1)) 81 | (list '\x5B;\x5D;)))))))))))) 82 | 83 | (define 84 | (pythagorean v1) 85 | (let 86 | ((w1 (list-ref (force v1) 0)) (x1 (list-ref (force v1) 1)) (y1 (list-ref (force v1) 2))) 87 | (= (+ (* w1 w1) (* x1 x1)) (* y1 y1)))) 88 | 89 | (define (triples z1) (filter (delay (lambda (a2) (pythagorean a2))) (delay (alltriples z1)))) 90 | 91 | (define 92 | (sumall b2) 93 | (record-case 94 | (force b2) 95 | ((\x5B;\x5D;) () 0) 96 | ((_::_) 97 | (c2 d2) 98 | (let 99 | ((e2 (list-ref c2 0)) (f2 (list-ref c2 1)) (g2 (list-ref c2 2))) 100 | (+ (+ (+ (sumall (delay d2)) e2) f2) g2))))) 101 | 102 | (define (test1) (sumall (delay (triples (delay 200))))) -------------------------------------------------------------------------------- /test/TriplesFO.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Agda.Builtin.Bool 3 | open import Agda.Builtin.Nat 4 | 5 | variable A B : Set 6 | 7 | data List (A : Set) : Set where 8 | [] : List A 9 | _::_ : A → List A → List A 10 | 11 | infixr 5 _::_ 12 | 13 | if_then_else_ : Bool → A → A → A 14 | if true then x else y = x 15 | if false then x else y = y 16 | 17 | id : A → A 18 | id x = x 19 | 20 | _++_ : List A → List A → List A 21 | [] ++ ys = ys 22 | (x :: xs) ++ ys = x :: (xs ++ ys) 23 | 24 | range : Nat → Nat → List Nat 25 | range x y = go (suc y - x) x 26 | where 27 | go : Nat → Nat → List Nat 28 | go zero _ = [] 29 | go (suc m) n = n :: go m (suc n) 30 | 31 | record Triple : Set where 32 | constructor triple 33 | field fst snd trd : Nat 34 | 35 | bind1 : Nat → Nat → List Nat → List Triple 36 | bind1 y z [] = [] 37 | bind1 y z (x :: xs) = triple x y z :: bind1 y z xs 38 | 39 | bind2 : Nat → List Nat → List Triple 40 | bind2 z [] = [] 41 | bind2 z (y :: ys) = bind1 y z (range 1 y) ++ bind2 z ys 42 | 43 | bind3 : List Nat → List Triple 44 | bind3 [] = [] 45 | bind3 (z :: zs) = bind2 z (range 1 z) ++ bind3 zs 46 | 47 | alltriples : Nat → List Triple 48 | alltriples top = bind3 (range 1 top) 49 | 50 | pythagorean : Triple → Bool 51 | pythagorean (triple x y z) = x * x + y * y == z * z 52 | 53 | 54 | filterP : List Triple → List Triple 55 | filterP [] = [] 56 | filterP (x :: xs) = (if pythagorean x then (x ::_) else id) (filterP xs) 57 | 58 | 59 | triples : Nat → List Triple 60 | triples top = filterP (alltriples top) 61 | 62 | sumall : List Triple → Nat 63 | sumall [] = 0 64 | sumall (triple x y z :: xs) = x + y + z + sumall xs 65 | 66 | test1 = sumall (triples 200) -- evaluates to 33638 67 | -------------------------------------------------------------------------------- /test/formalize-all-the-things.agda: -------------------------------------------------------------------------------- 1 | -- This is a cut-down version of the code at https://jesper.sikanda.be/posts/formalize-all-the-things.html 2 | 3 | open import Agda.Primitive 4 | open import Agda.Builtin.Bool 5 | open import Agda.Builtin.Nat 6 | open import Agda.Builtin.Equality 7 | 8 | infixr 5 _∷_ 9 | data List {a} (A : Set a) : Set a where 10 | [] : List A 11 | _∷_ : (x : A) (xs : List A) → List A 12 | 13 | {-# BUILTIN LIST List #-} 14 | 15 | variable 16 | A B C : Set 17 | x y z : A 18 | k l m n : Nat 19 | 20 | it : {{x : A}} → A 21 | it {{x}} = x 22 | 23 | data Maybe (A : Set) : Set where 24 | just : A → Maybe A 25 | nothing : Maybe A 26 | 27 | mapMaybe : (A → B) → (Maybe A → Maybe B) 28 | mapMaybe f (just x) = just (f x) 29 | mapMaybe f nothing = nothing 30 | 31 | testMapMaybe = mapMaybe suc (just 5) 32 | 33 | record _×_ (A B : Set) : Set where 34 | constructor _,_ 35 | field 36 | fst : A 37 | snd : B 38 | open _×_ 39 | 40 | data _⊎_ (A B : Set) : Set where 41 | inl : A → A ⊎ B 42 | inr : B → A ⊎ B 43 | 44 | mapInl : (A → B) → A ⊎ C → B ⊎ C 45 | mapInl f (inl x) = inl (f x) 46 | mapInl f (inr y) = inr y 47 | 48 | mapInr : (B → C) → A ⊎ B → A ⊎ C 49 | mapInr f (inl x) = inl x 50 | mapInr f (inr y) = inr (f y) 51 | 52 | record ⊤ : Set where 53 | constructor tt -- no fields 54 | 55 | data ⊥ : Set where -- no constructor 56 | 57 | ¬_ : Set → Set 58 | ¬ A = A → ⊥ 59 | 60 | sym : x ≡ y → y ≡ x 61 | sym refl = refl 62 | 63 | trans : x ≡ y → y ≡ z → x ≡ z 64 | trans refl refl = refl 65 | 66 | cong : (f : A → B) → x ≡ y → f x ≡ f y 67 | cong f refl = refl 68 | 69 | subst : (P : A → Set) → x ≡ y → P x → P y 70 | subst P refl p = p 71 | 72 | module Nat-≤ where 73 | 74 | data _≤_ : Nat → Nat → Set where 75 | ≤-zero : zero ≤ n 76 | ≤-suc : m ≤ n → suc m ≤ suc n 77 | 78 | ≤-refl : n ≤ n 79 | ≤-refl {n = zero} = ≤-zero 80 | ≤-refl {n = suc k} = ≤-suc ≤-refl 81 | 82 | ≤-trans : k ≤ l → l ≤ m → k ≤ m 83 | ≤-trans ≤-zero l≤m = ≤-zero 84 | ≤-trans (≤-suc k≤l) (≤-suc l≤m) = 85 | ≤-suc (≤-trans k≤l l≤m) 86 | 87 | ≤-antisym : m ≤ n → n ≤ m → m ≡ n 88 | ≤-antisym ≤-zero ≤-zero = refl 89 | ≤-antisym (≤-suc m≤n) (≤-suc n≤m) = 90 | cong suc (≤-antisym m≤n n≤m) 91 | 92 | So : Bool → Set 93 | So false = ⊥ 94 | So true = ⊤ 95 | 96 | instance 97 | ≤-dec : {p : So (m < suc n)} → m ≤ n 98 | ≤-dec {m = zero} {n = n} = ≤-zero 99 | ≤-dec {m = suc m} {n = suc n} {p = p} = 100 | ≤-suc (≤-dec {p = p}) 101 | 102 | record Ord (A : Set) : Set₁ where 103 | field 104 | _≤_ : A → A → Set 105 | ≤-refl : x ≤ x 106 | ≤-trans : x ≤ y → y ≤ z → x ≤ z 107 | ≤-antisym : x ≤ y → y ≤ x → x ≡ y 108 | 109 | _≥_ : A → A → Set 110 | x ≥ y = y ≤ x 111 | 112 | open Ord {{...}} 113 | 114 | instance 115 | Ord-Nat : Ord Nat 116 | _≤_ {{Ord-Nat}} = Nat-≤._≤_ 117 | ≤-refl {{Ord-Nat}} = Nat-≤.≤-refl 118 | ≤-trans {{Ord-Nat}} = Nat-≤.≤-trans 119 | ≤-antisym {{Ord-Nat}} = Nat-≤.≤-antisym 120 | 121 | instance 122 | Ord-⊤ : Ord ⊤ 123 | _≤_ {{Ord-⊤}} = λ _ _ → ⊤ 124 | ≤-refl {{Ord-⊤}} = tt 125 | ≤-trans {{Ord-⊤}} = λ _ _ → tt 126 | ≤-antisym {{Ord-⊤}} = λ _ _ → refl 127 | 128 | data Tri {{_ : Ord A}} : A → A → Set where 129 | less : {{x≤y : x ≤ y}} → Tri x y 130 | equal : {{x≡y : x ≡ y}} → Tri x y 131 | greater : {{x≥y : x ≥ y}} → Tri x y 132 | 133 | record TDO (A : Set) : Set₁ where 134 | field 135 | {{Ord-A}} : Ord A -- superclass Ord 136 | tri : (x y : A) → Tri x y 137 | 138 | open TDO {{...}} public 139 | 140 | triNat : (x y : Nat) → Tri x y 141 | triNat zero zero = equal 142 | triNat zero (suc y) = less 143 | triNat (suc x) zero = greater 144 | triNat (suc x) (suc y) with triNat x y 145 | ... | less {{x≤y}} = less {{x≤y = Nat-≤.≤-suc x≤y}} 146 | ... | equal {{x≡y}} = equal {{x≡y = cong suc x≡y}} 147 | ... | greater {{x≥y}} = greater {{x≥y = Nat-≤.≤-suc x≥y}} 148 | 149 | testTriNat = triNat 3 5 150 | 151 | instance 152 | TDO-Nat : TDO Nat 153 | Ord-A {{TDO-Nat}} = Ord-Nat 154 | tri {{TDO-Nat}} = triNat 155 | 156 | data [_]∞ (A : Set) : Set where 157 | -∞ : [ A ]∞ 158 | [_] : A → [ A ]∞ 159 | +∞ : [ A ]∞ 160 | 161 | variable 162 | lower upper : [ A ]∞ 163 | 164 | module Ord-[]∞ {A : Set} {{ A-≤ : Ord A}} where 165 | 166 | data _≤∞_ : [ A ]∞ → [ A ]∞ → Set where 167 | -∞-≤ : -∞ ≤∞ y 168 | []-≤ : x ≤ y → [ x ] ≤∞ [ y ] 169 | +∞-≤ : x ≤∞ +∞ 170 | 171 | []∞-refl : x ≤∞ x 172 | []∞-refl { -∞} = -∞-≤ 173 | []∞-refl {[ x ]} = []-≤ ≤-refl 174 | []∞-refl { +∞} = +∞-≤ 175 | 176 | []∞-trans : x ≤∞ y → y ≤∞ z → x ≤∞ z 177 | []∞-trans -∞-≤ _ = -∞-≤ 178 | []∞-trans ([]-≤ x≤y) ([]-≤ y≤z) = []-≤ (≤-trans x≤y y≤z) 179 | []∞-trans _ +∞-≤ = +∞-≤ 180 | 181 | []∞-antisym : x ≤∞ y → y ≤∞ x → x ≡ y 182 | []∞-antisym -∞-≤ -∞-≤ = refl 183 | []∞-antisym ([]-≤ x≤y) ([]-≤ y≤x) = cong [_] (≤-antisym x≤y y≤x) 184 | []∞-antisym +∞-≤ +∞-≤ = refl 185 | 186 | instance 187 | Ord-[]∞ : {{_ : Ord A}} → Ord [ A ]∞ 188 | _≤_ {{Ord-[]∞}} = _≤∞_ 189 | ≤-refl {{Ord-[]∞}} = []∞-refl 190 | ≤-trans {{Ord-[]∞}} = []∞-trans 191 | ≤-antisym {{Ord-[]∞}} = []∞-antisym 192 | 193 | open Ord-[]∞ public 194 | 195 | module _ {{_ : Ord A}} where 196 | 197 | instance 198 | -∞-≤-I : {y : [ A ]∞} → -∞ ≤ y 199 | -∞-≤-I = -∞-≤ 200 | 201 | +∞-≤-I : {x : [ A ]∞} → x ≤ +∞ 202 | +∞-≤-I = +∞-≤ 203 | 204 | []-≤-I : {x y : A} {{x≤y : x ≤ y}} → [ x ] ≤ [ y ] 205 | []-≤-I {{x≤y = x≤y}} = []-≤ x≤y 206 | 207 | data BST (A : Set) {{_ : Ord A}} 208 | (lower upper : [ A ]∞) : Set where 209 | 210 | leaf : {{l≤u : lower ≤ upper}} 211 | → BST A lower upper 212 | 213 | node : (x : A) 214 | → BST A lower [ x ] 215 | → BST A [ x ] upper 216 | → BST A lower upper 217 | 218 | testBST : BST Nat -∞ +∞ 219 | testBST = node 3 leaf leaf 220 | 221 | module Lookup {{_ : TDO A}} where 222 | 223 | data _∈_ {lower} {upper} (x : A) : 224 | (t : BST A lower upper) → Set where 225 | here : ∀ {t₁ t₂} → x ≡ y → x ∈ node y t₁ t₂ 226 | left : ∀ {t₁ t₂} → x ∈ t₁ → x ∈ node y t₁ t₂ 227 | right : ∀ {t₁ t₂} → x ∈ t₂ → x ∈ node y t₁ t₂ 228 | 229 | lookup : ∀ {lower} {upper} 230 | → (x : A) (t : BST A lower upper) → Maybe (x ∈ t) 231 | lookup x leaf = nothing 232 | lookup x (node y t₁ t₂) with tri x y 233 | ... | less = mapMaybe left (lookup x t₁) 234 | ... | equal = just (here it) 235 | ... | greater = mapMaybe right (lookup x t₂) 236 | 237 | module Insert {{_ : TDO A}} where 238 | 239 | insert : (x : A) (t : BST A lower upper) 240 | → {{l≤x : lower ≤ [ x ]}} {{x≤u : [ x ] ≤ upper}} 241 | → BST A lower upper 242 | insert x leaf = node x leaf leaf 243 | insert x (node y t₁ t₂) with tri x y 244 | ... | less = node y (insert x t₁) t₂ 245 | ... | equal = node y t₁ t₂ 246 | ... | greater = node y t₁ (insert x t₂) 247 | 248 | open Lookup 249 | open Insert 250 | 251 | testLookup = lookup 3 testBST 252 | 253 | testInsert : BST Nat -∞ +∞ 254 | testInsert = insert 4 testBST 255 | 256 | fromList : {{_ : TDO A}} → List A → BST A -∞ +∞ 257 | fromList [] = leaf {{ l≤u = -∞-≤-I }} 258 | fromList (x ∷ xs) = insert x (fromList xs) 259 | 260 | testFromList = fromList (1 ∷ 2 ∷ 3 ∷ []) 261 | 262 | _++_ : List A → List A → List A 263 | [] ++ ys = ys 264 | (x ∷ xs) ++ ys = x ∷ (xs ++ ys) 265 | 266 | flatten : {{_ : Ord A}} {lower upper : [ A ]∞} → BST A lower upper → List A 267 | flatten leaf = [] 268 | flatten (node x l r) = flatten l ++ (x ∷ flatten r) 269 | 270 | testFlatten = flatten testInsert 271 | 272 | sort : {{TDO A}} → List A → List A 273 | sort xs = flatten (fromList xs) 274 | 275 | test1 = sort (5 ∷ 3 ∷ 9 ∷ 1 ∷ 2 ∷ 10 ∷ 7 ∷ 4 ∷ 8 ∷ 6 ∷ []) 276 | -------------------------------------------------------------------------------- /test/formalize-all-the-things.ss: -------------------------------------------------------------------------------- 1 | (import (only (chezscheme) record-case)) 2 | 3 | (define (monus x y) (max 0 (- x y))) 4 | 5 | (define (seq x y) y) 6 | 7 | (define (it b) b) 8 | 9 | (define (mapMaybe e f) (record-case f ((just) (g) (list 'just (e g))) 10 | ((nothing) () f))) 11 | 12 | (define (testMapMaybe) (mapMaybe (lambda (h) (+ 1 h)) (list 'just 5))) 13 | 14 | (define (fst i) (let ((j (list-ref i 0)) (k (list-ref i 1))) j)) 15 | 16 | (define (snd l) (let ((m (list-ref l 0)) (n (list-ref l 1))) n)) 17 | 18 | (define (mapInl r s) (record-case s ((inl) (t) (list 'inl (r t))) 19 | ((inr) (u) s))) 20 | 21 | (define (mapInr y z) (record-case z ((inl) (a1) z) 22 | ((inr) (b1) (list 'inr (y b1))))) 23 | 24 | (define (subst h1) h1) 25 | 26 | (define (≤-refl i1) (if (= 0 i1) (list '≤-zero) 27 | (let ((j1 (- i1 1))) (list '≤-suc (≤-refl j1))))) 28 | 29 | (define 30 | (≤-trans n1 o1) 31 | (record-case 32 | n1 33 | ((≤-zero) () (list '≤-zero)) 34 | ((≤-suc) (s1) (let ((v1 (list-ref o1 1))) (list '≤-suc (≤-trans s1 v1)))))) 35 | 36 | (define (≤-dec w1) (if (= 0 w1) (list '≤-zero) 37 | (let ((z1 (- w1 1))) (list '≤-suc (≤-dec z1))))) 38 | 39 | (define (z≤-refl a2) (let ((c2 (list-ref a2 0)) (d2 (list-ref a2 1))) c2)) 40 | 41 | (define (z≤-trans f2) (let ((h2 (list-ref f2 0)) (i2 (list-ref f2 1))) i2)) 42 | 43 | (define 44 | (Ord-Nat) 45 | (list 46 | (lambda (k2) (≤-refl k2)) 47 | (lambda (l2) (lambda (m2) (lambda (n2) (lambda (o2) (lambda (p2) (≤-trans o2 p2)))))))) 48 | 49 | (define 50 | (Ord-⊤) 51 | (list (lambda (q2) (list)) (lambda (r2) (lambda (s2) (lambda (t2) (lambda (u2) (lambda (v2) (list)))))))) 52 | 53 | (define (Ord-A w2) (let ((x2 (list-ref w2 0)) (y2 (list-ref w2 1))) x2)) 54 | 55 | (define (tri z2) (let ((a3 (list-ref z2 0)) (b3 (list-ref z2 1))) b3)) 56 | 57 | (define 58 | (triNat c3 d3) 59 | (if 60 | (= 0 c3) 61 | (if (= 0 d3) (list 'equal) 62 | (list 'less (≤-dec 0))) 63 | (let 64 | ((e3 (- c3 1))) 65 | (if 66 | (= 0 d3) 67 | (list 'greater (≤-dec 0)) 68 | (let 69 | ((f3 (- d3 1))) 70 | (let 71 | ((g3 (triNat e3 f3))) 72 | (record-case 73 | g3 74 | ((less) (j3) (list 'less (list '≤-suc j3))) 75 | ((equal) () (list 'equal)) 76 | ((greater) (p3) (list 'greater (list '≤-suc p3)))))))))) 77 | 78 | (define (testTriNat) (triNat 3 5)) 79 | 80 | (define (TDO-Nat) (list (Ord-Nat) (lambda (q3) (lambda (r3) (triNat q3 r3))))) 81 | 82 | (define 83 | (\x5B;\x5D;∞-refl t3 u3) 84 | (record-case 85 | u3 86 | ((-∞) () (list '-∞-≤)) 87 | ((\x5B;_\x5D;) (v3) (list '\x5B;\x5D;-≤ ((z≤-refl t3) v3))) 88 | ((+∞) () (list '+∞-≤)))) 89 | 90 | (define 91 | (\x5B;\x5D;∞-trans x3 y3 92 | z3 93 | a4 94 | b4 95 | c4) 96 | (let 97 | ((d4 (seq c4 (list '+∞-≤)))) 98 | (record-case 99 | b4 100 | ((-∞-≤) () (list '-∞-≤)) 101 | ((\x5B;\x5D;-≤) 102 | (h4) 103 | (let 104 | ((i4 (list-ref y3 1))) 105 | (let 106 | ((j4 (list-ref z3 1))) 107 | (record-case 108 | c4 109 | ((\x5B;\x5D;-≤) 110 | (m4) 111 | (let 112 | ((n4 (list-ref a4 1))) 113 | (list '\x5B;\x5D;-≤ ((((((z≤-trans x3) i4) j4) n4) h4) m4)))) 114 | ((+∞-≤) () (list '+∞-≤)))))) 115 | (else d4)))) 116 | 117 | (define 118 | (Ord-\x5B;\x5D;∞ q4) 119 | (list 120 | (lambda (s4) (\x5B;\x5D;∞-refl q4 s4)) 121 | (lambda 122 | (t4) 123 | (lambda 124 | (u4) 125 | (lambda (v4) (lambda (w4) (lambda (x4) (\x5B;\x5D;∞-trans q4 t4 126 | u4 127 | v4 128 | w4 129 | x4)))))))) 130 | 131 | (define (-∞-≤-I) (list '-∞-≤)) 132 | 133 | (define (+∞-≤-I) (list '+∞-≤)) 134 | 135 | (define (\x5B;\x5D;-≤-I f5) (list '\x5B;\x5D;-≤ f5)) 136 | 137 | (define (testBST) (list 'node 3 138 | (list 'leaf (list '-∞-≤)) 139 | (list 'leaf (list '+∞-≤)))) 140 | 141 | (define 142 | (lookup h5 k5 143 | l5) 144 | (record-case 145 | l5 146 | ((leaf) (m5) (list 'nothing)) 147 | ((node) 148 | (n5 o5 p5) 149 | (let 150 | ((q5 (((tri h5) k5) n5))) 151 | (record-case 152 | q5 153 | ((less) (t5) (mapMaybe (lambda (u5) (list 'left u5)) (lookup h5 k5 154 | o5))) 155 | ((equal) () (list 'just (list 'here))) 156 | ((greater) (a6) (mapMaybe (lambda (b6) (list 'right b6)) (lookup h5 k5 157 | p5)))))))) 158 | 159 | (define 160 | (insert d6 g6 161 | h6 162 | i6 163 | j6) 164 | (record-case 165 | h6 166 | ((leaf) (k6) (list 'node g6 167 | (list 'leaf i6) 168 | (list 'leaf j6))) 169 | ((node) 170 | (l6 m6 n6) 171 | (let 172 | ((o6 (((tri d6) g6) l6))) 173 | (record-case 174 | o6 175 | ((less) (r6) (list 'node l6 176 | (insert d6 g6 177 | m6 178 | i6 179 | (list '\x5B;\x5D;-≤ r6)) 180 | n6)) 181 | ((equal) () h6) 182 | ((greater) (x6) (list 'node l6 183 | m6 184 | (insert d6 g6 185 | n6 186 | (list '\x5B;\x5D;-≤ x6) 187 | j6)))))))) 188 | 189 | (define (testLookup) (lookup (TDO-Nat) 3 190 | (testBST))) 191 | 192 | (define (testInsert) (insert (TDO-Nat) 4 193 | (testBST) 194 | (list '-∞-≤) 195 | (list '+∞-≤))) 196 | 197 | (define 198 | (fromList z6 a7) 199 | (record-case 200 | a7 201 | ((\x5B;\x5D;) () (list 'leaf (list '-∞-≤))) 202 | ((_∷_) (b7 c7) (insert z6 b7 203 | (fromList z6 c7) 204 | (list '-∞-≤) 205 | (list '+∞-≤))))) 206 | 207 | (define 208 | (testFromList) 209 | (fromList (TDO-Nat) (list '_∷_ 1 210 | (list '_∷_ 2 211 | (list '_∷_ 3 212 | (list '\x5B;\x5D;)))))) 213 | 214 | (define 215 | (_++_ e7 f7) 216 | (record-case e7 ((\x5B;\x5D;) () f7) 217 | ((_∷_) (g7 h7) (list '_∷_ g7 218 | (_++_ h7 f7))))) 219 | 220 | (define 221 | (flatten m7) 222 | (record-case 223 | m7 224 | ((leaf) (n7) (list '\x5B;\x5D;)) 225 | ((node) (o7 p7 q7) (_++_ (flatten p7) (list '_∷_ o7 226 | (flatten q7)))))) 227 | 228 | (define (testFlatten) (flatten (testInsert))) 229 | 230 | (define (sort s7 t7) (flatten (fromList s7 t7))) 231 | 232 | (define 233 | (test1) 234 | (sort 235 | (TDO-Nat) 236 | (list 237 | '_∷_ 238 | 5 239 | (list 240 | '_∷_ 241 | 3 242 | (list 243 | '_∷_ 244 | 9 245 | (list 246 | '_∷_ 247 | 1 248 | (list 249 | '_∷_ 250 | 2 251 | (list 252 | '_∷_ 253 | 10 254 | (list '_∷_ 7 255 | (list '_∷_ 4 256 | (list '_∷_ 8 257 | (list '_∷_ 6 258 | (list '\x5B;\x5D;))))))))))))) --------------------------------------------------------------------------------