├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── app └── Main.hs ├── cabal.project ├── kind-lang.cabal ├── main.kindc └── src ├── Kind.hs └── Kind ├── CLI.hs ├── Check.hs ├── CompileJS.hs ├── Env.hs ├── Equal.hs ├── Parse.hs ├── Reduce.hs ├── Show.hs ├── Type.hs └── Util.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-* 2 | *.o 3 | *.hi 4 | *.chi 5 | *.chs.h 6 | *.dyn_o 7 | *.dyn_hi 8 | .cabal-sandbox/ 9 | cabal.sandbox.config 10 | *.prof 11 | *.aux 12 | *.hp 13 | *.eventlog 14 | .stack-work/ 15 | cabal.project.local* 16 | .ghc.environment.* 17 | .vscode/ 18 | .idea/ 19 | .DS_Store 20 | .holefill 21 | .tmp 22 | .backup/ 23 | *.koder 24 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for kind2hs 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024 Victor Taelin 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Kind 2 | 3 | Kind is a minimal Proof Checker. 4 | 5 | This repository is a full rewrite of Kind from the old JS implementation to 6 | Haskell. It is being actively developed. See examples on 7 | [KindBook](https://github.com/HigherOrderCO/KindBook). 8 | 9 | # Usage 10 | 11 | 1. Clone and install this project 12 | 13 | 2. Use the `kind` command to check/run terms 14 | 15 | --- 16 | 17 | We will write a proper README later (: 18 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Kind (main) 4 | 5 | main :: IO () 6 | main = Kind.main 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | -- Enable -O2 optimization for all packages 4 | package * 5 | optimization: 2 6 | -------------------------------------------------------------------------------- /kind-lang.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: kind-lang 3 | version: 0.1.0.0 4 | license: MIT 5 | license-file: LICENSE 6 | author: Victor Taelin 7 | maintainer: victor.taelin@gmail.com 8 | category: Language 9 | build-type: Simple 10 | extra-doc-files: CHANGELOG.md 11 | 12 | common warnings 13 | ghc-options: -w 14 | 15 | library 16 | import: warnings 17 | exposed-modules: Kind 18 | , Kind.CLI 19 | , Kind.Check 20 | , Kind.CompileJS 21 | , Kind.Env 22 | , Kind.Equal 23 | , Kind.Parse 24 | , Kind.Reduce 25 | , Kind.Show 26 | , Kind.Type 27 | , Kind.Util 28 | other-modules: 29 | build-depends: base ^>=4.20.0.0 30 | , containers ==0.7 31 | , parsec ==3.1.17.0 32 | , ansi-terminal==1.1.1 33 | , directory==1.3.8.3 34 | , hs-highlight == 1.0.3 35 | , filepath==1.5.2.0 36 | , mtl==2.3.1 37 | hs-source-dirs: src 38 | default-language: GHC2024 39 | 40 | executable kind 41 | import: warnings 42 | main-is: Main.hs 43 | build-depends: base ^>=4.20.0.0 44 | , kind-lang 45 | , ansi-terminal==1.1.1 46 | , directory==1.3.8.3 47 | , hs-highlight == 1.0.3 48 | , filepath==1.5.2.0 49 | , mtl==2.3.1 50 | hs-source-dirs: app 51 | default-language: GHC2024 52 | -------------------------------------------------------------------------------- /main.kindc: -------------------------------------------------------------------------------- 1 | 2 | 3 | Bool : * = #[]{ 4 | #true{} : Bool 5 | #false{} : Bool 6 | }; 7 | 8 | Nat : * = #[]{ 9 | #zero{} : Nat 10 | #succ{ pred: Nat } : Nat 11 | }; 12 | 13 | 14 | IsTrue : ∀(b: Bool) * = λb #[b]{ 15 | #indeed{} : (IsTrue #true{}) 16 | }; 17 | 18 | Equal : ∀(T: *) ∀(a: T) ∀(b: T) * = λT λa λb #[a b]{ 19 | #refl{} : (Equal T a a) 20 | }; 21 | 22 | rewrite 23 | : ∀(T: *) 24 | ∀(a: T) 25 | ∀(b: T) 26 | ∀(e: (Equal T a b)) 27 | ∀(P: ∀(x: A) *) 28 | ∀(x: (P a)) 29 | (P b) 30 | = λT λa λb λ{ 31 | #refl: λP λx x 32 | }; 33 | 34 | MAIN = rewrite; 35 | 36 | //MAIN 37 | //: (((Equal Bool) #true{}) #true{}) 38 | //= #refl{}; 39 | 40 | //Equal.rewrite(e: Equal) Type>(x: P(a)): P(b) 41 | //case e { 42 | //refl: x 43 | //} : P(e.b) 44 | 45 | -------------------------------------------------------------------------------- /src/Kind.hs: -------------------------------------------------------------------------------- 1 | module Kind ( 2 | module Kind.CLI, 3 | module Kind.Check, 4 | module Kind.Env, 5 | module Kind.Equal, 6 | module Kind.Parse, 7 | module Kind.Reduce, 8 | module Kind.Show, 9 | module Kind.Type, 10 | module Kind.Util, 11 | ) where 12 | 13 | import Kind.CLI 14 | import Kind.Check 15 | import Kind.CompileJS 16 | import Kind.Env 17 | import Kind.Equal 18 | import Kind.Parse 19 | import Kind.Reduce 20 | import Kind.Show 21 | import Kind.Type 22 | import Kind.Util 23 | -------------------------------------------------------------------------------- /src/Kind/CLI.hs: -------------------------------------------------------------------------------- 1 | -- Type.hs: 2 | -- //./Type.hs// 3 | 4 | module Kind.CLI where 5 | 6 | import Control.Exception (try) 7 | import Control.Monad (forM, forM_, foldM) 8 | import Data.List (stripPrefix, isSuffixOf, nub) 9 | import Highlight (highlightError) 10 | import Kind.Check 11 | import Kind.CompileJS 12 | import Kind.Env 13 | import Kind.Parse 14 | import Kind.Reduce 15 | import Kind.Show 16 | import Kind.Type 17 | import Kind.Util 18 | import System.Console.ANSI 19 | import System.Directory (canonicalizePath, getCurrentDirectory, doesDirectoryExist, doesFileExist, getDirectoryContents) 20 | import System.Environment (getArgs) 21 | import System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure)) 22 | import System.FilePath (takeDirectory, (), takeFileName, dropExtension, isExtensionOf) 23 | import System.IO (readFile) 24 | import qualified Data.IntMap.Strict as IM 25 | import qualified Data.Map.Strict as M 26 | import qualified Data.Set as S 27 | 28 | import Debug.Trace 29 | 30 | type FileCtx = (Book, M.Map FilePath [String], M.Map FilePath [String]) 31 | type Command = String -> FileCtx -> String -> String -> IO (Either String ()) 32 | 33 | -- main :: IO () 34 | -- main = ctest 35 | 36 | main :: IO () 37 | main = do 38 | args <- getArgs 39 | currPath <- getCurrentDirectory 40 | bookPath <- findBookDir currPath 41 | case bookPath of 42 | Nothing -> do 43 | putStrLn "Error: No 'book' directory found in the path." 44 | exitWith (ExitFailure 1) 45 | Just bookPath -> do 46 | result <- case args of 47 | -- ["check"] -> runWithAll bookPath cliCheckAll 48 | ["run", arg] -> runWithOne bookPath arg cliNormal 49 | ["check"] -> runWithAll bookPath cliCheck 50 | ["check", arg] -> runWithOne bookPath arg cliCheck 51 | ["to-js", arg] -> runWithOne bookPath arg cliToJS 52 | ["show", arg] -> runWithOne bookPath arg cliShow 53 | ["deps", arg] -> runWithOne bookPath arg cliDeps 54 | ["rdeps", arg] -> runWithOne bookPath arg cliRDeps 55 | _ -> printHelp 56 | case result of 57 | Left err -> do 58 | putStrLn err 59 | exitWith (ExitFailure 1) 60 | Right _ -> do 61 | exitWith ExitSuccess 62 | 63 | printHelp :: IO (Either String ()) 64 | printHelp = do 65 | putStrLn "Kind usage:" 66 | putStrLn " kind check # Checks all .kind files in the current directory and subdirectories" 67 | putStrLn " kind check # Type-checks all definitions in the specified file" 68 | putStrLn " kind run # Normalizes the specified definition" 69 | putStrLn " kind show # Stringifies the specified definition" 70 | putStrLn " kind to-js # Compiles the specified definition to JavaScript" 71 | putStrLn " kind deps # Shows immediate dependencies of the specified definition" 72 | putStrLn " kind rdeps # Shows all dependencies of the specified definition recursively" 73 | putStrLn " kind help # Shows this help message" 74 | return $ Right () 75 | 76 | -- CLI Commands 77 | -- ------------ 78 | 79 | -- Normalizes the target definition 80 | cliNormal :: Command 81 | cliNormal bookPath (book, _, _) defName defPath = 82 | case M.lookup "main" book of 83 | Just term -> do 84 | result <- showInfo book IM.empty (Print term 0) 85 | putStrLn result 86 | return $ Right () 87 | Nothing -> do 88 | return $ Left $ "Error: Definition '" ++ defName ++ "' not found." 89 | 90 | -- Checks all definitions in the target file 91 | cliCheck :: Command 92 | cliCheck bookPath (book, defs, _) defName defPath = do 93 | case M.lookup defPath defs of 94 | Just fileDefNames -> do 95 | results <- forM fileDefNames $ \fileDefName -> do 96 | case M.lookup fileDefName book of 97 | Just term -> do 98 | case envRun (doCheck term) book of 99 | Done state _ -> do 100 | cliPrintLogs state 101 | cliPrintWarn term state 102 | putStrLn $ "\x1b[32m✓ " ++ fileDefName ++ "\x1b[0m" 103 | return $ Right () 104 | Fail state -> do 105 | cliPrintLogs state 106 | cliPrintWarn term state 107 | putStrLn $ "\x1b[31m✗ " ++ fileDefName ++ "\x1b[0m" 108 | return $ Left $ "Error." 109 | Nothing -> return $ Left $ "Definition not found: " ++ fileDefName 110 | putStrLn "" 111 | return $ sequence_ results 112 | Nothing -> do 113 | return $ Left $ "No definitions found in file: " ++ defPath 114 | 115 | -- Compiles the whole book to JS 116 | cliToJS :: Command 117 | cliToJS bookPath (book, _, _) _ _ = do 118 | putStrLn $ compileJS book 119 | return $ Right () 120 | 121 | -- Shows a definition 122 | cliShow :: Command 123 | cliShow bookPath (book, _, _) defName _ = 124 | case M.lookup defName book of 125 | Just term -> do 126 | putStrLn $ showTerm term 127 | return $ Right () 128 | Nothing -> do 129 | return $ Left $ "Error: Definition '" ++ defName ++ "' not found." 130 | 131 | -- Shows immediate dependencies of a definition 132 | cliDeps :: Command 133 | cliDeps bookPath (book, _, _) defName _ = 134 | case M.lookup defName book of 135 | Just term -> do 136 | forM_ (filter (/= defName) $ nub $ getDeps term) $ \dep -> putStrLn dep 137 | return $ Right () 138 | Nothing -> do 139 | return $ Left $ "Error: Definition '" ++ defName ++ "' not found." 140 | 141 | -- Shows all dependencies of a definition recursively 142 | cliRDeps :: Command 143 | cliRDeps bookPath (book, _, _) defName _ = do 144 | let deps = S.toList $ S.delete defName $ getAllDeps book defName 145 | forM_ deps $ \dep -> putStrLn dep 146 | return $ Right () 147 | 148 | -- CLI Runners 149 | -- ----------- 150 | 151 | -- Runs a command on a single file 152 | runWithOne :: FilePath -> String -> Command -> IO (Either String ()) 153 | runWithOne bookPath arg action = do 154 | let defName = getDefName bookPath arg 155 | let defPath = getDefPath bookPath defName 156 | cliCtx <- loadName bookPath M.empty defName 157 | action bookPath cliCtx defName defPath 158 | 159 | -- Runs a command on all files 160 | runWithAll :: FilePath -> Command -> IO (Either String ()) 161 | runWithAll bookPath action = do 162 | files <- findKindFiles bookPath 163 | results <- forM files $ \file -> do 164 | putStrLn $ "\x1b[1m\x1b[4m[" ++ file ++ "]\x1b[0m" 165 | runWithOne bookPath file action 166 | return $ sequence_ results 167 | 168 | -- Loader 169 | -- ------ 170 | 171 | -- Loads a name and all its dependencies recursively 172 | loadName :: FilePath -> Book -> String -> IO FileCtx 173 | loadName bookPath book name = do 174 | if M.member name book 175 | then do 176 | return (book, M.empty, M.empty) 177 | else do 178 | let dirPath = bookPath name 179 | isDir <- doesDirectoryExist dirPath 180 | if isDir 181 | then loadFile bookPath book (dirPath takeFileName name ++ ".kind") 182 | else loadFile bookPath book (bookPath name ++ ".kind") 183 | 184 | -- Loads a file and all its dependencies recursivelly 185 | loadFile :: FilePath -> Book -> FilePath -> IO FileCtx 186 | loadFile bookPath book filePath = do 187 | fileExists <- doesFileExist filePath 188 | if not fileExists 189 | then do 190 | return (book, M.empty, M.empty) 191 | else do 192 | code <- readFile filePath 193 | book0 <- doParseBook filePath code 194 | let book1 = M.union book book0 195 | let defs = M.keys book0 196 | let deps = concatMap (getDeps . snd) (M.toList book0) 197 | let defs' = M.singleton filePath defs 198 | let deps' = M.singleton filePath deps 199 | foldM (\ (depBook, depDefs, depDeps) dep -> do 200 | (depBook', depDefs', depDeps') <- loadName bookPath depBook dep 201 | return ( depBook' , M.union depDefs depDefs' , M.union depDeps depDeps') 202 | ) (book1, defs', deps') deps 203 | 204 | -- Utils 205 | -- ----- 206 | 207 | -- Finds the directory named "monobook" 208 | findBookDir :: FilePath -> IO (Maybe FilePath) 209 | findBookDir dir = do 210 | let kindBookDir = dir "kindbook" 211 | foundKindBook <- doesDirectoryExist kindBookDir 212 | if foundKindBook 213 | then return $ Just kindBookDir 214 | else if takeDirectory dir == dir 215 | then return Nothing 216 | else findBookDir (takeDirectory dir) 217 | 218 | -- Finds all Kind files in this directory tree 219 | findKindFiles :: FilePath -> IO [FilePath] 220 | findKindFiles dir = do 221 | contents <- getDirectoryContents dir 222 | let properNames = filter (`notElem` [".", ".."]) contents 223 | paths <- forM properNames $ \name -> do 224 | let path = dir name 225 | isDirectory <- doesDirectoryExist path 226 | if isDirectory 227 | then findKindFiles path 228 | else return [path | ".kind" `isSuffixOf` path] 229 | return (concat paths) 230 | 231 | -- Loads a file into a string 232 | readSource :: FilePath -> IO String 233 | readSource file = do 234 | result <- try (readFile file) :: IO (Either IOError String) 235 | case result of 236 | Right x -> return x 237 | Left er -> return $ "Could not read source file: " ++ file 238 | 239 | -- Extracts the definition name from a file path or name 240 | getDefName :: FilePath -> String -> String 241 | getDefName bookPath = dropBookPath . dropExtension where 242 | dropExtension path 243 | | isExtensionOf "kind" path = System.FilePath.dropExtension path 244 | | otherwise = path 245 | dropBookPath path = maybe path id (stripPrefix (bookPath++"/") path) 246 | 247 | -- Gets the full path for a definition 248 | getDefPath :: FilePath -> String -> FilePath 249 | getDefPath bookPath name = bookPath name ++ ".kind" 250 | 251 | -- Stringification 252 | -- --------------- 253 | 254 | showInfo :: Book -> Fill -> Info -> IO String 255 | showInfo book fill info = case info of 256 | Found nam typ ctx dep -> 257 | let nam' = concat ["?", nam] 258 | typ' = showTermGo True (normal book fill 0 typ dep) dep 259 | ctx' = showContext book fill ctx dep 260 | in return $ concat ["\x1b[1mGOAL\x1b[0m ", nam', " : ", typ', "\n", ctx'] 261 | Error src exp det bad dep -> do 262 | let exp' = concat ["- expected : \x1b[32m", showTermGo True (normal book fill 0 exp dep) dep, "\x1b[0m"] 263 | det' = concat ["- detected : \x1b[31m", showTermGo True (normal book fill 0 det dep) dep, "\x1b[0m"] 264 | bad' = concat ["- origin : \x1b[2m", showTermGo True (normal book fill 0 bad dep) dep, "\x1b[0m"] 265 | (file, text) <- case src of 266 | Just (Cod (Loc fileName iniLine iniCol) (Loc _ endLine endCol)) -> do 267 | canonPath <- canonicalizePath fileName 268 | content <- readSource canonPath 269 | let highlighted = highlightError (iniLine, iniCol) (endLine, endCol) content 270 | return (canonPath, unlines $ take 8 $ lines highlighted) 271 | Nothing -> return ("unknown_file", "Could not read source file.\n") 272 | let src' = concat ["\x1b[4m", file, "\x1b[0m\n", text] 273 | return $ concat ["\x1b[1mERROR:\x1b[0m\n", exp', "\n", det', "\n", bad', "\n", src'] 274 | Solve nam val dep -> 275 | return $ concat ["SOLVE: _", show nam, " = ", showTermGo True val dep] 276 | Vague nam -> 277 | return $ concat ["VAGUE: _", nam] 278 | Print val dep -> 279 | return $ showTermGo True (normal book fill 2 val dep) dep 280 | 281 | showContext :: Book -> Fill -> [Term] -> Int -> String 282 | showContext book fill ctx dep = unlines $ map (\term -> "- " ++ showContextAnn book fill term dep) ctx 283 | 284 | showContextAnn :: Book -> Fill -> Term -> Int -> String 285 | showContextAnn book fill (Ann chk val typ) dep = concat [showTermGo True (normal book fill 0 val dep) dep, " : ", showTermGo True (normal book fill 0 typ dep) dep] 286 | showContextAnn book fill (Src _ val) dep = showContextAnn book fill val dep 287 | showContextAnn book fill term dep = showTermGo True (normal book fill 0 term dep) dep 288 | 289 | -- Prints logs from the type-checker 290 | cliPrintLogs :: State -> IO () 291 | cliPrintLogs (State book fill susp logs) = do 292 | forM_ logs $ \log -> do 293 | result <- showInfo book fill log 294 | putStr result 295 | 296 | -- Prints a warning if there are unsolved metas 297 | cliPrintWarn :: Term -> State -> IO () 298 | cliPrintWarn term (State _ fill _ _) = do 299 | let metaCount = countMetas term 300 | let fillCount = IM.size fill 301 | if (metaCount > fillCount) then do 302 | putStrLn $ "WARNING: " ++ show (metaCount - fillCount) ++ " unsolved metas." 303 | else 304 | return () 305 | -------------------------------------------------------------------------------- /src/Kind/Check.hs: -------------------------------------------------------------------------------- 1 | -- //./Type.hs// 2 | 3 | module Kind.Check where 4 | 5 | import Kind.Env 6 | import Kind.Equal 7 | import Kind.Reduce 8 | import Kind.Show 9 | import Kind.Type 10 | import Kind.Util 11 | 12 | import qualified Data.IntMap.Strict as IM 13 | import qualified Data.Map.Strict as M 14 | 15 | import Control.Monad (forM, forM_, unless, when) 16 | import Debug.Trace 17 | 18 | -- Type-Checking 19 | -- ------------- 20 | 21 | -- Modes: 22 | -- - sus=True : suspended checks on / better unification / wont return annotated term 23 | -- - sus=False : suspended checks off / worse unification / will return annotated term 24 | 25 | infer :: Bool -> Maybe Cod -> Term -> Int -> Env Term 26 | infer sus src term dep = debug ("infer:" ++ (if sus then "* " else " ") ++ showTermGo False term dep) $ go term where 27 | 28 | go (All nam inp bod) = do 29 | inpA <- checkLater sus src inp Set dep 30 | bodA <- checkLater sus src (bod (Ann False (Var nam dep) inp)) Set (dep + 1) 31 | return $ Ann False (All nam inpA (\x -> bodA)) Set 32 | 33 | go (App fun arg) = do 34 | funA <- infer sus src fun dep 35 | book <- envGetBook 36 | fill <- envGetFill 37 | case reduce book fill 2 (getType funA) of 38 | (All inpNam inpTyp inpBod) -> do 39 | argA <- checkLater sus src arg inpTyp dep 40 | return $ Ann False (App funA argA) (inpBod arg) 41 | otherwise -> do 42 | envLog (Error src (Ref "function") (getType funA) (App fun arg) dep) 43 | envFail 44 | 45 | go (Ann True val typ) = do 46 | check sus src val typ dep 47 | 48 | go (Ann False val typ) = do 49 | return $ Ann False val typ 50 | 51 | go (Slf nam typ bod) = do 52 | typA <- checkLater sus src typ Set dep 53 | bodA <- checkLater sus src (bod (Ann False (Var nam dep) typ)) Set (dep + 1) 54 | return $ Ann False (Slf nam typA (\x -> bodA)) Set 55 | 56 | go (Ins val) = do 57 | valA <- infer sus src val dep 58 | book <- envGetBook 59 | fill <- envGetFill 60 | case reduce book fill 2 (getType valA) of 61 | (Slf slfNam slfTyp slfBod) -> do 62 | return $ Ann False (Ins valA) (slfBod (Ins valA)) 63 | otherwise -> do 64 | envLog (Error src (Ref "Self") (getType valA) (Ins val) dep) 65 | envFail 66 | 67 | go (Ref nam) = do 68 | book <- envGetBook 69 | case M.lookup nam book of 70 | Just val -> do 71 | valA <- infer sus src val dep 72 | return $ Ann False (Ref nam) (getType valA) 73 | Nothing -> do 74 | envLog (Error src (Ref "expression") (Ref "undefined") (Ref nam) dep) 75 | envFail 76 | 77 | go Set = do 78 | return $ Ann False Set Set 79 | 80 | go U64 = do 81 | return $ Ann False U64 Set 82 | 83 | go F64 = do 84 | return $ Ann False F64 Set 85 | 86 | go (Num num) = do 87 | return $ Ann False (Num num) U64 88 | 89 | go (Flt num) = do 90 | return $ Ann False (Flt num) F64 91 | 92 | 93 | go (Op2 opr fst snd) = do 94 | fstT <- infer sus src fst dep 95 | sndT <- infer sus src snd dep 96 | 97 | let validTypes = [F64, U64] 98 | isValidType <- checkValidType (getType fstT) validTypes dep 99 | 100 | if not isValidType then do 101 | envLog (Error src (Ref "Valid numeric type") (getType fstT) (Op2 opr fst snd) dep) 102 | envFail 103 | else do 104 | typesEqual <- equal (getType fstT) (getType sndT) dep 105 | if not typesEqual then do 106 | envLog (Error src (getType fstT) (getType sndT) (Op2 opr fst snd) dep) 107 | envFail 108 | else do 109 | book <- envGetBook 110 | fill <- envGetFill 111 | let reducedFst = reduce book fill 1 (getType fstT) 112 | let returnType = getOpReturnType opr reducedFst 113 | return $ Ann False (Op2 opr fstT sndT) returnType 114 | 115 | go (Swi zer suc) = do 116 | envLog (Error src (Ref "annotation") (Ref "switch") (Swi zer suc) dep) 117 | envFail 118 | 119 | go (Map typ) = do 120 | typA <- checkLater sus src typ Set dep 121 | return $ Ann False (Map typA) Set 122 | 123 | go (KVs kvs dft) = do 124 | dftA <- infer sus src dft dep 125 | kvsA <- forM (IM.toList kvs) $ \(key, val ) -> do 126 | valA <- check sus src val (getType dftA) dep 127 | return (key, valA) 128 | return $ Ann False (KVs (IM.fromList kvsA) dftA) (Map (getType dftA)) 129 | 130 | go (Get got nam map key bod) = do 131 | mapA <- infer sus src map dep 132 | book <- envGetBook 133 | fill <- envGetFill 134 | case reduce book fill 2 (getType mapA) of 135 | (Map typ) -> do 136 | let got_ann = Ann False (Var got dep) typ 137 | let nam_ann = Ann False (Var nam dep) (Map typ) 138 | keyA <- check sus src key U64 dep 139 | bodA <- infer sus src (bod got_ann nam_ann) dep 140 | return $ Ann False (Get got nam mapA keyA (\g m -> bodA)) (getType bodA) 141 | otherwise -> do 142 | envLog (Error src (Ref "Map") (getType mapA) (Get got nam map key bod) dep) 143 | envFail 144 | 145 | go (Put got nam map key val bod) = do 146 | mapA <- infer sus src map dep 147 | book <- envGetBook 148 | fill <- envGetFill 149 | case reduce book fill 2 (getType mapA) of 150 | (Map typ) -> do 151 | valA <- check sus src val typ dep 152 | let got_ann = Ann False (Var got dep) typ 153 | let nam_ann = Ann False (Var nam dep) (Map typ) 154 | keyA <- check sus src key U64 dep 155 | bodA <- infer sus src (bod got_ann nam_ann) dep 156 | return $ Ann False (Put got nam mapA keyA valA (\g m -> bodA)) (getType bodA) 157 | otherwise -> do 158 | envLog (Error src (Ref "Map") (getType mapA) (Put got nam map key val bod) dep) 159 | envFail 160 | 161 | go (Let nam val bod) = do 162 | valA <- infer sus src val dep 163 | bodA <- infer sus src (bod (Ann False (Var nam dep) (getType valA))) dep 164 | return $ Ann False (Let nam valA (\x -> bodA)) (getType bodA) 165 | 166 | go (Use nam val bod) = do 167 | infer sus src (bod val) dep 168 | 169 | -- TODO: annotate inside ADT for completion (not needed) 170 | go (ADT scp cts typ) = do 171 | ctsA <- forM cts $ \ (Ctr cnam tele) -> do 172 | teleA <- checkTele sus src tele Set dep 173 | return $ Ctr cnam teleA 174 | return $ Ann False (ADT scp ctsA typ) Set 175 | 176 | go (Con nam arg) = do 177 | envLog (Error src (Ref "annotation") (Ref "constructor") (Con nam arg) dep) 178 | envFail 179 | 180 | go (Mat cse) = do 181 | envLog (Error src (Ref "annotation") (Ref "match") (Mat cse) dep) 182 | envFail 183 | 184 | go (Lam nam bod) = do 185 | envLog (Error src (Ref "annotation") (Ref "lambda") (Lam nam bod) dep) 186 | envFail 187 | 188 | go (Hol nam ctx) = do 189 | envLog (Error src (Ref "annotation") (Ref "hole") (Hol nam ctx) dep) 190 | envFail 191 | 192 | go (Met uid spn) = do 193 | envLog (Error src (Ref "annotation") (Ref "meta") (Met uid spn) dep) 194 | envFail 195 | 196 | go (Log msg nxt) = do 197 | msgA <- infer sus src msg dep 198 | nxtA <- infer sus src nxt dep 199 | return $ Ann False (Log msgA nxtA) (getType nxtA) 200 | 201 | go (Var nam idx) = do 202 | envLog (Error src (Ref "annotation") (Ref "variable") (Var nam idx) dep) 203 | envFail 204 | 205 | go (Src src val) = do 206 | infer sus (Just src) val dep 207 | 208 | go tm@(Txt txt) = do 209 | return $ Ann False tm (Ref "String") 210 | -- book <- envGetBook 211 | -- fill <- envGetFill 212 | -- go (reduce book fill 2 tm) 213 | 214 | go tm@(Nat val) = do 215 | book <- envGetBook 216 | fill <- envGetFill 217 | go (reduce book fill 2 tm) 218 | 219 | go tm@(Lst lst) = do 220 | book <- envGetBook 221 | fill <- envGetFill 222 | go (reduce book fill 2 tm) 223 | 224 | check :: Bool -> Maybe Cod -> Term -> Term -> Int -> Env Term 225 | check sus src term typx dep = debug ("check:" ++ (if sus then "* " else " ") ++ showTermGo False term dep ++ "\n :: " ++ showTermGo True typx dep) $ go term where 226 | 227 | go (App (Src _ val) arg) = 228 | go (App val arg) 229 | 230 | go (App (Mat cse) arg) = do 231 | argA <- infer sus src arg dep 232 | infer sus src (App (Ann True (Mat cse) (All "x" (getType argA) (\x -> replace arg x typx dep))) arg) dep 233 | 234 | go (App (Swi zer suc) arg) = do 235 | argA <- infer sus src arg dep 236 | infer sus src (App (Ann True (Swi zer suc) (All "x" (getType argA) (\x -> replace arg x typx dep))) arg) dep 237 | 238 | go (Lam nam bod) = do 239 | book <- envGetBook 240 | fill <- envGetFill 241 | case reduce book fill 2 typx of 242 | (All typNam typInp typBod) -> do 243 | let ann = Ann False (Var nam dep) typInp 244 | bodA <- check sus src (bod ann) (typBod ann) (dep + 1) 245 | return $ Ann False (Lam nam (\x -> bodA)) typx 246 | otherwise -> do 247 | infer sus src (Lam nam bod) dep 248 | 249 | go (Ins val) = do 250 | book <- envGetBook 251 | fill <- envGetFill 252 | case reduce book fill 2 typx of 253 | Slf typNam typTyp typBod -> do 254 | valA <- check sus src val (typBod (Ins val)) dep 255 | return $ Ann False (Ins valA) typx 256 | _ -> infer sus src (Ins val) dep 257 | 258 | go val@(Con nam arg) = do 259 | book <- envGetBook 260 | fill <- envGetFill 261 | case reduce book fill 2 typx of 262 | (ADT adtScp adtCts adtTyp) -> do 263 | case lookup nam (map (\(Ctr cNam cTel) -> (cNam, cTel)) adtCts) of 264 | Just cTel -> do 265 | argA <- checkConstructor src arg cTel dep 266 | return $ Ann False (Con nam argA) typx 267 | Nothing -> do 268 | envLog (Error src (Hol ("constructor_not_found:"++nam) []) (Hol "unknown_type" []) (Con nam arg) dep) 269 | envFail 270 | otherwise -> infer sus src (Con nam arg) dep 271 | where 272 | checkConstructor :: Maybe Cod -> [(Maybe String, Term)] -> Tele -> Int -> Env [(Maybe String, Term)] 273 | checkConstructor src [] (TRet ret) dep = do 274 | cmp src val ret typx dep 275 | return [] 276 | checkConstructor src ((field, arg):args) (TExt nam inp bod) dep = 277 | case field of 278 | Just field -> if field /= nam 279 | then do 280 | envLog (Error src (Hol ("expected:" ++ nam) []) (Hol ("detected:" ++ field) []) (Hol "field_mismatch" []) dep) 281 | envFail 282 | else do 283 | argA <- check sus src arg inp dep 284 | argsA <- checkConstructor src args (bod arg) (dep + 1) 285 | return $ (Just field, argA) : argsA 286 | Nothing -> do 287 | argA <- check sus src arg inp dep 288 | argsA <- checkConstructor src args (bod arg) (dep + 1) 289 | return $ (Nothing, argA) : argsA 290 | checkConstructor src _ _ dep = do 291 | envLog (Error src (Hol "arity_mismatch" []) (Hol "unknown_type" []) (Hol "constructor" []) dep) 292 | envFail 293 | 294 | go (Mat cse) = do 295 | book <- envGetBook 296 | fill <- envGetFill 297 | case reduce book fill 2 typx of 298 | (All typNam typInp typBod) -> do 299 | case reduce book fill 2 typInp of 300 | (ADT adtScp adtCts adtTyp) -> do 301 | -- Checks if all cases are well-typed 302 | let adtCtsMap = M.fromList (map (\ (Ctr cNam cTel) -> (cNam, cTel)) adtCts) 303 | let coveredCases = M.fromList cse 304 | cseA <- forM cse $ \ (cNam, cBod) -> do 305 | if cNam == "_" then do 306 | if null (adtCtsMap `M.difference` coveredCases) then do 307 | checkUnreachable Nothing cNam cBod dep 308 | else do 309 | cBodA <- check sus src cBod (All "" typInp typBod) dep 310 | return (cNam, cBodA) 311 | else case M.lookup cNam adtCtsMap of 312 | Just cTel -> do 313 | let a_r = teleToTerms cTel dep 314 | let eqs = zip (getDatIndices (reduce book fill 2 typInp)) (getDatIndices (reduce book fill 2 (snd a_r))) 315 | let rt0 = teleToType cTel (typBod (Ann False (Con cNam (fst a_r)) typInp)) dep 316 | let rt1 = foldl' (\ ty (a,b) -> replace a b ty dep) rt0 eqs 317 | if any (\(a,b) -> incompatible a b dep) eqs then 318 | checkUnreachable Nothing cNam cBod dep 319 | else do 320 | cBodA <- check sus src cBod rt1 dep 321 | return (cNam, cBodA) 322 | Nothing -> do 323 | envLog (Error src (Hol ("constructor_not_found:"++cNam) []) (Hol "unknown_type" []) (Mat cse) dep) 324 | envFail 325 | -- Check if all constructors are covered 326 | forM_ adtCts $ \ (Ctr cNam _) -> 327 | unless (M.member cNam coveredCases || M.member "_" coveredCases) $ do 328 | envLog (Error src (Hol ("missing_case:" ++ cNam) []) (Hol "incomplete_match" []) (Mat cse) dep) 329 | envFail 330 | return $ Ann False (Mat cseA) typx 331 | otherwise -> infer sus src (Mat cse) dep 332 | otherwise -> infer sus src (Mat cse) dep 333 | 334 | go (Swi zer suc) = do 335 | book <- envGetBook 336 | fill <- envGetFill 337 | case reduce book fill 2 typx of 338 | (All typNam typInp typBod) -> do 339 | case reduce book fill 2 typInp of 340 | U64 -> do 341 | -- Check zero case 342 | let zerAnn = Ann False (Num 0) U64 343 | zerA <- check sus src zer (typBod zerAnn) dep 344 | -- Check successor case 345 | let sucAnn = Ann False (Var "n" dep) U64 346 | let sucTyp = All "n" U64 (\x -> typBod (Op2 ADD (Num 1) x)) 347 | sucA <- check sus src suc sucTyp dep 348 | return $ Ann False (Swi zerA sucA) typx 349 | otherwise -> infer sus src (Swi zer suc) dep 350 | otherwise -> infer sus src (Swi zer suc) dep 351 | 352 | go (KVs kvs dft) = do 353 | book <- envGetBook 354 | fill <- envGetFill 355 | case reduce book fill 2 typx of 356 | (Map typ) -> do 357 | dftA <- check sus src dft typ dep 358 | kvsA <- forM (IM.toList kvs) $ \(key, val) -> do 359 | valA <- check sus src val typ dep 360 | return (key, valA) 361 | return $ Ann False (KVs (IM.fromList kvsA) dftA) typx 362 | otherwise -> infer sus src (KVs kvs dft) dep 363 | 364 | go (Get got nam map key bod) = do 365 | mapA <- infer sus src map dep 366 | book <- envGetBook 367 | fill <- envGetFill 368 | case reduce book fill 2 (getType mapA) of 369 | (Map typ) -> do 370 | let got_ann = Ann False (Var got dep) typ 371 | let nam_ann = Ann False (Var nam dep) (Map typ) 372 | keyA <- check sus src key U64 dep 373 | bodA <- check sus src (bod got_ann nam_ann) typx dep 374 | return $ Ann False (Get got nam mapA keyA (\g m -> bodA)) typx 375 | otherwise -> do 376 | envLog (Error src (Ref "Map") (getType mapA) (Get got nam map key bod) dep) 377 | envFail 378 | 379 | go (Put got nam map key val bod) = do 380 | mapA <- infer sus src map dep 381 | book <- envGetBook 382 | fill <- envGetFill 383 | case reduce book fill 2 (getType mapA) of 384 | (Map typ) -> do 385 | valA <- check sus src val typ dep 386 | let got_ann = Ann False (Var got dep) typ 387 | let nam_ann = Ann False (Var nam dep) (Map typ) 388 | keyA <- check sus src key U64 dep 389 | bodA <- check sus src (bod got_ann nam_ann) typx dep 390 | return $ Ann False (Put got nam mapA keyA valA (\g m -> bodA)) typx 391 | otherwise -> do 392 | envLog (Error src (Ref "Map") (getType mapA) (Put got nam map key val bod) dep) 393 | envFail 394 | 395 | go (Let nam val bod) = do 396 | valA <- infer sus src val dep 397 | bodA <- check sus src (bod (Ann False (Var nam dep) (getType valA))) typx dep 398 | return $ Ann False (Let nam valA (\x -> bodA)) typx 399 | 400 | go (Use nam val bod) = do 401 | check sus src (bod val) typx dep 402 | 403 | go (Hol nam ctx) = do 404 | envLog (Found nam typx ctx dep) 405 | return $ Ann False (Hol nam ctx) typx 406 | 407 | go (Met uid spn) = do 408 | return $ Ann False (Met uid spn) typx 409 | 410 | go (Log msg nxt) = do 411 | msgA <- infer sus src msg dep 412 | nxtA <- check sus src nxt typx dep 413 | return $ Ann False (Log msgA nxtA) typx 414 | 415 | go tm@(Txt txt) = do 416 | return $ Ann False tm (Ref "String") 417 | -- book <- envGetBook 418 | -- fill <- envGetFill 419 | -- go (reduce book fill 2 tm) 420 | 421 | go tm@(Nat val) = do 422 | book <- envGetBook 423 | fill <- envGetFill 424 | go (reduce book fill 2 tm) 425 | 426 | go tm@(Lst lst) = do 427 | book <- envGetBook 428 | fill <- envGetFill 429 | go (reduce book fill 2 tm) 430 | 431 | go (Ann True val typ) = do 432 | cmp src val typ typx dep 433 | check sus src val typ dep 434 | 435 | go (Ann False val typ) = do 436 | cmp src val typ typx dep -- FIXME: should this be here? 437 | return $ Ann False val typ 438 | 439 | go (Src src val) = do 440 | check sus (Just src) val typx dep 441 | 442 | go term = do 443 | termA <- infer sus src term dep 444 | cmp src term typx (getType termA) dep 445 | return termA 446 | 447 | cmp src term expected detected dep = do 448 | equal <- equal expected detected dep 449 | if equal then do 450 | susp <- envTakeSusp 451 | forM_ susp $ \ (Check src val typ dep) -> do 452 | check sus src val typ dep 453 | return () 454 | else do 455 | envLog (Error src expected detected term dep) 456 | envFail 457 | 458 | checkTele :: Bool -> Maybe Cod -> Tele -> Term -> Int -> Env Tele 459 | checkTele sus src tele typ dep = case tele of 460 | TRet term -> do 461 | termA <- check sus src term typ dep 462 | return $ TRet termA 463 | TExt nam inp bod -> do 464 | inpA <- check sus src inp Set dep 465 | bodA <- checkTele sus src (bod (Ann False (Var nam dep) inp)) typ (dep + 1) 466 | return $ TExt nam inpA (\x -> bodA) 467 | 468 | checkUnreachable :: Maybe Cod -> String -> Term -> Int -> Env (String, Term) 469 | checkUnreachable src cNam term dep = go src cNam term dep where 470 | go src cNam (Lam nam bod) dep = go src cNam (bod (Con "void" [])) (dep+1) 471 | go src cNam (Let nam val bod) dep = go src cNam (bod (Con "void" [])) (dep+1) 472 | go src cNam (Use nam val bod) dep = go src cNam (bod (Con "void" [])) (dep+1) 473 | go _ cNam (Src src val) dep = go (Just src) cNam val dep 474 | go src cNam (Hol nam ctx) dep = envLog (Found nam (Hol "unreachable" []) ctx dep) >> go src cNam Set dep 475 | go src cNam term dep = return (cNam, Ann False Set U64) 476 | 477 | checkLater :: Bool -> Maybe Cod -> Term -> Term -> Int -> Env Term 478 | checkLater False src term typx dep = check False src term typx dep 479 | checkLater True src term typx dep = envSusp (Check src term typx dep) >> return (Met 0 []) 480 | 481 | doCheckMode :: Bool -> Term -> Env Term 482 | doCheckMode sus (Ann _ val typ) = do 483 | check sus Nothing typ Set 0 484 | check sus Nothing val typ 0 485 | doCheckMode sus (Src _ val) = do 486 | doCheckMode sus val 487 | doCheckMode sus (Ref nam) = do 488 | book <- envGetBook 489 | case M.lookup nam book of 490 | Just val -> doCheckMode sus val 491 | Nothing -> envLog (Error Nothing (Ref "expression") (Ref "undefined") (Ref nam) 0) >> envFail 492 | doCheckMode sus term = do 493 | infer True Nothing term 0 494 | 495 | doCheck :: Term -> Env Term 496 | doCheck = doCheckMode True 497 | 498 | doAnnotate :: Term -> Env (Term, Fill) 499 | doAnnotate term = do 500 | doCheckMode True term 501 | term <- doCheckMode False term 502 | fill <- envGetFill 503 | return (bind term [], fill) 504 | -------------------------------------------------------------------------------- /src/Kind/CompileJS.hs: -------------------------------------------------------------------------------- 1 | -- Type.hs: 2 | -- //./Type.hs// 3 | 4 | -- FIXME: currently, the Map type will compile to a mutable map in JS, which 5 | -- means we assume it is used linearly (no cloning). To improve this, we can add 6 | -- a shallow-cloning operation for cloned maps, or use an immutable map. Adding 7 | -- linearity checks to Kind would let us pick the best representation. 8 | 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | module Kind.CompileJS where 12 | 13 | import Kind.Check 14 | import Kind.Env 15 | import Kind.Equal 16 | import Kind.Reduce 17 | import Kind.Show 18 | import Kind.Type 19 | import Kind.Util 20 | 21 | import Control.Monad (forM) 22 | import Data.List (intercalate, isSuffixOf, elem, isInfixOf, isPrefixOf) 23 | import Data.Maybe (fromJust, isJust) 24 | import Data.Word 25 | import qualified Control.Monad.State.Lazy as ST 26 | import qualified Data.IntMap.Strict as IM 27 | import qualified Data.Map.Strict as M 28 | import qualified Data.Set as S 29 | 30 | import Debug.Trace 31 | 32 | import Prelude hiding (EQ, LT, GT) 33 | 34 | -- Type 35 | -- ---- 36 | 37 | -- Compilation Targets 38 | data Target = C | JS deriving (Eq, Show) 39 | 40 | -- Compilable Term 41 | data CT 42 | = CNul 43 | | CSet 44 | | CU64 45 | | CF64 46 | | CADT [(String,[(String,CT)])] 47 | | CMap CT 48 | | CAll (String,CT) (CT -> CT) 49 | | CLam (String,CT) (CT -> CT) 50 | | CApp CT CT 51 | | CCon String [(String, CT)] 52 | | CMat CT [(String, [(String,CT)], CT)] 53 | | CRef String 54 | | CHol String 55 | | CLet (String,CT) CT (CT -> CT) 56 | | CNum Word64 57 | | CFlt Double 58 | | COp2 CT Oper CT CT 59 | | CSwi CT CT CT 60 | | CKVs (IM.IntMap CT) CT 61 | | CGet String String CT CT (CT -> CT -> CT) 62 | | CPut String String CT CT CT (CT -> CT -> CT) 63 | | CLog CT CT 64 | | CVar String Int 65 | | CTxt String 66 | | CLst [CT] 67 | | CNat Integer 68 | 69 | type CTBook = M.Map String CT 70 | 71 | -- Term to CT 72 | -- ---------- 73 | 74 | -- Converts a Term into a Compilable Term 75 | -- Uses type information to: 76 | -- - Ensure constructor fields are present 77 | -- - Annotate Mat cases with the field names 78 | termToCT :: Book -> Fill -> Term -> Maybe Term -> Int -> CT 79 | termToCT book fill term typx dep = bindCT (t2ct term typx dep) [] where 80 | 81 | t2ct term typx dep = 82 | -- trace ("t2ct: " ++ showTerm term ++ "\ntype: " ++ maybe "*" showTerm typx ++ "\ndep: " ++ show dep) $ 83 | go term where 84 | 85 | go (All nam inp bod) = 86 | let inp' = t2ct inp Nothing dep 87 | bod' = \x -> t2ct (bod (Var nam dep)) Nothing (dep+1) 88 | in CAll (nam,inp') bod' 89 | go (Lam nam bod) = 90 | case typx of 91 | Just typx -> case (reduce book fill 2 typx) of 92 | (All _ inp _) -> 93 | let inp' = t2ct inp Nothing dep 94 | bod' = \x -> t2ct (bod (Var nam dep)) Nothing (dep+1) 95 | in CLam (nam,inp') bod' 96 | other -> error "err" 97 | Nothing -> error "err" 98 | go (App fun arg) = 99 | let fun' = t2ct fun Nothing dep 100 | arg' = t2ct arg Nothing dep 101 | in CApp fun' arg' 102 | go (Ann _ val typ) = 103 | t2ct val (Just typ) dep 104 | go (Slf _ _ _) = 105 | CNul 106 | go (Ins val) = 107 | t2ct val typx dep 108 | go (ADT scp cts typ) = 109 | let cts' = map (\ (Ctr nam tele) -> (nam, map (\ (fn,ft) -> (fn, go ft)) (getTeleFields tele dep []))) cts 110 | in CADT cts' 111 | go (Con nam arg) = 112 | case typx of 113 | Just typx -> case lookup nam (getADTCts (reduce book fill 2 typx)) of 114 | Just (Ctr _ tele) -> 115 | let fNames = getTeleNames tele dep [] 116 | fields = map (\ (f,t) -> (f, t2ct t Nothing dep)) $ zip fNames (map snd arg) 117 | in CCon nam fields 118 | Nothing -> error $ "constructor-not-found:" ++ nam 119 | Nothing -> error $ "untyped-constructor" 120 | go (Mat cse) = 121 | case typx of 122 | Just typx -> case reduce book fill 2 typx of 123 | (All _ adt _) -> 124 | let adtV = reduce book fill 2 adt 125 | cts = getADTCts adtV 126 | adt' = t2ct adt Nothing dep 127 | cses = map (\ (cnam, cbod) -> 128 | if cnam == "_" then 129 | (cnam, [("_",adt')], t2ct cbod Nothing dep) 130 | else case lookup cnam cts of 131 | Just (Ctr _ tele) -> 132 | let fInps = getTeleFields tele dep [] 133 | fInps' = map (\ (nm,ty) -> (nm, t2ct ty Nothing dep)) fInps 134 | in (cnam, fInps', t2ct cbod Nothing dep) 135 | Nothing -> error $ "constructor-not-found:" ++ cnam) cse 136 | in CLam ("__" ++ show dep, adt') $ \x -> CMat x cses 137 | otherwise -> error "match-without-type" 138 | Nothing -> error "err" 139 | go (Swi zer suc) = 140 | let zer' = t2ct zer Nothing dep 141 | suc' = t2ct suc Nothing dep 142 | in CLam ("__" ++ show dep, CU64) $ \x -> CSwi x zer' suc' 143 | go (Map typ) = 144 | let typ' = t2ct typ Nothing dep 145 | in CMap typ' 146 | go (KVs kvs def) = 147 | let kvs' = IM.map (\v -> t2ct v Nothing dep) kvs 148 | def' = t2ct def Nothing dep 149 | in CKVs kvs' def' 150 | go (Get got nam map key bod) = 151 | let map' = t2ct map Nothing dep 152 | key' = t2ct key Nothing dep 153 | bod' = \x y -> t2ct (bod (Var got dep) (Var nam dep)) Nothing (dep+2) 154 | in CGet got nam map' key' bod' 155 | go (Put got nam map key val bod) = 156 | let map' = t2ct map Nothing dep 157 | key' = t2ct key Nothing dep 158 | val' = t2ct val Nothing dep 159 | bod' = \x y -> t2ct (bod (Var got dep) (Var nam dep)) Nothing (dep+2) 160 | in CPut got nam map' key' val' bod' 161 | go (All _ _ _) = 162 | CNul 163 | go (Ref nam) = 164 | CRef nam 165 | go (Let nam val bod) = 166 | -- FIXME: add type 167 | let val' = t2ct val Nothing dep 168 | bod' = \x -> t2ct (bod (Var nam dep)) Nothing (dep+1) 169 | in CLet (nam,CNul) val' bod' 170 | go (Use nam val bod) = 171 | t2ct (bod val) typx dep 172 | go Set = 173 | CSet 174 | go U64 = 175 | CU64 176 | go F64 = 177 | CF64 178 | go (Num val) = 179 | CNum val 180 | go (Flt val) = 181 | CFlt val 182 | go (Op2 opr fst snd) = case typx of 183 | Nothing -> error "Type information required for binary operation" 184 | Just typ -> 185 | let fst' = t2ct fst Nothing dep 186 | snd' = t2ct snd Nothing dep 187 | typ' = t2ct typ Nothing dep 188 | in COp2 typ' opr fst' snd' 189 | go (Txt txt) = 190 | CTxt txt 191 | go (Lst lst) = 192 | CLst (map (\x -> t2ct x Nothing dep) lst) 193 | go (Nat val) = 194 | CNat val 195 | go (Hol nam _) = 196 | CHol nam 197 | go (Met _ _) = 198 | CNul 199 | go (Log msg nxt) = 200 | let msg' = t2ct msg Nothing dep 201 | nxt' = t2ct nxt Nothing dep 202 | in CLog msg' nxt' 203 | go (Var nam idx) = 204 | CVar nam idx 205 | go (Src _ val) = 206 | t2ct val typx dep 207 | 208 | -- CT Transformations 209 | -- ------------------ 210 | 211 | -- Removes unreachable cases 212 | removeUnreachables :: CT -> CT 213 | removeUnreachables ct = go ct where 214 | go CNul = 215 | CNul 216 | go CSet = 217 | CSet 218 | go CU64 = 219 | CU64 220 | go CF64 = 221 | CF64 222 | go (CADT cts) = 223 | let cts' = map (\ (n,fs) -> (n, map (\ (fn,ft) -> (fn, go ft)) fs)) cts 224 | in CADT cts' 225 | go (CMap typ) = 226 | let typ' = go typ 227 | in CMap typ' 228 | go (CMat val cse) = 229 | let val' = go val 230 | cse' = map (\ (n,f,t) -> (n, map (\ (fn,ft) -> (fn, go ft)) f, go t)) cse 231 | cseF = filter (\ (_,_,t) -> not (isNul t)) cse' 232 | in CMat val' cseF 233 | go (CAll (nam,inp) bod) = 234 | let inp' = go inp 235 | bod' = \x -> go (bod x) 236 | in CAll (nam,inp') bod' 237 | go (CLam (nam,inp) bod) = 238 | let inp' = go inp 239 | bod' = \x -> go (bod x) 240 | in CLam (nam,inp') bod' 241 | go (CApp fun arg) = 242 | let fun' = go fun 243 | arg' = go arg 244 | in CApp fun' arg' 245 | go (CCon nam fields) = 246 | let fields' = map (\ (f,t) -> (f, go t)) fields 247 | in CCon nam fields' 248 | go (CRef nam) = CRef nam 249 | go (CHol nam) = CHol nam 250 | go (CLet (nam,typ) val bod) = 251 | let typ' = go typ 252 | val' = go val 253 | bod' = \x -> go (bod x) 254 | in CLet (nam,typ') val' bod' 255 | go (CNum val) = 256 | CNum val 257 | go (CFlt val) = 258 | CFlt val 259 | go (COp2 typ opr fst snd) = 260 | let fst' = go fst 261 | snd' = go snd 262 | typ' = go typ 263 | in COp2 typ' opr fst' snd' 264 | go (CSwi val zer suc) = 265 | let val' = go val 266 | zer' = go zer 267 | suc' = go suc 268 | in CSwi val' zer' suc' 269 | go (CKVs kvs def) = 270 | let kvs' = IM.map go kvs 271 | def' = go def 272 | in CKVs kvs' def' 273 | go (CGet got nam map key bod) = 274 | let map' = go map 275 | key' = go key 276 | bod' = \x y -> go (bod x y) 277 | in CGet got nam map' key' bod' 278 | go (CPut got nam map key val bod) = 279 | let map' = go map 280 | key' = go key 281 | val' = go val 282 | bod' = \x y -> go (bod x y) 283 | in CPut got nam map' key' val' bod' 284 | go (CLog msg nxt) = 285 | let msg' = go msg 286 | nxt' = go nxt 287 | in CLog msg' nxt' 288 | go (CVar nam idx) = 289 | CVar nam idx 290 | go (CTxt txt) = 291 | CTxt txt 292 | go (CLst lst) = 293 | CLst (map go lst) 294 | go (CNat val) = 295 | CNat val 296 | 297 | -- Lifts shareable lambdas across branches: 298 | -- - from: λx match v { #Foo{a b}: λy λz A #Bar: λy λz B ... } 299 | -- - to: λx λy λz match v { #Foo{a b}: A #Bar: B ... } 300 | -- TODO: document why this is (and has to be) terrible 301 | -- NOTE: this loses dependencies, turning foralls into simple arrows 302 | liftLambdas :: CT -> Int -> CT 303 | liftLambdas ct depth = 304 | gen (liftInp ct depth [] 0) [] ct depth where 305 | 306 | gen :: [CT] -> [CT] -> CT -> Int -> CT 307 | gen [] ctx ct dep = liftVal ctx ct dep [] 0 308 | gen (inp:inps) ctx ct dep = CLam (nam dep, inp) (\x -> gen inps (ctx++[x]) ct (dep+1)) 309 | 310 | nam :: Int -> String 311 | nam d = "_" ++ "$" ++ show d 312 | 313 | var :: [CT] -> Int -> CT 314 | var ctx d | d < length ctx = ctx !! d 315 | var ctx d | otherwise = CNul 316 | 317 | eta :: [(String,CT)] -> CT -> CT 318 | eta [] ct = ct 319 | eta (fld:flds) (CLam (nam,inp) bod) = CLam (nam,inp) $ \x -> eta flds (bod x) 320 | eta (fld:flds) ct = CLam fld $ \x -> CApp (eta flds ct) x 321 | 322 | liftVal :: [CT] -> CT -> Int -> [CT] -> Int -> CT 323 | liftVal ctx ct dep inp skip = go ct dep inp skip where 324 | go (CLam (nam,inp) bod) dep inps 0 = liftVal ctx (bod (var ctx (length inps))) (dep+1) (inps++[inp]) 0 325 | go (CLam (nam,inp) bod) dep inps skip = CLam (nam,inp) $ \x -> liftVal ctx (bod x) (dep+1) inps (skip-1) 326 | go (CLet (nam,typ) val bod) dep inps skip = CLet (nam,typ) val $ \x -> liftVal ctx (bod x) (dep+1) inps skip 327 | go ct@(CMat val cse) dep inps skip | length cse > 0 = 328 | let recsV = flip map cse $ \ (_,f,b) -> liftVal ctx (eta f b) dep inps (skip + length f) 329 | recsI = flip map cse $ \ (_,f,b) -> liftInp (eta f b) dep inps (skip + length f) 330 | valid = flip all recsI $ \ a -> length a == length (head recsI) 331 | in if valid then CMat val (zipWith (\ (n,f,_) b -> (n,f,b)) cse recsV) else ct 332 | go ct@(CSwi val zer suc) dep inps skip = 333 | let recZI = liftInp (eta [] zer) dep inps skip 334 | recZV = liftVal ctx (eta [] zer) dep inps skip 335 | recSI = liftInp (eta [("p",CU64)] suc) dep inps (skip + 1) 336 | recSV = liftVal ctx (eta [("p",CU64)] suc) dep inps (skip + 1) 337 | valid = length recZI == length recSI 338 | in if valid then CSwi val recZV recSV else ct 339 | go ct dep inps s = ct 340 | 341 | liftInp :: CT -> Int -> [CT] -> Int -> [CT] 342 | liftInp ct dep inps skip = go ct dep inps skip where 343 | go (CLam (nam,inp) bod) dep inps 0 = liftInp (bod CNul) (dep+1) (inps++[inp]) 0 344 | go (CLam (nam,inp) bod) dep inps skip = liftInp (bod CNul) (dep+1) inps (skip-1) 345 | go (CLet (nam,typ) val bod) dep inps skip = liftInp (bod CNul) (dep+1) inps skip 346 | go (CMat val cse) dep inps skip | length cse > 0 = 347 | let recsI = flip map cse $ \ (_,f,b) -> liftInp (eta f b) dep inps (skip + length f) 348 | valid = flip all recsI $ \ a -> length a == length (head recsI) 349 | in if valid then head recsI else inps 350 | go (CSwi val zer suc) dep inps skip = 351 | let recZI = liftInp (eta [] zer) dep inps skip 352 | recSI = liftInp (eta [("p",CU64)] suc) dep inps (skip + 1) 353 | valid = length recZI == length recSI 354 | in if valid then recZI else inps 355 | go ct dep inps s = inps 356 | 357 | inline :: CTBook -> CT -> CT 358 | inline book ct = nf ct where 359 | nf :: CT -> CT 360 | nf ct = go (red book ct) where 361 | go :: CT -> CT 362 | go CNul = CNul 363 | go CSet = CSet 364 | go CU64 = CU64 365 | go CF64 = CF64 366 | go (CADT cts) = CADT (map (\ (n,fs) -> (n, map (\ (fn,ft) -> (fn, nf ft)) fs)) cts) 367 | go (CMap typ) = CMap (nf typ) 368 | go (CAll (nam,inp) bod) = CAll (nam, nf inp) (\x -> nf (bod x)) 369 | go (CLam (nam,inp) bod) = CLam (nam, nf inp) (\x -> nf (bod x)) 370 | go (CApp fun arg) = CApp (nf fun) (nf arg) 371 | go (CCon nam fields) = CCon nam (map (\ (f,t) -> (f, nf t)) fields) 372 | go (CADT cts) = CADT (map (\ (n,fs) -> (n, map (\ (fn,ft) -> (fn, nf ft)) fs)) cts) 373 | go (CMat val cses) = CMat (nf val) (map (\ (n,f,b) -> (n, map (\ (fn,ft) -> (fn, nf ft)) f, nf b)) cses) 374 | go (CRef nam) = CRef nam 375 | go (CHol nam) = CHol nam 376 | go (CLet (nam,typ) val bod) = CLet (nam, nf typ) (nf val) (\x -> nf (bod x)) 377 | go (CNum val) = CNum val 378 | go (CFlt val) = CFlt val 379 | go (COp2 typ opr fst snd) = COp2 (nf typ) opr (nf fst) (nf snd) 380 | go (CSwi val zer suc) = CSwi (nf val) (nf zer) (nf suc) 381 | go (CKVs kvs def) = CKVs (IM.map nf kvs) (nf def) 382 | go (CGet g n m k b) = CGet g n (nf m) (nf k) (\x y -> nf (b x y)) 383 | go (CPut g n m k v b) = CPut g n (nf m) (nf k) (nf v) (\x y -> nf (b x y)) 384 | go (CLog msg nxt) = CLog (nf msg) (nf nxt) 385 | go (CVar nam idx) = CVar nam idx 386 | go (CTxt txt) = CTxt txt 387 | go (CLst lst) = CLst (map nf lst) 388 | go (CNat val) = CNat val 389 | 390 | -- CT Evaluation 391 | -- ------------- 392 | 393 | -- Reduce to WNF 394 | red :: CTBook -> CT -> CT 395 | red book tm = go tm where 396 | go (CApp fun arg) = app book (red book fun) arg 397 | go (CRef nam) = ref book nam 398 | go val = val 399 | 400 | -- (let x = y A B) 401 | -- --------------- 402 | -- let x = y (A B) 403 | 404 | -- Application 405 | app :: CTBook -> CT -> CT -> CT 406 | app book (CAll (nam,inp) bod) arg = red book (bod (red book arg)) 407 | app book (CLam (nam,inp) bod) arg = red book (bod (red book arg)) 408 | app book (CMat val cse) arg = CMat val (map (\ (n,f,b) -> (n, f, skp f b (\b -> CApp b arg))) cse) 409 | app book (CLet (nam,typ) val bod) arg = CLet (nam,typ) val (\x -> app book (bod x) arg) 410 | app book fun arg = CApp fun arg 411 | 412 | -- Maps inside N lambdas 413 | skp :: [(String,CT)] -> CT -> (CT -> CT) -> CT 414 | skp [] ct fn = fn ct 415 | skp (fld:flds) ct fn = CLam fld $ \x -> skp flds (CApp ct x) fn 416 | 417 | -- Reference 418 | -- NOTE: this should only inline refs ending with "bind", "bind/go" or "pure". 419 | -- create an aux function called "inl :: String -> Bool" after it 420 | ref :: CTBook -> String -> CT 421 | ref book nam 422 | | inl nam = red book (fromJust (M.lookup nam book)) 423 | | otherwise = CRef nam 424 | where 425 | inl :: String -> Bool 426 | inl nam = any (`isSuffixOf` nam) 427 | [ "/bind" 428 | , "/bind/go" 429 | , "/pure" 430 | -- , "HVM/RTag/eq" 431 | -- , "HVM/RTerm/get-lab" 432 | -- , "HVM/RTerm/get-loc" 433 | -- , "HVM/RTerm/get-tag" 434 | -- , "HVM/RTerm/new" 435 | -- , "HVM/alloc-redex" 436 | -- , "HVM/alloc-rnod" 437 | -- , "HVM/get" 438 | -- , "HVM/just" 439 | -- , "HVM/link" 440 | -- , "HVM/port" 441 | -- , "HVM/push-redex" 442 | -- , "HVM/set" 443 | -- , "HVM/swap" 444 | -- , "HVM/take" 445 | -- , "U64/to-bool" 446 | , "IO/print" 447 | , "IO/prompt" 448 | , "IO/swap" 449 | , "IO/read" 450 | , "IO/exec" 451 | , "IO/args" 452 | ] 453 | 454 | -- JavaScript Codegen 455 | -- ------------------ 456 | 457 | getArguments :: CT -> ([(String,CT)], CT) 458 | getArguments term = go term 0 where 459 | go (CLam (nam,inp) bod) dep = 460 | let (args, body) = go (bod (CVar nam dep)) (dep+1) 461 | in ((nam,inp):args, body) 462 | go body dep = ([], body) 463 | 464 | arityOf :: CTBook -> String -> Int 465 | arityOf book name = case M.lookup name book of 466 | Just ct -> length $ fst $ getArguments ct 467 | Nothing -> 0 468 | 469 | isRecCall :: String -> Int -> CT -> [CT] -> Bool 470 | isRecCall fnName arity appFun appArgs = 471 | case appFun of 472 | CRef appFunName -> 473 | let isSameFunc = appFunName == fnName 474 | isSameArity = length appArgs == arity 475 | in isSameFunc && isSameArity 476 | _ -> False 477 | 478 | isSatCall :: CTBook -> CT -> [CT] -> Bool 479 | isSatCall book (CRef funName) appArgs = arityOf book funName == length appArgs 480 | isSatCall book _ _ = False 481 | 482 | isEffCall :: CTBook -> CT -> [CT] -> Bool 483 | isEffCall book (CHol name) appArgs = True 484 | isEffCall book name appArgs = False 485 | 486 | -- Converts a function to JavaScript or C 487 | fnToJS :: CTBook -> String -> CT -> ST.State Int String 488 | fnToJS book fnName ct@(getArguments -> (fnArgs, fnBody)) = do 489 | bodyName <- fresh 490 | bodyStmt <- ctToJS True bodyName fnBody 0 491 | argTypes <- return $ zipWith (\ dep (nm,ty) -> tyToTS ty dep) [0..] fnArgs 492 | 493 | let arg = zip (map fst fnArgs) argTypes 494 | let tco = isInfixOf "/*TCO*/" bodyStmt 495 | let bod = "{" ++ bodyStmt ++ "return " ++ bodyName ++ "; }" 496 | let fun = jsDefFun fnName arg tco bod 497 | let cur = jsDefCur fnName arg 498 | return $ fun ++ "\n" ++ cur 499 | 500 | where 501 | 502 | -- Generates top-level function 503 | jsDefFun name [] tco body = 504 | let wrap = \x -> "(() => " ++ x ++ ")()" 505 | head = "const " ++ nameToJS name ++ "$ = " 506 | in head ++ wrap body 507 | jsDefFun name arg tco body = 508 | let loop = \ x -> concat ["{while(1)", x, "}"] 509 | head = "function " ++ nameToJS name ++ "$(" ++ intercalate "," (map (\ (nm,ty) -> nm++"/*:"++ty++"*/") arg) ++ ") " 510 | in head ++ (if tco then loop body else body) 511 | 512 | -- Generates top-level function (curried version) 513 | jsDefCur name arg = 514 | let head = "const " ++ nameToJS name ++ " = " ++ concat (map (\x -> x ++ " => ") (map fst arg)) 515 | body = nameToJS name ++ "$" ++ (if null arg then "" else "(" ++ intercalate "," (map fst arg) ++ ")") 516 | in head ++ body 517 | 518 | -- Genreates a fresh name 519 | fresh :: ST.State Int String 520 | fresh = do 521 | n <- ST.get 522 | ST.put (n + 1) 523 | return $ "$x" ++ show n 524 | 525 | -- Assigns an expression to a name, or return it directly 526 | set :: String -> String -> ST.State Int String 527 | set name expr = return $ "var " ++ name ++ " = " ++ expr ++ ";" 528 | 529 | -- Compiles a name to JS 530 | nameToJS :: String -> String 531 | nameToJS x = "$" ++ map (\c -> if c == '/' || c == '.' || c == '-' || c == '#' then '$' else c) x 532 | 533 | -- Compiles an Oper to JS 534 | operToJS :: Oper -> String 535 | operToJS ADD = "+" 536 | operToJS SUB = "-" 537 | operToJS MUL = "*" 538 | operToJS DIV = "/" 539 | operToJS MOD = "%" 540 | operToJS EQ = "===" 541 | operToJS NE = "!==" 542 | operToJS LT = "<" 543 | operToJS GT = ">" 544 | operToJS LTE = "<=" 545 | operToJS GTE = ">=" 546 | operToJS AND = "&" 547 | operToJS OR = "|" 548 | operToJS XOR = "^" 549 | operToJS LSH = "<<" 550 | operToJS RSH = ">>" 551 | 552 | -- Compiles a CType to TS 553 | tyToTS :: CT -> Int -> String 554 | tyToTS CSet dep = 555 | "Type" 556 | tyToTS CU64 dep = 557 | "BigInt" 558 | tyToTS CF64 dep = 559 | "Number" 560 | tyToTS (CADT cts) dep = 561 | intercalate " | " $ flip map cts $ \ (nm,fs) -> "{$:'" ++ nm ++ "'" ++ concat (map (\ (fn,ft) -> ", " ++ fn ++ ": " ++ tyToTS ft dep) fs) ++ "}" 562 | tyToTS (CMap typ) dep = 563 | "Map" 564 | tyToTS (CAll (nam,inp) bod) dep = 565 | let uid = nameToJS nam ++ "$" ++ show dep 566 | in "(" ++ uid ++ ":" ++ tyToTS inp dep ++ ") => " ++ tyToTS (bod (CVar uid dep)) (dep + 1) 567 | tyToTS (CRef nam) dep = 568 | nam 569 | tyToTS (CVar nam _) dep = 570 | nam 571 | tyToTS (CApp fun arg) dep = 572 | tyToTS fun dep ++ "<" ++ tyToTS arg dep ++ ">" 573 | tyToTS CNul dep = 574 | "null" 575 | tyToTS term dep = 576 | "null" 577 | 578 | -- Compiles a CTerm to JS 579 | ctToJS :: Bool -> String -> CT -> Int -> ST.State Int String 580 | ctToJS tail var term dep = 581 | -- trace ("COMPILE: " ++ showCT term 0) $ 582 | go (red book term) where 583 | go CNul = 584 | set var "null" 585 | go CSet = 586 | set var "/*Type*/null" 587 | go ty@CU64 = 588 | set var $ "/*" ++ tyToTS ty dep ++ "*/null" 589 | go ty@CF64 = 590 | set var $ "/*" ++ tyToTS ty dep ++ "*/null" 591 | go ty@(CADT cts) = do 592 | set var $ "/*" ++ tyToTS ty dep ++ "*/null" 593 | go ty@(CMap typ) = 594 | set var $ "/*" ++ tyToTS ty dep ++ "*/null" 595 | go ty@(CAll (nam,inp) bod) = 596 | set var $ "/*" ++ tyToTS ty dep ++ "*/null" 597 | go tm@(CLam (nam,inp) bod) = do 598 | let (names, bodyTerm, _) = lams tm dep [] 599 | bodyName <- fresh 600 | bodyStmt <- ctToJS False bodyName bodyTerm (dep + length names) 601 | set var $ concat ["(", intercalate " => " names, " => {", bodyStmt, "return ", bodyName, ";})"] 602 | where lams :: CT -> Int -> [String] -> ([String], CT, Maybe Term) 603 | lams (CLam (n,i) b) dep names = 604 | let uid = nameToJS n ++ "$" ++ show dep 605 | in lams (b (CVar uid dep)) (dep + 1) (uid : names) 606 | lams term dep names = (reverse names, term, Nothing) 607 | go app@(CApp fun arg) = do 608 | let (appFun, appArgs) = getAppChain app 609 | -- Tail Recursive Call 610 | if tail && isRecCall fnName (length fnArgs) appFun appArgs then do 611 | argDefs <- forM (zip (map fst fnArgs) appArgs) $ \ (paramName, appArgs) -> do 612 | argName <- fresh 613 | argStmt <- ctToJS False argName appArgs dep 614 | return (argStmt, paramName ++ " = " ++ argName ++ ";") 615 | let (argStmts, paramDefs) = unzip argDefs 616 | return $ concat argStmts ++ concat paramDefs ++ "/*TCO*/continue;" 617 | -- Saturated Call Optimization 618 | else if isSatCall book appFun appArgs then do 619 | let (CRef funName) = appFun 620 | argNamesStmts <- forM appArgs $ \arg -> do 621 | argName <- fresh 622 | argStmt <- ctToJS False argName arg dep 623 | return (argName, argStmt) 624 | retStmt <- set var $ concat [nameToJS funName, "$(", intercalate ", " (map fst argNamesStmts), ")"] 625 | return $ concat (map snd argNamesStmts ++ [retStmt]) 626 | -- IO Actions 627 | else if isEffCall book appFun appArgs then do 628 | let (CHol name) = appFun 629 | case name of 630 | "IO_BIND" -> do 631 | let [_, _, call, cont] = appArgs 632 | callName <- fresh 633 | callStmt <- ctToJS False callName call dep 634 | contStmt <- ctToJS False var (CApp cont (CVar callName dep)) dep 635 | return $ concat [callStmt, contStmt] 636 | "IO_PURE" -> do 637 | let [_, value] = appArgs 638 | valueStmt <- ctToJS False var value dep 639 | return $ valueStmt 640 | "IO_SWAP" -> do 641 | let [key, val] = appArgs 642 | keyName <- fresh 643 | keyStmt <- ctToJS False keyName key dep 644 | valName <- fresh 645 | valStmt <- ctToJS False valName val dep 646 | resName <- fresh 647 | resStmt <- set resName (concat ["SWAP(", keyName, ", ", valName, ");"]) 648 | doneStmt <- ctToJS False var (CVar resName 0) dep 649 | return $ concat [keyStmt, valStmt, resStmt, doneStmt] 650 | "IO_PRINT" -> do 651 | let [text] = appArgs 652 | textName <- fresh 653 | textStmt <- ctToJS False textName text dep 654 | doneStmt <- ctToJS False var (CCon "Unit" []) dep 655 | return $ concat [textStmt, "console.log(LIST_TO_JSTR(", textName, "));", doneStmt] 656 | "IO_PROMPT" -> do 657 | error $ "TODO" 658 | "IO_READ" -> do 659 | let [path] = appArgs 660 | pathName <- fresh 661 | pathStmt <- ctToJS False pathName path dep 662 | let readStmt = concat 663 | [ "try { var ", var, " = { $: 'Done', value: JSTR_TO_LIST(readFileSync(LIST_TO_JSTR(", pathName, "), 'utf8')) }; } " 664 | , "catch (e) { var ", var, " = { $: 'Fail', error: e.message }; }" 665 | ] 666 | return $ concat [pathStmt, readStmt] 667 | "IO_EXEC" -> do 668 | let [cmd] = appArgs 669 | cmdName <- fresh 670 | cmdStmt <- ctToJS False cmdName cmd dep 671 | retStmt <- set var $ concat ["JSTR_TO_LIST(execSync(LIST_TO_JSTR(", cmdName, ")).toString())"] 672 | return $ concat [cmdStmt, retStmt] 673 | "IO_ARGS" -> do 674 | let [_] = appArgs 675 | retStmt <- set var "JARRAY_TO_LIST(process.argv.slice(2), JSTR_TO_LIST)" 676 | return retStmt 677 | _ -> error $ "Unknown IO operation: " ++ name 678 | -- Normal Application 679 | else do 680 | funName <- fresh 681 | funStmt <- ctToJS False funName fun dep 682 | argName <- fresh 683 | argStmt <- ctToJS False argName arg dep 684 | retStmt <- set var $ concat ["(", funName, ")(", argName, ")"] 685 | return $ concat [funStmt, argStmt, retStmt] 686 | go (CCon nam fields) = do 687 | objStmt <- set var $ concat ["({$: \"", nam, "\"})"] 688 | setStmts <- forM fields $ \ (nm, tm) -> do 689 | fldName <- fresh 690 | fldStmt <- ctToJS False fldName tm dep 691 | setStmt <- return $ concat [var ++ "." ++ nm ++ " = " ++ fldName ++ ";"] 692 | return $ concat [fldStmt, setStmt] 693 | return $ concat $ [objStmt] ++ setStmts 694 | go (CMat val cses) = do 695 | let isRecord = length cses == 1 && not (any (\ (nm,_,_) -> nm == "_") cses) 696 | valName <- fresh 697 | valStmt <- ctToJS False valName val dep 698 | cases <- forM cses $ \ (cnam, fields, cbod) -> 699 | if cnam == "_" then do 700 | retStmt <- ctToJS tail var (CApp cbod (CVar valName 0)) dep 701 | return $ concat ["default: { " ++ retStmt, " break; }"] 702 | else do 703 | let bod = foldl CApp cbod (map (\ (fn,ft) -> (CVar (valName++"."++fn) 0)) fields) 704 | retStmt <- ctToJS tail var bod dep 705 | return $ if isRecord 706 | then retStmt 707 | else concat ["case \"", cnam, "\": { ", retStmt, " break; }"] 708 | let switch = if isRecord 709 | then concat [valStmt, unwords cases] 710 | else concat [valStmt, "switch (", valName, ".$) { ", unwords cases, " }"] 711 | return $ switch 712 | go (CSwi val zer suc) = do 713 | valName <- fresh 714 | valStmt <- ctToJS False valName val dep 715 | zerStmt <- ctToJS tail var zer dep 716 | sucStmt <- ctToJS tail var (CApp suc (COp2 CU64 SUB (CVar valName 0) (CNum 1))) dep 717 | let swiStmt = concat [valStmt, "if (", valName, " === 0n) { ", zerStmt, " } else { ", sucStmt, " }"] 718 | return $ swiStmt 719 | go (CKVs kvs def) = do 720 | dftStmt <- do 721 | dftName <- fresh 722 | dftStmt <- ctToJS False dftName def dep 723 | return $ concat [dftStmt, var, ".set(-1n, ", dftName, ");"] 724 | kvStmts <- forM (IM.toList kvs) $ \(k, v) -> do 725 | valName <- fresh 726 | valStmt <- ctToJS False valName v dep 727 | return $ concat [valStmt, var, ".set(", show k, "n, ", valName, ");"] 728 | let mapStmt = concat ["var ", var, " = new Map();", unwords kvStmts, dftStmt] 729 | return $ mapStmt 730 | go (CGet got nam map key bod) = do 731 | mapName <- fresh 732 | mapStmt <- ctToJS False mapName map dep 733 | keyName <- fresh 734 | keyStmt <- ctToJS False keyName key dep 735 | neoName <- fresh 736 | gotName <- fresh 737 | retStmt <- ctToJS tail var (bod (CVar gotName dep) (CVar neoName dep)) dep 738 | let gotStmt = concat ["var ", gotName, " = ", mapName, ".has(", keyName, ") ? ", mapName, ".get(", keyName, ") : ", mapName, ".get(-1n);"] 739 | let neoStmt = concat ["var ", neoName, " = ", mapName, ";"] 740 | return $ concat [mapStmt, keyStmt, gotStmt, neoStmt, retStmt] 741 | go (CPut got nam map key val bod) = do 742 | mapName <- fresh 743 | mapStmt <- ctToJS False mapName map dep 744 | keyName <- fresh 745 | keyStmt <- ctToJS False keyName key dep 746 | valName <- fresh 747 | valStmt <- ctToJS False valName val dep 748 | neoName <- fresh 749 | gotName <- fresh 750 | retStmt <- ctToJS tail var (bod (CVar gotName dep) (CVar neoName dep)) dep 751 | let gotStmt = concat ["var ", gotName, " = ", mapName, ".has(", keyName, ") ? ", mapName, ".get(", keyName, ") : ", mapName, ".get(-1n);"] 752 | let neoStmt = concat ["var ", neoName, " = ", mapName, "; ", mapName, ".set(", keyName, ", ", valName, ");"] 753 | return $ concat [mapStmt, keyStmt, valStmt, gotStmt, neoStmt, retStmt] 754 | go (CRef nam) = 755 | set var $ nameToJS nam 756 | go (CHol nam) = 757 | set var $ "null" 758 | go (CLet (nam,typ) val bod) = do 759 | let uid = nameToJS nam ++ "$" ++ show dep 760 | valStmt <- ctToJS False uid val dep 761 | bodStmt <- ctToJS tail var (bod (CVar uid dep)) (dep + 1) 762 | return $ concat [valStmt, bodStmt] 763 | go (CNum val) = 764 | set var $ show val ++ "n" 765 | go (CFlt val) = 766 | set var $ show val 767 | 768 | go (COp2 typ opr fst snd) = do 769 | let opr' = operToJS opr 770 | fstName <- fresh 771 | sndName <- fresh 772 | fstStmt <- ctToJS False fstName fst dep 773 | sndStmt <- ctToJS False sndName snd dep 774 | 775 | 776 | let retExpr = case typ of 777 | CF64 -> concat [fstName, " ", opr', " ", sndName] 778 | CU64 -> concat ["BigInt.asUintN(64, ", fstName, " ", opr', " ", sndName, ")"] 779 | _ -> error ("Invalid type for binary operation: " ++ showCT typ dep) 780 | 781 | retStmt <- set var retExpr 782 | return $ concat [fstStmt, sndStmt, retStmt] 783 | go (CLog msg nxt) = do 784 | msgName <- fresh 785 | msgStmt <- ctToJS False msgName msg dep 786 | nxtName <- fresh 787 | nxtStmt <- ctToJS tail nxtName nxt dep 788 | retStmt <- set var $ concat ["(console.log(LIST_TO_JSTR(", msgName, ")), ", nxtName, ")"] 789 | return $ concat [msgStmt, nxtStmt, retStmt] 790 | go (CVar nam _) = 791 | set var nam 792 | go (CTxt txt) = 793 | set var $ "JSTR_TO_LIST(`" ++ (concatMap (\c -> if c == '`' then "\\`" else [c]) txt) ++ "`)" 794 | go (CLst lst) = 795 | let cons = \x acc -> CCon "Cons" [("head", x), ("tail", acc)] 796 | nil = CCon "Nil" [] 797 | in ctToJS False var (foldr cons nil lst) dep 798 | go (CNat val) = 799 | let succ = \x -> CCon "Succ" [("pred", x)] 800 | zero = CCon "Zero" [] 801 | in ctToJS False var (foldr (\_ acc -> succ acc) zero [1..val]) dep 802 | 803 | prelude :: String 804 | prelude = unlines [ 805 | "import { readFileSync } from 'fs';", 806 | "import { execSync } from 'child_process';", 807 | "", 808 | "function LIST_TO_JSTR(list) {", 809 | " try {", 810 | " let result = '';", 811 | " let current = list;", 812 | " while (current.$ === 'Cons') {", 813 | " result += String.fromCodePoint(Number(current.head));", 814 | " current = current.tail;", 815 | " }", 816 | " if (current.$ === 'Nil') {", 817 | " return result;", 818 | " }", 819 | " } catch (e) {}", 820 | " return list;", 821 | "}", 822 | "", 823 | "function JSTR_TO_LIST(str) {", 824 | " let list = {$: 'Nil'};", 825 | " for (let i = str.length - 1; i >= 0; i--) {", 826 | " list = {$: 'Cons', head: BigInt(str.charCodeAt(i)), tail: list};", 827 | " }", 828 | " return list;", 829 | "}", 830 | "", 831 | "function LIST_TO_JARRAY(list, decode) {", 832 | " try {", 833 | " let result = [];", 834 | " let current = list;", 835 | " while (current.$ === 'Cons') {", 836 | " result += decode(current.head);", 837 | " current = current.tail;", 838 | " }", 839 | " if (current.$ === 'Nil') {", 840 | " return result;", 841 | " }", 842 | " } catch (e) {}", 843 | " return list;", 844 | "}", 845 | "", 846 | "function JARRAY_TO_LIST(inp, encode) {", 847 | " let out = {$: 'Nil'};", 848 | " for (let i = inp.length - 1; i >= 0; i--) {", 849 | " out = {$: 'Cons', head: encode(inp[i]), tail: out};", 850 | " }", 851 | " return out;", 852 | "}", 853 | "", 854 | "let MEMORY = new Map();", 855 | "function SWAP(key, val) {", 856 | " var old = MEMORY.get(key) || 0n;", 857 | " MEMORY.set(key, val);", 858 | " return old;", 859 | "}" 860 | ] 861 | 862 | generateJS :: CTBook -> (String, CT) -> String 863 | generateJS book (name, ct) = ST.evalState (fnToJS book name ct) 0 ++ "\n\n" 864 | 865 | defToCT :: Book -> (String, Term) -> (String, CT) 866 | defToCT book (name, term) = 867 | case envRun (doAnnotate term) book of 868 | Done _ (term, fill) -> (name, termToCT book fill term Nothing 0) 869 | Fail _ -> error $ "COMPILATION_ERROR: " ++ name ++ " is ill-typed" 870 | 871 | compileJS :: Book -> String 872 | compileJS book = 873 | let ctDefs0 = flip map (topoSortBook book) (defToCT book) 874 | ctDefs1 = flip map ctDefs0 $ \ (nm,ct) -> (nm, removeUnreachables ct) 875 | ctDefs2 = flip map ctDefs1 $ \ (nm,ct) -> (nm, inline (M.fromList ctDefs1) ct) 876 | ctDefs3 = flip map ctDefs2 $ \ (nm,ct) -> (nm, liftLambdas ct 0) 877 | jsFns = concatMap (generateJS (M.fromList ctDefs3)) ctDefs3 878 | exports = "export { " ++ intercalate ", " (getFunctionNames jsFns) ++ " }" 879 | debug = trace ("\nCompiled CTs:\n" ++ unlines (map (\(n,c) -> "- " ++ n ++ ":\n" ++ showCT c 0) ctDefs3)) 880 | in prelude ++ "\n\n" ++ jsFns ++ "\n" ++ exports 881 | 882 | -- Utils 883 | -- ----- 884 | 885 | bindCT :: CT -> [(String,CT)] -> CT 886 | bindCT CNul ctx = CNul 887 | bindCT CSet ctx = CSet 888 | bindCT CU64 ctx = CU64 889 | bindCT CF64 ctx = CF64 890 | bindCT (CADT cts) ctx = 891 | let cts' = map (\ (n,fs) -> (n, map (\ (fn,ft) -> (fn, bindCT ft ctx)) fs)) cts in 892 | CADT cts' 893 | bindCT (CMap typ) ctx = 894 | CMap (bindCT typ ctx) 895 | bindCT (CAll (nam,inp) bod) ctx = 896 | let inp' = bindCT inp ctx in 897 | let bod' = \x -> bindCT (bod (CVar nam 0)) ((nam, x) : ctx) in 898 | CAll (nam,inp') bod' 899 | bindCT (CLam (nam,inp) bod) ctx = 900 | let inp' = bindCT inp ctx in 901 | let bod' = \x -> bindCT (bod (CVar nam 0)) ((nam, x) : ctx) in 902 | CLam (nam,inp') bod' 903 | bindCT (CApp fun arg) ctx = 904 | let fun' = bindCT fun ctx in 905 | let arg' = bindCT arg ctx in 906 | CApp fun' arg' 907 | bindCT (CCon nam arg) ctx = 908 | let arg' = map (\(f, x) -> (f, bindCT x ctx)) arg in 909 | CCon nam arg' 910 | bindCT (CMat val cse) ctx = 911 | let val' = bindCT val ctx in 912 | let cse' = map (\(cn,fs,cb) -> (cn, fs, bindCT cb ctx)) cse in 913 | CMat val' cse' 914 | bindCT (CRef nam) ctx = 915 | case lookup nam ctx of 916 | Just x -> x 917 | Nothing -> CRef nam 918 | bindCT (CHol nam) ctx = 919 | CHol nam 920 | bindCT (CLet (nam,typ) val bod) ctx = 921 | let typ' = bindCT typ ctx in 922 | let val' = bindCT val ctx in 923 | let bod' = \x -> bindCT (bod (CVar nam 0)) ((nam, x) : ctx) in 924 | CLet (nam,typ') val' bod' 925 | bindCT (CNum val) ctx = CNum val 926 | bindCT (CFlt val) ctx = CFlt val 927 | bindCT (COp2 typ opr fst snd) ctx = 928 | let fst' = bindCT fst ctx in 929 | let snd' = bindCT snd ctx in 930 | let typ' = bindCT typ ctx in 931 | COp2 typ' opr fst' snd' 932 | bindCT (CSwi val zer suc) ctx = 933 | let val' = bindCT val ctx in 934 | let zer' = bindCT zer ctx in 935 | let suc' = bindCT suc ctx in 936 | CSwi val' zer' suc' 937 | bindCT (CKVs kvs def) ctx = 938 | let kvs' = IM.map (\v -> bindCT v ctx) kvs in 939 | let def' = bindCT def ctx in 940 | CKVs kvs' def' 941 | bindCT (CGet got nam map key bod) ctx = 942 | let map' = bindCT map ctx in 943 | let key' = bindCT key ctx in 944 | let bod' = \x y -> bindCT (bod (CVar got 0) (CVar nam 0)) ((nam, y) : (got, x) : ctx) in 945 | CGet got nam map' key' bod' 946 | bindCT (CPut got nam map key val bod) ctx = 947 | let map' = bindCT map ctx in 948 | let key' = bindCT key ctx in 949 | let val' = bindCT val ctx in 950 | let bod' = \x y -> bindCT (bod (CVar got 0) (CVar nam 0)) ((nam, y) : (got, x) : ctx) in 951 | CPut got nam map' key' val' bod' 952 | bindCT (CLog msg nxt) ctx = 953 | let msg' = bindCT msg ctx in 954 | let nxt' = bindCT nxt ctx in 955 | CLog msg' nxt' 956 | bindCT (CVar nam idx) ctx = 957 | case lookup nam ctx of 958 | Just x -> x 959 | Nothing -> CVar nam idx 960 | bindCT (CTxt txt) ctx = CTxt txt 961 | bindCT (CLst lst) ctx = 962 | let lst' = map (\x -> bindCT x ctx) lst in 963 | CLst lst' 964 | bindCT (CNat val) ctx = CNat val 965 | 966 | rnCT :: CT -> [(String,CT)] -> CT 967 | rnCT CNul ctx = CNul 968 | rnCT CSet ctx = CSet 969 | rnCT CU64 ctx = CU64 970 | rnCT CF64 ctx = CF64 971 | rnCT (CADT cts) ctx = 972 | let cts' = map (\ (n,fs) -> (n, map (\ (fn,ft) -> (fn, rnCT ft ctx)) fs)) cts in 973 | CADT cts' 974 | rnCT (CMap typ) ctx = 975 | let typ' = rnCT typ ctx 976 | in (CMap typ') 977 | rnCT (CAll (nam,inp) bod) ctx = 978 | let nam' = "x" ++ show (length ctx) in 979 | let inp' = rnCT inp ctx in 980 | let bod' = \x -> rnCT (bod (CVar nam' 0)) ((nam', x) : ctx) in 981 | CAll (nam',inp') bod' 982 | rnCT (CLam (nam,inp) bod) ctx = 983 | let nam' = "x" ++ show (length ctx) in 984 | let inp' = rnCT inp ctx in 985 | let bod' = \x -> rnCT (bod (CVar nam' 0)) ((nam', x) : ctx) in 986 | CLam (nam',inp') bod' 987 | rnCT (CApp fun arg) ctx = 988 | let fun' = rnCT fun ctx in 989 | let arg' = rnCT arg ctx in 990 | CApp fun' arg' 991 | rnCT (CCon nam arg) ctx = 992 | let arg' = map (\(f, x) -> (f, rnCT x ctx)) arg in 993 | CCon nam arg' 994 | rnCT (CMat val cse) ctx = 995 | let val' = rnCT val ctx in 996 | let cse' = map (\(cn,fs,cb) -> (cn, fs, rnCT cb ctx)) cse in 997 | CMat val' cse' 998 | rnCT (CRef nam) ctx = 999 | case lookup nam ctx of 1000 | Just x -> x 1001 | Nothing -> CRef nam 1002 | rnCT (CLet (nam,typ) val bod) ctx = 1003 | let typ' = rnCT typ ctx in 1004 | let val' = rnCT val ctx in 1005 | let bod' = \x -> rnCT (bod (CVar nam 0)) ((nam, x) : ctx) in 1006 | CLet (nam,typ') val' bod' 1007 | rnCT (CNum val) ctx = CNum val 1008 | rnCT (CFlt val) ctx = CFlt val 1009 | rnCT (COp2 typ opr fst snd) ctx = 1010 | let fst' = rnCT fst ctx in 1011 | let snd' = rnCT snd ctx in 1012 | let typ' = rnCT typ ctx in 1013 | COp2 typ' opr fst' snd' 1014 | rnCT (CSwi val zer suc) ctx = 1015 | let val' = rnCT val ctx in 1016 | let zer' = rnCT zer ctx in 1017 | let suc' = rnCT suc ctx in 1018 | CSwi val' zer' suc' 1019 | rnCT (CKVs kvs def) ctx = 1020 | let kvs' = IM.map (\v -> rnCT v ctx) kvs in 1021 | let def' = rnCT def ctx in 1022 | CKVs kvs' def' 1023 | rnCT (CGet got nam map key bod) ctx = 1024 | let map' = rnCT map ctx in 1025 | let key' = rnCT key ctx in 1026 | let bod' = \x y -> rnCT (bod (CVar got 0) (CVar nam 0)) ((got, x) : (nam, y) : ctx) in 1027 | CGet got nam map' key' bod' 1028 | rnCT (CPut got nam map key val bod) ctx = 1029 | let map' = rnCT map ctx in 1030 | let key' = rnCT key ctx in 1031 | let val' = rnCT val ctx in 1032 | let bod' = \x y -> rnCT (bod (CVar got 0) (CVar nam 0)) ((got, x) : (nam, y) : ctx) in 1033 | CPut got nam map' key' val' bod' 1034 | rnCT (CLog msg nxt) ctx = 1035 | let msg' = rnCT msg ctx in 1036 | let nxt' = rnCT nxt ctx in 1037 | CLog msg' nxt' 1038 | rnCT (CVar nam idx) ctx = 1039 | case lookup nam ctx of 1040 | Just x -> x 1041 | Nothing -> CVar nam idx 1042 | rnCT (CTxt txt) ctx = CTxt txt 1043 | rnCT (CLst lst) ctx = 1044 | let lst' = map (\x -> rnCT x ctx) lst in 1045 | CLst lst' 1046 | rnCT (CNat val) ctx = CNat val 1047 | 1048 | getAppChain :: CT -> (CT, [CT]) 1049 | getAppChain (CApp fun arg) = 1050 | let (f, args) = getAppChain fun 1051 | in (f, args ++ [arg]) 1052 | getAppChain term = (term, []) 1053 | 1054 | isNul :: CT -> Bool 1055 | isNul CNul = True 1056 | isNul _ = False 1057 | 1058 | getFunctionNames :: String -> [String] 1059 | getFunctionNames js = 1060 | [ name | line <- lines js, 1061 | "const " `isPrefixOf` line, 1062 | let parts = words line, 1063 | length parts >= 2, 1064 | let name = head $ words $ parts !! 1, 1065 | not $ "$" `isSuffixOf` name -- Skip internal functions ending with $ 1066 | ] 1067 | 1068 | -- Stringification 1069 | -- --------------- 1070 | 1071 | -- TODO: implement a showCT :: CT -> String function 1072 | showCT :: CT -> Int -> String 1073 | showCT CNul dep = "*" 1074 | showCT CSet dep = "Set" 1075 | showCT CU64 dep = "U64" 1076 | showCT CF64 dep = "F64" 1077 | showCT (CADT cts) dep = "data{" ++ concatMap (\ (n,fs) -> "#" ++ n ++ " " ++ concatMap (\ (fn,ft) -> fn ++ ":" ++ showCT ft dep ++ " ") fs) cts ++ "}" 1078 | showCT (CMap typ) dep = "(Map " ++ showCT typ dep ++ ")" 1079 | showCT (CLam (nam,inp) bod) dep = "λ(" ++ nam ++ ": " ++ showCT inp dep ++ "). " ++ showCT (bod (CVar nam dep)) (dep+1) 1080 | showCT (CAll (nam,inp) bod) dep = "∀(" ++ nam ++ ": " ++ showCT inp dep ++ "). " ++ showCT (bod (CVar nam dep)) (dep+1) 1081 | showCT (CApp fun arg) dep = "(" ++ showCT fun dep ++ " " ++ showCT arg dep ++ ")" 1082 | showCT (CCon nam fields) dep = "#" ++ nam ++ "{" ++ concatMap (\ (f,v) -> f ++ ":" ++ showCT v dep ++ " ") fields ++ "}" 1083 | showCT (CMat val cses) dep = "match " ++ showCT val dep ++ " {" ++ concatMap (\(cn,fs,cb) -> "#" ++ cn ++ ":" ++ showCT cb dep ++ " ") cses ++ "}" 1084 | showCT (CRef nam) dep = nam 1085 | showCT (CHol nam) dep = nam 1086 | showCT (CLet (nam,typ) val bod) dep = "let " ++ nam ++ " : " ++ showCT typ dep ++ " = " ++ showCT val dep ++ "; " ++ showCT (bod (CVar nam dep)) (dep+1) 1087 | showCT (CNum val) dep = show val 1088 | showCT (CFlt val) dep = show val 1089 | showCT (COp2 typ opr fst snd) dep = "( " ++ showCT fst dep ++ " " ++ showCT snd dep ++ ")" 1090 | showCT (CSwi val zer suc) dep = "switch " ++ showCT val dep ++ " {0:" ++ showCT zer dep ++ " _: " ++ showCT suc dep ++ "}" 1091 | showCT (CKVs kvs def) dep = "{" ++ unwords (map (\(k,v) -> show k ++ ":" ++ showCT v dep) (IM.toList kvs)) ++ " | " ++ showCT def dep ++ "}" 1092 | showCT (CGet g n m k b) dep = "get " ++ g ++ " = " ++ n ++ "@" ++ showCT m dep ++ "[" ++ showCT k dep ++ "] " ++ showCT (b (CVar g dep) (CVar n dep)) (dep+2) 1093 | showCT (CPut g n m k v b) dep = "put " ++ g ++ " = " ++ n ++ "@" ++ showCT m dep ++ "[" ++ showCT k dep ++ "] := " ++ showCT v dep ++ " " ++ showCT (b (CVar g dep) (CVar n dep)) (dep+2) 1094 | showCT (CLog msg nxt) dep = "log(" ++ showCT msg dep ++ "," ++ showCT nxt dep ++ ")" 1095 | showCT (CVar nam dep) _ = nam ++ "^" ++ show dep 1096 | showCT (CTxt txt) dep = show txt 1097 | showCT (CLst lst) dep = "[" ++ unwords (map (\x -> showCT x dep) lst) ++ "]" 1098 | showCT (CNat val) dep = show val 1099 | -------------------------------------------------------------------------------- /src/Kind/Env.hs: -------------------------------------------------------------------------------- 1 | module Kind.Env where 2 | 3 | import Kind.Type 4 | 5 | import qualified Data.IntMap.Strict as IM 6 | import qualified Data.Map.Strict as M 7 | 8 | -- Environment 9 | -- ----------- 10 | 11 | envBind :: Env a -> (a -> Env b) -> Env b 12 | envBind (Env a) b = Env $ \state -> case a state of 13 | Done state' value -> let Env b' = b value in b' state' 14 | Fail state' -> Fail state' 15 | 16 | envPure :: a -> Env a 17 | envPure a = Env $ \state -> Done state a 18 | 19 | envFail :: Env a 20 | envFail = Env $ \state -> Fail state 21 | 22 | envRun :: Env a -> Book -> Res a 23 | envRun (Env chk) book = chk (State book IM.empty [] []) 24 | 25 | envLog :: Info -> Env Int 26 | envLog log = Env $ \ (State book fill susp logs) -> Done (State book fill susp (log : logs)) 1 27 | 28 | envSnapshot :: Env State 29 | envSnapshot = Env $ \state -> Done state state 30 | 31 | envRewind :: State -> Env Int 32 | envRewind state = Env $ \_ -> Done state 0 33 | 34 | envSusp :: Check -> Env () 35 | envSusp chk = Env $ \ (State book fill susp logs) -> Done (State book fill (susp ++ [chk]) logs) () 36 | 37 | envFill :: Int -> Term -> Env () 38 | envFill k v = Env $ \ (State book fill susp logs) -> Done (State book (IM.insert k v fill) susp logs) () 39 | 40 | envGetFill :: Env Fill 41 | envGetFill = Env $ \ (State book fill susp logs) -> Done (State book fill susp logs) fill 42 | 43 | envGetBook :: Env Book 44 | envGetBook = Env $ \ (State book fill susp logs) -> Done (State book fill susp logs) book 45 | 46 | envTakeSusp :: Env [Check] 47 | envTakeSusp = Env $ \ (State book fill susp logs) -> Done (State book fill [] logs) susp 48 | 49 | instance Functor Env where 50 | fmap f (Env chk) = Env $ \logs -> case chk logs of 51 | Done logs' a -> Done logs' (f a) 52 | Fail logs' -> Fail logs' 53 | 54 | instance Applicative Env where 55 | pure = envPure 56 | (Env chkF) <*> (Env chkA) = Env $ \logs -> case chkF logs of 57 | Done logs' f -> case chkA logs' of 58 | Done logs'' a -> Done logs'' (f a) 59 | Fail logs'' -> Fail logs'' 60 | Fail logs' -> Fail logs' 61 | 62 | instance Monad Env where 63 | (Env a) >>= b = envBind (Env a) b 64 | -------------------------------------------------------------------------------- /src/Kind/Equal.hs: -------------------------------------------------------------------------------- 1 | -- //./Type.hs// 2 | 3 | module Kind.Equal where 4 | 5 | import Control.Monad (zipWithM) 6 | 7 | import Debug.Trace 8 | 9 | import Kind.Type 10 | import Kind.Env 11 | import Kind.Reduce 12 | import Kind.Show 13 | 14 | import qualified Data.Map.Strict as M 15 | import qualified Data.IntMap.Strict as IM 16 | 17 | -- Equality 18 | -- -------- 19 | 20 | -- Checks if two terms are equal, after reduction steps 21 | equal :: Term -> Term -> Int -> Env Bool 22 | equal a b dep = debug ("== " ++ showTermGo False a dep ++ "\n.. " ++ showTermGo False b dep) $ do 23 | -- If both terms are identical, return true 24 | state <- envSnapshot 25 | is_id <- identical a b dep 26 | if is_id then do 27 | envPure True 28 | -- Otherwise, reduces both terms to wnf 29 | else do 30 | envRewind state 31 | book <- envGetBook 32 | fill <- envGetFill 33 | let aWnf = reduce book fill 2 a 34 | let bWnf = reduce book fill 2 b 35 | -- If both term wnfs are identical, return true 36 | state <- envSnapshot 37 | is_id <- identical aWnf bWnf dep 38 | if is_id then do 39 | envPure True 40 | -- Otherwise, check if they're component-wise equal 41 | else do 42 | envRewind state 43 | similar aWnf bWnf dep 44 | 45 | -- Checks if two terms are already syntactically identical 46 | identical :: Term -> Term -> Int -> Env Bool 47 | identical a b dep = do 48 | fill <- envGetFill 49 | debug ("ID " ++ showTermGo False a dep ++ "\n.. " ++ showTermGo False b dep ++ "\n" ++ (unlines $ map (\(k,v) -> "~" ++ show k ++ " = " ++ showTermGo False v dep) $ IM.toList fill)) $ go a b dep 50 | where 51 | go (All aNam aInp aBod) (All bNam bInp bBod) dep = do 52 | iInp <- identical aInp bInp dep 53 | iBod <- identical (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 54 | return (iInp && iBod) 55 | go (Lam aNam aBod) (Lam bNam bBod) dep = 56 | identical (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 57 | go (App aFun aArg) (App bFun bArg) dep = do 58 | iFun <- identical aFun bFun dep 59 | iArg <- identical aArg bArg dep 60 | return (iFun && iArg) 61 | go (Slf aNam aTyp aBod) (Slf bNam bTyp bBod) dep = 62 | identical aTyp bTyp dep 63 | go (Ins aVal) b dep = 64 | identical aVal b dep 65 | go a (Ins bVal) dep = 66 | identical a bVal dep 67 | go (ADT aScp aCts aTyp) (ADT bScp bCts bTyp) dep = do 68 | identical aTyp bTyp dep 69 | go (Con aNam aArg) (Con bNam bArg) dep = do 70 | if aNam == bNam && length aArg == length bArg 71 | then and <$> zipWithM (\(_, aVal) (_, bVal) -> identical aVal bVal dep) aArg bArg 72 | else return False 73 | go (Mat aCse) (Mat bCse) dep = do 74 | if length aCse == length bCse 75 | then and <$> zipWithM goCse aCse bCse 76 | else return False 77 | go (Let aNam aVal aBod) b dep = 78 | identical (aBod aVal) b dep 79 | go a (Let bNam bVal bBod) dep = 80 | identical a (bBod bVal) dep 81 | go (Use aNam aVal aBod) b dep = 82 | identical (aBod aVal) b dep 83 | go a (Use bNam bVal bBod) dep = 84 | identical a (bBod bVal) dep 85 | go Set Set dep = 86 | return True 87 | go (Ann chk aVal aTyp) b dep = 88 | identical aVal b dep 89 | go a (Ann chk bVal bTyp) dep = 90 | identical a bVal dep 91 | go (Met aUid aSpn) b dep = do 92 | fill <- envGetFill 93 | case IM.lookup aUid fill of 94 | Just sol -> identical sol b dep 95 | Nothing -> unify aUid aSpn b dep 96 | go a (Met bUid bSpn) dep = do 97 | fill <- envGetFill 98 | case IM.lookup bUid fill of 99 | Just sol -> identical a sol dep 100 | Nothing -> unify bUid bSpn a dep 101 | go (Log aMsg aNxt) b dep = 102 | identical aNxt b dep 103 | go a (Log bMsg bNxt) dep = 104 | identical a bNxt dep 105 | go (Hol aNam aCtx) b dep = 106 | return True 107 | go a (Hol bNam bCtx) dep = 108 | return True 109 | go U64 U64 dep = 110 | return True 111 | go F64 F64 dep = 112 | return True 113 | go (Num aVal) (Num bVal) dep = 114 | return (aVal == bVal) 115 | go (Flt aVal) (Flt bVal) dep = 116 | return (aVal == bVal) 117 | go (Op2 aOpr aFst aSnd) (Op2 bOpr bFst bSnd) dep = do 118 | iFst <- identical aFst bFst dep 119 | iSnd <- identical aSnd bSnd dep 120 | return (iFst && iSnd) 121 | go (Swi aZer aSuc) (Swi bZer bSuc) dep = do 122 | iZer <- identical aZer bZer dep 123 | iSuc <- identical aSuc bSuc dep 124 | return (iZer && iSuc) 125 | go (Map aTyp) (Map bTyp) dep = 126 | identical aTyp bTyp dep 127 | go (KVs aMap aDef) (KVs bMap bDef) dep = do 128 | iDef <- identical aDef bDef dep 129 | iMap <- flip mapM (IM.toList aMap) $ \ (aKey,aVal) -> 130 | case IM.lookup aKey bMap of 131 | Just bVal -> identical aVal bVal dep 132 | Nothing -> return False 133 | return (iDef && and iMap && IM.size aMap == IM.size bMap) 134 | go (Get aGot aNam aMap aKey aBod) (Get bGot bNam bMap bKey bBod) dep = do 135 | iMap <- identical aMap bMap dep 136 | iKey <- identical aKey bKey dep 137 | iBod <- identical (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2) 138 | return (iMap && iKey && iBod) 139 | go (Put aGot aNam aMap aKey aVal aBod) (Put bGot bNam bMap bKey bVal bBod) dep = do 140 | iMap <- identical aMap bMap dep 141 | iKey <- identical aKey bKey dep 142 | iVal <- identical aVal bVal dep 143 | iBod <- identical (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2) 144 | return (iMap && iKey && iVal && iBod) 145 | go (Txt aTxt) (Txt bTxt) dep = 146 | return (aTxt == bTxt) 147 | go (Lst aLst) (Lst bLst) dep = 148 | if length aLst == length bLst 149 | then and <$> zipWithM (\a b -> identical a b dep) aLst bLst 150 | else return False 151 | go (Nat aVal) (Nat bVal) dep = 152 | return (aVal == bVal) 153 | go (Src aSrc aVal) b dep = 154 | identical aVal b dep 155 | go a (Src bSrc bVal) dep = 156 | identical a bVal dep 157 | go (Ref aNam) (Ref bNam) dep = 158 | return (aNam == bNam) 159 | go (Var aNam aIdx) (Var bNam bIdx) dep = 160 | return (aIdx == bIdx) 161 | go a b dep = 162 | return False 163 | 164 | goCtr (Ctr aCNm aTele) (Ctr bCNm bTele) = do 165 | if aCNm == bCNm 166 | then goTele aTele bTele dep 167 | else return False 168 | 169 | goCse (aCNam, aCBod) (bCNam, bCBod) = do 170 | if aCNam == bCNam 171 | then identical aCBod bCBod dep 172 | else return False 173 | 174 | goTele :: Tele -> Tele -> Int -> Env Bool 175 | goTele (TRet aTerm) (TRet bTerm) dep = identical aTerm bTerm dep 176 | goTele (TExt aNam aTyp aBod) (TExt bNam bTyp bBod) dep = do 177 | iTyp <- identical aTyp bTyp dep 178 | iBod <- goTele (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 179 | return (iTyp && iBod) 180 | goTele _ _ _ = return False 181 | 182 | -- Checks if two terms are component-wise equal 183 | similar :: Term -> Term -> Int -> Env Bool 184 | similar a b dep = go a b dep where 185 | go (All aNam aInp aBod) (All bNam bInp bBod) dep = do 186 | eInp <- equal aInp bInp dep 187 | eBod <- equal (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 188 | return (eInp && eBod) 189 | go (Lam aNam aBod) (Lam bNam bBod) dep = 190 | equal (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 191 | go (App aFun aArg) (App bFun bArg) dep = do 192 | eFun <- similar aFun bFun dep 193 | eArg <- equal aArg bArg dep 194 | return (eFun && eArg) 195 | go (Slf aNam aTyp aBod) (Slf bNam bTyp bBod) dep = do 196 | book <- envGetBook 197 | similar (reduce book IM.empty 0 aTyp) (reduce book IM.empty 0 bTyp) dep 198 | go (ADT aScp aCts aTyp) (ADT bScp bCts bTyp) dep = do 199 | book <- envGetBook 200 | similar (reduce book IM.empty 0 aTyp) (reduce book IM.empty 0 bTyp) dep 201 | -- eSlf <- zipWithM (\ax bx -> equal ax bx dep) aScp bScp 202 | -- if and eSlf && length aCts == length bCts 203 | -- then and <$> zipWithM goCtr aCts bCts 204 | -- else return False 205 | go (Con aNam aArg) (Con bNam bArg) dep = do 206 | if aNam == bNam && length aArg == length bArg 207 | then and <$> zipWithM (\(_, aVal) (_, bVal) -> equal aVal bVal dep) aArg bArg 208 | else return False 209 | go (Mat aCse) (Mat bCse) dep = do 210 | if length aCse == length bCse 211 | then and <$> zipWithM goCse aCse bCse 212 | else return False 213 | go (Op2 aOpr aFst aSnd) (Op2 bOpr bFst bSnd) dep = do 214 | eFst <- equal aFst bFst dep 215 | eSnd <- equal aSnd bSnd dep 216 | return (eFst && eSnd) 217 | go (Swi aZer aSuc) (Swi bZer bSuc) dep = do 218 | eZer <- equal aZer bZer dep 219 | eSuc <- equal aSuc bSuc dep 220 | return (eZer && eSuc) 221 | go (Map aTyp) (Map bTyp) dep = do 222 | equal aTyp bTyp dep 223 | go (KVs aMap aDef) (KVs bMap bDef) dep = do 224 | eDef <- equal aDef bDef dep 225 | eMap <- flip mapM (IM.toList aMap) $ \ (aKey,aVal) -> 226 | case IM.lookup aKey bMap of 227 | Just bVal -> equal aVal bVal dep 228 | Nothing -> return False 229 | return (eDef && and eMap && IM.size aMap == IM.size bMap) 230 | go (Get aGot aNam aMap aKey aBod) (Get bGot bNam bMap bKey bBod) dep = do 231 | eMap <- equal aMap bMap dep 232 | eKey <- equal aKey bKey dep 233 | eBod <- equal (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2) 234 | return (eMap && eKey && eBod) 235 | go (Put aGot aNam aMap aKey aVal aBod) (Put bGot bNam bMap bKey bVal bBod) dep = do 236 | eMap <- equal aMap bMap dep 237 | eKey <- equal aKey bKey dep 238 | eVal <- equal aVal bVal dep 239 | eBod <- equal (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2) 240 | return (eMap && eKey && eVal && eBod) 241 | go a b dep = identical a b dep 242 | 243 | goCtr (Ctr aCNm aTele) (Ctr bCNm bTele) = do 244 | if aCNm == bCNm 245 | then goTele aTele bTele dep 246 | else return False 247 | 248 | goCse (aCNam, aCBod) (bCNam, bCBod) = do 249 | if aCNam == bCNam 250 | then equal aCBod bCBod dep 251 | else return False 252 | 253 | goTele :: Tele -> Tele -> Int -> Env Bool 254 | goTele (TRet aTerm) (TRet bTerm) dep = equal aTerm bTerm dep 255 | goTele (TExt aNam aTyp aBod) (TExt bNam bTyp bBod) dep = do 256 | eTyp <- equal aTyp bTyp dep 257 | eBod <- goTele (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 258 | return (eTyp && eBod) 259 | goTele _ _ _ = return False 260 | 261 | -- Unification 262 | -- ----------- 263 | 264 | -- If possible, solves a (?X x y z ...) = K problem, generating a subst. 265 | unify :: Int -> [Term] -> Term -> Int -> Env Bool 266 | unify uid spn b dep = do 267 | book <- envGetBook 268 | fill <- envGetFill 269 | 270 | -- is this hole not already solved? 271 | let solved = IM.member uid fill 272 | 273 | -- does the spine satisfies conditions? 274 | let solvable = valid fill spn [] 275 | 276 | -- is the solution not recursive? 277 | let no_loops = not $ occur book fill uid b dep 278 | 279 | debug ("unify: " ++ show uid ++ " " ++ showTermGo False b dep ++ " | " ++ show solved ++ " " ++ show solvable ++ " " ++ show no_loops) $ do 280 | if not solved && solvable && no_loops then do 281 | let solution = solve book fill uid spn b 282 | debug ("solve: " ++ show uid ++ " " ++ showTermGo False solution dep ++ " | spn: " ++ show (map (\t -> showTermGo False t dep) spn)) $ envFill uid solution 283 | return True 284 | 285 | -- Otherwise, return true iff both are identical metavars 286 | else case b of 287 | (Src bSrc bVal) -> unify uid spn bVal dep 288 | (Met bUid bSpn) -> return $ uid == bUid 289 | other -> return $ False 290 | 291 | -- Checks if a problem is solveable by pattern unification. 292 | valid :: Fill -> [Term] -> [Int] -> Bool 293 | valid fill [] vars = True 294 | valid fill (x : spn) vars = case reduce M.empty fill 0 x of 295 | (Var nam idx) -> not (elem idx vars) && valid fill spn (idx : vars) 296 | otherwise -> False 297 | 298 | -- Generates the solution, adding binders and renaming variables. 299 | solve :: Book -> Fill -> Int -> [Term] -> Term -> Term 300 | solve book fill uid [] b = b 301 | solve book fill uid (x : spn) b = case reduce book fill 0 x of 302 | (Var nam idx) -> Lam nam $ \x -> subst idx x (solve book fill uid spn b) 303 | otherwise -> error "unreachable" 304 | 305 | -- Checks if a metavar uid occurs recursively inside a term 306 | occur :: Book -> Fill -> Int -> Term -> Int -> Bool 307 | occur book fill uid term dep = go term dep where 308 | go (All nam inp bod) dep = 309 | let o_inp = go inp dep 310 | o_bod = go (bod (Var nam dep)) (dep + 1) 311 | in o_inp || o_bod 312 | go (Lam nam bod) dep = 313 | let o_bod = go (bod (Var nam dep)) (dep + 1) 314 | in o_bod 315 | go (App fun arg) dep = 316 | let o_fun = go fun dep 317 | o_arg = go arg dep 318 | in o_fun || o_arg 319 | go (Ann chk val typ) dep = 320 | let o_val = go val dep 321 | o_typ = go typ dep 322 | in o_val || o_typ 323 | go (Slf nam typ bod) dep = 324 | let o_typ = go typ dep 325 | o_bod = go (bod (Var nam dep)) (dep + 1) 326 | in o_typ || o_bod 327 | go (Ins val) dep = 328 | let o_val = go val dep 329 | in o_val 330 | go (ADT scp cts typ) dep = 331 | let o_scp = any (\x -> go x dep) scp 332 | o_cts = any (\(Ctr _ tele) -> goTele tele dep) cts 333 | a_typ = go typ dep 334 | in o_scp || o_cts || a_typ 335 | go (Con nam arg) dep = 336 | any (\(_, x) -> go x dep) arg 337 | go (Mat cse) dep = 338 | any (\ (_, cbod) -> go cbod dep) cse 339 | go (Let nam val bod) dep = 340 | let o_val = go val dep 341 | o_bod = go (bod (Var nam dep)) (dep + 1) 342 | in o_val || o_bod 343 | go (Use nam val bod) dep = 344 | let o_val = go val dep 345 | o_bod = go (bod (Var nam dep)) (dep + 1) 346 | in o_val || o_bod 347 | go (Log msg nxt) dep = 348 | let o_msg = go msg dep 349 | o_nxt = go nxt dep 350 | in o_msg || o_nxt 351 | go (Hol nam ctx) dep = 352 | False 353 | go (Op2 opr fst snd) dep = 354 | let o_fst = go fst dep 355 | o_snd = go snd dep 356 | in o_fst || o_snd 357 | go (Swi zer suc) dep = 358 | let o_zer = go zer dep 359 | o_suc = go suc dep 360 | in o_zer || o_suc 361 | go (Map typ) dep = 362 | let o_typ = go typ dep 363 | in o_typ 364 | go (KVs map def) dep = 365 | let o_map = any (\(_, x) -> go x dep) (IM.toList map) 366 | o_def = go def dep 367 | in o_map || o_def 368 | go (Get got nam map key bod) dep = 369 | let o_map = go map dep 370 | o_key = go key dep 371 | o_bod = go (bod (Var got dep) (Var nam dep)) (dep + 2) 372 | in o_map || o_key || o_bod 373 | go (Put got nam map key val bod) dep = 374 | let o_map = go map dep 375 | o_key = go key dep 376 | o_val = go val dep 377 | o_bod = go (bod (Var got dep) (Var nam dep)) (dep + 2) 378 | in o_map || o_key || o_val || o_bod 379 | go (Src src val) dep = 380 | let o_val = go val dep 381 | in o_val 382 | go (Met bUid bSpn) dep = 383 | case reduce book fill 2 (Met bUid bSpn) of 384 | Met bUid bSpn -> uid == bUid 385 | term -> go term dep 386 | go _ dep = 387 | False 388 | 389 | goTele :: Tele -> Int -> Bool 390 | goTele (TRet term) dep = go term dep 391 | goTele (TExt nam typ bod) dep = 392 | let o_typ = go typ dep 393 | o_bod = goTele (bod (Var nam dep)) (dep + 1) 394 | in o_typ || o_bod 395 | 396 | -- Substitution 397 | -- ------------ 398 | 399 | -- This is the ugly / slow part of Kind. See: https://gist.github.com/VictorTaelin/48eed41a8eca3500721c06dfec72d48c 400 | 401 | -- Behaves like 'identical', except it is pure and returns a Bool. 402 | same :: Term -> Term -> Int -> Bool 403 | same (All aNam aInp aBod) (All bNam bInp bBod) dep = 404 | let sInp = same aInp bInp dep 405 | sBod = same (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 406 | in sInp && sBod 407 | same (Lam aNam aBod) (Lam bNam bBod) dep = 408 | let sBod = same (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 409 | in sBod 410 | same (App aFun aArg) (App bFun bArg) dep = 411 | let sFun = same aFun bFun dep 412 | sArg = same aArg bArg dep 413 | in sFun && sArg 414 | same (Slf aNam aTyp aBod) (Slf bNam bTyp bBod) dep = 415 | let sTyp = same aTyp bTyp dep 416 | in sTyp 417 | same (Ins aVal) b dep = 418 | same aVal b dep 419 | same a (Ins bVal) dep = 420 | same a bVal dep 421 | same (ADT aScp aCts aTyp) (ADT bScp bCts bTyp) dep = 422 | -- let sSlf = and $ zipWith (\ax bx -> same ax bx dep) aScp bScp 423 | -- sCts = length aCts == length bCts && and (zipWith (\ a b -> sameCtr a b dep) aCts bCts) 424 | let sTyp = same aTyp bTyp dep 425 | in sTyp 426 | same (Con aNam aArg) (Con bNam bArg) dep = 427 | let sNam = aNam == bNam 428 | sArg = length aArg == length bArg && and (zipWith (\(_, aVal) (_, bVal) -> same aVal bVal dep) aArg bArg) 429 | in sNam && sArg 430 | same (Mat aCse) (Mat bCse) dep = 431 | let sCse = length aCse == length bCse && and (zipWith (\ a b -> sameCse a b dep) aCse bCse) 432 | in sCse 433 | same (Let aNam aVal aBod) b dep = 434 | same (aBod aVal) b dep 435 | same a (Let bNam bVal bBod) dep = 436 | same a (bBod bVal) dep 437 | same (Use aNam aVal aBod) b dep = 438 | same (aBod aVal) b dep 439 | same a (Use bNam bVal bBod) dep = 440 | same a (bBod bVal) dep 441 | same Set Set dep = 442 | True 443 | same (Ann chk aVal aTyp) b dep = 444 | same aVal b dep 445 | same a (Ann chk bVal bTyp) dep = 446 | same a bVal dep 447 | same (Met aUid aSpn) b dep = 448 | False 449 | same a (Met bUid bSpn) dep = 450 | False 451 | -- TODO: Log 452 | same (Log aMsg aNxt) b dep = 453 | same aNxt b dep 454 | same a (Log bMsg bNxt) dep = 455 | same a bNxt dep 456 | same (Hol aNam aCtx) b dep = 457 | True 458 | same a (Hol bNam bCtx) dep = 459 | True 460 | same U64 U64 dep = 461 | True 462 | same F64 F64 dep = 463 | True 464 | same (Num aVal) (Num bVal) dep = 465 | aVal == bVal 466 | same (Flt aVal) (Flt bVal) dep = 467 | aVal == bVal 468 | same (Op2 aOpr aFst aSnd) (Op2 bOpr bFst bSnd) dep = 469 | same aFst bFst dep && same aSnd bSnd dep 470 | same (Swi aZer aSuc) (Swi bZer bSuc) dep = 471 | same aZer bZer dep && same aSuc bSuc dep 472 | same (Map aTyp) (Map bTyp) dep = 473 | same aTyp bTyp dep 474 | same (KVs aMap aDef) (KVs bMap bDef) dep = 475 | let sDef = same aDef bDef dep 476 | sMap = IM.size aMap == IM.size bMap && and (map (\ (aKey,aVal) -> maybe False (\bVal -> same aVal bVal dep) (IM.lookup aKey bMap)) (IM.toList aMap)) 477 | in sDef && sMap 478 | same (Get aGot aNam aMap aKey aBod) (Get bGot bNam bMap bKey bBod) dep = 479 | let sMap = same aMap bMap dep 480 | sKey = same aKey bKey dep 481 | sBod = same (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2) 482 | in sMap && sKey && sBod 483 | same (Put aGot aNam aMap aKey aVal aBod) (Put bGot bNam bMap bKey bVal bBod) dep = 484 | let sMap = same aMap bMap dep 485 | sKey = same aKey bKey dep 486 | sVal = same aVal bVal dep 487 | sBod = same (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2) 488 | in sMap && sKey && sVal && sBod 489 | same (Txt aTxt) (Txt bTxt) dep = 490 | aTxt == bTxt 491 | same (Lst aLst) (Lst bLst) dep = 492 | length aLst == length bLst && and (zipWith (\a b -> same a b dep) aLst bLst) 493 | same (Nat aVal) (Nat bVal) dep = 494 | aVal == bVal 495 | same (Src aSrc aVal) b dep = 496 | same aVal b dep 497 | same a (Src bSrc bVal) dep = 498 | same a bVal dep 499 | same (Ref aNam) (Ref bNam) dep = 500 | aNam == bNam 501 | same (Var aNam aIdx) (Var bNam bIdx) dep = 502 | aIdx == bIdx 503 | same _ _ _ = False 504 | 505 | -- Auxiliary functions 506 | sameCtr :: Ctr -> Ctr -> Int -> Bool 507 | sameCtr (Ctr aCNm aTele) (Ctr bCNm bTele) dep = 508 | if aCNm == bCNm 509 | then sameTele aTele bTele dep 510 | else False 511 | 512 | sameCse :: (String, Term) -> (String, Term) -> Int -> Bool 513 | sameCse (aCNam, aCBod) (bCNam, bCBod) dep = 514 | if aCNam == bCNam 515 | then same aCBod bCBod dep 516 | else False 517 | 518 | sameTele :: Tele -> Tele -> Int -> Bool 519 | sameTele (TRet aTerm) (TRet bTerm) dep = same aTerm bTerm dep 520 | sameTele (TExt aNam aTyp aBod) (TExt bNam bTyp bBod) dep = 521 | let sTyp = same aTyp bTyp dep 522 | sBod = sameTele (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1) 523 | in sTyp && sBod 524 | sameTele _ _ _ = False 525 | 526 | -- Substitutes a Bruijn level variable by a neo value in term. 527 | subst :: Int -> Term -> Term -> Term 528 | subst lvl neo term = go term where 529 | go (All nam inp bod) = All nam (go inp) (\x -> go (bod (Sub x))) 530 | go (Lam nam bod) = Lam nam (\x -> go (bod (Sub x))) 531 | go (App fun arg) = App (go fun) (go arg) 532 | go (Ann chk val typ) = Ann chk (go val) (go typ) 533 | go (Slf nam typ bod) = Slf nam (go typ) (\x -> go (bod (Sub x))) 534 | go (Ins val) = Ins (go val) 535 | go (ADT scp cts typ) = ADT (map go scp) (map goCtr cts) (go typ) 536 | go (Con nam arg) = Con nam (map (\(f, t) -> (f, go t)) arg) 537 | go (Mat cse) = Mat (map goCse cse) 538 | go (Swi zer suc) = Swi (go zer) (go suc) 539 | go (Map typ) = Map (go typ) 540 | go (KVs map def) = KVs (IM.map go map) (go def) 541 | go (Get g n m k b) = Get g n (go m) (go k) (\x y -> go (b x y)) 542 | go (Put g n m k v b) = Put g n (go m) (go k) (go v) (\x y -> go (b x y)) 543 | go (Use nam val bod) = Use nam (go val) (\x -> go (bod (Sub x))) 544 | go (Met uid spn) = Met uid (map go spn) 545 | go (Log msg nxt) = Log (go msg) (go nxt) 546 | go (Hol nam ctx) = Hol nam (map go ctx) 547 | go Set = Set 548 | go U64 = U64 549 | go F64 = F64 550 | go (Num n) = Num n 551 | go (Flt n) = Flt n 552 | go (Op2 opr fst snd) = Op2 opr (go fst) (go snd) 553 | go (Txt txt) = Txt txt 554 | go (Lst lst) = Lst (map go lst) 555 | go (Nat val) = Nat val 556 | go (Var nam idx) = if lvl == idx then neo else Var nam idx 557 | go (Src src val) = Src src (go val) 558 | go (Sub val) = val 559 | goCtr (Ctr nm tele) = Ctr nm (goTele tele) 560 | goCse (cnam, cbod) = (cnam, go cbod) 561 | goTele (TRet term) = TRet (go term) 562 | goTele (TExt k t b) = TExt k (go t) (\x -> goTele (b x)) 563 | 564 | -- Replaces a term by another 565 | replace :: Term -> Term -> Term -> Int -> Term 566 | replace old neo term dep = if same old term dep then neo else go term where 567 | go (All nam inp bod) = All nam (replace old neo inp dep) (\x -> replace old neo (bod (Sub x)) (dep+1)) 568 | go (Lam nam bod) = Lam nam (\x -> replace old neo (bod (Sub x)) (dep+1)) 569 | go (App fun arg) = App (replace old neo fun dep) (replace old neo arg dep) 570 | go (Ann chk val typ) = Ann chk (replace old neo val dep) (replace old neo typ dep) 571 | go (Slf nam typ bod) = Slf nam (replace old neo typ dep) (\x -> replace old neo (bod (Sub x)) (dep+1)) 572 | go (Ins val) = Ins (replace old neo val dep) 573 | go (ADT scp cts typ) = ADT (map (\x -> replace old neo x (dep+1)) scp) (map goCtr cts) (replace old neo typ dep) 574 | go (Con nam arg) = Con nam (map (\(f, t) -> (f, replace old neo t dep)) arg) 575 | go (Mat cse) = Mat (map goCse cse) 576 | go (Swi zer suc) = Swi (replace old neo zer dep) (replace old neo suc dep) 577 | go (Map typ) = Map (replace old neo typ dep) 578 | go (KVs map def) = KVs (IM.map (\x -> replace old neo x dep) map) (replace old neo def dep) 579 | go (Get g n m k b) = Get g n (replace old neo m dep) (replace old neo k dep) (\x y -> replace old neo (b x y) (dep+2)) 580 | go (Put g n m k v b) = Put g n (replace old neo m dep) (replace old neo k dep) (replace old neo v dep) (\x y -> replace old neo (b x y) (dep+2)) 581 | go (Ref nam) = Ref nam 582 | go (Let nam val bod) = Let nam (replace old neo val dep) (\x -> replace old neo (bod (Sub x)) (dep+1)) 583 | go (Use nam val bod) = Use nam (replace old neo val dep) (\x -> replace old neo (bod (Sub x)) (dep+1)) 584 | go (Met uid spn) = Met uid (map (\x -> replace old neo x (dep+1)) spn) 585 | go (Log msg nxt) = Log (replace old neo msg dep) (replace old neo nxt dep) 586 | go (Hol nam ctx) = Hol nam (map (\x -> replace old neo x (dep+1)) ctx) 587 | go Set = Set 588 | go U64 = U64 589 | go F64 = F64 590 | go (Num n) = Num n 591 | go (Flt n) = Flt n 592 | go (Op2 opr fst snd) = Op2 opr (replace old neo fst dep) (replace old neo snd dep) 593 | go (Txt txt) = Txt txt 594 | go (Lst lst) = Lst (map (\x -> replace old neo x dep) lst) 595 | go (Nat val) = Nat val 596 | go (Var nam idx) = Var nam idx 597 | go (Src src val) = Src src (replace old neo val dep) 598 | go (Sub val) = val 599 | goCtr (Ctr nm tele) = Ctr nm (goTele tele dep) 600 | goCse (cnam, cbod) = (cnam, replace old neo cbod dep) 601 | goTele (TRet term) d = TRet (replace old neo term d) 602 | goTele (TExt k t b) d = TExt k (replace old neo t d) (\x -> goTele (b x) (d+1)) 603 | 604 | -- Returns true when two terms can definitely never be made identical. 605 | -- TODO: to implement this, just recurse pairwise on the Con constructor, 606 | -- until a different name is found. All other terms are considered compatible. 607 | incompatible :: Term -> Term -> Int -> Bool 608 | incompatible (Con aNam aArg) (Con bNam bArg) dep | aNam /= bNam = True 609 | incompatible (Con aNam aArg) (Con bNam bArg) dep | otherwise = length aArg == length bArg && any (\(a,b) -> incompatible a b dep) (zip (map snd aArg) (map snd bArg)) 610 | incompatible (Src aSrc aVal) b dep = incompatible aVal b dep 611 | incompatible a (Src bSrc bVal) dep = incompatible a bVal dep 612 | incompatible _ _ _ = False 613 | -------------------------------------------------------------------------------- /src/Kind/Parse.hs: -------------------------------------------------------------------------------- 1 | -- //./Type.hs// 2 | 3 | module Kind.Parse where 4 | 5 | import Data.Char (ord) 6 | import Data.Functor.Identity (Identity) 7 | import Data.List (intercalate, isPrefixOf, uncons, unsnoc, find, transpose) 8 | import Data.Maybe (catMaybes, fromJust, isJust) 9 | import Data.Set (toList, fromList) 10 | import Data.Word 11 | import Debug.Trace 12 | import Highlight (highlightError, highlight) 13 | import Kind.Equal 14 | import Kind.Reduce 15 | import Kind.Show 16 | import Kind.Type 17 | import Prelude hiding (EQ, LT, GT) 18 | import System.Console.ANSI 19 | import Text.Parsec ((), (<|>), getPosition, sourceLine, sourceColumn, getState, setState) 20 | import Text.Parsec.Error (errorPos, errorMessages, showErrorMessages, ParseError, errorMessages, Message(..)) 21 | import qualified Control.Applicative as A 22 | import qualified Data.IntMap.Strict as IM 23 | import qualified Data.Map.Strict as M 24 | import qualified Text.Parsec as P 25 | 26 | type Uses = [(String, String)] 27 | type PState = (String, Int, Uses) 28 | type Parser a = P.ParsecT String PState Identity a 29 | -- Types used for flattening pattern-matching equations 30 | type Rule = ([Pattern], Term) 31 | data Pattern = PVar String | PCtr (Maybe String) String [Pattern] | PNum Word64 | PSuc Word64 String 32 | 33 | -- Helper functions that consume trailing whitespace 34 | skip :: Parser () 35 | skip = P.skipMany (parseSpace <|> parseComment) 36 | where 37 | parseSpace = (P.try $ do 38 | P.space 39 | return ()) "Space" 40 | parseComment = (P.try $ do 41 | P.string "//" 42 | P.skipMany (P.noneOf "\n") 43 | P.char '\n' 44 | return ()) "Comment" 45 | 46 | char :: Char -> Parser Char 47 | char c = P.char c 48 | 49 | string :: String -> Parser String 50 | string s = P.string s 51 | 52 | char_skp :: Char -> Parser Char 53 | char_skp c = P.char c <* skip 54 | 55 | string_skp :: String -> Parser String 56 | string_skp s = P.string s <* skip 57 | 58 | name_init :: Parser Char 59 | name_init = P.satisfy (`elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/_.-$") 60 | 61 | name_char :: Parser Char 62 | name_char = P.satisfy (`elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789/_.-$") 63 | 64 | name :: Parser String 65 | name = (do 66 | head <- name_init 67 | tail <- P.many name_char 68 | return (head : tail)) "Name" 69 | 70 | name_skp :: Parser String 71 | name_skp = name <* skip 72 | 73 | digit :: Parser Char 74 | digit = P.digit 75 | 76 | numeric :: Parser String 77 | numeric = (do 78 | head <- P.satisfy (`elem` "0123456789") 79 | tail <- P.many (P.satisfy (`elem` "bx0123456789abcdefABCDEF_")) 80 | return $ show (read (filter (/= '_') (head : tail)) :: Word64)) "Number" 81 | 82 | numeric_skp :: Parser String 83 | numeric_skp = numeric <* skip 84 | 85 | oneOf :: String -> Parser Char 86 | oneOf s = P.oneOf s 87 | 88 | noneOf :: String -> Parser Char 89 | noneOf s = P.noneOf s 90 | 91 | guardChoice :: [(Parser a, Parser ())] -> Parser a -> Parser a 92 | guardChoice [] df = df 93 | guardChoice ((p, g):ps) df = do 94 | guard <- P.lookAhead $ P.optionMaybe $ P.try g 95 | case guard of 96 | Just () -> p 97 | Nothing -> guardChoice ps df 98 | 99 | discard :: Parser a -> Parser () 100 | discard p = p >> return () 101 | 102 | -- Main parsing functions 103 | doParseTerm :: String -> String -> IO Term 104 | doParseTerm filename input = 105 | case P.runParser (parseTerm <* P.eof) (filename, 0, []) filename input of 106 | Left err -> do 107 | showParseError filename input err 108 | return $ Ref "bad-parse" 109 | Right term -> return $ bind (genMetas term) [] 110 | 111 | doParseUses :: String -> String -> IO Uses 112 | doParseUses filename input = 113 | case P.runParser (parseUses <* P.eof) (filename, 0, []) filename input of 114 | Left err -> do 115 | showParseError filename input err 116 | return $ [] 117 | Right uses -> return uses 118 | 119 | doParseBook :: String -> String -> IO Book 120 | doParseBook filename input = do 121 | let parser = do 122 | skip 123 | uses <- parseUses 124 | setState (filename, 0, uses) 125 | parseBook <* P.eof 126 | case P.runParser parser (filename, 0, []) filename input of 127 | Left err -> do 128 | showParseError filename input err 129 | return M.empty 130 | Right book -> return book 131 | 132 | -- Error handling 133 | extractExpectedTokens :: ParseError -> String 134 | extractExpectedTokens err = 135 | let expectedMsgs = [msg | Expect msg <- errorMessages err, msg /= "Space", msg /= "Comment"] 136 | in intercalate " | " expectedMsgs 137 | 138 | showParseError :: String -> String -> P.ParseError -> IO () 139 | showParseError filename input err = do 140 | let pos = errorPos err 141 | let lin = sourceLine pos 142 | let col = sourceColumn pos 143 | let errorMsg = extractExpectedTokens err 144 | putStrLn $ setSGRCode [SetConsoleIntensity BoldIntensity] ++ "\nPARSE_ERROR" ++ setSGRCode [Reset] 145 | putStrLn $ "- expected: " ++ errorMsg 146 | putStrLn $ "- detected:" 147 | putStrLn $ highlightError (lin, col) (lin, col + 1) input 148 | putStrLn $ setSGRCode [SetUnderlining SingleUnderline] ++ filename ++ 149 | setSGRCode [Reset] ++ " " ++ show lin ++ ":" ++ show col 150 | 151 | -- Parsing helpers 152 | -- FIXME: currently, this will include suffix trivia. how can we avoid that? 153 | withSrc :: Parser Term -> Parser Term 154 | withSrc parser = do 155 | ini <- getPosition 156 | val <- parser 157 | end <- getPosition 158 | (nam, _, _) <- P.getState 159 | skip 160 | let iniLoc = Loc nam (sourceLine ini) (sourceColumn ini) 161 | let endLoc = Loc nam (sourceLine end) (sourceColumn end) 162 | return $ Src (Cod iniLoc endLoc) val 163 | 164 | -- Term Parser 165 | -- ----------- 166 | 167 | -- Main term parser 168 | parseTerm :: Parser Term 169 | parseTerm = do 170 | skip 171 | term <- guardChoice 172 | [ (parseAll, discard $ string_skp "∀") 173 | , (parseSwi, discard $ string_skp "λ" >> string_skp "{" >> string_skp "0") 174 | , (parseMat, discard $ string_skp "λ" >> string_skp "{" >> string_skp "#") 175 | , (parseLam, discard $ string_skp "λ") 176 | , (parseEra, discard $ string_skp "λ") 177 | , (parseOp2, discard $ string_skp "(" >> parseOper) 178 | , (parseMap, discard $ string_skp "(Map ") 179 | , (parseApp, discard $ string_skp "(") 180 | , (parseSlf, discard $ string_skp "$(") 181 | , (parseIns, discard $ string_skp "~") 182 | , (parseADT, discard $ string_skp "#[" <|> string_skp "data[") 183 | , (parseNat, discard $ string_skp "#" >> digit) 184 | , (parseCon, discard $ string_skp "#" >> name) 185 | , ((parseUse parseTerm), discard $ string_skp "use ") 186 | , ((parseLet parseTerm), discard $ string_skp "let ") 187 | , ((parseGet parseTerm), discard $ string_skp "get ") 188 | , ((parsePut parseTerm), discard $ string_skp "put ") 189 | , (parseIf, discard $ string_skp "if ") 190 | , (parseWhen, discard $ string_skp "when ") 191 | , (parseMatInl, discard $ string_skp "match ") 192 | , (parseSwiInl, discard $ string_skp "switch ") 193 | , (parseKVs, discard $ string_skp "{") 194 | , (parseDo, discard $ string_skp "do ") 195 | , (parseSet, discard $ string_skp "*") 196 | , (parseFloat, discard $ string_skp "-" <|> (P.many1 digit >> string_skp ".")) 197 | , (parseNum, discard $ numeric) 198 | , (parseTxt, discard $ string_skp "\"") 199 | , (parseLst, discard $ string_skp "[") 200 | , (parseChr, discard $ string_skp "'") 201 | , (parseHol, discard $ string_skp "?") 202 | , ((parseLog parseTerm), discard $ string_skp "log ") 203 | , (parseRef, discard $ name) 204 | ] $ fail "Term" 205 | skip 206 | parseSuffix term 207 | 208 | -- Individual term parsers 209 | parseAll = withSrc $ do 210 | string_skp "∀" 211 | era <- P.optionMaybe (char_skp '-') 212 | char_skp '(' 213 | nam <- name_skp 214 | char_skp ':' 215 | inp <- parseTerm 216 | char_skp ')' 217 | bod <- parseTerm 218 | return $ All nam inp (\x -> bod) 219 | 220 | parseLam = withSrc $ do 221 | string_skp "λ" 222 | era <- P.optionMaybe (char_skp '-') 223 | nam <- name_skp 224 | bod <- parseTerm 225 | return $ Lam nam (\x -> bod) 226 | 227 | parseEra = withSrc $ do 228 | string_skp "λ" 229 | era <- P.optionMaybe (char_skp '-') 230 | nam <- char_skp '_' 231 | bod <- parseTerm 232 | return $ Lam "_" (\x -> bod) 233 | 234 | parseApp = withSrc $ do 235 | char_skp '(' 236 | fun <- parseTerm 237 | args <- P.many $ do 238 | P.notFollowedBy (char ')') 239 | era <- P.optionMaybe (char_skp '-') 240 | arg <- parseTerm 241 | return (era, arg) 242 | char ')' 243 | return $ foldl (\f (era, a) -> App f a) fun args 244 | 245 | parseSlf = withSrc $ do 246 | string_skp "$(" 247 | nam <- name_skp 248 | char_skp ':' 249 | typ <- parseTerm 250 | char_skp ')' 251 | bod <- parseTerm 252 | return $ Slf nam typ (\x -> bod) 253 | 254 | parseIns = withSrc $ do 255 | char_skp '~' 256 | val <- parseTerm 257 | return $ Ins val 258 | 259 | parseADT = withSrc $ do 260 | P.choice [string_skp "#[", string_skp "data["] 261 | scp <- P.many parseTerm 262 | char_skp ']' 263 | char_skp '{' 264 | cts <- P.many $ P.try parseADTCtr 265 | char '}' 266 | typ <- do 267 | skip 268 | char_skp ':' 269 | parseTerm 270 | return $ ADT scp cts typ 271 | 272 | parseADTCtr :: Parser Ctr 273 | parseADTCtr = do 274 | char_skp '#' 275 | name <- name_skp 276 | tele <- parseTele 277 | return $ Ctr name tele 278 | 279 | parseTele :: Parser Tele 280 | parseTele = do 281 | fields <- P.option [] $ do 282 | char_skp '{' 283 | fields <- P.many $ P.try $ do 284 | nam <- name_skp 285 | char_skp ':' 286 | typ <- parseTerm 287 | return (nam, typ) 288 | char_skp '}' 289 | return fields 290 | ret <- P.choice 291 | [ do 292 | P.try $ char_skp ':' 293 | parseTerm 294 | , do 295 | return (Met 0 []) 296 | ] 297 | return $ foldr (\(nam, typ) acc -> TExt nam typ (\x -> acc)) (TRet ret) fields 298 | 299 | parseCon = withSrc $ do 300 | char_skp '#' 301 | nam <- name 302 | args <- P.option [] $ P.try $ do 303 | skip 304 | char_skp '{' 305 | args <- P.many $ do 306 | P.notFollowedBy (char_skp '}') 307 | name <- P.optionMaybe $ P.try $ do 308 | name <- name_skp 309 | char_skp ':' 310 | return name 311 | term <- parseTerm 312 | return (name, term) 313 | char '}' 314 | return args 315 | return $ Con nam args 316 | 317 | parseMatCases :: Parser [(String, Term)] 318 | parseMatCases = do 319 | cse <- P.many $ P.try $ do 320 | string_skp "#" 321 | cnam <- name_skp 322 | args <- P.option [] $ P.try $ do 323 | char_skp '{' 324 | names <- P.many name_skp 325 | char_skp '}' 326 | return names 327 | char_skp ':' 328 | cbod <- parseTerm 329 | return (cnam, foldr (\arg acc -> Lam arg (\_ -> acc)) cbod args) 330 | dflt <- P.optionMaybe $ do 331 | dnam <- P.try $ do 332 | dnam <- name_skp 333 | string_skp ":" 334 | return dnam 335 | dbod <- parseTerm 336 | return (dnam, dbod) 337 | return $ case dflt of 338 | Just (dnam, dbod) -> cse ++ [("_", (Lam dnam (\_ -> dbod)))] 339 | Nothing -> cse 340 | 341 | parseSwiCases :: Parser Term 342 | parseSwiCases = do 343 | cse <- P.many $ P.try $ do 344 | cnam <- numeric_skp 345 | char_skp ':' 346 | cbod <- parseTerm 347 | return (cnam, cbod) 348 | dflt <- P.optionMaybe $ do 349 | dnam <- P.try $ do 350 | cnam <- numeric_skp 351 | char_skp '+' 352 | dnam <- name_skp 353 | string_skp ":" 354 | return dnam 355 | dbod <- parseTerm 356 | return (dnam, dbod) 357 | case dflt of 358 | Just (dnam, dbod) -> return $ build (cse ++ [("_", (Lam dnam (\_ -> dbod)))]) 0 359 | Nothing -> return $ build cse 0 360 | where build :: [(String, Term)] -> Int -> Term 361 | build [] i = error "Switch must have at least one case." 362 | build (("_",t):cs) i = t 363 | build ((n,t):cs) i | read n == i = Swi t (build cs (i+1)) 364 | build ((n,t):cs) i | otherwise = error "Switch cases must be in ascending order starting from 0." 365 | 366 | parseSwiElim :: Parser Term 367 | parseSwiElim = do 368 | cases <- parseSwiCases 369 | return cases 370 | 371 | parseSwi = withSrc $ do 372 | char_skp 'λ' 373 | char_skp '{' 374 | P.lookAhead $ P.try $ char_skp '0' 375 | elim <- parseSwiElim 376 | char '}' 377 | return $ elim 378 | 379 | parseMat = withSrc $ do 380 | char_skp 'λ' 381 | char_skp '{' 382 | cse <- parseMatCases 383 | char '}' 384 | return $ Mat cse 385 | 386 | -- TODO: implement the Map parsers 387 | parseMap = withSrc $ do 388 | string_skp "(Map " 389 | typ <- parseTerm 390 | char ')' 391 | return $ Map typ 392 | 393 | parseKVs = withSrc $ do 394 | char_skp '{' 395 | kvs <- P.many parseKV 396 | char_skp '|' 397 | dft <- parseTerm 398 | char '}' 399 | return $ KVs (IM.fromList kvs) dft 400 | where 401 | parseKV = do 402 | key <- read <$> numeric_skp 403 | char_skp ':' 404 | val <- parseTerm 405 | return (key, val) 406 | 407 | parseGet parseBody = withSrc $ do 408 | string_skp "get " 409 | got <- name_skp 410 | string_skp "=" 411 | nam <- name_skp 412 | map <- P.option (Ref nam) $ P.try $ char_skp '@' >> parseTerm 413 | char_skp '[' 414 | key <- parseTerm 415 | char_skp ']' 416 | bod <- parseBody 417 | return $ Get got nam map key (\x y -> bod) 418 | 419 | parsePut parseBody = withSrc $ do 420 | string_skp "put " 421 | got <- P.option "_" $ P.try $ do 422 | got <- name_skp 423 | string_skp "=" 424 | return got 425 | nam <- name_skp 426 | map <- P.option (Ref nam) $ P.try $ char_skp '@' >> parseTerm 427 | char_skp '[' 428 | key <- parseTerm 429 | char_skp ']' 430 | string_skp ":=" 431 | val <- parseTerm 432 | bod <- parseBody 433 | return $ Put got nam map key val (\x y -> bod) 434 | 435 | parseRef = withSrc $ do 436 | name <- name 437 | (_, _, uses) <- P.getState 438 | let name' = expandUses uses name 439 | return $ case name' of 440 | "U64" -> U64 441 | "F64" -> F64 442 | "Set" -> Set 443 | "_" -> Met 0 [] 444 | _ -> Ref name' 445 | 446 | parseLocal :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term 447 | parseLocal header ctor parseBody = withSrc $ P.choice 448 | [ parseLocalMch header ctor parseBody 449 | , parseLocalPar header ctor parseBody 450 | , parseLocalVal header ctor parseBody 451 | ] 452 | 453 | parseLocalMch :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term 454 | parseLocalMch header ctor parseBody = do 455 | P.try $ string_skp (header ++ " #") 456 | cnam <- name_skp 457 | char_skp '{' 458 | args <- P.many name_skp 459 | char_skp '}' 460 | char_skp '=' 461 | val <- parseTerm 462 | bod <- parseBody 463 | return $ ctor "got" val (\got -> 464 | App (Mat [(cnam, foldr (\arg acc -> Lam arg (\_ -> acc)) bod args)]) got) 465 | 466 | parseLocalPar :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term 467 | parseLocalPar header ctor parseBody = do 468 | P.try $ string_skp (header ++ " (") 469 | head <- name_skp 470 | tail <- P.many $ do 471 | char_skp ',' 472 | name_skp 473 | char_skp ')' 474 | let (init, last) = maybe ([], head) id $ unsnoc (head : tail) 475 | char_skp '=' 476 | val <- parseTerm 477 | bod <- parseBody 478 | return $ ctor "got" val (\got -> 479 | App (foldr (\x acc -> Mat [("Pair", Lam x (\_ -> acc))]) (Lam last (\_ -> bod)) init) got) 480 | 481 | parseLocalVal :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term 482 | parseLocalVal header ctor parseBody = do 483 | P.try $ string_skp (header ++ " ") 484 | nam <- name_skp 485 | char_skp '=' 486 | val <- parseTerm 487 | bod <- parseBody 488 | return $ ctor nam val (\x -> bod) 489 | 490 | parseLet :: Parser Term -> Parser Term 491 | parseLet = parseLocal "let" Let 492 | 493 | parseUse :: Parser Term -> Parser Term 494 | parseUse = parseLocal "use" Use 495 | 496 | parseSet = withSrc $ char '*' >> return Set 497 | 498 | parseFloat = withSrc $ P.try $ do 499 | -- Parse optional negative sign 500 | sign <- P.option id $ P.char '-' >> return negate 501 | 502 | -- Parse integer part 503 | intPart <- P.many1 digit 504 | 505 | -- Parse decimal part (this must succeed, or we fail the whole parser) 506 | decPart <- do 507 | char '.' 508 | P.many1 digit 509 | 510 | -- Parse optional exponent 511 | expPart <- P.option 0 $ P.try $ do 512 | oneOf "eE" 513 | expSign <- P.option '+' (oneOf "+-") 514 | exp <- read <$> P.many1 digit 515 | return $ if expSign == '-' then -exp else exp 516 | 517 | -- Combine parts into final float 518 | let floatStr = intPart ++ "." ++ decPart 519 | let value = (read floatStr :: Double) * (10 ^^ expPart) 520 | 521 | -- Apply the sign to the final value 522 | return $ Flt (sign value) 523 | 524 | parseNum = withSrc $ do 525 | val <- numeric 526 | return $ Num (read (filter (/= '_') val)) 527 | 528 | parseOp2 = withSrc $ do 529 | char_skp '(' 530 | opr <- parseOper 531 | fst <- parseTerm 532 | snd <- parseTerm 533 | char ')' 534 | return $ Op2 opr fst snd 535 | 536 | parseLst = withSrc $ do 537 | char_skp '[' 538 | elems <- P.many parseTerm 539 | char ']' 540 | return $ Lst elems 541 | 542 | parseTxtChr :: Parser Char 543 | parseTxtChr = P.choice 544 | [ P.try $ do 545 | char_skp '\\' 546 | c <- oneOf "\\\"nrtbf0/\'" 547 | return $ case c of 548 | '\\' -> '\\' 549 | '/' -> '/' 550 | '"' -> '"' 551 | '\'' -> '\'' 552 | 'n' -> '\n' 553 | 'r' -> '\r' 554 | 't' -> '\t' 555 | 'b' -> '\b' 556 | 'f' -> '\f' 557 | '0' -> '\0' 558 | , P.try $ do 559 | string_skp "\\u" 560 | code <- P.count 4 P.hexDigit 561 | return $ toEnum (read ("0x" ++ code) :: Int) 562 | , noneOf "\"\\" 563 | ] 564 | 565 | parseTxt = withSrc $ do 566 | char '"' 567 | txt <- P.many parseTxtChr 568 | char '"' 569 | return $ Txt txt 570 | 571 | parseChr = withSrc $ do 572 | char '\'' 573 | chr <- parseTxtChr 574 | char '\'' 575 | return $ Num (fromIntegral $ ord chr) 576 | 577 | parseHol = withSrc $ do 578 | char_skp '?' 579 | nam <- name_skp 580 | ctx <- P.option [] $ do 581 | char_skp '[' 582 | terms <- P.sepBy parseTerm (char_skp ',') 583 | char ']' 584 | return terms 585 | return $ Hol nam ctx 586 | 587 | parseLog parseBody = withSrc $ do 588 | string_skp "log " 589 | msg <- parseTerm 590 | val <- parseBody 591 | return $ Log msg val 592 | 593 | parseOper = P.choice 594 | [ P.try (string_skp "+") >> return ADD 595 | , P.try (string_skp "-") >> return SUB 596 | , P.try (string_skp "*") >> return MUL 597 | , P.try (string_skp "/") >> return DIV 598 | , P.try (string_skp "%") >> return MOD 599 | , P.try (string_skp "<<") >> return LSH 600 | , P.try (string_skp ">>") >> return RSH 601 | , P.try (string_skp "<=") >> return LTE 602 | , P.try (string_skp ">=") >> return GTE 603 | , P.try (string_skp "<") >> return LT 604 | , P.try (string_skp ">") >> return GT 605 | , P.try (string_skp "==") >> return EQ 606 | , P.try (string_skp "!=") >> return NE 607 | , P.try (string_skp "&") >> return AND 608 | , P.try (string_skp "|") >> return OR 609 | , P.try (string_skp "^") >> return XOR 610 | ] "Binary operator" 611 | 612 | parseSuffix :: Term -> Parser Term 613 | parseSuffix term = guardChoice 614 | [ (parseSuffArr term, discard $ string_skp "->") 615 | , (parseSuffAnn term, discard $ string_skp "::") 616 | , (parseSuffEql term, discard $ string_skp "==") 617 | , (parseSuffPAR term, discard $ string_skp "&") 618 | , (parseSuffPar term, discard $ string_skp ",") 619 | , (parseSuffCns term, discard $ string_skp ";;") 620 | ] $ parseSuffVal term 621 | 622 | parseSuffArr :: Term -> Parser Term 623 | parseSuffArr term = do 624 | P.try $ string_skp "->" 625 | ret <- parseTerm 626 | return $ All "_" term (\_ -> ret) 627 | 628 | parseSuffAnn :: Term -> Parser Term 629 | parseSuffAnn term = do 630 | P.try $ string_skp "::" 631 | typ <- parseTerm 632 | return $ Ann True term typ 633 | 634 | parseSuffEql :: Term -> Parser Term 635 | parseSuffEql term = do 636 | P.try $ string_skp "==" 637 | other <- parseTerm 638 | return $ App (App (App (Ref "Equal") (Met 0 [])) term) other 639 | 640 | parseSuffPAR :: Term -> Parser Term 641 | parseSuffPAR fst = do 642 | P.try $ string_skp "&" 643 | snd <- parseTerm 644 | return $ App (App (Ref "Pair") fst) snd 645 | 646 | parseSuffPar :: Term -> Parser Term 647 | parseSuffPar fst = do 648 | P.try $ string_skp "," 649 | snd <- parseTerm 650 | return $ Con "Pair" [(Nothing, fst), (Nothing, snd)] 651 | 652 | parseSuffCns :: Term -> Parser Term 653 | parseSuffCns head = do 654 | P.try $ string_skp ";;" 655 | tail <- parseTerm 656 | return $ Con "Cons" [(Nothing, head), (Nothing, tail)] 657 | 658 | parseSuffVal :: Term -> Parser Term 659 | parseSuffVal term = return term 660 | 661 | -- Book Parser 662 | -- ----------- 663 | 664 | parseBook :: Parser Book 665 | parseBook = M.fromList <$> P.many parseDef 666 | 667 | parseDef :: Parser (String, Term) 668 | parseDef = guardChoice 669 | [ (parseDefADT, discard $ string_skp "data ") 670 | , (parseDefFun, discard $ string_skp "#" <|> name_skp) 671 | ] $ fail "Top-level definition" 672 | 673 | parseDefADT :: Parser (String, Term) 674 | parseDefADT = do 675 | (_, _, uses) <- P.getState 676 | P.try $ string_skp "data " 677 | name <- name_skp 678 | let nameA = expandUses uses name 679 | params <- P.many $ do 680 | P.try $ char_skp '(' 681 | pname <- name_skp 682 | char_skp ':' 683 | ptype <- parseTerm 684 | char_skp ')' 685 | return (pname, ptype) 686 | indices <- P.choice 687 | [ do 688 | P.try $ char_skp '~' 689 | P.many $ do 690 | P.notFollowedBy (char '{') 691 | char_skp '(' 692 | iname <- name_skp 693 | char_skp ':' 694 | itype <- parseTerm 695 | char_skp ')' 696 | return (iname, itype) 697 | , return [] 698 | ] 699 | char_skp '{' 700 | ctrs <- P.many $ P.try parseADTCtr 701 | char_skp '}' 702 | let paramTypes = map snd params 703 | let indexTypes = map snd indices 704 | let paramNames = map fst params 705 | let indexNames = map fst indices 706 | let allParams = params ++ indices 707 | let selfType = foldl (\ acc arg -> App acc (Ref arg)) (Ref nameA) (paramNames ++ indexNames) 708 | let typeBody = foldr (\ (pname, ptype) acc -> All pname ptype (\_ -> acc)) Set allParams 709 | let newCtrs = map (fillCtrRet selfType) ctrs -- fill ctr type when omitted 710 | let dataBody = ADT (map (\ (iNam,iTyp) -> Ref iNam) indices) newCtrs selfType 711 | let fullBody = foldr (\ (pname, _) acc -> Lam pname (\_ -> acc)) dataBody allParams 712 | let term = bind (genMetas (Ann False fullBody typeBody)) [] 713 | return $ 714 | -- trace ("parsed " ++ nameA ++ " = " ++ (showTermGo False term 0)) 715 | (nameA, term) 716 | where fillCtrRet ret (Ctr nm tele) = Ctr nm (fillTeleRet ret tele) 717 | fillTeleRet ret (TRet (Met _ _)) = TRet ret 718 | fillTeleRet _ (TRet ret) = TRet ret 719 | fillTeleRet ret (TExt nm tm bod) = TExt nm tm (\x -> fillTeleRet ret (bod x)) -- FIXME: 'bod x'? 720 | 721 | parseDefFun :: Parser (String, Term) 722 | parseDefFun = do 723 | numb <- P.optionMaybe $ char_skp '#' 724 | name <- name_skp 725 | typ <- P.optionMaybe $ do 726 | char_skp ':' 727 | t <- parseTerm 728 | return t 729 | val <- guardChoice 730 | [ (parseDefFunSingle, discard $ char_skp '=') 731 | , (parseDefFunRules, discard $ char_skp '|') 732 | ] parseDefFunTest 733 | (filename, count, uses) <- P.getState 734 | let name0 = expandUses uses name 735 | let name1 = if isJust numb then name0 ++ "#" ++ show count else name0 736 | P.setState (filename, if isJust numb then count + 1 else count, uses) 737 | case typ of 738 | Nothing -> return (name1, bind (genMetas val) []) 739 | Just t -> return (name1, bind (genMetas (Ann False val t)) []) 740 | 741 | parseDefFunSingle :: Parser Term 742 | parseDefFunSingle = do 743 | char_skp '=' 744 | val <- parseTerm 745 | return val 746 | 747 | parseDefFunRules :: Parser Term 748 | parseDefFunRules = withSrc $ do 749 | rules <- P.many1 (parseRule 0) 750 | let flat = flattenDef rules 0 751 | return 752 | -- $ trace ("DONE: " ++ showTerm flat) 753 | flat 754 | 755 | parseDefFunTest :: Parser Term 756 | parseDefFunTest = return (Con "Refl" []) 757 | 758 | parseRule :: Int -> Parser Rule 759 | parseRule dep = do 760 | P.try $ do 761 | P.count dep $ char_skp '.' 762 | char_skp '|' 763 | pats <- P.many parsePattern 764 | body <- P.choice 765 | [ withSrc $ P.try $ do 766 | string_skp "with " 767 | wth <- P.many1 $ P.notFollowedBy (char_skp '.') >> parseTerm 768 | rul <- P.many1 $ parseRule (dep + 1) 769 | return $ flattenWith dep wth rul 770 | , P.try $ do 771 | char_skp '=' 772 | body <- parseTerm 773 | return body 774 | ] 775 | return $ (pats, body) 776 | 777 | parsePattern :: Parser Pattern 778 | parsePattern = do 779 | P.notFollowedBy $ string_skp "with " 780 | pat <- guardChoice 781 | [ (parsePatPrn, discard $ string_skp "(") 782 | , (parsePatNat, discard $ string_skp "#" >> numeric_skp) 783 | , (parsePatLst, discard $ string_skp "[") 784 | , (parsePatCon, discard $ string_skp "#" <|> (name_skp >> string_skp "@")) 785 | , (parsePatTxt, discard $ string_skp "\"") 786 | , (parsePatSuc, discard $ numeric_skp >> char_skp '+') 787 | , (parsePatNum, discard $ numeric_skp) 788 | , (parsePatVar, discard $ name_skp) 789 | ] $ fail "Pattern-matching" 790 | parsePatSuffix pat 791 | 792 | parsePatSuffix :: Pattern -> Parser Pattern 793 | parsePatSuffix pat = P.choice 794 | [ parsePatSuffPar pat 795 | , parsePatSuffCns pat 796 | , return pat 797 | ] 798 | 799 | parsePatSuffPar :: Pattern -> Parser Pattern 800 | parsePatSuffPar fst = do 801 | P.try $ string_skp "," 802 | snd <- parsePattern 803 | return $ PCtr Nothing "Pair" [fst, snd] 804 | 805 | parsePatSuffCns :: Pattern -> Parser Pattern 806 | parsePatSuffCns head = do 807 | P.try $ string_skp ";;" 808 | tail <- parsePattern 809 | return $ PCtr Nothing "Cons" [head, tail] 810 | 811 | parsePatPrn :: Parser Pattern 812 | parsePatPrn = do 813 | string_skp "(" 814 | pat <- parsePattern 815 | string_skp ")" 816 | return pat 817 | 818 | parsePatNat :: Parser Pattern 819 | parsePatNat = do 820 | char_skp '#' 821 | num <- numeric_skp 822 | let n = read num 823 | return $ (foldr (\_ acc -> PCtr Nothing "Succ" [acc]) (PCtr Nothing "Zero" []) [1..n]) 824 | 825 | parsePatLst :: Parser Pattern 826 | parsePatLst = do 827 | char_skp '[' 828 | elems <- P.many parsePattern 829 | char_skp ']' 830 | return $ foldr (\x acc -> PCtr Nothing "Cons" [x, acc]) (PCtr Nothing "Nil" []) elems 831 | 832 | parsePatTxt :: Parser Pattern 833 | parsePatTxt = do 834 | char '"' 835 | txt <- P.many parseTxtChr 836 | char '"' 837 | return $ foldr (\x acc -> PCtr Nothing "Cons" [PNum (toEnum (ord x)), acc]) (PCtr Nothing "Nil" []) txt 838 | 839 | parsePatPar :: Parser Pattern 840 | parsePatPar = do 841 | char_skp '(' 842 | head <- parsePattern 843 | tail <- P.many $ do 844 | char_skp ',' 845 | parsePattern 846 | char_skp ')' 847 | let (init, last) = maybe ([], head) id (unsnoc (head : tail)) 848 | return $ foldr (\x acc -> PCtr Nothing "Pair" [x, acc]) last init 849 | 850 | parsePatCon :: Parser Pattern 851 | parsePatCon = do 852 | name <- P.optionMaybe $ P.try $ do 853 | name <- name_skp 854 | char_skp '@' 855 | return name 856 | char_skp '#' 857 | cnam <- name_skp 858 | args <- P.option [] $ P.try $ do 859 | char_skp '{' 860 | args <- P.many parsePattern 861 | char_skp '}' 862 | return args 863 | return $ (PCtr name cnam args) 864 | 865 | parsePatNum :: Parser Pattern 866 | parsePatNum = do 867 | num <- numeric_skp 868 | return $ (PNum (read num)) 869 | 870 | parsePatSuc :: Parser Pattern 871 | parsePatSuc = do 872 | num <- numeric_skp 873 | char_skp '+' 874 | nam <- name_skp 875 | return $ (PSuc (read num) nam) 876 | 877 | parsePatVar :: Parser Pattern 878 | parsePatVar = do 879 | name <- name_skp 880 | return $ (PVar name) 881 | 882 | parseUses :: Parser Uses 883 | parseUses = P.many $ P.try $ do 884 | string_skp "use " 885 | long <- name_skp 886 | string_skp "as " 887 | short <- name_skp 888 | return (short, long) 889 | 890 | expandUses :: Uses -> String -> String 891 | expandUses ((short, long):uses) name 892 | | short == name = long 893 | | (short ++ "/") `isPrefixOf` name = long ++ drop (length short) name 894 | | otherwise = expandUses uses name 895 | expandUses [] name = name 896 | 897 | -- Syntax Sugars 898 | -- ------------- 899 | 900 | parseDo :: Parser Term 901 | parseDo = withSrc $ do 902 | string_skp "do " 903 | monad <- name_skp 904 | char_skp '{' 905 | skip 906 | (_, _, uses) <- P.getState 907 | body <- parseStmt (expandUses uses monad) 908 | char '}' 909 | return body 910 | 911 | parseStmt :: String -> Parser Term 912 | parseStmt monad = guardChoice 913 | [ (parseDoFor monad, discard $ string_skp "for " <|> (string_skp "ask" >> name_skp >> string_skp "=" >> string_skp "for")) 914 | , (parseDoAsk monad, discard $ string_skp "ask ") 915 | , (parseDoRet monad, discard $ string_skp "ret ") 916 | , (parseLet (parseStmt monad), discard $ string_skp "let ") 917 | , (parseUse (parseStmt monad), discard $ string_skp "use ") 918 | , (parseLog (parseStmt monad), discard $ string_skp "log ") 919 | ] parseTerm 920 | 921 | parseDoAsk :: String -> Parser Term 922 | parseDoAsk monad = guardChoice 923 | [ (parseDoAskMch monad, discard $ string_skp "ask #") 924 | , (parseDoAskPar monad, discard $ string_skp "ask (" >> name_skp >> string_skp ",") 925 | , (parseDoAskVal monad, discard $ string_skp "ask ") 926 | ] $ fail "'ask' statement" 927 | 928 | parseDoAskMch :: String -> Parser Term 929 | parseDoAskMch monad = do 930 | string_skp "ask #" 931 | cnam <- name_skp 932 | char_skp '{' 933 | args <- P.many name_skp 934 | char_skp '}' 935 | char_skp '=' 936 | val <- parseTerm 937 | next <- parseStmt monad 938 | (_, _, uses) <- P.getState 939 | return $ App 940 | (App (App (App (Ref (monad ++ "/bind")) (Met 0 [])) (Met 0 [])) val) 941 | (Lam "got" (\got -> 942 | App (Mat [(cnam, foldr (\arg acc -> Lam arg (\_ -> acc)) next args)]) got)) 943 | 944 | parseDoAskPar :: String -> Parser Term 945 | parseDoAskPar monad = do 946 | string_skp "ask (" 947 | head <- name_skp 948 | tail <- P.many $ do 949 | char_skp ',' 950 | name_skp 951 | char_skp ')' 952 | let (init, last) = maybe ([], head) id $ unsnoc (head : tail) 953 | char_skp '=' 954 | val <- parseTerm 955 | next <- parseStmt monad 956 | (_, _, uses) <- P.getState 957 | return $ App 958 | (App (App (App (Ref (monad ++ "/bind")) (Met 0 [])) (Met 0 [])) val) 959 | (foldr (\x acc -> Mat [("Pair", Lam x (\_ -> acc))]) (Lam last (\_ -> next)) init) 960 | 961 | parseDoAskVal :: String -> Parser Term 962 | parseDoAskVal monad = P.choice 963 | [ parseDoAskValNamed monad 964 | , parseDoAskValAnon monad 965 | ] 966 | 967 | parseDoAskValNamed :: String -> Parser Term 968 | parseDoAskValNamed monad = P.try $ do 969 | string_skp "ask " 970 | nam <- name_skp 971 | char_skp '=' 972 | exp <- parseTerm 973 | next <- parseStmt monad 974 | (_, _, uses) <- P.getState 975 | return $ App 976 | (App (App (App (Ref (monad ++ "/bind")) (Met 0 [])) (Met 0 [])) exp) 977 | (Lam nam (\_ -> next)) 978 | 979 | parseDoAskValAnon :: String -> Parser Term 980 | parseDoAskValAnon monad = P.try $ do 981 | string_skp "ask " 982 | exp <- parseTerm 983 | next <- parseStmt monad 984 | (_, _, uses) <- P.getState 985 | return $ App 986 | (App (App (App (Ref (monad ++ "/bind")) (Met 0 [])) (Met 0 [])) exp) 987 | (Lam "_" (\_ -> next)) 988 | 989 | parseDoRet :: String -> Parser Term 990 | parseDoRet monad = do 991 | string_skp "ret " 992 | exp <- parseTerm 993 | (_, _, uses) <- P.getState 994 | return $ App (App (Ref (monad ++ "/pure")) (Met 0 [])) exp 995 | 996 | parseDoFor :: String -> Parser Term 997 | parseDoFor monad = do 998 | (stt, nam, lst, loop, body) <- P.choice 999 | [ do 1000 | stt <- P.try $ do 1001 | string_skp "ask " 1002 | stt <- name_skp 1003 | string_skp "=" 1004 | string_skp "for" 1005 | return stt 1006 | nam <- name_skp 1007 | string_skp "in" 1008 | lst <- parseTerm 1009 | char_skp '{' 1010 | loop <- parseStmt monad 1011 | char_skp '}' 1012 | body <- parseStmt monad 1013 | return (Just stt, nam, lst, loop, body) 1014 | , do 1015 | P.try $ string_skp "for " 1016 | nam <- name_skp 1017 | string_skp "in" 1018 | lst <- parseTerm 1019 | char_skp '{' 1020 | loop <- parseStmt monad 1021 | char_skp '}' 1022 | body <- parseStmt monad 1023 | return (Nothing, nam, lst, loop, body) ] 1024 | let f0 = Ref "List/for" 1025 | let f1 = App f0 (Met 0 []) 1026 | let f2 = App f1 (Ref (monad ++ "/Monad")) 1027 | let f3 = App f2 (Met 0 []) 1028 | let f4 = App f3 (Met 0 []) 1029 | let f5 = App f4 lst 1030 | let f6 = App f5 (maybe (Num 0) Ref stt) 1031 | let f7 = App f6 (Lam (maybe "" id stt) (\s -> Lam nam (\_ -> loop))) 1032 | let b0 = Ref (monad ++ "/bind") 1033 | let b1 = App b0 (Met 0 []) 1034 | let b2 = App b1 (Met 0 []) 1035 | let b3 = App b2 f7 1036 | let b4 = App b3 (Lam (maybe "" id stt) (\_ -> body)) 1037 | return b4 1038 | 1039 | -- If-Then-Else 1040 | -- ------------ 1041 | 1042 | -- if cond { t } else { f } 1043 | -- --------------------------------- desugars to 1044 | -- match cond { #True: t #False: f } 1045 | 1046 | parseIf = withSrc $ do 1047 | string_skp "if " 1048 | cond <- parseTerm 1049 | t <- parseBranch True 1050 | string_skp "else" 1051 | f <- P.choice [parseBranch False, parseIf] 1052 | return $ App (Mat [("True", t), ("False", f)]) cond 1053 | where 1054 | parseBranch isIf = P.choice 1055 | [ do 1056 | string_skp "do " 1057 | monad <- name_skp 1058 | char_skp '{' 1059 | (_, _, uses) <- P.getState 1060 | t <- parseStmt (expandUses uses monad) 1061 | if isIf then char_skp '}' else char '}' 1062 | return t 1063 | , do 1064 | char_skp '{' 1065 | t <- parseTerm 1066 | if isIf then char_skp '}' else char '}' 1067 | return t 1068 | ] 1069 | 1070 | -- When 1071 | -- ---- 1072 | 1073 | -- when fn x { c0: v0 c1: v1 } else { df } 1074 | -- -------------------------------------------------------- desugars to 1075 | -- if (fn x c0) { v0 } else if (fn x c1) { v1 } else { df } 1076 | 1077 | parseWhen = withSrc $ do 1078 | string_skp "when " 1079 | fun <- parseTerm 1080 | val <- parseTerm 1081 | char_skp '{' 1082 | cases <- P.many $ do 1083 | cond <- parseTerm 1084 | char_skp ':' 1085 | body <- parseTerm 1086 | return (cond, body) 1087 | char_skp '}' 1088 | string_skp "else" 1089 | char_skp '{' 1090 | elseCase <- parseTerm 1091 | char '}' 1092 | return $ foldr 1093 | (\ (cond, body) acc -> App 1094 | (Mat [("True", body), ("False", acc)]) 1095 | (App (App fun val) cond)) 1096 | elseCase 1097 | cases 1098 | 1099 | -- Match 1100 | -- ----- 1101 | 1102 | parseMatInl :: Parser Term 1103 | parseMatInl = withSrc $ do 1104 | string_skp "match " 1105 | x <- parseTerm 1106 | char_skp '{' 1107 | cse <- parseMatCases 1108 | char '}' 1109 | return $ App (Mat cse) x 1110 | 1111 | parseSwiInl :: Parser Term 1112 | parseSwiInl = withSrc $ do 1113 | string_skp "switch " 1114 | x <- parseTerm 1115 | char_skp '{' 1116 | cse <- parseSwiCases 1117 | char '}' 1118 | return $ App cse x 1119 | 1120 | -- Nat 1121 | -- --- 1122 | 1123 | parseNat :: Parser Term 1124 | parseNat = withSrc $ do 1125 | char_skp '#' 1126 | num <- P.many1 digit 1127 | return $ Nat (read num) 1128 | 1129 | -- Flattener 1130 | -- --------- 1131 | 1132 | -- FIXME: the functions below are still a little bit messy and can be improved 1133 | 1134 | -- Flattener for pattern matching equations 1135 | flattenDef :: [Rule] -> Int -> Term 1136 | flattenDef rules depth = 1137 | let (pats, bods) = unzip rules 1138 | in flattenRules pats bods depth 1139 | 1140 | flattenWith :: Int -> [Term] -> [Rule] -> Term 1141 | flattenWith dep wth rul = 1142 | -- Wrap the 'with' arguments and patterns in Pairs since the type checker only takes one match argument. 1143 | let wthA = foldr1 (\x acc -> Ann True (Con "Pair" [(Nothing, x), (Nothing, acc)]) (App (App (Ref "Pair") (Met 0 [])) (Met 0 []))) wth 1144 | rulA = map (\(pat, wth) -> ([foldr1 (\x acc -> PCtr Nothing "Pair" [x, acc]) pat], wth)) rul 1145 | bod = flattenDef rulA (dep + 1) 1146 | in App bod wthA 1147 | 1148 | flattenRules :: [[Pattern]] -> [Term] -> Int -> Term 1149 | flattenRules ([]:mat) (bod:bods) depth = bod 1150 | flattenRules (pats:mat) (bod:bods) depth 1151 | | all isVar col = flattenVarCol col mat' (bod:bods) (depth + 1) 1152 | | not (null (getColCtrs col)) = flattenAdtCol col mat' (bod:bods) (depth + 1) 1153 | | isJust (fst (getColSucc col)) = flattenNumCol col mat' (bod:bods) (depth + 1) 1154 | | otherwise = error "invalid pattern matching function" 1155 | where (col,mat') = getCol (pats:mat) 1156 | flattenRules _ _ _ = error "internal error" 1157 | 1158 | -- Flattens a column with only variables 1159 | flattenVarCol :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Term 1160 | flattenVarCol col mat bods depth = 1161 | -- trace (replicate (depth * 2) ' ' ++ "flattenVarCol: col = " ++ show col ++ ", depth = " ++ show depth) $ 1162 | let nam = maybe "_" id (getVarColName col) 1163 | bod = flattenRules mat bods depth 1164 | in Lam nam (\x -> bod) 1165 | 1166 | -- Flattens a column with constructors and possibly variables 1167 | flattenAdtCol :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Term 1168 | flattenAdtCol col mat bods depth = 1169 | -- trace (replicate (depth * 2) ' ' ++ "flattenAdtCol: col = " ++ show col ++ ", depth = " ++ show depth) $ 1170 | let ctr = map (makeCtrCase col mat bods depth) (getColCtrs col) 1171 | dfl = makeDflCase col mat bods depth 1172 | nam = getMatNam col 1173 | in case nam of 1174 | (Just nam) -> (Lam nam (\x -> App (Mat (ctr++dfl)) (Ref nam))) 1175 | Nothing -> Mat (ctr++dfl) 1176 | 1177 | -- Creates a constructor case: '#Name: body' 1178 | makeCtrCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> String -> (String, Term) 1179 | makeCtrCase col mat bods depth ctr = 1180 | -- trace (replicate (depth * 2) ' ' ++ "makeCtrCase: col = " ++ show col ++ ", mat = " ++ show mat ++ ", bods = " ++ show (map showTerm bods) ++ ", depth = " ++ show depth ++ ", ctr = " ++ ctr) $ 1181 | let var = getCtrColNames col ctr 1182 | (mat', bods') = foldr (go var) ([], []) (zip3 col mat bods) 1183 | bod = flattenRules mat' bods' (depth + 1) 1184 | in (ctr, bod) 1185 | where go var ((PCtr nam cnam ps), pats, bod) (mat, bods) 1186 | | cnam == ctr = ((ps ++ pats):mat, bod:bods) 1187 | | otherwise = (mat, bods) 1188 | go var ((PVar "_"), pats, bod) (mat, bods) = 1189 | let pat = map (maybe (PVar "_") PVar) var 1190 | in ((pat ++ pats):mat, bod:bods) 1191 | go var ((PVar nam), pats, bod) (mat, bods) = 1192 | let vr2 = [maybe (nam++"."++show i) id vr | (vr, i) <- zip var [0..]] 1193 | pat = map PVar vr2 1194 | bo2 = Use nam (Con ctr (map (\x -> (Nothing, Ref x)) vr2)) (\x -> bod) 1195 | in ((pat ++ pats):mat, bo2:bods) 1196 | go var (_, pats, bod) (mat, bods) = 1197 | (mat, bods) 1198 | 1199 | -- Creates a default case: '#_: body' 1200 | makeDflCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> [(String, Term)] 1201 | makeDflCase col mat bods depth = 1202 | -- trace (replicate (depth * 2) ' ' ++ "makeDflCase: col = " ++ show col ++ ", depth = " ++ show depth) $ 1203 | let (mat', bods') = foldr go ([], []) (zip3 col mat bods) in 1204 | if null bods' then [] else [("_", flattenRules mat' bods' (depth + 1))] 1205 | where go ((PVar nam), pats, bod) (mat, bods) = (((PVar nam):pats):mat, bod:bods) 1206 | go (_, pats, bod) (mat, bods) = (mat, bods) 1207 | 1208 | flattenNumCol :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Term 1209 | flattenNumCol col mat bods depth = 1210 | -- Find the succ case with the value 1211 | let (suc, var) = getColSucc col 1212 | sucA = fromJust suc 1213 | varA = maybe ("%n-" ++ show sucA) id var 1214 | numCs = map (makeNumCase col mat bods depth) [0..sucA-1] 1215 | sucCs = (makeSucCase col mat bods depth sucA varA) 1216 | in foldr (\x acc -> Swi x acc) sucCs numCs 1217 | 1218 | makeNumCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Word64 -> Term 1219 | makeNumCase col mat bods depth num = 1220 | let (mat', bods') = foldr go ([], []) (zip3 col mat bods) 1221 | in if null bods' then error $ "missing case for " ++ show num 1222 | else (flattenRules mat' bods' (depth + 1)) 1223 | where go ((PNum val), pats, bod) (mat, bods) 1224 | | val == num = (pats:mat, bod:bods) 1225 | | otherwise = (mat, bods) 1226 | go ((PVar "_"), pats, bod) (mat, bods) = 1227 | (pats:mat, bod:bods) 1228 | go ((PVar nam), pats, bod) (mat, bods) = 1229 | let bod' = Use nam (Num num) (\x -> bod) 1230 | in (pats:mat, bod':bods) 1231 | go (_, pats, bod) (mat, bods) = 1232 | (mat, bods) 1233 | 1234 | makeSucCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Word64 -> String -> Term 1235 | makeSucCase col mat bods depth suc var = 1236 | let (mat', bods') = foldr go ([], []) (zip3 col mat bods) 1237 | bod = if null bods' then error $ "missing case for " ++ show suc ++ "+" ++ var 1238 | else (flattenRules mat' bods' (depth + 1)) 1239 | in Lam var (\x -> bod) 1240 | where go ((PSuc _ _), pats, bod) (mat, bods) = (pats:mat, bod:bods) 1241 | go ((PVar "_"), pats, bod) (mat, bods) = (pats:mat, bod:bods) 1242 | go ((PVar nam), pats, bod) (mat, bods) = 1243 | let bodA = Use nam (Op2 ADD (Num suc) (Ref var)) (\x -> bod) 1244 | in (pats:mat, bodA:bods) 1245 | go (_, pats, bod) (mat, bods) = (mat, bods) 1246 | 1247 | -- Helper Functions 1248 | 1249 | isVar :: Pattern -> Bool 1250 | isVar (PVar _) = True 1251 | isVar _ = False 1252 | 1253 | getCol :: [[Pattern]] -> ([Pattern], [[Pattern]]) 1254 | getCol (pats:mat) = unzip (catMaybes (map uncons (pats:mat))) 1255 | 1256 | getColCtrs :: [Pattern] -> [String] 1257 | getColCtrs col = toList . fromList $ foldr (\pat acc -> case pat of (PCtr _ cnam _) -> cnam:acc ; _ -> acc) [] col 1258 | 1259 | getVarColName :: [Pattern] -> Maybe String 1260 | getVarColName col = foldr (A.<|>) Nothing $ map go col 1261 | where go (PVar "_") = Nothing 1262 | go (PVar nam) = Just nam 1263 | go _ = Nothing 1264 | 1265 | -- For a column of patterns that will become a Mat, 1266 | -- return the name of the inner fields or Nothing if they are also Mats. 1267 | getCtrColNames :: [Pattern] -> String -> [Maybe String] 1268 | getCtrColNames col ctr = 1269 | let mat = foldr go [] col 1270 | in map getVarColName (transpose mat) 1271 | where go (PCtr nam cnam ps) acc 1272 | | cnam == ctr = ps:acc 1273 | | otherwise = acc 1274 | go _ acc = acc 1275 | 1276 | getMatNam :: [Pattern] -> Maybe String 1277 | getMatNam (PCtr (Just nam) _ _:_) = Just nam 1278 | getMatNam (_:col) = getMatNam col 1279 | getMatNam [] = Nothing 1280 | 1281 | -- If theres a PSuc, it returns (Just val, Just nam) 1282 | -- If there a PNum a PVar but no PSuc, it returns (Just (max val + 1), Nothing) 1283 | -- Otherwise, it returns (Nothing, Nothing) 1284 | getColSucc :: [Pattern] -> (Maybe Word64, Maybe String) 1285 | getColSucc pats = 1286 | case findSuc pats of 1287 | Just (val, name) -> (Just val, Just name) 1288 | Nothing -> case (maxNum pats Nothing) of 1289 | Just maxVal -> (Just (maxVal + 1), Nothing) 1290 | Nothing -> (Nothing, Nothing) 1291 | where 1292 | findSuc [] = Nothing 1293 | findSuc (PSuc val name:_) = Just (val, name) 1294 | findSuc (_:rest) = findSuc rest 1295 | 1296 | maxNum [] acc = acc 1297 | maxNum (PNum val:ps) Nothing = maxNum ps (Just val) 1298 | maxNum (PNum val:ps) (Just max) = maxNum ps (Just (if val > max then val else max)) 1299 | maxNum (_:ps) acc = maxNum ps acc 1300 | -------------------------------------------------------------------------------- /src/Kind/Reduce.hs: -------------------------------------------------------------------------------- 1 | -- //./Type.hs// 2 | 3 | module Kind.Reduce where 4 | 5 | import Prelude hiding (EQ, LT, GT) 6 | import Data.Bits ( (.&.), (.|.), xor, shiftL, shiftR ) 7 | import Data.Char (ord) 8 | import Data.Fixed (mod') 9 | import Debug.Trace 10 | import Kind.Show 11 | import Kind.Type 12 | 13 | import qualified Data.Map.Strict as M 14 | import qualified Data.IntMap.Strict as IM 15 | 16 | -- for exitting on undefined ref (should be handled better) 17 | import System.Exit (exitWith, ExitCode(ExitFailure)) 18 | import System.IO.Unsafe (unsafePerformIO) 19 | 20 | -- Evaluation 21 | -- ---------- 22 | 23 | -- Evaluates a term to weak normal form 24 | -- 'lv' defines when to expand refs: 0 = never, 1 = on redexes 25 | reduce :: Book -> Fill -> Int -> Term -> Term 26 | reduce book fill lv term = red term where 27 | 28 | red (App fun arg) = app (red fun) arg 29 | red (Ann chk val typ) = red val 30 | red (Ins val) = red val 31 | red (Ref nam) = ref nam 32 | red (Let nam val bod) = red (bod (red val)) 33 | red (Use nam val bod) = red (bod (red val)) 34 | red (Op2 opr fst snd) = op2 opr (red fst) (red snd) 35 | red (Txt val) = txt val 36 | red (Lst val) = lst val 37 | red (Nat val) = nat val 38 | red (Src src val) = red val 39 | red (Met uid spn) = met uid spn 40 | red (Log msg nxt) = log msg nxt 41 | red (Get g n m k b) = get g n (red m) (red k) b 42 | red (Put g n m k v b) = put g n (red m) (red k) v b 43 | red val = val 44 | 45 | app (Ref nam) arg | lv > 0 = app (ref nam) arg 46 | app (Met uid spn) arg = red (Met uid (spn ++ [arg])) 47 | app (Lam nam bod) arg = red (bod (reduce book fill 0 arg)) 48 | app (Mat cse) arg = mat cse (red arg) 49 | app (Swi zer suc) arg = swi zer suc (red arg) 50 | app fun arg = App fun arg 51 | 52 | mat cse (Con cnam carg) = case lookup cnam cse of 53 | Just cx -> red (foldl App cx (map snd carg)) 54 | Nothing -> case lookup "_" cse of 55 | Just df -> red (App df (Con cnam carg)) 56 | Nothing -> error $ "Constructor " ++ cnam ++ " not found in pattern match and no default case '_' provided :" ++ (showTermGo True (Mat cse) 0) 57 | mat cse arg = App (Mat cse) arg 58 | 59 | swi zer suc (Num 0) = red zer 60 | swi zer suc (Num n) = red (App suc (Num (n - 1))) 61 | swi zer suc (Op2 ADD (Num 1) k) = red (App suc k) 62 | swi zer suc val = App (Swi zer suc) val 63 | 64 | met uid spn = case IM.lookup uid fill of 65 | Just val -> red (case spn of 66 | [] -> val 67 | (x : xs) -> foldl App val spn) 68 | Nothing -> Met uid spn 69 | 70 | op2 op (Ref nam) (Num snd) | lv > 0 = op2 op (ref nam) (Num snd) 71 | op2 op (Num fst) (Ref nam) | lv > 0 = op2 op (Num fst) (ref nam) 72 | op2 ADD (Num fst) (Num snd) = Num (fst + snd) 73 | op2 SUB (Num fst) (Num snd) = Num (fst - snd) 74 | op2 MUL (Num fst) (Num snd) = Num (fst * snd) 75 | op2 DIV (Num fst) (Num snd) = Num (div fst snd) 76 | op2 MOD (Num fst) (Num snd) = Num (mod fst snd) 77 | op2 EQ (Num fst) (Num snd) = Num (if fst == snd then 1 else 0) 78 | op2 NE (Num fst) (Num snd) = Num (if fst /= snd then 1 else 0) 79 | op2 LT (Num fst) (Num snd) = Num (if fst < snd then 1 else 0) 80 | op2 GT (Num fst) (Num snd) = Num (if fst > snd then 1 else 0) 81 | op2 LTE (Num fst) (Num snd) = Num (if fst <= snd then 1 else 0) 82 | op2 GTE (Num fst) (Num snd) = Num (if fst >= snd then 1 else 0) 83 | op2 AND (Num fst) (Num snd) = Num (fst .&. snd) 84 | op2 OR (Num fst) (Num snd) = Num (fst .|. snd) 85 | op2 XOR (Num fst) (Num snd) = Num (fst `xor` snd) 86 | op2 LSH (Num fst) (Num snd) = Num (shiftL fst (fromIntegral snd)) 87 | op2 RSH (Num fst) (Num snd) = Num (shiftR fst (fromIntegral snd)) 88 | op2 op (Ref nam) (Flt snd) | lv > 0 = op2 op (ref nam) (Flt snd) 89 | op2 op (Flt fst) (Ref nam) | lv > 0 = op2 op (Flt fst) (ref nam) 90 | op2 ADD (Flt fst) (Flt snd) = Flt (fst + snd) 91 | op2 SUB (Flt fst) (Flt snd) = Flt (fst - snd) 92 | op2 MUL (Flt fst) (Flt snd) = Flt (fst * snd) 93 | op2 DIV (Flt fst) (Flt snd) = Flt (fst / snd) 94 | op2 MOD (Flt fst) (Flt snd) = Flt (mod' fst snd) 95 | op2 EQ (Flt fst) (Flt snd) = Num (if fst == snd then 1 else 0) 96 | op2 NE (Flt fst) (Flt snd) = Num (if fst /= snd then 1 else 0) 97 | op2 LT (Flt fst) (Flt snd) = Num (if fst < snd then 1 else 0) 98 | op2 GT (Flt fst) (Flt snd) = Num (if fst > snd then 1 else 0) 99 | op2 LTE (Flt fst) (Flt snd) = Num (if fst <= snd then 1 else 0) 100 | op2 GTE (Flt fst) (Flt snd) = Num (if fst >= snd then 1 else 0) 101 | op2 AND (Flt _) (Flt _) = error "Bitwise AND not supported for floating-point numbers" 102 | op2 OR (Flt _) (Flt _) = error "Bitwise OR not supported for floating-point numbers" 103 | op2 XOR (Flt _) (Flt _) = error "Bitwise XOR not supported for floating-point numbers" 104 | op2 opr fst snd = Op2 opr fst snd 105 | 106 | ref nam | lv > 0 = case M.lookup nam book of 107 | Just val -> red val 108 | Nothing -> Con ("undefined-reference:"++nam) [] 109 | ref nam = Ref nam 110 | 111 | txt [] = red (Con "Nil" []) 112 | txt (x:xs) = red (Con "Cons" [(Nothing, Num (toEnum (ord x))), (Nothing, Txt xs)]) 113 | 114 | lst [] = red (Con "Nil" []) 115 | lst (x:xs) = red (Con "Cons" [(Nothing, x), (Nothing, Lst xs)]) 116 | 117 | nat 0 = Con "Zero" [] 118 | nat n = Con "Succ" [(Nothing, Nat (n - 1))] 119 | 120 | log msg nxt = logMsg book fill lv msg msg nxt "" 121 | 122 | get g n (KVs kvs d) (Num k) b = case IM.lookup (fromIntegral k) kvs of 123 | Just v -> red (b v (KVs kvs d)) 124 | Nothing -> red (b d (KVs kvs d)) 125 | get g n m k b = Get g n m k b 126 | 127 | put g n (KVs kvs d) (Num k) v b = case IM.lookup (fromIntegral k) kvs of 128 | Just o -> red (b o (KVs (IM.insert (fromIntegral k) v kvs) d)) 129 | Nothing -> red (b d (KVs (IM.insert (fromIntegral k) v kvs) d)) 130 | put g n m k v b = Put g n m k v b 131 | 132 | -- Logging 133 | -- ------- 134 | 135 | logMsg :: Book -> Fill -> Int -> Term -> Term -> Term -> String -> Term 136 | logMsg book fill lv msg' msg nxt txt = 137 | case (reduce book fill 2 msg) of 138 | Con "Cons" [(_, head), (_, tail)] -> case (reduce book fill lv head) of 139 | Num chr -> logMsg book fill lv msg' tail nxt (txt ++ [toEnum (fromIntegral chr)]) 140 | _ -> trace (">> " ++ (showTerm (normal book fill 1 msg' 0))) $ (reduce book fill lv nxt) 141 | Con "Nil" [] -> 142 | trace txt (reduce book fill lv nxt) 143 | bad -> 144 | trace (">> " ++ (showTerm (normal book fill 1 msg' 0))) $ (reduce book fill lv nxt) 145 | 146 | -- Normalization 147 | -- ------------- 148 | 149 | -- Evaluates a term to full normal form 150 | normal :: Book -> Fill -> Int -> Term -> Int -> Term 151 | normal book fill lv term dep = go (reduce book fill lv term) dep where 152 | go (All nam inp bod) dep = 153 | let nf_inp = normal book fill lv inp dep in 154 | let nf_bod = \x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in 155 | All nam nf_inp nf_bod 156 | go (Lam nam bod) dep = 157 | let nf_bod = \x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in 158 | Lam nam nf_bod 159 | go (App fun arg) dep = 160 | let nf_fun = normal book fill lv fun dep in 161 | let nf_arg = normal book fill lv arg dep in 162 | App nf_fun nf_arg 163 | go (Ann chk val typ) dep = 164 | let nf_val = normal book fill lv val dep in 165 | let nf_typ = normal book fill lv typ dep in 166 | Ann chk nf_val nf_typ 167 | go (Slf nam typ bod) dep = 168 | let nf_bod = \x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in 169 | Slf nam typ nf_bod 170 | go (Ins val) dep = 171 | let nf_val = normal book fill lv val dep in 172 | Ins nf_val 173 | go (ADT scp cts typ) dep = 174 | let go_ctr = (\ (Ctr nm tele) -> 175 | let nf_tele = normalTele book fill lv tele dep in 176 | Ctr nm nf_tele) in 177 | let nf_scp = map (\x -> normal book fill lv x dep) scp in 178 | let nf_cts = map go_ctr cts in 179 | let nf_typ = normal book fill lv typ dep in 180 | ADT nf_scp nf_cts nf_typ 181 | go (Con nam arg) dep = 182 | let nf_arg = map (\(f, t) -> (f, normal book fill lv t dep)) arg in 183 | Con nam nf_arg 184 | go (Mat cse) dep = 185 | let nf_cse = map (\(cnam, cbod) -> (cnam, normal book fill lv cbod dep)) cse in 186 | Mat nf_cse 187 | go (Swi zer suc) dep = 188 | let nf_zer = normal book fill lv zer dep in 189 | let nf_suc = normal book fill lv suc dep in 190 | Swi nf_zer nf_suc 191 | go (Ref nam) dep = Ref nam 192 | go (Let nam val bod) dep = 193 | let nf_val = normal book fill lv val dep in 194 | let nf_bod = \x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in 195 | Let nam nf_val nf_bod 196 | go (Use nam val bod) dep = 197 | let nf_val = normal book fill lv val dep in 198 | let nf_bod = \x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in 199 | Use nam nf_val nf_bod 200 | go (Hol nam ctx) dep = Hol nam ctx 201 | go Set dep = Set 202 | go U64 dep = U64 203 | go F64 dep = F64 204 | go (Num val) dep = Num val 205 | go (Flt val) dep = Flt val 206 | go (Op2 opr fst snd) dep = 207 | let nf_fst = normal book fill lv fst dep in 208 | let nf_snd = normal book fill lv snd dep in 209 | Op2 opr nf_fst nf_snd 210 | go (Map typ) dep = 211 | let nf_typ = normal book fill lv typ dep in 212 | Map nf_typ 213 | go (KVs kvs def) dep = 214 | let nf_kvs = IM.map (\x -> normal book fill lv x dep) kvs in 215 | let nf_def = normal book fill lv def dep in 216 | KVs nf_kvs nf_def 217 | go (Get g n m k b) dep = 218 | let nf_m = normal book fill lv m dep in 219 | let nf_k = normal book fill lv k dep in 220 | let nf_b = \v s -> normal book fill lv (b (Var g dep) (Var n dep)) (dep + 2) in 221 | Get g n nf_m nf_k nf_b 222 | go (Put g n m k v b) dep = 223 | let nf_m = normal book fill lv m dep in 224 | let nf_k = normal book fill lv k dep in 225 | let nf_v = normal book fill lv v dep in 226 | let nf_b = \o s -> normal book fill lv (b (Var g dep) (Var n dep)) (dep + 2) in 227 | Put g n nf_m nf_k nf_v nf_b 228 | go (Txt val) dep = Txt val 229 | go (Lst val) dep = 230 | let nf_val = map (\x -> normal book fill lv x dep) val in 231 | Lst nf_val 232 | go (Nat val) dep = Nat val 233 | go (Var nam idx) dep = Var nam idx 234 | go (Src src val) dep = 235 | let nf_val = normal book fill lv val dep in 236 | Src src nf_val 237 | go (Met uid spn) dep = Met uid spn -- TODO: normalize spine 238 | go (Log msg nxt) dep = 239 | let nf_msg = normal book fill lv msg dep in 240 | let nf_nxt = normal book fill lv nxt dep in 241 | Log nf_msg nf_nxt 242 | 243 | normalTele :: Book -> Fill -> Int -> Tele -> Int -> Tele 244 | normalTele book fill lv tele dep = case tele of 245 | TRet term -> 246 | let nf_term = normal book fill lv term dep in 247 | TRet nf_term 248 | TExt nam typ bod -> 249 | let nf_typ = normal book fill lv typ dep in 250 | let nf_bod = \x -> normalTele book fill lv (bod (Var nam dep)) (dep + 1) in 251 | TExt nam nf_typ nf_bod 252 | 253 | -- Binding 254 | -- ------- 255 | 256 | -- Binds quoted variables to bound HOAS variables 257 | bind :: Term -> [(String,Term)] -> Term 258 | bind (All nam inp bod) ctx = 259 | let inp' = bind inp ctx in 260 | let bod' = \x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in 261 | All nam inp' bod' 262 | bind (Lam nam bod) ctx = 263 | let bod' = \x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in 264 | Lam nam bod' 265 | bind (App fun arg) ctx = 266 | let fun' = bind fun ctx in 267 | let arg' = bind arg ctx in 268 | App fun' arg' 269 | bind (Ann chk val typ) ctx = 270 | let val' = bind val ctx in 271 | let typ' = bind typ ctx in 272 | Ann chk val' typ' 273 | bind (Slf nam typ bod) ctx = 274 | let typ' = bind typ ctx in 275 | let bod' = \x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in 276 | Slf nam typ' bod' 277 | bind (Ins val) ctx = 278 | let val' = bind val ctx in 279 | Ins val' 280 | bind (ADT scp cts typ) ctx = 281 | let scp' = map (\x -> bind x ctx) scp in 282 | let cts' = map (\x -> bindCtr x ctx) cts in 283 | let typ' = bind typ ctx in 284 | ADT scp' cts' typ' 285 | where 286 | bindCtr (Ctr nm tele) ctx = Ctr nm (bindTele tele ctx) 287 | bindTele (TRet term) ctx = TRet (bind term ctx) 288 | bindTele (TExt nam typ bod) ctx = TExt nam (bind typ ctx) $ \x -> bindTele (bod x) ((nam, x) : ctx) -- FIXME: 'bod x'? 289 | bind (Con nam arg) ctx = 290 | let arg' = map (\(f, x) -> (f, bind x ctx)) arg in 291 | Con nam arg' 292 | bind (Mat cse) ctx = 293 | let cse' = map (\(cn,cb) -> (cn, bind cb ctx)) cse in 294 | Mat cse' 295 | bind (Swi zer suc) ctx = 296 | let zer' = bind zer ctx in 297 | let suc' = bind suc ctx in 298 | Swi zer' suc' 299 | bind (Map typ) ctx = 300 | let typ' = bind typ ctx in 301 | Map typ' 302 | bind (KVs kvs def) ctx = 303 | let kvs' = IM.map (\x -> bind x ctx) kvs in 304 | let def' = bind def ctx in 305 | KVs kvs' def' 306 | bind (Get g n m k b) ctx = 307 | let m' = bind m ctx in 308 | let k' = bind k ctx in 309 | let b' = \v s -> bind (b v s) ((n, s) : (g, v) : ctx) in 310 | Get g n m' k' b' 311 | bind (Put g n m k v b) ctx = 312 | let m' = bind m ctx in 313 | let k' = bind k ctx in 314 | let v' = bind v ctx in 315 | let b' = \o s -> bind (b o s) ((n, s) : (g, o) : ctx) in 316 | Put g n m' k' v' b' 317 | bind (Ref nam) ctx = 318 | case lookup nam ctx of 319 | Just x -> x 320 | Nothing -> Ref nam 321 | bind (Let nam val bod) ctx = 322 | let val' = bind val ctx in 323 | let bod' = \x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in 324 | Let nam val' bod' 325 | bind (Use nam val bod) ctx = 326 | let val' = bind val ctx in 327 | let bod' = \x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in 328 | Use nam val' bod' 329 | bind Set ctx = Set 330 | bind U64 ctx = U64 331 | bind F64 ctx = F64 332 | bind (Num val) ctx = Num val 333 | bind (Flt val) ctx = Flt val 334 | bind (Op2 opr fst snd) ctx = 335 | let fst' = bind fst ctx in 336 | let snd' = bind snd ctx in 337 | Op2 opr fst' snd' 338 | bind (Txt txt) ctx = Txt txt 339 | bind (Lst lst) ctx = 340 | let lst' = map (\x -> bind x ctx) lst in 341 | Lst lst' 342 | bind (Nat val) ctx = Nat val 343 | bind (Hol nam ctxs) ctx = Hol nam (reverse (map snd ctx)) 344 | bind (Met uid spn) ctx = Met uid [] 345 | bind (Log msg nxt) ctx = 346 | let msg' = bind msg ctx in 347 | let nxt' = bind nxt ctx in 348 | Log msg' nxt' 349 | bind (Var nam idx) ctx = 350 | case lookup nam ctx of 351 | Just x -> x 352 | Nothing -> Var nam idx 353 | bind (Src src val) ctx = 354 | let val' = bind val ctx in 355 | Src src val' 356 | 357 | genMetas :: Term -> Term 358 | genMetas term = fst (genMetasGo term 0) 359 | 360 | genMetasGo :: Term -> Int -> (Term, Int) 361 | genMetasGo (All nam inp bod) c = 362 | let (inp', c1) = genMetasGo inp c 363 | (bod', c2) = genMetasGo (bod (Var nam 0)) c1 364 | in (All nam inp' (\_ -> bod'), c2) 365 | genMetasGo (Lam nam bod) c = 366 | let (bod', c1) = genMetasGo (bod (Var nam 0)) c 367 | in (Lam nam (\_ -> bod'), c1) 368 | genMetasGo (App fun arg) c = 369 | let (fun', c1) = genMetasGo fun c 370 | (arg', c2) = genMetasGo arg c1 371 | in (App fun' arg', c2) 372 | genMetasGo (Ann chk val typ) c = 373 | let (val', c1) = genMetasGo val c 374 | (typ', c2) = genMetasGo typ c1 375 | in (Ann chk val' typ', c2) 376 | genMetasGo (Slf nam typ bod) c = 377 | let (typ', c1) = genMetasGo typ c 378 | (bod', c2) = genMetasGo (bod (Var nam 0)) c1 379 | in (Slf nam typ' (\_ -> bod'), c2) 380 | genMetasGo (Ins val) c = 381 | let (val', c1) = genMetasGo val c 382 | in (Ins val', c1) 383 | genMetasGo (ADT scp cts typ) c = 384 | let (scp', c1) = foldr (\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) scp 385 | (cts', c2) = foldr (\(Ctr nm tele) (acc, c') -> let (tele', c'') = genMetasGoTele tele c' in (Ctr nm tele' : acc, c'')) ([], c1) cts 386 | (typ', c3) = genMetasGo typ c2 387 | in (ADT scp' cts' typ', c3) 388 | genMetasGo (Con nam arg) c = 389 | let (arg', c1) = foldr (\(f, t) (acc, c') -> let (t', c'') = genMetasGo t c' in ((f, t'):acc, c'')) ([], c) arg 390 | in (Con nam arg', c1) 391 | genMetasGo (Mat cse) c = 392 | let (cse', c1) = foldr (\(cn, cb) (acc, c') -> let (cb', c'') = genMetasGo cb c' in ((cn, cb'):acc, c'')) ([], c) cse 393 | in (Mat cse', c1) 394 | genMetasGo (Swi zer suc) c = 395 | let (zer', c1) = genMetasGo zer c 396 | (suc', c2) = genMetasGo suc c1 397 | in (Swi zer' suc', c2) 398 | genMetasGo (Map typ) c = 399 | let (typ', c1) = genMetasGo typ c 400 | in (Map typ', c1) 401 | genMetasGo (KVs kvs def) c = 402 | let (def', c1) = genMetasGo def c 403 | (kvs', c2) = foldr (\ (k, t) (acc, c') -> let (t', c'') = genMetasGo t c' in (IM.insert k t' acc, c'')) (IM.empty, c1) (IM.toList kvs) 404 | in (KVs kvs' def', c2) 405 | genMetasGo (Get g n m k b) c = 406 | let (m', c1) = genMetasGo m c 407 | (k', c2) = genMetasGo k c1 408 | (b', c3) = genMetasGo (b (Var g 0) (Var n 0)) c2 409 | in (Get g n m' k' (\_ _ -> b'), c3) 410 | genMetasGo (Put g n m k v b) c = 411 | let (m', c1) = genMetasGo m c 412 | (k', c2) = genMetasGo k c1 413 | (v', c3) = genMetasGo v c2 414 | (b', c4) = genMetasGo (b (Var g 0) (Var n 0)) c3 415 | in (Put g n m' k' v' (\_ _ -> b'), c4) 416 | genMetasGo (Let nam val bod) c = 417 | let (val', c1) = genMetasGo val c 418 | (bod', c2) = genMetasGo (bod (Var nam 0)) c1 419 | in (Let nam val' (\_ -> bod'), c2) 420 | genMetasGo (Use nam val bod) c = 421 | let (val', c1) = genMetasGo val c 422 | (bod', c2) = genMetasGo (bod (Var nam 0)) c1 423 | in (Use nam val' (\_ -> bod'), c2) 424 | genMetasGo (Met _ spn) c = 425 | let (spn', c1) = foldr (\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) spn 426 | in (Met c1 spn', c1 + 1) 427 | genMetasGo (Op2 opr fst snd) c = 428 | let (fst', c1) = genMetasGo fst c 429 | (snd', c2) = genMetasGo snd c1 430 | in (Op2 opr fst' snd', c2) 431 | genMetasGo (Lst lst) c = 432 | let (lst', c1) = foldr (\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) lst 433 | in (Lst lst', c1) 434 | genMetasGo (Log msg nxt) c = 435 | let (msg', c1) = genMetasGo msg c 436 | (nxt', c2) = genMetasGo nxt c1 437 | in (Log msg' nxt', c2) 438 | genMetasGo (Hol nam ctx) c = 439 | let (ctx', c1) = foldr (\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) ctx 440 | in (Hol nam ctx', c1) 441 | genMetasGo (Src src val) c = 442 | let (val', c1) = genMetasGo val c 443 | in (Src src val', c1) 444 | genMetasGo term c = (term, c) 445 | 446 | genMetasGoTele :: Tele -> Int -> (Tele, Int) 447 | genMetasGoTele (TRet term) c = 448 | let (term', c1) = genMetasGo term c 449 | in (TRet term', c1) 450 | genMetasGoTele (TExt nam typ bod) c = 451 | let (typ', c1) = genMetasGo typ c 452 | (bod', c2) = genMetasGoTele (bod (Var nam 0)) c1 453 | in (TExt nam typ' (\_ -> bod'), c2) 454 | 455 | countMetas :: Term -> Int 456 | countMetas term = snd (genMetasGo term 0) 457 | -------------------------------------------------------------------------------- /src/Kind/Show.hs: -------------------------------------------------------------------------------- 1 | -- //./Type.hs// 2 | 3 | module Kind.Show where 4 | 5 | import Prelude hiding (EQ, LT, GT) 6 | 7 | import Kind.Type 8 | 9 | import Debug.Trace 10 | import Data.Word 11 | 12 | import Control.Applicative ((<|>)) 13 | 14 | import qualified Data.Map.Strict as M 15 | import qualified Data.IntMap.Strict as IM 16 | 17 | -- Stringification 18 | -- --------------- 19 | 20 | showTermGo :: Bool -> Term -> Int -> String 21 | showTermGo small term dep = 22 | case pretty term of 23 | Just str -> str 24 | Nothing -> case term of 25 | All nam inp bod -> 26 | let nam' = nam 27 | inp' = showTermGo small inp dep 28 | bod' = showTermGo small (bod (Var nam dep)) (dep + 1) 29 | in concat ["∀(" , nam' , ": " , inp' , ") " , bod'] 30 | Lam nam bod -> 31 | let nam' = nam 32 | bod' = showTermGo small (bod (Var nam dep)) (dep + 1) 33 | in concat ["λ" , nam' , " " , bod'] 34 | App fun arg -> 35 | let (func, args) = unwrap fun [arg] 36 | func' = showTermGo small func dep 37 | args' = unwords (map (\x -> showTermGo small x dep) args) 38 | in concat ["(" , func' , " " , args' , ")"] 39 | where unwrap :: Term -> [Term] -> (Term, [Term]) 40 | unwrap (App fun arg) args = unwrap fun (arg:args) 41 | unwrap term args = (term, args) 42 | Ann chk val typ -> 43 | if small 44 | then showTermGo small val dep 45 | else let val' = showTermGo small val dep 46 | typ' = showTermGo small typ dep 47 | in concat ["{" , val' , ": " , typ' , "}"] 48 | Slf nam typ bod -> 49 | let nam' = nam 50 | typ' = showTermGo small typ dep 51 | bod' = showTermGo small (bod (Var nam dep)) (dep + 1) 52 | in concat ["$(" , nam' , ": " , typ' , ") " , bod'] 53 | Ins val -> 54 | let val' = showTermGo small val dep 55 | in concat ["~" , val'] 56 | -- CHANGED: Updated ADT case to use new Ctr structure 57 | ADT scp cts typ -> 58 | let scp' = unwords (map (\x -> showTermGo small x dep) scp) 59 | cts' = unwords (map (\(Ctr nm tele) -> "#" ++ nm ++ " " ++ showTeleGo small tele dep) cts) 60 | typ' = showTermGo small typ dep 61 | in concat ["#[", scp', "]{ ", cts', " } : ", typ'] 62 | Con nam arg -> 63 | let arg' = unwords (map showArg arg) 64 | in concat ["#", nam, "{", arg', "}"] 65 | where 66 | showArg (maybeField, term) = case maybeField of 67 | Just field -> field ++ ": " ++ showTermGo small term dep 68 | Nothing -> showTermGo small term dep 69 | Mat cse -> 70 | let cse' = unwords (map (\(cnm, cbod) -> "#" ++ cnm ++ ": " ++ showTermGo small cbod dep) cse) 71 | in concat ["λ{ ", cse', " }"] 72 | -- Ref nam -> concat ["@", nam] 73 | Ref nam -> concat [nam] 74 | Let nam val bod -> 75 | let nam' = nam 76 | val' = showTermGo small val dep 77 | bod' = showTermGo small (bod (Var nam dep)) (dep + 1) 78 | in concat ["let " , nam' , " = " , val' , " " , bod'] 79 | Use nam val bod -> 80 | let nam' = nam 81 | val' = showTermGo small val dep 82 | bod' = showTermGo small (bod (Var nam dep)) (dep + 1) 83 | in concat ["use " , nam' , " = " , val' , " " , bod'] 84 | Set -> "*" 85 | U64 -> "U64" 86 | F64 -> "F64" 87 | Num val -> 88 | let val' = show val 89 | in concat [val'] 90 | Flt val -> 91 | let val' = show val 92 | in concat [val'] 93 | Op2 opr fst snd -> 94 | let opr' = showOper opr 95 | fst' = showTermGo small fst dep 96 | snd' = showTermGo small snd dep 97 | in concat ["(" , opr' , " " , fst' , " " , snd' , ")"] 98 | Swi zero succ -> 99 | let zero' = showTermGo small zero dep 100 | succ' = showTermGo small succ dep 101 | in concat ["λ{ 0: ", zero', " _: ", succ', " }"] 102 | Map typ -> 103 | let typ' = showTermGo small typ dep 104 | in concat ["(Map ", typ', ")"] 105 | KVs kvs def -> 106 | let kvs' = unwords (map (\(k, v) -> show k ++ ":" ++ showTermGo small v dep) (IM.toList kvs)) 107 | def' = showTermGo small def dep 108 | in concat ["{", kvs', " | ", def', "}"] 109 | Get got nam map key bod -> 110 | let got' = got 111 | nam' = nam 112 | map' = showTermGo small map dep 113 | key' = showTermGo small key dep 114 | bod' = showTermGo small (bod (Var got dep) (Var nam dep)) (dep + 2) 115 | in concat ["get ", got', " = ", nam', "@", map', "[", key', "] ", bod'] 116 | Put got nam map key val bod -> 117 | let got' = got 118 | nam' = nam 119 | map' = showTermGo small map dep 120 | key' = showTermGo small key dep 121 | val' = showTermGo small val dep 122 | bod' = showTermGo small (bod (Var got dep) (Var nam dep)) (dep + 2) 123 | in concat ["put ", got', " = ", nam', "@", map', "[", key', "] := ", val', " ", bod'] 124 | Txt txt -> concat ["\"" , txt , "\""] 125 | Lst lst -> concat ["[", unwords (map (\x -> showTermGo small x dep) lst), "]"] 126 | Nat val -> concat ["#", (show val)] 127 | Hol nam ctx -> concat ["?" , nam] 128 | -- Met uid spn -> concat ["_", show uid, "[", strSpn spn dep, " ]"] 129 | Met uid spn -> concat ["_", show uid] 130 | Log msg nxt -> 131 | let msg' = showTermGo small msg dep 132 | nxt' = showTermGo small nxt dep 133 | in concat ["log ", msg', " ", nxt'] 134 | Var nam idx -> nam 135 | Src src val -> if small 136 | then showTermGo small val dep 137 | else concat ["!", showTermGo small val dep] 138 | 139 | -- CHANGED: Added showTeleGo function 140 | showTeleGo :: Bool -> Tele -> Int -> String 141 | showTeleGo small tele dep = "{ " ++ go tele dep where 142 | go (TExt nam typ bod) dep = 143 | let typ' = showTermGo small typ dep 144 | bod' = go (bod (Var nam dep)) (dep + 1) 145 | in concat [nam, ": ", typ', " ", bod'] 146 | go (TRet term) dep = 147 | let term' = showTermGo small term dep 148 | in concat ["}: ", term'] 149 | 150 | showTele :: Tele -> String 151 | showTele tele = showTeleGo True tele 0 152 | 153 | showTerm :: Term -> String 154 | showTerm term = showTermGo True term 0 155 | 156 | strSpn :: [Term] -> Int -> String 157 | strSpn [] dep = "" 158 | strSpn (x : xs) dep = concat [" ", showTermGo True x dep, strSpn xs dep] 159 | 160 | showOper :: Oper -> String 161 | showOper ADD = "+" 162 | showOper SUB = "-" 163 | showOper MUL = "*" 164 | showOper DIV = "/" 165 | showOper MOD = "%" 166 | showOper EQ = "==" 167 | showOper NE = "!=" 168 | showOper LT = "<" 169 | showOper GT = ">" 170 | showOper LTE = "<=" 171 | showOper GTE = ">=" 172 | showOper AND = "&" 173 | showOper OR = "|" 174 | showOper XOR = "^" 175 | showOper LSH = "<<" 176 | showOper RSH = ">>" 177 | 178 | -- Pretty Printing (Sugars) 179 | -- ------------------------ 180 | 181 | pretty :: Term -> Maybe String 182 | pretty term = prettyString term <|> prettyNat term <|> prettyList term <|> prettyEqual term 183 | 184 | prettyString :: Term -> Maybe String 185 | prettyString (Con "View" [(_, term)]) = do 186 | chars <- prettyStringGo term 187 | return $ '"' : chars ++ "\"" 188 | prettyString _ = Nothing 189 | 190 | prettyStringGo :: Term -> Maybe String 191 | prettyStringGo (Con "Nil" []) = Just [] 192 | prettyStringGo (Con "Cons" [(_, Num head), (_, tail)]) = do 193 | rest <- prettyStringGo tail 194 | return $ toEnum (fromIntegral head) : rest 195 | prettyStringGo _ = Nothing 196 | 197 | prettyNat :: Term -> Maybe String 198 | prettyNat (Con "Zero" []) = Just "#0" 199 | prettyNat term = go 0 term where 200 | go n (Con "Succ" [(_, pred)]) = go (n + 1) pred 201 | go n (Con "Zero" []) = Just $ "#" ++ show n 202 | go _ _ = Nothing 203 | 204 | prettyList :: Term -> Maybe String 205 | prettyList term = do 206 | terms <- asList term 207 | return $ "[" ++ unwords (map (\x -> showTermGo True x 0) terms) ++ "]" 208 | where asList (Con "Nil" []) = do 209 | Just [] 210 | asList (Con "Cons" [(_, head), (_, tail)]) = do 211 | rest <- asList tail 212 | return (head : rest) 213 | asList _ = Nothing 214 | 215 | prettyEqual :: Term -> Maybe String 216 | prettyEqual (App (App (App (Ref "Equal") t) a) b) = do 217 | let a' = showTermGo True a 0 218 | b' = showTermGo True b 0 219 | return $ a' ++ " == " ++ b' 220 | prettyEqual _ = Nothing 221 | -------------------------------------------------------------------------------- /src/Kind/Type.hs: -------------------------------------------------------------------------------- 1 | module Kind.Type where 2 | 3 | import System.IO.Unsafe (unsafePerformIO) 4 | import qualified Data.IntMap.Strict as IM 5 | import qualified Data.Map.Strict as M 6 | 7 | import Debug.Trace 8 | import Data.Word (Word64) 9 | 10 | -- Kind's AST 11 | data Term 12 | -- Product: `∀(x: A) B` 13 | = All String Term (Term -> Term) 14 | 15 | -- Lambda: `λx f` 16 | | Lam String (Term -> Term) 17 | 18 | -- Application: `(fun arg)` 19 | | App Term Term 20 | 21 | -- Annotation: `{x: T}` 22 | | Ann Bool Term Term 23 | 24 | -- Self-Type: `$(x: A) B` 25 | | Slf String Term (Term -> Term) 26 | 27 | -- Self-Inst: `~x` 28 | | Ins Term 29 | 30 | -- Datatype: `#[i0 i1...]{ #C0 Tele0 #C1 Tele1 ... }` 31 | | ADT [Term] [Ctr] Term 32 | 33 | -- Constructor: `#CN { x0 x1 ... }` 34 | | Con String [(Maybe String, Term)] 35 | 36 | -- Lambda-Match: `λ{ #C0:B0 #C1:B1 ... }` 37 | | Mat [(String, Term)] 38 | 39 | -- Top-Level Reference: `Foo` 40 | | Ref String 41 | 42 | -- Local let-definition: `let x = val body` 43 | | Let String Term (Term -> Term) 44 | 45 | -- Local use-definition: `use x = val body` 46 | | Use String Term (Term -> Term) 47 | 48 | -- Universe: `Set` 49 | | Set 50 | 51 | -- U64 Type: `U64` 52 | | U64 53 | 54 | -- F64 Type: `F64` 55 | | F64 56 | 57 | -- U64 Value: `123` 58 | | Num Word64 59 | 60 | -- F64 Value: `1.5` 61 | | Flt Double 62 | 63 | -- Binary Operation: `(+ x y)` 64 | | Op2 Oper Term Term 65 | 66 | -- U64 Elimination: `λ{ 0:A 1+p:B }` 67 | | Swi Term Term 68 | 69 | -- Linear Map Type: `(Map T)` 70 | | Map Term 71 | 72 | -- Linear Map Value: `{ k0:v0 k1:v1 ... | default }` 73 | | KVs (IM.IntMap Term) Term 74 | 75 | -- Linear Map Getter: `get val = nam@map[key] bod` 76 | -- - got is the name of the obtained value 77 | -- - nam is the name of the map 78 | -- - map is the value of the map 79 | -- - key is the key to query 80 | -- - bod is the continuation; receives the value and the same map 81 | | Get String String Term Term (Term -> Term -> Term) 82 | 83 | -- Map Swapper: `put got = nam@map[key] := val body` 84 | -- - got is the name of the old value 85 | -- - nam is the name of the map 86 | -- - map is the value of the map 87 | -- - key is the key to swap 88 | -- - val is the val to insert 89 | -- - bod is the continuation; receives the old value and the changed map 90 | | Put String String Term Term Term (Term -> Term -> Term) 91 | 92 | -- Inspection Hole 93 | | Hol String [Term] 94 | 95 | -- Unification Metavar 96 | | Met Int [Term] 97 | 98 | -- Logging 99 | | Log Term Term 100 | 101 | -- Variable 102 | | Var String Int 103 | 104 | -- Source Location 105 | | Src Cod Term 106 | 107 | -- Text Literal (sugar) 108 | | Txt String 109 | 110 | -- List Literal (sugar) 111 | | Lst [Term] 112 | 113 | -- Nat Literal (sugar) 114 | | Nat Integer 115 | 116 | -- Substitution 117 | | Sub Term 118 | 119 | -- Location: Name, Line, Column 120 | data Loc = Loc String Int Int 121 | data Cod = Cod Loc Loc 122 | 123 | -- Numeric Operators 124 | data Oper 125 | = ADD | SUB | MUL | DIV 126 | | MOD | EQ | NE | LT 127 | | GT | LTE | GTE | AND 128 | | OR | XOR | LSH | RSH 129 | deriving Show 130 | 131 | -- Telescope 132 | data Tele 133 | = TRet Term 134 | | TExt String Term (Term -> Tele) 135 | 136 | -- Constructor 137 | data Ctr = Ctr String Tele 138 | 139 | -- Book of Definitions 140 | type Book = M.Map String Term 141 | 142 | -- Type-Checker Outputs 143 | data Info 144 | = Found String Term [Term] Int 145 | | Solve Int Term Int 146 | | Error (Maybe Cod) Term Term Term Int 147 | | Vague String 148 | | Print Term Int 149 | 150 | -- Unification Solutions 151 | type Fill = IM.IntMap Term 152 | 153 | -- Checker State 154 | data Check = Check (Maybe Cod) Term Term Int -- postponed check 155 | data State = State Book Fill [Check] [Info] -- state type 156 | data Res a = Done State a | Fail State -- result type 157 | data Env a = Env (State -> Res a) -- monadic checker 158 | 159 | -- UNCOMMENT THIS TO DEBUG THE TYPE CHECKER 160 | -- debug a b = trace a b 161 | debug a b = b 162 | -------------------------------------------------------------------------------- /src/Kind/Util.hs: -------------------------------------------------------------------------------- 1 | -- //./Type.hs// 2 | 3 | module Kind.Util where 4 | 5 | import Kind.Show 6 | import Kind.Type 7 | import Kind.Equal 8 | 9 | import Prelude hiding (LT, GT, EQ) 10 | 11 | import qualified Data.IntMap.Strict as IM 12 | import qualified Data.Map.Strict as M 13 | import qualified Data.Set as S 14 | 15 | import Debug.Trace 16 | 17 | -- Gets dependencies of a term 18 | getDeps :: Term -> [String] 19 | getDeps term = case term of 20 | Ref nam -> [nam] 21 | All _ inp out -> getDeps inp ++ getDeps (out Set) 22 | Lam _ bod -> getDeps (bod Set) 23 | App fun arg -> getDeps fun ++ getDeps arg 24 | Ann _ val typ -> getDeps val ++ getDeps typ 25 | Slf _ typ bod -> getDeps typ ++ getDeps (bod Set) 26 | Ins val -> getDeps val 27 | ADT scp cts t -> concatMap getDeps scp ++ concatMap getDepsCtr cts ++ getDeps t 28 | Con _ arg -> concatMap (getDeps . snd) arg 29 | Mat cse -> concatMap (getDeps . snd) cse 30 | Let _ val bod -> getDeps val ++ getDeps (bod Set) 31 | Use _ val bod -> getDeps val ++ getDeps (bod Set) 32 | Op2 _ fst snd -> getDeps fst ++ getDeps snd 33 | Swi zer suc -> getDeps zer ++ getDeps suc 34 | Map val -> getDeps val 35 | KVs kvs def -> concatMap getDeps (IM.elems kvs) ++ getDeps def 36 | Get _ _ m k b -> getDeps m ++ getDeps k ++ getDeps (b Set Set) 37 | Put _ _ m k v b -> getDeps m ++ getDeps k ++ getDeps v ++ getDeps (b Set Set) 38 | Src _ val -> getDeps val 39 | Hol _ args -> concatMap getDeps args 40 | Met _ args -> concatMap getDeps args 41 | Log msg nxt -> getDeps msg ++ getDeps nxt 42 | Var _ _ -> [] 43 | Set -> [] 44 | U64 -> [] 45 | F64 -> [] 46 | Num _ -> [] 47 | Flt _ -> [] 48 | Txt _ -> [] 49 | Lst elems -> concatMap getDeps elems 50 | Nat _ -> [] 51 | 52 | -- Gets dependencies of a constructor 53 | getDepsCtr :: Ctr -> [String] 54 | getDepsCtr (Ctr _ tele) = getDepsTele tele 55 | 56 | -- Gets dependencies of a telescope 57 | getDepsTele :: Tele -> [String] 58 | getDepsTele (TRet term) = getDeps term 59 | getDepsTele (TExt _ typ bod) = getDeps typ ++ getDepsTele (bod Set) 60 | 61 | -- Gets all dependencies (direct and indirect) of a term 62 | getAllDeps :: Book -> String -> S.Set String 63 | getAllDeps book name = go S.empty [name] where 64 | go visited [] = visited 65 | go visited (x:xs) 66 | | S.member x visited = go visited xs 67 | | otherwise = case M.lookup x book of 68 | Just term -> go (S.insert x visited) (getDeps term ++ xs) 69 | Nothing -> go (S.insert x visited) xs 70 | 71 | -- Topologically sorts a book 72 | topoSortBook :: Book -> [(String, Term)] 73 | topoSortBook book = go (M.keysSet book) [] where 74 | go mustInclude done = case S.lookupMin mustInclude of 75 | Nothing -> reverse done 76 | Just name -> 77 | let (mustInclude', done') = include mustInclude done name 78 | in go mustInclude' done' 79 | 80 | include :: S.Set String -> [(String, Term)] -> String -> (S.Set String, [(String, Term)]) 81 | include mustInclude done name = 82 | if not (S.member name mustInclude) then 83 | (mustInclude, done) 84 | else case M.lookup name book of 85 | Nothing -> 86 | error ("unbound:" ++ name) 87 | Just term -> 88 | let deps = getDeps term 89 | mustInclude' = S.delete name mustInclude 90 | (mustInclude'', done') = includeDeps mustInclude' done deps 91 | in (mustInclude'', (name,term) : done') 92 | 93 | includeDeps :: S.Set String -> [(String, Term)] -> [String] -> (S.Set String, [(String, Term)]) 94 | includeDeps mustInclude done [] = (mustInclude, done) 95 | includeDeps mustInclude done (dep:deps) = 96 | let (mustInclude', done') = include mustInclude done dep 97 | (mustInclude'', done'') = includeDeps mustInclude' done' deps 98 | in (mustInclude'', done'') 99 | 100 | -- Converts: 101 | -- - from a Tele: `{ x:A y:(B x) ... }: (C x y ...)` 102 | -- - to a type: `∀(x: A) ∀(y: (B x)) ... (C x y ...)` 103 | teleToType :: Tele -> Term -> Int -> Term 104 | teleToType (TRet _) ret _ = ret 105 | teleToType (TExt nam inp bod) ret dep = All nam inp (\x -> teleToType (bod x) ret (dep + 1)) 106 | 107 | -- Converts: 108 | -- - from a Tele : `{ x:A y:(B x) ... }: (C x y ...)` 109 | -- - to terms : `([(Just "x", ), [(Just "y", <(B x)>)], ...], <(C x y ...)>)` 110 | teleToTerms :: Tele -> Int -> ([(Maybe String, Term)], Term) 111 | teleToTerms tele dep = go tele [] dep where 112 | go (TRet ret) args _ = (reverse args, ret) 113 | go (TExt nam inp bod) args dep = go (bod (Var nam dep)) ((Just nam, Var nam dep) : args) (dep + 1) 114 | 115 | getTeleNames :: Tele -> Int -> [String] -> [String] 116 | getTeleNames (TRet _) dep acc = reverse acc 117 | getTeleNames (TExt name _ next) dep acc = getTeleNames (next (Var name dep)) (dep+1) (name:acc) 118 | 119 | getTeleFields :: Tele -> Int -> [(String,Term)] -> [(String,Term)] 120 | getTeleFields (TRet _) dep acc = reverse acc 121 | getTeleFields (TExt name ttyp next) dep acc = getTeleFields (next (Var name dep)) (dep+1) ((name,ttyp):acc) 122 | 123 | getDatIndices :: Term -> [Term] 124 | getDatIndices term = case term of 125 | ADT idxs _ _ -> idxs 126 | _ -> [] 127 | 128 | getType :: Term -> Term 129 | getType (Ann _ val typ) = typ 130 | getType _ = error "?" 131 | 132 | getTerm :: Term -> Term 133 | getTerm (Ann _ val typ) = val 134 | getTerm _ = error "?" 135 | 136 | getCtrName :: Ctr -> String 137 | getCtrName (Ctr name _) = name 138 | 139 | getADTCts :: Term -> [(String,Ctr)] 140 | getADTCts (ADT _ cts _) = map (\ ctr -> (getCtrName ctr, ctr)) cts 141 | getADTCts (Src loc val) = getADTCts val 142 | getADTCts term = error ("not-an-adt:" ++ showTerm term) 143 | 144 | -- Given a typed term, return its argument's names 145 | getArgNames :: Term -> [String] 146 | getArgNames (Ann _ _ typ) = getForallNames typ 147 | getArgNames (Src _ val) = getArgNames val 148 | getArgNames _ = [] 149 | 150 | -- Returns the names in a chain of foralls 151 | getForallNames :: Term -> [String] 152 | getForallNames (All nam _ bod) = nam : getForallNames (bod Set) 153 | getForallNames (Src _ val) = getForallNames val 154 | getForallNames _ = [] 155 | 156 | getOpReturnType :: Oper -> Term -> Term 157 | getOpReturnType ADD U64 = U64 158 | getOpReturnType ADD F64 = F64 159 | getOpReturnType SUB U64 = U64 160 | getOpReturnType SUB F64 = F64 161 | getOpReturnType MUL U64 = U64 162 | getOpReturnType MUL F64 = F64 163 | getOpReturnType DIV U64 = U64 164 | getOpReturnType DIV F64 = F64 165 | getOpReturnType MOD U64 = U64 166 | getOpReturnType EQ _ = U64 167 | getOpReturnType NE _ = U64 168 | getOpReturnType LT _ = U64 169 | getOpReturnType GT _ = U64 170 | getOpReturnType LTE _ = U64 171 | getOpReturnType GTE _ = U64 172 | getOpReturnType AND U64 = U64 173 | getOpReturnType OR U64 = U64 174 | getOpReturnType XOR U64 = U64 175 | getOpReturnType LSH U64 = U64 176 | getOpReturnType RSH U64 = U64 177 | getOpReturnType opr trm = error ("Invalid opertor: " ++ (show opr) ++ " Invalid operand type: " ++ (showTerm trm)) 178 | 179 | checkValidType :: Term -> [Term] -> Int -> Env Bool 180 | checkValidType typ validTypes dep = foldr (\t acc -> do 181 | isEqual <- equal typ t dep 182 | if isEqual then return True else acc 183 | ) (return False) validTypes 184 | 185 | --------------------------------------------------------------------------------