[ { "path": ".gitignore", "content": "dist-*\n*.o\n*.hi\n*.chi\n*.chs.h\n*.dyn_o\n*.dyn_hi\n.cabal-sandbox/\ncabal.sandbox.config\n*.prof\n*.aux\n*.hp\n*.eventlog\n.stack-work/\ncabal.project.local*\n.ghc.environment.*\n.vscode/\n.idea/\n.DS_Store\n.holefill\n.tmp\n.backup/\n*.koder\n" }, { "path": "CHANGELOG.md", "content": "# Revision history for kind2hs\n\n## 0.1.0.0 -- YYYY-mm-dd\n\n* First version. Released on an unsuspecting world.\n" }, { "path": "LICENSE", "content": "Copyright (c) 2024 Victor Taelin\n\nPermission is hereby granted, free of charge, to any person obtaining\na copy of this software and associated documentation files (the\n\"Software\"), to deal in the Software without restriction, including\nwithout limitation the rights to use, copy, modify, merge, publish,\ndistribute, sublicense, and/or sell copies of the Software, and to\npermit persons to whom the Software is furnished to do so, subject to\nthe following conditions:\n\nThe above copyright notice and this permission notice shall be included\nin all copies or substantial portions of the Software.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\nEXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\nMERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.\nIN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY\nCLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,\nTORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE\nSOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\n" }, { "path": "README.md", "content": "# Kind\n\nKind is a minimal Proof Checker.\n\nThis repository is a full rewrite of Kind from the old JS implementation to\nHaskell. It is being actively developed. See examples on\n[KindBook](https://github.com/HigherOrderCO/KindBook).\n\n# Usage\n\n1. Clone and install this project\n\n2. Use the `kind` command to check/run terms\n\n---\n\nWe will write a proper README later (:\n" }, { "path": "app/Main.hs", "content": "module Main where\n\nimport Kind (main)\n\nmain :: IO ()\nmain = Kind.main\n" }, { "path": "cabal.project", "content": "packages: .\n\n-- Enable -O2 optimization for all packages\npackage *\n optimization: 2\n" }, { "path": "kind-lang.cabal", "content": "cabal-version: 3.0\nname: kind-lang\nversion: 0.1.0.0\nlicense: MIT\nlicense-file: LICENSE\nauthor: Victor Taelin\nmaintainer: victor.taelin@gmail.com\ncategory: Language\nbuild-type: Simple\nextra-doc-files: CHANGELOG.md\n\ncommon warnings\n ghc-options: -w\n\nlibrary\n import: warnings\n exposed-modules: Kind\n , Kind.CLI\n , Kind.Check\n , Kind.CompileJS\n , Kind.Env\n , Kind.Equal\n , Kind.Parse\n , Kind.Reduce\n , Kind.Show\n , Kind.Type\n , Kind.Util\n other-modules: \n build-depends: base ^>=4.20.0.0\n , containers ==0.7\n , parsec ==3.1.17.0\n , ansi-terminal==1.1.1\n , directory==1.3.8.3\n , hs-highlight == 1.0.3\n , filepath==1.5.2.0\n , mtl==2.3.1\n hs-source-dirs: src\n default-language: GHC2024\n\nexecutable kind\n import: warnings\n main-is: Main.hs\n build-depends: base ^>=4.20.0.0\n , kind-lang\n , ansi-terminal==1.1.1\n , directory==1.3.8.3\n , hs-highlight == 1.0.3\n , filepath==1.5.2.0\n , mtl==2.3.1\n hs-source-dirs: app\n default-language: GHC2024\n" }, { "path": "main.kindc", "content": "\n\nBool : * = #[]{\n #true{} : Bool\n #false{} : Bool\n};\n\nNat : * = #[]{\n #zero{} : Nat\n #succ{ pred: Nat } : Nat\n};\n\n\nIsTrue : ∀(b: Bool) * = λb #[b]{\n #indeed{} : (IsTrue #true{})\n};\n\nEqual : ∀(T: *) ∀(a: T) ∀(b: T) * = λT λa λb #[a b]{\n #refl{} : (Equal T a a)\n};\n\nrewrite\n: ∀(T: *)\n ∀(a: T)\n ∀(b: T)\n ∀(e: (Equal T a b))\n ∀(P: ∀(x: A) *)\n ∀(x: (P a))\n (P b)\n= λT λa λb λ{\n #refl: λP λx x\n};\n\nMAIN = rewrite;\n\n//MAIN\n//: (((Equal Bool) #true{}) #true{})\n//= #refl{};\n\n//Equal.rewrite(e: Equal) Type>(x: P(a)): P(b)\n //case e {\n //refl: x\n //} : P(e.b)\n\n" }, { "path": "src/Kind/CLI.hs", "content": "-- Type.hs:\n-- //./Type.hs//\n\nmodule Kind.CLI where\n\nimport Control.Exception (try)\nimport Control.Monad (forM, forM_, foldM)\nimport Data.List (stripPrefix, isSuffixOf, nub)\nimport Highlight (highlightError)\nimport Kind.Check\nimport Kind.CompileJS\nimport Kind.Env\nimport Kind.Parse\nimport Kind.Reduce\nimport Kind.Show\nimport Kind.Type\nimport Kind.Util\nimport System.Console.ANSI\nimport System.Directory (canonicalizePath, getCurrentDirectory, doesDirectoryExist, doesFileExist, getDirectoryContents)\nimport System.Environment (getArgs)\nimport System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure))\nimport System.FilePath (takeDirectory, (), takeFileName, dropExtension, isExtensionOf)\nimport System.IO (readFile)\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\nimport qualified Data.Set as S\n\nimport Debug.Trace\n\ntype FileCtx = (Book, M.Map FilePath [String], M.Map FilePath [String])\ntype Command = String -> FileCtx -> String -> String -> IO (Either String ())\n\n-- main :: IO ()\n-- main = ctest\n\nmain :: IO ()\nmain = do\n args <- getArgs\n currPath <- getCurrentDirectory\n bookPath <- findBookDir currPath\n case bookPath of\n Nothing -> do\n putStrLn \"Error: No 'book' directory found in the path.\"\n exitWith (ExitFailure 1)\n Just bookPath -> do\n result <- case args of\n -- [\"check\"] -> runWithAll bookPath cliCheckAll\n [\"run\", arg] -> runWithOne bookPath arg cliNormal\n [\"check\"] -> runWithAll bookPath cliCheck\n [\"check\", arg] -> runWithOne bookPath arg cliCheck\n [\"to-js\", arg] -> runWithOne bookPath arg cliToJS\n [\"show\", arg] -> runWithOne bookPath arg cliShow\n [\"deps\", arg] -> runWithOne bookPath arg cliDeps\n [\"rdeps\", arg] -> runWithOne bookPath arg cliRDeps\n _ -> printHelp\n case result of\n Left err -> do\n putStrLn err\n exitWith (ExitFailure 1)\n Right _ -> do\n exitWith ExitSuccess\n\nprintHelp :: IO (Either String ())\nprintHelp = do\n putStrLn \"Kind usage:\"\n putStrLn \" kind check # Checks all .kind files in the current directory and subdirectories\"\n putStrLn \" kind check # Type-checks all definitions in the specified file\"\n putStrLn \" kind run # Normalizes the specified definition\"\n putStrLn \" kind show # Stringifies the specified definition\"\n putStrLn \" kind to-js # Compiles the specified definition to JavaScript\"\n putStrLn \" kind deps # Shows immediate dependencies of the specified definition\"\n putStrLn \" kind rdeps # Shows all dependencies of the specified definition recursively\"\n putStrLn \" kind help # Shows this help message\"\n return $ Right ()\n\n-- CLI Commands\n-- ------------\n\n-- Normalizes the target definition\ncliNormal :: Command\ncliNormal bookPath (book, _, _) defName defPath =\n case M.lookup \"main\" book of\n Just term -> do\n result <- showInfo book IM.empty (Print term 0)\n putStrLn result\n return $ Right ()\n Nothing -> do\n return $ Left $ \"Error: Definition '\" ++ defName ++ \"' not found.\"\n\n-- Checks all definitions in the target file\ncliCheck :: Command\ncliCheck bookPath (book, defs, _) defName defPath = do\n case M.lookup defPath defs of\n Just fileDefNames -> do\n results <- forM fileDefNames $ \\fileDefName -> do\n case M.lookup fileDefName book of\n Just term -> do\n case envRun (doCheck term) book of\n Done state _ -> do\n cliPrintLogs state\n cliPrintWarn term state\n putStrLn $ \"\\x1b[32m✓ \" ++ fileDefName ++ \"\\x1b[0m\"\n return $ Right ()\n Fail state -> do\n cliPrintLogs state\n cliPrintWarn term state\n putStrLn $ \"\\x1b[31m✗ \" ++ fileDefName ++ \"\\x1b[0m\"\n return $ Left $ \"Error.\"\n Nothing -> return $ Left $ \"Definition not found: \" ++ fileDefName\n putStrLn \"\"\n return $ sequence_ results\n Nothing -> do\n return $ Left $ \"No definitions found in file: \" ++ defPath\n\n-- Compiles the whole book to JS\ncliToJS :: Command\ncliToJS bookPath (book, _, _) _ _ = do\n putStrLn $ compileJS book\n return $ Right ()\n\n-- Shows a definition\ncliShow :: Command\ncliShow bookPath (book, _, _) defName _ = \n case M.lookup defName book of\n Just term -> do\n putStrLn $ showTerm term\n return $ Right ()\n Nothing -> do\n return $ Left $ \"Error: Definition '\" ++ defName ++ \"' not found.\"\n\n-- Shows immediate dependencies of a definition\ncliDeps :: Command\ncliDeps bookPath (book, _, _) defName _ = \n case M.lookup defName book of\n Just term -> do\n forM_ (filter (/= defName) $ nub $ getDeps term) $ \\dep -> putStrLn dep\n return $ Right ()\n Nothing -> do\n return $ Left $ \"Error: Definition '\" ++ defName ++ \"' not found.\"\n\n-- Shows all dependencies of a definition recursively\ncliRDeps :: Command\ncliRDeps bookPath (book, _, _) defName _ = do\n let deps = S.toList $ S.delete defName $ getAllDeps book defName\n forM_ deps $ \\dep -> putStrLn dep\n return $ Right ()\n\n-- CLI Runners\n-- -----------\n\n-- Runs a command on a single file\nrunWithOne :: FilePath -> String -> Command -> IO (Either String ())\nrunWithOne bookPath arg action = do\n let defName = getDefName bookPath arg\n let defPath = getDefPath bookPath defName\n cliCtx <- loadName bookPath M.empty defName\n action bookPath cliCtx defName defPath\n\n-- Runs a command on all files\nrunWithAll :: FilePath -> Command -> IO (Either String ())\nrunWithAll bookPath action = do\n files <- findKindFiles bookPath\n results <- forM files $ \\file -> do\n putStrLn $ \"\\x1b[1m\\x1b[4m[\" ++ file ++ \"]\\x1b[0m\"\n runWithOne bookPath file action\n return $ sequence_ results\n\n-- Loader\n-- ------\n\n-- Loads a name and all its dependencies recursively\nloadName :: FilePath -> Book -> String -> IO FileCtx\nloadName bookPath book name = do\n if M.member name book\n then do\n return (book, M.empty, M.empty)\n else do\n let dirPath = bookPath name\n isDir <- doesDirectoryExist dirPath\n if isDir\n then loadFile bookPath book (dirPath takeFileName name ++ \".kind\")\n else loadFile bookPath book (bookPath name ++ \".kind\")\n\n-- Loads a file and all its dependencies recursivelly\nloadFile :: FilePath -> Book -> FilePath -> IO FileCtx\nloadFile bookPath book filePath = do\n fileExists <- doesFileExist filePath\n if not fileExists\n then do\n return (book, M.empty, M.empty)\n else do\n code <- readFile filePath\n book0 <- doParseBook filePath code\n let book1 = M.union book book0\n let defs = M.keys book0\n let deps = concatMap (getDeps . snd) (M.toList book0)\n let defs' = M.singleton filePath defs\n let deps' = M.singleton filePath deps\n foldM (\\ (depBook, depDefs, depDeps) dep -> do\n (depBook', depDefs', depDeps') <- loadName bookPath depBook dep\n return ( depBook' , M.union depDefs depDefs' , M.union depDeps depDeps')\n ) (book1, defs', deps') deps\n\n-- Utils\n-- -----\n\n-- Finds the directory named \"monobook\"\nfindBookDir :: FilePath -> IO (Maybe FilePath)\nfindBookDir dir = do\n let kindBookDir = dir \"kindbook\"\n foundKindBook <- doesDirectoryExist kindBookDir\n if foundKindBook\n then return $ Just kindBookDir\n else if takeDirectory dir == dir\n then return Nothing\n else findBookDir (takeDirectory dir)\n\n-- Finds all Kind files in this directory tree\nfindKindFiles :: FilePath -> IO [FilePath]\nfindKindFiles dir = do\n contents <- getDirectoryContents dir\n let properNames = filter (`notElem` [\".\", \"..\"]) contents\n paths <- forM properNames $ \\name -> do\n let path = dir name\n isDirectory <- doesDirectoryExist path\n if isDirectory\n then findKindFiles path\n else return [path | \".kind\" `isSuffixOf` path]\n return (concat paths)\n\n-- Loads a file into a string\nreadSource :: FilePath -> IO String\nreadSource file = do\n result <- try (readFile file) :: IO (Either IOError String)\n case result of\n Right x -> return x\n Left er -> return $ \"Could not read source file: \" ++ file\n\n-- Extracts the definition name from a file path or name\ngetDefName :: FilePath -> String -> String\ngetDefName bookPath = dropBookPath . dropExtension where\n dropExtension path\n | isExtensionOf \"kind\" path = System.FilePath.dropExtension path\n | otherwise = path\n dropBookPath path = maybe path id (stripPrefix (bookPath++\"/\") path)\n\n-- Gets the full path for a definition\ngetDefPath :: FilePath -> String -> FilePath\ngetDefPath bookPath name = bookPath name ++ \".kind\"\n\n-- Stringification\n-- ---------------\n\nshowInfo :: Book -> Fill -> Info -> IO String\nshowInfo book fill info = case info of\n Found nam typ ctx dep ->\n let nam' = concat [\"?\", nam]\n typ' = showTermGo True (normal book fill 0 typ dep) dep\n ctx' = showContext book fill ctx dep\n in return $ concat [\"\\x1b[1mGOAL\\x1b[0m \", nam', \" : \", typ', \"\\n\", ctx']\n Error src exp det bad dep -> do\n let exp' = concat [\"- expected : \\x1b[32m\", showTermGo True (normal book fill 0 exp dep) dep, \"\\x1b[0m\"]\n det' = concat [\"- detected : \\x1b[31m\", showTermGo True (normal book fill 0 det dep) dep, \"\\x1b[0m\"]\n bad' = concat [\"- origin : \\x1b[2m\", showTermGo True (normal book fill 0 bad dep) dep, \"\\x1b[0m\"]\n (file, text) <- case src of\n Just (Cod (Loc fileName iniLine iniCol) (Loc _ endLine endCol)) -> do\n canonPath <- canonicalizePath fileName\n content <- readSource canonPath\n let highlighted = highlightError (iniLine, iniCol) (endLine, endCol) content\n return (canonPath, unlines $ take 8 $ lines highlighted)\n Nothing -> return (\"unknown_file\", \"Could not read source file.\\n\")\n let src' = concat [\"\\x1b[4m\", file, \"\\x1b[0m\\n\", text]\n return $ concat [\"\\x1b[1mERROR:\\x1b[0m\\n\", exp', \"\\n\", det', \"\\n\", bad', \"\\n\", src']\n Solve nam val dep ->\n return $ concat [\"SOLVE: _\", show nam, \" = \", showTermGo True val dep]\n Vague nam ->\n return $ concat [\"VAGUE: _\", nam]\n Print val dep ->\n return $ showTermGo True (normal book fill 2 val dep) dep\n\nshowContext :: Book -> Fill -> [Term] -> Int -> String\nshowContext book fill ctx dep = unlines $ map (\\term -> \"- \" ++ showContextAnn book fill term dep) ctx\n\nshowContextAnn :: Book -> Fill -> Term -> Int -> String\nshowContextAnn 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]\nshowContextAnn book fill (Src _ val) dep = showContextAnn book fill val dep\nshowContextAnn book fill term dep = showTermGo True (normal book fill 0 term dep) dep\n\n-- Prints logs from the type-checker\ncliPrintLogs :: State -> IO ()\ncliPrintLogs (State book fill susp logs) = do\n forM_ logs $ \\log -> do\n result <- showInfo book fill log\n putStr result\n\n-- Prints a warning if there are unsolved metas\ncliPrintWarn :: Term -> State -> IO ()\ncliPrintWarn term (State _ fill _ _) = do\n let metaCount = countMetas term\n let fillCount = IM.size fill\n if (metaCount > fillCount) then do\n putStrLn $ \"WARNING: \" ++ show (metaCount - fillCount) ++ \" unsolved metas.\"\n else\n return ()\n" }, { "path": "src/Kind/Check.hs", "content": "-- //./Type.hs//\n\nmodule Kind.Check where\n\nimport Kind.Env\nimport Kind.Equal\nimport Kind.Reduce\nimport Kind.Show\nimport Kind.Type\nimport Kind.Util\n\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\n\nimport Control.Monad (forM, forM_, unless, when)\nimport Debug.Trace\n\n-- Type-Checking\n-- -------------\n\n-- Modes:\n-- - sus=True : suspended checks on / better unification / wont return annotated term \n-- - sus=False : suspended checks off / worse unification / will return annotated term\n\ninfer :: Bool -> Maybe Cod -> Term -> Int -> Env Term\ninfer sus src term dep = debug (\"infer:\" ++ (if sus then \"* \" else \" \") ++ showTermGo False term dep) $ go term where\n\n go (All nam inp bod) = do\n inpA <- checkLater sus src inp Set dep\n bodA <- checkLater sus src (bod (Ann False (Var nam dep) inp)) Set (dep + 1)\n return $ Ann False (All nam inpA (\\x -> bodA)) Set\n\n go (App fun arg) = do\n funA <- infer sus src fun dep\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 (getType funA) of\n (All inpNam inpTyp inpBod) -> do\n argA <- checkLater sus src arg inpTyp dep\n return $ Ann False (App funA argA) (inpBod arg)\n otherwise -> do\n envLog (Error src (Ref \"function\") (getType funA) (App fun arg) dep)\n envFail\n\n go (Ann True val typ) = do\n check sus src val typ dep\n\n go (Ann False val typ) = do\n return $ Ann False val typ\n\n go (Slf nam typ bod) = do\n typA <- checkLater sus src typ Set dep\n bodA <- checkLater sus src (bod (Ann False (Var nam dep) typ)) Set (dep + 1)\n return $ Ann False (Slf nam typA (\\x -> bodA)) Set\n\n go (Ins val) = do\n valA <- infer sus src val dep\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 (getType valA) of\n (Slf slfNam slfTyp slfBod) -> do\n return $ Ann False (Ins valA) (slfBod (Ins valA))\n otherwise -> do\n envLog (Error src (Ref \"Self\") (getType valA) (Ins val) dep)\n envFail\n\n go (Ref nam) = do\n book <- envGetBook\n case M.lookup nam book of\n Just val -> do\n valA <- infer sus src val dep\n return $ Ann False (Ref nam) (getType valA)\n Nothing -> do\n envLog (Error src (Ref \"expression\") (Ref \"undefined\") (Ref nam) dep)\n envFail\n\n go Set = do\n return $ Ann False Set Set\n\n go U64 = do\n return $ Ann False U64 Set\n\n go F64 = do\n return $ Ann False F64 Set\n\n go (Num num) = do\n return $ Ann False (Num num) U64\n\n go (Flt num) = do\n return $ Ann False (Flt num) F64\n\n\n go (Op2 opr fst snd) = do\n fstT <- infer sus src fst dep\n sndT <- infer sus src snd dep\n \n let validTypes = [F64, U64]\n isValidType <- checkValidType (getType fstT) validTypes dep\n\n if not isValidType then do\n envLog (Error src (Ref \"Valid numeric type\") (getType fstT) (Op2 opr fst snd) dep)\n envFail\n else do\n typesEqual <- equal (getType fstT) (getType sndT) dep\n if not typesEqual then do\n envLog (Error src (getType fstT) (getType sndT) (Op2 opr fst snd) dep)\n envFail\n else do\n book <- envGetBook\n fill <- envGetFill\n let reducedFst = reduce book fill 1 (getType fstT)\n let returnType = getOpReturnType opr reducedFst\n return $ Ann False (Op2 opr fstT sndT) returnType\n \n go (Swi zer suc) = do\n envLog (Error src (Ref \"annotation\") (Ref \"switch\") (Swi zer suc) dep)\n envFail\n\n go (Map typ) = do\n typA <- checkLater sus src typ Set dep\n return $ Ann False (Map typA) Set\n\n go (KVs kvs dft) = do\n dftA <- infer sus src dft dep\n kvsA <- forM (IM.toList kvs) $ \\(key, val ) -> do\n valA <- check sus src val (getType dftA) dep\n return (key, valA)\n return $ Ann False (KVs (IM.fromList kvsA) dftA) (Map (getType dftA))\n\n go (Get got nam map key bod) = do\n mapA <- infer sus src map dep\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 (getType mapA) of\n (Map typ) -> do\n let got_ann = Ann False (Var got dep) typ\n let nam_ann = Ann False (Var nam dep) (Map typ)\n keyA <- check sus src key U64 dep\n bodA <- infer sus src (bod got_ann nam_ann) dep\n return $ Ann False (Get got nam mapA keyA (\\g m -> bodA)) (getType bodA)\n otherwise -> do\n envLog (Error src (Ref \"Map\") (getType mapA) (Get got nam map key bod) dep)\n envFail\n\n go (Put got nam map key val bod) = do\n mapA <- infer sus src map dep\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 (getType mapA) of\n (Map typ) -> do\n valA <- check sus src val typ dep\n let got_ann = Ann False (Var got dep) typ\n let nam_ann = Ann False (Var nam dep) (Map typ)\n keyA <- check sus src key U64 dep\n bodA <- infer sus src (bod got_ann nam_ann) dep\n return $ Ann False (Put got nam mapA keyA valA (\\g m -> bodA)) (getType bodA)\n otherwise -> do\n envLog (Error src (Ref \"Map\") (getType mapA) (Put got nam map key val bod) dep)\n envFail\n\n go (Let nam val bod) = do\n valA <- infer sus src val dep\n bodA <- infer sus src (bod (Ann False (Var nam dep) (getType valA))) dep\n return $ Ann False (Let nam valA (\\x -> bodA)) (getType bodA)\n\n go (Use nam val bod) = do\n infer sus src (bod val) dep\n\n -- TODO: annotate inside ADT for completion (not needed)\n go (ADT scp cts typ) = do\n ctsA <- forM cts $ \\ (Ctr cnam tele) -> do\n teleA <- checkTele sus src tele Set dep\n return $ Ctr cnam teleA\n return $ Ann False (ADT scp ctsA typ) Set\n\n go (Con nam arg) = do\n envLog (Error src (Ref \"annotation\") (Ref \"constructor\") (Con nam arg) dep)\n envFail\n\n go (Mat cse) = do\n envLog (Error src (Ref \"annotation\") (Ref \"match\") (Mat cse) dep)\n envFail\n\n go (Lam nam bod) = do\n envLog (Error src (Ref \"annotation\") (Ref \"lambda\") (Lam nam bod) dep)\n envFail\n\n go (Hol nam ctx) = do\n envLog (Error src (Ref \"annotation\") (Ref \"hole\") (Hol nam ctx) dep)\n envFail\n\n go (Met uid spn) = do\n envLog (Error src (Ref \"annotation\") (Ref \"meta\") (Met uid spn) dep)\n envFail\n\n go (Log msg nxt) = do\n msgA <- infer sus src msg dep\n nxtA <- infer sus src nxt dep\n return $ Ann False (Log msgA nxtA) (getType nxtA)\n\n go (Var nam idx) = do\n envLog (Error src (Ref \"annotation\") (Ref \"variable\") (Var nam idx) dep)\n envFail\n\n go (Src src val) = do\n infer sus (Just src) val dep\n\n go tm@(Txt txt) = do\n return $ Ann False tm (Ref \"String\")\n -- book <- envGetBook\n -- fill <- envGetFill\n -- go (reduce book fill 2 tm)\n\n go tm@(Nat val) = do\n book <- envGetBook\n fill <- envGetFill\n go (reduce book fill 2 tm)\n\n go tm@(Lst lst) = do\n book <- envGetBook\n fill <- envGetFill\n go (reduce book fill 2 tm)\n\ncheck :: Bool -> Maybe Cod -> Term -> Term -> Int -> Env Term\ncheck sus src term typx dep = debug (\"check:\" ++ (if sus then \"* \" else \" \") ++ showTermGo False term dep ++ \"\\n :: \" ++ showTermGo True typx dep) $ go term where\n\n go (App (Src _ val) arg) =\n go (App val arg)\n\n go (App (Mat cse) arg) = do\n argA <- infer sus src arg dep\n infer sus src (App (Ann True (Mat cse) (All \"x\" (getType argA) (\\x -> replace arg x typx dep))) arg) dep\n\n go (App (Swi zer suc) arg) = do\n argA <- infer sus src arg dep\n infer sus src (App (Ann True (Swi zer suc) (All \"x\" (getType argA) (\\x -> replace arg x typx dep))) arg) dep\n\n go (Lam nam bod) = do\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 typx of\n (All typNam typInp typBod) -> do\n let ann = Ann False (Var nam dep) typInp\n bodA <- check sus src (bod ann) (typBod ann) (dep + 1)\n return $ Ann False (Lam nam (\\x -> bodA)) typx\n otherwise -> do\n infer sus src (Lam nam bod) dep\n\n go (Ins val) = do\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 typx of\n Slf typNam typTyp typBod -> do\n valA <- check sus src val (typBod (Ins val)) dep\n return $ Ann False (Ins valA) typx\n _ -> infer sus src (Ins val) dep\n\n go val@(Con nam arg) = do\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 typx of\n (ADT adtScp adtCts adtTyp) -> do\n case lookup nam (map (\\(Ctr cNam cTel) -> (cNam, cTel)) adtCts) of\n Just cTel -> do\n argA <- checkConstructor src arg cTel dep\n return $ Ann False (Con nam argA) typx\n Nothing -> do\n envLog (Error src (Hol (\"constructor_not_found:\"++nam) []) (Hol \"unknown_type\" []) (Con nam arg) dep)\n envFail\n otherwise -> infer sus src (Con nam arg) dep\n where\n checkConstructor :: Maybe Cod -> [(Maybe String, Term)] -> Tele -> Int -> Env [(Maybe String, Term)]\n checkConstructor src [] (TRet ret) dep = do\n cmp src val ret typx dep\n return []\n checkConstructor src ((field, arg):args) (TExt nam inp bod) dep =\n case field of\n Just field -> if field /= nam\n then do\n envLog (Error src (Hol (\"expected:\" ++ nam) []) (Hol (\"detected:\" ++ field) []) (Hol \"field_mismatch\" []) dep)\n envFail\n else do\n argA <- check sus src arg inp dep\n argsA <- checkConstructor src args (bod arg) (dep + 1)\n return $ (Just field, argA) : argsA\n Nothing -> do\n argA <- check sus src arg inp dep\n argsA <- checkConstructor src args (bod arg) (dep + 1)\n return $ (Nothing, argA) : argsA\n checkConstructor src _ _ dep = do\n envLog (Error src (Hol \"arity_mismatch\" []) (Hol \"unknown_type\" []) (Hol \"constructor\" []) dep)\n envFail\n\n go (Mat cse) = do\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 typx of\n (All typNam typInp typBod) -> do\n case reduce book fill 2 typInp of\n (ADT adtScp adtCts adtTyp) -> do\n -- Checks if all cases are well-typed\n let adtCtsMap = M.fromList (map (\\ (Ctr cNam cTel) -> (cNam, cTel)) adtCts)\n let coveredCases = M.fromList cse\n cseA <- forM cse $ \\ (cNam, cBod) -> do\n if cNam == \"_\" then do\n if null (adtCtsMap `M.difference` coveredCases) then do\n checkUnreachable Nothing cNam cBod dep\n else do\n cBodA <- check sus src cBod (All \"\" typInp typBod) dep\n return (cNam, cBodA)\n else case M.lookup cNam adtCtsMap of\n Just cTel -> do\n let a_r = teleToTerms cTel dep\n let eqs = zip (getDatIndices (reduce book fill 2 typInp)) (getDatIndices (reduce book fill 2 (snd a_r)))\n let rt0 = teleToType cTel (typBod (Ann False (Con cNam (fst a_r)) typInp)) dep\n let rt1 = foldl' (\\ ty (a,b) -> replace a b ty dep) rt0 eqs\n if any (\\(a,b) -> incompatible a b dep) eqs then\n checkUnreachable Nothing cNam cBod dep\n else do\n cBodA <- check sus src cBod rt1 dep\n return (cNam, cBodA)\n Nothing -> do\n envLog (Error src (Hol (\"constructor_not_found:\"++cNam) []) (Hol \"unknown_type\" []) (Mat cse) dep)\n envFail\n -- Check if all constructors are covered\n forM_ adtCts $ \\ (Ctr cNam _) ->\n unless (M.member cNam coveredCases || M.member \"_\" coveredCases) $ do\n envLog (Error src (Hol (\"missing_case:\" ++ cNam) []) (Hol \"incomplete_match\" []) (Mat cse) dep)\n envFail\n return $ Ann False (Mat cseA) typx\n otherwise -> infer sus src (Mat cse) dep\n otherwise -> infer sus src (Mat cse) dep\n\n go (Swi zer suc) = do\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 typx of\n (All typNam typInp typBod) -> do\n case reduce book fill 2 typInp of\n U64 -> do\n -- Check zero case\n let zerAnn = Ann False (Num 0) U64\n zerA <- check sus src zer (typBod zerAnn) dep\n -- Check successor case\n let sucAnn = Ann False (Var \"n\" dep) U64\n let sucTyp = All \"n\" U64 (\\x -> typBod (Op2 ADD (Num 1) x))\n sucA <- check sus src suc sucTyp dep\n return $ Ann False (Swi zerA sucA) typx\n otherwise -> infer sus src (Swi zer suc) dep\n otherwise -> infer sus src (Swi zer suc) dep\n\n go (KVs kvs dft) = do\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 typx of\n (Map typ) -> do\n dftA <- check sus src dft typ dep\n kvsA <- forM (IM.toList kvs) $ \\(key, val) -> do\n valA <- check sus src val typ dep\n return (key, valA)\n return $ Ann False (KVs (IM.fromList kvsA) dftA) typx\n otherwise -> infer sus src (KVs kvs dft) dep\n\n go (Get got nam map key bod) = do\n mapA <- infer sus src map dep\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 (getType mapA) of\n (Map typ) -> do\n let got_ann = Ann False (Var got dep) typ\n let nam_ann = Ann False (Var nam dep) (Map typ)\n keyA <- check sus src key U64 dep\n bodA <- check sus src (bod got_ann nam_ann) typx dep\n return $ Ann False (Get got nam mapA keyA (\\g m -> bodA)) typx\n otherwise -> do\n envLog (Error src (Ref \"Map\") (getType mapA) (Get got nam map key bod) dep)\n envFail\n\n go (Put got nam map key val bod) = do\n mapA <- infer sus src map dep\n book <- envGetBook\n fill <- envGetFill\n case reduce book fill 2 (getType mapA) of\n (Map typ) -> do\n valA <- check sus src val typ dep\n let got_ann = Ann False (Var got dep) typ\n let nam_ann = Ann False (Var nam dep) (Map typ)\n keyA <- check sus src key U64 dep\n bodA <- check sus src (bod got_ann nam_ann) typx dep\n return $ Ann False (Put got nam mapA keyA valA (\\g m -> bodA)) typx\n otherwise -> do\n envLog (Error src (Ref \"Map\") (getType mapA) (Put got nam map key val bod) dep)\n envFail\n\n go (Let nam val bod) = do\n valA <- infer sus src val dep\n bodA <- check sus src (bod (Ann False (Var nam dep) (getType valA))) typx dep\n return $ Ann False (Let nam valA (\\x -> bodA)) typx\n\n go (Use nam val bod) = do\n check sus src (bod val) typx dep\n\n go (Hol nam ctx) = do\n envLog (Found nam typx ctx dep)\n return $ Ann False (Hol nam ctx) typx\n\n go (Met uid spn) = do\n return $ Ann False (Met uid spn) typx\n\n go (Log msg nxt) = do\n msgA <- infer sus src msg dep\n nxtA <- check sus src nxt typx dep\n return $ Ann False (Log msgA nxtA) typx\n\n go tm@(Txt txt) = do\n return $ Ann False tm (Ref \"String\")\n -- book <- envGetBook\n -- fill <- envGetFill\n -- go (reduce book fill 2 tm)\n\n go tm@(Nat val) = do\n book <- envGetBook\n fill <- envGetFill\n go (reduce book fill 2 tm)\n\n go tm@(Lst lst) = do\n book <- envGetBook\n fill <- envGetFill\n go (reduce book fill 2 tm)\n\n go (Ann True val typ) = do\n cmp src val typ typx dep\n check sus src val typ dep\n\n go (Ann False val typ) = do\n cmp src val typ typx dep -- FIXME: should this be here?\n return $ Ann False val typ\n\n go (Src src val) = do\n check sus (Just src) val typx dep\n\n go term = do\n termA <- infer sus src term dep\n cmp src term typx (getType termA) dep\n return termA\n\n cmp src term expected detected dep = do\n equal <- equal expected detected dep\n if equal then do\n susp <- envTakeSusp\n forM_ susp $ \\ (Check src val typ dep) -> do\n check sus src val typ dep\n return ()\n else do\n envLog (Error src expected detected term dep)\n envFail\n\ncheckTele :: Bool -> Maybe Cod -> Tele -> Term -> Int -> Env Tele\ncheckTele sus src tele typ dep = case tele of\n TRet term -> do\n termA <- check sus src term typ dep\n return $ TRet termA\n TExt nam inp bod -> do\n inpA <- check sus src inp Set dep\n bodA <- checkTele sus src (bod (Ann False (Var nam dep) inp)) typ (dep + 1)\n return $ TExt nam inpA (\\x -> bodA)\n\ncheckUnreachable :: Maybe Cod -> String -> Term -> Int -> Env (String, Term)\ncheckUnreachable src cNam term dep = go src cNam term dep where\n go src cNam (Lam nam bod) dep = go src cNam (bod (Con \"void\" [])) (dep+1)\n go src cNam (Let nam val bod) dep = go src cNam (bod (Con \"void\" [])) (dep+1)\n go src cNam (Use nam val bod) dep = go src cNam (bod (Con \"void\" [])) (dep+1)\n go _ cNam (Src src val) dep = go (Just src) cNam val dep\n go src cNam (Hol nam ctx) dep = envLog (Found nam (Hol \"unreachable\" []) ctx dep) >> go src cNam Set dep\n go src cNam term dep = return (cNam, Ann False Set U64)\n\ncheckLater :: Bool -> Maybe Cod -> Term -> Term -> Int -> Env Term\ncheckLater False src term typx dep = check False src term typx dep\ncheckLater True src term typx dep = envSusp (Check src term typx dep) >> return (Met 0 [])\n\ndoCheckMode :: Bool -> Term -> Env Term\ndoCheckMode sus (Ann _ val typ) = do\n check sus Nothing typ Set 0\n check sus Nothing val typ 0\ndoCheckMode sus (Src _ val) = do\n doCheckMode sus val\ndoCheckMode sus (Ref nam) = do\n book <- envGetBook\n case M.lookup nam book of\n Just val -> doCheckMode sus val\n Nothing -> envLog (Error Nothing (Ref \"expression\") (Ref \"undefined\") (Ref nam) 0) >> envFail\ndoCheckMode sus term = do\n infer True Nothing term 0\n\ndoCheck :: Term -> Env Term\ndoCheck = doCheckMode True\n\ndoAnnotate :: Term -> Env (Term, Fill)\ndoAnnotate term = do\n doCheckMode True term\n term <- doCheckMode False term\n fill <- envGetFill\n return (bind term [], fill)\n" }, { "path": "src/Kind/CompileJS.hs", "content": "-- Type.hs:\n-- //./Type.hs//\n\n-- FIXME: currently, the Map type will compile to a mutable map in JS, which\n-- means we assume it is used linearly (no cloning). To improve this, we can add\n-- a shallow-cloning operation for cloned maps, or use an immutable map. Adding\n-- linearity checks to Kind would let us pick the best representation.\n\n{-# LANGUAGE ViewPatterns #-}\n\nmodule Kind.CompileJS where\n\nimport Kind.Check\nimport Kind.Env\nimport Kind.Equal\nimport Kind.Reduce\nimport Kind.Show\nimport Kind.Type\nimport Kind.Util\n\nimport Control.Monad (forM)\nimport Data.List (intercalate, isSuffixOf, elem, isInfixOf, isPrefixOf)\nimport Data.Maybe (fromJust, isJust)\nimport Data.Word\nimport qualified Control.Monad.State.Lazy as ST\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\nimport qualified Data.Set as S\n\nimport Debug.Trace\n\nimport Prelude hiding (EQ, LT, GT)\n\n-- Type\n-- ----\n\n-- Compilation Targets\ndata Target = C | JS deriving (Eq, Show)\n\n-- Compilable Term\ndata CT\n = CNul\n | CSet\n | CU64\n | CF64\n | CADT [(String,[(String,CT)])]\n | CMap CT\n | CAll (String,CT) (CT -> CT)\n | CLam (String,CT) (CT -> CT)\n | CApp CT CT\n | CCon String [(String, CT)]\n | CMat CT [(String, [(String,CT)], CT)]\n | CRef String\n | CHol String\n | CLet (String,CT) CT (CT -> CT)\n | CNum Word64\n | CFlt Double\n | COp2 CT Oper CT CT\n | CSwi CT CT CT\n | CKVs (IM.IntMap CT) CT\n | CGet String String CT CT (CT -> CT -> CT)\n | CPut String String CT CT CT (CT -> CT -> CT)\n | CLog CT CT\n | CVar String Int\n | CTxt String\n | CLst [CT]\n | CNat Integer\n\ntype CTBook = M.Map String CT\n\n-- Term to CT\n-- ----------\n\n-- Converts a Term into a Compilable Term\n-- Uses type information to:\n-- - Ensure constructor fields are present\n-- - Annotate Mat cases with the field names\ntermToCT :: Book -> Fill -> Term -> Maybe Term -> Int -> CT\ntermToCT book fill term typx dep = bindCT (t2ct term typx dep) [] where\n\n t2ct term typx dep = \n -- trace (\"t2ct: \" ++ showTerm term ++ \"\\ntype: \" ++ maybe \"*\" showTerm typx ++ \"\\ndep: \" ++ show dep) $\n go term where\n\n go (All nam inp bod) =\n let inp' = t2ct inp Nothing dep\n bod' = \\x -> t2ct (bod (Var nam dep)) Nothing (dep+1)\n in CAll (nam,inp') bod'\n go (Lam nam bod) =\n case typx of\n Just typx -> case (reduce book fill 2 typx) of\n (All _ inp _) ->\n let inp' = t2ct inp Nothing dep\n bod' = \\x -> t2ct (bod (Var nam dep)) Nothing (dep+1)\n in CLam (nam,inp') bod'\n other -> error \"err\"\n Nothing -> error \"err\"\n go (App fun arg) =\n let fun' = t2ct fun Nothing dep\n arg' = t2ct arg Nothing dep\n in CApp fun' arg'\n go (Ann _ val typ) =\n t2ct val (Just typ) dep\n go (Slf _ _ _) =\n CNul\n go (Ins val) =\n t2ct val typx dep\n go (ADT scp cts typ) =\n let cts' = map (\\ (Ctr nam tele) -> (nam, map (\\ (fn,ft) -> (fn, go ft)) (getTeleFields tele dep []))) cts\n in CADT cts'\n go (Con nam arg) =\n case typx of\n Just typx -> case lookup nam (getADTCts (reduce book fill 2 typx)) of\n Just (Ctr _ tele) ->\n let fNames = getTeleNames tele dep []\n fields = map (\\ (f,t) -> (f, t2ct t Nothing dep)) $ zip fNames (map snd arg)\n in CCon nam fields\n Nothing -> error $ \"constructor-not-found:\" ++ nam\n Nothing -> error $ \"untyped-constructor\"\n go (Mat cse) =\n case typx of\n Just typx -> case reduce book fill 2 typx of\n (All _ adt _) ->\n let adtV = reduce book fill 2 adt\n cts = getADTCts adtV\n adt' = t2ct adt Nothing dep\n cses = map (\\ (cnam, cbod) ->\n if cnam == \"_\" then\n (cnam, [(\"_\",adt')], t2ct cbod Nothing dep)\n else case lookup cnam cts of\n Just (Ctr _ tele) ->\n let fInps = getTeleFields tele dep []\n fInps' = map (\\ (nm,ty) -> (nm, t2ct ty Nothing dep)) fInps\n in (cnam, fInps', t2ct cbod Nothing dep)\n Nothing -> error $ \"constructor-not-found:\" ++ cnam) cse\n in CLam (\"__\" ++ show dep, adt') $ \\x -> CMat x cses\n otherwise -> error \"match-without-type\"\n Nothing -> error \"err\"\n go (Swi zer suc) =\n let zer' = t2ct zer Nothing dep\n suc' = t2ct suc Nothing dep\n in CLam (\"__\" ++ show dep, CU64) $ \\x -> CSwi x zer' suc'\n go (Map typ) =\n let typ' = t2ct typ Nothing dep\n in CMap typ'\n go (KVs kvs def) =\n let kvs' = IM.map (\\v -> t2ct v Nothing dep) kvs\n def' = t2ct def Nothing dep\n in CKVs kvs' def'\n go (Get got nam map key bod) =\n let map' = t2ct map Nothing dep\n key' = t2ct key Nothing dep\n bod' = \\x y -> t2ct (bod (Var got dep) (Var nam dep)) Nothing (dep+2)\n in CGet got nam map' key' bod'\n go (Put got nam map key val bod) =\n let map' = t2ct map Nothing dep\n key' = t2ct key Nothing dep\n val' = t2ct val Nothing dep\n bod' = \\x y -> t2ct (bod (Var got dep) (Var nam dep)) Nothing (dep+2)\n in CPut got nam map' key' val' bod'\n go (All _ _ _) =\n CNul\n go (Ref nam) =\n CRef nam\n go (Let nam val bod) =\n -- FIXME: add type\n let val' = t2ct val Nothing dep\n bod' = \\x -> t2ct (bod (Var nam dep)) Nothing (dep+1)\n in CLet (nam,CNul) val' bod'\n go (Use nam val bod) =\n t2ct (bod val) typx dep\n go Set =\n CSet\n go U64 =\n CU64\n go F64 =\n CF64\n go (Num val) =\n CNum val\n go (Flt val) =\n CFlt val\n go (Op2 opr fst snd) = case typx of\n Nothing -> error \"Type information required for binary operation\"\n Just typ -> \n let fst' = t2ct fst Nothing dep\n snd' = t2ct snd Nothing dep\n typ' = t2ct typ Nothing dep\n in COp2 typ' opr fst' snd'\n go (Txt txt) =\n CTxt txt\n go (Lst lst) =\n CLst (map (\\x -> t2ct x Nothing dep) lst)\n go (Nat val) =\n CNat val\n go (Hol nam _) =\n CHol nam\n go (Met _ _) =\n CNul\n go (Log msg nxt) =\n let msg' = t2ct msg Nothing dep\n nxt' = t2ct nxt Nothing dep\n in CLog msg' nxt'\n go (Var nam idx) =\n CVar nam idx\n go (Src _ val) =\n t2ct val typx dep\n\n-- CT Transformations\n-- ------------------\n\n-- Removes unreachable cases\nremoveUnreachables :: CT -> CT\nremoveUnreachables ct = go ct where\n go CNul =\n CNul\n go CSet =\n CSet\n go CU64 =\n CU64\n go CF64 =\n CF64\n go (CADT cts) =\n let cts' = map (\\ (n,fs) -> (n, map (\\ (fn,ft) -> (fn, go ft)) fs)) cts\n in CADT cts'\n go (CMap typ) =\n let typ' = go typ\n in CMap typ'\n go (CMat val cse) =\n let val' = go val\n cse' = map (\\ (n,f,t) -> (n, map (\\ (fn,ft) -> (fn, go ft)) f, go t)) cse\n cseF = filter (\\ (_,_,t) -> not (isNul t)) cse'\n in CMat val' cseF\n go (CAll (nam,inp) bod) =\n let inp' = go inp\n bod' = \\x -> go (bod x)\n in CAll (nam,inp') bod'\n go (CLam (nam,inp) bod) =\n let inp' = go inp\n bod' = \\x -> go (bod x)\n in CLam (nam,inp') bod'\n go (CApp fun arg) =\n let fun' = go fun\n arg' = go arg\n in CApp fun' arg'\n go (CCon nam fields) =\n let fields' = map (\\ (f,t) -> (f, go t)) fields\n in CCon nam fields'\n go (CRef nam) = CRef nam\n go (CHol nam) = CHol nam\n go (CLet (nam,typ) val bod) =\n let typ' = go typ\n val' = go val\n bod' = \\x -> go (bod x)\n in CLet (nam,typ') val' bod'\n go (CNum val) =\n CNum val\n go (CFlt val) =\n CFlt val\n go (COp2 typ opr fst snd) =\n let fst' = go fst\n snd' = go snd\n typ' = go typ\n in COp2 typ' opr fst' snd'\n go (CSwi val zer suc) =\n let val' = go val\n zer' = go zer\n suc' = go suc\n in CSwi val' zer' suc'\n go (CKVs kvs def) =\n let kvs' = IM.map go kvs\n def' = go def\n in CKVs kvs' def'\n go (CGet got nam map key bod) =\n let map' = go map\n key' = go key\n bod' = \\x y -> go (bod x y)\n in CGet got nam map' key' bod'\n go (CPut got nam map key val bod) =\n let map' = go map\n key' = go key\n val' = go val\n bod' = \\x y -> go (bod x y)\n in CPut got nam map' key' val' bod'\n go (CLog msg nxt) =\n let msg' = go msg\n nxt' = go nxt\n in CLog msg' nxt'\n go (CVar nam idx) =\n CVar nam idx\n go (CTxt txt) =\n CTxt txt\n go (CLst lst) =\n CLst (map go lst)\n go (CNat val) =\n CNat val\n\n-- Lifts shareable lambdas across branches:\n-- - from: λx match v { #Foo{a b}: λy λz A #Bar: λy λz B ... }\n-- - to: λx λy λz match v { #Foo{a b}: A #Bar: B ... }\n-- TODO: document why this is (and has to be) terrible\n-- NOTE: this loses dependencies, turning foralls into simple arrows\nliftLambdas :: CT -> Int -> CT\nliftLambdas ct depth = \n gen (liftInp ct depth [] 0) [] ct depth where\n\n gen :: [CT] -> [CT] -> CT -> Int -> CT\n gen [] ctx ct dep = liftVal ctx ct dep [] 0\n gen (inp:inps) ctx ct dep = CLam (nam dep, inp) (\\x -> gen inps (ctx++[x]) ct (dep+1))\n\n nam :: Int -> String\n nam d = \"_\" ++ \"$\" ++ show d\n\n var :: [CT] -> Int -> CT\n var ctx d | d < length ctx = ctx !! d\n var ctx d | otherwise = CNul\n\n eta :: [(String,CT)] -> CT -> CT\n eta [] ct = ct\n eta (fld:flds) (CLam (nam,inp) bod) = CLam (nam,inp) $ \\x -> eta flds (bod x)\n eta (fld:flds) ct = CLam fld $ \\x -> CApp (eta flds ct) x\n\n liftVal :: [CT] -> CT -> Int -> [CT] -> Int -> CT\n liftVal ctx ct dep inp skip = go ct dep inp skip where\n go (CLam (nam,inp) bod) dep inps 0 = liftVal ctx (bod (var ctx (length inps))) (dep+1) (inps++[inp]) 0\n go (CLam (nam,inp) bod) dep inps skip = CLam (nam,inp) $ \\x -> liftVal ctx (bod x) (dep+1) inps (skip-1)\n go (CLet (nam,typ) val bod) dep inps skip = CLet (nam,typ) val $ \\x -> liftVal ctx (bod x) (dep+1) inps skip\n go ct@(CMat val cse) dep inps skip | length cse > 0 =\n let recsV = flip map cse $ \\ (_,f,b) -> liftVal ctx (eta f b) dep inps (skip + length f)\n recsI = flip map cse $ \\ (_,f,b) -> liftInp (eta f b) dep inps (skip + length f)\n valid = flip all recsI $ \\ a -> length a == length (head recsI)\n in if valid then CMat val (zipWith (\\ (n,f,_) b -> (n,f,b)) cse recsV) else ct\n go ct@(CSwi val zer suc) dep inps skip =\n let recZI = liftInp (eta [] zer) dep inps skip\n recZV = liftVal ctx (eta [] zer) dep inps skip\n recSI = liftInp (eta [(\"p\",CU64)] suc) dep inps (skip + 1)\n recSV = liftVal ctx (eta [(\"p\",CU64)] suc) dep inps (skip + 1)\n valid = length recZI == length recSI\n in if valid then CSwi val recZV recSV else ct\n go ct dep inps s = ct\n\n liftInp :: CT -> Int -> [CT] -> Int -> [CT]\n liftInp ct dep inps skip = go ct dep inps skip where\n go (CLam (nam,inp) bod) dep inps 0 = liftInp (bod CNul) (dep+1) (inps++[inp]) 0\n go (CLam (nam,inp) bod) dep inps skip = liftInp (bod CNul) (dep+1) inps (skip-1)\n go (CLet (nam,typ) val bod) dep inps skip = liftInp (bod CNul) (dep+1) inps skip\n go (CMat val cse) dep inps skip | length cse > 0 =\n let recsI = flip map cse $ \\ (_,f,b) -> liftInp (eta f b) dep inps (skip + length f)\n valid = flip all recsI $ \\ a -> length a == length (head recsI)\n in if valid then head recsI else inps\n go (CSwi val zer suc) dep inps skip =\n let recZI = liftInp (eta [] zer) dep inps skip\n recSI = liftInp (eta [(\"p\",CU64)] suc) dep inps (skip + 1)\n valid = length recZI == length recSI\n in if valid then recZI else inps\n go ct dep inps s = inps\n\ninline :: CTBook -> CT -> CT\ninline book ct = nf ct where\n nf :: CT -> CT\n nf ct = go (red book ct) where\n go :: CT -> CT\n go CNul = CNul\n go CSet = CSet\n go CU64 = CU64\n go CF64 = CF64\n go (CADT cts) = CADT (map (\\ (n,fs) -> (n, map (\\ (fn,ft) -> (fn, nf ft)) fs)) cts)\n go (CMap typ) = CMap (nf typ)\n go (CAll (nam,inp) bod) = CAll (nam, nf inp) (\\x -> nf (bod x))\n go (CLam (nam,inp) bod) = CLam (nam, nf inp) (\\x -> nf (bod x))\n go (CApp fun arg) = CApp (nf fun) (nf arg)\n go (CCon nam fields) = CCon nam (map (\\ (f,t) -> (f, nf t)) fields)\n go (CADT cts) = CADT (map (\\ (n,fs) -> (n, map (\\ (fn,ft) -> (fn, nf ft)) fs)) cts)\n go (CMat val cses) = CMat (nf val) (map (\\ (n,f,b) -> (n, map (\\ (fn,ft) -> (fn, nf ft)) f, nf b)) cses)\n go (CRef nam) = CRef nam\n go (CHol nam) = CHol nam\n go (CLet (nam,typ) val bod) = CLet (nam, nf typ) (nf val) (\\x -> nf (bod x))\n go (CNum val) = CNum val\n go (CFlt val) = CFlt val\n go (COp2 typ opr fst snd) = COp2 (nf typ) opr (nf fst) (nf snd)\n go (CSwi val zer suc) = CSwi (nf val) (nf zer) (nf suc)\n go (CKVs kvs def) = CKVs (IM.map nf kvs) (nf def)\n go (CGet g n m k b) = CGet g n (nf m) (nf k) (\\x y -> nf (b x y))\n go (CPut g n m k v b) = CPut g n (nf m) (nf k) (nf v) (\\x y -> nf (b x y))\n go (CLog msg nxt) = CLog (nf msg) (nf nxt)\n go (CVar nam idx) = CVar nam idx\n go (CTxt txt) = CTxt txt\n go (CLst lst) = CLst (map nf lst)\n go (CNat val) = CNat val\n\n-- CT Evaluation\n-- -------------\n\n-- Reduce to WNF\nred :: CTBook -> CT -> CT\nred book tm = go tm where\n go (CApp fun arg) = app book (red book fun) arg\n go (CRef nam) = ref book nam \n go val = val\n\n-- (let x = y A B)\n-- ---------------\n-- let x = y (A B)\n\n-- Application\napp :: CTBook -> CT -> CT -> CT\napp book (CAll (nam,inp) bod) arg = red book (bod (red book arg))\napp book (CLam (nam,inp) bod) arg = red book (bod (red book arg))\napp book (CMat val cse) arg = CMat val (map (\\ (n,f,b) -> (n, f, skp f b (\\b -> CApp b arg))) cse)\napp book (CLet (nam,typ) val bod) arg = CLet (nam,typ) val (\\x -> app book (bod x) arg)\napp book fun arg = CApp fun arg\n\n-- Maps inside N lambdas\nskp :: [(String,CT)] -> CT -> (CT -> CT) -> CT\nskp [] ct fn = fn ct\nskp (fld:flds) ct fn = CLam fld $ \\x -> skp flds (CApp ct x) fn\n\n-- Reference\n-- NOTE: this should only inline refs ending with \"bind\", \"bind/go\" or \"pure\".\n-- create an aux function called \"inl :: String -> Bool\" after it\nref :: CTBook -> String -> CT\nref book nam\n | inl nam = red book (fromJust (M.lookup nam book))\n | otherwise = CRef nam\n where\n inl :: String -> Bool\n inl nam = any (`isSuffixOf` nam)\n [ \"/bind\"\n , \"/bind/go\"\n , \"/pure\"\n -- , \"HVM/RTag/eq\"\n -- , \"HVM/RTerm/get-lab\"\n -- , \"HVM/RTerm/get-loc\"\n -- , \"HVM/RTerm/get-tag\"\n -- , \"HVM/RTerm/new\"\n -- , \"HVM/alloc-redex\"\n -- , \"HVM/alloc-rnod\"\n -- , \"HVM/get\"\n -- , \"HVM/just\"\n -- , \"HVM/link\"\n -- , \"HVM/port\"\n -- , \"HVM/push-redex\"\n -- , \"HVM/set\"\n -- , \"HVM/swap\"\n -- , \"HVM/take\"\n -- , \"U64/to-bool\"\n , \"IO/print\"\n , \"IO/prompt\"\n , \"IO/swap\"\n , \"IO/read\"\n , \"IO/exec\"\n , \"IO/args\"\n ]\n\n-- JavaScript Codegen\n-- ------------------\n\ngetArguments :: CT -> ([(String,CT)], CT)\ngetArguments term = go term 0 where\n go (CLam (nam,inp) bod) dep =\n let (args, body) = go (bod (CVar nam dep)) (dep+1)\n in ((nam,inp):args, body)\n go body dep = ([], body)\n\narityOf :: CTBook -> String -> Int\narityOf book name = case M.lookup name book of\n Just ct -> length $ fst $ getArguments ct\n Nothing -> 0\n\nisRecCall :: String -> Int -> CT -> [CT] -> Bool\nisRecCall fnName arity appFun appArgs =\n case appFun of\n CRef appFunName ->\n let isSameFunc = appFunName == fnName\n isSameArity = length appArgs == arity\n in isSameFunc && isSameArity\n _ -> False\n\nisSatCall :: CTBook -> CT -> [CT] -> Bool\nisSatCall book (CRef funName) appArgs = arityOf book funName == length appArgs\nisSatCall book _ _ = False\n\nisEffCall :: CTBook -> CT -> [CT] -> Bool\nisEffCall book (CHol name) appArgs = True\nisEffCall book name appArgs = False\n\n-- Converts a function to JavaScript or C\nfnToJS :: CTBook -> String -> CT -> ST.State Int String\nfnToJS book fnName ct@(getArguments -> (fnArgs, fnBody)) = do\n bodyName <- fresh\n bodyStmt <- ctToJS True bodyName fnBody 0 \n argTypes <- return $ zipWith (\\ dep (nm,ty) -> tyToTS ty dep) [0..] fnArgs\n\n let arg = zip (map fst fnArgs) argTypes\n let tco = isInfixOf \"/*TCO*/\" bodyStmt\n let bod = \"{\" ++ bodyStmt ++ \"return \" ++ bodyName ++ \"; }\"\n let fun = jsDefFun fnName arg tco bod\n let cur = jsDefCur fnName arg\n return $ fun ++ \"\\n\" ++ cur\n\n where\n\n -- Generates top-level function\n jsDefFun name [] tco body = \n let wrap = \\x -> \"(() => \" ++ x ++ \")()\"\n head = \"const \" ++ nameToJS name ++ \"$ = \"\n in head ++ wrap body\n jsDefFun name arg tco body =\n let loop = \\ x -> concat [\"{while(1)\", x, \"}\"]\n head = \"function \" ++ nameToJS name ++ \"$(\" ++ intercalate \",\" (map (\\ (nm,ty) -> nm++\"/*:\"++ty++\"*/\") arg) ++ \") \"\n in head ++ (if tco then loop body else body)\n\n -- Generates top-level function (curried version)\n jsDefCur name arg =\n let head = \"const \" ++ nameToJS name ++ \" = \" ++ concat (map (\\x -> x ++ \" => \") (map fst arg))\n body = nameToJS name ++ \"$\" ++ (if null arg then \"\" else \"(\" ++ intercalate \",\" (map fst arg) ++ \")\")\n in head ++ body\n\n -- Genreates a fresh name\n fresh :: ST.State Int String\n fresh = do\n n <- ST.get\n ST.put (n + 1)\n return $ \"$x\" ++ show n\n\n -- Assigns an expression to a name, or return it directly\n set :: String -> String -> ST.State Int String\n set name expr = return $ \"var \" ++ name ++ \" = \" ++ expr ++ \";\"\n\n -- Compiles a name to JS\n nameToJS :: String -> String\n nameToJS x = \"$\" ++ map (\\c -> if c == '/' || c == '.' || c == '-' || c == '#' then '$' else c) x\n\n -- Compiles an Oper to JS\n operToJS :: Oper -> String\n operToJS ADD = \"+\"\n operToJS SUB = \"-\"\n operToJS MUL = \"*\"\n operToJS DIV = \"/\"\n operToJS MOD = \"%\"\n operToJS EQ = \"===\"\n operToJS NE = \"!==\"\n operToJS LT = \"<\"\n operToJS GT = \">\"\n operToJS LTE = \"<=\"\n operToJS GTE = \">=\"\n operToJS AND = \"&\"\n operToJS OR = \"|\"\n operToJS XOR = \"^\"\n operToJS LSH = \"<<\"\n operToJS RSH = \">>\"\n\n -- Compiles a CType to TS\n tyToTS :: CT -> Int -> String\n tyToTS CSet dep =\n \"Type\"\n tyToTS CU64 dep =\n \"BigInt\"\n tyToTS CF64 dep =\n \"Number\"\n tyToTS (CADT cts) dep =\n intercalate \" | \" $ flip map cts $ \\ (nm,fs) -> \"{$:'\" ++ nm ++ \"'\" ++ concat (map (\\ (fn,ft) -> \", \" ++ fn ++ \": \" ++ tyToTS ft dep) fs) ++ \"}\"\n tyToTS (CMap typ) dep =\n \"Map\"\n tyToTS (CAll (nam,inp) bod) dep =\n let uid = nameToJS nam ++ \"$\" ++ show dep\n in \"(\" ++ uid ++ \":\" ++ tyToTS inp dep ++ \") => \" ++ tyToTS (bod (CVar uid dep)) (dep + 1)\n tyToTS (CRef nam) dep =\n nam\n tyToTS (CVar nam _) dep = \n nam\n tyToTS (CApp fun arg) dep =\n tyToTS fun dep ++ \"<\" ++ tyToTS arg dep ++ \">\"\n tyToTS CNul dep =\n \"null\"\n tyToTS term dep =\n \"null\"\n\n -- Compiles a CTerm to JS\n ctToJS :: Bool -> String -> CT -> Int -> ST.State Int String\n ctToJS tail var term dep = \n -- trace (\"COMPILE: \" ++ showCT term 0) $\n go (red book term) where\n go CNul =\n set var \"null\"\n go CSet =\n set var \"/*Type*/null\"\n go ty@CU64 =\n set var $ \"/*\" ++ tyToTS ty dep ++ \"*/null\"\n go ty@CF64 =\n set var $ \"/*\" ++ tyToTS ty dep ++ \"*/null\"\n go ty@(CADT cts) = do\n set var $ \"/*\" ++ tyToTS ty dep ++ \"*/null\"\n go ty@(CMap typ) =\n set var $ \"/*\" ++ tyToTS ty dep ++ \"*/null\"\n go ty@(CAll (nam,inp) bod) =\n set var $ \"/*\" ++ tyToTS ty dep ++ \"*/null\"\n go tm@(CLam (nam,inp) bod) = do\n let (names, bodyTerm, _) = lams tm dep []\n bodyName <- fresh\n bodyStmt <- ctToJS False bodyName bodyTerm (dep + length names)\n set var $ concat [\"(\", intercalate \" => \" names, \" => {\", bodyStmt, \"return \", bodyName, \";})\"]\n where lams :: CT -> Int -> [String] -> ([String], CT, Maybe Term)\n lams (CLam (n,i) b) dep names =\n let uid = nameToJS n ++ \"$\" ++ show dep\n in lams (b (CVar uid dep)) (dep + 1) (uid : names)\n lams term dep names = (reverse names, term, Nothing)\n go app@(CApp fun arg) = do\n let (appFun, appArgs) = getAppChain app\n -- Tail Recursive Call\n if tail && isRecCall fnName (length fnArgs) appFun appArgs then do\n argDefs <- forM (zip (map fst fnArgs) appArgs) $ \\ (paramName, appArgs) -> do\n argName <- fresh\n argStmt <- ctToJS False argName appArgs dep\n return (argStmt, paramName ++ \" = \" ++ argName ++ \";\")\n let (argStmts, paramDefs) = unzip argDefs\n return $ concat argStmts ++ concat paramDefs ++ \"/*TCO*/continue;\"\n -- Saturated Call Optimization\n else if isSatCall book appFun appArgs then do\n let (CRef funName) = appFun\n argNamesStmts <- forM appArgs $ \\arg -> do\n argName <- fresh\n argStmt <- ctToJS False argName arg dep\n return (argName, argStmt)\n retStmt <- set var $ concat [nameToJS funName, \"$(\", intercalate \", \" (map fst argNamesStmts), \")\"]\n return $ concat (map snd argNamesStmts ++ [retStmt])\n -- IO Actions\n else if isEffCall book appFun appArgs then do\n let (CHol name) = appFun\n case name of\n \"IO_BIND\" -> do\n let [_, _, call, cont] = appArgs\n callName <- fresh\n callStmt <- ctToJS False callName call dep\n contStmt <- ctToJS False var (CApp cont (CVar callName dep)) dep\n return $ concat [callStmt, contStmt]\n \"IO_PURE\" -> do\n let [_, value] = appArgs\n valueStmt <- ctToJS False var value dep\n return $ valueStmt\n \"IO_SWAP\" -> do\n let [key, val] = appArgs\n keyName <- fresh\n keyStmt <- ctToJS False keyName key dep\n valName <- fresh\n valStmt <- ctToJS False valName val dep\n resName <- fresh\n resStmt <- set resName (concat [\"SWAP(\", keyName, \", \", valName, \");\"])\n doneStmt <- ctToJS False var (CVar resName 0) dep\n return $ concat [keyStmt, valStmt, resStmt, doneStmt]\n \"IO_PRINT\" -> do\n let [text] = appArgs\n textName <- fresh\n textStmt <- ctToJS False textName text dep\n doneStmt <- ctToJS False var (CCon \"Unit\" []) dep \n return $ concat [textStmt, \"console.log(LIST_TO_JSTR(\", textName, \"));\", doneStmt]\n \"IO_PROMPT\" -> do\n error $ \"TODO\"\n \"IO_READ\" -> do\n let [path] = appArgs\n pathName <- fresh\n pathStmt <- ctToJS False pathName path dep\n let readStmt = concat\n [ \"try { var \", var, \" = { $: 'Done', value: JSTR_TO_LIST(readFileSync(LIST_TO_JSTR(\", pathName, \"), 'utf8')) }; } \"\n , \"catch (e) { var \", var, \" = { $: 'Fail', error: e.message }; }\"\n ]\n return $ concat [pathStmt, readStmt]\n \"IO_EXEC\" -> do\n let [cmd] = appArgs\n cmdName <- fresh\n cmdStmt <- ctToJS False cmdName cmd dep\n retStmt <- set var $ concat [\"JSTR_TO_LIST(execSync(LIST_TO_JSTR(\", cmdName, \")).toString())\"]\n return $ concat [cmdStmt, retStmt]\n \"IO_ARGS\" -> do\n let [_] = appArgs\n retStmt <- set var \"JARRAY_TO_LIST(process.argv.slice(2), JSTR_TO_LIST)\"\n return retStmt\n _ -> error $ \"Unknown IO operation: \" ++ name\n -- Normal Application\n else do\n funName <- fresh\n funStmt <- ctToJS False funName fun dep\n argName <- fresh\n argStmt <- ctToJS False argName arg dep\n retStmt <- set var $ concat [\"(\", funName, \")(\", argName, \")\"]\n return $ concat [funStmt, argStmt, retStmt]\n go (CCon nam fields) = do\n objStmt <- set var $ concat [\"({$: \\\"\", nam, \"\\\"})\"]\n setStmts <- forM fields $ \\ (nm, tm) -> do\n fldName <- fresh\n fldStmt <- ctToJS False fldName tm dep\n setStmt <- return $ concat [var ++ \".\" ++ nm ++ \" = \" ++ fldName ++ \";\"]\n return $ concat [fldStmt, setStmt]\n return $ concat $ [objStmt] ++ setStmts\n go (CMat val cses) = do\n let isRecord = length cses == 1 && not (any (\\ (nm,_,_) -> nm == \"_\") cses)\n valName <- fresh\n valStmt <- ctToJS False valName val dep\n cases <- forM cses $ \\ (cnam, fields, cbod) ->\n if cnam == \"_\" then do\n retStmt <- ctToJS tail var (CApp cbod (CVar valName 0)) dep\n return $ concat [\"default: { \" ++ retStmt, \" break; }\"]\n else do\n let bod = foldl CApp cbod (map (\\ (fn,ft) -> (CVar (valName++\".\"++fn) 0)) fields)\n retStmt <- ctToJS tail var bod dep\n return $ if isRecord\n then retStmt\n else concat [\"case \\\"\", cnam, \"\\\": { \", retStmt, \" break; }\"]\n let switch = if isRecord\n then concat [valStmt, unwords cases]\n else concat [valStmt, \"switch (\", valName, \".$) { \", unwords cases, \" }\"]\n return $ switch\n go (CSwi val zer suc) = do\n valName <- fresh\n valStmt <- ctToJS False valName val dep\n zerStmt <- ctToJS tail var zer dep\n sucStmt <- ctToJS tail var (CApp suc (COp2 CU64 SUB (CVar valName 0) (CNum 1))) dep\n let swiStmt = concat [valStmt, \"if (\", valName, \" === 0n) { \", zerStmt, \" } else { \", sucStmt, \" }\"]\n return $ swiStmt\n go (CKVs kvs def) = do\n dftStmt <- do\n dftName <- fresh\n dftStmt <- ctToJS False dftName def dep\n return $ concat [dftStmt, var, \".set(-1n, \", dftName, \");\"]\n kvStmts <- forM (IM.toList kvs) $ \\(k, v) -> do\n valName <- fresh\n valStmt <- ctToJS False valName v dep\n return $ concat [valStmt, var, \".set(\", show k, \"n, \", valName, \");\"]\n let mapStmt = concat [\"var \", var, \" = new Map();\", unwords kvStmts, dftStmt]\n return $ mapStmt\n go (CGet got nam map key bod) = do\n mapName <- fresh\n mapStmt <- ctToJS False mapName map dep\n keyName <- fresh\n keyStmt <- ctToJS False keyName key dep\n neoName <- fresh\n gotName <- fresh\n retStmt <- ctToJS tail var (bod (CVar gotName dep) (CVar neoName dep)) dep\n let gotStmt = concat [\"var \", gotName, \" = \", mapName, \".has(\", keyName, \") ? \", mapName, \".get(\", keyName, \") : \", mapName, \".get(-1n);\"]\n let neoStmt = concat [\"var \", neoName, \" = \", mapName, \";\"]\n return $ concat [mapStmt, keyStmt, gotStmt, neoStmt, retStmt]\n go (CPut got nam map key val bod) = do\n mapName <- fresh\n mapStmt <- ctToJS False mapName map dep\n keyName <- fresh\n keyStmt <- ctToJS False keyName key dep\n valName <- fresh\n valStmt <- ctToJS False valName val dep\n neoName <- fresh\n gotName <- fresh\n retStmt <- ctToJS tail var (bod (CVar gotName dep) (CVar neoName dep)) dep\n let gotStmt = concat [\"var \", gotName, \" = \", mapName, \".has(\", keyName, \") ? \", mapName, \".get(\", keyName, \") : \", mapName, \".get(-1n);\"]\n let neoStmt = concat [\"var \", neoName, \" = \", mapName, \"; \", mapName, \".set(\", keyName, \", \", valName, \");\"]\n return $ concat [mapStmt, keyStmt, valStmt, gotStmt, neoStmt, retStmt]\n go (CRef nam) =\n set var $ nameToJS nam\n go (CHol nam) =\n set var $ \"null\"\n go (CLet (nam,typ) val bod) = do\n let uid = nameToJS nam ++ \"$\" ++ show dep\n valStmt <- ctToJS False uid val dep\n bodStmt <- ctToJS tail var (bod (CVar uid dep)) (dep + 1)\n return $ concat [valStmt, bodStmt]\n go (CNum val) =\n set var $ show val ++ \"n\"\n go (CFlt val) =\n set var $ show val\n\n go (COp2 typ opr fst snd) = do\n let opr' = operToJS opr\n fstName <- fresh\n sndName <- fresh\n fstStmt <- ctToJS False fstName fst dep\n sndStmt <- ctToJS False sndName snd dep\n\n\n let retExpr = case typ of\n CF64 -> concat [fstName, \" \", opr', \" \", sndName]\n CU64 -> concat [\"BigInt.asUintN(64, \", fstName, \" \", opr', \" \", sndName, \")\"]\n _ -> error (\"Invalid type for binary operation: \" ++ showCT typ dep)\n \n retStmt <- set var retExpr\n return $ concat [fstStmt, sndStmt, retStmt]\n go (CLog msg nxt) = do\n msgName <- fresh\n msgStmt <- ctToJS False msgName msg dep\n nxtName <- fresh\n nxtStmt <- ctToJS tail nxtName nxt dep\n retStmt <- set var $ concat [\"(console.log(LIST_TO_JSTR(\", msgName, \")), \", nxtName, \")\"]\n return $ concat [msgStmt, nxtStmt, retStmt]\n go (CVar nam _) =\n set var nam\n go (CTxt txt) =\n set var $ \"JSTR_TO_LIST(`\" ++ (concatMap (\\c -> if c == '`' then \"\\\\`\" else [c]) txt) ++ \"`)\"\n go (CLst lst) =\n let cons = \\x acc -> CCon \"Cons\" [(\"head\", x), (\"tail\", acc)]\n nil = CCon \"Nil\" []\n in ctToJS False var (foldr cons nil lst) dep\n go (CNat val) =\n let succ = \\x -> CCon \"Succ\" [(\"pred\", x)]\n zero = CCon \"Zero\" []\n in ctToJS False var (foldr (\\_ acc -> succ acc) zero [1..val]) dep\n\nprelude :: String\nprelude = unlines [\n \"import { readFileSync } from 'fs';\",\n \"import { execSync } from 'child_process';\",\n \"\",\n \"function LIST_TO_JSTR(list) {\",\n \" try {\",\n \" let result = '';\",\n \" let current = list;\",\n \" while (current.$ === 'Cons') {\",\n \" result += String.fromCodePoint(Number(current.head));\",\n \" current = current.tail;\",\n \" }\",\n \" if (current.$ === 'Nil') {\",\n \" return result;\",\n \" }\",\n \" } catch (e) {}\",\n \" return list;\",\n \"}\",\n \"\",\n \"function JSTR_TO_LIST(str) {\",\n \" let list = {$: 'Nil'};\",\n \" for (let i = str.length - 1; i >= 0; i--) {\",\n \" list = {$: 'Cons', head: BigInt(str.charCodeAt(i)), tail: list};\",\n \" }\",\n \" return list;\",\n \"}\",\n \"\",\n \"function LIST_TO_JARRAY(list, decode) {\",\n \" try {\",\n \" let result = [];\",\n \" let current = list;\",\n \" while (current.$ === 'Cons') {\",\n \" result += decode(current.head);\",\n \" current = current.tail;\",\n \" }\",\n \" if (current.$ === 'Nil') {\",\n \" return result;\",\n \" }\",\n \" } catch (e) {}\",\n \" return list;\",\n \"}\",\n \"\",\n \"function JARRAY_TO_LIST(inp, encode) {\",\n \" let out = {$: 'Nil'};\",\n \" for (let i = inp.length - 1; i >= 0; i--) {\",\n \" out = {$: 'Cons', head: encode(inp[i]), tail: out};\",\n \" }\",\n \" return out;\",\n \"}\",\n \"\",\n \"let MEMORY = new Map();\",\n \"function SWAP(key, val) {\",\n \" var old = MEMORY.get(key) || 0n;\",\n \" MEMORY.set(key, val);\",\n \" return old;\",\n \"}\"\n ]\n\ngenerateJS :: CTBook -> (String, CT) -> String\ngenerateJS book (name, ct) = ST.evalState (fnToJS book name ct) 0 ++ \"\\n\\n\"\n\ndefToCT :: Book -> (String, Term) -> (String, CT)\ndefToCT book (name, term) =\n case envRun (doAnnotate term) book of\n Done _ (term, fill) -> (name, termToCT book fill term Nothing 0)\n Fail _ -> error $ \"COMPILATION_ERROR: \" ++ name ++ \" is ill-typed\"\n\ncompileJS :: Book -> String\ncompileJS book =\n let ctDefs0 = flip map (topoSortBook book) (defToCT book)\n ctDefs1 = flip map ctDefs0 $ \\ (nm,ct) -> (nm, removeUnreachables ct)\n ctDefs2 = flip map ctDefs1 $ \\ (nm,ct) -> (nm, inline (M.fromList ctDefs1) ct)\n ctDefs3 = flip map ctDefs2 $ \\ (nm,ct) -> (nm, liftLambdas ct 0)\n jsFns = concatMap (generateJS (M.fromList ctDefs3)) ctDefs3\n exports = \"export { \" ++ intercalate \", \" (getFunctionNames jsFns) ++ \" }\" \n debug = trace (\"\\nCompiled CTs:\\n\" ++ unlines (map (\\(n,c) -> \"- \" ++ n ++ \":\\n\" ++ showCT c 0) ctDefs3))\n in prelude ++ \"\\n\\n\" ++ jsFns ++ \"\\n\" ++ exports\n\n-- Utils\n-- -----\n\nbindCT :: CT -> [(String,CT)] -> CT\nbindCT CNul ctx = CNul\nbindCT CSet ctx = CSet\nbindCT CU64 ctx = CU64\nbindCT CF64 ctx = CF64\nbindCT (CADT cts) ctx =\n let cts' = map (\\ (n,fs) -> (n, map (\\ (fn,ft) -> (fn, bindCT ft ctx)) fs)) cts in\n CADT cts'\nbindCT (CMap typ) ctx =\n CMap (bindCT typ ctx)\nbindCT (CAll (nam,inp) bod) ctx =\n let inp' = bindCT inp ctx in\n let bod' = \\x -> bindCT (bod (CVar nam 0)) ((nam, x) : ctx) in\n CAll (nam,inp') bod'\nbindCT (CLam (nam,inp) bod) ctx =\n let inp' = bindCT inp ctx in\n let bod' = \\x -> bindCT (bod (CVar nam 0)) ((nam, x) : ctx) in\n CLam (nam,inp') bod'\nbindCT (CApp fun arg) ctx =\n let fun' = bindCT fun ctx in\n let arg' = bindCT arg ctx in\n CApp fun' arg'\nbindCT (CCon nam arg) ctx =\n let arg' = map (\\(f, x) -> (f, bindCT x ctx)) arg in\n CCon nam arg'\nbindCT (CMat val cse) ctx =\n let val' = bindCT val ctx in\n let cse' = map (\\(cn,fs,cb) -> (cn, fs, bindCT cb ctx)) cse in\n CMat val' cse'\nbindCT (CRef nam) ctx =\n case lookup nam ctx of\n Just x -> x\n Nothing -> CRef nam\nbindCT (CHol nam) ctx =\n CHol nam\nbindCT (CLet (nam,typ) val bod) ctx =\n let typ' = bindCT typ ctx in\n let val' = bindCT val ctx in\n let bod' = \\x -> bindCT (bod (CVar nam 0)) ((nam, x) : ctx) in\n CLet (nam,typ') val' bod'\nbindCT (CNum val) ctx = CNum val\nbindCT (CFlt val) ctx = CFlt val\nbindCT (COp2 typ opr fst snd) ctx =\n let fst' = bindCT fst ctx in\n let snd' = bindCT snd ctx in\n let typ' = bindCT typ ctx in\n COp2 typ' opr fst' snd'\nbindCT (CSwi val zer suc) ctx =\n let val' = bindCT val ctx in\n let zer' = bindCT zer ctx in\n let suc' = bindCT suc ctx in\n CSwi val' zer' suc'\nbindCT (CKVs kvs def) ctx =\n let kvs' = IM.map (\\v -> bindCT v ctx) kvs in\n let def' = bindCT def ctx in\n CKVs kvs' def'\nbindCT (CGet got nam map key bod) ctx =\n let map' = bindCT map ctx in\n let key' = bindCT key ctx in\n let bod' = \\x y -> bindCT (bod (CVar got 0) (CVar nam 0)) ((nam, y) : (got, x) : ctx) in\n CGet got nam map' key' bod'\nbindCT (CPut got nam map key val bod) ctx =\n let map' = bindCT map ctx in\n let key' = bindCT key ctx in\n let val' = bindCT val ctx in\n let bod' = \\x y -> bindCT (bod (CVar got 0) (CVar nam 0)) ((nam, y) : (got, x) : ctx) in\n CPut got nam map' key' val' bod'\nbindCT (CLog msg nxt) ctx =\n let msg' = bindCT msg ctx in\n let nxt' = bindCT nxt ctx in\n CLog msg' nxt'\nbindCT (CVar nam idx) ctx =\n case lookup nam ctx of\n Just x -> x\n Nothing -> CVar nam idx\nbindCT (CTxt txt) ctx = CTxt txt\nbindCT (CLst lst) ctx =\n let lst' = map (\\x -> bindCT x ctx) lst in\n CLst lst'\nbindCT (CNat val) ctx = CNat val\n\nrnCT :: CT -> [(String,CT)] -> CT\nrnCT CNul ctx = CNul\nrnCT CSet ctx = CSet\nrnCT CU64 ctx = CU64\nrnCT CF64 ctx = CF64\nrnCT (CADT cts) ctx =\n let cts' = map (\\ (n,fs) -> (n, map (\\ (fn,ft) -> (fn, rnCT ft ctx)) fs)) cts in\n CADT cts'\nrnCT (CMap typ) ctx =\n let typ' = rnCT typ ctx\n in (CMap typ')\nrnCT (CAll (nam,inp) bod) ctx =\n let nam' = \"x\" ++ show (length ctx) in\n let inp' = rnCT inp ctx in\n let bod' = \\x -> rnCT (bod (CVar nam' 0)) ((nam', x) : ctx) in\n CAll (nam',inp') bod'\nrnCT (CLam (nam,inp) bod) ctx =\n let nam' = \"x\" ++ show (length ctx) in\n let inp' = rnCT inp ctx in\n let bod' = \\x -> rnCT (bod (CVar nam' 0)) ((nam', x) : ctx) in\n CLam (nam',inp') bod'\nrnCT (CApp fun arg) ctx =\n let fun' = rnCT fun ctx in\n let arg' = rnCT arg ctx in\n CApp fun' arg'\nrnCT (CCon nam arg) ctx =\n let arg' = map (\\(f, x) -> (f, rnCT x ctx)) arg in\n CCon nam arg'\nrnCT (CMat val cse) ctx =\n let val' = rnCT val ctx in\n let cse' = map (\\(cn,fs,cb) -> (cn, fs, rnCT cb ctx)) cse in\n CMat val' cse'\nrnCT (CRef nam) ctx =\n case lookup nam ctx of\n Just x -> x\n Nothing -> CRef nam\nrnCT (CLet (nam,typ) val bod) ctx =\n let typ' = rnCT typ ctx in\n let val' = rnCT val ctx in\n let bod' = \\x -> rnCT (bod (CVar nam 0)) ((nam, x) : ctx) in\n CLet (nam,typ') val' bod'\nrnCT (CNum val) ctx = CNum val\nrnCT (CFlt val) ctx = CFlt val\nrnCT (COp2 typ opr fst snd) ctx =\n let fst' = rnCT fst ctx in\n let snd' = rnCT snd ctx in\n let typ' = rnCT typ ctx in\n COp2 typ' opr fst' snd'\nrnCT (CSwi val zer suc) ctx =\n let val' = rnCT val ctx in\n let zer' = rnCT zer ctx in\n let suc' = rnCT suc ctx in\n CSwi val' zer' suc'\nrnCT (CKVs kvs def) ctx =\n let kvs' = IM.map (\\v -> rnCT v ctx) kvs in\n let def' = rnCT def ctx in\n CKVs kvs' def'\nrnCT (CGet got nam map key bod) ctx =\n let map' = rnCT map ctx in\n let key' = rnCT key ctx in\n let bod' = \\x y -> rnCT (bod (CVar got 0) (CVar nam 0)) ((got, x) : (nam, y) : ctx) in\n CGet got nam map' key' bod'\nrnCT (CPut got nam map key val bod) ctx =\n let map' = rnCT map ctx in\n let key' = rnCT key ctx in\n let val' = rnCT val ctx in\n let bod' = \\x y -> rnCT (bod (CVar got 0) (CVar nam 0)) ((got, x) : (nam, y) : ctx) in\n CPut got nam map' key' val' bod'\nrnCT (CLog msg nxt) ctx =\n let msg' = rnCT msg ctx in\n let nxt' = rnCT nxt ctx in\n CLog msg' nxt'\nrnCT (CVar nam idx) ctx =\n case lookup nam ctx of\n Just x -> x\n Nothing -> CVar nam idx\nrnCT (CTxt txt) ctx = CTxt txt\nrnCT (CLst lst) ctx =\n let lst' = map (\\x -> rnCT x ctx) lst in\n CLst lst'\nrnCT (CNat val) ctx = CNat val\n\ngetAppChain :: CT -> (CT, [CT])\ngetAppChain (CApp fun arg) =\n let (f, args) = getAppChain fun\n in (f, args ++ [arg])\ngetAppChain term = (term, [])\n\nisNul :: CT -> Bool\nisNul CNul = True\nisNul _ = False\n\ngetFunctionNames :: String -> [String]\ngetFunctionNames js = \n [ name | line <- lines js,\n \"const \" `isPrefixOf` line,\n let parts = words line,\n length parts >= 2,\n let name = head $ words $ parts !! 1,\n not $ \"$\" `isSuffixOf` name -- Skip internal functions ending with $\n ]\n\n-- Stringification\n-- ---------------\n\n-- TODO: implement a showCT :: CT -> String function\nshowCT :: CT -> Int -> String\nshowCT CNul dep = \"*\"\nshowCT CSet dep = \"Set\"\nshowCT CU64 dep = \"U64\"\nshowCT CF64 dep = \"F64\"\nshowCT (CADT cts) dep = \"data{\" ++ concatMap (\\ (n,fs) -> \"#\" ++ n ++ \" \" ++ concatMap (\\ (fn,ft) -> fn ++ \":\" ++ showCT ft dep ++ \" \") fs) cts ++ \"}\"\nshowCT (CMap typ) dep = \"(Map \" ++ showCT typ dep ++ \")\"\nshowCT (CLam (nam,inp) bod) dep = \"λ(\" ++ nam ++ \": \" ++ showCT inp dep ++ \"). \" ++ showCT (bod (CVar nam dep)) (dep+1)\nshowCT (CAll (nam,inp) bod) dep = \"∀(\" ++ nam ++ \": \" ++ showCT inp dep ++ \"). \" ++ showCT (bod (CVar nam dep)) (dep+1)\nshowCT (CApp fun arg) dep = \"(\" ++ showCT fun dep ++ \" \" ++ showCT arg dep ++ \")\"\nshowCT (CCon nam fields) dep = \"#\" ++ nam ++ \"{\" ++ concatMap (\\ (f,v) -> f ++ \":\" ++ showCT v dep ++ \" \") fields ++ \"}\"\nshowCT (CMat val cses) dep = \"match \" ++ showCT val dep ++ \" {\" ++ concatMap (\\(cn,fs,cb) -> \"#\" ++ cn ++ \":\" ++ showCT cb dep ++ \" \") cses ++ \"}\"\nshowCT (CRef nam) dep = nam\nshowCT (CHol nam) dep = nam\nshowCT (CLet (nam,typ) val bod) dep = \"let \" ++ nam ++ \" : \" ++ showCT typ dep ++ \" = \" ++ showCT val dep ++ \"; \" ++ showCT (bod (CVar nam dep)) (dep+1)\nshowCT (CNum val) dep = show val\nshowCT (CFlt val) dep = show val\nshowCT (COp2 typ opr fst snd) dep = \"( \" ++ showCT fst dep ++ \" \" ++ showCT snd dep ++ \")\"\nshowCT (CSwi val zer suc) dep = \"switch \" ++ showCT val dep ++ \" {0:\" ++ showCT zer dep ++ \" _: \" ++ showCT suc dep ++ \"}\"\nshowCT (CKVs kvs def) dep = \"{\" ++ unwords (map (\\(k,v) -> show k ++ \":\" ++ showCT v dep) (IM.toList kvs)) ++ \" | \" ++ showCT def dep ++ \"}\"\nshowCT (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)\nshowCT (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)\nshowCT (CLog msg nxt) dep = \"log(\" ++ showCT msg dep ++ \",\" ++ showCT nxt dep ++ \")\"\nshowCT (CVar nam dep) _ = nam ++ \"^\" ++ show dep\nshowCT (CTxt txt) dep = show txt\nshowCT (CLst lst) dep = \"[\" ++ unwords (map (\\x -> showCT x dep) lst) ++ \"]\"\nshowCT (CNat val) dep = show val\n" }, { "path": "src/Kind/Env.hs", "content": "module Kind.Env where\n\nimport Kind.Type\n\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\n\n-- Environment\n-- -----------\n\nenvBind :: Env a -> (a -> Env b) -> Env b\nenvBind (Env a) b = Env $ \\state -> case a state of\n Done state' value -> let Env b' = b value in b' state'\n Fail state' -> Fail state'\n\nenvPure :: a -> Env a\nenvPure a = Env $ \\state -> Done state a\n\nenvFail :: Env a\nenvFail = Env $ \\state -> Fail state\n\nenvRun :: Env a -> Book -> Res a\nenvRun (Env chk) book = chk (State book IM.empty [] [])\n\nenvLog :: Info -> Env Int\nenvLog log = Env $ \\ (State book fill susp logs) -> Done (State book fill susp (log : logs)) 1\n\nenvSnapshot :: Env State\nenvSnapshot = Env $ \\state -> Done state state\n\nenvRewind :: State -> Env Int\nenvRewind state = Env $ \\_ -> Done state 0\n\nenvSusp :: Check -> Env ()\nenvSusp chk = Env $ \\ (State book fill susp logs) -> Done (State book fill (susp ++ [chk]) logs) ()\n\nenvFill :: Int -> Term -> Env ()\nenvFill k v = Env $ \\ (State book fill susp logs) -> Done (State book (IM.insert k v fill) susp logs) ()\n\nenvGetFill :: Env Fill\nenvGetFill = Env $ \\ (State book fill susp logs) -> Done (State book fill susp logs) fill\n\nenvGetBook :: Env Book\nenvGetBook = Env $ \\ (State book fill susp logs) -> Done (State book fill susp logs) book\n\nenvTakeSusp :: Env [Check]\nenvTakeSusp = Env $ \\ (State book fill susp logs) -> Done (State book fill [] logs) susp\n\ninstance Functor Env where\n fmap f (Env chk) = Env $ \\logs -> case chk logs of\n Done logs' a -> Done logs' (f a)\n Fail logs' -> Fail logs'\n\ninstance Applicative Env where\n pure = envPure\n (Env chkF) <*> (Env chkA) = Env $ \\logs -> case chkF logs of\n Done logs' f -> case chkA logs' of\n Done logs'' a -> Done logs'' (f a)\n Fail logs'' -> Fail logs''\n Fail logs' -> Fail logs'\n\ninstance Monad Env where\n (Env a) >>= b = envBind (Env a) b\n" }, { "path": "src/Kind/Equal.hs", "content": "-- //./Type.hs//\n\nmodule Kind.Equal where\n\nimport Control.Monad (zipWithM)\n\nimport Debug.Trace\n\nimport Kind.Type\nimport Kind.Env\nimport Kind.Reduce\nimport Kind.Show\n\nimport qualified Data.Map.Strict as M\nimport qualified Data.IntMap.Strict as IM\n\n-- Equality\n-- --------\n\n-- Checks if two terms are equal, after reduction steps\nequal :: Term -> Term -> Int -> Env Bool\nequal a b dep = debug (\"== \" ++ showTermGo False a dep ++ \"\\n.. \" ++ showTermGo False b dep) $ do\n -- If both terms are identical, return true\n state <- envSnapshot\n is_id <- identical a b dep\n if is_id then do\n envPure True\n -- Otherwise, reduces both terms to wnf\n else do\n envRewind state\n book <- envGetBook\n fill <- envGetFill\n let aWnf = reduce book fill 2 a\n let bWnf = reduce book fill 2 b\n -- If both term wnfs are identical, return true\n state <- envSnapshot\n is_id <- identical aWnf bWnf dep\n if is_id then do\n envPure True\n -- Otherwise, check if they're component-wise equal\n else do\n envRewind state\n similar aWnf bWnf dep\n\n-- Checks if two terms are already syntactically identical\nidentical :: Term -> Term -> Int -> Env Bool\nidentical a b dep = do\n fill <- envGetFill\n 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\n where\n go (All aNam aInp aBod) (All bNam bInp bBod) dep = do\n iInp <- identical aInp bInp dep\n iBod <- identical (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n return (iInp && iBod)\n go (Lam aNam aBod) (Lam bNam bBod) dep =\n identical (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n go (App aFun aArg) (App bFun bArg) dep = do\n iFun <- identical aFun bFun dep\n iArg <- identical aArg bArg dep\n return (iFun && iArg)\n go (Slf aNam aTyp aBod) (Slf bNam bTyp bBod) dep =\n identical aTyp bTyp dep\n go (Ins aVal) b dep =\n identical aVal b dep\n go a (Ins bVal) dep =\n identical a bVal dep\n go (ADT aScp aCts aTyp) (ADT bScp bCts bTyp) dep = do\n identical aTyp bTyp dep\n go (Con aNam aArg) (Con bNam bArg) dep = do\n if aNam == bNam && length aArg == length bArg\n then and <$> zipWithM (\\(_, aVal) (_, bVal) -> identical aVal bVal dep) aArg bArg\n else return False\n go (Mat aCse) (Mat bCse) dep = do\n if length aCse == length bCse\n then and <$> zipWithM goCse aCse bCse\n else return False\n go (Let aNam aVal aBod) b dep =\n identical (aBod aVal) b dep\n go a (Let bNam bVal bBod) dep =\n identical a (bBod bVal) dep\n go (Use aNam aVal aBod) b dep =\n identical (aBod aVal) b dep\n go a (Use bNam bVal bBod) dep =\n identical a (bBod bVal) dep\n go Set Set dep =\n return True\n go (Ann chk aVal aTyp) b dep =\n identical aVal b dep\n go a (Ann chk bVal bTyp) dep =\n identical a bVal dep\n go (Met aUid aSpn) b dep = do\n fill <- envGetFill\n case IM.lookup aUid fill of\n Just sol -> identical sol b dep\n Nothing -> unify aUid aSpn b dep\n go a (Met bUid bSpn) dep = do\n fill <- envGetFill\n case IM.lookup bUid fill of\n Just sol -> identical a sol dep\n Nothing -> unify bUid bSpn a dep\n go (Log aMsg aNxt) b dep =\n identical aNxt b dep\n go a (Log bMsg bNxt) dep =\n identical a bNxt dep\n go (Hol aNam aCtx) b dep =\n return True\n go a (Hol bNam bCtx) dep =\n return True\n go U64 U64 dep =\n return True\n go F64 F64 dep =\n return True\n go (Num aVal) (Num bVal) dep =\n return (aVal == bVal)\n go (Flt aVal) (Flt bVal) dep =\n return (aVal == bVal)\n go (Op2 aOpr aFst aSnd) (Op2 bOpr bFst bSnd) dep = do\n iFst <- identical aFst bFst dep\n iSnd <- identical aSnd bSnd dep\n return (iFst && iSnd)\n go (Swi aZer aSuc) (Swi bZer bSuc) dep = do\n iZer <- identical aZer bZer dep\n iSuc <- identical aSuc bSuc dep\n return (iZer && iSuc)\n go (Map aTyp) (Map bTyp) dep =\n identical aTyp bTyp dep\n go (KVs aMap aDef) (KVs bMap bDef) dep = do\n iDef <- identical aDef bDef dep\n iMap <- flip mapM (IM.toList aMap) $ \\ (aKey,aVal) ->\n case IM.lookup aKey bMap of\n Just bVal -> identical aVal bVal dep\n Nothing -> return False\n return (iDef && and iMap && IM.size aMap == IM.size bMap)\n go (Get aGot aNam aMap aKey aBod) (Get bGot bNam bMap bKey bBod) dep = do\n iMap <- identical aMap bMap dep\n iKey <- identical aKey bKey dep\n iBod <- identical (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2)\n return (iMap && iKey && iBod)\n go (Put aGot aNam aMap aKey aVal aBod) (Put bGot bNam bMap bKey bVal bBod) dep = do\n iMap <- identical aMap bMap dep\n iKey <- identical aKey bKey dep\n iVal <- identical aVal bVal dep\n iBod <- identical (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2)\n return (iMap && iKey && iVal && iBod)\n go (Txt aTxt) (Txt bTxt) dep =\n return (aTxt == bTxt)\n go (Lst aLst) (Lst bLst) dep =\n if length aLst == length bLst\n then and <$> zipWithM (\\a b -> identical a b dep) aLst bLst\n else return False\n go (Nat aVal) (Nat bVal) dep =\n return (aVal == bVal)\n go (Src aSrc aVal) b dep =\n identical aVal b dep\n go a (Src bSrc bVal) dep =\n identical a bVal dep\n go (Ref aNam) (Ref bNam) dep =\n return (aNam == bNam)\n go (Var aNam aIdx) (Var bNam bIdx) dep =\n return (aIdx == bIdx)\n go a b dep =\n return False\n\n goCtr (Ctr aCNm aTele) (Ctr bCNm bTele) = do\n if aCNm == bCNm\n then goTele aTele bTele dep\n else return False\n\n goCse (aCNam, aCBod) (bCNam, bCBod) = do\n if aCNam == bCNam\n then identical aCBod bCBod dep\n else return False\n\n goTele :: Tele -> Tele -> Int -> Env Bool\n goTele (TRet aTerm) (TRet bTerm) dep = identical aTerm bTerm dep\n goTele (TExt aNam aTyp aBod) (TExt bNam bTyp bBod) dep = do\n iTyp <- identical aTyp bTyp dep\n iBod <- goTele (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n return (iTyp && iBod)\n goTele _ _ _ = return False\n\n-- Checks if two terms are component-wise equal\nsimilar :: Term -> Term -> Int -> Env Bool\nsimilar a b dep = go a b dep where\n go (All aNam aInp aBod) (All bNam bInp bBod) dep = do\n eInp <- equal aInp bInp dep\n eBod <- equal (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n return (eInp && eBod)\n go (Lam aNam aBod) (Lam bNam bBod) dep =\n equal (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n go (App aFun aArg) (App bFun bArg) dep = do\n eFun <- similar aFun bFun dep\n eArg <- equal aArg bArg dep\n return (eFun && eArg)\n go (Slf aNam aTyp aBod) (Slf bNam bTyp bBod) dep = do\n book <- envGetBook\n similar (reduce book IM.empty 0 aTyp) (reduce book IM.empty 0 bTyp) dep\n go (ADT aScp aCts aTyp) (ADT bScp bCts bTyp) dep = do\n book <- envGetBook\n similar (reduce book IM.empty 0 aTyp) (reduce book IM.empty 0 bTyp) dep\n -- eSlf <- zipWithM (\\ax bx -> equal ax bx dep) aScp bScp\n -- if and eSlf && length aCts == length bCts\n -- then and <$> zipWithM goCtr aCts bCts\n -- else return False\n go (Con aNam aArg) (Con bNam bArg) dep = do\n if aNam == bNam && length aArg == length bArg\n then and <$> zipWithM (\\(_, aVal) (_, bVal) -> equal aVal bVal dep) aArg bArg\n else return False\n go (Mat aCse) (Mat bCse) dep = do\n if length aCse == length bCse\n then and <$> zipWithM goCse aCse bCse\n else return False\n go (Op2 aOpr aFst aSnd) (Op2 bOpr bFst bSnd) dep = do\n eFst <- equal aFst bFst dep\n eSnd <- equal aSnd bSnd dep\n return (eFst && eSnd)\n go (Swi aZer aSuc) (Swi bZer bSuc) dep = do\n eZer <- equal aZer bZer dep\n eSuc <- equal aSuc bSuc dep\n return (eZer && eSuc)\n go (Map aTyp) (Map bTyp) dep = do\n equal aTyp bTyp dep\n go (KVs aMap aDef) (KVs bMap bDef) dep = do\n eDef <- equal aDef bDef dep\n eMap <- flip mapM (IM.toList aMap) $ \\ (aKey,aVal) ->\n case IM.lookup aKey bMap of\n Just bVal -> equal aVal bVal dep\n Nothing -> return False\n return (eDef && and eMap && IM.size aMap == IM.size bMap)\n go (Get aGot aNam aMap aKey aBod) (Get bGot bNam bMap bKey bBod) dep = do\n eMap <- equal aMap bMap dep\n eKey <- equal aKey bKey dep\n eBod <- equal (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2)\n return (eMap && eKey && eBod)\n go (Put aGot aNam aMap aKey aVal aBod) (Put bGot bNam bMap bKey bVal bBod) dep = do\n eMap <- equal aMap bMap dep\n eKey <- equal aKey bKey dep\n eVal <- equal aVal bVal dep\n eBod <- equal (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2)\n return (eMap && eKey && eVal && eBod)\n go a b dep = identical a b dep\n\n goCtr (Ctr aCNm aTele) (Ctr bCNm bTele) = do\n if aCNm == bCNm\n then goTele aTele bTele dep\n else return False\n\n goCse (aCNam, aCBod) (bCNam, bCBod) = do\n if aCNam == bCNam\n then equal aCBod bCBod dep\n else return False\n\n goTele :: Tele -> Tele -> Int -> Env Bool\n goTele (TRet aTerm) (TRet bTerm) dep = equal aTerm bTerm dep\n goTele (TExt aNam aTyp aBod) (TExt bNam bTyp bBod) dep = do\n eTyp <- equal aTyp bTyp dep\n eBod <- goTele (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n return (eTyp && eBod)\n goTele _ _ _ = return False\n\n-- Unification\n-- -----------\n\n-- If possible, solves a (?X x y z ...) = K problem, generating a subst.\nunify :: Int -> [Term] -> Term -> Int -> Env Bool\nunify uid spn b dep = do\n book <- envGetBook\n fill <- envGetFill\n\n -- is this hole not already solved?\n let solved = IM.member uid fill\n\n -- does the spine satisfies conditions?\n let solvable = valid fill spn []\n\n -- is the solution not recursive?\n let no_loops = not $ occur book fill uid b dep\n\n debug (\"unify: \" ++ show uid ++ \" \" ++ showTermGo False b dep ++ \" | \" ++ show solved ++ \" \" ++ show solvable ++ \" \" ++ show no_loops) $ do\n if not solved && solvable && no_loops then do\n let solution = solve book fill uid spn b\n debug (\"solve: \" ++ show uid ++ \" \" ++ showTermGo False solution dep ++ \" | spn: \" ++ show (map (\\t -> showTermGo False t dep) spn)) $ envFill uid solution\n return True\n\n -- Otherwise, return true iff both are identical metavars\n else case b of\n (Src bSrc bVal) -> unify uid spn bVal dep\n (Met bUid bSpn) -> return $ uid == bUid\n other -> return $ False\n\n-- Checks if a problem is solveable by pattern unification.\nvalid :: Fill -> [Term] -> [Int] -> Bool\nvalid fill [] vars = True\nvalid fill (x : spn) vars = case reduce M.empty fill 0 x of\n (Var nam idx) -> not (elem idx vars) && valid fill spn (idx : vars)\n otherwise -> False\n\n-- Generates the solution, adding binders and renaming variables.\nsolve :: Book -> Fill -> Int -> [Term] -> Term -> Term\nsolve book fill uid [] b = b\nsolve book fill uid (x : spn) b = case reduce book fill 0 x of\n (Var nam idx) -> Lam nam $ \\x -> subst idx x (solve book fill uid spn b)\n otherwise -> error \"unreachable\"\n\n-- Checks if a metavar uid occurs recursively inside a term\noccur :: Book -> Fill -> Int -> Term -> Int -> Bool\noccur book fill uid term dep = go term dep where\n go (All nam inp bod) dep =\n let o_inp = go inp dep\n o_bod = go (bod (Var nam dep)) (dep + 1)\n in o_inp || o_bod\n go (Lam nam bod) dep =\n let o_bod = go (bod (Var nam dep)) (dep + 1)\n in o_bod\n go (App fun arg) dep =\n let o_fun = go fun dep\n o_arg = go arg dep\n in o_fun || o_arg\n go (Ann chk val typ) dep =\n let o_val = go val dep\n o_typ = go typ dep\n in o_val || o_typ\n go (Slf nam typ bod) dep =\n let o_typ = go typ dep\n o_bod = go (bod (Var nam dep)) (dep + 1)\n in o_typ || o_bod\n go (Ins val) dep =\n let o_val = go val dep\n in o_val\n go (ADT scp cts typ) dep =\n let o_scp = any (\\x -> go x dep) scp\n o_cts = any (\\(Ctr _ tele) -> goTele tele dep) cts\n a_typ = go typ dep\n in o_scp || o_cts || a_typ\n go (Con nam arg) dep =\n any (\\(_, x) -> go x dep) arg\n go (Mat cse) dep =\n any (\\ (_, cbod) -> go cbod dep) cse\n go (Let nam val bod) dep =\n let o_val = go val dep\n o_bod = go (bod (Var nam dep)) (dep + 1)\n in o_val || o_bod\n go (Use nam val bod) dep =\n let o_val = go val dep\n o_bod = go (bod (Var nam dep)) (dep + 1)\n in o_val || o_bod\n go (Log msg nxt) dep =\n let o_msg = go msg dep\n o_nxt = go nxt dep\n in o_msg || o_nxt\n go (Hol nam ctx) dep =\n False\n go (Op2 opr fst snd) dep =\n let o_fst = go fst dep\n o_snd = go snd dep\n in o_fst || o_snd\n go (Swi zer suc) dep =\n let o_zer = go zer dep\n o_suc = go suc dep\n in o_zer || o_suc\n go (Map typ) dep =\n let o_typ = go typ dep\n in o_typ\n go (KVs map def) dep =\n let o_map = any (\\(_, x) -> go x dep) (IM.toList map)\n o_def = go def dep\n in o_map || o_def\n go (Get got nam map key bod) dep =\n let o_map = go map dep\n o_key = go key dep\n o_bod = go (bod (Var got dep) (Var nam dep)) (dep + 2)\n in o_map || o_key || o_bod\n go (Put got nam map key val bod) dep =\n let o_map = go map dep\n o_key = go key dep\n o_val = go val dep\n o_bod = go (bod (Var got dep) (Var nam dep)) (dep + 2)\n in o_map || o_key || o_val || o_bod\n go (Src src val) dep =\n let o_val = go val dep\n in o_val\n go (Met bUid bSpn) dep =\n case reduce book fill 2 (Met bUid bSpn) of\n Met bUid bSpn -> uid == bUid\n term -> go term dep\n go _ dep =\n False\n\n goTele :: Tele -> Int -> Bool\n goTele (TRet term) dep = go term dep\n goTele (TExt nam typ bod) dep =\n let o_typ = go typ dep\n o_bod = goTele (bod (Var nam dep)) (dep + 1)\n in o_typ || o_bod\n\n-- Substitution\n-- ------------\n\n-- This is the ugly / slow part of Kind. See: https://gist.github.com/VictorTaelin/48eed41a8eca3500721c06dfec72d48c\n\n-- Behaves like 'identical', except it is pure and returns a Bool.\nsame :: Term -> Term -> Int -> Bool\nsame (All aNam aInp aBod) (All bNam bInp bBod) dep =\n let sInp = same aInp bInp dep\n sBod = same (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n in sInp && sBod\nsame (Lam aNam aBod) (Lam bNam bBod) dep =\n let sBod = same (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n in sBod\nsame (App aFun aArg) (App bFun bArg) dep =\n let sFun = same aFun bFun dep\n sArg = same aArg bArg dep\n in sFun && sArg\nsame (Slf aNam aTyp aBod) (Slf bNam bTyp bBod) dep =\n let sTyp = same aTyp bTyp dep\n in sTyp\nsame (Ins aVal) b dep =\n same aVal b dep\nsame a (Ins bVal) dep =\n same a bVal dep\nsame (ADT aScp aCts aTyp) (ADT bScp bCts bTyp) dep =\n -- let sSlf = and $ zipWith (\\ax bx -> same ax bx dep) aScp bScp\n -- sCts = length aCts == length bCts && and (zipWith (\\ a b -> sameCtr a b dep) aCts bCts)\n let sTyp = same aTyp bTyp dep\n in sTyp\nsame (Con aNam aArg) (Con bNam bArg) dep =\n let sNam = aNam == bNam\n sArg = length aArg == length bArg && and (zipWith (\\(_, aVal) (_, bVal) -> same aVal bVal dep) aArg bArg)\n in sNam && sArg\nsame (Mat aCse) (Mat bCse) dep =\n let sCse = length aCse == length bCse && and (zipWith (\\ a b -> sameCse a b dep) aCse bCse)\n in sCse\nsame (Let aNam aVal aBod) b dep =\n same (aBod aVal) b dep\nsame a (Let bNam bVal bBod) dep =\n same a (bBod bVal) dep\nsame (Use aNam aVal aBod) b dep =\n same (aBod aVal) b dep\nsame a (Use bNam bVal bBod) dep =\n same a (bBod bVal) dep\nsame Set Set dep =\n True\nsame (Ann chk aVal aTyp) b dep =\n same aVal b dep\nsame a (Ann chk bVal bTyp) dep =\n same a bVal dep\nsame (Met aUid aSpn) b dep =\n False\nsame a (Met bUid bSpn) dep =\n False\n-- TODO: Log\nsame (Log aMsg aNxt) b dep =\n same aNxt b dep\nsame a (Log bMsg bNxt) dep =\n same a bNxt dep\nsame (Hol aNam aCtx) b dep =\n True\nsame a (Hol bNam bCtx) dep =\n True\nsame U64 U64 dep =\n True\nsame F64 F64 dep =\n True\nsame (Num aVal) (Num bVal) dep =\n aVal == bVal\nsame (Flt aVal) (Flt bVal) dep =\n aVal == bVal\nsame (Op2 aOpr aFst aSnd) (Op2 bOpr bFst bSnd) dep =\n same aFst bFst dep && same aSnd bSnd dep\nsame (Swi aZer aSuc) (Swi bZer bSuc) dep =\n same aZer bZer dep && same aSuc bSuc dep\nsame (Map aTyp) (Map bTyp) dep =\n same aTyp bTyp dep\nsame (KVs aMap aDef) (KVs bMap bDef) dep =\n let sDef = same aDef bDef dep\n 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))\n in sDef && sMap\nsame (Get aGot aNam aMap aKey aBod) (Get bGot bNam bMap bKey bBod) dep =\n let sMap = same aMap bMap dep\n sKey = same aKey bKey dep\n sBod = same (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2)\n in sMap && sKey && sBod\nsame (Put aGot aNam aMap aKey aVal aBod) (Put bGot bNam bMap bKey bVal bBod) dep =\n let sMap = same aMap bMap dep\n sKey = same aKey bKey dep\n sVal = same aVal bVal dep\n sBod = same (aBod (Var aGot dep) (Var aNam dep)) (bBod (Var bGot dep) (Var bNam dep)) (dep + 2)\n in sMap && sKey && sVal && sBod\nsame (Txt aTxt) (Txt bTxt) dep =\n aTxt == bTxt\nsame (Lst aLst) (Lst bLst) dep =\n length aLst == length bLst && and (zipWith (\\a b -> same a b dep) aLst bLst)\nsame (Nat aVal) (Nat bVal) dep =\n aVal == bVal\nsame (Src aSrc aVal) b dep =\n same aVal b dep\nsame a (Src bSrc bVal) dep =\n same a bVal dep\nsame (Ref aNam) (Ref bNam) dep =\n aNam == bNam\nsame (Var aNam aIdx) (Var bNam bIdx) dep =\n aIdx == bIdx\nsame _ _ _ = False\n\n-- Auxiliary functions\nsameCtr :: Ctr -> Ctr -> Int -> Bool\nsameCtr (Ctr aCNm aTele) (Ctr bCNm bTele) dep =\n if aCNm == bCNm\n then sameTele aTele bTele dep\n else False\n\nsameCse :: (String, Term) -> (String, Term) -> Int -> Bool\nsameCse (aCNam, aCBod) (bCNam, bCBod) dep =\n if aCNam == bCNam\n then same aCBod bCBod dep\n else False\n\nsameTele :: Tele -> Tele -> Int -> Bool\nsameTele (TRet aTerm) (TRet bTerm) dep = same aTerm bTerm dep\nsameTele (TExt aNam aTyp aBod) (TExt bNam bTyp bBod) dep =\n let sTyp = same aTyp bTyp dep\n sBod = sameTele (aBod (Var aNam dep)) (bBod (Var bNam dep)) (dep + 1)\n in sTyp && sBod\nsameTele _ _ _ = False\n\n-- Substitutes a Bruijn level variable by a neo value in term.\nsubst :: Int -> Term -> Term -> Term\nsubst lvl neo term = go term where\n go (All nam inp bod) = All nam (go inp) (\\x -> go (bod (Sub x)))\n go (Lam nam bod) = Lam nam (\\x -> go (bod (Sub x)))\n go (App fun arg) = App (go fun) (go arg)\n go (Ann chk val typ) = Ann chk (go val) (go typ)\n go (Slf nam typ bod) = Slf nam (go typ) (\\x -> go (bod (Sub x)))\n go (Ins val) = Ins (go val)\n go (ADT scp cts typ) = ADT (map go scp) (map goCtr cts) (go typ)\n go (Con nam arg) = Con nam (map (\\(f, t) -> (f, go t)) arg)\n go (Mat cse) = Mat (map goCse cse)\n go (Swi zer suc) = Swi (go zer) (go suc)\n go (Map typ) = Map (go typ)\n go (KVs map def) = KVs (IM.map go map) (go def)\n go (Get g n m k b) = Get g n (go m) (go k) (\\x y -> go (b x y))\n go (Put g n m k v b) = Put g n (go m) (go k) (go v) (\\x y -> go (b x y))\n go (Use nam val bod) = Use nam (go val) (\\x -> go (bod (Sub x)))\n go (Met uid spn) = Met uid (map go spn)\n go (Log msg nxt) = Log (go msg) (go nxt)\n go (Hol nam ctx) = Hol nam (map go ctx)\n go Set = Set\n go U64 = U64\n go F64 = F64\n go (Num n) = Num n\n go (Flt n) = Flt n\n go (Op2 opr fst snd) = Op2 opr (go fst) (go snd)\n go (Txt txt) = Txt txt\n go (Lst lst) = Lst (map go lst)\n go (Nat val) = Nat val\n go (Var nam idx) = if lvl == idx then neo else Var nam idx\n go (Src src val) = Src src (go val)\n go (Sub val) = val\n goCtr (Ctr nm tele) = Ctr nm (goTele tele)\n goCse (cnam, cbod) = (cnam, go cbod)\n goTele (TRet term) = TRet (go term)\n goTele (TExt k t b) = TExt k (go t) (\\x -> goTele (b x))\n\n-- Replaces a term by another\nreplace :: Term -> Term -> Term -> Int -> Term\nreplace old neo term dep = if same old term dep then neo else go term where\n go (All nam inp bod) = All nam (replace old neo inp dep) (\\x -> replace old neo (bod (Sub x)) (dep+1))\n go (Lam nam bod) = Lam nam (\\x -> replace old neo (bod (Sub x)) (dep+1))\n go (App fun arg) = App (replace old neo fun dep) (replace old neo arg dep)\n go (Ann chk val typ) = Ann chk (replace old neo val dep) (replace old neo typ dep)\n go (Slf nam typ bod) = Slf nam (replace old neo typ dep) (\\x -> replace old neo (bod (Sub x)) (dep+1))\n go (Ins val) = Ins (replace old neo val dep)\n go (ADT scp cts typ) = ADT (map (\\x -> replace old neo x (dep+1)) scp) (map goCtr cts) (replace old neo typ dep)\n go (Con nam arg) = Con nam (map (\\(f, t) -> (f, replace old neo t dep)) arg)\n go (Mat cse) = Mat (map goCse cse)\n go (Swi zer suc) = Swi (replace old neo zer dep) (replace old neo suc dep)\n go (Map typ) = Map (replace old neo typ dep)\n go (KVs map def) = KVs (IM.map (\\x -> replace old neo x dep) map) (replace old neo def dep)\n 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))\n 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))\n go (Ref nam) = Ref nam\n go (Let nam val bod) = Let nam (replace old neo val dep) (\\x -> replace old neo (bod (Sub x)) (dep+1))\n go (Use nam val bod) = Use nam (replace old neo val dep) (\\x -> replace old neo (bod (Sub x)) (dep+1))\n go (Met uid spn) = Met uid (map (\\x -> replace old neo x (dep+1)) spn)\n go (Log msg nxt) = Log (replace old neo msg dep) (replace old neo nxt dep)\n go (Hol nam ctx) = Hol nam (map (\\x -> replace old neo x (dep+1)) ctx)\n go Set = Set\n go U64 = U64\n go F64 = F64\n go (Num n) = Num n\n go (Flt n) = Flt n\n go (Op2 opr fst snd) = Op2 opr (replace old neo fst dep) (replace old neo snd dep)\n go (Txt txt) = Txt txt\n go (Lst lst) = Lst (map (\\x -> replace old neo x dep) lst)\n go (Nat val) = Nat val\n go (Var nam idx) = Var nam idx\n go (Src src val) = Src src (replace old neo val dep)\n go (Sub val) = val\n goCtr (Ctr nm tele) = Ctr nm (goTele tele dep)\n goCse (cnam, cbod) = (cnam, replace old neo cbod dep)\n goTele (TRet term) d = TRet (replace old neo term d)\n goTele (TExt k t b) d = TExt k (replace old neo t d) (\\x -> goTele (b x) (d+1))\n\n-- Returns true when two terms can definitely never be made identical.\n-- TODO: to implement this, just recurse pairwise on the Con constructor,\n-- until a different name is found. All other terms are considered compatible.\nincompatible :: Term -> Term -> Int -> Bool\nincompatible (Con aNam aArg) (Con bNam bArg) dep | aNam /= bNam = True\nincompatible (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))\nincompatible (Src aSrc aVal) b dep = incompatible aVal b dep\nincompatible a (Src bSrc bVal) dep = incompatible a bVal dep\nincompatible _ _ _ = False\n" }, { "path": "src/Kind/Parse.hs", "content": "-- //./Type.hs//\n\nmodule Kind.Parse where\n\nimport Data.Char (ord)\nimport Data.Functor.Identity (Identity)\nimport Data.List (intercalate, isPrefixOf, uncons, unsnoc, find, transpose)\nimport Data.Maybe (catMaybes, fromJust, isJust)\nimport Data.Set (toList, fromList)\nimport Data.Word\nimport Debug.Trace\nimport Highlight (highlightError, highlight)\nimport Kind.Equal\nimport Kind.Reduce\nimport Kind.Show\nimport Kind.Type\nimport Prelude hiding (EQ, LT, GT)\nimport System.Console.ANSI\nimport Text.Parsec ((), (<|>), getPosition, sourceLine, sourceColumn, getState, setState)\nimport Text.Parsec.Error (errorPos, errorMessages, showErrorMessages, ParseError, errorMessages, Message(..))\nimport qualified Control.Applicative as A\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\nimport qualified Text.Parsec as P\n\ntype Uses = [(String, String)]\ntype PState = (String, Int, Uses)\ntype Parser a = P.ParsecT String PState Identity a\n-- Types used for flattening pattern-matching equations\ntype Rule = ([Pattern], Term)\ndata Pattern = PVar String | PCtr (Maybe String) String [Pattern] | PNum Word64 | PSuc Word64 String\n\n-- Helper functions that consume trailing whitespace\nskip :: Parser ()\nskip = P.skipMany (parseSpace <|> parseComment)\n where\n parseSpace = (P.try $ do\n P.space\n return ()) \"Space\"\n parseComment = (P.try $ do\n P.string \"//\"\n P.skipMany (P.noneOf \"\\n\")\n P.char '\\n'\n return ()) \"Comment\"\n\nchar :: Char -> Parser Char\nchar c = P.char c\n\nstring :: String -> Parser String\nstring s = P.string s\n\nchar_skp :: Char -> Parser Char\nchar_skp c = P.char c <* skip\n\nstring_skp :: String -> Parser String\nstring_skp s = P.string s <* skip\n\nname_init :: Parser Char\nname_init = P.satisfy (`elem` \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/_.-$\")\n\nname_char :: Parser Char\nname_char = P.satisfy (`elem` \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789/_.-$\")\n\nname :: Parser String\nname = (do\n head <- name_init\n tail <- P.many name_char\n return (head : tail)) \"Name\"\n\nname_skp :: Parser String\nname_skp = name <* skip\n\ndigit :: Parser Char\ndigit = P.digit\n\nnumeric :: Parser String\nnumeric = (do\n head <- P.satisfy (`elem` \"0123456789\")\n tail <- P.many (P.satisfy (`elem` \"bx0123456789abcdefABCDEF_\"))\n return $ show (read (filter (/= '_') (head : tail)) :: Word64)) \"Number\"\n\nnumeric_skp :: Parser String\nnumeric_skp = numeric <* skip\n\noneOf :: String -> Parser Char\noneOf s = P.oneOf s\n\nnoneOf :: String -> Parser Char\nnoneOf s = P.noneOf s\n\nguardChoice :: [(Parser a, Parser ())] -> Parser a -> Parser a\nguardChoice [] df = df\nguardChoice ((p, g):ps) df = do\n guard <- P.lookAhead $ P.optionMaybe $ P.try g\n case guard of\n Just () -> p\n Nothing -> guardChoice ps df\n\ndiscard :: Parser a -> Parser ()\ndiscard p = p >> return ()\n\n-- Main parsing functions\ndoParseTerm :: String -> String -> IO Term\ndoParseTerm filename input =\n case P.runParser (parseTerm <* P.eof) (filename, 0, []) filename input of\n Left err -> do\n showParseError filename input err\n return $ Ref \"bad-parse\"\n Right term -> return $ bind (genMetas term) []\n\ndoParseUses :: String -> String -> IO Uses\ndoParseUses filename input =\n case P.runParser (parseUses <* P.eof) (filename, 0, []) filename input of\n Left err -> do\n showParseError filename input err\n return $ []\n Right uses -> return uses\n\ndoParseBook :: String -> String -> IO Book\ndoParseBook filename input = do\n let parser = do\n skip\n uses <- parseUses\n setState (filename, 0, uses)\n parseBook <* P.eof\n case P.runParser parser (filename, 0, []) filename input of\n Left err -> do\n showParseError filename input err\n return M.empty\n Right book -> return book\n\n-- Error handling\nextractExpectedTokens :: ParseError -> String\nextractExpectedTokens err =\n let expectedMsgs = [msg | Expect msg <- errorMessages err, msg /= \"Space\", msg /= \"Comment\"]\n in intercalate \" | \" expectedMsgs\n\nshowParseError :: String -> String -> P.ParseError -> IO ()\nshowParseError filename input err = do\n let pos = errorPos err\n let lin = sourceLine pos\n let col = sourceColumn pos\n let errorMsg = extractExpectedTokens err\n putStrLn $ setSGRCode [SetConsoleIntensity BoldIntensity] ++ \"\\nPARSE_ERROR\" ++ setSGRCode [Reset]\n putStrLn $ \"- expected: \" ++ errorMsg\n putStrLn $ \"- detected:\"\n putStrLn $ highlightError (lin, col) (lin, col + 1) input\n putStrLn $ setSGRCode [SetUnderlining SingleUnderline] ++ filename ++\n setSGRCode [Reset] ++ \" \" ++ show lin ++ \":\" ++ show col\n\n-- Parsing helpers\n-- FIXME: currently, this will include suffix trivia. how can we avoid that?\nwithSrc :: Parser Term -> Parser Term\nwithSrc parser = do\n ini <- getPosition\n val <- parser\n end <- getPosition\n (nam, _, _) <- P.getState\n skip\n let iniLoc = Loc nam (sourceLine ini) (sourceColumn ini)\n let endLoc = Loc nam (sourceLine end) (sourceColumn end)\n return $ Src (Cod iniLoc endLoc) val\n\n-- Term Parser\n-- -----------\n\n-- Main term parser\nparseTerm :: Parser Term\nparseTerm = do\n skip\n term <- guardChoice\n [ (parseAll, discard $ string_skp \"∀\")\n , (parseSwi, discard $ string_skp \"λ\" >> string_skp \"{\" >> string_skp \"0\")\n , (parseMat, discard $ string_skp \"λ\" >> string_skp \"{\" >> string_skp \"#\")\n , (parseLam, discard $ string_skp \"λ\")\n , (parseEra, discard $ string_skp \"λ\")\n , (parseOp2, discard $ string_skp \"(\" >> parseOper)\n , (parseMap, discard $ string_skp \"(Map \")\n , (parseApp, discard $ string_skp \"(\")\n , (parseSlf, discard $ string_skp \"$(\")\n , (parseIns, discard $ string_skp \"~\")\n , (parseADT, discard $ string_skp \"#[\" <|> string_skp \"data[\")\n , (parseNat, discard $ string_skp \"#\" >> digit)\n , (parseCon, discard $ string_skp \"#\" >> name)\n , ((parseUse parseTerm), discard $ string_skp \"use \")\n , ((parseLet parseTerm), discard $ string_skp \"let \")\n , ((parseGet parseTerm), discard $ string_skp \"get \")\n , ((parsePut parseTerm), discard $ string_skp \"put \")\n , (parseIf, discard $ string_skp \"if \")\n , (parseWhen, discard $ string_skp \"when \")\n , (parseMatInl, discard $ string_skp \"match \")\n , (parseSwiInl, discard $ string_skp \"switch \")\n , (parseKVs, discard $ string_skp \"{\")\n , (parseDo, discard $ string_skp \"do \")\n , (parseSet, discard $ string_skp \"*\")\n , (parseFloat, discard $ string_skp \"-\" <|> (P.many1 digit >> string_skp \".\"))\n , (parseNum, discard $ numeric)\n , (parseTxt, discard $ string_skp \"\\\"\")\n , (parseLst, discard $ string_skp \"[\")\n , (parseChr, discard $ string_skp \"'\")\n , (parseHol, discard $ string_skp \"?\")\n , ((parseLog parseTerm), discard $ string_skp \"log \")\n , (parseRef, discard $ name)\n ] $ fail \"Term\"\n skip\n parseSuffix term\n\n-- Individual term parsers\nparseAll = withSrc $ do\n string_skp \"∀\"\n era <- P.optionMaybe (char_skp '-')\n char_skp '('\n nam <- name_skp\n char_skp ':'\n inp <- parseTerm\n char_skp ')'\n bod <- parseTerm\n return $ All nam inp (\\x -> bod)\n\nparseLam = withSrc $ do\n string_skp \"λ\"\n era <- P.optionMaybe (char_skp '-')\n nam <- name_skp\n bod <- parseTerm\n return $ Lam nam (\\x -> bod)\n\nparseEra = withSrc $ do\n string_skp \"λ\"\n era <- P.optionMaybe (char_skp '-')\n nam <- char_skp '_'\n bod <- parseTerm\n return $ Lam \"_\" (\\x -> bod)\n\nparseApp = withSrc $ do\n char_skp '('\n fun <- parseTerm\n args <- P.many $ do\n P.notFollowedBy (char ')')\n era <- P.optionMaybe (char_skp '-')\n arg <- parseTerm\n return (era, arg)\n char ')'\n return $ foldl (\\f (era, a) -> App f a) fun args\n\nparseSlf = withSrc $ do\n string_skp \"$(\"\n nam <- name_skp\n char_skp ':'\n typ <- parseTerm\n char_skp ')'\n bod <- parseTerm\n return $ Slf nam typ (\\x -> bod)\n\nparseIns = withSrc $ do\n char_skp '~'\n val <- parseTerm\n return $ Ins val\n\nparseADT = withSrc $ do\n P.choice [string_skp \"#[\", string_skp \"data[\"]\n scp <- P.many parseTerm\n char_skp ']'\n char_skp '{'\n cts <- P.many $ P.try parseADTCtr\n char '}'\n typ <- do\n skip\n char_skp ':'\n parseTerm\n return $ ADT scp cts typ\n\nparseADTCtr :: Parser Ctr\nparseADTCtr = do\n char_skp '#'\n name <- name_skp\n tele <- parseTele\n return $ Ctr name tele\n\nparseTele :: Parser Tele\nparseTele = do\n fields <- P.option [] $ do\n char_skp '{'\n fields <- P.many $ P.try $ do\n nam <- name_skp\n char_skp ':'\n typ <- parseTerm\n return (nam, typ)\n char_skp '}'\n return fields\n ret <- P.choice\n [ do\n P.try $ char_skp ':'\n parseTerm\n , do\n return (Met 0 [])\n ]\n return $ foldr (\\(nam, typ) acc -> TExt nam typ (\\x -> acc)) (TRet ret) fields\n\nparseCon = withSrc $ do\n char_skp '#'\n nam <- name\n args <- P.option [] $ P.try $ do\n skip\n char_skp '{'\n args <- P.many $ do\n P.notFollowedBy (char_skp '}')\n name <- P.optionMaybe $ P.try $ do\n name <- name_skp\n char_skp ':'\n return name\n term <- parseTerm\n return (name, term)\n char '}'\n return args\n return $ Con nam args\n\nparseMatCases :: Parser [(String, Term)]\nparseMatCases = do\n cse <- P.many $ P.try $ do\n string_skp \"#\"\n cnam <- name_skp\n args <- P.option [] $ P.try $ do\n char_skp '{'\n names <- P.many name_skp\n char_skp '}'\n return names\n char_skp ':'\n cbod <- parseTerm\n return (cnam, foldr (\\arg acc -> Lam arg (\\_ -> acc)) cbod args)\n dflt <- P.optionMaybe $ do\n dnam <- P.try $ do\n dnam <- name_skp\n string_skp \":\"\n return dnam\n dbod <- parseTerm\n return (dnam, dbod)\n return $ case dflt of\n Just (dnam, dbod) -> cse ++ [(\"_\", (Lam dnam (\\_ -> dbod)))]\n Nothing -> cse\n\nparseSwiCases :: Parser Term\nparseSwiCases = do\n cse <- P.many $ P.try $ do\n cnam <- numeric_skp\n char_skp ':'\n cbod <- parseTerm\n return (cnam, cbod)\n dflt <- P.optionMaybe $ do\n dnam <- P.try $ do\n cnam <- numeric_skp\n char_skp '+'\n dnam <- name_skp\n string_skp \":\"\n return dnam\n dbod <- parseTerm\n return (dnam, dbod)\n case dflt of\n Just (dnam, dbod) -> return $ build (cse ++ [(\"_\", (Lam dnam (\\_ -> dbod)))]) 0\n Nothing -> return $ build cse 0\n where build :: [(String, Term)] -> Int -> Term\n build [] i = error \"Switch must have at least one case.\"\n build ((\"_\",t):cs) i = t\n build ((n,t):cs) i | read n == i = Swi t (build cs (i+1))\n build ((n,t):cs) i | otherwise = error \"Switch cases must be in ascending order starting from 0.\"\n\nparseSwiElim :: Parser Term\nparseSwiElim = do\n cases <- parseSwiCases\n return cases\n\nparseSwi = withSrc $ do\n char_skp 'λ'\n char_skp '{'\n P.lookAhead $ P.try $ char_skp '0'\n elim <- parseSwiElim\n char '}'\n return $ elim\n\nparseMat = withSrc $ do\n char_skp 'λ'\n char_skp '{'\n cse <- parseMatCases\n char '}'\n return $ Mat cse\n\n-- TODO: implement the Map parsers\nparseMap = withSrc $ do\n string_skp \"(Map \"\n typ <- parseTerm\n char ')'\n return $ Map typ\n\nparseKVs = withSrc $ do\n char_skp '{'\n kvs <- P.many parseKV\n char_skp '|'\n dft <- parseTerm\n char '}'\n return $ KVs (IM.fromList kvs) dft\n where\n parseKV = do\n key <- read <$> numeric_skp\n char_skp ':'\n val <- parseTerm\n return (key, val)\n\nparseGet parseBody = withSrc $ do\n string_skp \"get \"\n got <- name_skp\n string_skp \"=\"\n nam <- name_skp\n map <- P.option (Ref nam) $ P.try $ char_skp '@' >> parseTerm\n char_skp '['\n key <- parseTerm\n char_skp ']'\n bod <- parseBody\n return $ Get got nam map key (\\x y -> bod)\n\nparsePut parseBody = withSrc $ do\n string_skp \"put \"\n got <- P.option \"_\" $ P.try $ do\n got <- name_skp\n string_skp \"=\"\n return got\n nam <- name_skp\n map <- P.option (Ref nam) $ P.try $ char_skp '@' >> parseTerm\n char_skp '['\n key <- parseTerm\n char_skp ']'\n string_skp \":=\"\n val <- parseTerm\n bod <- parseBody\n return $ Put got nam map key val (\\x y -> bod)\n\nparseRef = withSrc $ do\n name <- name\n (_, _, uses) <- P.getState\n let name' = expandUses uses name\n return $ case name' of\n \"U64\" -> U64\n \"F64\" -> F64\n \"Set\" -> Set\n \"_\" -> Met 0 []\n _ -> Ref name'\n\nparseLocal :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term\nparseLocal header ctor parseBody = withSrc $ P.choice\n [ parseLocalMch header ctor parseBody\n , parseLocalPar header ctor parseBody\n , parseLocalVal header ctor parseBody\n ]\n\nparseLocalMch :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term\nparseLocalMch header ctor parseBody = do\n P.try $ string_skp (header ++ \" #\")\n cnam <- name_skp\n char_skp '{'\n args <- P.many name_skp\n char_skp '}'\n char_skp '='\n val <- parseTerm\n bod <- parseBody\n return $ ctor \"got\" val (\\got ->\n App (Mat [(cnam, foldr (\\arg acc -> Lam arg (\\_ -> acc)) bod args)]) got)\n\nparseLocalPar :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term\nparseLocalPar header ctor parseBody = do\n P.try $ string_skp (header ++ \" (\")\n head <- name_skp\n tail <- P.many $ do\n char_skp ','\n name_skp\n char_skp ')'\n let (init, last) = maybe ([], head) id $ unsnoc (head : tail)\n char_skp '='\n val <- parseTerm\n bod <- parseBody\n return $ ctor \"got\" val (\\got ->\n App (foldr (\\x acc -> Mat [(\"Pair\", Lam x (\\_ -> acc))]) (Lam last (\\_ -> bod)) init) got)\n\nparseLocalVal :: String -> (String -> Term -> (Term -> Term) -> Term) -> Parser Term -> Parser Term\nparseLocalVal header ctor parseBody = do\n P.try $ string_skp (header ++ \" \")\n nam <- name_skp\n char_skp '='\n val <- parseTerm\n bod <- parseBody\n return $ ctor nam val (\\x -> bod)\n\nparseLet :: Parser Term -> Parser Term\nparseLet = parseLocal \"let\" Let\n\nparseUse :: Parser Term -> Parser Term\nparseUse = parseLocal \"use\" Use\n\nparseSet = withSrc $ char '*' >> return Set\n\nparseFloat = withSrc $ P.try $ do\n -- Parse optional negative sign\n sign <- P.option id $ P.char '-' >> return negate\n\n -- Parse integer part\n intPart <- P.many1 digit\n\n -- Parse decimal part (this must succeed, or we fail the whole parser)\n decPart <- do\n char '.'\n P.many1 digit\n\n -- Parse optional exponent\n expPart <- P.option 0 $ P.try $ do\n oneOf \"eE\"\n expSign <- P.option '+' (oneOf \"+-\")\n exp <- read <$> P.many1 digit\n return $ if expSign == '-' then -exp else exp\n\n -- Combine parts into final float\n let floatStr = intPart ++ \".\" ++ decPart\n let value = (read floatStr :: Double) * (10 ^^ expPart)\n\n -- Apply the sign to the final value\n return $ Flt (sign value)\n\nparseNum = withSrc $ do\n val <- numeric\n return $ Num (read (filter (/= '_') val))\n\nparseOp2 = withSrc $ do\n char_skp '('\n opr <- parseOper\n fst <- parseTerm\n snd <- parseTerm\n char ')'\n return $ Op2 opr fst snd\n\nparseLst = withSrc $ do\n char_skp '['\n elems <- P.many parseTerm\n char ']'\n return $ Lst elems\n\nparseTxtChr :: Parser Char\nparseTxtChr = P.choice\n [ P.try $ do\n char_skp '\\\\'\n c <- oneOf \"\\\\\\\"nrtbf0/\\'\"\n return $ case c of\n '\\\\' -> '\\\\'\n '/' -> '/'\n '\"' -> '\"'\n '\\'' -> '\\''\n 'n' -> '\\n'\n 'r' -> '\\r'\n 't' -> '\\t'\n 'b' -> '\\b'\n 'f' -> '\\f'\n '0' -> '\\0'\n , P.try $ do\n string_skp \"\\\\u\"\n code <- P.count 4 P.hexDigit\n return $ toEnum (read (\"0x\" ++ code) :: Int)\n , noneOf \"\\\"\\\\\"\n ]\n\nparseTxt = withSrc $ do\n char '\"'\n txt <- P.many parseTxtChr\n char '\"'\n return $ Txt txt\n\nparseChr = withSrc $ do\n char '\\''\n chr <- parseTxtChr\n char '\\''\n return $ Num (fromIntegral $ ord chr)\n\nparseHol = withSrc $ do\n char_skp '?'\n nam <- name_skp\n ctx <- P.option [] $ do\n char_skp '['\n terms <- P.sepBy parseTerm (char_skp ',')\n char ']'\n return terms\n return $ Hol nam ctx\n\nparseLog parseBody = withSrc $ do\n string_skp \"log \"\n msg <- parseTerm\n val <- parseBody\n return $ Log msg val\n\nparseOper = P.choice\n [ P.try (string_skp \"+\") >> return ADD\n , P.try (string_skp \"-\") >> return SUB\n , P.try (string_skp \"*\") >> return MUL\n , P.try (string_skp \"/\") >> return DIV\n , P.try (string_skp \"%\") >> return MOD\n , P.try (string_skp \"<<\") >> return LSH\n , P.try (string_skp \">>\") >> return RSH\n , P.try (string_skp \"<=\") >> return LTE\n , P.try (string_skp \">=\") >> return GTE\n , P.try (string_skp \"<\") >> return LT\n , P.try (string_skp \">\") >> return GT\n , P.try (string_skp \"==\") >> return EQ\n , P.try (string_skp \"!=\") >> return NE\n , P.try (string_skp \"&\") >> return AND\n , P.try (string_skp \"|\") >> return OR\n , P.try (string_skp \"^\") >> return XOR\n ] \"Binary operator\"\n\nparseSuffix :: Term -> Parser Term\nparseSuffix term = guardChoice\n [ (parseSuffArr term, discard $ string_skp \"->\")\n , (parseSuffAnn term, discard $ string_skp \"::\")\n , (parseSuffEql term, discard $ string_skp \"==\")\n , (parseSuffPAR term, discard $ string_skp \"&\")\n , (parseSuffPar term, discard $ string_skp \",\")\n , (parseSuffCns term, discard $ string_skp \";;\")\n ] $ parseSuffVal term\n\nparseSuffArr :: Term -> Parser Term\nparseSuffArr term = do\n P.try $ string_skp \"->\"\n ret <- parseTerm\n return $ All \"_\" term (\\_ -> ret)\n\nparseSuffAnn :: Term -> Parser Term\nparseSuffAnn term = do\n P.try $ string_skp \"::\"\n typ <- parseTerm\n return $ Ann True term typ\n\nparseSuffEql :: Term -> Parser Term\nparseSuffEql term = do\n P.try $ string_skp \"==\"\n other <- parseTerm\n return $ App (App (App (Ref \"Equal\") (Met 0 [])) term) other\n\nparseSuffPAR :: Term -> Parser Term\nparseSuffPAR fst = do\n P.try $ string_skp \"&\"\n snd <- parseTerm\n return $ App (App (Ref \"Pair\") fst) snd\n\nparseSuffPar :: Term -> Parser Term\nparseSuffPar fst = do\n P.try $ string_skp \",\"\n snd <- parseTerm\n return $ Con \"Pair\" [(Nothing, fst), (Nothing, snd)]\n\nparseSuffCns :: Term -> Parser Term\nparseSuffCns head = do\n P.try $ string_skp \";;\"\n tail <- parseTerm\n return $ Con \"Cons\" [(Nothing, head), (Nothing, tail)]\n\nparseSuffVal :: Term -> Parser Term\nparseSuffVal term = return term\n\n-- Book Parser\n-- -----------\n\nparseBook :: Parser Book\nparseBook = M.fromList <$> P.many parseDef\n\nparseDef :: Parser (String, Term)\nparseDef = guardChoice\n [ (parseDefADT, discard $ string_skp \"data \")\n , (parseDefFun, discard $ string_skp \"#\" <|> name_skp)\n ] $ fail \"Top-level definition\"\n\nparseDefADT :: Parser (String, Term)\nparseDefADT = do\n (_, _, uses) <- P.getState\n P.try $ string_skp \"data \"\n name <- name_skp\n let nameA = expandUses uses name\n params <- P.many $ do\n P.try $ char_skp '('\n pname <- name_skp\n char_skp ':'\n ptype <- parseTerm\n char_skp ')'\n return (pname, ptype)\n indices <- P.choice\n [ do\n P.try $ char_skp '~'\n P.many $ do\n P.notFollowedBy (char '{')\n char_skp '('\n iname <- name_skp\n char_skp ':'\n itype <- parseTerm\n char_skp ')'\n return (iname, itype)\n , return []\n ]\n char_skp '{'\n ctrs <- P.many $ P.try parseADTCtr\n char_skp '}'\n let paramTypes = map snd params\n let indexTypes = map snd indices\n let paramNames = map fst params\n let indexNames = map fst indices\n let allParams = params ++ indices\n let selfType = foldl (\\ acc arg -> App acc (Ref arg)) (Ref nameA) (paramNames ++ indexNames)\n let typeBody = foldr (\\ (pname, ptype) acc -> All pname ptype (\\_ -> acc)) Set allParams\n let newCtrs = map (fillCtrRet selfType) ctrs -- fill ctr type when omitted\n let dataBody = ADT (map (\\ (iNam,iTyp) -> Ref iNam) indices) newCtrs selfType\n let fullBody = foldr (\\ (pname, _) acc -> Lam pname (\\_ -> acc)) dataBody allParams\n let term = bind (genMetas (Ann False fullBody typeBody)) []\n return $\n -- trace (\"parsed \" ++ nameA ++ \" = \" ++ (showTermGo False term 0))\n (nameA, term)\n where fillCtrRet ret (Ctr nm tele) = Ctr nm (fillTeleRet ret tele)\n fillTeleRet ret (TRet (Met _ _)) = TRet ret\n fillTeleRet _ (TRet ret) = TRet ret\n fillTeleRet ret (TExt nm tm bod) = TExt nm tm (\\x -> fillTeleRet ret (bod x)) -- FIXME: 'bod x'?\n\nparseDefFun :: Parser (String, Term)\nparseDefFun = do\n numb <- P.optionMaybe $ char_skp '#'\n name <- name_skp\n typ <- P.optionMaybe $ do\n char_skp ':'\n t <- parseTerm\n return t\n val <- guardChoice\n [ (parseDefFunSingle, discard $ char_skp '=')\n , (parseDefFunRules, discard $ char_skp '|')\n ] parseDefFunTest\n (filename, count, uses) <- P.getState\n let name0 = expandUses uses name\n let name1 = if isJust numb then name0 ++ \"#\" ++ show count else name0\n P.setState (filename, if isJust numb then count + 1 else count, uses)\n case typ of\n Nothing -> return (name1, bind (genMetas val) [])\n Just t -> return (name1, bind (genMetas (Ann False val t)) [])\n\nparseDefFunSingle :: Parser Term\nparseDefFunSingle = do\n char_skp '='\n val <- parseTerm\n return val\n\nparseDefFunRules :: Parser Term\nparseDefFunRules = withSrc $ do\n rules <- P.many1 (parseRule 0)\n let flat = flattenDef rules 0\n return\n -- $ trace (\"DONE: \" ++ showTerm flat)\n flat\n\nparseDefFunTest :: Parser Term\nparseDefFunTest = return (Con \"Refl\" [])\n\nparseRule :: Int -> Parser Rule\nparseRule dep = do\n P.try $ do\n P.count dep $ char_skp '.'\n char_skp '|'\n pats <- P.many parsePattern\n body <- P.choice \n [ withSrc $ P.try $ do\n string_skp \"with \"\n wth <- P.many1 $ P.notFollowedBy (char_skp '.') >> parseTerm\n rul <- P.many1 $ parseRule (dep + 1)\n return $ flattenWith dep wth rul\n , P.try $ do\n char_skp '='\n body <- parseTerm\n return body\n ]\n return $ (pats, body)\n\nparsePattern :: Parser Pattern\nparsePattern = do\n P.notFollowedBy $ string_skp \"with \"\n pat <- guardChoice\n [ (parsePatPrn, discard $ string_skp \"(\")\n , (parsePatNat, discard $ string_skp \"#\" >> numeric_skp)\n , (parsePatLst, discard $ string_skp \"[\")\n , (parsePatCon, discard $ string_skp \"#\" <|> (name_skp >> string_skp \"@\"))\n , (parsePatTxt, discard $ string_skp \"\\\"\")\n , (parsePatSuc, discard $ numeric_skp >> char_skp '+')\n , (parsePatNum, discard $ numeric_skp)\n , (parsePatVar, discard $ name_skp)\n ] $ fail \"Pattern-matching\"\n parsePatSuffix pat\n\nparsePatSuffix :: Pattern -> Parser Pattern\nparsePatSuffix pat = P.choice\n [ parsePatSuffPar pat\n , parsePatSuffCns pat\n , return pat\n ]\n\nparsePatSuffPar :: Pattern -> Parser Pattern\nparsePatSuffPar fst = do\n P.try $ string_skp \",\"\n snd <- parsePattern\n return $ PCtr Nothing \"Pair\" [fst, snd]\n\nparsePatSuffCns :: Pattern -> Parser Pattern\nparsePatSuffCns head = do\n P.try $ string_skp \";;\"\n tail <- parsePattern\n return $ PCtr Nothing \"Cons\" [head, tail]\n\nparsePatPrn :: Parser Pattern\nparsePatPrn = do\n string_skp \"(\"\n pat <- parsePattern\n string_skp \")\"\n return pat\n\nparsePatNat :: Parser Pattern\nparsePatNat = do\n char_skp '#'\n num <- numeric_skp\n let n = read num\n return $ (foldr (\\_ acc -> PCtr Nothing \"Succ\" [acc]) (PCtr Nothing \"Zero\" []) [1..n])\n\nparsePatLst :: Parser Pattern\nparsePatLst = do\n char_skp '['\n elems <- P.many parsePattern\n char_skp ']'\n return $ foldr (\\x acc -> PCtr Nothing \"Cons\" [x, acc]) (PCtr Nothing \"Nil\" []) elems\n\nparsePatTxt :: Parser Pattern\nparsePatTxt = do\n char '\"'\n txt <- P.many parseTxtChr\n char '\"'\n return $ foldr (\\x acc -> PCtr Nothing \"Cons\" [PNum (toEnum (ord x)), acc]) (PCtr Nothing \"Nil\" []) txt\n\nparsePatPar :: Parser Pattern\nparsePatPar = do\n char_skp '('\n head <- parsePattern\n tail <- P.many $ do\n char_skp ','\n parsePattern\n char_skp ')'\n let (init, last) = maybe ([], head) id (unsnoc (head : tail))\n return $ foldr (\\x acc -> PCtr Nothing \"Pair\" [x, acc]) last init\n\nparsePatCon :: Parser Pattern\nparsePatCon = do\n name <- P.optionMaybe $ P.try $ do\n name <- name_skp\n char_skp '@'\n return name\n char_skp '#'\n cnam <- name_skp\n args <- P.option [] $ P.try $ do\n char_skp '{'\n args <- P.many parsePattern\n char_skp '}'\n return args\n return $ (PCtr name cnam args)\n\nparsePatNum :: Parser Pattern\nparsePatNum = do\n num <- numeric_skp\n return $ (PNum (read num))\n\nparsePatSuc :: Parser Pattern\nparsePatSuc = do\n num <- numeric_skp\n char_skp '+'\n nam <- name_skp\n return $ (PSuc (read num) nam)\n\nparsePatVar :: Parser Pattern\nparsePatVar = do\n name <- name_skp\n return $ (PVar name)\n\nparseUses :: Parser Uses\nparseUses = P.many $ P.try $ do\n string_skp \"use \"\n long <- name_skp\n string_skp \"as \"\n short <- name_skp\n return (short, long)\n\nexpandUses :: Uses -> String -> String\nexpandUses ((short, long):uses) name\n | short == name = long\n | (short ++ \"/\") `isPrefixOf` name = long ++ drop (length short) name\n | otherwise = expandUses uses name\nexpandUses [] name = name\n\n-- Syntax Sugars\n-- -------------\n\nparseDo :: Parser Term\nparseDo = withSrc $ do\n string_skp \"do \"\n monad <- name_skp\n char_skp '{'\n skip\n (_, _, uses) <- P.getState\n body <- parseStmt (expandUses uses monad)\n char '}'\n return body\n\nparseStmt :: String -> Parser Term\nparseStmt monad = guardChoice\n [ (parseDoFor monad, discard $ string_skp \"for \" <|> (string_skp \"ask\" >> name_skp >> string_skp \"=\" >> string_skp \"for\"))\n , (parseDoAsk monad, discard $ string_skp \"ask \")\n , (parseDoRet monad, discard $ string_skp \"ret \")\n , (parseLet (parseStmt monad), discard $ string_skp \"let \")\n , (parseUse (parseStmt monad), discard $ string_skp \"use \")\n , (parseLog (parseStmt monad), discard $ string_skp \"log \")\n ] parseTerm\n\nparseDoAsk :: String -> Parser Term\nparseDoAsk monad = guardChoice\n [ (parseDoAskMch monad, discard $ string_skp \"ask #\")\n , (parseDoAskPar monad, discard $ string_skp \"ask (\" >> name_skp >> string_skp \",\")\n , (parseDoAskVal monad, discard $ string_skp \"ask \")\n ] $ fail \"'ask' statement\"\n\nparseDoAskMch :: String -> Parser Term\nparseDoAskMch monad = do\n string_skp \"ask #\"\n cnam <- name_skp\n char_skp '{'\n args <- P.many name_skp\n char_skp '}'\n char_skp '='\n val <- parseTerm\n next <- parseStmt monad\n (_, _, uses) <- P.getState\n return $ App\n (App (App (App (Ref (monad ++ \"/bind\")) (Met 0 [])) (Met 0 [])) val)\n (Lam \"got\" (\\got ->\n App (Mat [(cnam, foldr (\\arg acc -> Lam arg (\\_ -> acc)) next args)]) got))\n\nparseDoAskPar :: String -> Parser Term\nparseDoAskPar monad = do\n string_skp \"ask (\"\n head <- name_skp\n tail <- P.many $ do\n char_skp ','\n name_skp\n char_skp ')'\n let (init, last) = maybe ([], head) id $ unsnoc (head : tail)\n char_skp '='\n val <- parseTerm\n next <- parseStmt monad\n (_, _, uses) <- P.getState\n return $ App\n (App (App (App (Ref (monad ++ \"/bind\")) (Met 0 [])) (Met 0 [])) val)\n (foldr (\\x acc -> Mat [(\"Pair\", Lam x (\\_ -> acc))]) (Lam last (\\_ -> next)) init)\n\nparseDoAskVal :: String -> Parser Term\nparseDoAskVal monad = P.choice\n [ parseDoAskValNamed monad\n , parseDoAskValAnon monad\n ]\n\nparseDoAskValNamed :: String -> Parser Term\nparseDoAskValNamed monad = P.try $ do\n string_skp \"ask \"\n nam <- name_skp\n char_skp '='\n exp <- parseTerm\n next <- parseStmt monad\n (_, _, uses) <- P.getState\n return $ App\n (App (App (App (Ref (monad ++ \"/bind\")) (Met 0 [])) (Met 0 [])) exp)\n (Lam nam (\\_ -> next))\n\nparseDoAskValAnon :: String -> Parser Term\nparseDoAskValAnon monad = P.try $ do\n string_skp \"ask \"\n exp <- parseTerm\n next <- parseStmt monad\n (_, _, uses) <- P.getState\n return $ App\n (App (App (App (Ref (monad ++ \"/bind\")) (Met 0 [])) (Met 0 [])) exp)\n (Lam \"_\" (\\_ -> next))\n\nparseDoRet :: String -> Parser Term\nparseDoRet monad = do\n string_skp \"ret \"\n exp <- parseTerm\n (_, _, uses) <- P.getState\n return $ App (App (Ref (monad ++ \"/pure\")) (Met 0 [])) exp\n\nparseDoFor :: String -> Parser Term\nparseDoFor monad = do\n (stt, nam, lst, loop, body) <- P.choice\n [ do\n stt <- P.try $ do\n string_skp \"ask \"\n stt <- name_skp\n string_skp \"=\"\n string_skp \"for\"\n return stt\n nam <- name_skp\n string_skp \"in\"\n lst <- parseTerm\n char_skp '{'\n loop <- parseStmt monad\n char_skp '}'\n body <- parseStmt monad\n return (Just stt, nam, lst, loop, body)\n , do\n P.try $ string_skp \"for \"\n nam <- name_skp\n string_skp \"in\"\n lst <- parseTerm\n char_skp '{'\n loop <- parseStmt monad\n char_skp '}'\n body <- parseStmt monad\n return (Nothing, nam, lst, loop, body) ]\n let f0 = Ref \"List/for\"\n let f1 = App f0 (Met 0 [])\n let f2 = App f1 (Ref (monad ++ \"/Monad\"))\n let f3 = App f2 (Met 0 [])\n let f4 = App f3 (Met 0 [])\n let f5 = App f4 lst\n let f6 = App f5 (maybe (Num 0) Ref stt)\n let f7 = App f6 (Lam (maybe \"\" id stt) (\\s -> Lam nam (\\_ -> loop)))\n let b0 = Ref (monad ++ \"/bind\")\n let b1 = App b0 (Met 0 [])\n let b2 = App b1 (Met 0 [])\n let b3 = App b2 f7\n let b4 = App b3 (Lam (maybe \"\" id stt) (\\_ -> body))\n return b4\n\n-- If-Then-Else\n-- ------------\n\n-- if cond { t } else { f }\n-- --------------------------------- desugars to\n-- match cond { #True: t #False: f }\n\nparseIf = withSrc $ do\n string_skp \"if \"\n cond <- parseTerm\n t <- parseBranch True\n string_skp \"else\"\n f <- P.choice [parseBranch False, parseIf]\n return $ App (Mat [(\"True\", t), (\"False\", f)]) cond\n where\n parseBranch isIf = P.choice\n [ do\n string_skp \"do \"\n monad <- name_skp\n char_skp '{'\n (_, _, uses) <- P.getState\n t <- parseStmt (expandUses uses monad)\n if isIf then char_skp '}' else char '}'\n return t\n , do\n char_skp '{'\n t <- parseTerm\n if isIf then char_skp '}' else char '}'\n return t\n ]\n\n-- When\n-- ----\n\n-- when fn x { c0: v0 c1: v1 } else { df }\n-- -------------------------------------------------------- desugars to\n-- if (fn x c0) { v0 } else if (fn x c1) { v1 } else { df }\n\nparseWhen = withSrc $ do\n string_skp \"when \"\n fun <- parseTerm\n val <- parseTerm\n char_skp '{'\n cases <- P.many $ do\n cond <- parseTerm\n char_skp ':'\n body <- parseTerm\n return (cond, body)\n char_skp '}'\n string_skp \"else\"\n char_skp '{'\n elseCase <- parseTerm\n char '}'\n return $ foldr\n (\\ (cond, body) acc -> App\n (Mat [(\"True\", body), (\"False\", acc)])\n (App (App fun val) cond))\n elseCase\n cases\n\n-- Match\n-- -----\n\nparseMatInl :: Parser Term\nparseMatInl = withSrc $ do\n string_skp \"match \"\n x <- parseTerm\n char_skp '{'\n cse <- parseMatCases\n char '}'\n return $ App (Mat cse) x\n\nparseSwiInl :: Parser Term\nparseSwiInl = withSrc $ do\n string_skp \"switch \"\n x <- parseTerm\n char_skp '{'\n cse <- parseSwiCases\n char '}'\n return $ App cse x\n\n-- Nat\n-- ---\n\nparseNat :: Parser Term\nparseNat = withSrc $ do\n char_skp '#'\n num <- P.many1 digit\n return $ Nat (read num)\n\n-- Flattener\n-- ---------\n\n-- FIXME: the functions below are still a little bit messy and can be improved\n\n-- Flattener for pattern matching equations\nflattenDef :: [Rule] -> Int -> Term\nflattenDef rules depth =\n let (pats, bods) = unzip rules\n in flattenRules pats bods depth\n\nflattenWith :: Int -> [Term] -> [Rule] -> Term\nflattenWith dep wth rul =\n -- Wrap the 'with' arguments and patterns in Pairs since the type checker only takes one match argument.\n let wthA = foldr1 (\\x acc -> Ann True (Con \"Pair\" [(Nothing, x), (Nothing, acc)]) (App (App (Ref \"Pair\") (Met 0 [])) (Met 0 []))) wth\n rulA = map (\\(pat, wth) -> ([foldr1 (\\x acc -> PCtr Nothing \"Pair\" [x, acc]) pat], wth)) rul\n bod = flattenDef rulA (dep + 1)\n in App bod wthA\n\nflattenRules :: [[Pattern]] -> [Term] -> Int -> Term\nflattenRules ([]:mat) (bod:bods) depth = bod\nflattenRules (pats:mat) (bod:bods) depth\n | all isVar col = flattenVarCol col mat' (bod:bods) (depth + 1)\n | not (null (getColCtrs col)) = flattenAdtCol col mat' (bod:bods) (depth + 1)\n | isJust (fst (getColSucc col)) = flattenNumCol col mat' (bod:bods) (depth + 1)\n | otherwise = error \"invalid pattern matching function\"\n where (col,mat') = getCol (pats:mat)\nflattenRules _ _ _ = error \"internal error\"\n\n-- Flattens a column with only variables\nflattenVarCol :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Term\nflattenVarCol col mat bods depth =\n -- trace (replicate (depth * 2) ' ' ++ \"flattenVarCol: col = \" ++ show col ++ \", depth = \" ++ show depth) $\n let nam = maybe \"_\" id (getVarColName col)\n bod = flattenRules mat bods depth\n in Lam nam (\\x -> bod)\n\n-- Flattens a column with constructors and possibly variables\nflattenAdtCol :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Term\nflattenAdtCol col mat bods depth =\n -- trace (replicate (depth * 2) ' ' ++ \"flattenAdtCol: col = \" ++ show col ++ \", depth = \" ++ show depth) $\n let ctr = map (makeCtrCase col mat bods depth) (getColCtrs col)\n dfl = makeDflCase col mat bods depth\n nam = getMatNam col\n in case nam of\n (Just nam) -> (Lam nam (\\x -> App (Mat (ctr++dfl)) (Ref nam)))\n Nothing -> Mat (ctr++dfl)\n\n-- Creates a constructor case: '#Name: body'\nmakeCtrCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> String -> (String, Term)\nmakeCtrCase col mat bods depth ctr =\n -- trace (replicate (depth * 2) ' ' ++ \"makeCtrCase: col = \" ++ show col ++ \", mat = \" ++ show mat ++ \", bods = \" ++ show (map showTerm bods) ++ \", depth = \" ++ show depth ++ \", ctr = \" ++ ctr) $\n let var = getCtrColNames col ctr\n (mat', bods') = foldr (go var) ([], []) (zip3 col mat bods)\n bod = flattenRules mat' bods' (depth + 1)\n in (ctr, bod)\n where go var ((PCtr nam cnam ps), pats, bod) (mat, bods)\n | cnam == ctr = ((ps ++ pats):mat, bod:bods)\n | otherwise = (mat, bods)\n go var ((PVar \"_\"), pats, bod) (mat, bods) =\n let pat = map (maybe (PVar \"_\") PVar) var\n in ((pat ++ pats):mat, bod:bods)\n go var ((PVar nam), pats, bod) (mat, bods) =\n let vr2 = [maybe (nam++\".\"++show i) id vr | (vr, i) <- zip var [0..]]\n pat = map PVar vr2\n bo2 = Use nam (Con ctr (map (\\x -> (Nothing, Ref x)) vr2)) (\\x -> bod)\n in ((pat ++ pats):mat, bo2:bods)\n go var (_, pats, bod) (mat, bods) =\n (mat, bods)\n\n-- Creates a default case: '#_: body'\nmakeDflCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> [(String, Term)]\nmakeDflCase col mat bods depth =\n -- trace (replicate (depth * 2) ' ' ++ \"makeDflCase: col = \" ++ show col ++ \", depth = \" ++ show depth) $\n let (mat', bods') = foldr go ([], []) (zip3 col mat bods) in\n if null bods' then [] else [(\"_\", flattenRules mat' bods' (depth + 1))]\n where go ((PVar nam), pats, bod) (mat, bods) = (((PVar nam):pats):mat, bod:bods)\n go (_, pats, bod) (mat, bods) = (mat, bods)\n\nflattenNumCol :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Term\nflattenNumCol col mat bods depth =\n -- Find the succ case with the value\n let (suc, var) = getColSucc col\n sucA = fromJust suc\n varA = maybe (\"%n-\" ++ show sucA) id var\n numCs = map (makeNumCase col mat bods depth) [0..sucA-1]\n sucCs = (makeSucCase col mat bods depth sucA varA)\n in foldr (\\x acc -> Swi x acc) sucCs numCs\n\nmakeNumCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Word64 -> Term\nmakeNumCase col mat bods depth num =\n let (mat', bods') = foldr go ([], []) (zip3 col mat bods)\n in if null bods' then error $ \"missing case for \" ++ show num\n else (flattenRules mat' bods' (depth + 1))\n where go ((PNum val), pats, bod) (mat, bods)\n | val == num = (pats:mat, bod:bods)\n | otherwise = (mat, bods)\n go ((PVar \"_\"), pats, bod) (mat, bods) =\n (pats:mat, bod:bods)\n go ((PVar nam), pats, bod) (mat, bods) =\n let bod' = Use nam (Num num) (\\x -> bod)\n in (pats:mat, bod':bods)\n go (_, pats, bod) (mat, bods) =\n (mat, bods)\n\nmakeSucCase :: [Pattern] -> [[Pattern]] -> [Term] -> Int -> Word64 -> String -> Term\nmakeSucCase col mat bods depth suc var =\n let (mat', bods') = foldr go ([], []) (zip3 col mat bods)\n bod = if null bods' then error $ \"missing case for \" ++ show suc ++ \"+\" ++ var\n else (flattenRules mat' bods' (depth + 1))\n in Lam var (\\x -> bod)\n where go ((PSuc _ _), pats, bod) (mat, bods) = (pats:mat, bod:bods)\n go ((PVar \"_\"), pats, bod) (mat, bods) = (pats:mat, bod:bods)\n go ((PVar nam), pats, bod) (mat, bods) = \n let bodA = Use nam (Op2 ADD (Num suc) (Ref var)) (\\x -> bod)\n in (pats:mat, bodA:bods)\n go (_, pats, bod) (mat, bods) = (mat, bods)\n\n-- Helper Functions\n\nisVar :: Pattern -> Bool\nisVar (PVar _) = True\nisVar _ = False\n\ngetCol :: [[Pattern]] -> ([Pattern], [[Pattern]])\ngetCol (pats:mat) = unzip (catMaybes (map uncons (pats:mat)))\n\ngetColCtrs :: [Pattern] -> [String]\ngetColCtrs col = toList . fromList $ foldr (\\pat acc -> case pat of (PCtr _ cnam _) -> cnam:acc ; _ -> acc) [] col\n\ngetVarColName :: [Pattern] -> Maybe String\ngetVarColName col = foldr (A.<|>) Nothing $ map go col\n where go (PVar \"_\") = Nothing\n go (PVar nam) = Just nam\n go _ = Nothing\n\n-- For a column of patterns that will become a Mat,\n-- return the name of the inner fields or Nothing if they are also Mats.\ngetCtrColNames :: [Pattern] -> String -> [Maybe String]\ngetCtrColNames col ctr = \n let mat = foldr go [] col\n in map getVarColName (transpose mat)\n where go (PCtr nam cnam ps) acc\n | cnam == ctr = ps:acc\n | otherwise = acc\n go _ acc = acc\n\ngetMatNam :: [Pattern] -> Maybe String\ngetMatNam (PCtr (Just nam) _ _:_) = Just nam\ngetMatNam (_:col) = getMatNam col\ngetMatNam [] = Nothing\n\n-- If theres a PSuc, it returns (Just val, Just nam)\n-- If there a PNum a PVar but no PSuc, it returns (Just (max val + 1), Nothing)\n-- Otherwise, it returns (Nothing, Nothing)\ngetColSucc :: [Pattern] -> (Maybe Word64, Maybe String)\ngetColSucc pats =\n case findSuc pats of\n Just (val, name) -> (Just val, Just name)\n Nothing -> case (maxNum pats Nothing) of\n Just maxVal -> (Just (maxVal + 1), Nothing) \n Nothing -> (Nothing, Nothing)\n where\n findSuc [] = Nothing\n findSuc (PSuc val name:_) = Just (val, name)\n findSuc (_:rest) = findSuc rest\n\n maxNum [] acc = acc\n maxNum (PNum val:ps) Nothing = maxNum ps (Just val)\n maxNum (PNum val:ps) (Just max) = maxNum ps (Just (if val > max then val else max))\n maxNum (_:ps) acc = maxNum ps acc\n" }, { "path": "src/Kind/Reduce.hs", "content": "-- //./Type.hs//\n\nmodule Kind.Reduce where\n\nimport Prelude hiding (EQ, LT, GT)\nimport Data.Bits ( (.&.), (.|.), xor, shiftL, shiftR )\nimport Data.Char (ord)\nimport Data.Fixed (mod')\nimport Debug.Trace\nimport Kind.Show\nimport Kind.Type\n\nimport qualified Data.Map.Strict as M\nimport qualified Data.IntMap.Strict as IM\n\n-- for exitting on undefined ref (should be handled better)\nimport System.Exit (exitWith, ExitCode(ExitFailure))\nimport System.IO.Unsafe (unsafePerformIO)\n\n-- Evaluation\n-- ----------\n\n-- Evaluates a term to weak normal form\n-- 'lv' defines when to expand refs: 0 = never, 1 = on redexes\nreduce :: Book -> Fill -> Int -> Term -> Term\nreduce book fill lv term = red term where\n\n red (App fun arg) = app (red fun) arg\n red (Ann chk val typ) = red val\n red (Ins val) = red val\n red (Ref nam) = ref nam\n red (Let nam val bod) = red (bod (red val))\n red (Use nam val bod) = red (bod (red val))\n red (Op2 opr fst snd) = op2 opr (red fst) (red snd)\n red (Txt val) = txt val\n red (Lst val) = lst val\n red (Nat val) = nat val\n red (Src src val) = red val\n red (Met uid spn) = met uid spn\n red (Log msg nxt) = log msg nxt\n red (Get g n m k b) = get g n (red m) (red k) b\n red (Put g n m k v b) = put g n (red m) (red k) v b\n red val = val\n\n app (Ref nam) arg | lv > 0 = app (ref nam) arg\n app (Met uid spn) arg = red (Met uid (spn ++ [arg]))\n app (Lam nam bod) arg = red (bod (reduce book fill 0 arg))\n app (Mat cse) arg = mat cse (red arg)\n app (Swi zer suc) arg = swi zer suc (red arg)\n app fun arg = App fun arg\n\n mat cse (Con cnam carg) = case lookup cnam cse of\n Just cx -> red (foldl App cx (map snd carg))\n Nothing -> case lookup \"_\" cse of\n Just df -> red (App df (Con cnam carg))\n Nothing -> error $ \"Constructor \" ++ cnam ++ \" not found in pattern match and no default case '_' provided :\" ++ (showTermGo True (Mat cse) 0)\n mat cse arg = App (Mat cse) arg\n\n swi zer suc (Num 0) = red zer\n swi zer suc (Num n) = red (App suc (Num (n - 1)))\n swi zer suc (Op2 ADD (Num 1) k) = red (App suc k)\n swi zer suc val = App (Swi zer suc) val\n\n met uid spn = case IM.lookup uid fill of\n Just val -> red (case spn of\n [] -> val\n (x : xs) -> foldl App val spn)\n Nothing -> Met uid spn\n\n op2 op (Ref nam) (Num snd) | lv > 0 = op2 op (ref nam) (Num snd)\n op2 op (Num fst) (Ref nam) | lv > 0 = op2 op (Num fst) (ref nam)\n op2 ADD (Num fst) (Num snd) = Num (fst + snd)\n op2 SUB (Num fst) (Num snd) = Num (fst - snd)\n op2 MUL (Num fst) (Num snd) = Num (fst * snd)\n op2 DIV (Num fst) (Num snd) = Num (div fst snd)\n op2 MOD (Num fst) (Num snd) = Num (mod fst snd)\n op2 EQ (Num fst) (Num snd) = Num (if fst == snd then 1 else 0)\n op2 NE (Num fst) (Num snd) = Num (if fst /= snd then 1 else 0)\n op2 LT (Num fst) (Num snd) = Num (if fst < snd then 1 else 0)\n op2 GT (Num fst) (Num snd) = Num (if fst > snd then 1 else 0)\n op2 LTE (Num fst) (Num snd) = Num (if fst <= snd then 1 else 0)\n op2 GTE (Num fst) (Num snd) = Num (if fst >= snd then 1 else 0)\n op2 AND (Num fst) (Num snd) = Num (fst .&. snd)\n op2 OR (Num fst) (Num snd) = Num (fst .|. snd)\n op2 XOR (Num fst) (Num snd) = Num (fst `xor` snd)\n op2 LSH (Num fst) (Num snd) = Num (shiftL fst (fromIntegral snd))\n op2 RSH (Num fst) (Num snd) = Num (shiftR fst (fromIntegral snd))\n op2 op (Ref nam) (Flt snd) | lv > 0 = op2 op (ref nam) (Flt snd)\n op2 op (Flt fst) (Ref nam) | lv > 0 = op2 op (Flt fst) (ref nam)\n op2 ADD (Flt fst) (Flt snd) = Flt (fst + snd)\n op2 SUB (Flt fst) (Flt snd) = Flt (fst - snd)\n op2 MUL (Flt fst) (Flt snd) = Flt (fst * snd)\n op2 DIV (Flt fst) (Flt snd) = Flt (fst / snd)\n op2 MOD (Flt fst) (Flt snd) = Flt (mod' fst snd)\n op2 EQ (Flt fst) (Flt snd) = Num (if fst == snd then 1 else 0)\n op2 NE (Flt fst) (Flt snd) = Num (if fst /= snd then 1 else 0)\n op2 LT (Flt fst) (Flt snd) = Num (if fst < snd then 1 else 0)\n op2 GT (Flt fst) (Flt snd) = Num (if fst > snd then 1 else 0)\n op2 LTE (Flt fst) (Flt snd) = Num (if fst <= snd then 1 else 0)\n op2 GTE (Flt fst) (Flt snd) = Num (if fst >= snd then 1 else 0)\n op2 AND (Flt _) (Flt _) = error \"Bitwise AND not supported for floating-point numbers\"\n op2 OR (Flt _) (Flt _) = error \"Bitwise OR not supported for floating-point numbers\"\n op2 XOR (Flt _) (Flt _) = error \"Bitwise XOR not supported for floating-point numbers\"\n op2 opr fst snd = Op2 opr fst snd\n\n ref nam | lv > 0 = case M.lookup nam book of\n Just val -> red val\n Nothing -> Con (\"undefined-reference:\"++nam) []\n ref nam = Ref nam\n\n txt [] = red (Con \"Nil\" [])\n txt (x:xs) = red (Con \"Cons\" [(Nothing, Num (toEnum (ord x))), (Nothing, Txt xs)])\n\n lst [] = red (Con \"Nil\" [])\n lst (x:xs) = red (Con \"Cons\" [(Nothing, x), (Nothing, Lst xs)])\n \n nat 0 = Con \"Zero\" []\n nat n = Con \"Succ\" [(Nothing, Nat (n - 1))]\n\n log msg nxt = logMsg book fill lv msg msg nxt \"\"\n\n get g n (KVs kvs d) (Num k) b = case IM.lookup (fromIntegral k) kvs of\n Just v -> red (b v (KVs kvs d))\n Nothing -> red (b d (KVs kvs d))\n get g n m k b = Get g n m k b\n\n put g n (KVs kvs d) (Num k) v b = case IM.lookup (fromIntegral k) kvs of\n Just o -> red (b o (KVs (IM.insert (fromIntegral k) v kvs) d))\n Nothing -> red (b d (KVs (IM.insert (fromIntegral k) v kvs) d))\n put g n m k v b = Put g n m k v b\n\n-- Logging\n-- -------\n\nlogMsg :: Book -> Fill -> Int -> Term -> Term -> Term -> String -> Term\nlogMsg book fill lv msg' msg nxt txt =\n case (reduce book fill 2 msg) of\n Con \"Cons\" [(_, head), (_, tail)] -> case (reduce book fill lv head) of\n Num chr -> logMsg book fill lv msg' tail nxt (txt ++ [toEnum (fromIntegral chr)])\n _ -> trace (\">> \" ++ (showTerm (normal book fill 1 msg' 0))) $ (reduce book fill lv nxt)\n Con \"Nil\" [] ->\n trace txt (reduce book fill lv nxt)\n bad ->\n trace (\">> \" ++ (showTerm (normal book fill 1 msg' 0))) $ (reduce book fill lv nxt)\n\n-- Normalization\n-- -------------\n\n-- Evaluates a term to full normal form\nnormal :: Book -> Fill -> Int -> Term -> Int -> Term\nnormal book fill lv term dep = go (reduce book fill lv term) dep where\n go (All nam inp bod) dep =\n let nf_inp = normal book fill lv inp dep in\n let nf_bod = \\x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in\n All nam nf_inp nf_bod\n go (Lam nam bod) dep =\n let nf_bod = \\x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in\n Lam nam nf_bod\n go (App fun arg) dep =\n let nf_fun = normal book fill lv fun dep in\n let nf_arg = normal book fill lv arg dep in\n App nf_fun nf_arg\n go (Ann chk val typ) dep =\n let nf_val = normal book fill lv val dep in\n let nf_typ = normal book fill lv typ dep in\n Ann chk nf_val nf_typ\n go (Slf nam typ bod) dep =\n let nf_bod = \\x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in\n Slf nam typ nf_bod\n go (Ins val) dep =\n let nf_val = normal book fill lv val dep in\n Ins nf_val\n go (ADT scp cts typ) dep =\n let go_ctr = (\\ (Ctr nm tele) ->\n let nf_tele = normalTele book fill lv tele dep in\n Ctr nm nf_tele) in\n let nf_scp = map (\\x -> normal book fill lv x dep) scp in\n let nf_cts = map go_ctr cts in\n let nf_typ = normal book fill lv typ dep in\n ADT nf_scp nf_cts nf_typ\n go (Con nam arg) dep =\n let nf_arg = map (\\(f, t) -> (f, normal book fill lv t dep)) arg in\n Con nam nf_arg\n go (Mat cse) dep =\n let nf_cse = map (\\(cnam, cbod) -> (cnam, normal book fill lv cbod dep)) cse in\n Mat nf_cse\n go (Swi zer suc) dep =\n let nf_zer = normal book fill lv zer dep in\n let nf_suc = normal book fill lv suc dep in\n Swi nf_zer nf_suc\n go (Ref nam) dep = Ref nam\n go (Let nam val bod) dep =\n let nf_val = normal book fill lv val dep in\n let nf_bod = \\x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in\n Let nam nf_val nf_bod\n go (Use nam val bod) dep =\n let nf_val = normal book fill lv val dep in\n let nf_bod = \\x -> normal book fill lv (bod (Var nam dep)) (dep + 1) in\n Use nam nf_val nf_bod\n go (Hol nam ctx) dep = Hol nam ctx\n go Set dep = Set\n go U64 dep = U64\n go F64 dep = F64\n go (Num val) dep = Num val\n go (Flt val) dep = Flt val\n go (Op2 opr fst snd) dep =\n let nf_fst = normal book fill lv fst dep in\n let nf_snd = normal book fill lv snd dep in\n Op2 opr nf_fst nf_snd\n go (Map typ) dep =\n let nf_typ = normal book fill lv typ dep in\n Map nf_typ\n go (KVs kvs def) dep =\n let nf_kvs = IM.map (\\x -> normal book fill lv x dep) kvs in\n let nf_def = normal book fill lv def dep in\n KVs nf_kvs nf_def\n go (Get g n m k b) dep =\n let nf_m = normal book fill lv m dep in\n let nf_k = normal book fill lv k dep in\n let nf_b = \\v s -> normal book fill lv (b (Var g dep) (Var n dep)) (dep + 2) in\n Get g n nf_m nf_k nf_b\n go (Put g n m k v b) dep =\n let nf_m = normal book fill lv m dep in\n let nf_k = normal book fill lv k dep in\n let nf_v = normal book fill lv v dep in\n let nf_b = \\o s -> normal book fill lv (b (Var g dep) (Var n dep)) (dep + 2) in\n Put g n nf_m nf_k nf_v nf_b\n go (Txt val) dep = Txt val\n go (Lst val) dep =\n let nf_val = map (\\x -> normal book fill lv x dep) val in\n Lst nf_val\n go (Nat val) dep = Nat val\n go (Var nam idx) dep = Var nam idx\n go (Src src val) dep =\n let nf_val = normal book fill lv val dep in\n Src src nf_val\n go (Met uid spn) dep = Met uid spn -- TODO: normalize spine\n go (Log msg nxt) dep =\n let nf_msg = normal book fill lv msg dep in\n let nf_nxt = normal book fill lv nxt dep in\n Log nf_msg nf_nxt\n\nnormalTele :: Book -> Fill -> Int -> Tele -> Int -> Tele\nnormalTele book fill lv tele dep = case tele of\n TRet term ->\n let nf_term = normal book fill lv term dep in\n TRet nf_term\n TExt nam typ bod ->\n let nf_typ = normal book fill lv typ dep in\n let nf_bod = \\x -> normalTele book fill lv (bod (Var nam dep)) (dep + 1) in\n TExt nam nf_typ nf_bod\n\n-- Binding\n-- -------\n\n-- Binds quoted variables to bound HOAS variables\nbind :: Term -> [(String,Term)] -> Term\nbind (All nam inp bod) ctx =\n let inp' = bind inp ctx in\n let bod' = \\x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in\n All nam inp' bod'\nbind (Lam nam bod) ctx =\n let bod' = \\x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in\n Lam nam bod'\nbind (App fun arg) ctx =\n let fun' = bind fun ctx in\n let arg' = bind arg ctx in\n App fun' arg'\nbind (Ann chk val typ) ctx =\n let val' = bind val ctx in\n let typ' = bind typ ctx in\n Ann chk val' typ'\nbind (Slf nam typ bod) ctx =\n let typ' = bind typ ctx in\n let bod' = \\x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in\n Slf nam typ' bod'\nbind (Ins val) ctx =\n let val' = bind val ctx in\n Ins val'\nbind (ADT scp cts typ) ctx =\n let scp' = map (\\x -> bind x ctx) scp in\n let cts' = map (\\x -> bindCtr x ctx) cts in\n let typ' = bind typ ctx in\n ADT scp' cts' typ'\n where\n bindCtr (Ctr nm tele) ctx = Ctr nm (bindTele tele ctx)\n bindTele (TRet term) ctx = TRet (bind term ctx)\n bindTele (TExt nam typ bod) ctx = TExt nam (bind typ ctx) $ \\x -> bindTele (bod x) ((nam, x) : ctx) -- FIXME: 'bod x'?\nbind (Con nam arg) ctx =\n let arg' = map (\\(f, x) -> (f, bind x ctx)) arg in\n Con nam arg'\nbind (Mat cse) ctx =\n let cse' = map (\\(cn,cb) -> (cn, bind cb ctx)) cse in\n Mat cse'\nbind (Swi zer suc) ctx =\n let zer' = bind zer ctx in\n let suc' = bind suc ctx in\n Swi zer' suc'\nbind (Map typ) ctx =\n let typ' = bind typ ctx in\n Map typ'\nbind (KVs kvs def) ctx =\n let kvs' = IM.map (\\x -> bind x ctx) kvs in\n let def' = bind def ctx in\n KVs kvs' def'\nbind (Get g n m k b) ctx =\n let m' = bind m ctx in\n let k' = bind k ctx in\n let b' = \\v s -> bind (b v s) ((n, s) : (g, v) : ctx) in\n Get g n m' k' b'\nbind (Put g n m k v b) ctx =\n let m' = bind m ctx in\n let k' = bind k ctx in\n let v' = bind v ctx in\n let b' = \\o s -> bind (b o s) ((n, s) : (g, o) : ctx) in\n Put g n m' k' v' b'\nbind (Ref nam) ctx =\n case lookup nam ctx of\n Just x -> x\n Nothing -> Ref nam\nbind (Let nam val bod) ctx =\n let val' = bind val ctx in\n let bod' = \\x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in\n Let nam val' bod'\nbind (Use nam val bod) ctx =\n let val' = bind val ctx in\n let bod' = \\x -> bind (bod (Var nam 0)) ((nam, x) : ctx) in\n Use nam val' bod'\nbind Set ctx = Set\nbind U64 ctx = U64\nbind F64 ctx = F64\nbind (Num val) ctx = Num val\nbind (Flt val) ctx = Flt val\nbind (Op2 opr fst snd) ctx =\n let fst' = bind fst ctx in\n let snd' = bind snd ctx in\n Op2 opr fst' snd'\nbind (Txt txt) ctx = Txt txt\nbind (Lst lst) ctx =\n let lst' = map (\\x -> bind x ctx) lst in\n Lst lst'\nbind (Nat val) ctx = Nat val\nbind (Hol nam ctxs) ctx = Hol nam (reverse (map snd ctx))\nbind (Met uid spn) ctx = Met uid []\nbind (Log msg nxt) ctx =\n let msg' = bind msg ctx in\n let nxt' = bind nxt ctx in\n Log msg' nxt'\nbind (Var nam idx) ctx =\n case lookup nam ctx of\n Just x -> x\n Nothing -> Var nam idx\nbind (Src src val) ctx =\n let val' = bind val ctx in\n Src src val'\n\ngenMetas :: Term -> Term\ngenMetas term = fst (genMetasGo term 0)\n\ngenMetasGo :: Term -> Int -> (Term, Int)\ngenMetasGo (All nam inp bod) c = \n let (inp', c1) = genMetasGo inp c\n (bod', c2) = genMetasGo (bod (Var nam 0)) c1\n in (All nam inp' (\\_ -> bod'), c2)\ngenMetasGo (Lam nam bod) c = \n let (bod', c1) = genMetasGo (bod (Var nam 0)) c\n in (Lam nam (\\_ -> bod'), c1)\ngenMetasGo (App fun arg) c = \n let (fun', c1) = genMetasGo fun c\n (arg', c2) = genMetasGo arg c1\n in (App fun' arg', c2)\ngenMetasGo (Ann chk val typ) c = \n let (val', c1) = genMetasGo val c\n (typ', c2) = genMetasGo typ c1\n in (Ann chk val' typ', c2)\ngenMetasGo (Slf nam typ bod) c = \n let (typ', c1) = genMetasGo typ c\n (bod', c2) = genMetasGo (bod (Var nam 0)) c1\n in (Slf nam typ' (\\_ -> bod'), c2)\ngenMetasGo (Ins val) c = \n let (val', c1) = genMetasGo val c\n in (Ins val', c1)\ngenMetasGo (ADT scp cts typ) c = \n let (scp', c1) = foldr (\\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) scp\n (cts', c2) = foldr (\\(Ctr nm tele) (acc, c') -> let (tele', c'') = genMetasGoTele tele c' in (Ctr nm tele' : acc, c'')) ([], c1) cts\n (typ', c3) = genMetasGo typ c2\n in (ADT scp' cts' typ', c3)\ngenMetasGo (Con nam arg) c = \n let (arg', c1) = foldr (\\(f, t) (acc, c') -> let (t', c'') = genMetasGo t c' in ((f, t'):acc, c'')) ([], c) arg\n in (Con nam arg', c1)\ngenMetasGo (Mat cse) c = \n let (cse', c1) = foldr (\\(cn, cb) (acc, c') -> let (cb', c'') = genMetasGo cb c' in ((cn, cb'):acc, c'')) ([], c) cse\n in (Mat cse', c1)\ngenMetasGo (Swi zer suc) c = \n let (zer', c1) = genMetasGo zer c\n (suc', c2) = genMetasGo suc c1\n in (Swi zer' suc', c2)\ngenMetasGo (Map typ) c = \n let (typ', c1) = genMetasGo typ c\n in (Map typ', c1)\ngenMetasGo (KVs kvs def) c = \n let (def', c1) = genMetasGo def c\n (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)\n in (KVs kvs' def', c2)\ngenMetasGo (Get g n m k b) c = \n let (m', c1) = genMetasGo m c\n (k', c2) = genMetasGo k c1\n (b', c3) = genMetasGo (b (Var g 0) (Var n 0)) c2\n in (Get g n m' k' (\\_ _ -> b'), c3)\ngenMetasGo (Put g n m k v b) c = \n let (m', c1) = genMetasGo m c\n (k', c2) = genMetasGo k c1\n (v', c3) = genMetasGo v c2\n (b', c4) = genMetasGo (b (Var g 0) (Var n 0)) c3\n in (Put g n m' k' v' (\\_ _ -> b'), c4)\ngenMetasGo (Let nam val bod) c = \n let (val', c1) = genMetasGo val c\n (bod', c2) = genMetasGo (bod (Var nam 0)) c1\n in (Let nam val' (\\_ -> bod'), c2)\ngenMetasGo (Use nam val bod) c = \n let (val', c1) = genMetasGo val c\n (bod', c2) = genMetasGo (bod (Var nam 0)) c1\n in (Use nam val' (\\_ -> bod'), c2)\ngenMetasGo (Met _ spn) c = \n let (spn', c1) = foldr (\\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) spn\n in (Met c1 spn', c1 + 1)\ngenMetasGo (Op2 opr fst snd) c = \n let (fst', c1) = genMetasGo fst c\n (snd', c2) = genMetasGo snd c1\n in (Op2 opr fst' snd', c2)\ngenMetasGo (Lst lst) c = \n let (lst', c1) = foldr (\\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) lst\n in (Lst lst', c1)\ngenMetasGo (Log msg nxt) c = \n let (msg', c1) = genMetasGo msg c\n (nxt', c2) = genMetasGo nxt c1\n in (Log msg' nxt', c2)\ngenMetasGo (Hol nam ctx) c = \n let (ctx', c1) = foldr (\\t (acc, c') -> let (t', c'') = genMetasGo t c' in (t':acc, c'')) ([], c) ctx\n in (Hol nam ctx', c1)\ngenMetasGo (Src src val) c = \n let (val', c1) = genMetasGo val c\n in (Src src val', c1)\ngenMetasGo term c = (term, c)\n\ngenMetasGoTele :: Tele -> Int -> (Tele, Int)\ngenMetasGoTele (TRet term) c = \n let (term', c1) = genMetasGo term c\n in (TRet term', c1)\ngenMetasGoTele (TExt nam typ bod) c = \n let (typ', c1) = genMetasGo typ c\n (bod', c2) = genMetasGoTele (bod (Var nam 0)) c1\n in (TExt nam typ' (\\_ -> bod'), c2)\n\ncountMetas :: Term -> Int\ncountMetas term = snd (genMetasGo term 0)\n" }, { "path": "src/Kind/Show.hs", "content": "-- //./Type.hs//\n\nmodule Kind.Show where\n\nimport Prelude hiding (EQ, LT, GT)\n\nimport Kind.Type\n\nimport Debug.Trace\nimport Data.Word\n\nimport Control.Applicative ((<|>))\n\nimport qualified Data.Map.Strict as M\nimport qualified Data.IntMap.Strict as IM\n\n-- Stringification\n-- ---------------\n\nshowTermGo :: Bool -> Term -> Int -> String\nshowTermGo small term dep =\n case pretty term of\n Just str -> str\n Nothing -> case term of\n All nam inp bod ->\n let nam' = nam\n inp' = showTermGo small inp dep\n bod' = showTermGo small (bod (Var nam dep)) (dep + 1)\n in concat [\"∀(\" , nam' , \": \" , inp' , \") \" , bod']\n Lam nam bod ->\n let nam' = nam\n bod' = showTermGo small (bod (Var nam dep)) (dep + 1)\n in concat [\"λ\" , nam' , \" \" , bod']\n App fun arg ->\n let (func, args) = unwrap fun [arg]\n func' = showTermGo small func dep\n args' = unwords (map (\\x -> showTermGo small x dep) args)\n in concat [\"(\" , func' , \" \" , args' , \")\"]\n where unwrap :: Term -> [Term] -> (Term, [Term])\n unwrap (App fun arg) args = unwrap fun (arg:args)\n unwrap term args = (term, args)\n Ann chk val typ ->\n if small\n then showTermGo small val dep\n else let val' = showTermGo small val dep\n typ' = showTermGo small typ dep\n in concat [\"{\" , val' , \": \" , typ' , \"}\"]\n Slf nam typ bod ->\n let nam' = nam\n typ' = showTermGo small typ dep\n bod' = showTermGo small (bod (Var nam dep)) (dep + 1)\n in concat [\"$(\" , nam' , \": \" , typ' , \") \" , bod']\n Ins val ->\n let val' = showTermGo small val dep\n in concat [\"~\" , val']\n -- CHANGED: Updated ADT case to use new Ctr structure\n ADT scp cts typ ->\n let scp' = unwords (map (\\x -> showTermGo small x dep) scp)\n cts' = unwords (map (\\(Ctr nm tele) -> \"#\" ++ nm ++ \" \" ++ showTeleGo small tele dep) cts)\n typ' = showTermGo small typ dep\n in concat [\"#[\", scp', \"]{ \", cts', \" } : \", typ']\n Con nam arg ->\n let arg' = unwords (map showArg arg)\n in concat [\"#\", nam, \"{\", arg', \"}\"]\n where\n showArg (maybeField, term) = case maybeField of\n Just field -> field ++ \": \" ++ showTermGo small term dep\n Nothing -> showTermGo small term dep\n Mat cse ->\n let cse' = unwords (map (\\(cnm, cbod) -> \"#\" ++ cnm ++ \": \" ++ showTermGo small cbod dep) cse)\n in concat [\"λ{ \", cse', \" }\"]\n -- Ref nam -> concat [\"@\", nam]\n Ref nam -> concat [nam]\n Let nam val bod ->\n let nam' = nam\n val' = showTermGo small val dep\n bod' = showTermGo small (bod (Var nam dep)) (dep + 1)\n in concat [\"let \" , nam' , \" = \" , val' , \" \" , bod']\n Use nam val bod ->\n let nam' = nam\n val' = showTermGo small val dep\n bod' = showTermGo small (bod (Var nam dep)) (dep + 1)\n in concat [\"use \" , nam' , \" = \" , val' , \" \" , bod']\n Set -> \"*\"\n U64 -> \"U64\"\n F64 -> \"F64\"\n Num val ->\n let val' = show val\n in concat [val']\n Flt val ->\n let val' = show val\n in concat [val']\n Op2 opr fst snd ->\n let opr' = showOper opr\n fst' = showTermGo small fst dep\n snd' = showTermGo small snd dep\n in concat [\"(\" , opr' , \" \" , fst' , \" \" , snd' , \")\"]\n Swi zero succ ->\n let zero' = showTermGo small zero dep\n succ' = showTermGo small succ dep\n in concat [\"λ{ 0: \", zero', \" _: \", succ', \" }\"]\n Map typ ->\n let typ' = showTermGo small typ dep\n in concat [\"(Map \", typ', \")\"]\n KVs kvs def ->\n let kvs' = unwords (map (\\(k, v) -> show k ++ \":\" ++ showTermGo small v dep) (IM.toList kvs))\n def' = showTermGo small def dep\n in concat [\"{\", kvs', \" | \", def', \"}\"]\n Get got nam map key bod ->\n let got' = got\n nam' = nam\n map' = showTermGo small map dep\n key' = showTermGo small key dep\n bod' = showTermGo small (bod (Var got dep) (Var nam dep)) (dep + 2)\n in concat [\"get \", got', \" = \", nam', \"@\", map', \"[\", key', \"] \", bod']\n Put got nam map key val bod ->\n let got' = got\n nam' = nam\n map' = showTermGo small map dep\n key' = showTermGo small key dep\n val' = showTermGo small val dep\n bod' = showTermGo small (bod (Var got dep) (Var nam dep)) (dep + 2)\n in concat [\"put \", got', \" = \", nam', \"@\", map', \"[\", key', \"] := \", val', \" \", bod']\n Txt txt -> concat [\"\\\"\" , txt , \"\\\"\"]\n Lst lst -> concat [\"[\", unwords (map (\\x -> showTermGo small x dep) lst), \"]\"]\n Nat val -> concat [\"#\", (show val)]\n Hol nam ctx -> concat [\"?\" , nam]\n -- Met uid spn -> concat [\"_\", show uid, \"[\", strSpn spn dep, \" ]\"]\n Met uid spn -> concat [\"_\", show uid]\n Log msg nxt -> \n let msg' = showTermGo small msg dep\n nxt' = showTermGo small nxt dep\n in concat [\"log \", msg', \" \", nxt']\n Var nam idx -> nam\n Src src val -> if small\n then showTermGo small val dep\n else concat [\"!\", showTermGo small val dep]\n\n-- CHANGED: Added showTeleGo function\nshowTeleGo :: Bool -> Tele -> Int -> String\nshowTeleGo small tele dep = \"{ \" ++ go tele dep where\n go (TExt nam typ bod) dep =\n let typ' = showTermGo small typ dep\n bod' = go (bod (Var nam dep)) (dep + 1)\n in concat [nam, \": \", typ', \" \", bod']\n go (TRet term) dep =\n let term' = showTermGo small term dep\n in concat [\"}: \", term']\n\nshowTele :: Tele -> String\nshowTele tele = showTeleGo True tele 0\n\nshowTerm :: Term -> String\nshowTerm term = showTermGo True term 0\n\nstrSpn :: [Term] -> Int -> String\nstrSpn [] dep = \"\"\nstrSpn (x : xs) dep = concat [\" \", showTermGo True x dep, strSpn xs dep]\n\nshowOper :: Oper -> String\nshowOper ADD = \"+\"\nshowOper SUB = \"-\"\nshowOper MUL = \"*\"\nshowOper DIV = \"/\"\nshowOper MOD = \"%\"\nshowOper EQ = \"==\"\nshowOper NE = \"!=\"\nshowOper LT = \"<\"\nshowOper GT = \">\"\nshowOper LTE = \"<=\"\nshowOper GTE = \">=\"\nshowOper AND = \"&\"\nshowOper OR = \"|\"\nshowOper XOR = \"^\"\nshowOper LSH = \"<<\"\nshowOper RSH = \">>\"\n\n-- Pretty Printing (Sugars)\n-- ------------------------\n\npretty :: Term -> Maybe String\npretty term = prettyString term <|> prettyNat term <|> prettyList term <|> prettyEqual term\n\nprettyString :: Term -> Maybe String\nprettyString (Con \"View\" [(_, term)]) = do\n chars <- prettyStringGo term\n return $ '\"' : chars ++ \"\\\"\"\nprettyString _ = Nothing\n\nprettyStringGo :: Term -> Maybe String\nprettyStringGo (Con \"Nil\" []) = Just []\nprettyStringGo (Con \"Cons\" [(_, Num head), (_, tail)]) = do\n rest <- prettyStringGo tail\n return $ toEnum (fromIntegral head) : rest\nprettyStringGo _ = Nothing\n\nprettyNat :: Term -> Maybe String\nprettyNat (Con \"Zero\" []) = Just \"#0\"\nprettyNat term = go 0 term where\n go n (Con \"Succ\" [(_, pred)]) = go (n + 1) pred\n go n (Con \"Zero\" []) = Just $ \"#\" ++ show n\n go _ _ = Nothing\n\nprettyList :: Term -> Maybe String\nprettyList term = do\n terms <- asList term\n return $ \"[\" ++ unwords (map (\\x -> showTermGo True x 0) terms) ++ \"]\"\n where asList (Con \"Nil\" []) = do\n Just []\n asList (Con \"Cons\" [(_, head), (_, tail)]) = do\n rest <- asList tail\n return (head : rest)\n asList _ = Nothing\n\nprettyEqual :: Term -> Maybe String\nprettyEqual (App (App (App (Ref \"Equal\") t) a) b) = do\n let a' = showTermGo True a 0\n b' = showTermGo True b 0\n return $ a' ++ \" == \" ++ b'\nprettyEqual _ = Nothing\n" }, { "path": "src/Kind/Type.hs", "content": "module Kind.Type where\n\nimport System.IO.Unsafe (unsafePerformIO)\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\n\nimport Debug.Trace\nimport Data.Word (Word64)\n\n-- Kind's AST\ndata Term\n -- Product: `∀(x: A) B`\n = All String Term (Term -> Term)\n\n -- Lambda: `λx f`\n | Lam String (Term -> Term)\n\n -- Application: `(fun arg)`\n | App Term Term\n\n -- Annotation: `{x: T}`\n | Ann Bool Term Term\n\n -- Self-Type: `$(x: A) B`\n | Slf String Term (Term -> Term)\n\n -- Self-Inst: `~x`\n | Ins Term\n\n -- Datatype: `#[i0 i1...]{ #C0 Tele0 #C1 Tele1 ... }`\n | ADT [Term] [Ctr] Term\n\n -- Constructor: `#CN { x0 x1 ... }`\n | Con String [(Maybe String, Term)]\n\n -- Lambda-Match: `λ{ #C0:B0 #C1:B1 ... }`\n | Mat [(String, Term)]\n\n -- Top-Level Reference: `Foo`\n | Ref String\n\n -- Local let-definition: `let x = val body`\n | Let String Term (Term -> Term)\n\n -- Local use-definition: `use x = val body`\n | Use String Term (Term -> Term)\n\n -- Universe: `Set`\n | Set\n\n -- U64 Type: `U64`\n | U64\n\n -- F64 Type: `F64`\n | F64\n\n -- U64 Value: `123`\n | Num Word64\n\n -- F64 Value: `1.5`\n | Flt Double\n\n -- Binary Operation: `(+ x y)`\n | Op2 Oper Term Term\n\n -- U64 Elimination: `λ{ 0:A 1+p:B }`\n | Swi Term Term\n\n -- Linear Map Type: `(Map T)`\n | Map Term \n\n -- Linear Map Value: `{ k0:v0 k1:v1 ... | default }`\n | KVs (IM.IntMap Term) Term\n\n -- Linear Map Getter: `get val = nam@map[key] bod`\n -- - got is the name of the obtained value\n -- - nam is the name of the map\n -- - map is the value of the map\n -- - key is the key to query\n -- - bod is the continuation; receives the value and the same map\n | Get String String Term Term (Term -> Term -> Term)\n\n -- Map Swapper: `put got = nam@map[key] := val body`\n -- - got is the name of the old value\n -- - nam is the name of the map\n -- - map is the value of the map\n -- - key is the key to swap\n -- - val is the val to insert\n -- - bod is the continuation; receives the old value and the changed map\n | Put String String Term Term Term (Term -> Term -> Term)\n\n -- Inspection Hole\n | Hol String [Term]\n\n -- Unification Metavar\n | Met Int [Term]\n\n -- Logging\n | Log Term Term\n\n -- Variable\n | Var String Int\n\n -- Source Location\n | Src Cod Term\n\n -- Text Literal (sugar)\n | Txt String\n\n -- List Literal (sugar)\n | Lst [Term]\n\n -- Nat Literal (sugar)\n | Nat Integer\n\n -- Substitution\n | Sub Term\n\n-- Location: Name, Line, Column\ndata Loc = Loc String Int Int\ndata Cod = Cod Loc Loc\n\n-- Numeric Operators\ndata Oper \n = ADD | SUB | MUL | DIV\n | MOD | EQ | NE | LT\n | GT | LTE | GTE | AND\n | OR | XOR | LSH | RSH\n deriving Show\n\n-- Telescope\ndata Tele\n = TRet Term\n | TExt String Term (Term -> Tele)\n\n-- Constructor\ndata Ctr = Ctr String Tele\n\n-- Book of Definitions\ntype Book = M.Map String Term\n\n-- Type-Checker Outputs\ndata Info\n = Found String Term [Term] Int\n | Solve Int Term Int\n | Error (Maybe Cod) Term Term Term Int\n | Vague String\n | Print Term Int\n\n-- Unification Solutions\ntype Fill = IM.IntMap Term\n\n-- Checker State\ndata Check = Check (Maybe Cod) Term Term Int -- postponed check\ndata State = State Book Fill [Check] [Info] -- state type\ndata Res a = Done State a | Fail State -- result type\ndata Env a = Env (State -> Res a) -- monadic checker\n\n-- UNCOMMENT THIS TO DEBUG THE TYPE CHECKER\n-- debug a b = trace a b\ndebug a b = b\n" }, { "path": "src/Kind/Util.hs", "content": "-- //./Type.hs//\n\nmodule Kind.Util where\n\nimport Kind.Show\nimport Kind.Type\nimport Kind.Equal\n\nimport Prelude hiding (LT, GT, EQ)\n\nimport qualified Data.IntMap.Strict as IM\nimport qualified Data.Map.Strict as M\nimport qualified Data.Set as S\n\nimport Debug.Trace\n\n-- Gets dependencies of a term\ngetDeps :: Term -> [String]\ngetDeps term = case term of\n Ref nam -> [nam]\n All _ inp out -> getDeps inp ++ getDeps (out Set)\n Lam _ bod -> getDeps (bod Set)\n App fun arg -> getDeps fun ++ getDeps arg\n Ann _ val typ -> getDeps val ++ getDeps typ\n Slf _ typ bod -> getDeps typ ++ getDeps (bod Set)\n Ins val -> getDeps val\n ADT scp cts t -> concatMap getDeps scp ++ concatMap getDepsCtr cts ++ getDeps t\n Con _ arg -> concatMap (getDeps . snd) arg\n Mat cse -> concatMap (getDeps . snd) cse\n Let _ val bod -> getDeps val ++ getDeps (bod Set)\n Use _ val bod -> getDeps val ++ getDeps (bod Set)\n Op2 _ fst snd -> getDeps fst ++ getDeps snd\n Swi zer suc -> getDeps zer ++ getDeps suc\n Map val -> getDeps val\n KVs kvs def -> concatMap getDeps (IM.elems kvs) ++ getDeps def\n Get _ _ m k b -> getDeps m ++ getDeps k ++ getDeps (b Set Set)\n Put _ _ m k v b -> getDeps m ++ getDeps k ++ getDeps v ++ getDeps (b Set Set)\n Src _ val -> getDeps val\n Hol _ args -> concatMap getDeps args\n Met _ args -> concatMap getDeps args\n Log msg nxt -> getDeps msg ++ getDeps nxt\n Var _ _ -> []\n Set -> []\n U64 -> []\n F64 -> []\n Num _ -> []\n Flt _ -> []\n Txt _ -> []\n Lst elems -> concatMap getDeps elems\n Nat _ -> []\n\n-- Gets dependencies of a constructor\ngetDepsCtr :: Ctr -> [String]\ngetDepsCtr (Ctr _ tele) = getDepsTele tele\n\n-- Gets dependencies of a telescope\ngetDepsTele :: Tele -> [String]\ngetDepsTele (TRet term) = getDeps term\ngetDepsTele (TExt _ typ bod) = getDeps typ ++ getDepsTele (bod Set)\n\n-- Gets all dependencies (direct and indirect) of a term\ngetAllDeps :: Book -> String -> S.Set String\ngetAllDeps book name = go S.empty [name] where\n go visited [] = visited\n go visited (x:xs)\n | S.member x visited = go visited xs\n | otherwise = case M.lookup x book of\n Just term -> go (S.insert x visited) (getDeps term ++ xs)\n Nothing -> go (S.insert x visited) xs\n\n-- Topologically sorts a book\ntopoSortBook :: Book -> [(String, Term)]\ntopoSortBook book = go (M.keysSet book) [] where\n go mustInclude done = case S.lookupMin mustInclude of\n Nothing -> reverse done\n Just name -> \n let (mustInclude', done') = include mustInclude done name\n in go mustInclude' done'\n\n include :: S.Set String -> [(String, Term)] -> String -> (S.Set String, [(String, Term)])\n include mustInclude done name =\n if not (S.member name mustInclude) then\n (mustInclude, done)\n else case M.lookup name book of\n Nothing ->\n error (\"unbound:\" ++ name)\n Just term ->\n let deps = getDeps term\n mustInclude' = S.delete name mustInclude\n (mustInclude'', done') = includeDeps mustInclude' done deps\n in (mustInclude'', (name,term) : done')\n\n includeDeps :: S.Set String -> [(String, Term)] -> [String] -> (S.Set String, [(String, Term)])\n includeDeps mustInclude done [] = (mustInclude, done)\n includeDeps mustInclude done (dep:deps) =\n let (mustInclude', done') = include mustInclude done dep\n (mustInclude'', done'') = includeDeps mustInclude' done' deps\n in (mustInclude'', done'')\n\n-- Converts:\n-- - from a Tele: `{ x:A y:(B x) ... }: (C x y ...)`\n-- - to a type: `∀(x: A) ∀(y: (B x)) ... (C x y ...)`\nteleToType :: Tele -> Term -> Int -> Term\nteleToType (TRet _) ret _ = ret\nteleToType (TExt nam inp bod) ret dep = All nam inp (\\x -> teleToType (bod x) ret (dep + 1))\n\n-- Converts:\n-- - from a Tele : `{ x:A y:(B x) ... }: (C x y ...)`\n-- - to terms : `([(Just \"x\", ), [(Just \"y\", <(B x)>)], ...], <(C x y ...)>)`\nteleToTerms :: Tele -> Int -> ([(Maybe String, Term)], Term)\nteleToTerms tele dep = go tele [] dep where\n go (TRet ret) args _ = (reverse args, ret)\n go (TExt nam inp bod) args dep = go (bod (Var nam dep)) ((Just nam, Var nam dep) : args) (dep + 1)\n\ngetTeleNames :: Tele -> Int -> [String] -> [String]\ngetTeleNames (TRet _) dep acc = reverse acc\ngetTeleNames (TExt name _ next) dep acc = getTeleNames (next (Var name dep)) (dep+1) (name:acc)\n\ngetTeleFields :: Tele -> Int -> [(String,Term)] -> [(String,Term)]\ngetTeleFields (TRet _) dep acc = reverse acc\ngetTeleFields (TExt name ttyp next) dep acc = getTeleFields (next (Var name dep)) (dep+1) ((name,ttyp):acc)\n\ngetDatIndices :: Term -> [Term]\ngetDatIndices term = case term of\n ADT idxs _ _ -> idxs\n _ -> []\n\ngetType :: Term -> Term\ngetType (Ann _ val typ) = typ\ngetType _ = error \"?\"\n\ngetTerm :: Term -> Term\ngetTerm (Ann _ val typ) = val\ngetTerm _ = error \"?\"\n\ngetCtrName :: Ctr -> String\ngetCtrName (Ctr name _) = name\n\ngetADTCts :: Term -> [(String,Ctr)]\ngetADTCts (ADT _ cts _) = map (\\ ctr -> (getCtrName ctr, ctr)) cts\ngetADTCts (Src loc val) = getADTCts val\ngetADTCts term = error (\"not-an-adt:\" ++ showTerm term)\n\n-- Given a typed term, return its argument's names\ngetArgNames :: Term -> [String]\ngetArgNames (Ann _ _ typ) = getForallNames typ\ngetArgNames (Src _ val) = getArgNames val\ngetArgNames _ = []\n\n-- Returns the names in a chain of foralls\ngetForallNames :: Term -> [String]\ngetForallNames (All nam _ bod) = nam : getForallNames (bod Set)\ngetForallNames (Src _ val) = getForallNames val\ngetForallNames _ = []\n\ngetOpReturnType :: Oper -> Term -> Term\ngetOpReturnType ADD U64 = U64\ngetOpReturnType ADD F64 = F64\ngetOpReturnType SUB U64 = U64\ngetOpReturnType SUB F64 = F64\ngetOpReturnType MUL U64 = U64\ngetOpReturnType MUL F64 = F64\ngetOpReturnType DIV U64 = U64\ngetOpReturnType DIV F64 = F64\ngetOpReturnType MOD U64 = U64\ngetOpReturnType EQ _ = U64\ngetOpReturnType NE _ = U64\ngetOpReturnType LT _ = U64\ngetOpReturnType GT _ = U64\ngetOpReturnType LTE _ = U64\ngetOpReturnType GTE _ = U64\ngetOpReturnType AND U64 = U64\ngetOpReturnType OR U64 = U64\ngetOpReturnType XOR U64 = U64\ngetOpReturnType LSH U64 = U64\ngetOpReturnType RSH U64 = U64\ngetOpReturnType opr trm = error (\"Invalid opertor: \" ++ (show opr) ++ \" Invalid operand type: \" ++ (showTerm trm))\n\ncheckValidType :: Term -> [Term] -> Int -> Env Bool\ncheckValidType typ validTypes dep = foldr (\\t acc -> do\n isEqual <- equal typ t dep\n if isEqual then return True else acc\n ) (return False) validTypes\n\n" }, { "path": "src/Kind.hs", "content": "module Kind (\n module Kind.CLI,\n module Kind.Check,\n module Kind.Env,\n module Kind.Equal,\n module Kind.Parse,\n module Kind.Reduce,\n module Kind.Show,\n module Kind.Type,\n module Kind.Util,\n) where\n\nimport Kind.CLI\nimport Kind.Check\nimport Kind.CompileJS\nimport Kind.Env\nimport Kind.Equal\nimport Kind.Parse\nimport Kind.Reduce\nimport Kind.Show\nimport Kind.Type\nimport Kind.Util\n" } ]