From 320bc67bac3206d73e57bb64d3cfbd83d3e1f0bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Fri, 22 Oct 2021 06:59:40 +0200 Subject: [PATCH 01/59] feat: `scan` functions (#1339) --- core/Array.carp | 24 ++++++++++++++++++++++++ core/StaticArray.carp | 8 ++++++++ test/array.carp | 16 ++++++++++++++++ test/static_array.carp | 12 +++++++++++- 4 files changed, 59 insertions(+), 1 deletion(-) diff --git a/core/Array.carp b/core/Array.carp index 58d543576..98e9a2332 100644 --- a/core/Array.carp +++ b/core/Array.carp @@ -43,6 +43,30 @@ It will sum the previous sum with each new value, starting at `0`.") (set! total (~f total (unsafe-nth xs i)))) total))) + (doc scan "Similar to `Array.reduce`, but instead returns an array with the starting element, +and then all intermediate values. + +For example, a scan using `Int.+` over the array [1 1 1 1 1] (starting at 0) will return [0 1 2 3 4 5].") + (defn scan [f x xs] + (let [n (length xs) + ys (allocate (inc n))] + (do + (aset-uninitialized! &ys 0 @&x) + (for [i 1 (inc n)] + (aset-uninitialized! &ys i (~f (unsafe-nth &ys (dec i)) (unsafe-nth xs (dec i))))) + ys))) + + (doc endo-scan "Like `Array.scan`, but uses the first element of the array as the starting value. +Also does not create a new array, but reuses the initial one instead (by taking ownership over `xs`.) + +For example, an endo-scan using `Int.+` over the array [1 1 1 1 1] will return [1 2 3 4 5]") + (defn endo-scan [f xs] + (let [n (length &xs)] + (do + (for [i 1 n] + (aset! &xs i (~f (unsafe-nth &xs (dec i)) (unsafe-nth &xs i)))) + xs))) + (doc empty? "checks whether the array `a` is empty.") (defn empty? [a] (= (Array.length a) 0)) diff --git a/core/StaticArray.carp b/core/StaticArray.carp index ea30659c6..9c841db78 100644 --- a/core/StaticArray.carp +++ b/core/StaticArray.carp @@ -38,6 +38,14 @@ stack-allocated. For a more flexible, heap-allocated version, you might want to (set! total (~f total (StaticArray.unsafe-nth xs i)))) total))) + (doc scan! "Scans and replaces the array in-place, using a binary function. + +For example, give `(def numbers [1 1 1])`, a `scan!` using `Int.+` will mutate `numbers` to be `[1 2 3]`.") + (defn scan! [f xs] + (let [n (StaticArray.length xs)] + (for [i 1 n] + (StaticArray.aset! xs i (~f @(unsafe-nth xs (dec i)) @(unsafe-nth xs i)))))) + (doc = "compares two static arrays.") (defn = [a b] (if (/= (StaticArray.length a) (StaticArray.length b)) diff --git a/test/array.carp b/test/array.carp index 92ada023d..cc4676b3f 100644 --- a/test/array.carp +++ b/test/array.carp @@ -335,4 +335,20 @@ (Pair.init 6 [2 4 6]) (map-reduce &(fn [acc x] (Pair.init (+ @x @acc) (* @x 2))) 0 &[1 2 3]) "map-reduce works") + (assert-ref-equal test + [0 1 2 3 4 5] + (scan &(fn [x y] (+ @x @y)) 0 &[1 1 1 1 1]) + "scan works") + (assert-ref-equal test + [@"" @"a" @"ab" @"abc"] + (Array.scan &(fn [a b] (String.append a b)) @"" &[@"a" @"b" @"c"]) + "scan works on managed type") + (assert-ref-equal test + [1 2 3 4 5] + (endo-scan &(fn [x y] (+ @x @y)) [1 1 1 1 1]) + "endo-scan works") + (assert-ref-equal test + [@"a" @"ab" @"abc"] + (Array.endo-scan &String.append [@"a" @"b" @"c"]) + "endo-scan works on managed type") ) diff --git a/test/static_array.carp b/test/static_array.carp index eab79a87c..e6cf67004 100644 --- a/test/static_array.carp +++ b/test/static_array.carp @@ -216,4 +216,14 @@ (assert-equal test &2 (Pointer.to-ref (Pointer.inc (unsafe-raw $[1 2 3]))) - "unsafe-raw works as expected II")) + "unsafe-raw works as expected II") + + (let [arr $[1 1 1 1 1]] + (assert-equal test + $[1 2 3 4 5] + (do + (StaticArray.scan! &Int.+ arr) + arr) + "scan! works")) + + ) From 499a03e63edd1f370196f9ca43e55335d7e62c87 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Fri, 22 Oct 2021 00:59:51 -0400 Subject: [PATCH 02/59] fix: don't hang on module expansions (#1340) --- src/Expand.hs | 13 +++++++++++++ src/Primitives.hs | 2 ++ 2 files changed, 15 insertions(+) diff --git a/src/Expand.hs b/src/Expand.hs index c28301761..ef9c58f39 100644 --- a/src/Expand.hs +++ b/src/Expand.hs @@ -41,6 +41,19 @@ expand eval ctx xobj = Lst _ -> expandList xobj Arr _ -> expandArray xobj Sym _ _ -> expandSymbol xobj + -- This case is needed to ensure we expand naked mod names to initers consistently. + -- Consider both: + -- (width (address &(B 2))) + -- (width B) + -- The first case is correct code and was handled by expandList. The second case is an error and previously resulted in a loop because + -- module expansion wasn't handled in expandSymbol, but handling it there + -- by ending the expansion loop breaks init expansion in the first case, + -- since expandList calls expand. + -- So, we have no choice but to add a case here to cut the recursion and to expand this form consistently in all places. + Mod e _ -> + let pathToModule = pathToEnv e + implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) (xobjInfo xobj) (xobjTy xobj) + in pure (ctx, Right implicitInit) _ -> pure (ctx, Right xobj) where expandList :: XObj -> IO (Context, Either EvalError XObj) diff --git a/src/Primitives.hs b/src/Primitives.hs index 24345f9cb..f789ac46a 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -228,6 +228,8 @@ primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] = primitiveRegisterTypeWithoutFields ctx t Nothing primitiveRegisterType _ ctx [x] = pure (evalError ctx ("`register-type` takes a symbol, but it got " ++ pretty x) (xobjInfo x)) +primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] _) _) _ _), XObj (Str "") _ _] = + pure (evalError ctx ("cannot register type " ++ pretty x ++ " with an empty string override, this will produce invalid C") (xobjInfo x)) primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _, XObj (Str override) _ _] = primitiveRegisterTypeWithoutFields ctx t (Just override) primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), XObj (Str override) _ _, members] = From 0682f1a61e3ef02f460425cf02e47f2cc45adcb6 Mon Sep 17 00:00:00 2001 From: Lucas Leblow Date: Mon, 25 Oct 2021 01:50:10 -0600 Subject: [PATCH 03/59] Bug fix for #1064 and #843 (#1321) * Bug fix for #1064 and #843 Removes broken fix for #843 in Emit.hs, thus fixing #1064. And then this commit focuses on fixing the memory management side of things, so that we don't add deleters for symbols in the left-hand-side of match case expressions if we are matching on a ref (e.g. using match-ref). * Add sumtype memory tests --- src/Emit.hs | 4 +--- src/Memory.hs | 24 ++++++++++++------------ test/memory.carp | 45 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 15 deletions(-) diff --git a/src/Emit.hs b/src/Emit.hs index e003e15aa..3372a22b4 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -445,9 +445,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo when isNotVoid $ appendToSrc (addIndent indent' ++ retVar ++ " = " ++ caseExprRetVal ++ ";\n") let Just caseLhsInfo' = caseLhsInfo - when - (matchMode == MatchValue) - (delete indent' caseLhsInfo') + delete indent' caseLhsInfo' appendToSrc (addIndent indent ++ "}\n") in do exprVar <- visit indent expr diff --git a/src/Memory.hs b/src/Memory.hs index fee3e307a..2a20fce22 100644 --- a/src/Memory.hs +++ b/src/Memory.hs @@ -337,7 +337,7 @@ manageMemory typeEnv globalEnv root = -- 2. Variables deleted in at least one case has to be deleted in all, so make a union U of all such vars -- but remove the ones that were not present before the 'match' -- 3. In each case - take the intersection of U and the vars deleted in that case and add this result to its deleters - matchExpr@(XObj (Match _) _ _) : expr : cases -> + matchExpr@(XObj (Match matchMode) _ _) : expr : cases -> do visitedExpr <- visit expr case visitedExpr of @@ -346,7 +346,7 @@ manageMemory typeEnv globalEnv root = do _ <- unmanage typeEnv globalEnv okVisitedExpr MemState preDeleters deps lifetimes <- get - vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases) + vistedCasesAndDeps <- mapM (visitMatchCase matchMode) (pairwise cases) case sequence vistedCasesAndDeps of Left e -> pure (Left e) Right okCasesAndDeps -> @@ -415,11 +415,11 @@ manageMemory typeEnv globalEnv root = Right (XObj (Lst (okF : okArgs)) i t) [] -> pure (Right xobj) visitList _ = error "Must visit list." - visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty)) - visitMatchCase (lhs@XObj {}, rhs@XObj {}) = + visitMatchCase :: MatchMode -> (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty)) + visitMatchCase matchMode (lhs@XObj {}, rhs@XObj {}) = do MemState preDeleters _ _ <- get - _ <- visitCaseLhs lhs + _ <- visitCaseLhs matchMode lhs visitedRhs <- visit rhs _ <- unmanage typeEnv globalEnv rhs MemState postDeleters postDeps postLifetimes <- get @@ -427,20 +427,20 @@ manageMemory typeEnv globalEnv root = pure $ do okVisitedRhs <- visitedRhs pure ((postDeleters, (lhs, okVisitedRhs)), postDeps) - visitCaseLhs :: XObj -> State MemState (Either TypeError [()]) - visitCaseLhs (XObj (Lst vars) _ _) = + visitCaseLhs :: MatchMode -> XObj -> State MemState (Either TypeError [()]) + visitCaseLhs matchMode (XObj (Lst vars) _ _) = do - result <- mapM visitCaseLhs vars + result <- mapM (visitCaseLhs matchMode) vars let result' = sequence result pure (fmap concat result') - visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _) - | isVarName name = do + visitCaseLhs matchMode xobj@(XObj (Sym (SymPath _ name) _) _ _) + | (matchMode == MatchValue) && isVarName name = do manage typeEnv globalEnv xobj pure (Right []) | otherwise = pure (Right []) - visitCaseLhs (XObj Ref _ _) = + visitCaseLhs _ (XObj Ref _ _) = pure (Right []) - visitCaseLhs x = + visitCaseLhs _ x = error ("Unhandled: " ++ show x) visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj)) visitLetBinding (name, expr) = diff --git a/test/memory.carp b/test/memory.carp index 9d42c009c..5353ecc4f 100644 --- a/test/memory.carp +++ b/test/memory.carp @@ -444,6 +444,46 @@ (match m _ 1))))) +(deftype Example + One + (Two [String])) + +(defn sumtype-8 [] + (let-do [ex [(Example.Two @"OKOK")]] + (match-ref (Array.unsafe-nth &ex 0) + (Example.Two s) (println* s) + _ ()))) + +(deftype Sum One Two) + +(defn sumtype-9 [] + (let [state @"Ok" sumt &(Sum.One)] + (match-ref sumt + Sum.One (println* &@&state) + Sum.Two ()))) + +(defn sumtype-10 [] + (let [state 0] + (match-ref &(Sum.One) + Sum.One (println* ((fn [] @&state))) + Sum.Two ()))) + +(deftype ExampleA + One + (Two [(Array String)])) + +(defn sumtype-11 [] + (match-ref &(Just (ExampleA.Two [@"OKOK"])) + (Just s) () + _ ()) + ) + +(defn sumtype-12 [] + (match (Just (ExampleA.Two [@"OKOK"])) + (Just s) () + _ ()) + ) + (deftest test (assert-no-leak test scope-1 "scope-1 does not leak") (assert-no-leak test scope-2 "scope-2 does not leak") @@ -513,4 +553,9 @@ (assert-no-leak test sumtype-5 "sumtype-5 does not leak") (assert-no-leak test sumtype-6 "sumtype-6 does not leak") (assert-no-leak test sumtype-7 "sumtype-7 does not leak") + (assert-no-leak test sumtype-8 "sumtype-8 does not leak") + (assert-no-leak test sumtype-9 "sumtype-9 does not leak") + (assert-no-leak test sumtype-10 "sumtype-10 does not leak") + (assert-no-leak test sumtype-11 "sumtype-11 does not leak") + (assert-no-leak test sumtype-12 "sumtype-12 does not leak") ) From c471fcce89442ea4a9c0276a8aa78af4b48cb001 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 25 Oct 2021 03:53:08 -0400 Subject: [PATCH 04/59] fix: don't emit Unit type the casts (#1349) Previously, the forms cast to the type Unit would still result in variable assignment emissions, which produces invalid C. Consider the case: ```clojure ;; type of System.exit is (Int -> a) (defn main [] (the () (System.exit 0))) ``` This previously produced bad variable assignments. It now works as expected and emits only the function call. --- src/Emit.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Emit.hs b/src/Emit.hs index 3372a22b4..a2f2af381 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -530,7 +530,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo var <- visit indent value let Just t = ty fresh = mangle (freshVar info) - appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n") + unless (isUnit t) + (appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n")) pure fresh -- Ref [XObj Ref _ _, value] -> From 4e02c452dc44f901a03e3c548a0e579f083f935a Mon Sep 17 00:00:00 2001 From: Lucas Leblow Date: Thu, 28 Oct 2021 02:18:38 -0600 Subject: [PATCH 05/59] test: add match given-away value error test (#1351) --- .../match-given-away-value.carp.output.expected | 1 + test/test-for-errors/match-given-away-value.carp | 9 +++++++++ 2 files changed, 10 insertions(+) create mode 100644 test/output/test/test-for-errors/match-given-away-value.carp.output.expected create mode 100644 test/test-for-errors/match-given-away-value.carp diff --git a/test/output/test/test-for-errors/match-given-away-value.carp.output.expected b/test/output/test/test-for-errors/match-given-away-value.carp.output.expected new file mode 100644 index 000000000..da467a271 --- /dev/null +++ b/test/output/test/test-for-errors/match-given-away-value.carp.output.expected @@ -0,0 +1 @@ +match-given-away-value.carp:9:16 Referencing a given-away value 'e'. diff --git a/test/test-for-errors/match-given-away-value.carp b/test/test-for-errors/match-given-away-value.carp new file mode 100644 index 000000000..11772e210 --- /dev/null +++ b/test/test-for-errors/match-given-away-value.carp @@ -0,0 +1,9 @@ +(Project.config "file-path-print-length" "short") + +(deftype Example (A [String String])) + +(defn f [] + (let-do [e (Example.A @"x" @"y")] + (match e + (Example.A a b) ()) + (println* &e))) From 6f4e09f71f15e606f55e17b765457fef60aca083 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Thu, 28 Oct 2021 14:30:00 +0200 Subject: [PATCH 06/59] docs: add documentation to core expressions (#1350) (#1352) --- src/StartingEnv.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index aa7896ad6..cf0498ecc 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -489,16 +489,16 @@ startingGlobalEnv noArray = makeSymbol "do" "is used to group statements." "(do (println* \"hi\") 1) ; => 1" Do, makeSymbol "while" "is used for loops." "(while true\n (loop-forever))" While, makeSymbol "fn" "is used to define anonymous functions." "(fn [arg] body)" (Fn Nothing Set.empty), - makeSymbol "let" "" "" Let, - makeSymbol "break" "" "" Break, - makeSymbol "if" "" "" If, - makeSymbol "match" "" "" (Match MatchValue), - makeSymbol "match-ref" "" "" (Match MatchRef), - makeSymbol "set!" "" "" SetBang, - makeSymbol "the" "" "" The, - makeSymbol "ref" "" "" Ref, - makeSymbol "deref" "" "" Deref, - makeSymbol "with" "" "" With + makeSymbol "let" "is used to introduce local variables." "(let [var-name expression]\n body-with-var-defined)" Let, + makeSymbol "break" "is used to break out of loops." "(while true\n (break))" Break, + makeSymbol "if" "is used for conditional expressions." "(if conditional\n then-branch\n else-branch)" If, + makeSymbol "match" "is used for matching on sumtypes." "(match expression-returing-a-sumtype\n (Constructor value) (something-with value)\n _ \"wildcard\")" (Match MatchValue), + makeSymbol "match-ref" "is used for matching, like `match`, but takes references." "(match-ref expression-sumtype-ref\n (Constructor value-ref) value-ref\n _ \"wildcard\")" (Match MatchRef), + makeSymbol "set!" "is used to rebind a variable." "(set! var new-value)" SetBang, + makeSymbol "the" "is used to annotating expressions." "(the Type expression)" The, + makeSymbol "ref" "is used to take references. Long form of `&expression`." "(ref expression)" Ref, + makeSymbol "deref" "is used to call references. Long form of `~expression`." "(deref expression)" Deref, + makeSymbol "with" "makes modules available locally. Like `use`, but not global." "(with Module expression-with-module)" With ] ++ [("Array", Binder emptyMeta (XObj (Mod arrayModule E.empty) Nothing Nothing)) | not noArray] ++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule E.empty) Nothing Nothing))] From da25a255e99223b3d0158edede861b5f93a9f69d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Wed, 3 Nov 2021 08:09:26 +0000 Subject: [PATCH 07/59] feat: Adds flag to always output C id with headerparse (#1353) Adds -c|--emitcname flag to headerparse to always emit the C identifier in `register` definitions (useful when the register will be in a module). Fixes a bug where the kebab case flag would not output C identifiers making the emitted C identifiers not match with the ones in the headers. Adds docs entry about headerparse in CInterop doc. Makes headerparse emit `CChar` instead of `Char` when encountering a signature containing `char`. --- docs/CInterop.md | 37 +++++++++++++++++++++++++++++++++++++ headerparse/Main.hs | 25 ++++++++++++++----------- src/Types.hs | 2 ++ src/TypesToC.hs | 1 + 4 files changed, 54 insertions(+), 11 deletions(-) diff --git a/docs/CInterop.md b/docs/CInterop.md index 94251602e..17581a80f 100644 --- a/docs/CInterop.md +++ b/docs/CInterop.md @@ -16,6 +16,7 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide. - [`preproc`](#unsafe-preproc) - [Registering Types](#register-types) - [Callbacks](#callbacks) +- [Headerparse](#headerparse) ## How Carp generates identifiers @@ -558,3 +559,39 @@ it is the responsibility of the caller to ensure the operation is safe. It is also important to ensure the lifetime of the `Ptr` doesn't not exceed the lifetime of the function/env it represents. +## Headerparse + +`headerparse` is a Haskell script to aid in writing C bindings by parsing a C +header and generating `register` and `register-type` for you. It resides in the +`./headersparse` folder in Carp source repo and can be used in the following +way: + +```sh +stack runhaskell ./headerparse/Main.hs -- ../path/to/c/header.h +``` + +The script accepts the following flags: + +* `[-p|--prefixtoremove thePrefix]` Removes a prefix from the C identifiers +* `[-f|--kebabcase]` Converts identifiers to kebab-case +* `[-c|--emitcname]` Always emit the C identifier name after the binding + +### Example + +Invoking the script on this C header: + +```sh +stack runhaskell ./headerparse/Main.hs -- -p "MyModule_" -f ../path/to/aheader.h +``` + +```c +// aheader.h +bool MyModule_runThisFile(const char *file); +``` + +Will output the following: + +```clojure +(register run-this-file (λ [(Ptr CChar)] Bool) "MyModule_runThisFile") +``` + diff --git a/headerparse/Main.hs b/headerparse/Main.hs index d9211d7c3..1e4f74bba 100644 --- a/headerparse/Main.hs +++ b/headerparse/Main.hs @@ -16,6 +16,7 @@ import Util data Args = Args { prefixToRemove :: String, kebabCase :: Bool, + emitCName :: Bool, sourcePath :: String } deriving (Show) @@ -25,6 +26,7 @@ parseArgs = Args <$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "") <*> switch (long "kebabcase" <> short 'f') + <*> switch (long "emitcname" <> short 'c') <*> argument str (metavar "FILE") main = do @@ -43,13 +45,14 @@ main = do source (prefixToRemove parsedArgs) (kebabCase parsedArgs) + (emitCName parsedArgs) ) ) ) else print parsedArgs -parseHeaderFile :: FilePath -> String -> String -> Bool -> [XObj] -parseHeaderFile path src prefix kebab = +parseHeaderFile :: FilePath -> String -> String -> Bool -> Bool -> [XObj] +parseHeaderFile path src prefix kebab cName = case Parsec.runParser cSyntax () path src of Left err -> error (show err) Right ok -> concat ok @@ -77,11 +80,11 @@ parseHeaderFile path src prefix kebab = Nothing -> let tyXObj = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing - in pure (createRegisterForm name tyXObj prefix False) + in pure (createRegisterForm name tyXObj prefix False cName) Just args -> let argsTy = genTypes (length args) tyXObj = toFnTypeXObj argsTy ("a", 0) - in pure (createRegisterForm name tyXObj prefix False) + in pure (createRegisterForm name tyXObj prefix False cName) where argList = do _ <- Parsec.char '(' @@ -128,7 +131,7 @@ parseHeaderFile path src prefix kebab = Parsec.char ';' Parsec.many (Parsec.noneOf "\n") let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2) - pure (createRegisterForm name tyXObj prefix kebab) + pure (createRegisterForm name tyXObj prefix kebab cName) voidArg :: Parsec.Parsec String () [(String, Int)] voidArg = do _ <- Parsec.string "(void)" @@ -163,8 +166,8 @@ parseHeaderFile path src prefix kebab = --pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)] -createRegisterForm :: String -> XObj -> String -> Bool -> [XObj] -createRegisterForm name tyXObj prefix kebab = +createRegisterForm :: String -> XObj -> String -> Bool -> Bool -> [XObj] +createRegisterForm name tyXObj prefix kebab cName = let carpName = (if kebab then (toKebab . lowerFirst) else id) (if prefix == "" then name else removePrefix prefix name) @@ -175,9 +178,9 @@ createRegisterForm name tyXObj prefix kebab = (XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing), tyXObj ] - ++ if prefix == "" - then [] - else [(XObj (Str emitName) Nothing Nothing)] + ++ if (prefix /= "") || kebab || cName + then [(XObj (Str emitName) Nothing Nothing)] + else [] ) ) Nothing @@ -202,7 +205,7 @@ toTypeXObj typeString = (XObj (Sym (SymPath [] (show (cTypeToCarpType typeString))) Symbol) Nothing Nothing) cTypeToCarpType :: (String, Int) -> Ty -cTypeToCarpType ("char", 0) = CharTy +cTypeToCarpType ("char", 0) = CCharTy cTypeToCarpType ("int", 0) = IntTy cTypeToCarpType ("bool", 0) = BoolTy cTypeToCarpType ("long", 0) = LongTy diff --git a/src/Types.hs b/src/Types.hs index 319d2389e..61cf8e698 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -53,6 +53,7 @@ data Ty | StringTy | PatternTy | CharTy + | CCharTy | FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime | VarTy String | UnitTy @@ -171,6 +172,7 @@ instance Show Ty where show StringTy = "String" show PatternTy = "Pattern" show CharTy = "Char" + show CCharTy = "CChar" show (FuncTy argTys retTy StaticLifetimeTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")" show (FuncTy argTys retTy lt) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ " " ++ show lt ++ ")" show (VarTy t) = t diff --git a/src/TypesToC.hs b/src/TypesToC.hs index 6fc4778a2..2e719beae 100644 --- a/src/TypesToC.hs +++ b/src/TypesToC.hs @@ -39,6 +39,7 @@ tyToCManglePtr _ ty = f ty f StringTy = "String" f PatternTy = "Pattern" f CharTy = "Char" + f CCharTy = "CChar" f UnitTy = "void" f (VarTy x) = x f (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy From b62a05f91fa59757fe7499a72a8e66b7f008be84 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Sat, 6 Nov 2021 06:24:17 -0400 Subject: [PATCH 08/59] feat: add bytes->hex-string (#1354) --- core/Binary.carp | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/core/Binary.carp b/core/Binary.carp index 289094244..d64b928af 100644 --- a/core/Binary.carp +++ b/core/Binary.carp @@ -326,4 +326,52 @@ (defn int64-seq->bytes [order is] (let [f (fn [i] (int64->bytes order @i))] (Array.copy-map &f is))) + + (defn to-hex-str [b] + (let [hi (Byte.bit-and b (from-int 0xF0)) + lo (Byte.bit-shift-left b (from-int 4)) + nib-one (case hi + (from-int 0x00) @"0" + (from-int 0x10) @"1" + (from-int 0x20) @"2" + (from-int 0x30) @"3" + (from-int 0x40) @"4" + (from-int 0x50) @"5" + (from-int 0x60) @"6" + (from-int 0x70) @"7" + (from-int 0x80) @"8" + (from-int 0x90) @"9" + (from-int 0xA0) @"A" + (from-int 0xB0) @"B" + (from-int 0xC0) @"C" + (from-int 0xD0) @"D" + (from-int 0xE0) @"E" + (from-int 0xF0) @"F" + @"FATAL ERROR IN BIT LAND! ALL IS LOST") + nib-two (case lo + (from-int 0x00) @"0" + (from-int 0x10) @"1" + (from-int 0x20) @"2" + (from-int 0x30) @"3" + (from-int 0x40) @"4" + (from-int 0x50) @"5" + (from-int 0x60) @"6" + (from-int 0x70) @"7" + (from-int 0x80) @"8" + (from-int 0x90) @"9" + (from-int 0xA0) @"A" + (from-int 0xB0) @"B" + (from-int 0xC0) @"C" + (from-int 0xD0) @"D" + (from-int 0xE0) @"E" + (from-int 0xF0) @"F" + @"FATAL ERROR IN BIT LAND! ALL IS LOST")] + (String.concat &[nib-one nib-two]))) + + (doc bytes->hex-string + "Converts an array of bytes to a string of its hexadecimal representation") + (sig bytes->hex-string (Fn [(Ref (Array Byte) q)] String)) + (defn bytes->hex-string [bs] + (let [f (fn [b] (to-hex-str @b))] + (String.join " " &(Array.copy-map &f bs)))) ) From 70ec6d46d4c636c39dc4d47dc7732421a30a0b3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Wed, 17 Nov 2021 16:12:41 +0100 Subject: [PATCH 09/59] fix: Ignore clang nitpick --- app/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/app/Main.hs b/app/Main.hs index cd298c7c9..79b15d21d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,6 +36,7 @@ defaultProject = "-Wall", "-Werror", "-Wno-unused-variable", + "-Wno-unused-but-set-variable", "-Wno-self-assign" ], projectLibFlags = case platform of From a7e1115d4cab8fe38b8cbb9e176c2a06d4a1dacd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Fri, 19 Nov 2021 19:57:14 +0100 Subject: [PATCH 10/59] Revert "fix: Ignore clang nitpick" This reverts commit 70ec6d46d4c636c39dc4d47dc7732421a30a0b3f. --- app/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 79b15d21d..cd298c7c9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,7 +36,6 @@ defaultProject = "-Wall", "-Werror", "-Wno-unused-variable", - "-Wno-unused-but-set-variable", "-Wno-self-assign" ], projectLibFlags = case platform of From 380945bf320b193e171f04898e599f2ffce84bb7 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Tue, 30 Nov 2021 04:35:22 -0500 Subject: [PATCH 11/59] feat: add box type (#1358) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * feat: add box templates and box type This commit adds an implementation of Boxes, memory manged heap allocated values. Boxes are implemented as C pointers, with no additional structure but are treated as structs in Carp. To facilitate this, we need to add them as a clause to our special type emissions (TypesToC) as they'd otherwise be emitted like other struct types. Co-authored-by: Veit Heller * fix: slight memory management fix for Box Make sure we free the box! * test: add tests for box (including memory checks) * Revert "fix: Ignore clang nitpick" This reverts commit 70ec6d46d4c636c39dc4d47dc7732421a30a0b3f. * fix: update example/functor.carp Now that a builtin type named Box exists, the definitions in this file cause a conflict. I've renamed the "Box" type in the functor example to remove the conflict. * feat: add Box.peek Box.peek allows users to transform a reference to a box into a a reference to the box's contained value. The returned reference will have the same lifetime as the box. This function allows callers to manipulate the value in a box without re-allocation, for example: ```clojure (deftype Num [val Int]) (let-do [box (Box.init (Num.init 0))] (Num.set-val! (Box.peek &box) 1) @(Num.val (Box.peek &box))) ``` This commit also includes tests for Box.peek. Co-authored-by: TimDeve Co-authored-by: Veit Heller Co-authored-by: Erik Svedäng Co-authored-by: TimDeve --- CarpHask.cabal | 1 + core/Box.carp | 5 + core/Core.carp | 1 + examples/functor.carp | 16 +-- src/BoxTemplates.hs | 237 ++++++++++++++++++++++++++++++++++++++++++ src/StartingEnv.hs | 32 +++++- src/TypesToC.hs | 1 + test/box.carp | 24 +++++ test/memory.carp | 10 ++ 9 files changed, 315 insertions(+), 12 deletions(-) create mode 100644 core/Box.carp create mode 100644 src/BoxTemplates.hs create mode 100644 test/box.carp diff --git a/CarpHask.cabal b/CarpHask.cabal index 8f1a6fe67..5ca26b43b 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -18,6 +18,7 @@ library hs-source-dirs: src exposed-modules: ArrayTemplates, AssignTypes, + BoxTemplates, ColorText, Commands, Concretize, diff --git a/core/Box.carp b/core/Box.carp new file mode 100644 index 000000000..7122ee60b --- /dev/null +++ b/core/Box.carp @@ -0,0 +1,5 @@ +(defmodule Box + (defn = [box-a box-b] + (= (Box.unbox @box-a) (Box.unbox @box-b))) + (implements = =) +) diff --git a/core/Core.carp b/core/Core.carp index 9d9d532dd..00a4c86db 100644 --- a/core/Core.carp +++ b/core/Core.carp @@ -18,6 +18,7 @@ (load-once "Interfaces.carp") (load-once "Blitable.carp") (load-once "Bool.carp") +(load-once "Box.carp") (load-once "Macros.carp") (load-once "BoolExtras.carp") (load-once "List.carp") diff --git a/examples/functor.carp b/examples/functor.carp index 1ef6e8d3f..27d83ee1a 100644 --- a/examples/functor.carp +++ b/examples/functor.carp @@ -10,14 +10,14 @@ (implements fmap ArrayExtension.fmap) ) -(deftype (Box a) [x a]) +(deftype (MyBox a) [x a]) -(defmodule Box - (defn fmap [f box] (let [new-x (~f @(Box.x &box))] - (Box.set-x box new-x))) - (implements fmap Box.fmap)) +(defmodule MyBox + (defn fmap [f box] (let [new-x (~f @(MyBox.x &box))] + (MyBox.set-x box new-x))) + (implements fmap MyBox.fmap)) -(use Box) +(use MyBox) (use ArrayExtension) ;; TODO: This function currently concretizes to the type of the first (f *) it @@ -29,8 +29,8 @@ (defn main [] (do - (println &(str @(Box.x &(fmap &Int.inc (Box.init 100))))) - (println &(str @(Box.x &(Box.fmap &inc (Box.init 100))))) + (println &(str @(MyBox.x &(fmap &Int.inc (MyBox.init 100))))) + (println &(str @(MyBox.x &(MyBox.fmap &inc (MyBox.init 100))))) (println &(str &(ArrayExtension.fmap &inc [10 20 30 40 50]))) (println &(str &(fmap &Int.inc [10 20 30 40 50]))) (println &(Array.str &(fmap &Int.inc [10 20 30 40 50]))) diff --git a/src/BoxTemplates.hs b/src/BoxTemplates.hs new file mode 100644 index 000000000..2065df37e --- /dev/null +++ b/src/BoxTemplates.hs @@ -0,0 +1,237 @@ +-- | Module BoxTemplates defines Carp's Box type, a container for managed, +-- heap allocated objects. +module BoxTemplates + ( delete, + str, + prn, + BoxTemplates.init, + copy, + unbox, + peek, + ) +where + +import Concretize +import Obj +import Polymorphism +import Template +import ToTemplate +import Types + +boxTy :: Ty +boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")] + +-- | Defines a template for initializing Boxes. +init :: (String, Binder) +init = let path = SymPath ["Box"] "init" + t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy + docs = "Initializes a box pointing to value t." + decl = templateLiteral "$t* $NAME ($t t)" + body = const (multilineTemplate + [ "$DECL {", + " $t* instance;", + " instance = CARP_MALLOC(sizeof($t));", + " *instance = t;", + " return instance;", + "}" + ]) + deps = const [] + template = TemplateCreator $ \_ _ -> Template t decl body deps + in defineTypeParameterizedTemplate template path t docs + +-- | Defines a template for converting a boxed value to a local value. +unbox :: (String, Binder) +unbox = let path = SymPath ["Box"] "unbox" + t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy + docs = "Converts a boxed value to a reference to the value and delete the box." + decl = templateLiteral "$t $NAME($t* box)" + body = const (multilineTemplate + [ "$DECL {", + " $t local;", + " local = *box;", + " CARP_FREE(box);", + " return local;", + "}" + ]) + deps = const [] + template = TemplateCreator $ \_ _ -> Template t decl body deps + in defineTypeParameterizedTemplate template path t docs + +-- | Defines a template for getting a reference to the value stored in a box without performing an additional allocation. +peek :: (String, Binder) +peek = let path = SymPath ["Box"] "peek" + t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy + docs = "Returns a reference to the value stored in a box without performing an additional allocation." + decl = templateLiteral "$t* $NAME($t** box_ref)" + body = const (multilineTemplate + [ "$DECL {", + " return *box_ref;", + "}" + ]) + deps = const [] + template = TemplateCreator $ \_ _ -> Template t decl body deps + in defineTypeParameterizedTemplate template path t docs + +-- | Defines a template for copying a box. The copy will also be heap allocated. +copy :: (String, Binder) +copy = + let path = SymPath ["Box"] "copy" + t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy + docs = "Copies a box." + decl = (templateLiteral "$t* $NAME ($t** box)") + template = TemplateCreator $ + \tenv env -> + Template + t + decl + ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + innerCopy tenv env inner + ) + ( \(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + depsForCopyFunc tenv env inner + ++ depsForDeleteFunc tenv env boxType + ) + in defineTypeParameterizedTemplate template path t docs + where + innerCopy typeEnv valEnv innerTy = + case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of + FunctionFound functionFullName -> + multilineTemplate + [ "$DECL {", + " $t* copy;", + " copy = CARP_MALLOC(sizeof($t));", + " *copy = " ++ functionFullName ++ "(*box);", + " return copy;", + "}" + ] + _ -> + multilineTemplate + [ "$DECL {", + " $t* copy;", + " copy = CARP_MALLOC(sizeof($t));", + " *copy = *box;", + " return copy;", + "}" + ] + +-- | Defines a template for deleting a box. +delete :: (String, Binder) +delete = + let path = SymPath ["Box"] "delete" + t = FuncTy [boxTy] UnitTy StaticLifetimeTy + docs = "Deletes a box, freeing its associated memory." + decl = (templateLiteral "void $NAME ($t* box)") + templateCreator = TemplateCreator $ + \tenv env -> + Template + t + decl + ( \(FuncTy [bTy] UnitTy _) -> + multilineTemplate + [ "$DECL {", + " " ++ innerDelete tenv env bTy, + "}" + ] + ) + ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) -> + depsForDeleteFunc tenv env insideType + ) + in defineTypeParameterizedTemplate templateCreator path t docs + where + innerDelete :: TypeEnv -> Env -> Ty -> String + innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) = + case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of + FunctionFound functionFullName -> + " " ++ functionFullName ++ "(*box);\n" + ++ " CARP_FREE(box);" + FunctionNotFound msg -> error msg + FunctionIgnored -> + " /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n" + ++ " CARP_FREE(box);" + innerDelete _ _ _ = "" + +-- | Defines a template for printing a box as a string. +prn :: (String, Binder) +prn = + let path = SymPath ["Box"] "prn" + t = FuncTy [boxTy] StringTy StaticLifetimeTy + docs = "Returns a string representation of a Box." + decl = templateLiteral "String $NAME ($t* box)" + templateCreator = + TemplateCreator $ + ( \tenv env -> + Template + t + decl + ( \(FuncTy [boxT] StringTy _) -> + multilineTemplate + [ "$DECL {", + " if(!box){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + innerStr tenv env boxT, + " return buffer;", + "}" + ] + ) + ( \(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) -> + depsForPrnFunc tenv env inner + ) + ) + in defineTypeParameterizedTemplate templateCreator path t docs + +-- | Defines a template for printing a reference to a box as a string. +str :: (String, Binder) +str = + let path = SymPath ["Box"] "str" + t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy + docs = "Returns a string representation of a Box." + templateCreator = + TemplateCreator $ + ( \tenv env -> + Template + t + (templateLiteral "String $NAME ($t** box)") + ( \(FuncTy [RefTy boxT _] StringTy _) -> + multilineTemplate + [ "$DECL {", + " if(!box){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + innerStr tenv env boxT, + " return buffer;", + "}" + ] + ) + ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) -> + depsForPrnFunc tenv env inner + ) + ) + in defineTypeParameterizedTemplate templateCreator path t docs + +innerStr :: TypeEnv -> Env -> Ty -> String +innerStr tenv env (StructTy _ [t]) = + case findFunctionForMemberIncludePrimitives tenv env "prn" (typesStrFunctionType tenv env (RefTy t StaticLifetimeTy)) ("Inside box.", t) of + FunctionFound functionFullName -> + unlines + [ " char* temp = " ++ functionFullName ++ "(*box);", + " int size = snprintf(NULL, 0, \"(Box %s)\", temp);", + " String buffer = CARP_MALLOC(size);", + " sprintf(buffer, \"(Box %s)\", temp);", + " if(temp) {", + " CARP_FREE(temp);", + " temp = NULL;", + " }" + ] + FunctionNotFound _ -> + unlines + [ " String buffer = CARP_MALLOC(14);", + " sprintf(buffer, \"(Box unknown)\");" + ] + FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n" +innerStr _ _ _ = "" + diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index cf0498ecc..fc890a526 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -14,6 +14,7 @@ import qualified StaticArrayTemplates import Template import ToTemplate import Types +import qualified BoxTemplates -- | These modules will be loaded in order before any other code is evaluated. coreModules :: String -> [String] @@ -108,6 +109,28 @@ templatePointerCopy = ) (const []) +-- | The Box module contains functions for working with Boxes (pointers to heap allocated values). +boxModule :: Env +boxModule = + Env + { envBindings = bindings, + envParent = Nothing, + envModuleName = Just "Box", + envUseModules = Set.empty, + envMode = ExternalEnv, + envFunctionNestingLevel = 0 + } + where + bindings = Map.fromList + [ BoxTemplates.init, + BoxTemplates.unbox, + BoxTemplates.peek, + BoxTemplates.delete, + BoxTemplates.copy, + BoxTemplates.prn, + BoxTemplates.str + ] + maxArity :: Int maxArity = 9 @@ -506,6 +529,7 @@ startingGlobalEnv noArray = ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))] ++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))] ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))] + ++ [("Box", Binder emptyMeta (XObj (Mod boxModule E.empty) Nothing Nothing))] -- | The type environment (containing deftypes and interfaces) before any code is run. startingTypeEnv :: Env @@ -524,22 +548,22 @@ startingTypeEnv = [ interfaceBinder "delete" (FuncTy [VarTy "a"] UnitTy StaticLifetimeTy) - ([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete"] ++ registerFunctionFunctionsWithInterface "delete") + ([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete", SymPath ["Box"] "delete"] ++ registerFunctionFunctionsWithInterface "delete") builtInSymbolInfo, interfaceBinder "copy" (FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy) - ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy") + ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy", SymPath ["Box"] "copy"] ++ registerFunctionFunctionsWithInterface "copy") builtInSymbolInfo, interfaceBinder "str" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy) - (SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "str") + (SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : SymPath ["Box"] "str" : registerFunctionFunctionsWithInterface "str") builtInSymbolInfo, interfaceBinder "prn" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy) - (SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is) + (SymPath ["StaticArray"] "str" : SymPath ["Box"] "prn" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is) builtInSymbolInfo ] builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1) diff --git a/src/TypesToC.hs b/src/TypesToC.hs index 2e719beae..ef2c6fd7c 100644 --- a/src/TypesToC.hs +++ b/src/TypesToC.hs @@ -26,6 +26,7 @@ tyToCRawFunctionPtrFix FuncTy {} = "void*" tyToCRawFunctionPtrFix t = tyToCManglePtr False t tyToCManglePtr :: Bool -> Ty -> String +tyToCManglePtr b (StructTy (ConcreteNameTy (SymPath [] "Box")) [t]) = tyToCManglePtr b t ++ (if b then mangle "*" else "*") tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*") tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*") tyToCManglePtr _ ty = f ty diff --git a/test/box.carp b/test/box.carp new file mode 100644 index 000000000..32a0ea1de --- /dev/null +++ b/test/box.carp @@ -0,0 +1,24 @@ +(load "Test.carp") +(use Test) + +(Debug.sanitize-addresses) + +(deftype Num [val Int]) + +(deftest test + (assert-equal test + &(Box.init @"foo") + &(Box.init @"foo") + "init works as expected") + (assert-equal test + 2 + (Box.unbox (Box.init 2)) + "unbox works as expected") + (assert-equal test + 1 + (let-do [box (Box.init (Num.init 0))] + (Num.set-val! (Box.peek &box) 1) + @(Num.val (Box.peek &box))) + "peek works as expected" + ) +) diff --git a/test/memory.carp b/test/memory.carp index 5353ecc4f..d3aaaca8c 100644 --- a/test/memory.carp +++ b/test/memory.carp @@ -484,6 +484,14 @@ _ ()) ) +(defn box-1 [] + (do (ignore (Box.unbox (Box.init 2))))) + +(defn box-2 [] + (let-do [box (Box.init @"foo") + crate @&box] + (ignore (Box.unbox box)))) + (deftest test (assert-no-leak test scope-1 "scope-1 does not leak") (assert-no-leak test scope-2 "scope-2 does not leak") @@ -558,4 +566,6 @@ (assert-no-leak test sumtype-10 "sumtype-10 does not leak") (assert-no-leak test sumtype-11 "sumtype-11 does not leak") (assert-no-leak test sumtype-12 "sumtype-12 does not leak") + (assert-no-leak test box-1 "box-1 does not leak") + (assert-no-leak test box-2 "box-2 does not leak") ) From 1175bb795b8147cb0b6f3b3b5426ad19ce3616da Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Sun, 12 Dec 2021 08:56:41 -0500 Subject: [PATCH 12/59] fix: permit registering types in modules (#1362) Historically, we did not support calling (register-type) within a module--while there were instances of such calls (even in our core library!) they were not properly handled in two ways: 1. They weren't added to the right place in the type environment. 2. Their corresponding emitted code wasn't correct. This commit enables registering types in modules by making a few fixes: 1. Fix the logic in environment mutations -- before, adding a type to an environment would result in traversing the environment chain incorrectly. This is now fixed (we traverse modules and retrieve a type environment only at the end of the traversal). 2. Fix the typedef emission for registered types--it previously emitted the C code for the type path, not for the type definition (it called pathToC not tyToC). This will now allow authors of wrapper libraries to add more structure to their Carp wrapper APIs. This commit also adds a test to check the behavior. --- src/Emit.hs | 2 +- src/Env.hs | 19 +++++++++++-------- src/Primitives.hs | 2 +- test/interop.carp | 17 +++++++++++++++++ test/interop.h | 9 +++++++++ 5 files changed, 39 insertions(+), 10 deletions(-) create mode 100644 test/interop.carp create mode 100644 test/interop.h diff --git a/src/Emit.hs b/src/Emit.hs index a2f2af381..508733814 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -921,7 +921,7 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) = XObj (ExternalType Nothing) _ _ : _ -> "" XObj (ExternalType (Just override)) _ _ : XObj (Sym path _) _ _ : _ -> - "typedef " ++ override ++ " " ++ pathToC path ++ ";" + "typedef " ++ override ++ " " ++ tyToC (StructTy (ConcreteNameTy path) []) ++ ";" XObj (Command _) _ _ : _ -> "" XObj (Primitive _) _ _ : _ -> diff --git a/src/Env.hs b/src/Env.hs index 3242c6ba4..866c7244c 100644 --- a/src/Env.hs +++ b/src/Env.hs @@ -374,15 +374,18 @@ mutate :: Environment e => (EnvironmentProducer e) -> e -> SymPath -> Binder -> mutate f e path binder = go path where go (SymPath [] name) = f e name binder + go (SymPath (p : []) name) = + do mod' <- getBinder e p + env' <- nextEnv (modality e) mod' + res <- mutate f (inj env') (SymPath [] name) binder + new' <- updateEnv (modality e) (prj res) mod' + addBinding e p new' go (SymPath (p : ps) name) = - getBinder e p - >>= \modu -> - nextEnv (modality e) modu - >>= \oldEnv -> - mutate f (inj oldEnv) (SymPath ps name) binder - >>= \result -> - updateEnv (modality e) (prj result) modu - >>= addBinding e p + do mod' <- getBinder e p + old <- nextEnv Values mod' + result <- mutate f (inj old) (SymPath ps name) binder + new' <- updateEnv Values (prj result) mod' + addBinding e p new' -- | Insert a binding into an environment at the given path. insert :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e diff --git a/src/Primitives.hs b/src/Primitives.hs index f789ac46a..90ae712d9 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -241,7 +241,7 @@ primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError) -- | Register an external type that has no fields. primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj) primitiveRegisterTypeWithoutFields ctx t override = do - let path = SymPath [] t + let path = SymPath (contextPath ctx) t typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy) -- TODO: Support registering types in modules case insertTypeBinder ctx (markQualified path) (toBinder typeDefinition) of diff --git a/test/interop.carp b/test/interop.carp new file mode 100644 index 000000000..d035b235b --- /dev/null +++ b/test/interop.carp @@ -0,0 +1,17 @@ +(relative-include "interop.h") + +(load "Test.carp") +(use Test) + +(defmodule Wrap + (register-type Nested "NESTED") + (register make-nested (Fn [] Wrap.Nested) "make_nested") + (register test-nested (Fn [Wrap.Nested] Int) "test_nested") +) + +(deftest test + (assert-equal test + &1 + &(Wrap.test-nested (Wrap.make-nested)) + "Types registered in modules are emitted correctly.") +) diff --git a/test/interop.h b/test/interop.h new file mode 100644 index 000000000..9fb4bba11 --- /dev/null +++ b/test/interop.h @@ -0,0 +1,9 @@ +typedef int NESTED; + +int test_nested(NESTED x) { + return x; +} + +int make_nested() { + return 1; +} From b3ae93bfc4371ea4a97adf3adf862044e2a7762a Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 16 Dec 2021 15:31:16 -0500 Subject: [PATCH 13/59] fix: ensure registered types with fields emit path (#1364) This fixes an issue where by types with fields registered in modules weren't emitted with their module paths. This makes the behavior between RegisterTypeWithoutFields and RegisterTypeWithFields the same. They both account for the current module path in which the type is registered and output the emitted typedef appropriately. This fix also eliminates the need for a workaround in core/Pattern.carp. We previously had to register MatchResult with an override because of the old behavior, but now the override is no longer needed (since MatchResult is defined as PatternMatchResult in its source header). The call (register MatchResult) within (defmodule Pattern) emits "PatternMatchResult" by default since we now account for module paths for registered types. --- core/Pattern.carp | 3 +-- src/Primitives.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/core/Pattern.carp b/core/Pattern.carp index 26bd95826..86c439146 100644 --- a/core/Pattern.carp +++ b/core/Pattern.carp @@ -4,8 +4,7 @@ as, Regular Expressions. [See the docs for more information](../LanguageGuide.html#patterns).") (defmodule Pattern - - (register-type MatchResult "PatternMatchResult" [start Int, end Int]) + (register-type MatchResult [start Int, end Int]) (defmodule MatchResult (defn ref-str [ref-matchres] (fmt "(MatchResult start=%d end=%d)" diff --git a/src/Primitives.hs b/src/Primitives.hs index 90ae712d9..72bc9e9af 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -269,7 +269,7 @@ primitiveRegisterTypeWithFields ctx x t override members = [ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")), lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn")) ] - path = SymPath [] t + path = SymPath (contextPath ctx) t preExistingModule = case lookupBinderInGlobalEnv ctx path of Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et) _ -> Nothing From d82e8a5a3f446da59aef917cb7e26fb8b466b4bb Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 20 Dec 2021 09:41:14 -0500 Subject: [PATCH 14/59] refactor: add type candidates and template generators (#1361) * refactor: add type candidates for validation This commit adds a new module and type, the TypeCandidate, which represents a potentially valid or invalid type. We use it as the input for both type validation routines and type binding generation. The type also allows us to unify the structure of sum types and product types in an xobj agnostic way, paving the way for future simplification of binding generation for type definitions. This commit also removes SumtypeCase.hs, since it's no longer needed. * refactor: add template generators; update type templates This commit builds on the TypeCandidate data structure further by providing "template generators" that work on candidates. Using generators, templates for type functions ("methods") can be written almost completely declaratively. Generators also remove some of the typical boilerplate involved in creating templates from lists of tokens and enable us to unify several of the generic and concrete templates for types. Generators can act on type candidates or their fields (for field-specific functions). In general, this approach makes the generation of type templates more structured. A type candidate now contains all the information a generator needs to create appropriate templates, thus it is a single and well-defined input for validation and generation of user defined types. This commit also updates the Deftype templates to use template generators. * refactor: use template generators for sumtype templates --- CarpHask.cabal | 3 +- src/Concretize.hs | 54 +- src/Deftype.hs | 994 ++++++++---------- src/SumtypeCase.hs | 41 - src/Sumtypes.hs | 756 ++++++------- src/TemplateGenerator.hs | 97 ++ src/TypeCandidate.hs | 174 +++ src/TypeError.hs | 5 + src/Validate.hs | 124 +-- ...type_var_not_in_scope.carp.output.expected | 2 +- ...type_var_not_in_scope.carp.output.expected | 2 +- 11 files changed, 1193 insertions(+), 1059 deletions(-) delete mode 100644 src/SumtypeCase.hs create mode 100644 src/TemplateGenerator.hs create mode 100644 src/TypeCandidate.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index 5ca26b43b..061af81bc 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -56,11 +56,12 @@ library StartingEnv, StaticArrayTemplates, StructUtils, - SumtypeCase, Sumtypes, SymPath, Template, + TemplateGenerator, ToTemplate, + TypeCandidate, TypeError, TypePredicates, Types, diff --git a/src/Concretize.hs b/src/Concretize.hs index 7b4a5462d..4d224c099 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -19,6 +19,7 @@ module Concretize tokensForCopy, memberCopy, replaceGenericTypeSymbolsOnMembers, + replaceGenericTypeSymbolsOnFields, ) where @@ -41,7 +42,6 @@ import Obj import Polymorphism import Reify import qualified Set -import SumtypeCase import ToTemplate import TypeError import TypePredicates @@ -50,6 +50,7 @@ import TypesToC import Util import Validate import Prelude hiding (lookup) +import qualified TypeCandidate as TC data Level = Toplevel | Inside @@ -612,7 +613,9 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs - validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers + sname = getStructName originalStructTy + candidate <- TC.mkStructCandidate sname renamedOrig typeEnv env validMembers (getPathFromStructName sname) + validateType (TC.setRestriction candidate TC.AllowAny) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = XObj @@ -640,29 +643,24 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 - in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of - Left e -> error (show e) - Right mappings -> - let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases - concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases - deps = mapM (depsForCase typeEnv env) concretelyTypedCases - in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation. - Left err -> Left err - Right _ -> - case deps of - Right okDeps -> - Right $ - XObj - ( Lst - ( XObj (DefSumtype genericStructTy) Nothing Nothing : - XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : - concretelyTypedCases - ) - ) - (Just dummyInfo) - (Just TypeTy) : - concat okDeps - Left err -> Left err + nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases + fixLeft l = replaceLeft (FailedToInstantiateGenericType originalStructTy) l + in do mappings <- fixLeft $ solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] + let concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases + sname = (getStructName originalStructTy) + deps <- mapM (depsForCase typeEnv env) concretelyTypedCases + candidate <- TC.mkSumtypeCandidate sname renamedOrig typeEnv env concretelyTypedCases (getPathFromStructName sname) + validateType (TC.setRestriction candidate TC.AllowAny) + pure (XObj + ( Lst + ( XObj (DefSumtype genericStructTy) Nothing Nothing : + XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : + concretelyTypedCases + ) + ) + (Just dummyInfo) + (Just TypeTy) : + concat deps) instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype" -- Resolves dependencies for sumtype cases. @@ -677,6 +675,12 @@ depsForCase typeEnv env (XObj (Lst [_, XObj (Arr members) _ _]) _ _) = members depsForCase _ _ x = Left (InvalidSumtypeCase x) +-- | Replace instances of generic types in type candidate field definitions. +replaceGenericTypeSymbolsOnFields :: Map.Map String Ty -> [TC.TypeField] -> [TC.TypeField] +replaceGenericTypeSymbolsOnFields ms fields = map go fields + where go (TC.StructField name t) = (TC.StructField name (replaceTyVars ms t)) + go (TC.SumField name ts) = (TC.SumField name (map (replaceTyVars ms) ts)) + replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj] replaceGenericTypeSymbolsOnMembers mappings memberXObjs = concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs) diff --git a/src/Deftype.hs b/src/Deftype.hs index 1ab08b362..47d784348 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} module Deftype ( moduleForDeftype, moduleForDeftypeInContext, bindingsForRegisteredType, + fieldArg, memberArg, ) where @@ -24,6 +25,8 @@ import Types import TypesToC import Util import Validate +import qualified TypeCandidate as TC +import TemplateGenerator as TG {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -56,9 +59,6 @@ moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) - -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'. - -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc. - insidePath = pathStrings ++ [typeName] initmembers = case rest of -- ANSI C does not allow empty structs. We add a dummy member here to account for this. -- Note that we *don't* add this member for external types--we leave those definitions up to the user. @@ -66,18 +66,17 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i [(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)] _ -> rest in do - validateMemberCases typeEnv env typeVariables rest - let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest - okInit <- binderForInit insidePath structTy initmembers - (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" - (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" - (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest - (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest - let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers - moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs + let mems = case initmembers of + [(XObj (Arr ms)_ _)] -> ms + _ -> [] + -- Check that this is a valid type definition. + candidate <- TC.mkStructCandidate typeName typeVariables typeEnv env mems pathStrings + validateType candidate + -- Generate standard function bindings for the type. + (funcs, deps) <- generateTypeBindings candidate + -- Add the type and bindings to the environment. + let moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) - deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps pure (typeName, typeModuleXObj, deps) -- | Will generate getters/setters/updaters when registering EXTERNAL types. @@ -87,28 +86,48 @@ bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> M bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) - insidePath = pathStrings ++ [typeName] in do - validateMemberCases typeEnv env [] rest - let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) [] - (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest - okInit <- binderForInit insidePath structTy rest - (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" - (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" + let mems = case rest of + [(XObj (Arr ms)_ _)] -> ms + _ -> [] + -- Check that this is a valid type definition. + candidate <- TC.mkStructCandidate typeName [] typeEnv env mems pathStrings + validateType candidate + -- Generate function bindings for the registered type. + (binders, deps) <- templatesForMembers candidate + okInit <- binderForInit candidate + (okStr, strDeps) <- binderForStrOrPrn "str" candidate + (okPrn, _) <- binderForStrOrPrn "prn" candidate + -- Add the type and bindings to the environment. let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders) typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) pure (typeName, typeModuleXObj, deps ++ strDeps) +-------------------------------------------------------------------------------- +-- Binding creators + +-- | Generate the standard set of functions for a new type. +generateTypeBindings :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) +generateTypeBindings candidate = + do (okMembers, membersDeps) <- templatesForMembers candidate + okInit <- binderForInit candidate + (okStr, strDeps) <- binderForStrOrPrn "str" candidate + (okPrn, _) <- binderForStrOrPrn "prn" candidate + (okDelete, deleteDeps) <- binderForDelete candidate + (okCopy, copyDeps) <- binderForCopy candidate + pure ((okInit : okStr : okPrn : okDelete : okCopy : okMembers), + (deleteDeps ++ membersDeps ++ copyDeps ++ strDeps)) + -- | Generate all the templates for ALL the member variables in a deftype declaration. -templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj]) -templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] = - let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath structTy) (pairwise membersXobjs) +templatesForMembers :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) +templatesForMembers candidate = + let bindersAndDeps = concatMap (templatesForSingleMember candidate) (TC.getFields candidate) in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps) -templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type definition)." -- | Generate the templates for a single member in a deftype declaration. -templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])] -templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _) (nameXObj, typeXObj) = +templatesForSingleMember :: TC.TypeCandidate -> TC.TypeField -> [((String, Binder), [XObj])] +templatesForSingleMember _ (TC.StructField "__dummy" _) = [] +templatesForSingleMember candidate field@(TC.StructField _ t) = case t of -- Unit member types are special since we do not represent them in emitted c. -- Instead, members of type Unit are executed for their side effects and silently omitted @@ -126,329 +145,303 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _ (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) where - Just t = xobjToTy typeXObj - memberName = getName nameXObj + p = TC.toType candidate + memberName = TC.fieldName field binders getterSig setterSig mutatorSig updaterSig = - [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."), - if isTypeGeneric t - then (templateGenericSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."), - if isTypeGeneric t - then (templateGenericMutatingSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "` in place."), - instanceBinderWithDeps - (SymPath insidePath ("update-" ++ memberName)) - updaterSig - (templateUpdater (mangle memberName) t) - ("updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`.") + [ getter getterSig, + setter setterSig, + mutator mutatorSig, + updater updaterSig ] -templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember" - --- | The template for getters of a deftype. -templateGetter :: String -> Ty -> Template -templateGetter _ UnitTy = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($(Ref p) p)")) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const $ toTemplate "$DECL { return; }\n") - (const []) -templateGetter member memberTy = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) - (const (toTemplate "$t $NAME($(Ref p) p)")) - ( \(FuncTy [_] retTy _) -> - case retTy of - (RefTy UnitTy _) -> toTemplate " $DECL { void* ptr = NULL; return ptr; }\n" - _ -> - let fixForVoidStarMembers = - if isFunctionType memberTy && not (isTypeGeneric memberTy) - then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")" - else "" - in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n") - ) - (const []) - --- | The template for setters of a concrete deftype. -templateSetter :: TypeEnv -> Env -> String -> Ty -> Template -templateSetter _ _ _ UnitTy = - Template - (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p)")) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const (toTemplate "$DECL { return p; }\n")) - (const []) -templateSetter typeEnv env memberName memberTy = - let callToDelete = memberDeletion typeEnv env (memberName, memberTy) - in Template - (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p, $t newValue)")) - ( const - ( toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " p." ++ memberName ++ " = newValue;", - " return p;", - "}\n" - ] - ) - ) - ) - ( \_ -> - if - | isManaged typeEnv env memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) - | isFunctionType memberTy -> [defineFunctionTypeAlias memberTy] - | otherwise -> [] - ) - --- | The template for setters of a generic deftype. -templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) -templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName = - defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs - where - path = SymPath pathStrings ("set-" ++ memberName) - t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy - docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [_, memberTy] _ _) -> - case memberTy of - UnitTy -> toTemplate "$p $NAME($p p)" - _ -> toTemplate "$p $NAME($p p, $t newValue)" - ) - ( \(FuncTy [_, memberTy] _ _) -> - let callToDelete = memberDeletion typeEnv env (memberName, memberTy) - in case memberTy of - UnitTy -> toTemplate "$DECL { return p; }\n" - _ -> - toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " p." ++ memberName ++ " = newValue;", - " return p;", - "}\n" - ] - ) - ) - ( \(FuncTy [_, memberTy] _ _) -> - if isManaged typeEnv env memberTy - then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) - else [] - ) -templateGenericSetter _ _ _ _ = error "templategenericsetter" - --- | The template for mutating setters of a deftype. -templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template -templateMutatingSetter _ _ _ UnitTy = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($p* pRef)")) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const (toTemplate "$DECL { return; }\n")) - (const []) -templateMutatingSetter typeEnv env memberName memberTy = - let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) - in Template - (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($p* pRef, $t newValue)")) - ( const - ( toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " pRef->" ++ memberName ++ " = newValue;", - "}\n" - ] - ) - ) - ) - (const []) - --- | The template for mutating setters of a generic deftype. -templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) -templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName = - defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs - where - path = SymPath pathStrings ("set-" ++ memberName ++ "!") - t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy - docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "` in place." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [_, memberTy] _ _) -> - case memberTy of - UnitTy -> toTemplate "void $NAME($p* pRef)" - _ -> toTemplate "void $NAME($p* pRef, $t newValue)" - ) - ( \(FuncTy [_, memberTy] _ _) -> - let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) - in case memberTy of - UnitTy -> toTemplate "$DECL { return; }\n" - _ -> - toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " pRef->" ++ memberName ++ " = newValue;", - "}\n" - ] - ) - ) - ( \(FuncTy [_, memberTy] _ _) -> - if isManaged typeEnv env memberTy - then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) - else [] - ) -templateGenericMutatingSetter _ _ _ _ = error "templategenericmutatingsetter" - --- | The template for updater functions of a deftype. --- | (allows changing a variable by passing an transformation function). -templateUpdater :: String -> Ty -> Template -templateUpdater _ UnitTy = - Template - (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const (toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n"))) - ( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> - [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] - ) -templateUpdater member _ = - Template - (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t) - ( const - ( toTemplate - ( unlines - [ "$DECL {", - " p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";", - " return p;", - "}\n" - ] - ) - ) - ) - ( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> - if isTypeGeneric fRetTy - then [] - else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] - ) + + getter :: Ty -> ((String, Binder), [XObj]) + getter sig = let doc = "gets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) (TC.fieldName field) + temp = TG.generateConcreteFieldTemplate candidate field getterGenerator + in instanceBinderWithDeps binderP binderT temp doc + + setter :: Ty -> ((String, Binder), [XObj]) + setter sig = let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field)) + concrete = (TG.generateConcreteFieldTemplate candidate field setterGenerator) + generic = (TG.generateGenericFieldTemplate candidate field setterGenerator) + in if isTypeGeneric t + then (defineTypeParameterizedTemplate generic binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT concrete doc + + mutator :: Ty -> ((String, Binder), [XObj]) + mutator sig = let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "` in place." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field) ++ "!") + concrete = (TG.generateConcreteFieldTemplate candidate field mutatorGenerator) + generic = (TG.generateGenericFieldTemplate candidate field mutatorGenerator) + in if isTypeGeneric t + then (defineTypeParameterizedTemplate generic binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT concrete doc + + updater :: Ty -> ((String, Binder), [XObj]) + updater sig = let doc = "updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) ("update-" ++ (TC.fieldName field)) + temp = TG.generateConcreteFieldTemplate candidate field updateGenerator + in instanceBinderWithDeps binderP binderT temp doc +templatesForSingleMember _ _ = error "templatesforsinglemember" -- | Helper function to create the binder for the 'init' template. -binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) -binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = +binderForInit :: TC.TypeCandidate -> Either TypeError (String, Binder) +binderForInit candidate = -- Remove the __dummy field from the members array to ensure we can call the initializer with no arguments. -- See the implementation of moduleForDeftype for more details. - let nodummy = case membersXObjs of - [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)] -> [] - _ -> membersXObjs - in if isTypeGeneric structTy - then Right (genericInit StackAlloc insidePath structTy membersXObjs) - else - Right $ - instanceBinder - (SymPath insidePath "init") - -- don't include the dummy field in arg lists - (FuncTy (initArgListTypes nodummy) structTy StaticLifetimeTy) - (concreteInit StackAlloc structTy membersXObjs) - ("creates a `" ++ show structTy ++ "`.") -binderForInit _ _ _ = error "binderforinit" - --- | Generate a list of types from a deftype declaration. -initArgListTypes :: [XObj] -> [Ty] -initArgListTypes xobjs = - map (fromJust . xobjToTy . snd) (pairwise xobjs) - --- | The template for the 'init' and 'new' functions for a concrete deftype. -concreteInit :: AllocationMode -> Ty -> [XObj] -> Template -concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - Template - (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (unitless memberPairs))) ++ ")") - ) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - in tokensForInit allocationMode (show originalStructTy) correctedMembers - ) - (\FuncTy {} -> []) - where - unitless = remove (isUnit . snd) - nodummy = remove (isDummy . fst) - isDummy "__dummy" = True - isDummy _ = False -concreteInit _ _ _ = error "concreteinit" - --- | The template for the 'init' and 'new' functions for a generic deftype. -genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) -genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - defineTypeParameterizedTemplate templateCreator path t docs + let nodummy = remove ((=="__dummy") . TC.fieldName) (TC.getFields candidate) + doc = "creates a `" ++ (TC.getName candidate) ++ "`." + binderP = (SymPath (TC.getFullPath candidate) "init") + binderT = (FuncTy (concatMap TC.fieldTypes nodummy) (TC.toType candidate) StaticLifetimeTy) + gen = (initGenerator StackAlloc) + in if isTypeGeneric (TC.toType candidate) + then Right (defineTypeParameterizedTemplate (generateGenericTypeTemplate candidate gen) binderP binderT doc) + else Right (instanceBinder binderP binderT (generateConcreteTypeTemplate candidate gen) doc) + +-- | Helper function to create the binder for the 'str' template. +binderForStrOrPrn :: String -> TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +binderForStrOrPrn strOrPrn candidate = + let binderP = SymPath (TC.getFullPath candidate) strOrPrn + binderT = (FuncTy [RefTy (TC.toType candidate) (VarTy "q")] StringTy StaticLifetimeTy) + doc = "converts a `" ++ TC.getName candidate ++ "` to a string." + in if isTypeGeneric (TC.toType candidate) + then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, []) + else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc + +-- | Helper function to create the binder for the 'delete' template. +binderForDelete :: TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +binderForDelete candidate = + let doc = "deletes a `" ++ TC.getName candidate ++ "`. Should usually not be called manually." + binderP = SymPath (TC.getFullPath candidate) "delete" + binderT = FuncTy [(TC.toType candidate)] UnitTy StaticLifetimeTy + in if isTypeGeneric (TC.toType candidate) + then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate deleteGenerator) binderP binderT doc, []) + else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate deleteGenerator) doc + +-- | Helper function to create the binder for the 'copy' template. +binderForCopy :: TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +binderForCopy candidate = + let doc = "copies a `" ++ TC.getName candidate ++ "`." + binderP = SymPath (TC.getFullPath candidate) "copy" + binderT = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] (TC.toType candidate) StaticLifetimeTy + in if isTypeGeneric (TC.toType candidate) + then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate copyGenerator) binderP binderT doc, []) + else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate copyGenerator) doc + +-------------------------------------------------------------------------------- +-- Template generators +-- +-- These functions declaratively specify how C code should be emitted for a +-- type. Binder helpers use these to generate an appropriate template for a +-- bound function name for the type. + +-- | getterGenerator returns a template generator for struct property getters. +getterGenerator :: TG.TemplateGenerator TC.TypeField +getterGenerator = TG.mkTemplateGenerator tgen decl body deps where - path = SymPath pathStrings "init" - t = FuncTy (map snd (nodummy (memberXObjsToPairs membersXObjs))) originalStructTy StaticLifetimeTy - docs = "creates a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (remove (isUnit . snd) memberPairs))) ++ ")") - ) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - in tokensForInit allocationMode (show originalStructTy) correctedMembers - ) - ( \(FuncTy _ concreteStructTy _) -> - case concretizeType typeEnv env concreteStructTy of - Left _ -> [] - Right ok -> ok - ) - nodummy = remove (isDummy . fst) - isDummy "__dummy" = True - isDummy _ = False -genericInit _ _ _ _ = error "genericinit" - -tokensForInit :: AllocationMode -> String -> [XObj] -> [Token] -tokensForInit allocationMode typeName membersXObjs = - toTemplate $ - unlines - [ "$DECL {", - case allocationMode of - StackAlloc -> case unitless of - -- if this is truly a memberless struct, init it to 0; - -- This can happen, e.g. in cases where *all* members of the struct are of type Unit. - -- Since we do not generate members for Unit types. - [] -> " $p instance = {};" - _ -> " $p instance;" - HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", - assignments membersXObjs, - " return instance;", - "}" - ] + tgen :: TG.TypeGenerator TC.TypeField + tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl TG.GeneratorArg{instanceT=UnitTy} = toTemplate "void $NAME($(Ref p) p)" + decl _ = toTemplate "$t $NAME($(Ref p) p)" + + body :: TG.TokenGenerator TC.TypeField + body TG.GeneratorArg{value=(TC.StructField _ UnitTy)} = toTemplate "$DECL { return; }\n" + body TG.GeneratorArg{instanceT=(FuncTy _ (RefTy UnitTy _) _)} = toTemplate " $DECL { void* ptr = NULL; return ptr; }\n" + body TG.GeneratorArg{value=(TC.StructField name ty)} = + let fixForVoidStarMembers = + if isFunctionType ty && not (isTypeGeneric ty) + then "(" ++ tyToCLambdaFix (RefTy ty (VarTy "q")) ++ ")" + else "" + in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ (mangle name) ++ ")); }\n") + body TG.GeneratorArg{} = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps = const [] + +-- | setterGenerator returns a template generator for struct property setters. +setterGenerator :: TG.TemplateGenerator TC.TypeField +setterGenerator = TG.mkTemplateGenerator tgen decl body deps + where tgen :: TG.TypeGenerator TC.TypeField + tgen _ = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$p $NAME($p p)" + decl _ = toTemplate "$p $NAME($p p, $t newValue)" + + body :: TG.TokenGenerator TC.TypeField + body GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return p; }\n" + body GeneratorArg{tenv,env,instanceT= (FuncTy [_, ty] _ _),value=(TC.StructField name _)} = + multilineTemplate [ + "$DECL {", + memberDeletion tenv env (name, ty), + " p." ++ (mangle name) ++ " = newValue;", + " return p;", + "}\n" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps GeneratorArg{tenv, env, TG.instanceT=(FuncTy [_, ty] _ _)} + | isManaged tenv env ty = depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty) + | isFunctionType ty = [defineFunctionTypeAlias ty] + | otherwise = [] + deps _ = [] + +-- | mutatorGenerator returns a template generator for struct property setters (in-place). +mutatorGenerator :: TG.TemplateGenerator TC.TypeField +mutatorGenerator = TG.mkTemplateGenerator tgen decl body deps + where tgen :: TG.TypeGenerator TC.TypeField + tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "void $NAME($p* pRef)" + decl _ = toTemplate "void $NAME($p* pRef, $t newValue)" + + body :: TG.TokenGenerator TC.TypeField + -- Execution of the action passed as an argument is handled in Emit.hs. + body GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return; }\n" + body GeneratorArg{tenv, env, instanceT=(FuncTy [_, ty] _ _), value=(TC.StructField name _)} = + multilineTemplate [ + "$DECL {", + memberRefDeletion tenv env (name, ty), + " pRef->" ++ mangle name ++ " = newValue;", + "}\n" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps GeneratorArg{tenv, env, instanceT=(FuncTy [_, ty] _ _)} = + if isManaged tenv env ty + then depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty) + else [] + deps _ = [] + +-- | Returns a template generator for updating struct properties with a function. +updateGenerator :: TG.TemplateGenerator TC.TypeField +updateGenerator = TG.mkTemplateGenerator tgen decl body deps + where tgen :: TG.TypeGenerator TC.TypeField + tgen GeneratorArg{value=(TC.StructField _ UnitTy)} = + (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) + tgen _ = (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl _ = toTemplate "$p $NAME($p p, Lambda *updater)" -- Lambda used to be (Fn [t] t) + + body :: TG.TokenGenerator TC.TypeField + body GeneratorArg{value=(TC.StructField _ UnitTy)} = + toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n") + body GeneratorArg{value=(TC.StructField name _)} = multilineTemplate [ + "$DECL {", + " p." ++ mangle name ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ mangle name] ++ ";", + " return p;", + "}\n" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps GeneratorArg{instanceT=(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _)} = + if isTypeGeneric fRetTy + then [] + else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] + deps _ = [] + +-- | Returns a template generator for a types initializer function. +initGenerator :: AllocationMode -> TG.TemplateGenerator TC.TypeCandidate +initGenerator alloc = TG.mkTemplateGenerator genT decl body deps + where genT :: TG.TypeGenerator TC.TypeCandidate + genT GeneratorArg{value} = + (FuncTy (concatMap TC.fieldTypes (TC.getFields value)) (VarTy "p") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg{originalT, instanceT=(FuncTy _ concreteT _), value} = + let mappings = unifySignatures originalT concreteT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + cFields = remove isUnitT (remove isDummy concreteFields) + in toTemplate ("$p $NAME(" ++ joinWithComma (map fieldArg cFields) ++ ")") + decl _ = toTemplate "/* template error! */" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{originalT, instanceT=(FuncTy _ concreteT _), value} = + let mappings = unifySignatures originalT concreteT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in tokensForInit alloc (show originalT) (remove isUnitT concreteFields) + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, instanceT=(FuncTy _ concreteT _)} = + case concretizeType tenv env concreteT of + Left _ -> [] + Right ok -> ok + deps _ = [] + + tokensForInit :: AllocationMode -> String -> [TC.TypeField] -> [Token] + -- if this is truly a memberless struct, init it to 0; + -- This can happen in cases where *all* members of the struct are of type Unit. + -- Since we do not generate members for Unit types. + tokensForInit StackAlloc _ [] = + multilineTemplate [ + "$DECL {", + " $p instance = {};", + " return instance;", + "}" + ] + tokensForInit StackAlloc _ fields = + multilineTemplate [ + "$DECL {", + " $p instance;", + assignments fields, + " return instance;", + "}" + ] + tokensForInit HeapAlloc typeName fields = + multilineTemplate [ + "$DECL {", + " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", + assignments fields, + " return instance;", + "}" + ] + + assignments :: [TC.TypeField] -> String + assignments [] = "" + assignments fields = joinLines $ fmap (memberAssignment alloc) fields + + isDummy field = TC.fieldName field == "__dummy" + isUnitT (TC.StructField _ UnitTy) = True + isUnitT _ = False + +-- | Generate C code for assigning to a member variable. +-- Needs to know if the instance is a pointer or stack variable. +-- Also handles the special dummy member we add for empty structs to be ANSI C compatible. +memberAssignment :: AllocationMode -> TC.TypeField -> String +memberAssignment allocationMode field = + case (TC.fieldName field) of + "__dummy" -> " instance" ++ sep ++ mangle name ++ " = " ++ "0" ++ ";" + _ -> " instance" ++ sep ++ mangle name ++ " = " ++ mangle name ++ ";" where - assignments [] = "" - assignments _ = go unitless - where - go [] = "" - go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs - unitless = remove (isUnit . snd) (memberXObjsToPairs membersXObjs) + name = (TC.fieldName field) + sep = case allocationMode of + StackAlloc -> "." + HeapAlloc -> "->" -- | Creates the C code for an arg to the init function. -- | i.e. "(deftype A [x Int])" will generate "int x" which -- | will be used in the init function like this: "A_init(int x)" +fieldArg :: TC.TypeField -> String +fieldArg (TC.StructField name ty) = + tyToCLambdaFix (templatizeTy ty) ++ " " ++ mangle name +fieldArg _ = "" + +---- | Creates the C code for an arg to the init function. +---- | i.e. "(deftype A [x Int])" will generate "int x" which +---- | will be used in the init function like this: "A_init(int x)" memberArg :: (String, Ty) -> String memberArg (memberName, memberTy) = tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName @@ -462,207 +455,130 @@ templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt) templatizeTy (PointerTy t) = PointerTy (templatizeTy t) templatizeTy t = t --- | Helper function to create the binder for the 'str' template. -binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj]) -binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] strOrPrn = - if isTypeGeneric structTy - then Right (genericStr insidePath structTy membersXObjs strOrPrn, []) - else - Right - ( instanceBinderWithDeps - (SymPath insidePath strOrPrn) - (FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy) - (concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn) - ("converts a `" ++ show structTy ++ "` to a string.") - ) -binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn" - --- | The template for the 'str' function for a concrete deftype. -concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template -concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy name) _) memberPairs _ = - Template - (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) - (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") - ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - tokensForStr typeEnv env (show name) memberPairs concreteStructTy - ) - ( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) - (remove isFullyGenericType (map snd memberPairs)) - ) -concreteStr _ _ _ _ _ = error "concretestr" - --- | The template for the 'str' function for a generic deftype. -genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder) -genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy name) _) membersXObjs strOrPrn = - defineTypeParameterizedTemplate templateCreator path t docs - where - path = SymPath pathStrings strOrPrn - t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy - docs = "converts a `" ++ show originalStructTy ++ "` to a string." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [RefTy concreteStructTy _] StringTy _) -> - toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)" - ) - ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in tokensForStr typeEnv env (show name) memberPairs concreteStructTy - ) - ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) - (remove isFullyGenericType (map snd memberPairs)) - ++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)] - ) -genericStr _ _ _ _ = error "genericstr" - -tokensForStr :: TypeEnv -> Env -> String -> [(String, Ty)] -> Ty -> [Token] -tokensForStr typeEnv env typeName memberPairs concreteStructTy = - toTemplate $ - unlines - [ "$DECL {", - " // convert members to String here:", - " String temp = NULL;", - " int tempsize = 0;", - " (void)tempsize; // that way we remove the occasional unused warning ", - calculateStructStrSize typeEnv env memberPairs concreteStructTy, - " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - "", - " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");", - " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n", - joinLines (map (memberPrn typeEnv env) memberPairs), - " bufferPtr--;", - " sprintf(bufferPtr, \")\");", - " return buffer;", - "}" - ] +-- | Returns a template generator for a type's str and prn functions. +strGenerator :: TG.TemplateGenerator TC.TypeCandidate +strGenerator = TG.mkTemplateGenerator genT decl body deps + where genT :: TG.TypeGenerator TC.TypeCandidate + genT GeneratorArg{originalT} = + FuncTy [RefTy originalT (VarTy "q")] StringTy StaticLifetimeTy --- | Figure out how big the string needed for the string representation of the struct has to be. -calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String -calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) = - " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n" - ++ unlines (map (memberPrnSize typeEnv env) members) -calculateStructStrSize _ _ _ _ = error "calculatestructstrsize" + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg{instanceT=(FuncTy [RefTy structT _] _ _)} = + toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)" + decl _ = toTemplate "/* template error! */" --- | Generate C code for assigning to a member variable. --- Needs to know if the instance is a pointer or stack variable. --- Also handles the special dummy member we add for empty structs to be ANSI C compatible. -memberAssignment :: AllocationMode -> String -> String -memberAssignment allocationMode memberName = - case memberName of - "__dummy" -> " instance" ++ sep ++ memberName ++ " = " ++ "0" ++ ";" - _ -> " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" - where - sep = case allocationMode of - StackAlloc -> "." - HeapAlloc -> "->" + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in tokensForStr tenv env (getStructName structT) concreteFields structT + body _ = toTemplate "/* template error! */" --- | Helper function to create the binder for the 'delete' template. -binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) -binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = - if isTypeGeneric structTy - then Right (genericDelete insidePath structTy membersXObjs, []) - else - Right - ( instanceBinderWithDeps - (SymPath insidePath "delete") - (FuncTy [structTy] UnitTy StaticLifetimeTy) - (concreteDelete typeEnv env (memberXObjsToPairs membersXObjs)) - ("deletes a `" ++ show structTy ++ "`.") - ) -binderForDelete _ _ _ _ _ = error "binderfordelete" - --- | The template for the 'delete' function of a generic deftype. -genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder) -genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs - where - path = SymPath pathStrings "delete" - t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy - docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "void $NAME($p p)")) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in ( toTemplate $ - unlines - [ "$DECL {", - joinLines (map (memberDeletion typeEnv env) memberPairs), - "}" - ] - ) - ) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv env) (map snd memberPairs)) - ) -genericDelete _ _ _ = error "genericdelete" + deps :: TG.DepenGenerator TC.TypeCandidate + deps arg@GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in concatMap + (depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env) + (remove isFullyGenericType (concatMap TC.fieldTypes concreteFields)) + ++ [defineFunctionTypeAlias (instanceT arg) | not (isTypeGeneric structT)] + deps _ = [] --- | Helper function to create the binder for the 'copy' template. -binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) -binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = - if isTypeGeneric structTy - then Right (genericCopy insidePath structTy membersXObjs, []) - else - Right - ( instanceBinderWithDeps - (SymPath insidePath "copy") - (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) - (concreteCopy typeEnv env (memberXObjsToPairs membersXObjs)) - ("copies a `" ++ show structTy ++ "`.") - ) -binderForCopy _ _ _ _ _ = error "binderforcopy" - --- | The template for the 'copy' function of a generic deftype. -genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder) -genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs - where - path = SymPath pathStrings "copy" - t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy - docs = "copies the `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "$p $NAME($p* pRef)")) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in tokensForCopy typeEnv env memberPairs - ) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (map snd memberPairs)) - ) -genericCopy _ _ _ = error "genericcopy" + tokensForStr :: TypeEnv -> Env -> String -> [TC.TypeField] -> Ty -> [Token] + tokensForStr typeEnv env typeName fields concreteStructTy = + let members = remove ((=="__dummy"). fst) (map fieldToTuple fields) + in multilineTemplate + [ "$DECL {", + " // convert members to String here:", + " String temp = NULL;", + " int tempsize = 0;", + " (void)tempsize; // that way we remove the occasional unused warning ", + calculateStructStrSize typeEnv env members concreteStructTy, + " String buffer = CARP_MALLOC(size);", + " String bufferPtr = buffer;", + "", + " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");", + " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n", + joinLines (map (memberPrn typeEnv env) members), + " bufferPtr--;", + " sprintf(bufferPtr, \")\");", + " return buffer;", + "}" + ] + + -- | Figure out how big the string needed for the string representation of the struct has to be. + calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String + calculateStructStrSize typeEnv env fields s = + " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n" + ++ unlines (map (memberPrnSize typeEnv env) fields) + +-- | Returns a template generator for a type's delete function. +deleteGenerator :: TG.TemplateGenerator TC.TypeCandidate +deleteGenerator = TG.mkTemplateGenerator genT decl body deps + where genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy + + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "void $NAME($p p)" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [structT] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + members = map fieldToTuple concreteFields + in multilineTemplate [ + "$DECL {", + joinLines (map (memberDeletion tenv env) members), + "}" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [structT] _ _), value} + | isTypeGeneric structT = [] + | otherwise = let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in concatMap + (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) + (filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields)) + deps _ = [] + +-- | Returns a template generator for a type's copy function. +copyGenerator :: TG.TemplateGenerator TC.TypeCandidate +copyGenerator = TG.mkTemplateGenerator genT decl body deps + where genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy + + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "$p $NAME($p* pRef)" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + members = map fieldToTuple concreteFields + in tokensForCopy tenv env members + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} + | isTypeGeneric structT = [] + | otherwise = let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + members = map fieldToTuple concreteFields + in concatMap + (depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType) + (filter (isManaged tenv env) (map snd members)) + deps _ = [] + +-------------------------------------------------------------------------------- +-- Utilities + +-- | Converts a type field to a tuple of its name and primary type. +-- This is a convenience function for interop with the old tuple based +-- functions for handling type members and it should eventually be deprecated +-- once these functions work on type fields directly. +fieldToTuple :: TC.TypeField -> (String, Ty) +fieldToTuple (TC.StructField name t) = (mangle name, t) +fieldToTuple (TC.SumField name (t:_)) = (mangle name, t) -- note: not actually used. +fieldToTuple (TC.SumField name []) = (mangle name, TypeTy) -- note: not actually used. diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs deleted file mode 100644 index 43cf45c88..000000000 --- a/src/SumtypeCase.hs +++ /dev/null @@ -1,41 +0,0 @@ -module SumtypeCase where - -import Obj -import TypeError -import Types -import Validate - -data SumtypeCase = SumtypeCase - { caseName :: String, - caseTys :: [Ty] - } - deriving (Show, Eq) - -toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase] -toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars) - -toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase -toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = - let tys = map xobjToTy tyXObjs - in case sequence tys of - Nothing -> - Left (InvalidSumtypeCase x) - Just okTys -> - let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv globalEnv typeVars t x) okTys - in case sequence validated of - Left e -> - Left e - Right _ -> - Right $ - SumtypeCase - { caseName = name, - caseTys = okTys - } -toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) = - Right $ - SumtypeCase - { caseName = name, - caseTys = [] - } -toCase _ _ _ _ x = - Left (InvalidSumtypeCase x) diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 113b00970..60252cbc0 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -1,4 +1,11 @@ -module Sumtypes where +{-# LANGUAGE NamedFieldPuns #-} + +module Sumtypes + ( + moduleForSumtypeInContext, + moduleForSumtype + ) +where import Concretize import Context @@ -9,7 +16,6 @@ import Info import Managed import Obj import StructUtils -import SumtypeCase import Template import ToTemplate import TypeError @@ -17,14 +23,14 @@ import TypePredicates import Types import TypesToC import Util -import Validate (TypeVarRestriction (..)) +import Validate +import qualified TypeCandidate as TC +import TemplateGenerator as TG -getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase -getCase cases caseNameToFind = - case filter (\c -> caseName c == caseNameToFind) cases of - found : _ -> Just found - [] -> Nothing +-------------------------------------------------------------------------------- +-- Public +-- | Creates a module and generates standard functions for a user defined sum type in the given context. moduleForSumtypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) moduleForSumtypeInContext ctx name vars members info = let global = contextGlobalEnv ctx @@ -47,402 +53,396 @@ moduleForSumtypeInContext ctx name vars members info = ) in moduleForSumtype inner types global path name vars members info previous +-- | Creates a module and generates standard functions for a user defined sum type. moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj]) moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) - insidePath = pathStrings ++ [typeName] in do - let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest - okIniters <- initers insidePath structTy cases - okTag <- binderForTag insidePath structTy - (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str" - (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn" - okDelete <- binderForDelete typeEnv env insidePath structTy cases - (okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases - okMemberDeps <- memberDeps typeEnv env cases - let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag]) + -- validate the definition + candidate <- TC.mkSumtypeCandidate typeName typeVariables typeEnv env rest pathStrings + validateType candidate + -- produce standard function bindings + (binders, deps) <- generateBinders candidate + -- insert the module into the environment + let moduleEnvWithBindings = addListOfBindings moduleValueEnv binders typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) - pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps) - -memberDeps :: TypeEnv -> Env -> [SumtypeCase] -> Either TypeError [XObj] -memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap caseTys cases)) - -replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase] + pure (typeName, typeModuleXObj, deps) + +-------------------------------------------------------------------------------- +-- Private + +-- | Generate standard binders for the sumtype +generateBinders :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) +generateBinders candidate = + do okIniters <- initers candidate + okTag <- binderForTag candidate + (okStr, okStrDeps) <- binderForStrOrPrn candidate "str" + (okPrn, _) <- binderForStrOrPrn candidate "prn" + okDelete <- binderForDelete candidate + (okCopy, okCopyDeps) <- binderForCopy candidate + okMemberDeps <- memberDeps (TC.getTypeEnv candidate) (TC.getValueEnv candidate) (TC.getFields candidate) + let binders = okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag] + deps = okMemberDeps ++ okCopyDeps ++ okStrDeps + pure (binders, deps) + +-- | Gets concrete dependencies for sum type fields. +memberDeps :: TypeEnv -> Env -> [TC.TypeField] -> Either TypeError [XObj] +memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap TC.fieldTypes cases)) + +-- | Replace type variables in a sum type case +replaceGenericTypesOnCases :: TypeMappings -> [TC.TypeField] -> [TC.TypeField] replaceGenericTypesOnCases mappings = map replaceOnCase where - replaceOnCase theCase = - let newTys = map (replaceTyVars mappings) (caseTys theCase) - in theCase {caseTys = newTys} - -initers :: [String] -> Ty -> [SumtypeCase] -> Either TypeError [(String, Binder)] -initers insidePath structTy = mapM (binderForCaseInit insidePath structTy) - -binderForCaseInit :: [String] -> Ty -> SumtypeCase -> Either TypeError (String, Binder) -binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase = - if isTypeGeneric structTy - then Right (genericCaseInit StackAlloc insidePath structTy sumtypeCase) - else Right (concreteCaseInit StackAlloc insidePath structTy sumtypeCase) -binderForCaseInit _ _ _ = error "binderforcaseinit" - -concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder) -concreteCaseInit allocationMode insidePath structTy sumtypeCase = - instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc + replaceOnCase :: TC.TypeField -> TC.TypeField + replaceOnCase (TC.SumField name tys) = + let newTys = map (replaceTyVars mappings) tys + in (TC.SumField name newTys) + replaceOnCase field = field + +-------------------------------------------------------------------------------- +-- Binding generators + +type BinderGen = TC.TypeCandidate -> Either TypeError (String, Binder) +type BinderGenDeps = TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +type MultiBinderGen = TC.TypeCandidate -> Either TypeError [(String, Binder)] + +-- | Generate initializer bindings for each sum type case. +initers :: MultiBinderGen +initers candidate = mapM binderForCaseInit (TC.getFields candidate) where - doc = "creates a `" ++ caseName sumtypeCase ++ "`." - template = - Template - (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures structTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")") - ) - (const (tokensForCaseInit allocationMode structTy sumtypeCase)) - (\FuncTy {} -> []) - -genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder) -genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase = - defineTypeParameterizedTemplate templateCreator path t docs + -- | Generate an initializer binding for a single sum type case, using the given candidate. + binderForCaseInit :: TC.TypeField -> Either TypeError (String, Binder) + binderForCaseInit sumtypeCase = + if isTypeGeneric (TC.toType candidate) + then Right (genericCaseInit StackAlloc sumtypeCase) + else Right (concreteCaseInit StackAlloc sumtypeCase) + + -- | Generates a template for a concrete (no type variables) sum type case. + concreteCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder) + concreteCaseInit alloc field@(TC.SumField fieldname tys) = + let concrete = (TC.toType candidate) + doc = "creates a `" ++ fieldname ++ "`." + t = (FuncTy tys (VarTy "p") StaticLifetimeTy) + decl = (const (tokensForCaseInitDecl concrete concrete field)) + body = (const (tokensForCaseInit alloc concrete concrete field)) + deps = (const []) + temp = Template t decl body deps + binderPath = SymPath (TC.getFullPath candidate) fieldname + in instanceBinder binderPath (FuncTy tys concrete StaticLifetimeTy) temp doc + concreteCaseInit _ _ = error "concreteCaseInit" + + -- | Generates a template for a generic (has type variables) sum type case. + genericCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder) + genericCaseInit alloc field@(TC.SumField fieldname tys) = + let generic = (TC.toType candidate) + docs = "creates a `" ++ fieldname ++ "`." + ft = FuncTy tys generic StaticLifetimeTy + binderPath = SymPath (TC.getFullPath candidate) fieldname + t = (FuncTy tys (VarTy "p") StaticLifetimeTy) + decl = \(FuncTy _ concrete _) -> tokensForCaseInitDecl generic concrete field + body = \(FuncTy _ concrete _) -> tokensForCaseInit alloc generic concrete field + deps tenv env = \(FuncTy _ concrete _) -> either (const []) id (concretizeType tenv env concrete) + temp = TemplateCreator $ \tenv env -> Template t decl body (deps tenv env) + in defineTypeParameterizedTemplate temp binderPath ft docs + genericCaseInit _ _ = error "genericCaseInit" + +-- | Generates a binder for retrieving the tag of a sum type. +binderForTag :: BinderGen +binderForTag candidate = + let t = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] IntTy StaticLifetimeTy + decl = \(FuncTy [RefTy struct _] _ _) -> toTemplate $ proto struct + body = \(FuncTy [RefTy struct _] _ _) -> toTemplate $ proto struct ++ " { return p->_tag; }" + deps = const [] + path' = SymPath (TC.getFullPath candidate) "get-tag" + temp = Template t decl body deps + doc = "Gets the tag from a `" ++ (TC.getName candidate) ++ "`." + in Right (instanceBinder path' t temp doc) where - path = SymPath pathStrings (caseName sumtypeCase) - t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy - docs = "creates a `" ++ caseName sumtypeCase ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")" - ) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys}) - ) - ( \(FuncTy _ concreteStructTy _) -> - case concretizeType typeEnv env concreteStructTy of - Left _ -> [] - Right ok -> ok - ) + proto :: Ty -> String + proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)" -tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token] -tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase = - toTemplate $ - unlines - [ "$DECL {", - case allocationMode of - StackAlloc -> " $p instance;" - HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));", - joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless, - " instance._tag = " ++ tagName sumTy correctedName ++ ";", - " return instance;", - "}" - ] +-- | Helper function to create the binder for the 'str' template. +binderForStrOrPrn :: TC.TypeCandidate -> String -> Either TypeError ((String, Binder), [XObj]) +binderForStrOrPrn candidate strOrPrn = + let doc = "converts a `" ++ (getStructName (TC.toType candidate)) ++ "` to a string." + binderP = SymPath (TC.getFullPath candidate) strOrPrn + binderT = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] StringTy StaticLifetimeTy + in Right $ + if isTypeGeneric (TC.toType candidate) + then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc where - correctedName = caseName sumtypeCase - unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase) -tokensForCaseInit _ _ _ = error "tokensforcaseinit" + strGenerator :: TG.TemplateGenerator TC.TypeCandidate + strGenerator = TG.mkTemplateGenerator genT decl body deps -caseMemberAssignment :: AllocationMode -> String -> String -> String -caseMemberAssignment allocationMode caseNm memberName = - " instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";" - where - sep = case allocationMode of - StackAlloc -> ".u." - HeapAlloc -> "->u." + genT :: TG.TypeGenerator TC.TypeCandidate + genT GeneratorArg{value} = + FuncTy [RefTy (TC.toType value) (VarTy "q")] StringTy StaticLifetimeTy -binderForTag :: [String] -> Ty -> Either TypeError (String, Binder) -binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) = - Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc - where - path = SymPath insidePath "get-tag" - template = - Template - (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) - (\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy) - (\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }") - (const []) - proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)" - doc = "Gets the tag from a `" ++ show originalStructTy ++ "`." -binderForTag _ _ = error "binderfortag" + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg{instanceT=(FuncTy [RefTy ty _] _ _)} = + toTemplate $ "String $NAME(" ++ tyToCLambdaFix ty ++ " *p)" + decl _ = toTemplate "/* template error! */" --- | Helper function to create the binder for the 'str' template. -binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> Either TypeError ((String, Binder), [XObj]) -binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases strOrPrn = - Right $ - if isTypeGeneric structTy - then (genericStr insidePath structTy cases strOrPrn, []) - else concreteStr typeEnv env insidePath structTy cases strOrPrn -binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn" - --- | The template for the 'str' function for a concrete deftype. -concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj]) -concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn = - instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc - where - doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string." - template = - Template - (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) - (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") - ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - tokensForStr typeEnv env (show name) cases concreteStructTy - ) - ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) - (remove isFullyGenericType (concatMap caseTys cases)) - ) -concreteStr _ _ _ _ _ _ = error "concretestr" - --- | The template for the 'str' function for a generic deftype. -genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder) -genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn = - defineTypeParameterizedTemplate templateCreator path t docs - where - path = SymPath insidePath strOrPrn - t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy - docs = "stringifies a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [RefTy concreteStructTy _] StringTy _) -> - toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)" - ) - ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in tokensForStr typeEnv env (show name) correctedCases concreteStructTy - ) - ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - tys = remove isFullyGenericType (concatMap caseTys correctedCases) - in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) tys - ++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)] - ) -genericStr _ _ _ _ = error "genericstr" - -tokensForStr :: TypeEnv -> Env -> String -> [SumtypeCase] -> Ty -> [Token] -tokensForStr typeEnv env _ cases concreteStructTy = - toTemplate $ - unlines - [ "$DECL {", - " // convert members to String here:", - " String temp = NULL;", - " int tempsize = 0;", - " (void)tempsize; // that way we remove the occasional unused warning ", - calculateStructStrSize typeEnv env cases concreteStructTy, - " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - "", - concatMap (strCase typeEnv env concreteStructTy) cases, - " return buffer;", - "}" - ] + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + tokensForStr tenv env originalT ty (TC.getFields value) + body _ = toTemplate "/* template error! */" -namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String) -namesFromCase theCase concreteStructTy = - let name = caseName theCase - in (name, caseTys theCase {caseTys = remove isUnit (caseTys theCase)}, tagName concreteStructTy name) - -strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String -strCase typeEnv env concreteStructTy@(StructTy _ _) theCase = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " if(p->_tag == " ++ correctedTagName ++ ") {", - " sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");", - " bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n", - joinLines $ memberPrn typeEnv env <$> unionMembers name tys, - " bufferPtr--;", - " sprintf(bufferPtr, \")\");", - " }" - ] -strCase _ _ _ _ = error "strcase" - --- | Figure out how big the string needed for the string representation of the struct has to be. -calculateStructStrSize :: TypeEnv -> Env -> [SumtypeCase] -> Ty -> String -calculateStructStrSize typeEnv env cases structTy@(StructTy (ConcreteNameTy _) _) = - " int size = 1;\n" - ++ concatMap (strSizeCase typeEnv env structTy) cases -calculateStructStrSize _ _ _ _ = error "calculatestructstrsize" - -strSizeCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String -strSizeCase typeEnv env concreteStructTy@(StructTy _ _) theCase = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " if(p->_tag == " ++ correctedTagName ++ ") {", - " size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");", - joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys, - " }" - ] -strSizeCase _ _ _ _ = error "strsizecase" + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + depsForStr tenv env originalT ty (TC.getFields value) + deps _ = [] -- | Helper function to create the binder for the 'delete' template. -binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError (String, Binder) -binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases = - Right $ - if isTypeGeneric structTy - then genericSumtypeDelete insidePath structTy cases - else concreteSumtypeDelete insidePath typeEnv env structTy cases -binderForDelete _ _ _ _ _ = error "binderfordelete" - --- | The template for the 'delete' function of a generic sumtype. -genericSumtypeDelete :: [String] -> Ty -> [SumtypeCase] -> (String, Binder) -genericSumtypeDelete pathStrings originalStructTy cases = - defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs +binderForDelete :: BinderGen +binderForDelete candidate = + let t = (TC.toType candidate) + doc = "deletes a `" ++ (getStructName t) ++ "`. This should usually not be called manually." + binderT = FuncTy [t] UnitTy StaticLifetimeTy + binderP = SymPath (TC.getFullPath candidate) "delete" + in Right $ + if isTypeGeneric t + then defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate generator) binderP binderT doc + else instanceBinder binderP binderT (TG.generateConcreteTypeTemplate candidate generator) doc where - path = SymPath pathStrings "delete" - t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy - docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "void $NAME($p p)")) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in ( toTemplate $ - unlines - [ "$DECL {", - concatMap (deleteCase typeEnv env concreteStructTy) (zip correctedCases (True : repeat False)), - "}" - ] - ) - ) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys correctedCases)) - ) + generator :: TG.TemplateGenerator TC.TypeCandidate + generator = TG.mkTemplateGenerator genT decl body deps --- | The template for the 'delete' function of a concrete sumtype -concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder) -concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases = - instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc - where - doc = "deletes a `" ++ (show structTy) ++ "`. This should usually not be called manually." - template = - Template - (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($p p)")) - ( const - ( toTemplate $ - unlines - [ "$DECL {", - concatMap (deleteCase typeEnv env structTy) (zip cases (True : repeat False)), - "}" - ] - ) - ) - ( \_ -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys cases)) - ) -concreteSumtypeDelete _ _ _ _ _ = error "concretesumtypedelete" - -deleteCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String -deleteCase typeEnv env concreteStructTy@(StructTy _ _) (theCase, isFirstCase) = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {", - joinLines $ memberDeletion typeEnv env <$> unionMembers name tys, - " }" - ] -deleteCase _ _ _ _ = error "deletecase" + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "void $NAME($p p)" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [ty] _ _), value} = + tokensForDeleteBody tenv env originalT ty (TC.getFields value) + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [ty] _ _), value} = + depsForDelete tenv env originalT ty (TC.getFields value) + deps _ = [] -- | Helper function to create the binder for the 'copy' template. -binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError ((String, Binder), [XObj]) -binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases = - Right $ - if isTypeGeneric structTy - then (genericSumtypeCopy insidePath structTy cases, []) - else concreteSumtypeCopy insidePath typeEnv env structTy cases -binderForCopy _ _ _ _ _ = error "binderforcopy" - --- | The template for the 'copy' function of a generic sumtype. -genericSumtypeCopy :: [String] -> Ty -> [SumtypeCase] -> (String, Binder) -genericSumtypeCopy pathStrings originalStructTy cases = - defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs +binderForCopy :: BinderGenDeps +binderForCopy candidate = + let t = TC.toType candidate + doc = "copies a `" ++ (TC.getName candidate) ++ "`." + binderT = FuncTy [RefTy t (VarTy "q")] t StaticLifetimeTy + binderP = SymPath (TC.getFullPath candidate) "copy" + in Right $ + if isTypeGeneric (TC.toType candidate) + then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate generator) binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate generator) doc where - path = SymPath pathStrings "copy" - t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy - docs = "copies a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "$p $NAME($p* pRef)")) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in tokensForSumtypeCopy typeEnv env concreteStructTy correctedCases - ) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys correctedCases)) - ) - --- | The template for the 'copy' function of a concrete sumtype -concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj]) -concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases = - instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc + generator :: TG.TemplateGenerator TC.TypeCandidate + generator = TG.mkTemplateGenerator genT decl body deps + + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy + + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "$p $NAME($p* pRef)" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + tokensForSumtypeCopy tenv env originalT ty (TC.getFields value) + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + depsForCopy tenv env originalT ty (TC.getFields value) + deps _ = [] + +------------------------------------------------------------------------------- +-- Token and dep generators + +type TokenGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] +type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] + +-------------------------------------------------------------------------------- +-- Initializers + +-- | Generate an init function declaration. +tokensForCaseInitDecl :: Ty -> Ty -> TC.TypeField -> [Token] +tokensForCaseInitDecl orig concrete@(StructTy (ConcreteNameTy _) _) (TC.SumField _ tys) = + let mappings = unifySignatures orig concrete + concreteTys = map (replaceTyVars mappings) tys + in toTemplate ("$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit concreteTys)) ++ ")") +tokensForCaseInitDecl _ _ _ = + error "tokensForCaseInitDecl" + +-- | Given an allocation mode, an original, possibly polymorphic type, a +-- concrete type and a sum type field, generate an init function body. +tokensForCaseInit :: AllocationMode -> Ty -> Ty -> TC.TypeField -> [Token] +tokensForCaseInit alloc orig concrete (TC.SumField fieldname tys) = + let mappings = unifySignatures orig concrete + concreteTys = map (replaceTyVars mappings) tys + unitless = zip anonMemberNames $ remove isUnit concreteTys + in multilineTemplate + [ "$DECL {", + allocate alloc, + joinLines (assign alloc fieldname . fst <$> unitless), + " instance._tag = " ++ tagName concrete fieldname ++ ";", + " return instance;", + "}" + ] + where allocate :: AllocationMode -> String + allocate StackAlloc = " $p instance;" + allocate HeapAlloc = " $p instance = CARP_MALLOC(sizeof(" ++ show concrete ++ "));" + + assign :: AllocationMode -> String -> String -> String + assign alloc' name member = + " instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";" +tokensForCaseInit _ _ _ _ = error "tokenForCaseInit" + +accessor :: AllocationMode -> String +accessor StackAlloc = "." +accessor HeapAlloc = "->" + +-------------------------------------------------------------------------------- +-- Copy + +-- | Generates dependencies for sum type copy functions. +depsForCopy :: DepGen +depsForCopy tenv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in if isTypeGeneric concrete + then [] + else + concatMap + (depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType) + (filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields)) + +-- | Generates C function bodies for sum type copy functions. +tokensForSumtypeCopy :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] +tokensForSumtypeCopy typeEnv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in multilineTemplate + [ "$DECL {", + " $p copy = *pRef;", + joinLines $ + zipWith + (curry copyCase) + concreteFields + (True : repeat False), + " return copy;", + "}" + ] where - doc = "copies a `" ++ (show structTy) ++ "`." - template = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p* pRef)")) - (const (tokensForSumtypeCopy typeEnv env structTy cases)) - ( \_ -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys cases)) - ) -concreteSumtypeCopy _ _ _ _ _ = error "concretesumtypecopy" - -tokensForSumtypeCopy :: TypeEnv -> Env -> Ty -> [SumtypeCase] -> [Token] -tokensForSumtypeCopy typeEnv env concreteStructTy cases = - toTemplate $ - unlines - [ "$DECL {", - " $p copy = *pRef;", - joinLines $ - zipWith - (curry (copyCase typeEnv env concreteStructTy)) - cases - (True : repeat False), - " return copy;", + copyCase :: (TC.TypeField, Bool) -> String + copyCase (theCase, isFirstCase) = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {", + joinLines $ memberCopy typeEnv env <$> unionMembers name tys, + " }" + ] + +-------------------------------------------------------------------------------- +-- Delete + +-- | Generates tokens for the C function body of sum type copy functions. +tokensForDeleteBody :: TokenGen +tokensForDeleteBody tenv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in multilineTemplate [ + "$DECL {", + concatMap deleteCase (zip concreteFields (True : repeat False)), "}" - ] - -copyCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String -copyCase typeEnv env concreteStructTy@(StructTy _ _) (theCase, isFirstCase) = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {", - joinLines $ memberCopy typeEnv env <$> unionMembers name tys, - " }" + ] + where deleteCase :: (TC.TypeField, Bool) -> String + deleteCase (theCase, isFirstCase) = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {", + joinLines $ memberDeletion tenv env <$> unionMembers name tys, + " }" + ] + +-- | Generates deps for the body of a delete function. +depsForDelete :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] +depsForDelete tenv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in if isTypeGeneric concrete + then [] + else concatMap + (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) + (filter (isManaged tenv env) (concatMap (TC.fieldTypes) concreteFields)) + +-------------------------------------------------------------------------------- +-- Str and prn + +-- | Fetches dependencies for str and prn functions. +depsForStr :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] +depsForStr tenv env generic concrete fields = + let ft = FuncTy [RefTy concrete (VarTy "q")] StringTy StaticLifetimeTy + mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + tys = remove isFullyGenericType (concatMap TC.fieldTypes concreteFields) + in (concatMap (depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env) tys) + ++ [defineFunctionTypeAlias ft | not (isTypeGeneric concrete)] + +-- | Generates C function body tokens for sum type str and prn functions. +tokensForStr :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] +tokensForStr typeEnv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in multilineTemplate + [ "$DECL {", + " // convert members to String here:", + " String temp = NULL;", + " int tempsize = 0;", + " (void)tempsize; // that way we remove the occasional unused warning ", + calculateStructStrSize concreteFields, + " String buffer = CARP_MALLOC(size);", + " String bufferPtr = buffer;", + "", + concatMap strCase concreteFields, + " return buffer;", + "}" ] -copyCase _ _ _ _ = error "copycase" + where strCase :: TC.TypeField -> String + strCase theCase = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " if(p->_tag == " ++ correctedTagName ++ ") {", + " sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");", + " bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n", + joinLines $ memberPrn typeEnv env <$> unionMembers name tys, + " bufferPtr--;", + " sprintf(bufferPtr, \")\");", + " }" + ] + + -- | Figure out how big the string needed for the string representation of the struct has to be. + calculateStructStrSize :: [TC.TypeField] -> String + calculateStructStrSize cases = " int size = 1;\n" ++ concatMap strSizeCase cases + + strSizeCase :: TC.TypeField -> String + strSizeCase theCase = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " if(p->_tag == " ++ correctedTagName ++ ") {", + " size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");", + joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys, + " }" + ] + +-------------------------------------------------------------------------------- +-- Additional utilities + +namesFromCase :: TC.TypeField -> Ty -> (String, [Ty], String) +namesFromCase theCase concreteStructTy = + let name = TC.fieldName theCase + in (name, TC.fieldTypes (TC.SumField (TC.fieldName theCase) (remove isUnit (TC.fieldTypes theCase))), tagName concreteStructTy name) anonMemberName :: String -> String -> String anonMemberName name anon = "u." ++ name ++ "." ++ anon diff --git a/src/TemplateGenerator.hs b/src/TemplateGenerator.hs new file mode 100644 index 000000000..5a68bc20f --- /dev/null +++ b/src/TemplateGenerator.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module TemplateGenerator where + +import Obj +import Types +import qualified TypeCandidate as TC + +-------------------------------------------------------------------------------- +-- Template Generators +-- +-- Template generators define a standardized way to construct templates given a fixed set of arguments. + +-- | GeneratorArg is an argument to a template generator. +data GeneratorArg a = GeneratorArg { + tenv :: TypeEnv, + env :: Env, + originalT :: Ty, + instanceT :: Ty, + value :: a +} + +type TypeGenerator a = GeneratorArg a -> Ty +type TokenGenerator a = GeneratorArg a -> [Token] +type DepenGenerator a = GeneratorArg a -> [XObj] + +data TemplateGenerator a = TemplateGenerator { + genT :: TypeGenerator a, + decl :: TokenGenerator a, + body :: TokenGenerator a, + deps :: DepenGenerator a +} + +mkTemplateGenerator :: TypeGenerator a -> TokenGenerator a -> TokenGenerator a -> DepenGenerator a -> TemplateGenerator a +mkTemplateGenerator f g h j = TemplateGenerator f g h j + +generateConcreteTypeTemplate :: TC.TypeCandidate -> TemplateGenerator TC.TypeCandidate -> Template +generateConcreteTypeTemplate candidate gen = + let arg = GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + candidate + t = (genT gen) $ arg + d = (\tt -> (decl gen) $ (arg {instanceT = tt})) + b = (\tt -> (body gen) $ (arg {instanceT = tt})) + p = (\tt -> (deps gen) $ (arg {instanceT = tt})) + in Template t d b p + +generateConcreteFieldTemplate :: TC.TypeCandidate -> TC.TypeField -> TemplateGenerator TC.TypeField -> Template +generateConcreteFieldTemplate candidate field gen = + let arg = GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + field + t = (genT gen) $ arg + d = (\tt -> (decl gen) $ (arg {instanceT = tt})) + b = (\tt -> (body gen) $ (arg {instanceT = tt})) + p = (\tt -> (deps gen) $ (arg {instanceT = tt})) + in Template t d b p + +generateGenericFieldTemplate :: TC.TypeCandidate -> TC.TypeField -> TemplateGenerator TC.TypeField -> TemplateCreator +generateGenericFieldTemplate candidate field gen = + let arg = GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + field + t = (genT gen) arg + in TemplateCreator $ + \tenv env -> + Template + t + (\tt -> (decl gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (body gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (deps gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + +generateGenericTypeTemplate :: TC.TypeCandidate -> TemplateGenerator TC.TypeCandidate -> TemplateCreator +generateGenericTypeTemplate candidate gen = + let arg = GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + candidate + t = (genT gen) arg + in TemplateCreator $ + \tenv env -> + Template + t + (\tt -> (decl gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (body gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (deps gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs new file mode 100644 index 000000000..c00e4192d --- /dev/null +++ b/src/TypeCandidate.hs @@ -0,0 +1,174 @@ +-- | Module type candidate defines a structure for type definitions that have not been validated. +-- +-- Type candidates can either be valid or invalid. Invalid type candidates will be rejected by the type system. +module TypeCandidate + (mkStructCandidate, + mkSumtypeCandidate, + TypeVarRestriction(..), + InterfaceConstraint(..), + TypeField(..), + TypeMode(..), + getFields, + TypeCandidate.getName, + getRestriction, + getVariables, + TypeCandidate.getTypeEnv, + getConstraints, + getValueEnv, + getMode, + TypeCandidate.getPath, + getFullPath, + fieldName, + fieldTypes, + setRestriction, + toType, + TypeCandidate, + ) +where + +import Types +import TypeError +import Obj +import Util + +-------------------------------------------------------------------------------- +-- Data + +data TypeVarRestriction + = AllowAny + | OnlyNamesInScope + deriving Eq + +data InterfaceConstraint = InterfaceConstraint { + name :: String, + types :: Ty +} deriving Show + +data TypeField + = StructField String Ty + | SumField String [Ty] + deriving (Eq, Show) + +data TypeMode + = Struct + | Sum + deriving (Eq, Show) + +data TypeCandidate = TypeCandidate { + typeName :: String, + variables :: [Ty], + members :: [TypeField], + restriction :: TypeVarRestriction, + constraints :: [InterfaceConstraint], + typeEnv :: TypeEnv, + valueEnv :: Env, + mode :: TypeMode, + path :: [String] +} + +-------------------------------------------------------------------------------- +-- Private + +-- | Set the member fields of a type candidate. +setMembers :: TypeCandidate -> [TypeField] -> TypeCandidate +setMembers candidate fields = candidate {members = fields} + +-- | Given a pair of XObjs, construct a struct (product type) field. +mkStructField :: (XObj, XObj) -> Either TypeError TypeField +mkStructField ((XObj (Sym (SymPath [] fname) _) _ _), tx) = + maybe (Left (NotAType tx)) (Right . StructField fname) (xobjToTy tx) +mkStructField (x, _) = Left (InvalidStructField x) + +-- | Given an XObj, construct a sum type field. +mkSumField :: XObj -> Either TypeError TypeField +mkSumField x@(XObj (Lst [XObj (Sym (SymPath [] fname) Symbol) _ _, XObj (Arr txs) _ _]) _ _) = + maybe (Left (InvalidSumtypeCase x)) (Right . SumField fname) (mapM xobjToTy txs) +mkSumField (XObj (Sym (SymPath [] fname) Symbol) _ _) = Right (SumField fname []) +mkSumField x = Left (InvalidSumtypeCase x) + +-------------------------------------------------------------------------------- +-- Public + +-- | Returns the fields of a type candidate +getFields :: TypeCandidate -> [TypeField] +getFields = members + +getName :: TypeCandidate -> String +getName = typeName + +getVariables :: TypeCandidate -> [Ty] +getVariables = variables + +getRestriction :: TypeCandidate -> TypeVarRestriction +getRestriction = restriction + +setRestriction :: TypeCandidate -> TypeVarRestriction -> TypeCandidate +setRestriction candidate restrict = candidate {restriction = restrict} + +getTypeEnv :: TypeCandidate -> TypeEnv +getTypeEnv = typeEnv + +getValueEnv :: TypeCandidate -> Env +getValueEnv = valueEnv + +getConstraints :: TypeCandidate -> [InterfaceConstraint] +getConstraints = constraints + +getMode :: TypeCandidate -> TypeMode +getMode = mode + +getPath :: TypeCandidate -> [String] +getPath = path + +getFullPath :: TypeCandidate -> [String] +getFullPath candidate = TypeCandidate.getPath candidate ++ [TypeCandidate.getName candidate] + +-- | Returns the name of a type field. +fieldName :: TypeField -> String +fieldName (StructField n _) = n +fieldName (SumField n _) = n + +-- | Returns the types of a type field. +fieldTypes :: TypeField -> [Ty] +fieldTypes (StructField _ ty) = [ty] +fieldTypes (SumField _ ts) = ts + +-- | Creates a struct type candidate. +mkStructCandidate :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> [String] -> Either TypeError TypeCandidate +mkStructCandidate tname vars tenv env memberxs ps = + let typedMembers = mapM mkStructField (pairwise memberxs) + candidate = TypeCandidate { + typeName = tname, + variables = vars, + members = [], + restriction = OnlyNamesInScope, + constraints = [], + typeEnv = tenv, + valueEnv = env, + mode = Struct, + path = ps + } + in if even (length memberxs) + then fmap (setMembers candidate) typedMembers + else Left (UnevenMembers memberxs) + +-- | Creates a sum type candidate. +mkSumtypeCandidate :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> [String] -> Either TypeError TypeCandidate +mkSumtypeCandidate tname vars tenv env memberxs ps = + let typedMembers = mapM mkSumField memberxs + candidate = TypeCandidate { + typeName = tname, + variables = vars, + members = [], + restriction = OnlyNamesInScope, + constraints = [], + typeEnv = tenv, + valueEnv = env, + mode = Sum, + path = ps + } + in fmap (setMembers candidate) typedMembers + +toType :: TypeCandidate -> Ty +toType candidate = + StructTy (ConcreteNameTy (SymPath (TypeCandidate.getPath candidate) (TypeCandidate.getName candidate))) (getVariables candidate) diff --git a/src/TypeError.hs b/src/TypeError.hs index 1dd46aa65..f3470a060 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -62,6 +62,7 @@ data TypeError | InconsistentKinds String [XObj] | FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToInstantiateGenericType Ty + | InvalidStructField XObj instance Show TypeError where show (SymbolMissingType xobj env) = @@ -279,6 +280,10 @@ instance Show TypeError where "I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++ prettyInfoFromXObj xobj ++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`" + show (InvalidStructField xobj) = + "I can't use " ++ pretty xobj ++ "as a struct field at " + ++ prettyInfoFromXObj xobj + ++ ".\n\nStruct fields look like this: x Int, e.g. (deftype Point [x Int y Int])" show (InvalidMemberType t xobj) = "I can’t use the type `" ++ show t ++ "` as a member type at " ++ prettyInfoFromXObj xobj diff --git a/src/Validate.hs b/src/Validate.hs index 7b810a8ad..75e41fd9e 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -1,77 +1,58 @@ module Validate where import Control.Monad (foldM) -import Data.Function (on) import Data.List (nubBy, (\\)) -import Data.Maybe (fromJust) import qualified Env as E import Obj import TypeError import TypePredicates import Types -import Util +import qualified TypeCandidate as TC +import qualified Reify as R -{-# ANN validateMemberCases "HLint: ignore Eta reduce" #-} +-------------------------------------------------------------------------------- +-- Public -data TypeVarRestriction - = AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a' - | AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope - deriving (Eq) +-- | Determine whether a given type candidate is a valid type. +validateType :: TC.TypeCandidate -> Either TypeError () +validateType candidate = + do checkDuplicateMembers candidate + checkMembers candidate + checkKindConsistency candidate --- | Make sure that the member declarations in a type definition --- | Follow the pattern [ , , ...] --- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies. -validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError () -validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest - where - visit (XObj (Arr membersXObjs) _ _) = - validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs - visit xobj = - Left (InvalidSumtypeCase xobj) +-------------------------------------------------------------------------------- +-- Private -validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError () -validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs = - checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency - where - pairs = pairwise membersXObjs - -- Are the number of members even? - checkUnevenMembers :: Either TypeError () - checkUnevenMembers = - if even (length membersXObjs) - then Right () - else Left (UnevenMembers membersXObjs) - -- Are any members duplicated? - checkDuplicateMembers :: Either TypeError () - checkDuplicateMembers = - if length fields == length uniqueFields +-- | Checks whether any field names in the type are used more than once. +checkDuplicateMembers :: TC.TypeCandidate -> Either TypeError () +checkDuplicateMembers candidate = + let allFields = fmap TC.fieldName (TC.getFields candidate) + uniqueFields = nubBy (==) allFields + duplicates = allFields \\ uniqueFields + in if null duplicates then Right () - else Left (DuplicatedMembers dups) - where - fields = fst <$> pairs - uniqueFields = nubBy ((==) `on` xobjObj) fields - dups = fields \\ uniqueFields - -- Do all type variables have consistent kinds? - checkKindConsistency :: Either TypeError () - checkKindConsistency = - case areKindsConsistent varsOnly of - Left var -> Left (InconsistentKinds var membersXObjs) - _ -> pure () - where - -- fromJust is safe here; invalid types will be caught in the prior check. - -- todo? be safer anyway? - varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs) - checkMembers :: Either TypeError () - checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv globalEnv typeVariables . snd) pairs + else Left (DuplicatedMembers (map R.symbol duplicates)) + +-- | Returns an error if one of the types fields can't be used as a member type. +checkMembers :: TC.TypeCandidate -> Either TypeError () +checkMembers candidate = + let tenv = TC.getTypeEnv candidate + env = TC.getValueEnv candidate + tys = concat (map TC.fieldTypes (TC.getFields candidate)) + in mapM_ (canBeUsedAsMemberType (TC.getName candidate) (TC.getRestriction candidate) tenv env (TC.getVariables candidate)) tys -okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () -okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj = - case xobjToTy xobj of - Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj - Nothing -> Left (NotAType xobj) +-- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds. +checkKindConsistency :: TC.TypeCandidate -> Either TypeError () +checkKindConsistency candidate = + let allFieldTypes = concat (map TC.fieldTypes (TC.getFields candidate)) + allGenerics = filter isTypeGeneric $ allFieldTypes + in case areKindsConsistent allGenerics of + Left var -> Left (InconsistentKinds var (map R.reify allFieldTypes)) + _ -> pure () -- | Can this type be used as a member for a deftype? -canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () -canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj = +canBeUsedAsMemberType :: String -> TC.TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> Either TypeError () +canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables ty = case ty of UnitTy -> pure () IntTy -> pure () @@ -86,8 +67,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj FuncTy {} -> pure () PointerTy UnitTy -> pure () PointerTy inner -> - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj - >> pure () + canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables inner -- Struct variables may appear as complete applications or individual -- components in the head of a definition; that is the forms: -- ((Foo (f a b)) [x (f a b)]) @@ -108,41 +88,39 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj struct@(StructTy name tyVars) -> checkVar struct <> checkStruct name tyVars v@(VarTy _) -> checkVar v - _ -> Left (InvalidMemberType ty xobj) + _ -> Left (InvalidMemberType ty (R.reify ty)) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj - >> pure () + canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables innerType checkStruct (ConcreteNameTy path@(SymPath _ name)) vars = case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> pure () Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - _ -> Left (NotAmongRegisteredTypes ty xobj) + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars + _ -> Left (NotAmongRegisteredTypes ty (R.reify ty)) where checkInhabitants :: Ty -> Either TypeError () checkInhabitants (StructTy _ vs) = if length vs == length vars then pure () - else Left (UninhabitedConstructor ty xobj (length vs) (length vars)) - checkInhabitants _ = Left (InvalidMemberType ty xobj) + else Left (UninhabitedConstructor ty (R.reify ty) (length vs) (length vars)) + checkInhabitants _ = Left (InvalidMemberType ty (R.reify ty)) checkStruct v@(VarTy _) vars = - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj - >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables v + >> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars checkStruct _ _ = error "checkstruct" checkVar :: Ty -> Either TypeError () checkVar variable = case typeVarRestriction of - AllowAnyTypeVariableNames -> - pure () - AllowOnlyNamesInScope -> + TC.AllowAny -> pure () + TC.OnlyNamesInScope -> if any (isCaptured variable) typeVariables then pure () - else Left (InvalidMemberType ty xobj) + else Left (InvalidMemberType ty (R.reify ty)) where -- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)` -- `a` may be used as a member, sans `f`, but `f` may not appear diff --git a/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected b/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected index f096c2a6b..d813d3386 100644 --- a/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected +++ b/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected @@ -1 +1 @@ -deftype_type_var_not_in_scope.carp:3:10 deftype_type_var_not_in_scope.carp:3:21 Can't use 'b' as a type for a member variable. +deftype_type_var_not_in_scope.carp:3:10 Can't use 'b' as a type for a member variable. diff --git a/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected b/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected index ab7dab17d..c0cf98171 100644 --- a/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected +++ b/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected @@ -1 +1 @@ -sumtype_type_var_not_in_scope.carp:3:10 sumtype_type_var_not_in_scope.carp:4:3 Can't use 'x' as a type for a member variable. +sumtype_type_var_not_in_scope.carp:3:10 Can't use 'x' as a type for a member variable. From bf3e02e5f0a2a8abc00ecd1bc414dd376e2d3772 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Wed, 22 Dec 2021 15:58:42 +0100 Subject: [PATCH 15/59] chore: apply code formatting (#1365) --- src/BoxTemplates.hs | 99 ++++--- src/Concretize.hs | 42 +-- src/Deftype.hs | 600 ++++++++++++++++++++------------------- src/Emit.hs | 3 +- src/Env.hs | 22 +- src/Primitives.hs | 30 +- src/StartingEnv.hs | 21 +- src/Sumtypes.hs | 206 +++++++------- src/TemplateGenerator.hs | 84 +++--- src/TypeCandidate.hs | 125 ++++---- src/Validate.hs | 21 +- 11 files changed, 652 insertions(+), 601 deletions(-) diff --git a/src/BoxTemplates.hs b/src/BoxTemplates.hs index 2065df37e..2ef6803b0 100644 --- a/src/BoxTemplates.hs +++ b/src/BoxTemplates.hs @@ -23,54 +23,66 @@ boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")] -- | Defines a template for initializing Boxes. init :: (String, Binder) -init = let path = SymPath ["Box"] "init" - t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy - docs = "Initializes a box pointing to value t." - decl = templateLiteral "$t* $NAME ($t t)" - body = const (multilineTemplate - [ "$DECL {", - " $t* instance;", - " instance = CARP_MALLOC(sizeof($t));", - " *instance = t;", - " return instance;", - "}" - ]) - deps = const [] - template = TemplateCreator $ \_ _ -> Template t decl body deps - in defineTypeParameterizedTemplate template path t docs +init = + let path = SymPath ["Box"] "init" + t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy + docs = "Initializes a box pointing to value t." + decl = templateLiteral "$t* $NAME ($t t)" + body = + const + ( multilineTemplate + [ "$DECL {", + " $t* instance;", + " instance = CARP_MALLOC(sizeof($t));", + " *instance = t;", + " return instance;", + "}" + ] + ) + deps = const [] + template = TemplateCreator $ \_ _ -> Template t decl body deps + in defineTypeParameterizedTemplate template path t docs -- | Defines a template for converting a boxed value to a local value. unbox :: (String, Binder) -unbox = let path = SymPath ["Box"] "unbox" - t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy - docs = "Converts a boxed value to a reference to the value and delete the box." - decl = templateLiteral "$t $NAME($t* box)" - body = const (multilineTemplate - [ "$DECL {", - " $t local;", - " local = *box;", - " CARP_FREE(box);", - " return local;", - "}" - ]) - deps = const [] - template = TemplateCreator $ \_ _ -> Template t decl body deps - in defineTypeParameterizedTemplate template path t docs +unbox = + let path = SymPath ["Box"] "unbox" + t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy + docs = "Converts a boxed value to a reference to the value and delete the box." + decl = templateLiteral "$t $NAME($t* box)" + body = + const + ( multilineTemplate + [ "$DECL {", + " $t local;", + " local = *box;", + " CARP_FREE(box);", + " return local;", + "}" + ] + ) + deps = const [] + template = TemplateCreator $ \_ _ -> Template t decl body deps + in defineTypeParameterizedTemplate template path t docs -- | Defines a template for getting a reference to the value stored in a box without performing an additional allocation. peek :: (String, Binder) -peek = let path = SymPath ["Box"] "peek" - t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy - docs = "Returns a reference to the value stored in a box without performing an additional allocation." - decl = templateLiteral "$t* $NAME($t** box_ref)" - body = const (multilineTemplate - [ "$DECL {", - " return *box_ref;", - "}" - ]) - deps = const [] - template = TemplateCreator $ \_ _ -> Template t decl body deps - in defineTypeParameterizedTemplate template path t docs +peek = + let path = SymPath ["Box"] "peek" + t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy + docs = "Returns a reference to the value stored in a box without performing an additional allocation." + decl = templateLiteral "$t* $NAME($t** box_ref)" + body = + const + ( multilineTemplate + [ "$DECL {", + " return *box_ref;", + "}" + ] + ) + deps = const [] + template = TemplateCreator $ \_ _ -> Template t decl body deps + in defineTypeParameterizedTemplate template path t docs -- | Defines a template for copying a box. The copy will also be heap allocated. copy :: (String, Binder) @@ -142,7 +154,7 @@ delete = innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) = case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of FunctionFound functionFullName -> - " " ++ functionFullName ++ "(*box);\n" + " " ++ functionFullName ++ "(*box);\n" ++ " CARP_FREE(box);" FunctionNotFound msg -> error msg FunctionIgnored -> @@ -234,4 +246,3 @@ innerStr tenv env (StructTy _ [t]) = ] FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n" innerStr _ _ _ = "" - diff --git a/src/Concretize.hs b/src/Concretize.hs index 4d224c099..0fdb21707 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -43,6 +43,7 @@ import Polymorphism import Reify import qualified Set import ToTemplate +import qualified TypeCandidate as TC import TypeError import TypePredicates import Types @@ -50,7 +51,6 @@ import TypesToC import Util import Validate import Prelude hiding (lookup) -import qualified TypeCandidate as TC data Level = Toplevel | Inside @@ -645,22 +645,25 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases fixLeft l = replaceLeft (FailedToInstantiateGenericType originalStructTy) l - in do mappings <- fixLeft $ solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] - let concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases - sname = (getStructName originalStructTy) - deps <- mapM (depsForCase typeEnv env) concretelyTypedCases - candidate <- TC.mkSumtypeCandidate sname renamedOrig typeEnv env concretelyTypedCases (getPathFromStructName sname) - validateType (TC.setRestriction candidate TC.AllowAny) - pure (XObj - ( Lst - ( XObj (DefSumtype genericStructTy) Nothing Nothing : - XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : - concretelyTypedCases - ) - ) - (Just dummyInfo) - (Just TypeTy) : - concat deps) + in do + mappings <- fixLeft $ solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] + let concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases + sname = (getStructName originalStructTy) + deps <- mapM (depsForCase typeEnv env) concretelyTypedCases + candidate <- TC.mkSumtypeCandidate sname renamedOrig typeEnv env concretelyTypedCases (getPathFromStructName sname) + validateType (TC.setRestriction candidate TC.AllowAny) + pure + ( XObj + ( Lst + ( XObj (DefSumtype genericStructTy) Nothing Nothing : + XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : + concretelyTypedCases + ) + ) + (Just dummyInfo) + (Just TypeTy) : + concat deps + ) instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype" -- Resolves dependencies for sumtype cases. @@ -678,8 +681,9 @@ depsForCase _ _ x = Left (InvalidSumtypeCase x) -- | Replace instances of generic types in type candidate field definitions. replaceGenericTypeSymbolsOnFields :: Map.Map String Ty -> [TC.TypeField] -> [TC.TypeField] replaceGenericTypeSymbolsOnFields ms fields = map go fields - where go (TC.StructField name t) = (TC.StructField name (replaceTyVars ms t)) - go (TC.SumField name ts) = (TC.SumField name (map (replaceTyVars ms) ts)) + where + go (TC.StructField name t) = (TC.StructField name (replaceTyVars ms t)) + go (TC.SumField name ts) = (TC.SumField name (map (replaceTyVars ms) ts)) replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj] replaceGenericTypeSymbolsOnMembers mappings memberXObjs = diff --git a/src/Deftype.hs b/src/Deftype.hs index 47d784348..ecb5e67d2 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -18,15 +18,15 @@ import Managed import Obj import StructUtils import Template +import TemplateGenerator as TG import ToTemplate +import qualified TypeCandidate as TC import TypeError import TypePredicates import Types import TypesToC import Util import Validate -import qualified TypeCandidate as TC -import TemplateGenerator as TG {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -60,15 +60,15 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) initmembers = case rest of - -- ANSI C does not allow empty structs. We add a dummy member here to account for this. - -- Note that we *don't* add this member for external types--we leave those definitions up to the user. - -- The corresponding field is emitted for the struct definition in Emit.hs - [(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)] - _ -> rest + -- ANSI C does not allow empty structs. We add a dummy member here to account for this. + -- Note that we *don't* add this member for external types--we leave those definitions up to the user. + -- The corresponding field is emitted for the struct definition in Emit.hs + [(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)] + _ -> rest in do let mems = case initmembers of - [(XObj (Arr ms)_ _)] -> ms - _ -> [] + [(XObj (Arr ms) _ _)] -> ms + _ -> [] -- Check that this is a valid type definition. candidate <- TC.mkStructCandidate typeName typeVariables typeEnv env mems pathStrings validateType candidate @@ -88,8 +88,8 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) in do let mems = case rest of - [(XObj (Arr ms)_ _)] -> ms - _ -> [] + [(XObj (Arr ms) _ _)] -> ms + _ -> [] -- Check that this is a valid type definition. candidate <- TC.mkStructCandidate typeName [] typeEnv env mems pathStrings validateType candidate @@ -109,14 +109,17 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = -- | Generate the standard set of functions for a new type. generateTypeBindings :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) generateTypeBindings candidate = - do (okMembers, membersDeps) <- templatesForMembers candidate - okInit <- binderForInit candidate - (okStr, strDeps) <- binderForStrOrPrn "str" candidate - (okPrn, _) <- binderForStrOrPrn "prn" candidate - (okDelete, deleteDeps) <- binderForDelete candidate - (okCopy, copyDeps) <- binderForCopy candidate - pure ((okInit : okStr : okPrn : okDelete : okCopy : okMembers), - (deleteDeps ++ membersDeps ++ copyDeps ++ strDeps)) + do + (okMembers, membersDeps) <- templatesForMembers candidate + okInit <- binderForInit candidate + (okStr, strDeps) <- binderForStrOrPrn "str" candidate + (okPrn, _) <- binderForStrOrPrn "prn" candidate + (okDelete, deleteDeps) <- binderForDelete candidate + (okCopy, copyDeps) <- binderForCopy candidate + pure + ( (okInit : okStr : okPrn : okDelete : okCopy : okMembers), + (deleteDeps ++ membersDeps ++ copyDeps ++ strDeps) + ) -- | Generate all the templates for ALL the member variables in a deftype declaration. templatesForMembers :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) @@ -155,38 +158,42 @@ templatesForSingleMember candidate field@(TC.StructField _ t) = ] getter :: Ty -> ((String, Binder), [XObj]) - getter sig = let doc = "gets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`." - binderT = sig - binderP = SymPath (TC.getFullPath candidate) (TC.fieldName field) - temp = TG.generateConcreteFieldTemplate candidate field getterGenerator - in instanceBinderWithDeps binderP binderT temp doc + getter sig = + let doc = "gets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) (TC.fieldName field) + temp = TG.generateConcreteFieldTemplate candidate field getterGenerator + in instanceBinderWithDeps binderP binderT temp doc setter :: Ty -> ((String, Binder), [XObj]) - setter sig = let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`." - binderT = sig - binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field)) - concrete = (TG.generateConcreteFieldTemplate candidate field setterGenerator) - generic = (TG.generateGenericFieldTemplate candidate field setterGenerator) - in if isTypeGeneric t - then (defineTypeParameterizedTemplate generic binderP binderT doc, []) - else instanceBinderWithDeps binderP binderT concrete doc + setter sig = + let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field)) + concrete = (TG.generateConcreteFieldTemplate candidate field setterGenerator) + generic = (TG.generateGenericFieldTemplate candidate field setterGenerator) + in if isTypeGeneric t + then (defineTypeParameterizedTemplate generic binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT concrete doc mutator :: Ty -> ((String, Binder), [XObj]) - mutator sig = let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "` in place." - binderT = sig - binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field) ++ "!") - concrete = (TG.generateConcreteFieldTemplate candidate field mutatorGenerator) - generic = (TG.generateGenericFieldTemplate candidate field mutatorGenerator) - in if isTypeGeneric t - then (defineTypeParameterizedTemplate generic binderP binderT doc, []) - else instanceBinderWithDeps binderP binderT concrete doc + mutator sig = + let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "` in place." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field) ++ "!") + concrete = (TG.generateConcreteFieldTemplate candidate field mutatorGenerator) + generic = (TG.generateGenericFieldTemplate candidate field mutatorGenerator) + in if isTypeGeneric t + then (defineTypeParameterizedTemplate generic binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT concrete doc updater :: Ty -> ((String, Binder), [XObj]) - updater sig = let doc = "updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`." - binderT = sig - binderP = SymPath (TC.getFullPath candidate) ("update-" ++ (TC.fieldName field)) - temp = TG.generateConcreteFieldTemplate candidate field updateGenerator - in instanceBinderWithDeps binderP binderT temp doc + updater sig = + let doc = "updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`." + binderT = sig + binderP = SymPath (TC.getFullPath candidate) ("update-" ++ (TC.fieldName field)) + temp = TG.generateConcreteFieldTemplate candidate field updateGenerator + in instanceBinderWithDeps binderP binderT temp doc templatesForSingleMember _ _ = error "templatesforsinglemember" -- | Helper function to create the binder for the 'init' template. @@ -194,7 +201,7 @@ binderForInit :: TC.TypeCandidate -> Either TypeError (String, Binder) binderForInit candidate = -- Remove the __dummy field from the members array to ensure we can call the initializer with no arguments. -- See the implementation of moduleForDeftype for more details. - let nodummy = remove ((=="__dummy") . TC.fieldName) (TC.getFields candidate) + let nodummy = remove ((== "__dummy") . TC.fieldName) (TC.getFields candidate) doc = "creates a `" ++ (TC.getName candidate) ++ "`." binderP = (SymPath (TC.getFullPath candidate) "init") binderT = (FuncTy (concatMap TC.fieldTypes nodummy) (TC.toType candidate) StaticLifetimeTy) @@ -248,19 +255,19 @@ getterGenerator = TG.mkTemplateGenerator tgen decl body deps tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) decl :: TG.TokenGenerator TC.TypeField - decl TG.GeneratorArg{instanceT=UnitTy} = toTemplate "void $NAME($(Ref p) p)" + decl TG.GeneratorArg {instanceT = UnitTy} = toTemplate "void $NAME($(Ref p) p)" decl _ = toTemplate "$t $NAME($(Ref p) p)" body :: TG.TokenGenerator TC.TypeField - body TG.GeneratorArg{value=(TC.StructField _ UnitTy)} = toTemplate "$DECL { return; }\n" - body TG.GeneratorArg{instanceT=(FuncTy _ (RefTy UnitTy _) _)} = toTemplate " $DECL { void* ptr = NULL; return ptr; }\n" - body TG.GeneratorArg{value=(TC.StructField name ty)} = + body TG.GeneratorArg {value = (TC.StructField _ UnitTy)} = toTemplate "$DECL { return; }\n" + body TG.GeneratorArg {instanceT = (FuncTy _ (RefTy UnitTy _) _)} = toTemplate " $DECL { void* ptr = NULL; return ptr; }\n" + body TG.GeneratorArg {value = (TC.StructField name ty)} = let fixForVoidStarMembers = if isFunctionType ty && not (isTypeGeneric ty) then "(" ++ tyToCLambdaFix (RefTy ty (VarTy "q")) ++ ")" else "" in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ (mangle name) ++ ")); }\n") - body TG.GeneratorArg{} = toTemplate "/* template error! */" + body TG.GeneratorArg {} = toTemplate "/* template error! */" deps :: TG.DepenGenerator TC.TypeField deps = const [] @@ -268,154 +275,158 @@ getterGenerator = TG.mkTemplateGenerator tgen decl body deps -- | setterGenerator returns a template generator for struct property setters. setterGenerator :: TG.TemplateGenerator TC.TypeField setterGenerator = TG.mkTemplateGenerator tgen decl body deps - where tgen :: TG.TypeGenerator TC.TypeField - tgen _ = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) - - decl :: TG.TokenGenerator TC.TypeField - decl GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$p $NAME($p p)" - decl _ = toTemplate "$p $NAME($p p, $t newValue)" - - body :: TG.TokenGenerator TC.TypeField - body GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return p; }\n" - body GeneratorArg{tenv,env,instanceT= (FuncTy [_, ty] _ _),value=(TC.StructField name _)} = - multilineTemplate [ - "$DECL {", - memberDeletion tenv env (name, ty), - " p." ++ (mangle name) ++ " = newValue;", - " return p;", - "}\n" - ] - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeField - deps GeneratorArg{tenv, env, TG.instanceT=(FuncTy [_, ty] _ _)} - | isManaged tenv env ty = depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty) - | isFunctionType ty = [defineFunctionTypeAlias ty] - | otherwise = [] - deps _ = [] + where + tgen :: TG.TypeGenerator TC.TypeField + tgen _ = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$p $NAME($p p)" + decl _ = toTemplate "$p $NAME($p p, $t newValue)" + + body :: TG.TokenGenerator TC.TypeField + body GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return p; }\n" + body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} = + multilineTemplate + [ "$DECL {", + memberDeletion tenv env (name, ty), + " p." ++ (mangle name) ++ " = newValue;", + " return p;", + "}\n" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps GeneratorArg {tenv, env, TG.instanceT = (FuncTy [_, ty] _ _)} + | isManaged tenv env ty = depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty) + | isFunctionType ty = [defineFunctionTypeAlias ty] + | otherwise = [] + deps _ = [] -- | mutatorGenerator returns a template generator for struct property setters (in-place). mutatorGenerator :: TG.TemplateGenerator TC.TypeField mutatorGenerator = TG.mkTemplateGenerator tgen decl body deps - where tgen :: TG.TypeGenerator TC.TypeField - tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) - - decl :: TG.TokenGenerator TC.TypeField - decl GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "void $NAME($p* pRef)" - decl _ = toTemplate "void $NAME($p* pRef, $t newValue)" - - body :: TG.TokenGenerator TC.TypeField - -- Execution of the action passed as an argument is handled in Emit.hs. - body GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return; }\n" - body GeneratorArg{tenv, env, instanceT=(FuncTy [_, ty] _ _), value=(TC.StructField name _)} = - multilineTemplate [ - "$DECL {", - memberRefDeletion tenv env (name, ty), - " pRef->" ++ mangle name ++ " = newValue;", - "}\n" - ] - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeField - deps GeneratorArg{tenv, env, instanceT=(FuncTy [_, ty] _ _)} = - if isManaged tenv env ty - then depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty) - else [] - deps _ = [] + where + tgen :: TG.TypeGenerator TC.TypeField + tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "void $NAME($p* pRef)" + decl _ = toTemplate "void $NAME($p* pRef, $t newValue)" + + body :: TG.TokenGenerator TC.TypeField + -- Execution of the action passed as an argument is handled in Emit.hs. + body GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return; }\n" + body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} = + multilineTemplate + [ "$DECL {", + memberRefDeletion tenv env (name, ty), + " pRef->" ++ mangle name ++ " = newValue;", + "}\n" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _)} = + if isManaged tenv env ty + then depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty) + else [] + deps _ = [] -- | Returns a template generator for updating struct properties with a function. updateGenerator :: TG.TemplateGenerator TC.TypeField updateGenerator = TG.mkTemplateGenerator tgen decl body deps - where tgen :: TG.TypeGenerator TC.TypeField - tgen GeneratorArg{value=(TC.StructField _ UnitTy)} = - (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) - tgen _ = (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) - - decl :: TG.TokenGenerator TC.TypeField - decl _ = toTemplate "$p $NAME($p p, Lambda *updater)" -- Lambda used to be (Fn [t] t) - - body :: TG.TokenGenerator TC.TypeField - body GeneratorArg{value=(TC.StructField _ UnitTy)} = - toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n") - body GeneratorArg{value=(TC.StructField name _)} = multilineTemplate [ - "$DECL {", - " p." ++ mangle name ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ mangle name] ++ ";", - " return p;", - "}\n" - ] - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeField - deps GeneratorArg{instanceT=(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _)} = - if isTypeGeneric fRetTy - then [] - else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] - deps _ = [] + where + tgen :: TG.TypeGenerator TC.TypeField + tgen GeneratorArg {value = (TC.StructField _ UnitTy)} = + (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) + tgen _ = (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeField + decl _ = toTemplate "$p $NAME($p p, Lambda *updater)" -- Lambda used to be (Fn [t] t) + body :: TG.TokenGenerator TC.TypeField + body GeneratorArg {value = (TC.StructField _ UnitTy)} = + toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n") + body GeneratorArg {value = (TC.StructField name _)} = + multilineTemplate + [ "$DECL {", + " p." ++ mangle name ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ mangle name] ++ ";", + " return p;", + "}\n" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeField + deps GeneratorArg {instanceT = (FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _)} = + if isTypeGeneric fRetTy + then [] + else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] + deps _ = [] -- | Returns a template generator for a types initializer function. initGenerator :: AllocationMode -> TG.TemplateGenerator TC.TypeCandidate initGenerator alloc = TG.mkTemplateGenerator genT decl body deps - where genT :: TG.TypeGenerator TC.TypeCandidate - genT GeneratorArg{value} = - (FuncTy (concatMap TC.fieldTypes (TC.getFields value)) (VarTy "p") StaticLifetimeTy) - - decl :: TG.TokenGenerator TC.TypeCandidate - decl GeneratorArg{originalT, instanceT=(FuncTy _ concreteT _), value} = - let mappings = unifySignatures originalT concreteT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - cFields = remove isUnitT (remove isDummy concreteFields) - in toTemplate ("$p $NAME(" ++ joinWithComma (map fieldArg cFields) ++ ")") - decl _ = toTemplate "/* template error! */" - - body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{originalT, instanceT=(FuncTy _ concreteT _), value} = - let mappings = unifySignatures originalT concreteT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - in tokensForInit alloc (show originalT) (remove isUnitT concreteFields) - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeCandidate - deps GeneratorArg{tenv, env, instanceT=(FuncTy _ concreteT _)} = - case concretizeType tenv env concreteT of - Left _ -> [] - Right ok -> ok - deps _ = [] - - tokensForInit :: AllocationMode -> String -> [TC.TypeField] -> [Token] - -- if this is truly a memberless struct, init it to 0; - -- This can happen in cases where *all* members of the struct are of type Unit. - -- Since we do not generate members for Unit types. - tokensForInit StackAlloc _ [] = - multilineTemplate [ - "$DECL {", - " $p instance = {};", - " return instance;", - "}" - ] - tokensForInit StackAlloc _ fields = - multilineTemplate [ - "$DECL {", - " $p instance;", - assignments fields, - " return instance;", - "}" - ] - tokensForInit HeapAlloc typeName fields = - multilineTemplate [ - "$DECL {", - " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", - assignments fields, - " return instance;", - "}" - ] - - assignments :: [TC.TypeField] -> String - assignments [] = "" - assignments fields = joinLines $ fmap (memberAssignment alloc) fields - - isDummy field = TC.fieldName field == "__dummy" - isUnitT (TC.StructField _ UnitTy) = True - isUnitT _ = False + where + genT :: TG.TypeGenerator TC.TypeCandidate + genT GeneratorArg {value} = + (FuncTy (concatMap TC.fieldTypes (TC.getFields value)) (VarTy "p") StaticLifetimeTy) + + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg {originalT, instanceT = (FuncTy _ concreteT _), value} = + let mappings = unifySignatures originalT concreteT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + cFields = remove isUnitT (remove isDummy concreteFields) + in toTemplate ("$p $NAME(" ++ joinWithComma (map fieldArg cFields) ++ ")") + decl _ = toTemplate "/* template error! */" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg {originalT, instanceT = (FuncTy _ concreteT _), value} = + let mappings = unifySignatures originalT concreteT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in tokensForInit alloc (show originalT) (remove isUnitT concreteFields) + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg {tenv, env, instanceT = (FuncTy _ concreteT _)} = + case concretizeType tenv env concreteT of + Left _ -> [] + Right ok -> ok + deps _ = [] + + tokensForInit :: AllocationMode -> String -> [TC.TypeField] -> [Token] + -- if this is truly a memberless struct, init it to 0; + -- This can happen in cases where *all* members of the struct are of type Unit. + -- Since we do not generate members for Unit types. + tokensForInit StackAlloc _ [] = + multilineTemplate + [ "$DECL {", + " $p instance = {};", + " return instance;", + "}" + ] + tokensForInit StackAlloc _ fields = + multilineTemplate + [ "$DECL {", + " $p instance;", + assignments fields, + " return instance;", + "}" + ] + tokensForInit HeapAlloc typeName fields = + multilineTemplate + [ "$DECL {", + " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", + assignments fields, + " return instance;", + "}" + ] + + assignments :: [TC.TypeField] -> String + assignments [] = "" + assignments fields = joinLines $ fmap (memberAssignment alloc) fields + + isDummy field = TC.fieldName field == "__dummy" + isUnitT (TC.StructField _ UnitTy) = True + isUnitT _ = False -- | Generate C code for assigning to a member variable. -- Needs to know if the instance is a pointer or stack variable. @@ -458,118 +469,121 @@ templatizeTy t = t -- | Returns a template generator for a type's str and prn functions. strGenerator :: TG.TemplateGenerator TC.TypeCandidate strGenerator = TG.mkTemplateGenerator genT decl body deps - where genT :: TG.TypeGenerator TC.TypeCandidate - genT GeneratorArg{originalT} = - FuncTy [RefTy originalT (VarTy "q")] StringTy StaticLifetimeTy - - decl :: TG.TokenGenerator TC.TypeCandidate - decl GeneratorArg{instanceT=(FuncTy [RefTy structT _] _ _)} = - toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)" - decl _ = toTemplate "/* template error! */" - - body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} = - let mappings = unifySignatures originalT structT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - in tokensForStr tenv env (getStructName structT) concreteFields structT - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeCandidate - deps arg@GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} = - let mappings = unifySignatures originalT structT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - in concatMap - (depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env) - (remove isFullyGenericType (concatMap TC.fieldTypes concreteFields)) - ++ [defineFunctionTypeAlias (instanceT arg) | not (isTypeGeneric structT)] - deps _ = [] - - tokensForStr :: TypeEnv -> Env -> String -> [TC.TypeField] -> Ty -> [Token] - tokensForStr typeEnv env typeName fields concreteStructTy = - let members = remove ((=="__dummy"). fst) (map fieldToTuple fields) - in multilineTemplate - [ "$DECL {", - " // convert members to String here:", - " String temp = NULL;", - " int tempsize = 0;", - " (void)tempsize; // that way we remove the occasional unused warning ", - calculateStructStrSize typeEnv env members concreteStructTy, - " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - "", - " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");", - " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n", - joinLines (map (memberPrn typeEnv env) members), - " bufferPtr--;", - " sprintf(bufferPtr, \")\");", - " return buffer;", - "}" - ] - - -- | Figure out how big the string needed for the string representation of the struct has to be. - calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String - calculateStructStrSize typeEnv env fields s = - " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n" - ++ unlines (map (memberPrnSize typeEnv env) fields) + where + genT :: TG.TypeGenerator TC.TypeCandidate + genT GeneratorArg {originalT} = + FuncTy [RefTy originalT (VarTy "q")] StringTy StaticLifetimeTy + + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg {instanceT = (FuncTy [RefTy structT _] _ _)} = + toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)" + decl _ = toTemplate "/* template error! */" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in tokensForStr tenv env (getStructName structT) concreteFields structT + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps arg@GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in concatMap + (depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env) + (remove isFullyGenericType (concatMap TC.fieldTypes concreteFields)) + ++ [defineFunctionTypeAlias (instanceT arg) | not (isTypeGeneric structT)] + deps _ = [] + + tokensForStr :: TypeEnv -> Env -> String -> [TC.TypeField] -> Ty -> [Token] + tokensForStr typeEnv env typeName fields concreteStructTy = + let members = remove ((== "__dummy") . fst) (map fieldToTuple fields) + in multilineTemplate + [ "$DECL {", + " // convert members to String here:", + " String temp = NULL;", + " int tempsize = 0;", + " (void)tempsize; // that way we remove the occasional unused warning ", + calculateStructStrSize typeEnv env members concreteStructTy, + " String buffer = CARP_MALLOC(size);", + " String bufferPtr = buffer;", + "", + " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");", + " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n", + joinLines (map (memberPrn typeEnv env) members), + " bufferPtr--;", + " sprintf(bufferPtr, \")\");", + " return buffer;", + "}" + ] + calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String + calculateStructStrSize typeEnv env fields s = + " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n" + ++ unlines (map (memberPrnSize typeEnv env) fields) -- | Returns a template generator for a type's delete function. deleteGenerator :: TG.TemplateGenerator TC.TypeCandidate deleteGenerator = TG.mkTemplateGenerator genT decl body deps - where genT :: TG.TypeGenerator TC.TypeCandidate - genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy - - decl :: TG.TokenGenerator TC.TypeCandidate - decl _ = toTemplate "void $NAME($p p)" - - body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [structT] _ _), value} = - let mappings = unifySignatures originalT structT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - members = map fieldToTuple concreteFields - in multilineTemplate [ - "$DECL {", - joinLines (map (memberDeletion tenv env) members), - "}" - ] - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeCandidate - deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [structT] _ _), value} - | isTypeGeneric structT = [] - | otherwise = let mappings = unifySignatures originalT structT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - in concatMap - (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields)) - deps _ = [] + where + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy + + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "void $NAME($p p)" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [structT] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + members = map fieldToTuple concreteFields + in multilineTemplate + [ "$DECL {", + joinLines (map (memberDeletion tenv env) members), + "}" + ] + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [structT] _ _), value} + | isTypeGeneric structT = [] + | otherwise = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + in concatMap + (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) + (filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields)) + deps _ = [] -- | Returns a template generator for a type's copy function. copyGenerator :: TG.TemplateGenerator TC.TypeCandidate copyGenerator = TG.mkTemplateGenerator genT decl body deps - where genT :: TG.TypeGenerator TC.TypeCandidate - genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy - - decl :: TG.TokenGenerator TC.TypeCandidate - decl _ = toTemplate "$p $NAME($p* pRef)" - - body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} = - let mappings = unifySignatures originalT structT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - members = map fieldToTuple concreteFields - in tokensForCopy tenv env members - body _ = toTemplate "/* template error! */" - - deps :: TG.DepenGenerator TC.TypeCandidate - deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} - | isTypeGeneric structT = [] - | otherwise = let mappings = unifySignatures originalT structT - concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) - members = map fieldToTuple concreteFields - in concatMap - (depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType) - (filter (isManaged tenv env) (map snd members)) - deps _ = [] + where + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy + + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "$p $NAME($p* pRef)" + + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + members = map fieldToTuple concreteFields + in tokensForCopy tenv env members + body _ = toTemplate "/* template error! */" + + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} + | isTypeGeneric structT = [] + | otherwise = + let mappings = unifySignatures originalT structT + concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value) + members = map fieldToTuple concreteFields + in concatMap + (depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType) + (filter (isManaged tenv env) (map snd members)) + deps _ = [] -------------------------------------------------------------------------------- -- Utilities @@ -579,6 +593,6 @@ copyGenerator = TG.mkTemplateGenerator genT decl body deps -- functions for handling type members and it should eventually be deprecated -- once these functions work on type fields directly. fieldToTuple :: TC.TypeField -> (String, Ty) -fieldToTuple (TC.StructField name t) = (mangle name, t) -fieldToTuple (TC.SumField name (t:_)) = (mangle name, t) -- note: not actually used. +fieldToTuple (TC.StructField name t) = (mangle name, t) +fieldToTuple (TC.SumField name (t : _)) = (mangle name, t) -- note: not actually used. fieldToTuple (TC.SumField name []) = (mangle name, TypeTy) -- note: not actually used. diff --git a/src/Emit.hs b/src/Emit.hs index 508733814..9487b5cb4 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -530,7 +530,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo var <- visit indent value let Just t = ty fresh = mangle (freshVar info) - unless (isUnit t) + unless + (isUnit t) (appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n")) pure fresh -- Ref diff --git a/src/Env.hs b/src/Env.hs index 866c7244c..cc5fa03d2 100644 --- a/src/Env.hs +++ b/src/Env.hs @@ -375,17 +375,19 @@ mutate f e path binder = go path where go (SymPath [] name) = f e name binder go (SymPath (p : []) name) = - do mod' <- getBinder e p - env' <- nextEnv (modality e) mod' - res <- mutate f (inj env') (SymPath [] name) binder - new' <- updateEnv (modality e) (prj res) mod' - addBinding e p new' + do + mod' <- getBinder e p + env' <- nextEnv (modality e) mod' + res <- mutate f (inj env') (SymPath [] name) binder + new' <- updateEnv (modality e) (prj res) mod' + addBinding e p new' go (SymPath (p : ps) name) = - do mod' <- getBinder e p - old <- nextEnv Values mod' - result <- mutate f (inj old) (SymPath ps name) binder - new' <- updateEnv Values (prj result) mod' - addBinding e p new' + do + mod' <- getBinder e p + old <- nextEnv Values mod' + result <- mutate f (inj old) (SymPath ps name) binder + new' <- updateEnv Values (prj result) mod' + addBinding e p new' -- | Insert a binding into an environment at the given path. insert :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e diff --git a/src/Primitives.hs b/src/Primitives.hs index 72bc9e9af..e555b56e1 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -265,7 +265,9 @@ primitiveRegisterTypeWithFields ctx x t override members = Right ctx' = update ctx -- TODO: Another case where define does not get formally qualified deps! contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps) - autoDerive contextWithDefs (StructTy (ConcreteNameTy (unqualify path')) []) + autoDerive + contextWithDefs + (StructTy (ConcreteNameTy (unqualify path')) []) [ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")), lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn")) ] @@ -616,11 +618,14 @@ deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor = (ctxWithType, e) <- makeType ctx name [] constructor case e of Left err -> pure (evalError ctx (show err) (xobjInfo x)) - Right t -> autoDerive ctxWithType t - [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")), - lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")), - lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy")) - ] + Right t -> + autoDerive + ctxWithType + t + [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy")) + ] deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor = do (ctxWithType, e) <- @@ -631,11 +636,14 @@ deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) c ) case e of Left err -> pure (evalError ctx (show err) (xobjInfo x)) - Right t -> autoDerive ctxWithType t - [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")), - lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")), - lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy")) - ] + Right t -> + autoDerive + ctxWithType + t + [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy")) + ] deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name) checkVariables :: [XObj] -> Maybe [Ty] diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index fc890a526..7770cac38 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -1,6 +1,7 @@ module StartingEnv where import qualified ArrayTemplates +import qualified BoxTemplates import Commands import qualified Env as E import Eval @@ -14,7 +15,6 @@ import qualified StaticArrayTemplates import Template import ToTemplate import Types -import qualified BoxTemplates -- | These modules will be loaded in order before any other code is evaluated. coreModules :: String -> [String] @@ -121,15 +121,16 @@ boxModule = envFunctionNestingLevel = 0 } where - bindings = Map.fromList - [ BoxTemplates.init, - BoxTemplates.unbox, - BoxTemplates.peek, - BoxTemplates.delete, - BoxTemplates.copy, - BoxTemplates.prn, - BoxTemplates.str - ] + bindings = + Map.fromList + [ BoxTemplates.init, + BoxTemplates.unbox, + BoxTemplates.peek, + BoxTemplates.delete, + BoxTemplates.copy, + BoxTemplates.prn, + BoxTemplates.str + ] maxArity :: Int maxArity = 9 diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 60252cbc0..634ca4b96 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -1,9 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} module Sumtypes - ( - moduleForSumtypeInContext, - moduleForSumtype + ( moduleForSumtypeInContext, + moduleForSumtype, ) where @@ -17,15 +16,15 @@ import Managed import Obj import StructUtils import Template +import TemplateGenerator as TG import ToTemplate +import qualified TypeCandidate as TC import TypeError import TypePredicates import Types import TypesToC import Util import Validate -import qualified TypeCandidate as TC -import TemplateGenerator as TG -------------------------------------------------------------------------------- -- Public @@ -75,16 +74,17 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i -- | Generate standard binders for the sumtype generateBinders :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) generateBinders candidate = - do okIniters <- initers candidate - okTag <- binderForTag candidate - (okStr, okStrDeps) <- binderForStrOrPrn candidate "str" - (okPrn, _) <- binderForStrOrPrn candidate "prn" - okDelete <- binderForDelete candidate - (okCopy, okCopyDeps) <- binderForCopy candidate - okMemberDeps <- memberDeps (TC.getTypeEnv candidate) (TC.getValueEnv candidate) (TC.getFields candidate) - let binders = okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag] - deps = okMemberDeps ++ okCopyDeps ++ okStrDeps - pure (binders, deps) + do + okIniters <- initers candidate + okTag <- binderForTag candidate + (okStr, okStrDeps) <- binderForStrOrPrn candidate "str" + (okPrn, _) <- binderForStrOrPrn candidate "prn" + okDelete <- binderForDelete candidate + (okCopy, okCopyDeps) <- binderForCopy candidate + okMemberDeps <- memberDeps (TC.getTypeEnv candidate) (TC.getValueEnv candidate) (TC.getFields candidate) + let binders = okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag] + deps = okMemberDeps ++ okCopyDeps ++ okStrDeps + pure (binders, deps) -- | Gets concrete dependencies for sum type fields. memberDeps :: TypeEnv -> Env -> [TC.TypeField] -> Either TypeError [XObj] @@ -104,44 +104,41 @@ replaceGenericTypesOnCases mappings = map replaceOnCase -- Binding generators type BinderGen = TC.TypeCandidate -> Either TypeError (String, Binder) + type BinderGenDeps = TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) + type MultiBinderGen = TC.TypeCandidate -> Either TypeError [(String, Binder)] -- | Generate initializer bindings for each sum type case. initers :: MultiBinderGen initers candidate = mapM binderForCaseInit (TC.getFields candidate) where - -- | Generate an initializer binding for a single sum type case, using the given candidate. binderForCaseInit :: TC.TypeField -> Either TypeError (String, Binder) binderForCaseInit sumtypeCase = if isTypeGeneric (TC.toType candidate) then Right (genericCaseInit StackAlloc sumtypeCase) else Right (concreteCaseInit StackAlloc sumtypeCase) - - -- | Generates a template for a concrete (no type variables) sum type case. concreteCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder) concreteCaseInit alloc field@(TC.SumField fieldname tys) = let concrete = (TC.toType candidate) - doc = "creates a `" ++ fieldname ++ "`." - t = (FuncTy tys (VarTy "p") StaticLifetimeTy) - decl = (const (tokensForCaseInitDecl concrete concrete field)) - body = (const (tokensForCaseInit alloc concrete concrete field)) - deps = (const []) - temp = Template t decl body deps + doc = "creates a `" ++ fieldname ++ "`." + t = (FuncTy tys (VarTy "p") StaticLifetimeTy) + decl = (const (tokensForCaseInitDecl concrete concrete field)) + body = (const (tokensForCaseInit alloc concrete concrete field)) + deps = (const []) + temp = Template t decl body deps binderPath = SymPath (TC.getFullPath candidate) fieldname in instanceBinder binderPath (FuncTy tys concrete StaticLifetimeTy) temp doc concreteCaseInit _ _ = error "concreteCaseInit" - - -- | Generates a template for a generic (has type variables) sum type case. genericCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder) genericCaseInit alloc field@(TC.SumField fieldname tys) = let generic = (TC.toType candidate) - docs = "creates a `" ++ fieldname ++ "`." - ft = FuncTy tys generic StaticLifetimeTy + docs = "creates a `" ++ fieldname ++ "`." + ft = FuncTy tys generic StaticLifetimeTy binderPath = SymPath (TC.getFullPath candidate) fieldname - t = (FuncTy tys (VarTy "p") StaticLifetimeTy) - decl = \(FuncTy _ concrete _) -> tokensForCaseInitDecl generic concrete field - body = \(FuncTy _ concrete _) -> tokensForCaseInit alloc generic concrete field + t = (FuncTy tys (VarTy "p") StaticLifetimeTy) + decl = \(FuncTy _ concrete _) -> tokensForCaseInitDecl generic concrete field + body = \(FuncTy _ concrete _) -> tokensForCaseInit alloc generic concrete field deps tenv env = \(FuncTy _ concrete _) -> either (const []) id (concretizeType tenv env concrete) temp = TemplateCreator $ \tenv env -> Template t decl body (deps tenv env) in defineTypeParameterizedTemplate temp binderPath ft docs @@ -169,29 +166,29 @@ binderForStrOrPrn candidate strOrPrn = binderP = SymPath (TC.getFullPath candidate) strOrPrn binderT = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] StringTy StaticLifetimeTy in Right $ - if isTypeGeneric (TC.toType candidate) - then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, []) - else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc + if isTypeGeneric (TC.toType candidate) + then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc where strGenerator :: TG.TemplateGenerator TC.TypeCandidate strGenerator = TG.mkTemplateGenerator genT decl body deps genT :: TG.TypeGenerator TC.TypeCandidate - genT GeneratorArg{value} = + genT GeneratorArg {value} = FuncTy [RefTy (TC.toType value) (VarTy "q")] StringTy StaticLifetimeTy decl :: TG.TokenGenerator TC.TypeCandidate - decl GeneratorArg{instanceT=(FuncTy [RefTy ty _] _ _)} = + decl GeneratorArg {instanceT = (FuncTy [RefTy ty _] _ _)} = toTemplate $ "String $NAME(" ++ tyToCLambdaFix ty ++ " *p)" decl _ = toTemplate "/* template error! */" body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} = tokensForStr tenv env originalT ty (TC.getFields value) body _ = toTemplate "/* template error! */" deps :: TG.DepenGenerator TC.TypeCandidate - deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} = depsForStr tenv env originalT ty (TC.getFields value) deps _ = [] @@ -217,12 +214,12 @@ binderForDelete candidate = decl _ = toTemplate "void $NAME($p p)" body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [ty] _ _), value} = + body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [ty] _ _), value} = tokensForDeleteBody tenv env originalT ty (TC.getFields value) body _ = toTemplate "/* template error! */" deps :: TG.DepenGenerator TC.TypeCandidate - deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [ty] _ _), value} = + deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [ty] _ _), value} = depsForDelete tenv env originalT ty (TC.getFields value) deps _ = [] @@ -230,7 +227,7 @@ binderForDelete candidate = binderForCopy :: BinderGenDeps binderForCopy candidate = let t = TC.toType candidate - doc = "copies a `" ++ (TC.getName candidate) ++ "`." + doc = "copies a `" ++ (TC.getName candidate) ++ "`." binderT = FuncTy [RefTy t (VarTy "q")] t StaticLifetimeTy binderP = SymPath (TC.getFullPath candidate) "copy" in Right $ @@ -248,12 +245,12 @@ binderForCopy candidate = decl _ = toTemplate "$p $NAME($p* pRef)" body :: TG.TokenGenerator TC.TypeCandidate - body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} = tokensForSumtypeCopy tenv env originalT ty (TC.getFields value) body _ = toTemplate "/* template error! */" deps :: TG.DepenGenerator TC.TypeCandidate - deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} = depsForCopy tenv env originalT ty (TC.getFields value) deps _ = [] @@ -261,7 +258,8 @@ binderForCopy candidate = -- Token and dep generators type TokenGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] -type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] + +type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] -------------------------------------------------------------------------------- -- Initializers @@ -269,7 +267,7 @@ type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] -- | Generate an init function declaration. tokensForCaseInitDecl :: Ty -> Ty -> TC.TypeField -> [Token] tokensForCaseInitDecl orig concrete@(StructTy (ConcreteNameTy _) _) (TC.SumField _ tys) = - let mappings = unifySignatures orig concrete + let mappings = unifySignatures orig concrete concreteTys = map (replaceTyVars mappings) tys in toTemplate ("$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit concreteTys)) ++ ")") tokensForCaseInitDecl _ _ _ = @@ -279,24 +277,25 @@ tokensForCaseInitDecl _ _ _ = -- concrete type and a sum type field, generate an init function body. tokensForCaseInit :: AllocationMode -> Ty -> Ty -> TC.TypeField -> [Token] tokensForCaseInit alloc orig concrete (TC.SumField fieldname tys) = - let mappings = unifySignatures orig concrete + let mappings = unifySignatures orig concrete concreteTys = map (replaceTyVars mappings) tys unitless = zip anonMemberNames $ remove isUnit concreteTys in multilineTemplate - [ "$DECL {", - allocate alloc, - joinLines (assign alloc fieldname . fst <$> unitless), - " instance._tag = " ++ tagName concrete fieldname ++ ";", - " return instance;", - "}" - ] - where allocate :: AllocationMode -> String - allocate StackAlloc = " $p instance;" - allocate HeapAlloc = " $p instance = CARP_MALLOC(sizeof(" ++ show concrete ++ "));" - - assign :: AllocationMode -> String -> String -> String - assign alloc' name member = - " instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";" + [ "$DECL {", + allocate alloc, + joinLines (assign alloc fieldname . fst <$> unitless), + " instance._tag = " ++ tagName concrete fieldname ++ ";", + " return instance;", + "}" + ] + where + allocate :: AllocationMode -> String + allocate StackAlloc = " $p instance;" + allocate HeapAlloc = " $p instance = CARP_MALLOC(sizeof(" ++ show concrete ++ "));" + + assign :: AllocationMode -> String -> String -> String + assign alloc' name member = + " instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";" tokensForCaseInit _ _ _ _ = error "tokenForCaseInit" accessor :: AllocationMode -> String @@ -352,30 +351,32 @@ tokensForDeleteBody :: TokenGen tokensForDeleteBody tenv env generic concrete fields = let mappings = unifySignatures generic concrete concreteFields = replaceGenericTypesOnCases mappings fields - in multilineTemplate [ - "$DECL {", - concatMap deleteCase (zip concreteFields (True : repeat False)), - "}" - ] - where deleteCase :: (TC.TypeField, Bool) -> String - deleteCase (theCase, isFirstCase) = - let (name, tys, correctedTagName) = namesFromCase theCase concrete - in unlines - [ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {", - joinLines $ memberDeletion tenv env <$> unionMembers name tys, - " }" - ] + in multilineTemplate + [ "$DECL {", + concatMap deleteCase (zip concreteFields (True : repeat False)), + "}" + ] + where + deleteCase :: (TC.TypeField, Bool) -> String + deleteCase (theCase, isFirstCase) = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {", + joinLines $ memberDeletion tenv env <$> unionMembers name tys, + " }" + ] -- | Generates deps for the body of a delete function. depsForDelete :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] depsForDelete tenv env generic concrete fields = - let mappings = unifySignatures generic concrete + let mappings = unifySignatures generic concrete concreteFields = replaceGenericTypesOnCases mappings fields in if isTypeGeneric concrete then [] - else concatMap - (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged tenv env) (concatMap (TC.fieldTypes) concreteFields)) + else + concatMap + (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) + (filter (isManaged tenv env) (concatMap (TC.fieldTypes) concreteFields)) -------------------------------------------------------------------------------- -- Str and prn @@ -409,32 +410,31 @@ tokensForStr typeEnv env generic concrete fields = " return buffer;", "}" ] - where strCase :: TC.TypeField -> String - strCase theCase = - let (name, tys, correctedTagName) = namesFromCase theCase concrete - in unlines - [ " if(p->_tag == " ++ correctedTagName ++ ") {", - " sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");", - " bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n", - joinLines $ memberPrn typeEnv env <$> unionMembers name tys, - " bufferPtr--;", - " sprintf(bufferPtr, \")\");", - " }" - ] - - -- | Figure out how big the string needed for the string representation of the struct has to be. - calculateStructStrSize :: [TC.TypeField] -> String - calculateStructStrSize cases = " int size = 1;\n" ++ concatMap strSizeCase cases - - strSizeCase :: TC.TypeField -> String - strSizeCase theCase = - let (name, tys, correctedTagName) = namesFromCase theCase concrete - in unlines - [ " if(p->_tag == " ++ correctedTagName ++ ") {", - " size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");", - joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys, - " }" - ] + where + strCase :: TC.TypeField -> String + strCase theCase = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " if(p->_tag == " ++ correctedTagName ++ ") {", + " sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");", + " bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n", + joinLines $ memberPrn typeEnv env <$> unionMembers name tys, + " bufferPtr--;", + " sprintf(bufferPtr, \")\");", + " }" + ] + calculateStructStrSize :: [TC.TypeField] -> String + calculateStructStrSize cases = " int size = 1;\n" ++ concatMap strSizeCase cases + + strSizeCase :: TC.TypeField -> String + strSizeCase theCase = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " if(p->_tag == " ++ correctedTagName ++ ") {", + " size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");", + joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys, + " }" + ] -------------------------------------------------------------------------------- -- Additional utilities diff --git a/src/TemplateGenerator.hs b/src/TemplateGenerator.hs index 5a68bc20f..2d722fc1c 100644 --- a/src/TemplateGenerator.hs +++ b/src/TemplateGenerator.hs @@ -3,8 +3,8 @@ module TemplateGenerator where import Obj -import Types import qualified TypeCandidate as TC +import Types -------------------------------------------------------------------------------- -- Template Generators @@ -12,36 +12,39 @@ import qualified TypeCandidate as TC -- Template generators define a standardized way to construct templates given a fixed set of arguments. -- | GeneratorArg is an argument to a template generator. -data GeneratorArg a = GeneratorArg { - tenv :: TypeEnv, - env :: Env, - originalT :: Ty, - instanceT :: Ty, - value :: a -} +data GeneratorArg a = GeneratorArg + { tenv :: TypeEnv, + env :: Env, + originalT :: Ty, + instanceT :: Ty, + value :: a + } + +type TypeGenerator a = GeneratorArg a -> Ty -type TypeGenerator a = GeneratorArg a -> Ty type TokenGenerator a = GeneratorArg a -> [Token] + type DepenGenerator a = GeneratorArg a -> [XObj] -data TemplateGenerator a = TemplateGenerator { - genT :: TypeGenerator a, - decl :: TokenGenerator a, - body :: TokenGenerator a, - deps :: DepenGenerator a -} +data TemplateGenerator a = TemplateGenerator + { genT :: TypeGenerator a, + decl :: TokenGenerator a, + body :: TokenGenerator a, + deps :: DepenGenerator a + } mkTemplateGenerator :: TypeGenerator a -> TokenGenerator a -> TokenGenerator a -> DepenGenerator a -> TemplateGenerator a mkTemplateGenerator f g h j = TemplateGenerator f g h j generateConcreteTypeTemplate :: TC.TypeCandidate -> TemplateGenerator TC.TypeCandidate -> Template generateConcreteTypeTemplate candidate gen = - let arg = GeneratorArg - (TC.getTypeEnv candidate) - (TC.getValueEnv candidate) - (TC.toType candidate) - (TC.toType candidate) - candidate + let arg = + GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + candidate t = (genT gen) $ arg d = (\tt -> (decl gen) $ (arg {instanceT = tt})) b = (\tt -> (body gen) $ (arg {instanceT = tt})) @@ -50,12 +53,13 @@ generateConcreteTypeTemplate candidate gen = generateConcreteFieldTemplate :: TC.TypeCandidate -> TC.TypeField -> TemplateGenerator TC.TypeField -> Template generateConcreteFieldTemplate candidate field gen = - let arg = GeneratorArg - (TC.getTypeEnv candidate) - (TC.getValueEnv candidate) - (TC.toType candidate) - (TC.toType candidate) - field + let arg = + GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + field t = (genT gen) $ arg d = (\tt -> (decl gen) $ (arg {instanceT = tt})) b = (\tt -> (body gen) $ (arg {instanceT = tt})) @@ -64,12 +68,13 @@ generateConcreteFieldTemplate candidate field gen = generateGenericFieldTemplate :: TC.TypeCandidate -> TC.TypeField -> TemplateGenerator TC.TypeField -> TemplateCreator generateGenericFieldTemplate candidate field gen = - let arg = GeneratorArg - (TC.getTypeEnv candidate) - (TC.getValueEnv candidate) - (TC.toType candidate) - (TC.toType candidate) - field + let arg = + GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + field t = (genT gen) arg in TemplateCreator $ \tenv env -> @@ -81,12 +86,13 @@ generateGenericFieldTemplate candidate field gen = generateGenericTypeTemplate :: TC.TypeCandidate -> TemplateGenerator TC.TypeCandidate -> TemplateCreator generateGenericTypeTemplate candidate gen = - let arg = GeneratorArg - (TC.getTypeEnv candidate) - (TC.getValueEnv candidate) - (TC.toType candidate) - (TC.toType candidate) - candidate + let arg = + GeneratorArg + (TC.getTypeEnv candidate) + (TC.getValueEnv candidate) + (TC.toType candidate) + (TC.toType candidate) + candidate t = (genT gen) arg in TemplateCreator $ \tenv env -> diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs index c00e4192d..7c41e9652 100644 --- a/src/TypeCandidate.hs +++ b/src/TypeCandidate.hs @@ -2,33 +2,33 @@ -- -- Type candidates can either be valid or invalid. Invalid type candidates will be rejected by the type system. module TypeCandidate - (mkStructCandidate, - mkSumtypeCandidate, - TypeVarRestriction(..), - InterfaceConstraint(..), - TypeField(..), - TypeMode(..), - getFields, - TypeCandidate.getName, - getRestriction, - getVariables, - TypeCandidate.getTypeEnv, - getConstraints, - getValueEnv, - getMode, - TypeCandidate.getPath, - getFullPath, - fieldName, - fieldTypes, - setRestriction, - toType, - TypeCandidate, + ( mkStructCandidate, + mkSumtypeCandidate, + TypeVarRestriction (..), + InterfaceConstraint (..), + TypeField (..), + TypeMode (..), + getFields, + TypeCandidate.getName, + getRestriction, + getVariables, + TypeCandidate.getTypeEnv, + getConstraints, + getValueEnv, + getMode, + TypeCandidate.getPath, + getFullPath, + fieldName, + fieldTypes, + setRestriction, + toType, + TypeCandidate, ) where -import Types -import TypeError import Obj +import TypeError +import Types import Util -------------------------------------------------------------------------------- @@ -37,12 +37,13 @@ import Util data TypeVarRestriction = AllowAny | OnlyNamesInScope - deriving Eq + deriving (Eq) -data InterfaceConstraint = InterfaceConstraint { - name :: String, - types :: Ty -} deriving Show +data InterfaceConstraint = InterfaceConstraint + { name :: String, + types :: Ty + } + deriving (Show) data TypeField = StructField String Ty @@ -54,17 +55,17 @@ data TypeMode | Sum deriving (Eq, Show) -data TypeCandidate = TypeCandidate { - typeName :: String, - variables :: [Ty], - members :: [TypeField], - restriction :: TypeVarRestriction, - constraints :: [InterfaceConstraint], - typeEnv :: TypeEnv, - valueEnv :: Env, - mode :: TypeMode, - path :: [String] -} +data TypeCandidate = TypeCandidate + { typeName :: String, + variables :: [Ty], + members :: [TypeField], + restriction :: TypeVarRestriction, + constraints :: [InterfaceConstraint], + typeEnv :: TypeEnv, + valueEnv :: Env, + mode :: TypeMode, + path :: [String] + } -------------------------------------------------------------------------------- -- Private @@ -137,17 +138,18 @@ fieldTypes (SumField _ ts) = ts mkStructCandidate :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> [String] -> Either TypeError TypeCandidate mkStructCandidate tname vars tenv env memberxs ps = let typedMembers = mapM mkStructField (pairwise memberxs) - candidate = TypeCandidate { - typeName = tname, - variables = vars, - members = [], - restriction = OnlyNamesInScope, - constraints = [], - typeEnv = tenv, - valueEnv = env, - mode = Struct, - path = ps - } + candidate = + TypeCandidate + { typeName = tname, + variables = vars, + members = [], + restriction = OnlyNamesInScope, + constraints = [], + typeEnv = tenv, + valueEnv = env, + mode = Struct, + path = ps + } in if even (length memberxs) then fmap (setMembers candidate) typedMembers else Left (UnevenMembers memberxs) @@ -156,17 +158,18 @@ mkStructCandidate tname vars tenv env memberxs ps = mkSumtypeCandidate :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> [String] -> Either TypeError TypeCandidate mkSumtypeCandidate tname vars tenv env memberxs ps = let typedMembers = mapM mkSumField memberxs - candidate = TypeCandidate { - typeName = tname, - variables = vars, - members = [], - restriction = OnlyNamesInScope, - constraints = [], - typeEnv = tenv, - valueEnv = env, - mode = Sum, - path = ps - } + candidate = + TypeCandidate + { typeName = tname, + variables = vars, + members = [], + restriction = OnlyNamesInScope, + constraints = [], + typeEnv = tenv, + valueEnv = env, + mode = Sum, + path = ps + } in fmap (setMembers candidate) typedMembers toType :: TypeCandidate -> Ty diff --git a/src/Validate.hs b/src/Validate.hs index 75e41fd9e..b98c4ec1f 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -4,11 +4,11 @@ import Control.Monad (foldM) import Data.List (nubBy, (\\)) import qualified Env as E import Obj +import qualified Reify as R +import qualified TypeCandidate as TC import TypeError import TypePredicates import Types -import qualified TypeCandidate as TC -import qualified Reify as R -------------------------------------------------------------------------------- -- Public @@ -16,9 +16,10 @@ import qualified Reify as R -- | Determine whether a given type candidate is a valid type. validateType :: TC.TypeCandidate -> Either TypeError () validateType candidate = - do checkDuplicateMembers candidate - checkMembers candidate - checkKindConsistency candidate + do + checkDuplicateMembers candidate + checkMembers candidate + checkKindConsistency candidate -------------------------------------------------------------------------------- -- Private @@ -36,16 +37,16 @@ checkDuplicateMembers candidate = -- | Returns an error if one of the types fields can't be used as a member type. checkMembers :: TC.TypeCandidate -> Either TypeError () checkMembers candidate = - let tenv = TC.getTypeEnv candidate - env = TC.getValueEnv candidate - tys = concat (map TC.fieldTypes (TC.getFields candidate)) - in mapM_ (canBeUsedAsMemberType (TC.getName candidate) (TC.getRestriction candidate) tenv env (TC.getVariables candidate)) tys + let tenv = TC.getTypeEnv candidate + env = TC.getValueEnv candidate + tys = concat (map TC.fieldTypes (TC.getFields candidate)) + in mapM_ (canBeUsedAsMemberType (TC.getName candidate) (TC.getRestriction candidate) tenv env (TC.getVariables candidate)) tys -- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds. checkKindConsistency :: TC.TypeCandidate -> Either TypeError () checkKindConsistency candidate = let allFieldTypes = concat (map TC.fieldTypes (TC.getFields candidate)) - allGenerics = filter isTypeGeneric $ allFieldTypes + allGenerics = filter isTypeGeneric $ allFieldTypes in case areKindsConsistent allGenerics of Left var -> Left (InconsistentKinds var (map R.reify allFieldTypes)) _ -> pure () From ebdcd9b1bb575434a1ef1d58140b88c56f7739d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Wed, 22 Dec 2021 22:25:07 +0100 Subject: [PATCH 16/59] build: Release 0.5.4 --- CHANGELOG.md | 22 ++++++++++++++++++++++ CarpHask.cabal | 2 +- README.md | 2 +- app/Main.hs | 2 +- docs/ReleaseChecklist.md | 3 ++- 5 files changed, 27 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5805a43e3..6c65a599f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,25 @@ +# 0.5.4 +- refactor: Add type candidates and template generators (#1361) +- fix: Ensure registered types with fields emit path (#1364) +- fix: Permit registering types in modules (#1362) +- feat: Add box type (#1358) +- feat: Add bytes->hex-string (#1354) +- feat: Add flag to always output C id with headerparse (#1353) +- docs: Add documentation to core expressions (#1350) (#1352) +- test: Add match given-away value error test (#1351) +- fix: Don't emit Unit type the casts (#1349) +- fix: Bug fixes for #1064 and #843 (#1321) +- fix: Don't hang on module expansions (#1340) +- feat: Add `scan` functions (#1339) +- fix: Don't pass 'If' to InvalidObj when Obj actually is 'Mod' (#1327) +- feat: Register-type improvements (#1332) +- fix: Update ControlMacros.carp (#1336) +- fix: Categorize static calls correctly (#1322) +- docs: Fix typo in Macros.md (#1331) +- docs: Update Install.md (#1324) +- feat: Add assignment operator macros (#1320) +- feat: Add compiler error on maximum sumtype constructors (#1319) + # 0.5.3 - ci: Merges different platform releases into one (#1313) - feat: Add Dynamic.List.find-index (#1316) diff --git a/CarpHask.cabal b/CarpHask.cabal index 061af81bc..d2fd72e11 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -1,5 +1,5 @@ name: CarpHask -version: 0.5.3.0 +version: 0.5.4.0 -- synopsis: -- description: homepage: https://github.com/eriksvedang/Carp diff --git a/README.md b/README.md index 2593df502..528487e02 100644 --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ WARNING! This is a research project and a lot of information here might become outdated and misleading without any explanation. Don't use it for anything important just yet! -[Version 0.5.3 of the language is out!](https://github.com/carp-lang/Carp/releases/) +[Version 0.5.4 of the language is out!](https://github.com/carp-lang/Carp/releases/) ## About diff --git a/app/Main.hs b/app/Main.hs index cd298c7c9..fb0973b81 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -144,7 +144,7 @@ main = do >>= execStrs "Postload" postloads >>= \ctx -> case execMode of Repl -> do - putStrLn "Welcome to Carp 0.5.3" + putStrLn "Welcome to Carp 0.5.4" putStrLn "This is free software with ABSOLUTELY NO WARRANTY." putStrLn "Evaluate (help) for more information." snd <$> runRepl ctx diff --git a/docs/ReleaseChecklist.md b/docs/ReleaseChecklist.md index b9c2fc7b8..13fc679ca 100644 --- a/docs/ReleaseChecklist.md +++ b/docs/ReleaseChecklist.md @@ -21,7 +21,8 @@ See [CHANGELOG.md](../CHANGELOG.md) # 5. Make a commit on master ```bash -$ git commit -m "Release X.Y.Z" +$ git add . +$ git commit -m "build: Release X.Y.Z" ``` # 6. Tag the commit and push it From 90f45835e715c202c2605e072eacce0265b2231f Mon Sep 17 00:00:00 2001 From: IrrenWirr <85679298+IrrenWirr@users.noreply.github.com> Date: Thu, 30 Dec 2021 14:02:36 +0000 Subject: [PATCH 17/59] docs: Instructions to ensure correct handling of utf-8 (#1367) --- docs/Install.md | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/docs/Install.md b/docs/Install.md index b51a1300a..4fa2742ab 100644 --- a/docs/Install.md +++ b/docs/Install.md @@ -29,6 +29,20 @@ You should now be able to start Carp from anywhere: $ carp ``` +## Ensuring an UTF-8 aware LC_CTYPE locale in POSIX environments + +To be able to handle UTF-8 correctly when using `carp`'s interactive repl (binaries from `carp` always handle UTF-8 correctly), +all POSIX aware environments (Linux, MacOs or even Emacs's eshell inside a Windows 10) +need to have an `LC_CTYPE` environment variable set and exported to an UTF-8 aware value. + +For example, add this to your `.bashrc` or similar: +```bash +export LC_CTYPE=C.UTF-8 +``` +Take into account that the the environment variable `LC_ALL`, when set, overrides the value of `LC_CTYPE`. +So you may want to `unset` `LC_ALL` or to set and export it to an UTF-8 aware value. +You can see the values of `LC_ALL` and `LC_CTYPE` with the command `locale`. + ## C compiler The `carp` executable will emit a single file with C code, `main.c` and try to compile it using an external C compiler. @@ -59,3 +73,7 @@ Please let us know if you have trouble getting these bindings to work! We have t ## Footnote for Windows You can install clang with mingw64 but you'll also want to run `vcvarsall.bat amd64` or `vcvarsall.bat x86` each time you start your shell to help clang find the right headers. See https://github.com/carp-lang/Carp/issues/700 or https://github.com/carp-lang/Carp/issues/1323 for more information. + +Also when compiling files with `carp` from Windows you must ensure that : +* the file is encoded either as ANSI or UTF-8. (Using another encoding like UTF-8-BOM doesn't work.) +* using either Unix (LF) or Windows (CR LF) as linefeed/newline. (Using Macintosh (CR) as newline doesn't work.) From d729636f94b889a64c71004d7cb9d1cbb5dc3dbd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Mon, 3 Jan 2022 20:50:52 +0100 Subject: [PATCH 18/59] chore: try to randomly bump cachix/install-nix-action to v15 --- .github/workflows/nixpkgs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/nixpkgs.yml b/.github/workflows/nixpkgs.yml index ec980b4c6..21cbde1b3 100644 --- a/.github/workflows/nixpkgs.yml +++ b/.github/workflows/nixpkgs.yml @@ -12,7 +12,7 @@ jobs: os: [macos-latest, ubuntu-latest] steps: - uses: actions/checkout@v2.3.4 - - uses: cachix/install-nix-action@v12 + - uses: cachix/install-nix-action@v15 with: nix_path: nixpkgs=channel:nixos-20.09 - run: nix-build From 3522b0ad982006cd3ea577d1f23d8f033a0cad96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Mon, 3 Jan 2022 21:00:28 +0100 Subject: [PATCH 19/59] chore: try using ubuntu instead of macOS to run Nix --- .github/workflows/nixpkgs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/nixpkgs.yml b/.github/workflows/nixpkgs.yml index 21cbde1b3..b09f8ef0a 100644 --- a/.github/workflows/nixpkgs.yml +++ b/.github/workflows/nixpkgs.yml @@ -9,7 +9,7 @@ jobs: runs-on: ${{ matrix.os }} strategy: matrix: - os: [macos-latest, ubuntu-latest] + os: [ubuntu-latest] steps: - uses: actions/checkout@v2.3.4 - uses: cachix/install-nix-action@v15 From e34197bde0359dbd911cb931df48bff508bbba9c Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Sun, 9 Jan 2022 09:44:55 -0500 Subject: [PATCH 20/59] fix: fix type signature of Array.unsafe-raw (#1375) The Ref in the type signature had the array and lifetime type in the incorrect position. --- src/ArrayTemplates.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/ArrayTemplates.hs b/src/ArrayTemplates.hs index dd5c0fa3c..2cf8e325b 100644 --- a/src/ArrayTemplates.hs +++ b/src/ArrayTemplates.hs @@ -282,8 +282,7 @@ templateUnsafeRaw :: (String, Binder) templateUnsafeRaw = defineTemplate (SymPath ["Array"] "unsafe-raw") - -- TODO: Fix me! Order of members of Ref is incorrect. - (FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy) + (FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q")] (PointerTy (VarTy "t")) StaticLifetimeTy) "returns an array `a` as a raw pointer—useful for interacting with C." (toTemplate "$t* $NAME (Array* a)") (toTemplate "$DECL { return a->data; }") From 330dc52308c157c9c833b157cf0eb29dd9ca8327 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Sun, 9 Jan 2022 14:45:32 +0000 Subject: [PATCH 21/59] fix: Fixes nix install by using correct pkg-configDepends config key (#1372) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * fix: Fixes nix install by using correct pkg-configDepends config key As reported by Hrafn Blóðbók, nix updated references to pkgconfig in its codebase to use the `pkg-config` spelling, this seems to break the installation of Carp using nix. See this PR: https://github.com/NixOS/nixpkgs/commit/9bb3fccb5b55326cb3c2c507464a8a28d44d1730 * ci: Uses 21.05 release of nix to be compatible with pkg-config changes --- .github/workflows/nixpkgs.yml | 4 ++-- default.nix | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/nixpkgs.yml b/.github/workflows/nixpkgs.yml index b09f8ef0a..2c296e179 100644 --- a/.github/workflows/nixpkgs.yml +++ b/.github/workflows/nixpkgs.yml @@ -12,7 +12,7 @@ jobs: os: [ubuntu-latest] steps: - uses: actions/checkout@v2.3.4 - - uses: cachix/install-nix-action@v15 + - uses: cachix/install-nix-action@v16 with: - nix_path: nixpkgs=channel:nixos-20.09 + nix_path: nixpkgs=channel:nixos-21.05 - run: nix-build diff --git a/default.nix b/default.nix index e1421c2f2..2179c0071 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ let cabal-install clang gdb ormolu hlint flamegraph ghc-prof-flamegraph ] ++ lib.optionals stdenv.isLinux [ linuxPackages.perf tinycc zig ]; - pkgconfigDepends = [ SDL2 SDL2_image SDL2_mixer SDL2_ttf glfw ]; + pkg-configDepends = [ SDL2 SDL2_image SDL2_mixer SDL2_ttf glfw ]; enableLibraryProfiling = profiling; enableExecutableProfiling = profiling; enableSharedLibraries = false; From 027d8b32787fd9c4a1819d44a21452c90b62a6a8 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Mon, 10 Jan 2022 11:32:11 +0100 Subject: [PATCH 22/59] fix: #1347 by ignoring generically typed symbols on printing C (#1373) * fix: #1347 by introducing predicate * fix: simplify emission check in primitives (thanks @eriksvedang) --- src/Primitives.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Primitives.hs b/src/Primitives.hs index e555b56e1..c10cf8432 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -9,7 +9,7 @@ import Control.Applicative import Control.Monad (foldM, unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bifunctor -import Data.Either (fromRight, rights) +import Data.Either (fromRight, isRight, rights) import Data.Functor ((<&>)) import Data.List (foldl') import Data.Maybe (fromJust, fromMaybe) @@ -182,10 +182,12 @@ define hidden ctx qualifiedXObj = defineInTypeEnv = pure . fromRight ctx . (insertTypeBinder ctx qpath) defineInGlobalEnv :: Binder -> IO Context defineInGlobalEnv newBinder = - when (projectEchoC (contextProj ctx)) (putStrLn (toC All (Binder emptyMeta annXObj))) + when (projectEchoC (contextProj ctx) && canBeEmitted annXObj) (putStrLn (toC All (Binder emptyMeta annXObj))) >> case (lookupBinderInGlobalEnv ctx qpath) of Left _ -> pure (fromRight ctx (insertInGlobalEnv ctx qpath newBinder)) Right oldBinder -> redefineExistingBinder oldBinder newBinder + canBeEmitted :: XObj -> Bool + canBeEmitted x = isRight (checkForUnresolvedSymbols x) redefineExistingBinder :: Binder -> Binder -> IO Context redefineExistingBinder old@(Binder meta _) (Binder _ x) = do From bd653ad6e66e388ddc9275061332bc5b123619f9 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Mon, 24 Jan 2022 13:05:27 +0100 Subject: [PATCH 23/59] fix: fix leading % format in fmt (#1380) --- core/Format.carp | 2 +- test/format.carp | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/core/Format.carp b/core/Format.carp index 0551974de..a8f7dab27 100644 --- a/core/Format.carp +++ b/core/Format.carp @@ -14,7 +14,7 @@ (if (= \% (String.char-at s (inc idx))) ; this is an escaped % `(ref (String.append - "%" + %(String.slice s 0 (inc idx)) %(fmt-internal (String.slice s (+ idx 2) len) args))) (if (= 0 (length args)) ; we need to insert something, but have nothing (macro-error diff --git a/test/format.carp b/test/format.carp index e3da76709..d88753c72 100644 --- a/test/format.carp +++ b/test/format.carp @@ -34,6 +34,10 @@ "10 % 12.0 yay" &(fmt "%d %% %.1f %s" 10 12.0 "yay") "fmt macro works") + (assert-equal test + "hi % 12.0" + &(fmt "hi %% %.1f" 12.0) + "fmt macro works with leading % (regression test)") (assert-equal test "1 [2 3] h" &(let [x 1 From 6f120b0e75fca23fdeb869c9581289cd87ee7bd1 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 24 Jan 2022 07:06:32 -0500 Subject: [PATCH 24/59] fix: mangle field names in setter templates (#1379) * fix: mangle field names in setter templates This fixes a regression whereby the names of struct fields weren't mangled in calls to setters/mutators, resulting in invalid C code if the user happened to use reserved words in their struct field names such as "short" or a disallowed character like a dash. * test: check struct field name mangle regression This test ensures struct field names are mangled correctly in C output. --- src/Deftype.hs | 4 ++-- test/regression.carp | 12 ++++++++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Deftype.hs b/src/Deftype.hs index ecb5e67d2..6987fc2f3 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -288,7 +288,7 @@ setterGenerator = TG.mkTemplateGenerator tgen decl body deps body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} = multilineTemplate [ "$DECL {", - memberDeletion tenv env (name, ty), + memberDeletion tenv env (mangle name, ty), " p." ++ (mangle name) ++ " = newValue;", " return p;", "}\n" @@ -319,7 +319,7 @@ mutatorGenerator = TG.mkTemplateGenerator tgen decl body deps body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} = multilineTemplate [ "$DECL {", - memberRefDeletion tenv env (name, ty), + memberRefDeletion tenv env (mangle name, ty), " pRef->" ++ mangle name ++ " = newValue;", "}\n" ] diff --git a/test/regression.carp b/test/regression.carp index 6d0ba14f4..fbe19bdb8 100644 --- a/test/regression.carp +++ b/test/regression.carp @@ -100,6 +100,13 @@ (defn poly-nest-two [x] (Bar.Qux.init (Bar.Baz x))) (defn poly-nest-three [x] (PolyNest (Bar.Baz x))) +;; struct field names are mangled correctly (#1378) +(deftype Mangled + [short Int ;; c reserved word + default-value String ;; invalid var name symbol (-) + ] + ) + (deftest test (assert-equal test 1 @@ -160,4 +167,9 @@ @(Bar.Baz.it (PolyNest.it &(poly-nest-three 2))) "test that polymorphic types in modules can be referred to using other types outside the module") + (assert-equal test + "bar" + (Mangled.default-value &(Mangled.set-default-value (Mangled.init 0 @"foo") + @"bar")) + "struct field names are mangled correctly") ) From 3148703a224f0f646ca8fff18e7605671f2af839 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 14 Feb 2022 03:31:13 -0500 Subject: [PATCH 25/59] feat: add Dynamic.String.to-array (#1382) * feat: add Dynamic.String.to-array Adds a new dynamic function that converts a string to an array of strings, one for each character in the string. In other words, it's the same as Dynamic.String.to-list but the result is an array structure instead of a list. It's also significantly faster than to-list on large inputs. The current implementation of Dynamic.String.to-list takes long to process large inputs, presumably because of its recursive behavior and multiple calls to cons (I'm currently investigating this) (e.g. use read-file then try calling to-list, you may need to wait a while). Contrarily, to-array is nearly instantaneous even when the input string is large. This is because it leverages Haskell's `splitOn` directly, which, when given an empty delimiter, (which is the case for the empty string), splits the entire input sequence. Because "" is the empty list for a string in Haskell's representation, calling split-on with "" results in the splitting behavior. The output also includes the delimiting case, so we drop it using cdr. * test: add test for Dynamic.String.to-array --- core/String.carp | 5 +++++ test/macros.carp | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/core/String.carp b/core/String.carp index e4e02eea9..d82917b46 100644 --- a/core/String.carp +++ b/core/String.carp @@ -515,6 +515,11 @@ (if (String.empty? s) '() (cons (String.head s) (String.to-list (String.tail s))))) + + (doc to-array + "Converts a string to an array of strings of each of its characters.") + (defndynamic to-array [s] + (cdr (String.split-on "" s))) ) ) diff --git a/test/macros.carp b/test/macros.carp index e4466ad6e..8b09de412 100644 --- a/test/macros.carp +++ b/test/macros.carp @@ -387,6 +387,10 @@ '("h" "e" "l" "l" "o") (String.to-list "hello") "Dynamic.String.to-list works as expected") + (assert-dynamic-equal test + '["h" "e" "l" "l" "o"] + (String.to-array "hello") + "Dynamic.String.to-array works as expected") (assert-equal test 2 (let-do [src 1 dst 0] From 35edce70cd3dd9e12b8b11b0cfc4d78fd1695498 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Fri, 18 Mar 2022 04:34:45 -0400 Subject: [PATCH 26/59] feat: add c-name meta field (#1398) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * feat: add box templates and box type This commit adds an implementation of Boxes, memory manged heap allocated values. Boxes are implemented as C pointers, with no additional structure but are treated as structs in Carp. To facilitate this, we need to add them as a clause to our special type emissions (TypesToC) as they'd otherwise be emitted like other struct types. Co-authored-by: Veit Heller * fix: slight memory management fix for Box Make sure we free the box! * test: add tests for box (including memory checks) * Revert "fix: Ignore clang nitpick" This reverts commit 70ec6d46d4c636c39dc4d47dc7732421a30a0b3f. * fix: update example/functor.carp Now that a builtin type named Box exists, the definitions in this file cause a conflict. I've renamed the "Box" type in the functor example to remove the conflict. * feat: add Box.peek Box.peek allows users to transform a reference to a box into a a reference to the box's contained value. The returned reference will have the same lifetime as the box. This function allows callers to manipulate the value in a box without re-allocation, for example: ```clojure (deftype Num [val Int]) (let-do [box (Box.init (Num.init 0))] (Num.set-val! (Box.peek &box) 1) @(Num.val (Box.peek &box))) ``` This commit also includes tests for Box.peek. Co-authored-by: TimDeve * feat: add c-name meta key for code emission overrides This commit adds a new special compiler meta key, c-name, that enables users to explicitly c the C identifier Carp should emit for a given symbol. For now, it is only explicitly supported for Def and Defn forms. For example: ```clojure (defn foo-bar [] 2) (c-name foo-bar "foo_bar") ``` Will cause foo-bar in emitted C code to be emitted as `foo_bar` instead of `foo_MINUS_bar`. I've also refactored some of the meta code to be a bit more principled about keys that are understood by the compiler. * docs: update CInterop docs Adds a section on using the c-name meta field to override identifiers exclusively defined in Carp. Also performs some minor editorial. Co-authored-by: Veit Heller Co-authored-by: Erik Svedäng Co-authored-by: TimDeve --- core/Macros.carp | 10 ++++++++++ docs/CInterop.md | 50 ++++++++++++++++++++++++++++++++++++++++++------ src/Emit.hs | 14 ++++++++++---- src/Meta.hs | 43 +++++++++++++++++++++++++++++++++++++++++ src/Qualify.hs | 37 +++++++++++++++++++---------------- 5 files changed, 128 insertions(+), 26 deletions(-) diff --git a/core/Macros.carp b/core/Macros.carp index f6c61af15..b9bf1e331 100644 --- a/core/Macros.carp +++ b/core/Macros.carp @@ -104,6 +104,16 @@ (defmacro private [name] (eval (list 'meta-set! name "private" true))) +(doc c-name + "Override the identifiers Carp generates for a given symbol in C output." + "" + "```" + "(defn foo-bar [] 1)" + "(c-name foo-bar \"foo_bar\")" + "```") +(defmacro c-name [sym cname] + (eval (list 'meta-set! sym "c-name" cname))) + (hidden and-) (defndynamic and- [xs] ; (defndynamic and- [xs] ; shorter but currently not entirely stable diff --git a/docs/CInterop.md b/docs/CInterop.md index 17581a80f..8a811383e 100644 --- a/docs/CInterop.md +++ b/docs/CInterop.md @@ -18,7 +18,6 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide. - [Callbacks](#callbacks) - [Headerparse](#headerparse) - ## How Carp generates identifiers When creating a function or def it might be useful to know what identifier gets @@ -56,8 +55,9 @@ generated on the C side. Here are some examples: ; => print_MINUS_first_MINUS_and_MINUS_add__String_Long ``` -Looking at the examples should be clear enough but let's break it down: -Carp will replace illegal characters in C with a string representation of them +Looking at the examples should help illustrate how Carp transforms identifiers +before producing C code, but let's break it down: Carp will replace illegal +characters in C with a string representation of them (`- => _MINUS_`, `? => _QMARK_`, etc...) If in modules it will prefix the identifier with the modules name. When the arguments to a function are generic it will suffix the types to the @@ -66,9 +66,19 @@ a function is potentially generic but you don't want it to be you can add a non-generic signature to it to make Carp generate your function like in our `true?` example. -When creating bindings to a library it would be hard to coerce this logic into -creating the exact identifiers the library uses, this is why `register` and -`register-type` accepts an optional argument to specify what identifiers to use: +This process is called *mangling* and is necessary to ensure that identifiers +that are valid in Carp but invalid in C don't produce invalid C code. + +### Overriding Carp's default C identifier names + +When creating bindings to an existing C library in Carp, it's inconvenient to +have to replicate C identifiers exactly as they're declared in C. For example, +due to mangling, you couldn't wrap your Carp bindings in a module, since the +resulting identifiers would be prefixed, and probably incorrect. It would be +inconvenient and tedious to have to replicate existing C identifiers exactly +whenever you had to create bindings to an existing library , so, to help with +this, `register` and `register-type` accepts an optional argument to specify +what identifiers to use: ```clojure (defmodule CURL @@ -76,6 +86,34 @@ creating the exact identifiers the library uses, this is why `register` and (register form-free (Fn [(Ref HttpPost)] ()) "curl_formfree")) ``` +This enables you to define whatever structure you want in Carp code (for +example, here we wrap cURL bindings in a CURL module) while ensuring the +emitted identifiers are correct and map to the identifiers used by the existing +C library you're calling. For example, the `form-free` identifier in Carp would +normally be subject to mangling and emitted as `form_MINUS_free`, but the +override argument ensures this identifier is emitted as `curl_formfree` +instead. + +Likewise, you can override the C identifiers Carp generates for code +exclusively defined in Carp. For instance, you may want to migrate +safety-critical code in an existing C program into Carp, then call the +resulting safe C code in your original C program. This can become tedious if +your Carp code utilizes a lot of nested modules, custom types, or special +characters in identifiers. + +You can use the `c-name` meta field to explicitly set the C identifier Carp +generates for a given definition. This can help make your compiled C more +readable and easier to call from other languages. For example, given the +definition and c-name call: + +```clojure +(defn foo-bar [] 2) +(c-name foo-bar "foo_bar") +``` + +Carp will generate a corresponding identifier `foo_bar` in its C output, +instead of the default `foo_MINUS_bar`. + ## Managed types In Carp types like `String` and `Array` are _managed_ types in that they are diff --git a/src/Emit.hs b/src/Emit.hs index 9487b5cb4..814bcadd2 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -306,8 +306,10 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo do appendToSrc (addIndent indent ++ "{\n") let innerIndent = indent + indentAmount + cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta) + fullname = if (null cname) then pathToC path else cname ret <- visit innerIndent expr - when (ret /= "") $ appendToSrc (addIndent innerIndent ++ pathToC path ++ " = " ++ ret ++ ";\n") + when (ret /= "") $ appendToSrc (addIndent innerIndent ++ fullname ++ " = " ++ ret ++ ";\n") delete innerIndent info appendToSrc (addIndent indent ++ "}\n") pure "" @@ -782,16 +784,18 @@ delete indent i = mapM_ deleterToC (infoDelete i) defnToDeclaration :: MetaData -> SymPath -> [XObj] -> Ty -> String defnToDeclaration meta path@(SymPath _ name) argList retTy = - let (XObj (Lst annotations) _ _) = fromMaybe emptyList (Meta.get "annotations" meta) + let override = Meta.getString (Meta.getCompilerKey Meta.CNAME) meta + (XObj (Lst annotations) _ _) = fromMaybe emptyList (Meta.get "annotations" meta) annotationsStr = joinWith " " (map strToC annotations) sep = if not (null annotationsStr) then " " else "" + fullname = if (null override) then (pathToC path) else override in annotationsStr ++ sep ++ if name == "main" then "int main(int argc, char** argv)" else let retTyAsC = tyToCLambdaFix retTy paramsAsC = paramListToC argList - in (retTyAsC ++ " " ++ pathToC path ++ "(" ++ paramsAsC ++ ")") + in (retTyAsC ++ " " ++ fullname ++ "(" ++ paramsAsC ++ ")") where strToC (XObj (Str s) _ _) = s strToC xobj = pretty xobj @@ -895,9 +899,11 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) = in defnToDeclaration meta path argList retTy ++ ";\n" [XObj Def _ _, XObj (Sym path _) _ _, _] -> let Just t = ty + cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta) + fullname = if (null cname) then pathToC path else cname in if (isUnit t) then "" - else tyToCLambdaFix t ++ " " ++ pathToC path ++ ";\n" + else tyToCLambdaFix t ++ " " ++ fullname ++ ";\n" XObj (Deftype t) _ _ : XObj (Sym path _) _ _ : rest -> defStructToDeclaration t path rest XObj (DefSumtype t) _ _ : XObj (Sym _ _) _ _ : rest -> diff --git a/src/Meta.hs b/src/Meta.hs index 8f88a8b86..5eadfe40f 100644 --- a/src/Meta.hs +++ b/src/Meta.hs @@ -8,6 +8,10 @@ module Meta Meta.member, binderMember, hide, + getString, + getCompilerKey, + validateAndSet, + CompilerKey(..), ) where @@ -16,6 +20,41 @@ import qualified Map import Obj import SymPath import Types +import Data.Maybe(fromMaybe) +import Data.Either(fromRight) + +-------------------------------------------------------------------------------- +-- builtin special meta key values +-- These keys, when set, alter the compiler's behavior. + +data CompilerKey = CNAME + +-- Given a compiler key, returns the key name as a string along with a default value. +toKeyValue :: CompilerKey -> (String, XObj) +toKeyValue CNAME = ("c-name", (XObj (Str "") Nothing Nothing)) + +-- | Get the key associated with a compiler Meta key as a string. +getCompilerKey :: CompilerKey -> String +getCompilerKey = fst . toKeyValue + +-- | Special meta KV pairs expect values of a certain XObj form. +-- +-- Returns True for valid values for the given compiler key, False otherwise. +validateCompilerKeyValue :: CompilerKey -> Obj -> Bool +validateCompilerKeyValue CNAME (Str _) = True +validateCompilerKeyValue CNAME _ = False + +-- | Validate and set a compiler key for a given MetaData object. +-- +-- If the key or value is invalid, returns Left containing the original metadata. +-- If the key and value is valid, return Right containing the updated metadata. +validateAndSet :: MetaData -> CompilerKey -> XObj -> Either MetaData MetaData +validateAndSet meta key val + | validateCompilerKeyValue key (xobjObj val) = + Right (set (getCompilerKey key) val meta) + | otherwise = Left meta + +-------------------------------------------------------------------------------- -- | A temporary binder for meta calls on symbols that haven't been declared yet. -- Used in situations such as: @@ -61,3 +100,7 @@ binderMember key binder = Meta.member key $ fromBinder binder hide :: Binder -> Binder hide binder = updateBinderMeta binder "hidden" trueXObj + +-- | Get the value of a string valued meta key. +getString :: String -> MetaData -> String +getString key meta = fromMaybe "" $ fmap (fromRight "" . unwrapStringXObj) (Meta.get key meta) diff --git a/src/Qualify.hs b/src/Qualify.hs index d9f088bc9..d9a09ac48 100644 --- a/src/Qualify.hs +++ b/src/Qualify.hs @@ -27,6 +27,7 @@ import Obj import qualified Set import SymPath import Util +import qualified Meta -------------------------------------------------------------------------------- -- Errors @@ -353,7 +354,7 @@ qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i ) ) >>= \(origin, (e, binder)) -> - resolve (E.prj origin) (E.prj e) (binderXObj binder) + resolve (E.prj origin) (E.prj e) binder >>= pure . Qualified ) <> ((resolveMulti path (E.lookupInUsed localEnv globalEnv path)) >>= pure . Qualified) @@ -362,8 +363,8 @@ qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i <> pure (Qualified xobj) ) where - resolve :: Env -> Env -> XObj -> Either QualificationError XObj - resolve _ _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _) = + resolve :: Env -> Env -> Binder -> Either QualificationError XObj + resolve _ _ (Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) = -- Before we return an interface, double check that it isn't shadowed by a local let-binding. case (E.searchValue localEnv path) of Right (e, Binder _ _) -> @@ -371,25 +372,29 @@ qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i InternalEnv -> pure (XObj (Sym (getPath xobj) (LookupLocal (captureOrNot e localEnv))) i t) _ -> pure (XObj (InterfaceSym name) i t) _ -> pure (XObj (InterfaceSym name) i t) - resolve _ _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _) = + resolve _ _ (Binder _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _)) = pure (XObj (Sym (getPath x) (LookupGlobalOverride overrideName)) i t) - resolve _ _ (XObj (Mod modenv _) _ _) = + resolve _ _ (Binder _ (XObj (Mod modenv _) _ _)) = nakedInit modenv - resolve origin found xobj' = - if (isTypeDef xobj') - then - ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path))) - >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') (binderXObj binder) - ) - else case envMode (E.prj found) of - RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t) - InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t) - ExternalEnv -> pure (XObj (Sym (getPath xobj') (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))) i t) + resolve origin found (Binder meta xobj') = + let cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta) + modality = if (null cname) + then (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj')) + else (LookupGlobalOverride cname) + in if (isTypeDef xobj') + then + ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path))) + >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') binder + ) + else case envMode (E.prj found) of + RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t) + InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t) + ExternalEnv -> pure (XObj (Sym (getPath xobj') modality) i t) resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj resolveMulti _ [] = Left (FailedToFindSymbol xobj) resolveMulti _ [(e, b)] = - resolve (E.prj e) (E.prj e) (binderXObj b) + resolve (E.prj e) (E.prj e) b resolveMulti spath xs = let localOnly = remove (E.envIsExternal . fst) xs paths = map (getModuleSym . (second binderXObj)) xs From 5535fd7e5ccecc6e942d655dc0ce8080304669e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Mon, 21 Mar 2022 08:25:55 +0000 Subject: [PATCH 27/59] ci: Fixes scoop install as admin user (#1399) * ci: Fixes scoop install as admin user * ci: Upgrades Win CI runners to Windows Server 2019 * ci: Disables Debug.sanitize-addresses We're encountering the following error and I can't resolve it: https://github.com/actions/virtual-environments/issues/4978 --- .github/workflows/release.yml | 5 +++-- .github/workflows/windows.yml | 18 +++++++++++------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 4bd734b32..b6b07094e 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -21,7 +21,7 @@ jobs: artefact-name: "x86_64-macos" - os: Windows - runner: windows-latest + runner: windows-2022 artefact-name: "x86_64-windows" steps: @@ -39,7 +39,8 @@ jobs: - if: matrix.os == 'Windows' name: Install Scoop run: | - iwr -useb get.scoop.sh | iex + iwr -useb get.scoop.sh -outfile 'install-scoop.ps1' + ./install-scoop.ps1 -RunAsAdmin echo "~\scoop\shims" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append echo "C:\ProgramData\scoop\shims" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append diff --git a/.github/workflows/windows.yml b/.github/workflows/windows.yml index dca16f922..89716c916 100644 --- a/.github/workflows/windows.yml +++ b/.github/workflows/windows.yml @@ -8,7 +8,7 @@ on: jobs: build: - runs-on: windows-2016 + runs-on: windows-2022 steps: - name: Check out @@ -16,7 +16,8 @@ jobs: - name: Install Scoop run: | - iwr -useb get.scoop.sh | iex + iwr -useb get.scoop.sh -outfile 'install-scoop.ps1' + ./install-scoop.ps1 -RunAsAdmin echo "~\scoop\shims" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append echo "C:\ProgramData\scoop\shims" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append @@ -26,26 +27,29 @@ jobs: - uses: actions/cache@v1 name: Cache stack dependencies with: - path: C:\\Users\\runneradmin\\AppData\\Local\\Programs\\stack + path: C:\Users\runneradmin\AppData\Local\Programs\stack key: ${{ runner.os }}-stack-deps-${{ github.sha }} restore-keys: ${{ runner.os }}-stack-deps - uses: actions/cache@v1 name: Cache stack build with: - path: C:\\Users\\runneradmin\\AppData\\Roaming\\stack\ + path: C:\Users\runneradmin\AppData\Roaming\stack key: ${{ runner.os }}-stack-build-${{ github.sha }} restore-keys: ${{ runner.os }}-stack-build - - name: Install Clang - run: scoop install llvm --global - - name: Build run: stack build - name: Run Compiler Tests run: stack test + # Disabling sanitize-addresses because it fails with following error: + # https://github.com/actions/virtual-environments/issues/4978 + - name: Disable Debug.sanitize-addresses + shell: bash + run: find ./test ./examples -type f -name '*.carp' | xargs sed 's/^\((Debug.sanitize-addresses)\)/; \1/g' -i + - name: Run Carp Tests shell: bash run: ./scripts/run_carp_tests.sh --no_sdl From 55255d31e4d5cc9a7d29400b6dcb94fdc64ef2e9 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 23 Mar 2022 04:10:21 -0400 Subject: [PATCH 28/59] refactor: project configuration get/set parity (#1400) * refactor: project configuration get/set parity This commit refactors our handling of project configuration getters/setters in hopes of making it easier to ensure fields that have getters have setters and vice versa, and to ensure field keys are consistent across the Project.config and get-config commands. This commit also makes these commands return XObjs for all calls, instead of coercing certain things into strings and also adds getters for fields that previously lacked them, e.g.: (Project.get-config "libflags") => ("-lm") I've maintained parity with existing behaviors to avoid breaking changes, thus, this works as it did before this commit: (Project.config "libflags" "-lfoo") (Project.get-config "libflags") => ("-lm" "-lfoo") though it could now arguably take a list as an argument to permit complete one-liner replacements; one could still add a single flag and the interface would be more functional: (Project.config "libflags" (cons "-lfoo" (Project.get-config "libflags"))) => ("-lm" "-lfoo") (Project.config "libflags" ("-lbar" "-qux")) => ("-lbar" "-lqux") But, again, I've retained the old behavior to avoid breaking existing builds. This also fixes a small issue where by setting the file path print length to "full" still resulted in the "short" printing scheme. * fix: small typo fix in config field error messages * fix: restore old names for cflag and libflag config fields I accidentally pluralized these field keys, which broke some existing tests. This commit fixes that issue by restoring the original names. * fix: backwards compatibility for configuration fields Another small fix to ensure we retain backwards compatibility with existing code after recent configuration handling changes: pkg-config and load-stack fields should return array values, not lists. * refactor: move project configuration get/setters into a new module Moves the project configuration frontend code into its own module to avoid cyclic deps between Project and Obj and keep the Obj module clean. I've also removed some noisy comments about "internal only" project configuration fields. --- CarpHask.cabal | 1 + src/Commands.hs | 124 ++------------- src/Obj.hs | 73 +++++---- src/Project.hs | 78 +++++----- src/ProjectConfig.hs | 348 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 451 insertions(+), 173 deletions(-) create mode 100644 src/ProjectConfig.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index d2fd72e11..3d4fd115d 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -47,6 +47,7 @@ library Primitives, PrimitiveError Project, + ProjectConfig, Qualify, Reify, RenderDocs, diff --git a/src/Commands.hs b/src/Commands.hs index 7ad2cb140..c9c51b2e4 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -20,6 +20,7 @@ import Obj import Parsing (parse) import Path import Project +import ProjectConfig import Reify import RenderDocs import System.Directory (makeAbsolute) @@ -109,121 +110,26 @@ presentError msg ret = -- | Command for changing various project settings. commandProjectConfig :: BinaryCommandCallback commandProjectConfig ctx xobj@(XObj (Str key) _ _) value = do - let proj = contextProj ctx - newProj = case key of - "cflag" -> do - cflag <- unwrapStringXObj value - pure (proj {projectCFlags = addIfNotPresent cflag (projectCFlags proj)}) - "libflag" -> do - libflag <- unwrapStringXObj value - pure (proj {projectLibFlags = addIfNotPresent libflag (projectLibFlags proj)}) - "pkgconfigflag" -> do - pkgconfigflag <- unwrapStringXObj value - pure (proj {projectPkgConfigFlags = addIfNotPresent pkgconfigflag (projectPkgConfigFlags proj)}) - "cmod" -> do - cmod <- unwrapStringXObj value - pure (proj {projectCModules = addIfNotPresent cmod (projectCModules proj)}) - "prompt" -> do - prompt <- unwrapStringXObj value - pure (proj {projectPrompt = prompt}) - "search-path" -> do - searchPath <- unwrapStringXObj value - pure (proj {projectCarpSearchPaths = addIfNotPresent searchPath (projectCarpSearchPaths proj)}) - "print-ast" -> do - printAST <- unwrapBoolXObj value - pure (proj {projectPrintTypedAST = printAST}) - "echo-c" -> do - echoC <- unwrapBoolXObj value - pure (proj {projectEchoC = echoC}) - "echo-compiler-cmd" -> do - echoCompilerCmd <- unwrapBoolXObj value - pure (proj {projectEchoCompilationCommand = echoCompilerCmd}) - "compiler" -> do - compiler <- unwrapStringXObj value - pure (proj {projectCompiler = compiler}) - "target" -> do - target <- unwrapStringXObj value - pure (proj {projectTarget = Target target}) - "title" -> do - title <- unwrapStringXObj value - pure (proj {projectTitle = title}) - "output-directory" -> do - outDir <- unwrapStringXObj value - pure (proj {projectOutDir = outDir}) - "docs-directory" -> do - docsDir <- unwrapStringXObj value - pure (proj {projectDocsDir = docsDir}) - "docs-generate-index" -> - do - docsGenerateIndex <- unwrapBoolXObj value - pure (proj {projectDocsGenerateIndex = docsGenerateIndex}) - "docs-logo" -> do - logo <- unwrapStringXObj value - pure (proj {projectDocsLogo = logo}) - "docs-prelude" -> do - prelude <- unwrapStringXObj value - pure (proj {projectDocsPrelude = prelude}) - "docs-url" -> do - url <- unwrapStringXObj value - pure (proj {projectDocsURL = url}) - "docs-styling" -> do - url <- unwrapStringXObj value - pure (proj {projectDocsStyling = url}) - "file-path-print-length" -> do - len <- unwrapStringXObj value - case len of - "short" -> pure (proj {projectFilePathPrintLength = ShortPath}) - "full" -> pure (proj {projectFilePathPrintLength = ShortPath}) - _ -> Left ("Project.config can't understand the value '" ++ len ++ "' for key 'file-path-print-length.") - "generate-only" -> do - generateOnly <- unwrapBoolXObj value - pure (proj {projectGenerateOnly = generateOnly}) - "paren-balance-hints" -> - do - balanceHints <- unwrapBoolXObj value - pure (proj {projectBalanceHints = balanceHints}) - "force-reload" -> do - forceReload <- unwrapBoolXObj value - pure (proj {projectForceReload = forceReload}) - _ -> Left ("Project.config can't understand the key '" ++ key ++ "' at " ++ prettyInfoFromXObj xobj ++ ".") - case newProj of - Left errorMessage -> presentErrorWithLabel "CONFIG ERROR" errorMessage (ctx, dynamicNil) - Right ok -> pure (ctx {contextProj = ok}, dynamicNil) + let errLabel = "CONFIG ERROR" + badKey = "Project.config can't understand the key '" ++ key ++ "' at " ++ prettyInfoFromXObj xobj ++ "." + readOnly = ("the configuration field " ++ key ++ " is read-only") + in case Map.lookup key projectKeyMap of + Nothing -> presentErrorWithLabel errLabel badKey (ctx, dynamicNil) + Just (_, Nothing) -> presentErrorWithLabel errLabel readOnly (ctx, dynamicNil) + Just (_, Just setter) -> + case setter (contextProj ctx) value of + Left err -> presentErrorWithLabel errLabel err (ctx, dynamicNil) + Right ok -> pure (ctx {contextProj = ok}, dynamicNil) commandProjectConfig ctx faultyKey _ = presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil) -- | Command for changing various project settings. commandProjectGetConfig :: UnaryCommandCallback commandProjectGetConfig ctx xobj@(XObj (Str key) _ _) = - let proj = contextProj ctx - xstr s = XObj s (Just dummyInfo) (Just StringTy) - getVal _ = case key of - "cflag" -> Right $ Str $ show $ projectCFlags proj - "libflag" -> Right $ Str $ show $ projectLibFlags proj - "pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj - "load-stack" -> Right $ Arr $ xstr . Str <$> projectLoadStack proj - "prompt" -> Right $ Str $ projectPrompt proj - "search-path" -> Right $ Str $ show $ projectCarpSearchPaths proj - "print-ast" -> Right $ Bol $ projectPrintTypedAST proj - "echo-c" -> Right $ Bol $ projectEchoC proj - "echo-compiler-cmd" -> Right $ Bol $ projectEchoCompilationCommand proj - "compiler" -> Right $ Str $ projectCompiler proj - "target" -> Right $ Str $ show $ projectTarget proj - "title" -> Right $ Str $ projectTitle proj - "output-directory" -> Right $ Str $ projectOutDir proj - "docs-directory" -> Right $ Str $ projectDocsDir proj - "docs-logo" -> Right $ Str $ projectDocsLogo proj - "docs-prelude" -> Right $ Str $ projectDocsPrelude proj - "docs-url" -> Right $ Str $ projectDocsURL proj - "docs-generate-index" -> Right $ Bol $ projectDocsGenerateIndex proj - "docs-styling" -> Right $ Str $ projectDocsStyling proj - "file-path-print-length" -> Right $ Str $ show (projectFilePathPrintLength proj) - "generate-only" -> Right $ Bol $ projectGenerateOnly proj - "paren-balance-hints" -> Right $ Bol $ projectBalanceHints proj - _ -> Left key - in pure $ case getVal ctx of - Right val -> (ctx, Right $ xstr val) - Left k -> evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj) + case Map.lookup key projectKeyMap of + Nothing -> pure $ evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ key)) (xobjInfo xobj) + Just (Nothing, _) -> presentErrorWithLabel "CONFIG ERROR" ("the configuration field" ++ key ++ " is private and not readable") (ctx, dynamicNil) + Just (Just getter, _) -> pure (ctx, Right (getter (contextProj ctx))) commandProjectGetConfig ctx faultyKey = presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil) diff --git a/src/Obj.hs b/src/Obj.hs index 02f5d9084..8f200b0aa 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -332,11 +332,12 @@ machineReadableInfoFromXObj fppl xobj = Nothing -> "" -- | Obj with eXtra information. -data XObj = XObj - { xobjObj :: Obj, - xobjInfo :: Maybe Info, - xobjTy :: Maybe Ty - } +data XObj + = XObj + { xobjObj :: Obj, + xobjInfo :: Maybe Info, + xobjTy :: Maybe Ty + } deriving (Show, Eq, Ord) setObj :: XObj -> Obj -> XObj @@ -719,14 +720,15 @@ data EnvMode = ExternalEnv | InternalEnv | RecursionEnv deriving (Show, Eq, Gene instance Hashable EnvMode -- | Environment -data Env = Env - { envBindings :: Map.Map String Binder, - envParent :: Maybe Env, - envModuleName :: Maybe String, - envUseModules :: Set.Set SymPath, - envMode :: EnvMode, - envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting - } +data Env + = Env + { envBindings :: Map.Map String Binder, + envParent :: Maybe Env, + envModuleName :: Maybe String, + envUseModules :: Set.Set SymPath, + envMode :: EnvMode, + envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting + } deriving (Show, Eq, Generic) instance Hashable Env @@ -909,12 +911,13 @@ polymorphicSuffix signature actualType = type VisitedTypes = [Ty] -- | Templates are like macros, but defined inside the compiler and with access to the types they are instantiated with -data Template = Template - { templateSignature :: Ty, - templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful? - templateDefinition :: Ty -> [Token], - templateDependencies :: Ty -> [XObj] - } +data Template + = Template + { templateSignature :: Ty, + templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful? + templateDefinition :: Ty -> [Token], + templateDependencies :: Ty -> [XObj] + } instance Hashable Template where hashWithSalt s Template {..} = s `hashWithSalt` templateSignature @@ -934,7 +937,7 @@ data Token = TokTy Ty TokTyMode -- Some kind of type, will be looked up if it's a type variable. | TokC String -- Plain C code. | TokDecl -- Will emit the declaration (i.e. "foo(int x)"), this is useful - -- for avoiding repetition in the definition part of the template. + -- for avoiding repetition in the definition part of the template. | TokName -- Will emit the name of the instantiated function/variable. deriving (Eq, Ord) @@ -992,16 +995,17 @@ forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (xobjTy xobj) data ExecutionMode = Repl | Build | BuildAndRun | Install String | Check deriving (Show, Eq) -- | Information needed by the REPL -data Context = Context - { contextGlobalEnv :: Env, - contextInternalEnv :: Maybe Env, - contextTypeEnv :: TypeEnv, - contextPath :: [String], - contextProj :: Project, - contextLastInput :: String, - contextExecMode :: ExecutionMode, - contextHistory :: ![XObj] - } +data Context + = Context + { contextGlobalEnv :: Env, + contextInternalEnv :: Maybe Env, + contextTypeEnv :: TypeEnv, + contextPath :: [String], + contextProj :: Project, + contextLastInput :: String, + contextExecMode :: ExecutionMode, + contextHistory :: ![XObj] + } deriving (Show, Generic) instance Hashable Context where @@ -1163,3 +1167,12 @@ walk :: (XObj -> XObj) -> XObj -> XObj walk f (XObj (Arr xs) i t) = XObj (Arr (map (walk f) xs)) i t walk f (XObj (Lst xs) i t) = XObj (Lst (map (walk f) xs)) i t walk f x = f x + +wrapString :: String -> XObj +wrapString s = XObj (Str s) Nothing Nothing + +wrapList :: [XObj] -> XObj +wrapList xs = XObj (Lst xs) Nothing Nothing + +wrapArray :: [XObj] -> XObj +wrapArray xs = XObj (Arr xs) Nothing Nothing diff --git a/src/Project.hs b/src/Project.hs index a8c450c1e..e10017d23 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -15,40 +15,50 @@ instance Show Target where show (Target x) = x -- | Project (represents a lot of useful information for working at the REPL and building executables) -data Project = Project - { projectTitle :: String, - projectIncludes :: [Includer], - projectPreproc :: [String], - projectCFlags :: [String], - projectLibFlags :: [String], - projectPkgConfigFlags :: [String], - projectFiles :: [(FilePath, ReloadMode)], - projectAlreadyLoaded :: [FilePath], - projectEchoC :: Bool, - projectLibDir :: FilePath, - projectCarpDir :: FilePath, - projectOutDir :: FilePath, - projectDocsDir :: FilePath, - projectDocsLogo :: FilePath, - projectDocsPrelude :: String, - projectDocsURL :: String, - projectDocsGenerateIndex :: Bool, - projectDocsStyling :: String, - projectPrompt :: String, - projectCarpSearchPaths :: [FilePath], - projectPrintTypedAST :: Bool, - projectCompiler :: String, - projectTarget :: Target, - projectCore :: Bool, - projectEchoCompilationCommand :: Bool, - projectCanExecute :: Bool, - projectFilePathPrintLength :: FilePathPrintLength, - projectGenerateOnly :: Bool, - projectBalanceHints :: Bool, - projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`. - projectCModules :: [FilePath], - projectLoadStack :: [FilePath] - } +-- +-- N.B. If you add a new field and want it to be accessible in Carp, via the +-- get-config and config commands, add it to the projectKeyMap in Obj.hs with an +-- appropriate getter/setter. The getter you define should usually wrap the raw +-- value in an XObj. The setter typically validates an input XObj then updates +-- the project value. +-- +-- Otherwise, if the field is truly private and only for internal use in the +-- compiler, add the field to the Project record but omit it from the keyMap. +data Project + = Project + { projectTitle :: String, + projectIncludes :: [Includer], + projectPreproc :: [String], + projectCFlags :: [String], + projectLibFlags :: [String], + projectPkgConfigFlags :: [String], + projectFiles :: [(FilePath, ReloadMode)], + projectAlreadyLoaded :: [FilePath], + projectEchoC :: Bool, + projectLibDir :: FilePath, + projectCarpDir :: FilePath, + projectOutDir :: FilePath, + projectDocsDir :: FilePath, + projectDocsLogo :: FilePath, + projectDocsPrelude :: String, + projectDocsURL :: String, + projectDocsGenerateIndex :: Bool, + projectDocsStyling :: String, + projectPrompt :: String, + projectCarpSearchPaths :: [FilePath], + projectPrintTypedAST :: Bool, + projectCompiler :: String, + projectTarget :: Target, + projectCore :: Bool, + projectEchoCompilationCommand :: Bool, + projectCanExecute :: Bool, + projectFilePathPrintLength :: FilePathPrintLength, + projectGenerateOnly :: Bool, + projectBalanceHints :: Bool, + projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`. + projectCModules :: [FilePath], + projectLoadStack :: [FilePath] + } projectFlags :: Project -> String projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj) diff --git a/src/ProjectConfig.hs b/src/ProjectConfig.hs new file mode 100644 index 000000000..473c4c811 --- /dev/null +++ b/src/ProjectConfig.hs @@ -0,0 +1,348 @@ +-- | Defines a frontend for manipulating Project level data. +module ProjectConfig (projectKeyMap) where + +import Info +import qualified Map +import Obj +import Project +import Util + +-------------------------------------------------------------------------------- +-- Project + XObj manipulation +-- +-- Ideally, we'd define these in Project.hs, but these functions depend on XObj, +-- which would introduce a circular dep into Project.hs. + +-- Retrieve a project configuration value as an xobj. +type ProjectGetter = (Project -> XObj) + +-- Set a project configuration value. Can return either an error message or an +-- updated project. +type ProjectSetter = (Project -> XObj -> Either String Project) + +-- | Get a project's title. +projectGetTitle :: ProjectGetter +projectGetTitle proj = + let t = projectTitle proj + in XObj (Str t) Nothing Nothing + +-- | Set a project's title. +projectSetTitle :: ProjectSetter +projectSetTitle proj (XObj (Str t) _ _) = Right (proj {projectTitle = t}) +projectSetTitle _ _ = Left "can't use a non-string as a project title" + +-- | Get the project's C header includes. +projectGetIncludes :: ProjectGetter +projectGetIncludes proj = + let is = projectIncludes proj + in wrapList (map (wrapString . show) is) + +-- | Get the project's C preprocessor emissions. +projectGetPreproc :: ProjectGetter +projectGetPreproc proj = + let ps = projectPreproc proj + in wrapList (map wrapString ps) + +-- | Get the project's C compiler flags. +projectGetCFlags :: ProjectGetter +projectGetCFlags proj = + let fs = projectPreproc proj + in wrapList (map wrapString fs) + +-- | Set the project's C compiler flags +-- +-- NOTE: This retains existing behavior in which one can only add one flag at +-- a time and the flags are append only. A slightly more functional interface +-- would take a list of flags as arguments; e.g. to add *one* flag: +-- +-- (Project.config "cflags" (cons "-my-flag" (Project.get-config "cflags"))) +-- +-- or to wipe the flags whole-cloth (e.g. for a different target) +-- +-- (Project.config "cflags" ("-my" "-new" "-flags")) +-- +-- likewise for flag removal etc. +projectSetCFlags :: ProjectSetter +projectSetCFlags proj (XObj (Str f) _ _) = Right (proj {projectCFlags = addIfNotPresent f (projectCFlags proj)}) +projectSetCFlags _ _ = Left "can't use a non-string as a C compiler flag" + +-- | Get the project's C compiler library flags. +projectGetLibFlags :: ProjectGetter +projectGetLibFlags proj = + let ls = projectLibFlags proj + in wrapList (map wrapString ls) + +-- | Set the project's C compiler library flags +-- +-- NOTE: This retains existing behavior in which one can only add one flag at +-- a time and the flags are append only. A slightly more functional interface +-- would take a list of flags as arguments; e.g. to add *one* flag: +-- +-- (Project.config "libflags" (cons "-lmylib" (Project.get-config "libflags"))) +-- +-- or to wipe the flags whole-cloth (e.g. for a different target) +-- +-- (Project.config "libflags" ("-lmy" "-lnew" "-llibflags")) +-- +-- likewise for flag removal etc. +projectSetLibFlags :: ProjectSetter +projectSetLibFlags proj (XObj (Str flag) _ _) = Right (proj {projectLibFlags = addIfNotPresent flag (projectLibFlags proj)}) +projectSetLibFlags _ _ = Left "can't use non-string as library flag" + +-- | Get the pkg-config flags for the project. +projectGetPkgConfigFlags :: ProjectGetter +projectGetPkgConfigFlags proj = + let fs = projectPkgConfigFlags proj + in wrapArray (map wrapString fs) + +-- | Set the project's pkg-config flags +-- +-- NOTE: This retains existing behavior in which one can only add one flag at +-- a time and the flags are append only. A slightly more functional interface +-- would take a list of flags as arguments; e.g. to add *one* flag: +-- +-- (Project.config "pkgconfigflags" (cons "-lmylib" (Project.get-config +-- "pkgconfigflags"))) +-- +-- or to wipe the flags whole-cloth (e.g. for a different target) +-- +-- (Project.config "pkgconfigflags" ("-lmy" "-lnew" "-llibflags")) +-- +-- likewise for flag removal etc. +projectSetPkgConfigFlags :: ProjectSetter +projectSetPkgConfigFlags proj (XObj (Str flag) _ _) = Right (proj {projectPkgConfigFlags = addIfNotPresent flag (projectPkgConfigFlags proj)}) +projectSetPkgConfigFlags _ _ = Left "can't use non-string as pkg-config flag" + +projectGetEchoC :: ProjectGetter +projectGetEchoC proj = XObj (Bol (projectEchoC proj)) Nothing Nothing + +projectSetEchoC :: ProjectSetter +projectSetEchoC proj (XObj (Bol b) _ _) = Right (proj {projectEchoC = b}) +projectSetEchoC _ _ = Left "can't use non-bool as echo-c value" + +-- | Get the output directory for the project. +projectGetOutDir :: ProjectGetter +projectGetOutDir proj = XObj (Str (projectOutDir proj)) Nothing Nothing + +-- | Set the output directory for the project. +projectSetOutDir :: ProjectSetter +projectSetOutDir proj (XObj (Str dir) _ _) = Right (proj {projectOutDir = dir}) +projectSetOutDir _ _ = Left "can't use non-string as output directory" + +-- | Get the documentation directory for the project. +projectGetDocsDir :: ProjectGetter +projectGetDocsDir proj = XObj (Str (projectDocsDir proj)) Nothing Nothing + +-- | Set the documentation directory for the project. +projectSetDocsDir :: ProjectSetter +projectSetDocsDir proj (XObj (Str dir) _ _) = Right (proj {projectDocsDir = dir}) +projectSetDocsDir _ _ = Left "can't use non-string as docs directory" + +-- | Get the documentation logo for the project. +projectGetDocsLogo :: ProjectGetter +projectGetDocsLogo proj = XObj (Str (projectDocsLogo proj)) Nothing Nothing + +-- | Set the documentation logo for the project. +projectSetDocsLogo :: ProjectSetter +projectSetDocsLogo proj (XObj (Str dir) _ _) = Right (proj {projectDocsLogo = dir}) +projectSetDocsLogo _ _ = Left "can't use non-string as docs logo" + +-- | Get the documentation prelude for the project. +projectGetDocsPrelude :: ProjectGetter +projectGetDocsPrelude proj = XObj (Str (projectDocsPrelude proj)) Nothing Nothing + +-- | Set the documentation prelude for the project. +projectSetDocsPrelude :: ProjectSetter +projectSetDocsPrelude proj (XObj (Str text) _ _) = Right (proj {projectDocsPrelude = text}) +projectSetDocsPrelude _ _ = Left "can't use non-string as docs prelude" + +-- | Get the documentation URL for the project. +projectGetDocsURL :: ProjectGetter +projectGetDocsURL proj = XObj (Str (projectDocsURL proj)) Nothing Nothing + +-- | Set the documentation URL for the project. +projectSetDocsURL :: ProjectSetter +projectSetDocsURL proj (XObj (Str url) _ _) = Right (proj {projectDocsURL = url}) +projectSetDocsURL _ _ = Left "can't use non-string as docs url" + +-- | Get the generate-index option for the project. +projectGetDocsGenerateIndex :: ProjectGetter +projectGetDocsGenerateIndex proj = XObj (Bol (projectDocsGenerateIndex proj)) Nothing Nothing + +-- | Set the generate-index option for the project. +projectSetDocsGenerateIndex :: ProjectSetter +projectSetDocsGenerateIndex proj (XObj (Bol b) _ _) = Right (proj {projectDocsGenerateIndex = b}) +projectSetDocsGenerateIndex _ _ = Left "can't use non-bool as docs generate index option" + +-- | Get the documentation styling CSS path for the project. +projectGetDocsStyling :: ProjectGetter +projectGetDocsStyling proj = XObj (Str (projectDocsStyling proj)) Nothing Nothing + +-- | Set the documentation styling CSS path for the project. +projectSetDocsStyling :: ProjectSetter +projectSetDocsStyling proj (XObj (Str path) _ _) = Right (proj {projectDocsStyling = path}) +projectSetDocsStyling _ _ = Left "can't use non-string as docs styling path" + +-- | Get the prompt for the project. +projectGetPrompt :: ProjectGetter +projectGetPrompt proj = XObj (Str (projectPrompt proj)) Nothing Nothing + +-- | Set the prompt for the project. +projectSetPrompt :: ProjectSetter +projectSetPrompt proj (XObj (Str p) _ _) = Right (proj {projectPrompt = p}) +projectSetPrompt _ _ = Left "can't use non-string as project prompt" + +-- | Get the search paths for the project. +projectGetCarpSearchPaths :: ProjectGetter +projectGetCarpSearchPaths proj = + let fs = projectCarpSearchPaths proj + in wrapList (map wrapString fs) + +-- | Set the project's carp search paths +-- +-- NOTE: This retains existing behavior in which one can only add one flag at +-- a time and the flags are append only. A slightly more functional interface +-- would take a list of flags as arguments; +projectSetCarpSearchPaths :: ProjectSetter +projectSetCarpSearchPaths proj (XObj (Str p) _ _) = Right (proj {projectCarpSearchPaths = addIfNotPresent p (projectCarpSearchPaths proj)}) +projectSetCarpSearchPaths _ _ = Left "can't use non-string as search path" + +-- | Get the print-ast option for the project. +projectGetPrintTypedAST :: ProjectGetter +projectGetPrintTypedAST proj = XObj (Bol (projectPrintTypedAST proj)) Nothing Nothing + +-- | Set the print-ast option for the project. +projectSetPrintTypedAST :: ProjectSetter +projectSetPrintTypedAST proj (XObj (Bol b) _ _) = Right (proj {projectPrintTypedAST = b}) +projectSetPrintTypedAST _ _ = Left "can't use non-bool as print-ast option" + +-- | Get the C compiler for the project. +projectGetCompiler :: ProjectGetter +projectGetCompiler proj = XObj (Str (projectCompiler proj)) Nothing Nothing + +-- | Set the C compiler for the project. +projectSetCompiler :: ProjectSetter +projectSetCompiler proj (XObj (Str c) _ _) = Right (proj {projectCompiler = c}) +projectSetCompiler _ _ = Left "can't use non-string as compiler" + +-- | Get the target for the project. +projectGetTarget :: ProjectGetter +projectGetTarget proj = XObj (Str (show (projectTarget proj))) Nothing Nothing + +-- | Set the target for the project. +projectSetTarget :: ProjectSetter +projectSetTarget proj (XObj (Str "native") _ _) = Right (proj {projectTarget = Native}) +projectSetTarget proj (XObj (Str t) _ _) = Right (proj {projectTarget = Target t}) +projectSetTarget _ _ = Left "can't use non-string as target" + +-- | Get the core configuration option for the project. +projectGetCore :: ProjectGetter +projectGetCore proj = XObj (Bol (projectCore proj)) Nothing Nothing + +-- | Set the core configuration option for the project. +projectSetCore :: ProjectSetter +projectSetCore proj (XObj (Bol b) _ _) = Right (proj {projectCore = b}) +projectSetCore _ _ = Left "can't use non-bool as core option" + +-- | Get the echo compilation configuration option for the project. +projectGetEchoCompilationCommand :: ProjectGetter +projectGetEchoCompilationCommand proj = XObj (Bol (projectEchoCompilationCommand proj)) Nothing Nothing + +-- | Set the echo compilation configuration option for the project. +projectSetEchoCompilationCommand :: ProjectSetter +projectSetEchoCompilationCommand proj (XObj (Bol b) _ _) = Right (proj {projectEchoCompilationCommand = b}) +projectSetEchoCompilationCommand _ _ = Left "can't use non-bool as echo-compiler-cmd option" + +-- | Get the file path print length for the project. +projectGetFilePathPrintLength :: ProjectGetter +projectGetFilePathPrintLength proj = wrapString (show (projectFilePathPrintLength proj)) + +-- | Set the file path print length for the project. +projectSetFilePathPrintLength :: ProjectSetter +projectSetFilePathPrintLength proj (XObj (Str "short") _ _) = Right (proj {projectFilePathPrintLength = ShortPath}) +projectSetFilePathPrintLength proj (XObj (Str "full") _ _) = Right (proj {projectFilePathPrintLength = FullPath}) +projectSetFilePathPrintLength _ (XObj (Str s) _ _) = Left (s ++ "is not a valid value for file-path-print-length") +projectSetFilePathPrintLength _ _ = Left "can't use non-string as file-path-print-length" + +-- | Get the generate-only configuration option for the project. +projectGetGenerateOnly :: ProjectGetter +projectGetGenerateOnly proj = XObj (Bol (projectGenerateOnly proj)) Nothing Nothing + +-- | Set the generate-only configuration option for the project. +projectSetGenerateOnly :: ProjectSetter +projectSetGenerateOnly proj (XObj (Bol b) _ _) = Right (proj {projectGenerateOnly = b}) +projectSetGenerateOnly _ _ = Left "can't use non-bool as generate-only option" + +-- | Get the balance hints configuration option for the project. +projectGetBalanceHints :: ProjectGetter +projectGetBalanceHints proj = XObj (Bol (projectBalanceHints proj)) Nothing Nothing + +-- | Set the balance hints configuration option for the project. +projectSetBalanceHints :: ProjectSetter +projectSetBalanceHints proj (XObj (Bol b) _ _) = Right (proj {projectBalanceHints = b}) +projectSetBalanceHints _ _ = Left "can't use non-bool as paren-balance-hints option" + +-- | Get the generate-only configuration option for the project. +projectGetForceReload :: ProjectGetter +projectGetForceReload proj = XObj (Bol (projectForceReload proj)) Nothing Nothing + +-- | Set the generate-only configuration option for the project. +projectSetForceReload :: ProjectSetter +projectSetForceReload proj (XObj (Bol b) _ _) = Right (proj {projectForceReload = b}) +projectSetForceReload _ _ = Left "can't use non-bool as force-reload option" + +-- | Get the c modules for a project. +projectGetCModules :: ProjectGetter +projectGetCModules proj = wrapList (map wrapString (projectCModules proj)) + +-- | Set the c modules for a project. +-- +-- NOTE: This retains existing behavior in which one can only add one flag at +-- a time and the flags are append only. A slightly more functional interface +-- would take a list of flags as arguments; +projectSetCModules :: ProjectSetter +projectSetCModules proj (XObj (Str p) _ _) = Right (proj {projectCModules = addIfNotPresent p (projectCModules proj)}) +projectSetCModules _ _ = Left "can't use non-string as c module" + +-- | Get the load stack of a project. +projectGetLoadStack :: ProjectGetter +projectGetLoadStack proj = wrapArray (map wrapString (projectLoadStack proj)) + +-- | Mapping of compiler defined project keys to getter and setter functions. +-- This helps ensure we automatically enable access of project configuration +-- fields from Carp as they are added to the compiler. +-- +-- The first field is the key's getter, the second is its setter. If the field +-- should not have a setter, set the setter field to Nothing. If the field +-- should not have a getter, set the getter field to Nothing. +projectKeyMap :: Map.Map String (Maybe ProjectGetter, Maybe ProjectSetter) +projectKeyMap = + Map.fromList + [ ("title", (Just projectGetTitle, Just projectSetTitle)), + ("includes", (Just projectGetIncludes, Nothing)), -- has special setter variants defined in Commands.hs + ("preproc", (Just projectGetPreproc, Nothing)), -- has special setter variants defined in Commands.hs + ("cflag", (Just projectGetCFlags, Just projectSetCFlags)), + ("libflag", (Just projectGetLibFlags, Just projectSetLibFlags)), + ("pkgconfigflag", (Just projectGetPkgConfigFlags, Just projectSetPkgConfigFlags)), + ("echo-c", (Just projectGetEchoC, Just projectSetEchoC)), + ("output-directory", (Just projectGetOutDir, Just projectSetOutDir)), + ("docs-directory", (Just projectGetDocsDir, Just projectSetDocsDir)), + ("docs-logo", (Just projectGetDocsLogo, Just projectSetDocsLogo)), + ("docs-prelude", (Just projectGetDocsPrelude, Just projectSetDocsPrelude)), + ("docs-url", (Just projectGetDocsURL, Just projectSetDocsURL)), + ("docs-generate-index", (Just projectGetDocsGenerateIndex, Just projectSetDocsGenerateIndex)), + ("docs-styling", (Just projectGetDocsStyling, Just projectSetDocsStyling)), + ("prompt", (Just projectGetPrompt, Just projectSetPrompt)), + ("search-path", (Just projectGetCarpSearchPaths, Just projectSetCarpSearchPaths)), + ("print-ast", (Just projectGetPrintTypedAST, Just projectSetPrintTypedAST)), + ("compiler", (Just projectGetCompiler, Just projectSetCompiler)), + ("target", (Just projectGetTarget, Just projectSetTarget)), + ("core", (Just projectGetCore, Just projectSetCore)), + ("echo-compiler-cmd", (Just projectGetEchoCompilationCommand, Just projectSetEchoCompilationCommand)), + ("file-path-print-length", (Just projectGetFilePathPrintLength, Just projectSetFilePathPrintLength)), + ("generate-only", (Just projectGetGenerateOnly, Just projectSetGenerateOnly)), + ("paren-balance-hints", (Just projectGetBalanceHints, Just projectSetBalanceHints)), + ("force-reload", (Just projectGetForceReload, Just projectSetForceReload)), + ("cmod", (Just projectGetCModules, Just projectSetCModules)), + ("load-stack", (Just projectGetLoadStack, Nothing)) + ] From d2df3fe05824be32a6abd913d1aa1c05f50325e9 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Thu, 24 Mar 2022 04:12:14 -0400 Subject: [PATCH 29/59] feat: support cons-last for arrays (#1402) --- src/Commands.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Commands.hs b/src/Commands.hs index c9c51b2e4..7da0db1e1 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -400,6 +400,8 @@ commandConsLast ctx x xs = pure $ case xs of XObj (Lst lst) i t -> (ctx, Right (XObj (Lst (lst ++ [x])) i t)) -- TODO: should they get their own i:s and t:s + XObj (Arr arr) i t -> + (ctx, Right (XObj (Arr (arr ++ [x])) i t)) _ -> evalError ctx "Applying 'cons-last' to non-list or empty list." (xobjInfo xs) commandAppend :: BinaryCommandCallback From bf6df6405c5ac29246f7d74a21b8e56c6d5c47d5 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 28 Mar 2022 04:16:51 -0400 Subject: [PATCH 30/59] feat: add IO.fgetc (#1405) * feat: add feof and ferror These are C stdio functions that enable programmers to determine if a file read resulted in an error or EOF encounter. We can use these to power a definition of IO.fgetc, which is currently not defined. * feat: implement missing IO.fgetc IO defined a function, fgetc (distinct from IO.Raw.fgetc) which actually produced invalid code, since the name was not overridden and C does not define IO_fgetc. There was also a TODO to handle EOF conditions; so, I've implemented the function, checking for EOF and error conditions using the Raw stdio wrappers. IO.fgetc returns a Char in Success on success and an error string on failure. * refactor: distinguish EOF from errors in IO.fgetc We now report whether or not the error encountered in fgetc was EOF. Note that we don't yet report on the contents of other errors. --- core/IO.carp | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/core/IO.carp b/core/IO.carp index 7ae957374..e62e07183 100644 --- a/core/IO.carp +++ b/core/IO.carp @@ -77,6 +77,8 @@ module are wrappers around the C standard library.") (register SEEK-END Int "SEEK_END") (doc ftell "gets the position indicator of a file (thin wrapper for the C standard library).") (register ftell (Fn [(Ptr FILE)] Int) "ftell") + (register feof (Fn [(Ptr FILE)] Bool) "feof") + (register ferror (Fn [(Ptr FILE)] Bool) "ferror") ) (doc println "prints a string ref to stdout, appends a newline.") @@ -90,7 +92,13 @@ module are wrappers around the C standard library.") (doc get-line "gets a line from stdin.") (register get-line (Fn [] String)) (doc fgetc "gets a character from a file pointer (thin wrapper for the C standard library).") - (register fgetc (Fn [(Ptr FILE)] Char)) ; TODO: check EOF handling (see carp_io.h)! + (defn fgetc [file] + (let [char (IO.Raw.fgetc file)] + (if (IO.Raw.feof file) + (Result.Error @"couldn't read char from file, EOF reached") + (if (IO.Raw.ferror file) + (Result.Error @"error while reading char from file") + (Result.Success (Char.from-int char)))))) (doc open-file "opens a file by name using a mode (e.g. [r]ead, [w]rite, [a]ppend), [rb] read binary...). See fopen() in the C standard library for a detailed description of valid parameters.") (defn open-file [filename mode] From fe91fb80ba98ae6e097ef7ad1a8c1a1cbea15e4c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Tue, 29 Mar 2022 08:19:59 +0100 Subject: [PATCH 31/59] ci: Re-enable Debug.sanitize on Windows (#1406) --- .github/workflows/windows.yml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/.github/workflows/windows.yml b/.github/workflows/windows.yml index 89716c916..670e20b8b 100644 --- a/.github/workflows/windows.yml +++ b/.github/workflows/windows.yml @@ -24,6 +24,11 @@ jobs: - name: Install Stack run: scoop install stack + - name: Install LLVM + run: | + scoop install llvm + echo "C:\Users\runneradmin\scoop\apps\llvm\current\bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append + - uses: actions/cache@v1 name: Cache stack dependencies with: @@ -44,12 +49,6 @@ jobs: - name: Run Compiler Tests run: stack test - # Disabling sanitize-addresses because it fails with following error: - # https://github.com/actions/virtual-environments/issues/4978 - - name: Disable Debug.sanitize-addresses - shell: bash - run: find ./test ./examples -type f -name '*.carp' | xargs sed 's/^\((Debug.sanitize-addresses)\)/; \1/g' -i - - name: Run Carp Tests shell: bash run: ./scripts/run_carp_tests.sh --no_sdl From 3e5bdc0698d727d350790f8f567dc2e2e0423d13 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 4 Apr 2022 13:05:54 -0400 Subject: [PATCH 32/59] feat: don't manage blittable types (#1407) --- src/Managed.hs | 16 +++++++++++++--- test/memory.carp | 27 +++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/src/Managed.hs b/src/Managed.hs index 0ef1ae52c..0eb8e08e0 100644 --- a/src/Managed.hs +++ b/src/Managed.hs @@ -7,15 +7,25 @@ import Types -- | Should this type be handled by the memory management system. -- Implementation note: This top-level pattern match should be able to just -- match on all types and see whether they implement 'delete', but for some --- reson that doesn't work. Might need to handle generic types separately? +-- reason that doesn't work. Might need to handle generic types separately? +-- +-- TODO: When blit and delete are both implemented, issue a warning. isManaged :: TypeEnv -> Env -> Ty -> Bool isManaged typeEnv globalEnv structTy@StructTy {} = - interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [structTy] UnitTy StaticLifetimeTy) + not (isBlittable typeEnv globalEnv structTy) + && interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [structTy] UnitTy StaticLifetimeTy) isManaged typeEnv globalEnv funcTy@FuncTy {} = - interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [funcTy] UnitTy StaticLifetimeTy) + not (isBlittable typeEnv globalEnv funcTy) + && interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [funcTy] UnitTy StaticLifetimeTy) isManaged _ _ StringTy = True isManaged _ _ PatternTy = True isManaged _ _ _ = False + +-- | Returns true if this type implements the "blit" interface and is thus +-- freely copyable. +isBlittable :: TypeEnv -> Env -> Ty -> Bool +isBlittable typeEnv globalEnv t = + interfaceImplementedForTy typeEnv globalEnv "blit" (FuncTy [t] t StaticLifetimeTy) diff --git a/test/memory.carp b/test/memory.carp index d3aaaca8c..32ba8ad02 100644 --- a/test/memory.carp +++ b/test/memory.carp @@ -18,6 +18,32 @@ (f) (assert-equal state 0l (Debug.memory-balance) descr))) +(deftype BlitEnum Copy Move) +(defmodule BlitEnum + (defn blit [x] (the BlitEnum x)) + (implements blit blit) + + (defn prn [x] + (match x + (BlitEnum.Copy) @"copy semantics" + (BlitEnum.Move) @"move semantics")) + (implements prn prn) + + (defn change [x] + (match x + (BlitEnum.Copy) (BlitEnum.Move) + (BlitEnum.Move) (BlitEnum.Copy))) +) + +(defn blit-1 [] + ;; blit types are not borrow checked and have copy semantics + (let-do [enum (BlitEnum.Copy) + enum-copy enum] + (IO.println &(prn enum)) + (IO.println &(prn enum-copy)) + (IO.println &(prn (change enum))) + (IO.println &(prn (change enum-copy))))) + (defn scope-1 [] (let [s @""] ())) @@ -568,4 +594,5 @@ (assert-no-leak test sumtype-12 "sumtype-12 does not leak") (assert-no-leak test box-1 "box-1 does not leak") (assert-no-leak test box-2 "box-2 does not leak") + (assert-no-leak test blit-1 "blit-1 does not leak") ) From 8e8a67d1eb3f935f0b70db76429841fd4cded5d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Tue, 5 Apr 2022 10:32:09 +0100 Subject: [PATCH 33/59] chore: Updates Stackage version to 19.2 (#1408) * chore: Updates Stackage version to 19.2 Comes with GHC 9.0.2 * refactor: renames list-equal-unordered args to better fit conventions --- src/Parsing.hs | 12 ++- stack.yaml | 2 +- test/dynamic_map.carp | 175 +++++++++++++++++++++++------------------- 3 files changed, 102 insertions(+), 87 deletions(-) diff --git a/src/Parsing.hs b/src/Parsing.hs index b9781f766..eb4d8d0d7 100644 --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -627,17 +627,15 @@ balance text = parens <- Parsec.getState case parens of [] -> push c - '"' : xs -> case c of - '\\' -> do - _ <- Parsec.anyChar -- consume next - pure () - '"' -> Parsec.putState xs -- close string - _ -> pure () -- inside string (x : xs) -> case (x, c) of ('(', ')') -> Parsec.putState xs ('[', ']') -> Parsec.putState xs ('{', '}') -> Parsec.putState xs - ('"', '"') -> Parsec.putState xs + ('"', '"') -> Parsec.putState xs -- close string + ('"', '\\') -> do + _ <- Parsec.anyChar -- consume next + pure () + ('"', _) -> pure () --('\\', _) -> Parsec.putState xs -- ignore char after '\' _ -> push c push :: Char -> Parsec.Parsec String String () diff --git a/stack.yaml b/stack.yaml index 19fd11f7e..0b83203ad 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-15.3 +resolver: lts-19.2 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/test/dynamic_map.carp b/test/dynamic_map.carp index f1eae430d..5af3a75e3 100644 --- a/test/dynamic_map.carp +++ b/test/dynamic_map.carp @@ -1,189 +1,206 @@ (load "Test.carp") (use Test) +(doc list-equal-unordered "Checks two lists have the same values, not necessarily in the same order") +(defndynamic list-equal-unordered [xs ys] + (if (not (= (length xs) (length ys))) + false + (car (reduce (fn [state x] + (let [keep-going (car state) + l (cadr state)] + (if (not keep-going) + '(false ()) + (let [index (List.find-index l (curry = x))] + (if (nil? index) + '(false ()) + (list true (List.remove-nth l index))))))) + (list true ys) + xs)))) + (deftest test (assert-dynamic-equal test "2" (Map.get (Map.put (Map.create) "1" "2") "1") - "basic put and get works" - ) + "basic put and get works") + (assert-dynamic-equal test "3" (Map.get (Map.put (Map.put (Map.create) "1" "2") "1" "3") "1") - "put, update and get" - ) + "put, update and get") + (assert-dynamic-equal test nil (Map.get (Map.create) "1") - "get works with defaults" - ) + "get works with defaults") + (assert-dynamic-equal test true (Map.empty? (Map.update (Map.create) "x" inc)) - "update works with empty map" - ) + "update works with empty map") + (assert-dynamic-equal test 2 (Map.get (Map.update {"x" 1} "x" inc) "x") - "update works" - ) + "update works") + (assert-dynamic-equal test \x (Map.get-with-default {1 \x} 1 \_) - "get-with-default works I" - ) + "get-with-default works I") + (assert-dynamic-equal test \_ (Map.get-with-default {1 \x} 2 \_) - "get-with-default works II" - ) + "get-with-default works II") + (assert-dynamic-equal test 8 (Map.get (Map.update-with-default (Map.create) "x" inc 7) "x") - "update-with-default works with empty map" - ) + "update-with-default works with empty map") + (assert-dynamic-equal test 2 (Map.get (Map.update-with-default {"x" 1} "x" inc 7) "x") - "update-with-default works" - ) + "update-with-default works") + (assert-dynamic-equal test 1 (Map.len (Map.put (Map.create) "1" "2")) - "len works" - ) + "len works") + (assert-dynamic-equal test 0 (Map.len (Map.create)) - "length works on empty map" - ) + "length works on empty map") + (assert-dynamic-equal test false (Map.contains? (Map.create) "1") - "contains? works on empty map" - ) + "contains? works on empty map") + (assert-dynamic-equal test true (Map.contains? (Map.put (Map.create) "1" "2") "1") - "contains? works" - ) + "contains? works") + (assert-dynamic-equal test true (Map.contains? (Map.put (Map.create) -7 "2") -7) - "contains? works with negative keys" - ) + "contains? works with negative keys") + (assert-dynamic-equal test false (Map.contains? (Map.put (Map.create) 1 "2") -7) - "contains? works with negative keys" - ) + "contains? works with negative keys") + (assert-dynamic-equal test true (Map.empty? (Map.create)) - "empty? works on empty map" - ) + "empty? works on empty map") + (assert-dynamic-equal test false (Map.empty? (Map.put (Map.create) "1" "2")) - "empty? works" - ) + "empty? works") + (assert-dynamic-equal test true (Map.empty? (Map.remove (Map.put (Map.create) "1" "2") "1")) - "remove works" - ) + "remove works") + (assert-dynamic-equal test true (Map.all? (fn [p] (or (even? (car p)) (cadr p))) {1 true 2 false 4 false}) - "Map.all? works I" - ) + "Map.all? works I") + (assert-dynamic-equal test false (Map.all? (fn [p] (or (even? (car p)) (cadr p))) {1 true 2 false 5 false}) - "Map.all? works II" - ) + "Map.all? works II") + (assert-dynamic-equal test true (Map.= {1 2 3 4} {1 2 3 4}) - "Map.= works I" - ) + "Map.= works I") + (assert-dynamic-equal test false (Map.= {1 2 3 4} {1 2 3 5}) - "Map.= works II" - ) + "Map.= works II") + (assert-dynamic-equal test false (Map.= {1 2 3 4} {1 2}) - "Map.= works III" - ) + "Map.= works III") + (assert-dynamic-equal test 2 (Map.len (Map.from-array [(Pair.init 1 2) (Pair.init 3 4)])) - "creating a map from an array works" - ) + "creating a map from an array works") + (assert-dynamic-equal test "{ 1 2 }" (Map.str (Map.from-array [(Pair.init 1 2)])) - "stringification works I" - ) + "stringification works I") + (assert-dynamic-equal test ; TODO: should we escape strings? "{ hi bye }" (Map.str (Map.from-array [(Pair.init "hi" "bye")])) - "stringification works II" - ) + "stringification works II") + (assert-dynamic-equal test [(Pair.init 1 2)] (Map.to-array (Map.put (Map.create) 1 2)) - "Map.to-array works 1" - ) + "Map.to-array works 1") + (assert-dynamic-equal test 2 (length (Map.to-array (Map.from-array [(Pair.init 1 2) (Pair.init 3 4)]))) - "Map.to-array works 2" - ) + "Map.to-array works 2") + (assert-dynamic-equal test - "{ 1 12 3 34 }" - (Map.str (Map.map (fn [p] (+ (cadr p) (* 10 (car p)))) {1 2 3 4})) - "map works" - ) + { 1 12 3 34} + (Map.map (fn [p] (+ (cadr p) (* 10 (car p)))) {1 2 3 4}) + "map works") + (assert-dynamic-equal test 641 (Map.kv-reduce (fn [sum p] (+ sum (+ (* 100 (car p)) (* 10 (cadr p))))) 1 {1 1 2 1 3 2}) - "kv-reduce works" - ) - (assert-dynamic-equal test - '(1 2 3) - (Map.keys {1 1 2 1 3 2}) - "keys works" - ) - (assert-dynamic-equal test - '(1 1 2) - (Map.vals {1 1 2 1 3 2}) - "vals works" - ) + "kv-reduce works") + + (assert-dynamic-op test + '(1 2 3) + (Map.keys {1 1 2 1 3 2}) + "keys works" + list-equal-unordered) + + (assert-dynamic-op test + '(1 1 2) + (Map.vals {1 1 2 1 3 2}) + "vals works" + list-equal-unordered) + (assert-dynamic-equal test 3 (Map.get {(Pair.init 1 2) 3} (Pair.init 1 2)) - "Pairs work as keys" - ) + "Pairs work as keys") + (assert-dynamic-op test {1 "hi" 2 "bye"} (Map.reverse {"hi" 1 "bye" 2}) "reverse works" - Map.= - ) + Map.=) + (assert-dynamic-op test {1 "hi" 2 "bye" 3 "!"} (Map.merge {1 "bye" 3 "!"} {2 "bye" 1 "hi"}) "merge works" - Map.= - ) -) + Map.=)) + From a9e806fee75da503a72f6d5b701dc978d976c7da Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 6 Apr 2022 03:49:00 -0400 Subject: [PATCH 34/59] feat: implement blit on ByteOrder (#1410) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * feat: add box templates and box type This commit adds an implementation of Boxes, memory manged heap allocated values. Boxes are implemented as C pointers, with no additional structure but are treated as structs in Carp. To facilitate this, we need to add them as a clause to our special type emissions (TypesToC) as they'd otherwise be emitted like other struct types. Co-authored-by: Veit Heller * fix: slight memory management fix for Box Make sure we free the box! * test: add tests for box (including memory checks) * Revert "fix: Ignore clang nitpick" This reverts commit 70ec6d46d4c636c39dc4d47dc7732421a30a0b3f. * fix: update example/functor.carp Now that a builtin type named Box exists, the definitions in this file cause a conflict. I've renamed the "Box" type in the functor example to remove the conflict. * feat: add Box.peek Box.peek allows users to transform a reference to a box into a a reference to the box's contained value. The returned reference will have the same lifetime as the box. This function allows callers to manipulate the value in a box without re-allocation, for example: ```clojure (deftype Num [val Int]) (let-do [box (Box.init (Num.init 0))] (Num.set-val! (Box.peek &box) 1) @(Num.val (Box.peek &box))) ``` This commit also includes tests for Box.peek. Co-authored-by: TimDeve * feat: implement blit on ByteOrder ByteOrder is effectively just an enum that indicates desired endianness. We can freely copy it around without penalty. Co-authored-by: Veit Heller Co-authored-by: Erik Svedäng Co-authored-by: TimDeve --- core/Binary.carp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/core/Binary.carp b/core/Binary.carp index d64b928af..ea33d6873 100644 --- a/core/Binary.carp +++ b/core/Binary.carp @@ -29,6 +29,11 @@ significant byte occurs first in a given byte sequence.") (deftype ByteOrder LittleEndian BigEndian) +(defmodule ByteOrder + (defn blit [x] (the ByteOrder x)) + (implements blit blit) +) + (doc Binary "provides various helper functions to work with bits and bytes.") (defmodule Binary (register to-int16 (λ [Byte Byte] Uint16)) From d7ad0b2629bc64fb9b5f06d07347c630bc38a729 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Sat, 9 Apr 2022 06:04:16 +0100 Subject: [PATCH 35/59] feat: Adds Dynamic.sort & improves output of failing dynamic tests (#1411) * feat: Adds Dynamic.sort * test: Adds tests for Dynamic.sort * refactor: Makes dynamic test handler display diff of expected vs actual instead of displaying "true" : "true" * test: Removes complex implementation of list-equal-unordered Replaces it with sort + equal. While this is less "correct", having complex untested functions within test files is undesirable. This implementation is "good enough" for lists of integers. --- core/List.carp | 28 ++++++++++++++++++++++------ core/Test.carp | 27 +++++++++++++++++---------- test/dynamic_map.carp | 15 ++------------- test/list.carp | 20 ++++++++++++++++++++ 4 files changed, 61 insertions(+), 29 deletions(-) create mode 100644 test/list.carp diff --git a/core/List.carp b/core/List.carp index 43a6950e6..f50df7a7f 100644 --- a/core/List.carp +++ b/core/List.carp @@ -17,9 +17,9 @@ Example: (= 'a (cadr x)) car (= 'd (cadr x)) cdr (macro-error "`cxr` expects either `a` or `d` symbols, got " (cadr x))) - (if (= 1 (car x)) - (cxr (cddr x) pair) - (cxr (cons (- (car x) 1) (cdr x)) pair))))) + (if (= 1 (car x)) + (cxr (cddr x) pair) + (cxr (cons (- (car x) 1) (cdr x)) pair))))) (doc nthcdr "takes the `n`th tail or `cdr` of the list `pair`.") (defndynamic nthcdr [n pair] @@ -313,6 +313,23 @@ Example: (let [r (walk-replace-finder pairs x)] (if (empty? r) x (cadr r)))) form)) + (doc sort "Sorts a list using the provided predicate. It is not a stable sort. +Example: +``` +(sort '(1 3 4 2 5 4) <) ; => (1 2 3 4 4 5) +(sort '(1 3 4 2 5 4) >) ; => (5 4 4 3 2 1) +(sort '(\"one\" \"two---\" \"three\" \"four\") (fn [a b] (< (String.length a) (String.length b)))) ; => (\"one\" \"four\" \"three\" \"two---\") +```") + (defndynamic sort [l compare] + (if (nil? l) + '() + (let [x (car l) + xs (cdr l) + lower-filtered (filter (fn [y] (compare y x)) xs) + lower-sorted (Dynamic.sort lower-filtered compare) + higher-filtered (filter (fn [y] (not (compare y x))) xs) + higher-sorted (Dynamic.sort higher-filtered compare)] + (append lower-sorted (append (list x) higher-sorted))))) (defmodule List (doc pairs "makes a list of pairs out of a list `l`. If the number of @@ -367,6 +384,5 @@ Returns `nil` on failure") (let [res (List.find-index (cdr l) pred)] (if (nil? res) res - (inc res))))) - ) -) + (inc res))))))) + diff --git a/core/Test.carp b/core/Test.carp index 878b3e0ad..9744ae05e 100644 --- a/core/Test.carp +++ b/core/Test.carp @@ -18,9 +18,9 @@ Example: (deftype State [passed Int, failed Int]) (hidden State) (use Color.Id) - (hidden handler) - (defn handler [state expected actual descr what op] - (if (op expected actual) + (hidden display-test) + (defn display-test [state expected actual descr what is-success] + (if is-success (do (IO.colorize (Green) &(str* @"Test '" @descr @"' passed\n")) (State.update-passed (State.copy state) &Int.inc)) @@ -33,6 +33,14 @@ Example: (IO.color (Reset)) (State.update-failed (State.copy state) &Int.inc)))) + (hidden handler) + (defn handler [state expected actual descr what op] + (display-test state expected actual descr what (op expected actual))) + + (hidden dynhandler) + (defndynamic dynhandler [state expected actual descr what op] + (list 'Test.display-test state (str expected) (str actual) descr what (op expected actual))) + (doc assert-op "Assert that op returns true when given x and y.") (defn assert-op [state x y descr op] (handler state x y descr "value" op)) @@ -73,13 +81,13 @@ Example: (defn assert-error [state x descr] (assert-true state (Result.error? x) descr)) - (doc assert-dynamic-equal "Assert that the dynamic expressions `x` and `y` are equal.") - (defmacro assert-dynamic-equal [state x y descr] - `(Test.assert-equal %state true %(= (eval x) (eval y)) %descr)) - (doc assert-dynamic-op "Assert that the dynamic expressions `x` and `y` are equal.") (defmacro assert-dynamic-op [state x y descr op] - `(Test.assert-equal %state true %(op (eval x) (eval y)) %descr)) + (dynhandler state (eval x) (eval y) descr "value" op)) + + (doc assert-dynamic-equal "Assert that the dynamic expressions `x` and `y` are equal.") + (defmacro assert-dynamic-equal [state x y descr] + (dynhandler state (eval x) (eval y) descr "value" =)) (doc reset "Reset test state.") (defn reset [state] @@ -170,8 +178,7 @@ Example: `@(Test.State.failed %name) (cons-last `(Test.print-test-results %name) - `(do %@(with-test-internal name forms)))) - )) + `(do %@(with-test-internal name forms)))))) (defmacro deftest [name :rest forms] (eval diff --git a/test/dynamic_map.carp b/test/dynamic_map.carp index 5af3a75e3..64c8d2a74 100644 --- a/test/dynamic_map.carp +++ b/test/dynamic_map.carp @@ -3,19 +3,8 @@ (doc list-equal-unordered "Checks two lists have the same values, not necessarily in the same order") (defndynamic list-equal-unordered [xs ys] - (if (not (= (length xs) (length ys))) - false - (car (reduce (fn [state x] - (let [keep-going (car state) - l (cadr state)] - (if (not keep-going) - '(false ()) - (let [index (List.find-index l (curry = x))] - (if (nil? index) - '(false ()) - (list true (List.remove-nth l index))))))) - (list true ys) - xs)))) + (= (Dynamic.sort xs <) + (Dynamic.sort ys <))) (deftest test (assert-dynamic-equal test diff --git a/test/list.carp b/test/list.carp new file mode 100644 index 000000000..9b8d6ba17 --- /dev/null +++ b/test/list.carp @@ -0,0 +1,20 @@ +(load-and-use Test) + +(deftest test + (assert-dynamic-equal test + '(1 2 3 3 4) + (Dynamic.sort '(3 4 3 1 2) <) + "Dynamic.sort sorts from lower to higher") + + (assert-dynamic-equal test + '(4 3 3 2 1) + (Dynamic.sort '(3 4 3 1 2) >) + "Dynamic.sort sorts from higher to lower") + + (assert-dynamic-equal test + '("one" "four" "three" "two---") + (Dynamic.sort '("one" "two---" "three" "four") + (fn [a b] + (< (String.length a) (String.length b)))) + "Dynamic.sort sorts using predicate")) + From fa8af08e35f220f7bdcdd366793c0f958058d2b3 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 11 Apr 2022 10:55:53 -0400 Subject: [PATCH 36/59] fix: respect let binding shadowing in memory management (#1413) * fix: respect let binding shadowing in memory management Previously, we didn't account for shadowing in let bindings in our memory management routines. This led to rare situations in which multiple deleters might be added for a single variable name, for example: ```clojure (defn n [xs] (let [xs [1 2 3] n &xs] n)) ``` The borrow checker would fail on this code since it would assign `xs` two deleters, one for the untyped argument and another for the let binding. Instead, we now perform *exclusive* ownership transfer for the duration of the let scope--when a shadow is introduced, the previous deleters for that variable name are dropped until the end of the let scope, since we evaluate all instances of the shadowed name to the more local binding. At the end of the let scope, the original deleter is restored. Fixes issue #597 * refactor: improved dead reference error for let Since let scopes resolve to their bodies, we can report the body of the let as the xobj producing an error when a dead reference is returned. * test: update error message for dead refs in let * test: add regression test for issue #597 Ensure we don't regress and fail to manage memory when let bindings shadow function argument names. --- src/Info.hs | 16 ++++++++++++++ src/Memory.hs | 22 +++++++++++++++++-- test/memory.carp | 8 +++++++ .../return_ref_in_let.carp.output.expected | 2 +- 4 files changed, 45 insertions(+), 3 deletions(-) diff --git a/src/Info.hs b/src/Info.hs index 913bb4beb..45fc1dd4d 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -12,12 +12,14 @@ module Info makeTypeVariableNameFromInfo, setDeletersOnInfo, addDeletersToInfo, + uniqueDeleter, ) where import Path (takeFileName) import qualified Set import SymPath +import Data.List (unionBy) -- | Information about where the Obj originated from. data Info = Info @@ -58,6 +60,20 @@ instance Show Deleter where show (PrimDeleter var) = "(PrimDel " ++ show var ++ ")" show (RefDeleter var) = "(RefDel " ++ show var ++ ")" +-- | Get the variable name associated with a deleter. +deleterVar :: Deleter -> String +deleterVar (ProperDeleter _ _ v) = v +deleterVar (FakeDeleter v) = v +deleterVar (PrimDeleter v) = v +deleterVar (RefDeleter v) = v + +-- | Given two sets of deleters, take only a single deleter for each variable. +-- +-- Left biased in the case of duplicates. +uniqueDeleter :: Set.Set Deleter -> Set.Set Deleter -> Set.Set Deleter +uniqueDeleter xs ys = + Set.fromList (unionBy (\x y -> deleterVar x == deleterVar y) (Set.toList xs) (Set.toList ys)) + -- | Whether or not the full path of a source file or a short path should be -- printed. data FilePathPrintLength diff --git a/src/Memory.hs b/src/Memory.hs index 2a20fce22..43ed489bf 100644 --- a/src/Memory.hs +++ b/src/Memory.hs @@ -447,7 +447,8 @@ manageMemory typeEnv globalEnv root = do visitedExpr <- visit expr addToLifetimesMappingsIfRef True expr - result <- transferOwnership typeEnv globalEnv expr name + -- ensures this deleter is the only deleter associated with name for the duration of the let scope (shadowing). + result <- exclusiveTransferOwnership typeEnv globalEnv expr name whenRightReturn result $ do okExpr <- visitedExpr pure (name, okExpr) @@ -521,6 +522,21 @@ transferOwnership typeEnv globalEnv from to = manage typeEnv globalEnv to --(trace ("Transfered from " ++ getName from ++ " '" ++ varOfXObj from ++ "' to " ++ getName to ++ " '" ++ varOfXObj to ++ "'") to) pure (Right ()) +-- | Transfer ownership, and ensure the resulting set has only *one* deleter per variable. +-- +-- Multiple deleters can arise when one variable shadows an earlier one from a wider scope. +-- see issue #597 +exclusiveTransferOwnership :: TypeEnv -> Env -> XObj -> XObj -> State MemState (Either TypeError ()) +exclusiveTransferOwnership tenv genv from to = + do result <- unmanage tenv genv from + whenRight result $ do + MemState pre deps lts <- get + put (MemState Set.empty deps lts) -- add just this new deleter to the set + manage tenv genv to + MemState post postDeps postLts <- get + put (MemState (uniqueDeleter post pre) postDeps postLts) -- replace any duplicates and union with the prior set + pure (Right ()) + -- | Control that an `xobj` is OK to reference canBeReferenced :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ()) canBeReferenced typeEnv globalEnv xobj = @@ -574,7 +590,9 @@ refTargetIsAlive xobj = [] -> --trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ --pure (Right xobj) - pure (Left (UsingDeadReference xobj deleterName)) + pure (case xobjObj xobj of + (Lst (LetPat _ _ body)) -> (Left (UsingDeadReference body deleterName)) + _ -> (Left (UsingDeadReference xobj deleterName))) _ -> --trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ pure (Right xobj) diff --git a/test/memory.carp b/test/memory.carp index 32ba8ad02..3a0df4f81 100644 --- a/test/memory.carp +++ b/test/memory.carp @@ -57,6 +57,13 @@ (do (print "") ()))) +;; regression test for issue #597 +;; should compile fine. +(defn shadow-1 [x] + (let [x [1 2 3] + y &x] + ())) + (defn f [] @"") @@ -595,4 +602,5 @@ (assert-no-leak test box-1 "box-1 does not leak") (assert-no-leak test box-2 "box-2 does not leak") (assert-no-leak test blit-1 "blit-1 does not leak") + (assert-no-leak test (fn [] (shadow-1 2)) "shadow-1 does not leak") ) diff --git a/test/output/test/test-for-errors/return_ref_in_let.carp.output.expected b/test/output/test/test-for-errors/return_ref_in_let.carp.output.expected index 3182a497a..acaf052e9 100644 --- a/test/output/test/test-for-errors/return_ref_in_let.carp.output.expected +++ b/test/output/test/test-for-errors/return_ref_in_let.carp.output.expected @@ -1 +1 @@ -return_ref_in_let.carp:4:3 The reference '(let [xs (ref [1 2 3])] xs)' isn't alive. +return_ref_in_let.carp:5:5 The reference 'xs' isn't alive. From 5856f439213002abfadd2c65c51ece4935966f3d Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Tue, 12 Apr 2022 03:16:31 -0400 Subject: [PATCH 37/59] fix: respect symbol modes on interface concretization (#1415) * fix: respect symbol modes on interface concretization When concretizing interfaces (finding the appropriate implementation at a call site) we previously set the lookup mode of all such resolved symbols to CarpLand AFunction. This incorrectly overwrites the lookup mode of Externally registered types, causing them to emit incorrect C when the user specifies an override. We now preserve whatever lookup mode is assigned to the implementation the concretization resolves the interface to. This not only fixes the external override emission issue, but should be more correct in general. fixes #1414 * test: add regression test for issue #1414 --- src/Concretize.hs | 17 +++++++++-------- test/interface.carp | 15 +++++++++++++++ 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index 0fdb21707..bd2ead10e 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -421,20 +421,21 @@ visitInterfaceSym visited allowAmbig tenv env xobj@(InterfaceSymPat name) = go :: Binder -> State [XObj] (Either TypeError XObj) go (Binder _ (ListPat (InterfacePat _ paths))) = let tys = map (typeFromPath env) paths - tysToPathsDict = zip tys paths - in case filter (matchingSignature actualType) tysToPathsDict of - [] -> pure $ if allowAmbig then Right xobj else Left (NoMatchingSignature xobj name actualType tysToPathsDict) + modes = map (modeFromPath env) paths + tysModesPathsDict = zip3 tys modes paths + in case filter (\(t, _, p) -> matchingSignature actualType (t, p)) tysModesPathsDict of + [] -> pure $ if allowAmbig then Right xobj else Left (NoMatchingSignature xobj name actualType (map (\(t, _, p) -> (t,p)) tysModesPathsDict)) [x] -> updateSym x - xs -> case filter (typeEqIgnoreLifetimes actualType . fst) xs of + xs -> case filter (\(t,_,_) -> typeEqIgnoreLifetimes actualType t) xs of [] -> pure (Right xobj) -- No exact match of types [y] -> updateSym y - ps -> pure (Left (SeveralExactMatches xobj name actualType ps)) + ps -> pure (Left (SeveralExactMatches xobj name actualType (map (\(t, _, p) -> (t,p)) ps))) go _ = pure (Left (CannotConcretize xobj)) -- TODO: Should we also check for allowAmbig here? - updateSym (_, path) = if isTypeGeneric actualType then pure (Right xobj) else replace path - replace path = + updateSym (_, mode, path) = if isTypeGeneric actualType then pure (Right xobj) else replace mode path + replace mode path = -- We pass the original xobj ty here, should we be passing the type found via matching signature? - let normalSymbol = XObj (Sym path (LookupGlobal CarpLand AFunction)) (xobjInfo xobj) (xobjTy xobj) -- TODO: Is it surely AFunction here? Could be AVariable as well...!? + let normalSymbol = XObj (Sym path mode) (xobjInfo xobj) (xobjTy xobj) in visitSymbol visited allowAmbig diff --git a/test/interface.carp b/test/interface.carp index 470791a4b..85cf3a64f 100644 --- a/test/interface.carp +++ b/test/interface.carp @@ -36,6 +36,17 @@ (defn pikachu [times] (String.repeat times "pika")) (implements monster pikachu) +;; issue #1414, make sure we don't overwrite the lookup mode of implementations +(definterface FOO a) +(defmodule Foo + (register FOO Int "CARP_INT_MAX") + (implements FOO FOO) +) +(defmodule Bar + (defn bar [] + FOO) +) + (deftest test (assert-equal test &2 @@ -59,4 +70,8 @@ &(monster 3) "Implementations may be overwritten, when multiple implementations of the same type are provided.") + (assert-equal test + Int.MAX + (Bar.bar) + "regression for issue #1414") ) From 5d530b74915a468d4265ecb6b8215033088cb44f Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 13 Apr 2022 03:32:46 -0400 Subject: [PATCH 38/59] feat: register MAX and MIN macros for stdint types (#1412) * feat: register MAX and MIN macros for stdint types Adds MAX and MIN for each INT type and MAX for each UINT type. These are macros defined by stdint.h and are sometimes useful for bounds determinations and conversions and such. * feat: make MAX and MIN interfaces Since several numeric types define maximum and minimum values, it makes sense for these to be defined as interfaces. This commit also makes existing definitions of MAX and MIN for Carp's numeric types implement the interfaces. * fix: respect let binding shadowing in memory management (#1413) * fix: respect let binding shadowing in memory management Previously, we didn't account for shadowing in let bindings in our memory management routines. This led to rare situations in which multiple deleters might be added for a single variable name, for example: ```clojure (defn n [xs] (let [xs [1 2 3] n &xs] n)) ``` The borrow checker would fail on this code since it would assign `xs` two deleters, one for the untyped argument and another for the let binding. Instead, we now perform *exclusive* ownership transfer for the duration of the let scope--when a shadow is introduced, the previous deleters for that variable name are dropped until the end of the let scope, since we evaluate all instances of the shadowed name to the more local binding. At the end of the let scope, the original deleter is restored. Fixes issue #597 * refactor: improved dead reference error for let Since let scopes resolve to their bodies, we can report the body of the let as the xobj producing an error when a dead reference is returned. * test: update error message for dead refs in let * test: add regression test for issue #597 Ensure we don't regress and fail to manage memory when let bindings shadow function argument names. * fix: respect symbol modes on interface concretization (#1415) * fix: respect symbol modes on interface concretization When concretizing interfaces (finding the appropriate implementation at a call site) we previously set the lookup mode of all such resolved symbols to CarpLand AFunction. This incorrectly overwrites the lookup mode of Externally registered types, causing them to emit incorrect C when the user specifies an override. We now preserve whatever lookup mode is assigned to the implementation the concretization resolves the interface to. This not only fixes the external override emission issue, but should be more correct in general. fixes #1414 * test: add regression test for issue #1414 --- core/Double.carp | 1 + core/Float.carp | 1 + core/Int.carp | 2 ++ core/Interfaces.carp | 2 ++ core/Long.carp | 2 ++ core/StdInt.carp | 24 ++++++++++++++++++++++++ core/carp_stdint.h | 14 ++++++++++++++ 7 files changed, 46 insertions(+) diff --git a/core/Double.carp b/core/Double.carp index 833e51d5c..77afe577e 100644 --- a/core/Double.carp +++ b/core/Double.carp @@ -6,6 +6,7 @@ (implements pi Double.pi) (def e 2.718281828459045) (register MAX Double "CARP_DBL_MAX") + (implements MAX MAX) (register = (Fn [Double Double] Bool)) (register < (Fn [Double Double] Bool)) (register > (Fn [Double Double] Bool)) diff --git a/core/Float.carp b/core/Float.carp index 73596dafe..be58168dc 100644 --- a/core/Float.carp +++ b/core/Float.carp @@ -5,6 +5,7 @@ suffixed with `f`.") (defmodule Float (def pi 3.1415926536f) (register MAX Float "CARP_FLT_MAX") + (implements MAX MAX) (register neg (Fn [Float] Float)) (register + (Fn [Float Float] Float)) (register - (Fn [Float Float] Float)) diff --git a/core/Int.carp b/core/Int.carp index f18462207..8206cc4be 100644 --- a/core/Int.carp +++ b/core/Int.carp @@ -41,7 +41,9 @@ (defmodule Int (register MAX Int "CARP_INT_MAX") + (implements MAX MAX) (register MIN Int "CARP_INT_MIN") + (implements MIN MIN) (register bit-shift-left (λ [Int Int] Int)) (register bit-shift-right (λ [Int Int] Int)) (register bit-and (λ [Int Int] Int)) diff --git a/core/Interfaces.carp b/core/Interfaces.carp index 3a60a52e1..7c336005f 100644 --- a/core/Interfaces.carp +++ b/core/Interfaces.carp @@ -63,6 +63,8 @@ (definterface sqrt (λ [a] a)) (definterface tan (λ [a] a)) (definterface tanh (λ [a] a)) +(definterface MAX a) +(definterface MIN a) (definterface slice (Fn [&a Int Int] a)) diff --git a/core/Long.carp b/core/Long.carp index 60bb6826b..303e623ac 100644 --- a/core/Long.carp +++ b/core/Long.carp @@ -4,7 +4,9 @@ `l`.") (defmodule Long (register MAX Long "LONG_MAX") + (implements MAX MAX) (register MIN Long "LONG_MIN") + (implements MIN MIN) (register + (λ [Long Long] Long)) (register - (λ [Long Long] Long)) (register * (λ [Long Long] Long)) diff --git a/core/StdInt.carp b/core/StdInt.carp index 523b35b0f..2ec54e2f3 100644 --- a/core/StdInt.carp +++ b/core/StdInt.carp @@ -28,6 +28,10 @@ integer.") (register to-long (λ [Int8] Long)) (register from-long (λ [Long] Int8)) (register copy (Fn [&Int8] Int8)) + (register MAX Int8 "CARP_INT8_MAX") + (implements MAX MAX) + (register MIN Int8 "CARP_INT8_MIN") + (implements MIN MIN) (defn zero [] (from-long 0l)) @@ -74,6 +78,10 @@ integer.") (register to-long (λ [Int16] Long)) (register from-long (λ [Long] Int16)) (register copy (Fn [&Int16] Int16)) + (register MAX Int16 "CARP_INT16_MAX") + (implements MAX MAX) + (register MIN Int16 "CARP_INT16_MIN") + (implements MIN MIN) (defn zero [] (from-long 0l)) @@ -120,6 +128,10 @@ integer.") (register to-long (λ [Int32] Long)) (register from-long (λ [Long] Int32)) (register copy (Fn [&Int32] Int32)) + (register MAX Int32 "CARP_INT32_MAX") + (implements MAX MAX) + (register MIN Int32 "CARP_INT32_MIN") + (implements MIN MIN) (defn zero [] (from-long 0l)) @@ -166,6 +178,10 @@ integer.") (register to-long (λ [Int64] Long)) (register from-long (λ [Long] Int64)) (register copy (Fn [&Int64] Int64)) + (register MAX Int64 "CARP_INT64_MAX") + (implements MAX MAX) + (register MIN Int64 "CARP_INT64_MIN") + (implements MIN MIN) (defn zero [] (from-long 0l)) @@ -212,6 +228,8 @@ integer.") (register to-long (λ [Uint8] Long)) (register from-long (λ [Long] Uint8)) (register copy (Fn [&Uint8] Uint8)) + (register MAX Uint8 "CARP_UINT8_MAX") + (implements MAX MAX) (defn zero [] (from-long 0l)) @@ -258,6 +276,8 @@ integer.") (register to-long (λ [Uint16] Long)) (register from-long (λ [Long] Uint16)) (register copy (Fn [&Uint16] Uint16)) + (register MAX Uint16 "CARP_UINT16_MAX") + (implements MAX MAX) (defn zero [] (from-long 0l)) @@ -304,6 +324,8 @@ integer.") (register to-long (λ [Uint32] Long)) (register from-long (λ [Long] Uint32)) (register copy (Fn [&Uint32] Uint32)) + (register MAX Uint32 "CARP_UINT32_MAX") + (implements MAX MAX) (defn zero [] (from-long 0l)) @@ -350,6 +372,8 @@ integer.") (register to-long (λ [Uint64] Long)) (register from-long (λ [Long] Uint64)) (register copy (Fn [&Uint64] Uint64)) + (register MAX Uint64 "CARP_UINT64_MAX") + (implements MAX MAX) (defn zero [] (from-long 0l)) diff --git a/core/carp_stdint.h b/core/carp_stdint.h index 02a7e4fc6..610bb5880 100644 --- a/core/carp_stdint.h +++ b/core/carp_stdint.h @@ -7,6 +7,20 @@ typedef int16_t Int16; typedef int32_t Int32; typedef int64_t Int64; +uint8_t CARP_UINT8_MAX = UINT8_MAX; +uint16_t CARP_UINT16_MAX = UINT16_MAX; +uint32_t CARP_UINT32_MAX = UINT32_MAX; +uint64_t CARP_UINT64_MAX = UINT64_MAX; + +int8_t CARP_INT8_MAX = INT8_MAX; +int8_t CARP_INT8_MIN = INT8_MIN; +int16_t CARP_INT16_MAX = INT16_MAX; +int16_t CARP_INT16_MIN = INT16_MIN; +int32_t CARP_INT32_MAX = INT32_MAX; +int32_t CARP_INT32_MIN = INT32_MIN; +int64_t CARP_INT64_MAX = INT64_MAX; +int64_t CARP_INT64_MIN = INT64_MIN; + Uint8 Uint8__PLUS_(Uint8 x, Uint8 y) { return x + y; } From 9d9f982ce8c77b246ac82074c5435b49fb80bf69 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Tue, 19 Apr 2022 09:29:26 -0500 Subject: [PATCH 39/59] feat: add fputc wrapper to IO (#1417) * feat: add fputc wrapper to IO fputc is a low-level function that writes a single C character to a file. We can use this as a basis for more elegant APIs. The signature matches that of the C standard library function for compatibility, which takes an Int instead of a char. However, the documentation notes that the int argument is converted to an unsigned char. * doc: fix typos for fgetc and fputc docs --- core/IO.carp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/IO.carp b/core/IO.carp index e62e07183..dab0ced55 100644 --- a/core/IO.carp +++ b/core/IO.carp @@ -16,8 +16,10 @@ module are wrappers around the C standard library.") (register stderr (Ptr FILE) "stderr") (doc get-char "gets a character from stdin (thin wrapper for getchar() from C standard library).") (register get-char (Fn [] Int) "getchar") - (doc fgetc "gets a character from file (thin wrapper for the from C standard library).") + (doc fgetc "gets a character from file (thin wrapper for fgetc from the C standard library).") (register fgetc (Fn [(Ptr FILE)] Int) "fgetc") + (doc fputc "writes a character to a file (thin wrapper for fputc from the C standard library).") + (register fputc (Fn [Int (Ptr FILE)] Int) "fputc") (doc EOF "the End-Of-File character as a literal (thin wrapper for the C standard library)") (register EOF Int "EOF") (private fopen-) From 5d2338824bcaed09556ca4d6d638f12de19b7716 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim=20D=C3=A9v=C3=A9?= Date: Thu, 21 Apr 2022 11:45:26 +0100 Subject: [PATCH 40/59] docs: Updates markdown docs to only have one h1 (#1418) --- docs/DynamicSemantics.md | 2 -- docs/ReleaseChecklist.md | 12 ++++++------ docs/Tooling.md | 2 +- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/docs/DynamicSemantics.md b/docs/DynamicSemantics.md index e52b371ad..1cba8765c 100644 --- a/docs/DynamicSemantics.md +++ b/docs/DynamicSemantics.md @@ -25,8 +25,6 @@ This document will help us rewrite Carp's dynamic evaluator (defined in Eval.hs)
-# Semantics - ## Index [TODO] diff --git a/docs/ReleaseChecklist.md b/docs/ReleaseChecklist.md index 13fc679ca..468106b21 100644 --- a/docs/ReleaseChecklist.md +++ b/docs/ReleaseChecklist.md @@ -2,30 +2,30 @@ Do all of these things (somewhat) in order: -# 1. Update Cabal project version +## 1. Update Cabal project version See the second line of the file [CarpHask.cabal](../CarpHask.cabal). -# 2. Update the "Welcome to Carp X.Y.Z" REPL message +## 2. Update the "Welcome to Carp X.Y.Z" REPL message See [Main.hs](../App/Main.hs). -# 3. Update the blurb in README.md +## 3. Update the blurb in README.md See [README.md](../README.md) -# 4. Update the changelog +## 4. Update the changelog See [CHANGELOG.md](../CHANGELOG.md) -# 5. Make a commit on master +## 5. Make a commit on master ```bash $ git add . $ git commit -m "build: Release X.Y.Z" ``` -# 6. Tag the commit and push it +## 6. Tag the commit and push it ```bash $ git tag vX.Y.Z diff --git a/docs/Tooling.md b/docs/Tooling.md index 38f00ce0d..181d1d355 100644 --- a/docs/Tooling.md +++ b/docs/Tooling.md @@ -6,7 +6,7 @@ ## Emacs [https://github.com/carp-lang/carp-emacs](https://github.com/carp-lang/carp-emacs) -# Atom +## Atom [language-carp](https://atom.io/packages/language-carp) offers highlight with both TextMate and Tree-sitter, where tree-sitter grammar is more powerful. ## Other editors From e32ec43a26c51ebd136776566909f19476df6ed9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Fri, 22 Apr 2022 20:35:39 +0200 Subject: [PATCH 41/59] build: Release 0.5.5 --- CHANGELOG.md | 24 ++++++++++++++++++++++++ CarpHask.cabal | 2 +- README.md | 2 +- app/Main.hs | 2 +- 4 files changed, 27 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6c65a599f..47ca6ce8d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,27 @@ +# 0.5.5 +docs: updates markdown docs to only have one h1 (#1418) +feat: add fputc wrapper to IO (#1417) +feat: register MAX and MIN macros for stdint types (#1412) +fix: respect symbol modes on interface concretization (#1415) +fix: respect let binding shadowing in memory management (#1413) +feat: adds Dynamic.sort & improves output of failing dynamic tests (#1411) +feat: implement blit on ByteOrder (#1410) +chore: updates Stackage version to 19.2 (#1408) +feat: don't manage blittable types (#1407) +ci: re-enable Debug.sanitize on Windows (#1406) +feat: add IO.fgetc (#1405) +feat: support cons-last for arrays (#1402) +refactor: project configuration get/set parity (#1400) +ci: Fixes scoop install as admin user (#1399) +feat: add c-name meta field (#1398) +feat: add Dynamic.String.to-array (#1382) +fix: mangle field names in setter templates (#1379) +fix: fix leading % format in fmt (#1380) +fix: #1347 by ignoring generically typed symbols on printing C (#1373) +fix: nix install by using correct pkg-configDepends config key (#1372) +fix: type signature of Array.unsafe-raw (#1375) +docs: Instructions to ensure correct handling of utf-8 (#1367) + # 0.5.4 - refactor: Add type candidates and template generators (#1361) - fix: Ensure registered types with fields emit path (#1364) diff --git a/CarpHask.cabal b/CarpHask.cabal index 3d4fd115d..f5effcaf4 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -1,5 +1,5 @@ name: CarpHask -version: 0.5.4.0 +version: 0.5.5.0 -- synopsis: -- description: homepage: https://github.com/eriksvedang/Carp diff --git a/README.md b/README.md index 528487e02..272cb63c3 100644 --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ WARNING! This is a research project and a lot of information here might become outdated and misleading without any explanation. Don't use it for anything important just yet! -[Version 0.5.4 of the language is out!](https://github.com/carp-lang/Carp/releases/) +[Version 0.5.5 of the language is out!](https://github.com/carp-lang/Carp/releases/) ## About diff --git a/app/Main.hs b/app/Main.hs index fb0973b81..1838945a9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -144,7 +144,7 @@ main = do >>= execStrs "Postload" postloads >>= \ctx -> case execMode of Repl -> do - putStrLn "Welcome to Carp 0.5.4" + putStrLn "Welcome to Carp 0.5.5" putStrLn "This is free software with ABSOLUTELY NO WARRANTY." putStrLn "Evaluate (help) for more information." snd <$> runRepl ctx From e0b829138078adac36e0c45787ddf96cdbdf3183 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Fri, 22 Apr 2022 21:21:01 +0200 Subject: [PATCH 42/59] fix: bullet points in change log --- CHANGELOG.md | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 47ca6ce8d..937b6ae6c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,26 +1,26 @@ # 0.5.5 -docs: updates markdown docs to only have one h1 (#1418) -feat: add fputc wrapper to IO (#1417) -feat: register MAX and MIN macros for stdint types (#1412) -fix: respect symbol modes on interface concretization (#1415) -fix: respect let binding shadowing in memory management (#1413) -feat: adds Dynamic.sort & improves output of failing dynamic tests (#1411) -feat: implement blit on ByteOrder (#1410) -chore: updates Stackage version to 19.2 (#1408) -feat: don't manage blittable types (#1407) -ci: re-enable Debug.sanitize on Windows (#1406) -feat: add IO.fgetc (#1405) -feat: support cons-last for arrays (#1402) -refactor: project configuration get/set parity (#1400) -ci: Fixes scoop install as admin user (#1399) -feat: add c-name meta field (#1398) -feat: add Dynamic.String.to-array (#1382) -fix: mangle field names in setter templates (#1379) -fix: fix leading % format in fmt (#1380) -fix: #1347 by ignoring generically typed symbols on printing C (#1373) -fix: nix install by using correct pkg-configDepends config key (#1372) -fix: type signature of Array.unsafe-raw (#1375) -docs: Instructions to ensure correct handling of utf-8 (#1367) +- docs: updates markdown docs to only have one h1 (#1418) +- feat: add fputc wrapper to IO (#1417) +- feat: register MAX and MIN macros for stdint types (#1412) +- fix: respect symbol modes on interface concretization (#1415) +- fix: respect let binding shadowing in memory management (#1413) +- feat: adds Dynamic.sort & improves output of failing dynamic tests (#1411) +- feat: implement blit on ByteOrder (#1410) +- chore: updates Stackage version to 19.2 (#1408) +- feat: don't manage blittable types (#1407) +- ci: re-enable Debug.sanitize on Windows (#1406) +- feat: add IO.fgetc (#1405) +- feat: support cons-last for arrays (#1402) +- refactor: project configuration get/set parity (#1400) +- ci: Fixes scoop install as admin user (#1399) +- feat: add c-name meta field (#1398) +- feat: add Dynamic.String.to-array (#1382) +- fix: mangle field names in setter templates (#1379) +- fix: fix leading % format in fmt (#1380) +- fix: #1347 by ignoring generically typed symbols on printing C (#1373) +- fix: nix install by using correct pkg-configDepends config key (#1372) +- fix: type signature of Array.unsafe-raw (#1375) +- docs: Instructions to ensure correct handling of utf-8 (#1367) # 0.5.4 - refactor: Add type candidates and template generators (#1361) From 4c24c9eca74c5a114f82b0f8aa51c9f0f2d79926 Mon Sep 17 00:00:00 2001 From: Stig Brautaset Date: Sun, 14 Aug 2022 08:46:41 +0100 Subject: [PATCH 43/59] docs: Fix typo in language guide (#1426) --- docs/LanguageGuide.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/LanguageGuide.md b/docs/LanguageGuide.md index 590d82463..31dc1a233 100644 --- a/docs/LanguageGuide.md +++ b/docs/LanguageGuide.md @@ -383,7 +383,7 @@ and `Cat.meow` as an implementation of `speak`: (implements speak Cat.meow)) ``` -Only functions that satisfy an interface's singature can implement +Only functions that satisfy an interface's signature can implement it. For exmaple, the following function isn't a valid implementation of `speak` because it has the wrong number of arguments and its return type does not match the return type of `speak`: From e4adef0c97f3d24ad06653de852922b8648e37fd Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Mon, 29 Aug 2022 09:56:58 +0200 Subject: [PATCH 44/59] feat: add bag data structure (#1429) * feat: add bag data structure * refactor: incorporate feedback by scolsen --- core/Map.carp | 120 +++++++++++++++++++++++++++++++++++++++++++++++--- test/map.carp | 113 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 226 insertions(+), 7 deletions(-) diff --git a/core/Map.carp b/core/Map.carp index f654932e1..272b23d33 100644 --- a/core/Map.carp +++ b/core/Map.carp @@ -274,13 +274,28 @@ (doc update-with-default "Update value at key k in map with function f. If k doesn't exist in map, set k to (f v).") (defn update-with-default [m k f v] - (let [idx (Int.positive-mod (hash k) @(n-buckets &m))] - (update-buckets m &(fn [b] - (let [n (Array.unsafe-nth &b idx) - i (Bucket.find n k)] - (if (<= 0 i) - (Array.aset b idx (Bucket.set-idx @n i &(~f (Bucket.get-idx n i)))) - (Array.aset b idx (Bucket.push-back @n k &(~f @&v))))))))) + (let [idx (Int.positive-mod (hash k) @(n-buckets &m)) + in? (Map.contains? &m k)] + (update-len + (update-buckets m &(fn [b] + (let [n (Array.unsafe-nth &b idx) + i (Bucket.find n k)] + (if (<= 0 i) + (Array.aset b idx (Bucket.set-idx @n i &(~f (Bucket.get-idx n i)))) + (Array.aset b idx (Bucket.push-back @n k &(~f @&v))))))) + &(if in? id Int.inc)))) + + (doc update-with-default! "Update value at key k in map with function f, in-place. If k doesn't exist in map, set k to (f v).") + (defn update-with-default! [m k f v] + (let-do [idx (Int.positive-mod (hash k) @(n-buckets m)) + b (buckets m) + n (Array.unsafe-nth b idx) + i (Bucket.find n k)] + (if (<= 0 i) + (Array.aset! b idx (Bucket.set-idx @n i &(~f (Bucket.get-idx n i)))) + (do + (set-len! m (Int.inc @(len m))) + (Array.aset! b idx (Bucket.push-back @n k &(~f @&v))))))) (doc length "Get the length of the map m.") (defn length [m] @@ -806,3 +821,94 @@ collision.") (defndynamic to-array [m] (collect-into (reduce append '() m) array)) ) ) + +(deftype (Bag a) [ + internal (Map a Int) +]) + +(doc Bag + "is an unordered datatype that only stores all its equal elements once while preserving size by storing the count of each element." + "" + "Implementation notes: it is a map from elements to number of occurrences" + "under the hood.") +(defmodule Bag + (private internal) + (hidden internal) + (private set-internal) + (hidden set-internal) + (private update-internal) + (hidden internal) + + (doc create "Create an empty bag.") + (defn create [] + (init (Map.create))) + + (doc contains? "Check whether the bag `b` contains the value `v`.") + (defn contains? [b v] + (Map.contains? (internal b) v)) + + (doc put "Put a value `v` into the bag `b`.") + (defn put [b v] + (update-internal b &(fn [m] (Map.update-with-default m v &Int.inc 0)))) + + (doc put! "Put a value `v` into the bag `b` in-place.") + (defn put! [b v] + (Map.update-with-default! (internal b) v &Int.inc 0)) + + (doc length "Get the length of bag `b`.") + (defn length [b] + (Map.kv-reduce &(fn [acc _ v] (+ acc @v)) 0 (internal b))) + + (doc empty? "Check whether the bag `b` is empty.") + (defn empty? [b] + (Map.empty? (internal b))) + (implements empty? Bag.empty?) + + (doc remove "Remove the value `v` from the bag `b`.") + (defn remove [b v] + (if (not (contains? &b v)) + b + (update-internal b &(fn [m] + (let [cnt (Map.get &m v)] + (if (= cnt 1) + (Map.remove m v) + (Map.update m v &Int.dec))))))) + + (doc all? "Does the predicate hold for all values in this bag?") + (defn all? [pred bag] + (Array.all? pred &(Map.keys (internal bag)))) + + (defn = [a b] + (= (internal a) (internal b))) + (implements = Bag.=) + + (doc for-each "Execute the unary function f for each element in the bag b.") + (defn for-each [b f] + (doall f (Map.keys (internal b)))) + + (doc from-array "Create a bag from the values in array a.") + (defn from-array [a] + (let-do [b (create)] + (for [i 0 (Array.length a)] + (let [e (Array.unsafe-nth a i)] + (put! &b e))) + b)) + + (doc reduce "Reduce values of the bag b with function f. Order of reduction is not guaranteed") + (defn reduce [f init b] + (Map.kv-reduce + &(fn [r k cnt] (Array.reduce f r &(Array.replicate @cnt k))) + init + (internal b))) + + (doc to-array "Convert bag to Array of elements") + (defn to-array [b] + (reduce &(fn [arr elt] (Array.push-back arr @elt)) [] b)) + + (defn str [set] + (let [res (reduce &(fn [s e] (String.join "" &[s @" " (prn e)])) + @"(Bag" + set)] + (String.append &res ")"))) + (implements str Bag.str) +) diff --git a/test/map.carp b/test/map.carp index 96239989d..5c10e0ab6 100644 --- a/test/map.carp +++ b/test/map.carp @@ -356,4 +356,117 @@ 2 (Array.length &(Set.to-array &(Set.from-array &[1 2]))) "Set.to-array works 2" + ) + (assert-true test + (let-do [s (Bag.create)] + (Bag.put! &s "1") + (Bag.contains? &s "1")) + "put! works" + ) + (assert-equal test + 1 + (Bag.length &(Bag.put (Bag.create) "1")) + "length works" + ) + (assert-equal test + 2 + (Bag.length &(Bag.put (Bag.put (Bag.create) "1") "2")) + "length works" + ) + (assert-equal test + 2 + (Bag.length &(Bag.put (Bag.put (Bag.create) "1") "1")) + "putting the same element twice increases size" + ) + (assert-equal test + 0 + (Bag.length &(the (Bag Int) (Bag.create))) + "length works on empty bag" + ) + (assert-equal test + false + (Bag.contains? &(the (Bag String) (Bag.create)) "1") + "contains? works on empty map" + ) + (assert-equal test + true + (Bag.contains? &(Bag.put (Bag.create) "1") "1") + "contains? works" + ) + (assert-equal test + true + (Bag.contains? &(Bag.put (Bag.create) &-7) &-7) + "contains? works with negative keys" + ) + (assert-equal test + true + (Bag.empty? &(the (Bag Int) (Bag.create))) + "empty? works on empty bag" + ) + (assert-equal test + false + (Bag.empty? &(Bag.put (Bag.create) "1")) + "empty? works" + ) + (assert-equal test + true + (Bag.empty? &(Bag.remove (Bag.put (Bag.create) "1") "1")) + "remove works" + ) + (assert-equal test + true + (Bag.all? &(fn [i] (Int.even? @i)) &(Bag.from-array &[2 4 6 6])) + "Bag.all? works I" + ) + (assert-equal test + false + (Bag.all? &(fn [i] (Int.even? @i)) &(Bag.from-array &[2 4 7])) + "Bag.all? works II" + ) + (assert-equal test + true + (Bag.all? &(fn [i] false) &(the (Bag Int) (Bag.create))) + "Bag.all? works on empty set" + ) + (assert-equal test + true + (Bag.= &(Bag.from-array &[1 3 5]) &(Bag.from-array &[1 3 5])) + "Bag.= works" + ) + (assert-equal test + false + (Bag.= &(Bag.from-array &[1 3]) &(Bag.from-array &[1 3 5])) + "Bag.= works II" + ) + (assert-equal test + false + (Bag.= &(Bag.from-array &[1 3 5]) &(Bag.from-array &[1 3])) + "Bag.= works III" + ) + (assert-equal test + false + (Bag.= &(Bag.from-array &[1 3 5]) &(Bag.from-array &[1 4 5])) + "Bag.= works IV" + ) + (assert-equal test + 71 + (Bag.reduce &(fn [state i] (+ state (* 10 @i))) + 1 + &(Bag.from-array &[1 2 3 1])) + "reduce works" + ) + (assert-equal test + "(Bag @\"hi\" @\"hi\" @\"bye\")" + &(str &(Bag.from-array &[@"hi" @"bye" @"hi"])) + "stringification works" + ) + (assert-equal test + &[1] + &(Bag.to-array &(Bag.put (Bag.create) &1)) + "Bag.to-array works 1" + ) + (assert-equal test + 3 + (Array.length &(Bag.to-array &(Bag.from-array &[1 2 1]))) + "Bag.to-array works 2" )) From d67e4bea4c953f6f6a2db6a14ab77faa3d5757e0 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Tue, 30 Aug 2022 07:42:05 +0200 Subject: [PATCH 45/59] fix: allow String.concat to work on lists (#1430) --- src/Commands.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Commands.hs b/src/Commands.hs index 7da0db1e1..c8b00ee3e 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -500,6 +500,10 @@ commandStringConcat ctx a = case mapM unwrapStringXObj strings of Left err -> evalError ctx err (xobjInfo a) Right result -> (ctx, Right (XObj (Str (join result)) (Just dummyInfo) (Just StringTy))) + XObj (Lst strings) _ _ -> + case mapM unwrapStringXObj strings of + Left err -> evalError ctx err (xobjInfo a) + Right result -> (ctx, Right (XObj (Str (join result)) (Just dummyInfo) (Just StringTy))) _ -> evalError ctx ("Can't call concat with " ++ pretty a) (xobjInfo a) commandStringSplitOn :: BinaryCommandCallback From 0a7a83543d0e6857807a2d02e949bdc185862d9f Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Tue, 30 Aug 2022 15:40:13 +0200 Subject: [PATCH 46/59] fix: quasiquoting breaks List.pairs (#1431) --- core/List.carp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/List.carp b/core/List.carp index f50df7a7f..11401990a 100644 --- a/core/List.carp +++ b/core/List.carp @@ -337,7 +337,7 @@ elements is uneven, the trailing element will be discarded.") (defndynamic pairs [l] (if (< (length l) 2) '() - (cons `(%(car l) %(cadr l)) (List.pairs (cddr l))))) + (cons (list (car l) (cadr l)) (List.pairs (cddr l))))) (doc nth "gets the nth element of the list `l`.") (defndynamic nth [l n] From 106bcaa6fb662ea152399a8cc91e03601e45eef8 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 28 Sep 2022 00:53:00 -0400 Subject: [PATCH 47/59] refactor: remove unnecessary solveOneInternal function (#1433) --- src/Constraints.hs | 49 ++++++++++++++++++++++------------------------ 1 file changed, 23 insertions(+), 26 deletions(-) diff --git a/src/Constraints.hs b/src/Constraints.hs index a56ea57de..7f30da7ae 100644 --- a/src/Constraints.hs +++ b/src/Constraints.hs @@ -103,18 +103,15 @@ isTypeHole :: (String, Ty) -> Bool isTypeHole ('?' : _, _) = True isTypeHole _ = False -solveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings -solveOne = solveOneInternal - debugSolveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings debugSolveOne mappings constraint = - let m' = solveOneInternal mappings constraint + let m' = solveOne mappings constraint in trace ("" ++ show constraint ++ ", MAPPINGS: " ++ show m') m' -solveOneInternal :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings -solveOneInternal mappings constraint = +solveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings +solveOne mappings constraint = case constraint of --trace ("SOLVE " ++ show constraint) constraint of -- Two type variables Constraint aTy@(VarTy aName) bTy@(VarTy bName) _ _ _ _ -> @@ -129,9 +126,9 @@ solveOneInternal mappings constraint = -- Struct types Constraint (StructTy nameA varsA) (StructTy nameB varsB) _ _ _ _ -> let (Constraint _ _ i1 i2 ctx ord) = constraint - in case solveOneInternal mappings (Constraint nameA nameB i1 i2 ctx ord) of + in case solveOne mappings (Constraint nameA nameB i1 i2 ctx ord) of Left err -> Left err - Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip varsA varsB) + Right ok -> foldM (\m (aa, bb) -> solveOne m (Constraint aa bb i1 i2 ctx ord)) ok (zip varsA varsB) -- Func types Constraint (FuncTy argsA retA ltA) (FuncTy argsB retB ltB) _ _ _ _ -> if length argsA == length argsB @@ -139,43 +136,43 @@ solveOneInternal mappings constraint = let (Constraint _ _ i1 i2 ctx ord) = constraint res = foldM - (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) + (\m (aa, bb) -> solveOne m (Constraint aa bb i1 i2 ctx ord)) mappings ( zip (retA : argsA) (retB : argsB) ) in case res of - Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord) + Right ok -> solveOne ok (Constraint ltA ltB i1 i2 ctx ord) Left err -> Left err else Left (UnificationFailure constraint mappings) -- Pointer types Constraint (PointerTy a) (PointerTy b) _ _ _ _ -> let (Constraint _ _ i1 i2 ctx ord) = constraint - in solveOneInternal mappings (Constraint a b i1 i2 ctx ord) + in solveOne mappings (Constraint a b i1 i2 ctx ord) -- Ref types -- TODO: This messes up the error message since the constraint is between non-reffed types so the refs don't show in the error message!!! Constraint (RefTy a ltA) (RefTy b ltB) _ _ _ _ -> let (Constraint _ _ i1 i2 ctx ord) = constraint - in case solveOneInternal mappings (Constraint a b i1 i2 ctx ord) of + in case solveOne mappings (Constraint a b i1 i2 ctx ord) of Left err -> Left err - Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord) + Right ok -> solveOne ok (Constraint ltA ltB i1 i2 ctx ord) -- As a special case, allow Refs to stand for higher-order polymorphic -- structs (f a b) ~ (Ref a b) Constraint (StructTy v@(VarTy _) args) (RefTy b ltB) _ _ _ _ -> let (Constraint _ _ i1 i2 ctx ord) = constraint - in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of + in case solveOne mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of Left err -> Left err - Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB]) + Right ok -> foldM (\m (aa, bb) -> solveOne m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB]) -- TODO: The reverse argument order is necessary here since interface code -- uses the opposite order of most other solving code (abstract, concrete -- vs. concrete, abstract)--we should bring the interface code into -- compliance with this to obviate this stanza Constraint (RefTy b ltB) (StructTy v@(VarTy _) args) _ _ _ _ -> let (Constraint _ _ i1 i2 ctx ord) = constraint - in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of + in case solveOne mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of Left err -> Left err - Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB]) + Right ok -> foldM (\m (aa, bb) -> solveOne m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB]) -- Else Constraint _ CTy _ _ _ _ -> Right mappings Constraint CTy _ _ _ _ _ -> Right mappings @@ -207,37 +204,37 @@ checkConflictInternal mappings constraint name otherTy = Just (VarTy _) -> ok Just (StructTy (VarTy _) structTyVars) -> case otherTy of - StructTy _ otherTyVars -> foldM solveOneInternal mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars) + StructTy _ otherTyVars -> foldM solveOne mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars) VarTy _ -> Right mappings _ -> Left (UnificationFailure constraint mappings) Just (StructTy (ConcreteNameTy structName) structTyVars) -> case otherTy of StructTy (ConcreteNameTy otherStructName) otherTyVars - | structName == otherStructName -> foldM solveOneInternal mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars) - StructTy (VarTy _) otherTyVars -> foldM solveOneInternal mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars) + | structName == otherStructName -> foldM solveOne mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars) + StructTy (VarTy _) otherTyVars -> foldM solveOne mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars) VarTy _ -> Right mappings _ -> Left (UnificationFailure constraint mappings) Just (FuncTy argTys retTy lifetimeTy) -> case otherTy of FuncTy otherArgTys otherRetTy otherLifetimeTy -> do - m <- foldM solveOneInternal mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys) - case solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy) of - Right _ -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy) + m <- foldM solveOne mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys) + case solveOne m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy) of + Right _ -> solveOne m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy) Left err -> Left err VarTy _ -> Right mappings _ -> Left (UnificationFailure constraint mappings) Just (PointerTy innerTy) -> case otherTy of - PointerTy otherInnerTy -> solveOneInternal mappings (mkConstraint OrdPtr xobj1 xobj2 ctx innerTy otherInnerTy) + PointerTy otherInnerTy -> solveOne mappings (mkConstraint OrdPtr xobj1 xobj2 ctx innerTy otherInnerTy) VarTy _ -> Right mappings _ -> Left (UnificationFailure constraint mappings) Just (RefTy innerTy lifetimeTy) -> case otherTy of RefTy otherInnerTy otherLifetimeTy -> - case solveOneInternal mappings (mkConstraint OrdRef xobj1 xobj2 ctx innerTy otherInnerTy) of + case solveOne mappings (mkConstraint OrdRef xobj1 xobj2 ctx innerTy otherInnerTy) of Left err -> Left err - Right smappings -> solveOneInternal smappings (mkConstraint OrdRef xobj1 xobj2 ctx lifetimeTy otherLifetimeTy) + Right smappings -> solveOne smappings (mkConstraint OrdRef xobj1 xobj2 ctx lifetimeTy otherLifetimeTy) VarTy _ -> Right mappings _ -> Left (UnificationFailure constraint mappings) Just foundNonVar -> case otherTy of From ce0601ae6ed4d094cf67797fbab8c847a69dfa09 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Tue, 1 Nov 2022 07:07:30 -0400 Subject: [PATCH 48/59] docs: update memory.md (#1435) --- docs/Memory.md | 396 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 380 insertions(+), 16 deletions(-) diff --git a/docs/Memory.md b/docs/Memory.md index d55650d87..8674e3b92 100644 --- a/docs/Memory.md +++ b/docs/Memory.md @@ -1,34 +1,389 @@ # Memory Management - a closer look -### Related pages +Carp uses a *linear type system* to manage the memory associated with different +values throughout a program. Carp's memory management system is designed and +implemented with the following goals in mind: + +* Predictable: The memory management system's behavior should be easy to reason + about. +* Efficient: The memory management system should not have significant impacts + on performance. +* Safe: The memory management system should prevent errors related to memory + management, such as "use after free" and "double free" + +This document introduces the basic concepts behind the kind of linear type +system Carp uses. In addition, it takes a deeper look at how the system is +currently implemented. + +## Linear Types and Memory Management + +Carp's linear type system tracks the *ownership* of the memory associated with a +given value as part of its type signature. A *linear type* is a traditional type +with additional information called a *lifetime* that allows the type system to +track a value's association with a given memory location. + +The memory management system *only* manages linear types; not all types are +linear. Some of Carp's builtin types are linear by default: + +- The String type is linear and managed by the memory system. +- The Pattern type is linear and managed by the memory system. +- The Array type is linear and managed by the memory system. +- The Box type is linear and managed by the memory system. +- Function types are linear and managed by the memory system. + +All other builtin types are *not* linear, and thus aren't managed by the memory +system. + +A few conditions determine whether or not a user defined type is linear: + +- **Implementation of the `blit` interface**: this interface explicitly marks a + type as *non-linear*. Any type that implements it is ignored by the memory + management system and is assumed to pose no risks in relation to memory + allocation and deallocation. +- **Implementation of the `delete` interface**: this interface explicitly marks + a type as *linear*. Any type that implements it is managed by the memory + management system. Carp will call the implementation of this interface whenever + the memory management system decides it's safe to deallocate the memory + associated with a value of the type that implements this interface. + +When you define a type directly in Carp code, using `deftype` Carp will +*automatically implement the delete interface for you*. As a consequence, any +type that you declare using `deftype` will be managed by the memory management +system. In the most cases, this automatic management of user defined types is +beneficial. You can always redefine `delete` for your type if you need to write +a custom memory deallocation routine. However, if you need to define a type +that requires fine-grained control over its memory deallocation, it might be +better to define both the type and its deallocation routines in C, and register +them in Carp. + +The same conditions hold for [registered types][3] as well. If you register an +external type defined in C, Carp won't manage it unless you provide an +implementation of `delete` for the corresponding Carp type. See the [C interop +documentation][3] for more information. + +In the following sections, we'll explore a few key memory system operations. +Along the way, we'll present examples using Carp's builtin linear String type +to illustrate how the system manages values of linear types. + +## Bindings, Ownership, and Lexical Scopes + +Unless your program is incredibly short, you'll likely have one or more +*bindings* that associate names with values in your program. Typically, we can +assign the value of one binding to another. Consider the following local +variables in a let form: + +```clojure +(let [x 1 + y x + z x] + x) +``` + +In the example above, we assign the non-linear value *1* to `x`, then assign the +value of `x` to `y`, then assign the value of `x` to `z`. + +In Carp, linear values are treated differently. When we assign a linear value to +a binding, such as a local variable name, the *memory location* associated with +the value is also bound to the name. This changes the rules about how we can +assign values and pass them around a program. If we try to write the same +program as we did above, using a value of the linear type, `String`, we get +quite a different result: + +```clojure +;; Don't worry about the @ before the string literal. We'll explain it soon. +(let [string @"linear types!" + other-string string ;; used here! + yet-another-string string] ;; and here! + string) ;; and again here! +``` + +If you try to pass this program to the Carp compiler, you'll get an error in +return: `You’re using a given-away value string`. + +This illustrates the 'golden rule' that the memory management system enforces: +**every linear value can only be used once**. When we first assign `@"linear +types!"` to the variable `string`, we've already used it once. When we attempt +to assign `string` to `other-string` *and* `yet-another-string`, the memory +management system will detect that we're attempting to use the single value +`@"linear types!"` multiple times, which it won't allow. Note that *only* +assigning the value to string, then `string` to `other-string` is OK, as long as +we return `other-string`—we'll explain why in a later section. + +In casual terminology, this concept is called *ownership*. The binding to which +the linear value is assigned *owns* its associated memory. We can call such a +binding the value's *owner*. In this example, `string` is the initial owner of +the memory allocated for the linear value `@"linear types!"`. + +Every binding in Carp has a *lexical scope* that determines where in the program +the binding name is defined and can be validly referenced. The lexical scope of +`string` in our example happens to be our let form. The lexical scope of a +function parameter is only the body of the function. + +A linear value can only be used *once* in a single *lexical scope*. We "use" a +linear value whenever we *pass it to a different lexical scope*. For example, we +"use" `string`, if we return it: + +```clojure +(let [string @"linear types!"] + string) ;; used here! +``` + +We also use it when we pass it to another function: + +```clojure +(let [string @"linear types!"] + (do (reverse string) ;; used here! + ())) +``` -* [Drop](Drop.md) - a deeper look at the `drop` interface +What do both of these cases have in common? They raise the possibility that +`string`'s value (and it's assocaited memory) is passed to *another binding* +(when we pass it to a function, it's rebound to the function parameter; when we +return it, the caller might bind it to a new name in the lexical scope that +contains our let). As we'll see later, these are two particular examples of a +specific form of an operation we'll call *moving*. Binding the value of an +existing linear binding, as in `(let [string @"linear types!" other-string +string] ()))` is also a case of moving. -The goals of the memory management system in Carp are the following: +### Safe Deallocations -* Predictable -* Efficient -* Safe +The "use once" restriction is the mechanism that allows the memory management +system to prevent classical memory errors such as "use after free" and "double +free". Enforcing that a linear value is only used *once* in any lexical scope, +allows the management system to determine precisely when a binding's associated +memory can be freed. -This is achieved through a linear type system where memory is owned by the function or let-scope that allocated it. When the scope is exited the memory is deleted, unless it was returned to its outer scope or handed off to another function (passed as an argument). The other thing that can be done is temporarily lending out some piece of memory to another function using a ref: +When the memory management system determines some linear value will no longer be +used in the lexical scope of it's *owner*, it automatically calls the +corresponding linear type's `delete` implementation to free the associated +memory. +Now that we have an initial sense about the restrictions the memory management +system enforces around our use of linear values, we'll explore a few operations +the system performs that allow us to have greater flexibility. + +## Moving, Borrowing, and Copying + +At a high level, the functionality of the linear type system can be organized +into three primary operations: *moving*, *borrowing*, and *copying*. These are +casual, intuitive terms for what the system does with linear values as it +manages them across your program. We'll explore precise technical terminology +for each of these operations later on. + +### Moving: Transferring Ownership + +The memory management system ensures that only one binding ever owns the memory +associated with a given linear value. As a result, unlike non-linear values, +the compiler won't let you bind the same linear value to more than one +variable. Instead, when you reassign a linear value to another variable, The +old binding is invalidated, as we saw earlier: + +```clojure +(let [string @"linear types!" + other-string string + yet-another-string string] ;; error here! + ()) ``` -(let [s (make-string)] - (println &s)) + +In the prior example, the binding `string` is invalidated as soon as we assign +it to the binding `other-string`. The memory associated with `string` is now +associated with the binding `other-string`, and `other-string` is the linear +string's new owner. This process is called a *transfer of ownership*, or +*moving*. + +If we were to move our value across a number of bindings in sequence, we'd fix +our problem! There's no issue with moving some linear value across different +bindings in a lexical scope, there's only an issue if we attempt to move a value +out of *the same binding* more than once: + +```clojure +(let [string @"linear types!" ;; linear string value here. + other-string string ;; moved over to this binding + yet-another-string other-string] ;; still ok, moved to this binding + ()) ``` -In the example above s is of type String and it's contents are temporarily borrowed by 'println'. When the let-scope ends Carp will make sure that a call to `(String.delete s)` is inserted at the correct position. To avoid 's' being deleted, the let-expression could return it: +The important, and only rule about moving linear values is: *you can only move a +linear value from an individual binding __once__* in any given lexical scope. If +your code attempts to move a linear value from a binding more than once, the +memory management system will chastise you! + +#### Moving to a New Scope +Just as we transferred ownership of a linear value to another binding in the +same lexical scope, we can use ownership transfers to move a linear value into +a binding *beyond* its lexical scope. Consider this next example: + +```clojure +(let [string @"linear moves!"] + string) ``` -(let [s (make-string)] - (do (println &s) - s)) + +Though it's not as obvious, a move is happening here! In this case, a transfer +of ownership occurs across lexical scope boundaries. The linear string +associated with `string` and its corresponding memory are returned from the let +form. If the result of this let form is bound to some other variable, that new +binding will receive ownership of the linear string. Thus, the lifetimes of +linear values are not only limited to their lexical scopes. We can move linear +values in and out of other scopes, and the memory management system will +determine in which part of our code the value can be safely deallocated. + +Again, since returning the value is a *move*, or ownership transfer, the same +rules around moves apply: we can only make *one* move out of a given binding in +a single lexical scope: + +```clojure +(let [string @"linear moves!" + other-string string] ;; ok; first move out of string + string) ;; error! Second move out of string ``` -## Rule of thumb +Passing a linear value as an argument to a function is another example of a move +across lexical scopes. For instance, consider the following example: -To know whether a function takes over the responsibility of freeing some memory (through its args) or generates some new memory that the caller has to handle (through the return value), just look at the type of the function (right now the easiest way to do that is with the `(env)` command). If the value is a non-referenced struct type like String, Vector3, or similar, it means that the memory ownership gets handed over. If it's a reference signature (i.e. `(Ref String)`), the memory is just temporarily lended out and someone else will make sure it gets deleted. When interoping with existing C code it's often correct to send your data structures to C as refs or pointers (using `(Pointer.address )`), keeping the memory management inside the Carp section of the program. +```clojure +(let [string @"linear moves!" + reversed (reverse string)] ;; moved here! + reversed) +``` + +In this example, we *move* the linear value associated with `string` into the +function's lexical scope, binding it to whatever parameter name the function +declaration used for its first argument. Since we only moved the value out of +`string` once, the memory management system happily accepts this program. +#### Beyond Moves + +In some cases, transferring ownership might be too limiting. Let's reconsider +the earlier example, in which we tried to transfer ownership from `string` more +than once: + +```clojure +(let [string @"linear moves!" + other-string string + yet-another-string string] ;; error! + ()) +``` + +We might want to write "multi-move" code like this, but under the current rules +of the linear type system, we can't. Luckily, there's a way out: references. + +### Borrowing: Lending Ownership + +As we explored in the previous section, we can’t assign a linear value to +multiple bindings without transferring ownership. If we move a value from one +binding to another, we can only do so once, even if one of those moves transfers +ownership beyond the current scope. At any given point in a lexical scope, only +one binding can ever own the linear value. + +This restriction ensures the type system knows exactly when to deallocate the +memory associated with a linear value, but it can be a bit limiting. For +example, what if we wanted to process the value using a function, then use our +original value afterwards? + +```clojure +(let [string @"linear borrow!" + reversed (reverse string)] + (concatenate string reversed)) ;; error! +``` + +This short let block calls some imaginary functions to first reverse our linear +string, then join it with itself, returning the result. However there’s a big +problem here, once we move our string to `reverse`'s parameter the memory +management system won’t let us use it in `concatenate` since it violates the +"one move" rule. + +This time, the rule has put us in quite a difficult situation. We want to write +a program that uses `string` twice, but there's no way for us to use it twice +directly, thanks to the linear type system rules. Just passing `string` along to +other bindings won't help us here either. + +Luckily, there’s a mechanism that allows us to reuse `string` more than once in +our let block: *references*. + +References are another special type that the memory management system +understands how to work with. References are *not* linear types, but they give +us another way of working with linear types that allows us to get around the +type system’s “one owner” and "one move" restriction safely. + +A reference value points to some linear value, but because the reference is not +linear value itself, but rather a new, non-linear value, we’re allowed to pass +them around freely, just like we can with other non-linear values. Assigning a +reference to a linear value to some binding is called *borrowing*. Instead of +transferring ownership of a linear value to a new binding, we’re giving it a +temporary way to access the value, without taking it over and moving it. + +Use the `&` operator, or `ref` special form, to create a reference: + +```clojure +(let [string @"hello, linear world!" + reversed (reverse &string)] ;; reference to string + (concatenate string reversed) ;; ok; first move of string +``` + +Using references, we can get our initial string reversal and concatenation +program to work, the memory manager won’t complain. Since `string` is *borrowed* +by `reverse`, using a reference, there’s no longer an issue using it directly in +`concatenate` since this is now the one and only time it transfers ownership +(moves). + +In this case, we have no idea how `reverse` actually uses the reference to +produce a reversed string, but we’ve followed the memory management system’s +rules correctly. In the next section, we'll explore how we can actually make use +of the reference in an implementation of a function like reverse. + +### Copying: Increasing Supply + +Now that we’ve explored references and borrowing, you might wonder what we can +do with references. Again, references are not linear values themselves, but +they “point” to linear values. Their behaviors and relation to the type system +differ. So, what can we accomplish with references? + +In Carp, references, in general, (but we'll see that there are some special +cases) support only a single operation, called *copying*. Copying a reference +creates a new linear value that *duplicates* the linear value the reference is +pointing to. This new linear value is completely distinct from the original +linear value the reference points to. It has its own owner, and, just like other +linear values, the memory management system will determine when to remove it. + +Copying allows us to work with some linear value in multiple places in a safe +way. To copy the value pointed to by a reference, use the `@` operator. The +following example shows how the `reverse` function might be implemented: + +```clojure +(defn reverse [string-ref] + (reverse-internal @string-ref)) ;; reference copied here! +``` + +The function takes a reference to a linear string value, makes a copy of it, +reverses the copy, then returns the resulting linear value to the caller. Note +that we haven’t touched the original linear string pointed to by the +`string-ref` reference, we only work with a copy! + +We can also now understand the general string literal syntax we've used +throughout this text: + +```clojure +string @"hello, linear world!" +``` + +This binds a *copy* of the string literal to the variable `string`. This +reveals an important aspect of Carp’s builtin string literals: they are +references! We’ll explore why this makes sense a bit later. + +## Rule of thumb + +To know whether a function takes over the responsibility of freeing some memory +(through its args) or generates some new memory that the caller has to handle +(through the return value), just look at the type of the function (right now +the easiest way to do that is with the `(env)` command). If the value is a +non-referenced struct type like String, Vector3, or similar, it means that the +memory ownership gets handed over. If it's a reference signature (i.e. `(Ref +String)`), the memory is just temporarily lended out and someone else will make +sure it gets deleted. When interoping with existing C code it's often correct +to send your data structures to C as refs or pointers (using `(Pointer.address +)`), keeping the memory management inside the Carp section of the +program. ## Working with arrays @@ -40,7 +395,7 @@ The most important thing in Carp is to process arrays of data. Here's an example (reduce add 0 &(endo-map square (filter even? stuff))))) ``` -All the array transforming functions 'endo-map' and 'filter' use C-style mutation of the array and return the same data structure back afterwards, no allocation or deallocation needed. The lifetime analyzer ("borrow checker" in [Rust](https://www.rust-lang.org) parlance) makes sure that the same data structure isn't used in several places. +All the array transforming functions 'endo-map' and 'filter' use C-style mutation of the array and return the same data structure back afterwards, no allocation or deallocation needed. The lifetime analyzer ("borrow checker" in [Rust][1] parlance) makes sure that the same data structure isn't used in several places. The restriction of 'endo-map' is that it must return an array of the same type as the input. If that's not possible, use 'copy-map' instead. It works like the normal 'map' found in other functional languages. The 'copy-' prefix is there to remind you of the fact that the function is allocating memory. @@ -188,3 +543,12 @@ void f() { Note that a deleter is emitted for the value of type `Foo` once the `let` block ends and it goes out of scope, but not for the value of type `Bar`, which has no deleter associated with it. + +### Related pages + +* [Drop][2] - a deeper look at the `drop` interface + + +[1]: https://www.rust-lang.org +[2]: Drop.md +[3]: CInterop.md#register-types From 39208349e89c366d39991f5aaffc19c5b595b13e Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Tue, 1 Nov 2022 09:31:20 -0400 Subject: [PATCH 49/59] chore: disable unused-but-set-variable for clang (#1441) At some point (I believe version 13.0.0?) clang added a warning that catches variables that were assigned but unused. This version of clang (or later) is now bundled w/ github's macos images and is causing our tests to fail in continuous integration. We can currently generate C code that trips this warning, so for now I've disabled it as we do some other warnings related to variable usages. --- app/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/app/Main.hs b/app/Main.hs index 1838945a9..e1647598e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,6 +36,7 @@ defaultProject = "-Wall", "-Werror", "-Wno-unused-variable", + "-Wno-unused-but-set-variable", "-Wno-self-assign" ], projectLibFlags = case platform of From 0bec460f319c2724b9d58351e443a0dd7fa56d95 Mon Sep 17 00:00:00 2001 From: jgart <47760695+jgarte@users.noreply.github.com> Date: Mon, 5 Dec 2022 10:30:59 -0500 Subject: [PATCH 50/59] chore: Fix typos (#1444) --- src/Forms.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Forms.hs b/src/Forms.hs index 45c1e9c9a..0f728b7f3 100644 --- a/src/Forms.hs +++ b/src/Forms.hs @@ -149,11 +149,11 @@ data Modifier instance Show Modifier where show None = "" show (DefnQualifiedSyms arg) = - "`defn` requires all of its arguments to be unqualified symbols, but the arugment: " + "`defn` requires all of its arguments to be unqualified symbols, but the argument: " ++ pretty arg ++ " is qualified" show (DefnNonArrayArgs args) = - "`defn` requires an array of arugments, but it got: " ++ pretty args + "`defn` requires an array of arguments, but it got: " ++ pretty args show (DefnNonSymArgs arg) = "`defn` requires an array of symbols as arguments, but the argument: " ++ pretty arg @@ -178,17 +178,17 @@ instance Show Modifier where show (LetNonArrayBindings invalid) = "`let` requires an array of bindings, but it got: " ++ pretty invalid show (FnQualifiedSyms arg) = - "`fn` requires all of its arguments to be unqualified symbols, but the arugment: " + "`fn` requires all of its arguments to be unqualified symbols, but the argument: " ++ pretty arg ++ " is qualified" show (FnNonArrayArgs args) = - "`fn` requires an array of arugments, but it got: " ++ pretty args + "`fn` requires an array of arguments, but it got: " ++ pretty args show (FnNonSymArgs arg) = "`fn` requires an array of symbols as arguments, but the argument: " ++ pretty arg ++ " is not a symbol" show (InvalidWith x) = - "`with` requires a symbol as an arugment, but got: " ++ pretty x + "`with` requires a symbol as an argument, but got: " ++ pretty x formatModifier :: Modifier -> String formatModifier None = "" From 8c5845ea656b80980e8f6b3b39a9477097d6291e Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 28 Dec 2022 01:16:04 -0600 Subject: [PATCH 51/59] docs: cleanup core IO docs (#1447) --- core/IO.carp | 307 ++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 240 insertions(+), 67 deletions(-) diff --git a/core/IO.carp b/core/IO.carp index dab0ced55..f7a424cd5 100644 --- a/core/IO.carp +++ b/core/IO.carp @@ -1,99 +1,233 @@ (system-include "carp_io.h") +(doc FILE + "An opaque type representing a file handle. Wraps the `FILE` type from" + "the C standard library.") (register-type FILE) -(doc IO "is a module for performing I/O operations. Most functions found in this -module are wrappers around the C standard library.") +(doc IO + "A module for performing I/O operations. Most functions found in this" + "module are wrappers around the C standard library.") (defmodule IO - - (doc Raw "wrappers for functions from the C standard library. Consider using a more carpesque function from IO when it exists. For detailed documentation please consult the documentation of your system (e.g. under Linux try man fprint).") + (doc Raw + "Wrappers for functions from the C standard library. Consider using a more" + "carpesque function from IO when it exists. For detailed documentation please" + "consult the documentation of your system (e.g. under Linux try" + "`man fprint`).") (defmodule Raw - (doc stdin "the standard input file (thin wrapper for the C standard library).") + (doc stdin + "A file pointer to the system's standard input file (wraps the C" + "standard library `stdin`).") (register stdin (Ptr FILE) "stdin") - (doc stdout "the standard output file (thin wrapper for the C standard library).") + + (doc stdout + "A FILE pointer to the system's standard output file (wraps the C" + "standard library `stdout`).") (register stdout (Ptr FILE) "stdout") - (doc stderr "the standard error file (thin wrapper for the C standard library).") + + (doc stderr + "A FILE pointer to the system's standard error file (wraps the C" + "standard library `stderr`).") (register stderr (Ptr FILE) "stderr") - (doc get-char "gets a character from stdin (thin wrapper for getchar() from C standard library).") - (register get-char (Fn [] Int) "getchar") - (doc fgetc "gets a character from file (thin wrapper for fgetc from the C standard library).") - (register fgetc (Fn [(Ptr FILE)] Int) "fgetc") - (doc fputc "writes a character to a file (thin wrapper for fputc from the C standard library).") + + (doc get-char + "Returns a character from [`stdin`](#stdin)." + "Wraps `getchar()` from the C standard library.") + (register get-char (Fn [] Int) "getchar") + + (doc fgetc + "Returns a character from a given [FILE](#file)." + "Wraps `fgetc` from the C standard library.") + (register fgetc (Fn [(Ptr FILE)] Int) "fgetc") + + (doc fputc + "Writes a character to a [FILE](#file)" + "Wraps `fputc` from the C standard library.") (register fputc (Fn [Int (Ptr FILE)] Int) "fputc") - (doc EOF "the End-Of-File character as a literal (thin wrapper for the C standard library)") + + (doc EOF + "A signal indicating the End-Of-File has been reached." + "Wraps `EOF` from the C standard library") (register EOF Int "EOF") + (private fopen-) (hidden fopen-) (register fopen- (Fn [(Ptr CChar) (Ptr CChar)] (Ptr FILE)) "fopen" ) - (doc fopen "opens a file for input/output/appending (thin wrapper for the C standard library). Consider using the function IO.open-file instead.") - (defn fopen [pathname mode] - (fopen- (String.cstr pathname) (String.cstr mode)) ) - (doc fclose "closes a file pointer (thin wrapper for the C standard library).") - (register fclose (Fn [(Ptr FILE)] Int) "fclose") - (doc fclose! "same as (fclose) but to be used as a side effect.") - (defn fclose! [file] - (ignore (fclose file)) ) + + (doc fopen + "Low-level routine to open a file for input/output/appending." + "Wraps `fopen` from the C standard library." + "Consider using the function [IO.open-file](#open-file) instead.") + (defn fopen [pathname mode] + (fopen- (String.cstr pathname) (String.cstr mode))) + + (doc fclose + "Closes the [FILE](#file) associated with the given file pointer." + "Returns an integer indicating success or failure." + "Wraps `fclose` from the C standard library.") + (register fclose (Fn [(Ptr FILE)] Int) "fclose") + + (doc fclose! + "Closes a file via [`fclose`](#fclose), but discards the result," + "making this function appropriate for use as a side effect in" + "`do` forms") + (defn fclose! [file] + (ignore (fclose file)) ) + (private fwrite-) (hidden fwrite-) - (register fwrite- (Fn [(Ptr CChar) Int Int (Ptr FILE)] Int) "fwrite") - (doc fwrite "writes a C-string to a file and returns the number of written items (thin wrapper for the C standard library). Consider using [`write-file`](#write-file) instead.") - (defn fwrite [data item-size items-count file] - (fwrite- (String.cstr data) item-size items-count file) ) - (doc fwrite! "like fwrite but returns no indicator whether writing to file succeeded. Consider using fwrite instead.") - (defn fwrite! [data item-size items-count file] + (register fwrite- (Fn [(Ptr CChar) Int Int (Ptr FILE)] Int) "fwrite") + + (doc fwrite + "Writes a C-string to a file and returns the number of written bytes." + "Wraps `fwrite` from the C standard library." + "Consider using [`write-file`](#write-file) instead.") + (defn fwrite [data item-size items-count file] + (fwrite- (String.cstr data) item-size items-count file)) + + (doc fwrite! + "Writes a C-string to a file using [`fwrite`](#fwrite), but discards the result," + "making this function appropriate for use as a side effect in" + "`do` forms.") + (defn fwrite! [data item-size items-count file] (ignore (fwrite data item-size items-count file)) ) + (private fread-) (hidden fread-) (register fread- (Fn [a Int Int (Ptr FILE)] Int) "fread") - (doc fread "reads from a file into C-String (thin wrapper for fread(cstr, item-size, items-count, file) from C standard library). Consider using [`read-file`](#read-file) or [`unsafe-read-file`](#unsafe-read-file) instead.") - (defn fread [file-name item-size items-count file] - (fread- (String.cstr file-name) item-size items-count file) ) - (doc fflush "flushes a file pointer, i.e. commits every write (thin wrapper for the C standard library).") + + (doc fread + "Reads a given numebr of bytes from a file into C-String." + "Wraps `fread` from the C standard library." + "Consider using [`read-file`](#read-file) or" + "[`unsafe-read-file`](#unsafe-read-file) instead.") + (defn fread [file-name item-size items-count file] + (fread- (String.cstr file-name) item-size items-count file)) + + (doc fflush + "Flushes buffered data associated with a given [FILE](#file) pointer." + "For files in write mode, writes all buffered data to the file." + "For files in read mode, discards all unused data in the buffer." + "If the FILE pointer is NULL, flushes all open ouput streams." + "Returns an integer indicating success or failure." + "Wraps `fflush` from the C standard library.") (register fflush (Fn [(Ptr FILE)] Int) "fflush") - (doc fflush! "same as (fflush) but to be used as a side effect.") - (defn fflush! [file] - (ignore (fflush file)) ) - (doc rewind "rewinds a file pointer, i.e. puts input and output stream to beginning (thin wrapper for the C standard library). If you want to verify, that this succeeded, use (fseek stream 0, SEEK_SET) instead. ") + + (doc fflush! + "Flushes buffered data via [`fflush`](#fflush)" + ", but discards the result, making this function appropraite for use as" + "a side effect in `do` forms.") + (defn fflush! [file] + (ignore (fflush file))) + + (doc rewind + "Sets the stream position indicator associated with a [FILE](#file)" + "pointer back to the beginning of the file." + "Wraps `rewind` from the C standard library." + "To verify that resetting the position succeeded," + "use [`fseek`](#fseek) instead.") (register rewind (Fn [(Ptr FILE)] ()) "rewind") + (private unlink-) (hidden unlink-) (register unlink- (Fn [(Ptr CChar)] Int) "unlink") + ; override unlink for windows (windows-only - ; override unlink for windows (register unlink- (Fn [(Ptr CChar)] Int) "_unlink")) - (doc unlink "unlinks a file, i.e. deletes it (thin wrapper for POSIX api in ).") - (defn unlink [file-name] - (unlink- (String.cstr file-name)) ) - (doc unlink! "same as (unlink) but to be used as a side effect.") - (defn unlink! [file-name] - (ignore (unlink file-name)) ) - (doc fseek "sets the position indicator of a file (thin wrapper for fseek(file, offset, whence) from C standard library).") + + (doc unlink + "Removes the named link to a file from the filesystem." + "If this is the last link to the file, and no process has the file open," + "deletes the underlying file." + "If the argument designates a symbolic link, deletes the link only." + "Returns an integer indicating success or failure." + "Wraps `unlink` from the POSIX api in )." + "See the POSIX API documentation for more information.") + (defn unlink [file-name] + (unlink- (String.cstr file-name))) + + (doc unlink! + "Deletes a file link via [`unlink`](#unlink), but discards the result," + "making this function appropriate for use as a side effect in" + "`do` forms.") + (defn unlink! [file-name] + (ignore (unlink file-name))) + + (doc fseek + "Sets the position indicator of a [FILE](#file) based on a given" + "reference position and offset. The position indicator will be set to an" + "offset number of bytes from the reference position." + "Valid reference positions are [`SEEK-SET`](#seek-set)," + "[`SEEK-CUR`](#seek-cur), and [`SEEK-END`](#seek-end)." + "" + "Returns an integer indicating success or failure." + "Wraps `fseek` from the C standard library.") (register fseek (Fn [(Ptr FILE) Int Int] Int) "fseek") - (doc fseek! "same as (fseek) but to be used as a side effect.") - (register fseek! (Fn [(Ptr FILE) Int Int] ()) "fseek") ; note: (ignore (ffseek ...)) would also work - (doc SEEK-SET "to be used with fseek (thin wrapper for the C standard library).") + + (doc fseek! + "Sets the position indicator of a [FILE](#file) via `fseek`," + "but discards the result, making this function appropriate for use" + "as a side effect in `do` forms.") + (register fseek! (Fn [(Ptr FILE) Int Int] ()) "fseek") ; note: (ignore (ffseek ...)) would also work + + (doc SEEK-SET + "When passed to [`fseek`](#fseek) designates the reference position" + "as the beginning of the file." + "Wrpas `SEEK_SET` from the C standard library.") (register SEEK-SET Int "SEEK_SET") - (doc SEEK-CUR "to be used with fseek (thin wrapper for the C standard library).") + + (doc SEEK-CUR + "When passed to [`fseek`](#fseek) designates the reference position" + "as the current position in the file." + "Wraps `SEEK_CUR` from the C standard library.") (register SEEK-CUR Int "SEEK_CUR") - (doc SEEK-END "to be used with fseek (thin wrapper for the C standard library).") + + (doc SEEK-END + "When passed to [`fseek`](#fseek), designates the reference position" + "as the end of a [FILE](#file) (EOF)." + "Wraps `SEEK_END` from the C standard library.") (register SEEK-END Int "SEEK_END") - (doc ftell "gets the position indicator of a file (thin wrapper for the C standard library).") + + (doc ftell + "Returns the current value of the position indicator of a [FILE](#file)" + "Wraps `ftell` from the C standard library.") (register ftell (Fn [(Ptr FILE)] Int) "ftell") + + (doc feof + "Returns true if the position indicator for the given [FILE](#file)" + "is at the end of file [`EOF`](#eof)." + "Wraps `feof` from the C standard library.") (register feof (Fn [(Ptr FILE)] Bool) "feof") + + (doc ferror + "Returns true if an error indicator is set for the" + "given [FILE](#file)." + "Wraps `ferror` from the C standard library.") (register ferror (Fn [(Ptr FILE)] Bool) "ferror") ) - (doc println "prints a string ref to stdout, appends a newline.") + (doc println + "Prints a String ref to [`stdout`](#stdout), appends a newline.") (register println (Fn [(Ref String)] ())) - (doc print "prints a string ref to stdout, does not append a newline.") + + (doc print + "Prints a String ref to [`stdout`](#stdout).") (register print (Fn [(Ref String)] ())) - (doc errorln "prints a string ref to stderr, appends a newline.") + + (doc errorln + "Prints a String ref to [`stderr`](#stderr), appends a newline.") (register errorln (Fn [(Ref String)] ())) - (doc error "prints a string ref to stderr, does not append a newline.") + + (doc error "Prints a String ref to [`stderr`](#stderr).") (register error (Fn [(Ref String)] ())) - (doc get-line "gets a line from stdin.") + + (doc get-line + "Gets one line of input from [`stdin`](#stdin).") (register get-line (Fn [] String)) - (doc fgetc "gets a character from a file pointer (thin wrapper for the C standard library).") + + (doc fgetc + "Gets a single character from a [FILE](#file) pointer." + "Wraps `fgetc` from the C standard library.") (defn fgetc [file] (let [char (IO.Raw.fgetc file)] (if (IO.Raw.feof file) @@ -102,31 +236,45 @@ module are wrappers around the C standard library.") (Result.Error @"error while reading char from file") (Result.Success (Char.from-int char)))))) - (doc open-file "opens a file by name using a mode (e.g. [r]ead, [w]rite, [a]ppend), [rb] read binary...). See fopen() in the C standard library for a detailed description of valid parameters.") + (doc open-file + "Opens a [FILE](#file) with the given name using a designated mode" + "(e.g. [r]ead, [w]rite, [a]ppend), [rb] read binary...)." + "See `fopen` from the C standard library for a description of valid mode parameters.") (defn open-file [filename mode] (let [ptr (IO.Raw.fopen filename mode)] (if (null? ptr) - (Result.Error (System.error-text)) + (Result.Error (System.error-text)) (Result.Success ptr) ))) - (doc read->EOF "reads a file given by name until the End-Of-File character is reached. Please consider using read-file instead, even though this works fine for UTF-8 encoded input files.") - (defn read->EOF [filename] + (doc read->EOF + "Reads bytes from a named [FILE](#file) until the [End-Of-File](#eof) is reached." + "Consider using [read-file](#read-file) instead, even though this works fine for" + "UTF-8 encoded input files.") + (defn read->EOF [filename] (let [file? (IO.open-file filename "rb")] (match file? (Result.Error x) (Result.Error x) (Result.Success f) (let [c (zero) r []] (do - (while (do + (while (do (set! c (IO.Raw.fgetc f)) (/= c IO.Raw.EOF)) (set! r (Array.push-back r (Byte.from-int c)))) (IO.Raw.fclose! f) (Result.Success (String.from-bytes &r))))))) - (doc unsafe-read-file "returns the contents of a file passed as argument as a string. Note: there is no way to distinguish the output for an empty file and a missing file!") + (doc unsafe-read-file + "Returns the contents of a file passed as argument as a string." + "Note: there is no way to distinguish the output for an empty file" + "and a nonexistent file!") (register unsafe-read-file (Fn [&String] String)) - (doc read-file "Reads the content of a file into a (Result String String).\nIt is intended for text files, since the way to determine the length of a String is to use strlen() which probably will be inaccurate for binaries.") + + (doc read-file + "Reads the contents of a text [FILE](#file) into a (Result String String)." + "" + "If a binary file is passed as input, the resulting string length is" + "likely to be inaccurate.") (defn read-file [filename] (let [ finput? (open-file filename "rb") ] (if (Result.error? &finput?) @@ -147,7 +295,12 @@ module are wrappers around the C standard library.") (if (not (Int.= bytes-read length)) (Result.Error (fmt "Error: file='%s' has length=%d but bytes-read=%d" filename length bytes-read)) (Result.Success buffer) ))))))) - (doc write-file "Writes a string into a (text) file, overwriting it if it already exists.") + + (doc write-file + "Writes a String into a text [FILE](#file), overwriting it" + "if it already exists." + "" + "Returns a (Result Bool String) indicating success or failure.") (defn write-file [content file-name] (let [ fOut? (open-file file-name "wb") ; open as binary so line breaks don't multiply on Windows bytes2write (String.length content) ] @@ -158,13 +311,16 @@ module are wrappers around the C standard library.") (IO.Raw.fclose! fOut) (if (Int.= bytes-written bytes2write) (Result.Success true) - (Result.Error (fmt "only %d of %d bytes were written" bytes-written bytes2write)) ))))) + (Result.Error (fmt "only %d of %d bytes were written" bytes-written bytes2write))))))) (private getenv-) (hidden getenv-) - (doc getenv- "gets the value of an environment variable (thin wrapper for the C standard library)") + (doc getenv- "gets the value of an environment variable (thin wrapper for the C standard library)") (register getenv- (Fn [(Ptr CChar)] (Ptr CChar)) "getenv") - (doc getenv "gets the value of an environment variable (Carp-style wrapper for the C standard library)") + + (doc getenv + "Returns the value of an environment variable." + "Wraps `getenv` from the C standard library.") (defn getenv [s] (let [e (getenv- (String.cstr s))] (if (null? e) @@ -172,9 +328,26 @@ module are wrappers around the C standard library.") (Maybe.Just (from-cstr e))))) ) -; TODO: document this cool stuff, possibly even include an example! +; TODO(#1445): document this cool stuff, possibly even include an example! +(doc println* + "Prints any number of values to [`stdout`](#stdout), using their" + "`str` implementations. Appends final a newline to the output." + "" + "```" + "(println* \"I caught \" 4 \"carp!\")" + "=> I caught 4 carp!" + "```") (defmacro println* [:rest forms] `(IO.println %(build-str* forms))) +(doc print* + "Prints any number of values to [`stdout`](#stdout), using thier" + "`str` implementations." + "" + "```" + "(print* \"I caught \" 4 \"carp \")" + "(print* \"yesterday\")" + "=> I caught 4 carp yesterday" + "```") (defmacro print* [:rest forms] `(IO.print %(build-str* forms))) From 25f50c92a57cc91b6cb4ec48df658439f936b641 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 28 Dec 2022 01:16:56 -0600 Subject: [PATCH 52/59] chore: make Carp compile w/ GHC 9.2 + stack lts20.0 (#1449) --- src/ArrayTemplates.hs | 406 +++++++++++++++++++++--------------- src/AssignTypes.hs | 10 +- src/BoxTemplates.hs | 106 ++++++---- src/Concretize.hs | 46 ++-- src/Emit.hs | 201 ++++++++++-------- src/Env.hs | 8 + src/Eval.hs | 17 +- src/Expand.hs | 3 +- src/GenerateConstraints.hs | 198 ++++++++++-------- src/Info.hs | 9 +- src/InitialTypes.hs | 11 +- src/Interfaces.hs | 4 +- src/Memory.hs | 36 ++-- src/Meta.hs | 10 +- src/Obj.hs | 71 ++++--- src/Parsing.hs | 25 ++- src/Polymorphism.hs | 5 +- src/Primitives.hs | 19 +- src/Project.hs | 69 +++--- src/Qualify.hs | 42 ++-- src/RenderDocs.hs | 13 +- src/StartingEnv.hs | 9 +- src/StaticArrayTemplates.hs | 115 +++++----- src/Sumtypes.hs | 16 +- src/Template.hs | 12 +- src/TypeError.hs | 4 +- 26 files changed, 855 insertions(+), 610 deletions(-) diff --git a/src/ArrayTemplates.hs b/src/ArrayTemplates.hs index 2cf8e325b..35fc40651 100644 --- a/src/ArrayTemplates.hs +++ b/src/ArrayTemplates.hs @@ -36,11 +36,15 @@ templateEMap = Template templateType (templateLiteral "Array $NAME(Lambda *f, Array a)") - ( \(FuncTy [_, StructTy (ConcreteNameTy (SymPath [] "Array")) [memberTy]] _ _) -> - handleUnits memberTy + ( \case + (FuncTy [_, StructTy (ConcreteNameTy (SymPath [] "Array")) [memberTy]] _ _) -> + handleUnits memberTy + _ -> error "array templates: emap called on non array" ) - ( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) -> - [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] + ( \case + (FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) -> + [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] + _ -> error "array templates: emap called on non array" ) where elt = "((($a*)a.data)[i])" @@ -96,16 +100,20 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "Array $NAME(Lambda *predicate, Array a)")) -- Lambda used to be $(Fn [(Ref a)] Bool) - ( \(FuncTy [RefTy (FuncTy [RefTy insideTy _] BoolTy _) _, _] _ _) -> - let deleteCall = insideArrayDeletion typeEnv env insideTy - in ( case insideTy of - UnitTy -> declaration " insertIndex++; /* ignore () member; just increment length. */" deleteCall - _ -> declaration " ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];" deleteCall - ) + ( \case + (FuncTy [RefTy (FuncTy [RefTy insideTy _] BoolTy _) _, _] _ _) -> + let deleteCall = insideArrayDeletion typeEnv env insideTy + in ( case insideTy of + UnitTy -> declaration " insertIndex++; /* ignore () member; just increment length. */" deleteCall + _ -> declaration " ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];" deleteCall + ) + _ -> error "array tempaltes: efilter called on non-array" ) - ( \(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, _] _ _) -> - [defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)] - ++ depsForDeleteFunc typeEnv env insideType + ( \case + (FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, _] _ _) -> + [defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)] + ++ depsForDeleteFunc typeEnv env insideType + _ -> error "array tempaltes: efilter called on non-array" ) templatePushBack :: (String, Binder) @@ -133,17 +141,24 @@ templatePushBack = \_ _ -> Template t - ( \(FuncTy [_, valueTy] _ _) -> - case valueTy of - UnitTy -> toTemplate "Array $NAME(Array a)" - _ -> toTemplate "Array $NAME(Array a, $a value)" + ( \case + (FuncTy [_, valueTy] _ _) -> + case valueTy of + UnitTy -> toTemplate "Array $NAME(Array a)" + _ -> toTemplate "Array $NAME(Array a, $a value)" + _ -> error "array tempaltes: push back called on non array" ) - ( \(FuncTy [_, valueTy] _ _) -> - case valueTy of - UnitTy -> declaration " /* ignore () member */" - _ -> declaration " (($a*)a.data)[a.len - 1] = value;" + ( \case + (FuncTy [_, valueTy] _ _) -> + case valueTy of + UnitTy -> declaration " /* ignore () member */" + _ -> declaration " (($a*)a.data)[a.len - 1] = value;" + _ -> error "array tempaltes: push back called on non array" + ) + ( \case + (FuncTy [_, _] _ _) -> [] + _ -> error "array tempaltes: push back called on non array" ) - (\(FuncTy [_, _] _ _) -> []) templatePushBackBang :: (String, Binder) templatePushBackBang = @@ -169,17 +184,24 @@ templatePushBackBang = \_ _ -> Template t - ( \(FuncTy [_, valueTy] _ _) -> - case valueTy of - UnitTy -> toTemplate "void $NAME(Array *aRef)" - _ -> toTemplate "void $NAME(Array *aRef, $a value)" + ( \case + (FuncTy [_, valueTy] _ _) -> + case valueTy of + UnitTy -> toTemplate "void $NAME(Array *aRef)" + _ -> toTemplate "void $NAME(Array *aRef, $a value)" + _ -> error "array templates pushback bang called on non array" ) - ( \(FuncTy [_, valueTy] _ _) -> - case valueTy of - UnitTy -> declaration " /* ignore () member */" - _ -> declaration " (($a*)aRef->data)[aRef->len - 1] = value;" + ( \case + (FuncTy [_, valueTy] _ _) -> + case valueTy of + UnitTy -> declaration " /* ignore () member */" + _ -> declaration " (($a*)aRef->data)[aRef->len - 1] = value;" + _ -> error "array templates: pushbackbang called on non array" + ) + ( \case + (FuncTy [_, _] _ _) -> [] + _ -> error "array templates: pushbackbang called on non array" ) - (\(FuncTy [_, _] _ _) -> []) templatePopBack :: (String, Binder) templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs @@ -192,23 +214,27 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "Array $NAME(Array a)")) - ( \(FuncTy [StructTy _ [insideTy]] _ _) -> - let deleteElement = insideArrayDeletion typeEnv env insideTy - in toTemplate - ( unlines - [ "$DECL { ", - " assert(a.len > 0);", - " a.len--;", - " " ++ deleteElement "a.len", - templateShrinkCheck "a", - " return a;", - "}" - ] - ) + ( \case + (FuncTy [StructTy _ [insideTy]] _ _) -> + let deleteElement = insideArrayDeletion typeEnv env insideTy + in toTemplate + ( unlines + [ "$DECL { ", + " assert(a.len > 0);", + " a.len--;", + " " ++ deleteElement "a.len", + templateShrinkCheck "a", + " return a;", + "}" + ] + ) + _ -> error "array templates: pop back called on non array" ) - ( \(FuncTy [arrayType@(StructTy _ [insideTy])] _ _) -> - depsForDeleteFunc typeEnv env arrayType - ++ depsForCopyFunc typeEnv env insideTy + ( \case + (FuncTy [arrayType@(StructTy _ [insideTy])] _ _) -> + depsForDeleteFunc typeEnv env arrayType + ++ depsForCopyFunc typeEnv env insideTy + _ -> error "array templates: pop back called on non array" ) templatePopBackBang :: (String, Binder) @@ -224,27 +250,32 @@ templatePopBackBang = Template t (templateLiteral "$a $NAME(Array *aRef)") - ( \(FuncTy _ returnTy _) -> - case returnTy of - UnitTy -> - multilineTemplate - [ "$DECL { ", - " assert(aRef->len > 0);", - " aRef->len--;", - "}" - ] - _ -> - multilineTemplate - [ "$DECL { ", - " $a ret;", - " assert(aRef->len > 0);", - " ret = (($a*)aRef->data)[aRef->len - 1];", - " aRef->len--;", - " return ret;", - "}" - ] + ( \case + (FuncTy _ returnTy _) -> + case returnTy of + UnitTy -> + multilineTemplate + [ "$DECL { ", + " assert(aRef->len > 0);", + " aRef->len--;", + "}" + ] + _ -> + multilineTemplate + [ "$DECL { ", + " $a ret;", + " assert(aRef->len > 0);", + " ret = (($a*)aRef->data)[aRef->len - 1];", + " aRef->len--;", + " return ret;", + "}" + ] + _ -> error "array tempaltes: pop back bang called on non array" + ) + ( \case + (FuncTy [_] _ _) -> [] + _ -> error "array templates: pop back bang called on non array" ) - (\(FuncTy [_] _ _) -> []) templateNth :: (String, Binder) templateNth = @@ -264,8 +295,9 @@ templateNth = "}" ] ) - ( \(FuncTy [RefTy _ _, _] _ _) -> - [] + ( \case + (FuncTy [RefTy _ _, _] _ _) -> [] + _ -> error "array templates: nth called on non array" ) templateRaw :: (String, Binder) @@ -276,7 +308,10 @@ templateRaw = "returns an array `a` as a raw pointer—useful for interacting with C." (toTemplate "$t* $NAME (Array a)") (toTemplate "$DECL { return a.data; }") - (\(FuncTy [_] _ _) -> []) + ( \case + (FuncTy [_] _ _) -> [] + _ -> error "array templates: raw called on non array" + ) templateUnsafeRaw :: (String, Binder) templateUnsafeRaw = @@ -286,7 +321,10 @@ templateUnsafeRaw = "returns an array `a` as a raw pointer—useful for interacting with C." (toTemplate "$t* $NAME (Array* a)") (toTemplate "$DECL { return a->data; }") - (\(FuncTy [RefTy _ _] _ _) -> []) + ( \case + (FuncTy [RefTy _ _] _ _) -> [] + _ -> error "array templates: unsafe raw called on non array" + ) -- Several setter functions need to ensure the array's member type isn't Unit -- Such setters only run a side effect, so we can even drop bounds checks. @@ -308,29 +346,35 @@ templateAset = defineTypeParameterizedTemplate templateCreator path t docs \typeEnv env -> Template t - ( \(FuncTy [_, _, insideTy] _ _) -> - case insideTy of - UnitTy -> toTemplate "Array $NAME (Array a, int n)" - _ -> toTemplate "Array $NAME (Array a, int n, $t newValue)" + ( \case + (FuncTy [_, _, insideTy] _ _) -> + case insideTy of + UnitTy -> toTemplate "Array $NAME (Array a, int n)" + _ -> toTemplate "Array $NAME (Array a, int n, $t newValue)" + _ -> error "array templates: aset called with non array" ) - ( \(FuncTy [_, _, insideTy] _ _) -> - case insideTy of - -- Just return the same array for unit members. - UnitTy -> toTemplate "$DECL { return a; }" - _ -> - let deleter = insideArrayDeletion typeEnv env insideTy - in multilineTemplate - [ "$DECL {", - " assert(n >= 0);", - " assert(n < a.len);", - deleter "n", - " (($t*)a.data)[n] = newValue;", - " return a;", - "}" - ] + ( \case + (FuncTy [_, _, insideTy] _ _) -> + case insideTy of + -- Just return the same array for unit members. + UnitTy -> toTemplate "$DECL { return a; }" + _ -> + let deleter = insideArrayDeletion typeEnv env insideTy + in multilineTemplate + [ "$DECL {", + " assert(n >= 0);", + " assert(n < a.len);", + deleter "n", + " (($t*)a.data)[n] = newValue;", + " return a;", + "}" + ] + _ -> error "array templates: aset called with non array" ) - ( \(FuncTy [_, _, insideTy] _ _) -> - depsForDeleteFunc typeEnv env insideTy + ( \case + (FuncTy [_, _, insideTy] _ _) -> + depsForDeleteFunc typeEnv env insideTy + _ -> error "array templates: aset called with non array" ) templateAsetBang :: (String, Binder) @@ -343,28 +387,34 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs \typeEnv env -> Template t - ( \(FuncTy [_, _, valueType] _ _) -> - case valueType of - UnitTy -> toTemplate "void $NAME (Array *aRef, int n)" - _ -> toTemplate "void $NAME (Array *aRef, int n, $t newValue)" + ( \case + (FuncTy [_, _, valueType] _ _) -> + case valueType of + UnitTy -> toTemplate "void $NAME (Array *aRef, int n)" + _ -> toTemplate "void $NAME (Array *aRef, int n, $t newValue)" + _ -> error "array templates: asetbang called on non array" ) - ( \(FuncTy [_, _, insideTy] _ _) -> - case insideTy of - UnitTy -> unitSetterTemplate - _ -> - let deleter = insideArrayDeletion typeEnv env insideTy - in multilineTemplate - [ "$DECL {", - " Array a = *aRef;", - " assert(n >= 0);", - " assert(n < a.len);", - deleter "n", - " (($t*)a.data)[n] = newValue;", - "}" - ] + ( \case + (FuncTy [_, _, insideTy] _ _) -> + case insideTy of + UnitTy -> unitSetterTemplate + _ -> + let deleter = insideArrayDeletion typeEnv env insideTy + in multilineTemplate + [ "$DECL {", + " Array a = *aRef;", + " assert(n >= 0);", + " assert(n < a.len);", + deleter "n", + " (($t*)a.data)[n] = newValue;", + "}" + ] + _ -> error "array templates: asetbang called on non array" ) - ( \(FuncTy [RefTy arrayType _, _, _] _ _) -> - depsForDeleteFunc typeEnv env arrayType + ( \case + (FuncTy [RefTy arrayType _, _, _] _ _) -> + depsForDeleteFunc typeEnv env arrayType + _ -> error "array templates: asetbang called on non array" ) -- | This function can set uninitialized memory in an array (used together with 'allocate'). @@ -379,23 +429,27 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator \_ _ -> Template t - ( \(FuncTy [_, _, valueType] _ _) -> - case valueType of - UnitTy -> toTemplate "void $NAME (Array *aRef, int n)" - _ -> toTemplate "void $NAME (Array *aRef, int n, $t newValue)" + ( \case + (FuncTy [_, _, valueType] _ _) -> + case valueType of + UnitTy -> toTemplate "void $NAME (Array *aRef, int n)" + _ -> toTemplate "void $NAME (Array *aRef, int n, $t newValue)" + _ -> error "array templates: aset called on non array" ) - ( \(FuncTy [_, _, valueType] _ _) -> - case valueType of - UnitTy -> unitSetterTemplate - _ -> - multilineTemplate - [ "$DECL {", - " Array a = *aRef;", - " assert(n >= 0);", - " assert(n < a.len);", - " (($t*)a.data)[n] = newValue;", - "}" - ] + ( \case + (FuncTy [_, _, valueType] _ _) -> + case valueType of + UnitTy -> unitSetterTemplate + _ -> + multilineTemplate + [ "$DECL {", + " Array a = *aRef;", + " assert(n >= 0);", + " assert(n < a.len);", + " (($t*)a.data)[n] = newValue;", + "}" + ] + _ -> error "array templates: aset called on non array" ) (const []) @@ -411,8 +465,10 @@ templateLength = defineTypeParameterizedTemplate templateCreator path t docs t (const (toTemplate "int $NAME (Array *a)")) (const (toTemplate "$DECL { return (*a).len; }")) - ( \(FuncTy [RefTy arrayType _] _ _) -> - depsForDeleteFunc typeEnv env arrayType + ( \case + (FuncTy [RefTy arrayType _] _ _) -> + depsForDeleteFunc typeEnv env arrayType + _ -> error "array template: length called on non array" ) templateAllocate :: (String, Binder) @@ -426,23 +482,27 @@ templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "Array $NAME (int n)")) - ( \(FuncTy [_] arrayType _) -> - toTemplate $ - unlines - ( [ "$DECL {", - " Array a;", - " a.len = n;", - " a.capacity = n;", - " a.data = CARP_MALLOC(n*sizeof($t));" - ] - ++ initTy arrayType - ++ [ " return a;", - "}" - ] - ) + ( \case + (FuncTy [_] arrayType _) -> + toTemplate $ + unlines + ( [ "$DECL {", + " Array a;", + " a.len = n;", + " a.capacity = n;", + " a.data = CARP_MALLOC(n*sizeof($t));" + ] + ++ initTy arrayType + ++ [ " return a;", + "}" + ] + ) + _ -> error "array template: allocate called on non array" ) - ( \(FuncTy [_] arrayType _) -> - depsForDeleteFunc typeEnv env arrayType + ( \case + (FuncTy [_] arrayType _) -> + depsForDeleteFunc typeEnv env arrayType + _ -> error "array template: allocate called on non array" ) templateDeleteArray :: (String, Binder) @@ -456,13 +516,17 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc Template t (const (toTemplate "void $NAME (Array a)")) - ( \(FuncTy [arrayType] UnitTy _) -> - [TokDecl, TokC "{\n"] - ++ deleteTy typeEnv env arrayType - ++ [TokC "}\n"] + ( \case + (FuncTy [arrayType] UnitTy _) -> + [TokDecl, TokC "{\n"] + ++ deleteTy typeEnv env arrayType + ++ [TokC "}\n"] + _ -> error "array template: delete called with non array" ) - ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]] UnitTy _) -> - depsForDeleteFunc typeEnv env insideType + ( \case + (FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]] UnitTy _) -> + depsForDeleteFunc typeEnv env insideType + _ -> error "array template: delete called with non array" ) deleteTy :: TypeEnv -> Env -> Ty -> [Token] @@ -518,15 +582,17 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "Array $NAME (Array* a)")) - ( \(FuncTy [RefTy arrayType _] _ _) -> - [TokDecl, TokC "{\n"] - ++ [TokC " Array copy;\n"] - ++ [TokC " copy.len = a->len;\n"] - ++ [TokC " copy.capacity = a->capacity;\n"] - ++ [TokC " copy.data = CARP_MALLOC(sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->capacity);\n"] - ++ copyTy typeEnv env arrayType - ++ [TokC " return copy;\n"] - ++ [TokC "}\n"] + ( \case + (FuncTy [RefTy arrayType _] _ _) -> + [TokDecl, TokC "{\n"] + ++ [TokC " Array copy;\n"] + ++ [TokC " copy.len = a->len;\n"] + ++ [TokC " copy.capacity = a->capacity;\n"] + ++ [TokC " copy.data = CARP_MALLOC(sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->capacity);\n"] + ++ copyTy typeEnv env arrayType + ++ [TokC " return copy;\n"] + ++ [TokC "}\n"] + err -> error ("CAN'T MATCH: " ++ show err) ) ( \case (FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] _ _) -> @@ -576,13 +642,19 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "String $NAME (Array* a)")) - ( \(FuncTy [RefTy arrayType _] StringTy _) -> - [TokDecl, TokC " {\n"] - ++ strTy typeEnv env arrayType - ++ [TokC "}\n"] + ( \ft -> + case ft of + (FuncTy [RefTy arrayType _] StringTy _) -> + [TokDecl, TokC " {\n"] + ++ strTy typeEnv env arrayType + ++ [TokC "}\n"] + _ -> error "array templates: str called w/ non array" ) - ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] StringTy _) -> - depsForPrnFunc typeEnv env insideType + ( \ft -> + case ft of + (FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] StringTy _) -> + depsForPrnFunc typeEnv env insideType + _ -> error "array templates: str called w/ non array" ) path = SymPath ["Array"] "str" t = FuncTy [arrayRef] StringTy StaticLifetimeTy diff --git a/src/AssignTypes.hs b/src/AssignTypes.hs index 44b0ea5af..f7bfe9c7c 100644 --- a/src/AssignTypes.hs +++ b/src/AssignTypes.hs @@ -56,12 +56,16 @@ isArrayTypeOK _ = True -- | TODO: Only change variables that are machine generated. beautifyTypeVariables :: XObj -> Either TypeError XObj beautifyTypeVariables root = - let Just t = xobjTy root - tys = nub (typeVariablesInOrderOfAppearance t) + let tys = case xobjTy root of + Just t -> nub (typeVariablesInOrderOfAppearance t) + Nothing -> [] mappings = Map.fromList ( zip - (map (\(VarTy name) -> name) tys) + (map go tys) (map (VarTy . (: [])) ['a' ..]) ) in assignTypes mappings root + where + go (VarTy name) = name + go _ = "" -- called with non var type diff --git a/src/BoxTemplates.hs b/src/BoxTemplates.hs index 2ef6803b0..d31bd3919 100644 --- a/src/BoxTemplates.hs +++ b/src/BoxTemplates.hs @@ -96,12 +96,18 @@ copy = Template t decl - ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> - innerCopy tenv env inner + ( \ft -> + case ft of + (FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + innerCopy tenv env inner + _ -> error "box templates: copy called with non box" ) - ( \(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> - depsForCopyFunc tenv env inner - ++ depsForDeleteFunc tenv env boxType + ( \ft -> + case ft of + (FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + depsForCopyFunc tenv env inner + ++ depsForDeleteFunc tenv env boxType + _ -> error "box templates: copy called with non box" ) in defineTypeParameterizedTemplate template path t docs where @@ -138,15 +144,21 @@ delete = Template t decl - ( \(FuncTy [bTy] UnitTy _) -> - multilineTemplate - [ "$DECL {", - " " ++ innerDelete tenv env bTy, - "}" - ] + ( \ft -> + case ft of + (FuncTy [bTy] UnitTy _) -> + multilineTemplate + [ "$DECL {", + " " ++ innerDelete tenv env bTy, + "}" + ] + _ -> error "box templates: delete called with non box" ) - ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) -> - depsForDeleteFunc tenv env insideType + ( \ft -> + case ft of + (FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) -> + depsForDeleteFunc tenv env insideType + _ -> error "box templates: delete called with non box" ) in defineTypeParameterizedTemplate templateCreator path t docs where @@ -175,21 +187,27 @@ prn = Template t decl - ( \(FuncTy [boxT] StringTy _) -> - multilineTemplate - [ "$DECL {", - " if(!box){", - " String buffer = CARP_MALLOC(4);", - " sprintf(buffer, \"Nil\");", - " return buffer;", - " }", - innerStr tenv env boxT, - " return buffer;", - "}" - ] + ( \ft -> + case ft of + (FuncTy [boxT] StringTy _) -> + multilineTemplate + [ "$DECL {", + " if(!box){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + innerStr tenv env boxT, + " return buffer;", + "}" + ] + _ -> error "box templates: prn called with non box" ) - ( \(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) -> - depsForPrnFunc tenv env inner + ( \ft -> + case ft of + (FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) -> + depsForPrnFunc tenv env inner + _ -> error "box tempaltes: prn called with non box" ) ) in defineTypeParameterizedTemplate templateCreator path t docs @@ -206,21 +224,27 @@ str = Template t (templateLiteral "String $NAME ($t** box)") - ( \(FuncTy [RefTy boxT _] StringTy _) -> - multilineTemplate - [ "$DECL {", - " if(!box){", - " String buffer = CARP_MALLOC(4);", - " sprintf(buffer, \"Nil\");", - " return buffer;", - " }", - innerStr tenv env boxT, - " return buffer;", - "}" - ] + ( \ft -> + case ft of + (FuncTy [RefTy boxT _] StringTy _) -> + multilineTemplate + [ "$DECL {", + " if(!box){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + innerStr tenv env boxT, + " return buffer;", + "}" + ] + _ -> error "box templates: str called with non box ref" ) - ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) -> - depsForPrnFunc tenv env inner + ( \ft -> + case ft of + (FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) -> + depsForPrnFunc tenv env inner + _ -> error "box templates: str template called with non box type" ) ) in defineTypeParameterizedTemplate templateCreator path t docs diff --git a/src/Concretize.hs b/src/Concretize.hs index bd2ead10e..b3127203d 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -126,9 +126,12 @@ envWithFunctionArgs :: Env -> [XObj] -> Either EnvironmentError Env envWithFunctionArgs env arr = let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env) in foldM - (\e arg@(XObj (Sym path _) _ _) -> insertX e path arg) + go functionEnv arr + where + go e arg@(XObj (Sym path _) _ _) = insertX e path arg + go e _ = pure e -- | Concretely type a function definition. -- @@ -255,7 +258,7 @@ mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args) -- Its name will contain the name of the (normal, non-lambda) function it's contained within, -- plus the identifier of the particular s-expression that defines the lambda. SymPath spath name = (last visited) - Just funcTy = xobjTy root + funcTy = fromMaybe (error "concretize: can't concretize a lambda without type") $ xobjTy root lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel env) ++ "_" ++ show (maybe 0 infoIdentifier (xobjInfo root)) ++ "_env") lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing -- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols. @@ -286,8 +289,11 @@ mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args) -- (if it captures at least one variable) structMemberPairs = concatMap - ( \(XObj (Sym path _) _ (Just symTy)) -> - [XObj (Sym path Symbol) Nothing Nothing, reify symTy] + ( \x -> + case x of + (XObj (Sym path _) _ (Just symTy)) -> + [XObj (Sym path Symbol) Nothing Nothing, reify symTy] + _ -> error "concretize: struct member pair is a non symbol" ) capturedVars environmentStructTy = StructTy (ConcreteNameTy tyPath) [] @@ -365,7 +371,7 @@ visitSymbol visited allowAmbig tenv env xobj@(SymPat path mode) = Right (foundEnv, binder) | envIsExternal foundEnv -> let theXObj = binderXObj binder - Just theType = xobjTy theXObj + theType = fromMaybe (error "concretize: can't concretize a symbol without a type") $ xobjTy theXObj typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) (xobjTy xobj) in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $ (isTypeGeneric theType && not (isTypeGeneric typeOfVisited)) @@ -389,7 +395,7 @@ visitMultiSym visited allowAmbig tenv env xobj@(MultiSymPat name paths) = [x] -> go x _ -> pure (Right xobj) where - Just actualType = xobjTy xobj + actualType = fromMaybe (error "concretize: can't concretize a multisym without a type") $ xobjTy xobj tys = map (typeFromPath env) paths modes = map (modeFromPath env) paths tysToPathsDict = zip tys paths @@ -417,19 +423,19 @@ visitInterfaceSym :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] visitInterfaceSym visited allowAmbig tenv env xobj@(InterfaceSymPat name) = either (pure . const (Left (CannotConcretize xobj))) go (getTypeBinder tenv name) where - Just actualType = (xobjTy xobj) + actualType = fromMaybe (error "concretize: can't concretize an interface without type") $ (xobjTy xobj) go :: Binder -> State [XObj] (Either TypeError XObj) go (Binder _ (ListPat (InterfacePat _ paths))) = let tys = map (typeFromPath env) paths modes = map (modeFromPath env) paths tysModesPathsDict = zip3 tys modes paths in case filter (\(t, _, p) -> matchingSignature actualType (t, p)) tysModesPathsDict of - [] -> pure $ if allowAmbig then Right xobj else Left (NoMatchingSignature xobj name actualType (map (\(t, _, p) -> (t,p)) tysModesPathsDict)) + [] -> pure $ if allowAmbig then Right xobj else Left (NoMatchingSignature xobj name actualType (map (\(t, _, p) -> (t, p)) tysModesPathsDict)) [x] -> updateSym x - xs -> case filter (\(t,_,_) -> typeEqIgnoreLifetimes actualType t) xs of + xs -> case filter (\(t, _, _) -> typeEqIgnoreLifetimes actualType t) xs of [] -> pure (Right xobj) -- No exact match of types [y] -> updateSym y - ps -> pure (Left (SeveralExactMatches xobj name actualType (map (\(t, _, p) -> (t,p)) ps))) + ps -> pure (Left (SeveralExactMatches xobj name actualType (map (\(t, _, p) -> (t, p)) ps))) go _ = pure (Left (CannotConcretize xobj)) -- TODO: Should we also check for allowAmbig here? updateSym (_, mode, path) = if isTypeGeneric actualType then pure (Right xobj) else replace mode path @@ -577,7 +583,7 @@ renameGenericTypeSymbolsOnSum varpairs x@(XObj (Lst (caseNm : [a@(XObj (Arr arr) mapp = Map.fromList varpairs replacer mem@(XObj (Sym (SymPath [] name) _) _ _) = - let Just perhapsTyVar = xobjToTy mem + let perhapsTyVar = fromMaybe (error "concretize: can't replace generics on sum without type") $ xobjToTy mem in if isFullyGenericType perhapsTyVar then case Map.lookup (VarTy name) mapp of Just new -> reify new @@ -592,7 +598,7 @@ renameGenericTypeSymbolsOnProduct vars members = concatMap (\(var, (v, t)) -> [v, rename var t]) (zip vars (pairwise members)) where rename var mem = - let Just perhapsTyVar = xobjToTy mem + let perhapsTyVar = fromMaybe (error "concretize: can't replace generics on product without type") $ xobjToTy mem in if isFullyGenericType perhapsTyVar then reify var else mem @@ -606,8 +612,12 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic where fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing - XObj (Arr memberXObjs) _ _ = head membersXObjs - rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 + memberXObjs = case head membersXObjs of + XObj (Arr xs) _ _ -> xs + _ -> error "can't instantiate non array member objects" + (rename, renamedOrig) = case evalState (renameVarTys originalStructTy) 0 of + (StructTy n ro) -> ((StructTy n ro), ro) + _ -> error "concretize: can't instantiate a non struct type" solution = solve [Constraint originalStructTy genericStructTy fake1 fake2 fake1 OrdMultiSym] go mappings = do mappings' <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]) @@ -643,7 +653,9 @@ instantiateGenericSumtype :: TypeEnv -> Env -> Ty -> Ty -> [XObj] -> Either Type instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVars) genericStructTy cases = let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing - rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 + (rename, renamedOrig) = case evalState (renameVarTys originalStructTy) 0 of + (StructTy n ro) -> ((StructTy n ro), ro) + _ -> error "concretize: can't instantiate non struct type" nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases fixLeft l = replaceLeft (FailedToInstantiateGenericType originalStructTy) l in do @@ -692,7 +704,7 @@ replaceGenericTypeSymbolsOnMembers mappings memberXObjs = replaceGenericTypeSymbols :: Map.Map String Ty -> XObj -> XObj replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath _ name) _) _ _) = - let Just perhapsTyVar = xobjToTy xobj + let perhapsTyVar = fromMaybe (error "concretize: can't replace generics on xobj with no type") $ xobjToTy xobj in if isFullyGenericType perhapsTyVar then maybe xobj reify (Map.lookup name mappings) else xobj @@ -758,7 +770,7 @@ modeFromPath env p = concretizeDefinition :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Ty -> Either TypeError (XObj, [XObj]) concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definition concreteType = let SymPath pathStrings name = getPath definition - Just polyType = xobjTy definition + polyType = fromMaybe (error "concretize: definition without a type") $ xobjTy definition suffix = polymorphicSuffix polyType concreteType newPath = SymPath pathStrings (name ++ suffix) in case definition of diff --git a/src/Emit.hs b/src/Emit.hs index 814bcadd2..a41c85d33 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -204,7 +204,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo visitSymbol _ (XObj (Sym _ (LookupGlobalOverride overrideWithName)) _ _) = pure overrideWithName visitSymbol indent xobj@(XObj sym@(Sym path lookupMode) (Just i) ty) = - let Just t = ty + let t = fromMaybe (error "emit: symbol has no type") $ ty in if isTypeGeneric t then error @@ -237,7 +237,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo _ -> do let innerIndent = indent + indentAmount - Just (FuncTy _ retTy _) = ty + retTy = case ty of + Just (FuncTy _ rt _) -> rt + _ -> error "emit: defn has no return type" defnDecl = defnToDeclaration meta path argList retTy isMain = name == "main" appendToSrc (defnDecl ++ " {\n") @@ -255,7 +257,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo do let retVar = freshVar info capturedVars = Set.toList set - Just callback = name + callback = fromMaybe (SymPath [] "") name callbackMangled = pathToC callback needEnv = not (null capturedVars) lambdaEnvTypeName = (SymPath [] (callbackMangled ++ "_ty")) -- The name of the struct is the callback name with suffix '_ty'. @@ -277,17 +279,20 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo ++ "));\n" ) mapM_ - ( \(XObj (Sym path lookupMode) _ _) -> - appendToSrc - ( addIndent indent ++ lambdaEnvName ++ "->" - ++ pathToC path - ++ " = " - ++ ( case lookupMode of - LookupLocal (Capture _) -> "_env->" ++ pathToC path - _ -> pathToC path - ) - ++ ";\n" - ) + ( \xobj -> + case xobj of + (XObj (Sym path lookupMode) _ _) -> + appendToSrc + ( addIndent indent ++ lambdaEnvName ++ "->" + ++ pathToC path + ++ " = " + ++ ( case lookupMode of + LookupLocal (Capture _) -> "_env->" ++ pathToC path + _ -> pathToC path + ) + ++ ";\n" + ) + _ -> appendToSrc "" ) (remove (isUnit . forceTy) capturedVars) appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n") @@ -317,7 +322,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo [XObj Let _ _, XObj (Arr bindings) _ _, body] -> let indent' = indent + indentAmount in do - let Just bodyTy = xobjTy body + let bodyTy = fromMaybe (error "emit: let body has no type") $ xobjTy body isNotVoid = bodyTy /= UnitTy letBodyRet = freshVar info when isNotVoid $ -- Must be declared outside the scope @@ -326,7 +331,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo let letBindingToC (XObj (Sym (SymPath _ symName) _) _ _) expr = do ret <- visit indent' expr - let Just bindingTy = xobjTy expr + let bindingTy = fromMaybe (error "emit: let binding value has no type") $ xobjTy expr unless (isUnit bindingTy) $ appendToSrc (addIndent indent' ++ tyToCLambdaFix bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n") letBindingToC _ _ = error "Invalid binding." @@ -344,18 +349,18 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo let isNotVoid = xobjTy ifTrue /= Just UnitTy ifRetVar = freshVar info when isNotVoid $ - let Just ifT = xobjTy ifTrue + let ifT = fromMaybe (error "emit: if true branch has no type") $ xobjTy ifTrue in appendToSrc (addIndent indent ++ tyToCLambdaFix ifT ++ " " ++ ifRetVar ++ ";\n") exprVar <- visit indent expr appendToSrc (addIndent indent ++ "if (" ++ exprVar ++ ") {\n") trueVar <- visit indent' ifTrue - let Just ifTrueInfo = xobjInfo ifTrue + let ifTrueInfo = infoOrUnknown $ xobjInfo ifTrue delete indent' ifTrueInfo when isNotVoid $ appendToSrc (addIndent indent' ++ ifRetVar ++ " = " ++ trueVar ++ ";\n") appendToSrc (addIndent indent ++ "} else {\n") falseVar <- visit indent' ifFalse - let Just ifFalseInfo = xobjInfo ifFalse + let ifFalseInfo = infoOrUnknown $ xobjInfo ifFalse delete indent' ifFalseInfo when isNotVoid $ appendToSrc (addIndent indent' ++ ifRetVar ++ " = " ++ falseVar ++ ";\n") @@ -384,7 +389,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo tempVarToAvoidClash = freshVar exprInfo ++ "_temp" emitCaseMatcher :: (String, String) -> String -> XObj -> Integer -> State EmitterState () emitCaseMatcher (periodOrArrow, ampersandOrNot) caseName (XObj (Sym path _) _ t) index = - let Just tt = t + let tt = fromMaybe (error "emit: case matcher has no type") $ t in appendToSrc ( addIndent indent' ++ tyToCLambdaFix tt ++ " " ++ pathToC path ++ " = " ++ ampersandOrNot @@ -446,13 +451,13 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo caseExprRetVal <- visit indent' caseExpr when isNotVoid $ appendToSrc (addIndent indent' ++ retVar ++ " = " ++ caseExprRetVal ++ ";\n") - let Just caseLhsInfo' = caseLhsInfo + let caseLhsInfo' = infoOrUnknown caseLhsInfo delete indent' caseLhsInfo' appendToSrc (addIndent indent ++ "}\n") in do exprVar <- visit indent expr when isNotVoid $ - let Just t = ty + let t = fromMaybe (error "emit: match expression has no type") $ ty in appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ retVar ++ ";\n") zipWithM_ (emitCase exprVar) (True : repeat False) (pairwise rest) appendToSrc (addIndent indent ++ "else UNHANDLED(\"" ++ takeFileName (infoFile info) ++ "\", " ++ show (infoLine info) ++ ");\n") @@ -462,9 +467,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo -- While [XObj While _ _, expr, body] -> let indent' = indent + indentAmount - Just exprTy = xobjTy expr + exprTy = fromMaybe (error "emit: called on while expression has no type") $ xobjTy expr conditionVar = freshVar info - Just exprInfo = xobjInfo expr + exprInfo = infoOrUnknown $ xobjInfo expr in do exprRetVar <- visitWhileExpression indent appendToSrc (addIndent indent ++ tyToCLambdaFix exprTy ++ " " ++ conditionVar ++ " = " ++ exprRetVar ++ ";\n") @@ -496,7 +501,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo let lastExpr = last expressions retVar = freshVar info mapM_ (visit indent) (init expressions) - let (Just lastTy) = xobjTy lastExpr + let lastTy = fromMaybe (error "emit: final expression in do has no type") $ xobjTy lastExpr if lastTy == UnitTy then do _ <- visit indent lastExpr @@ -514,7 +519,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo (XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : (XObj (Sym sym _) _ _) : _)) _ _) -> "*" ++ pathToC sym (XObj (Sym sym _) _ _) -> pathToC sym _ -> error (show (CannotSet variable)) - Just varInfo = xobjInfo variable + varInfo = infoOrUnknown $ xobjInfo variable --appendToSrc (addIndent indent ++ "// " ++ show (length (infoDelete varInfo)) ++ " deleters for " ++ properVariableName ++ ":\n") delete indent varInfo appendToSrc @@ -530,7 +535,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo [XObj The _ _, _, value] -> do var <- visit indent value - let Just t = ty + let t = fromMaybe (error "emit: called emit on the with no type") ty fresh = mangle (freshVar info) unless (isUnit t) @@ -540,7 +545,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo [XObj Ref _ _, value] -> do var <- visit indent value - let Just t = ty + let t = case ty of + Just typ -> typ + _ -> error "emit: called emit on ref with no type" fresh = mangle (freshVar info) case t of (RefTy UnitTy _) -> appendToSrc "" @@ -548,7 +555,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo if isNumericLiteral value then do let literal = freshVar info ++ "_lit" - Just literalTy = xobjTy value + literalTy = case xobjTy value of + Just typ -> typ + _ -> error "called emit on ref without value type" appendToSrc (addIndent indent ++ "static " ++ tyToCLambdaFix literalTy ++ " " ++ literal ++ " = " ++ var ++ ";\n") appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ literal ++ "; // ref\n") else appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ var ++ "; // ref\n") @@ -573,10 +582,13 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo pure "" _ -> do - let Just t = ty - appendToSrc (templateToC template path t) - pure "" - -- Alias + case ty of + Just t -> + do + appendToSrc (templateToC template path t) + pure "" + _ -> pure "" -- called with no type + -- Alias XObj (Defalias _) _ _ : _ -> pure "" -- External @@ -612,10 +624,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo func@(XObj (Sym _ (LookupGlobalOverride overriddenName)) _ _) : args -> do argListAsC <- createArgList indent True args -- The 'True' means "unwrap lambdas" which is always the case for functions with overriden names (they are external) - let funcTy = case xobjTy func of - Just actualType -> actualType + let retTy = case xobjTy func of + Just (FuncTy _ rt _) -> rt _ -> error ("No type on func " ++ show func) - FuncTy _ retTy _ = funcTy callFunction = overriddenName ++ "(" ++ argListAsC ++ ");\n" if isUnit retTy then do @@ -629,7 +640,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo func@(XObj (Sym path (LookupGlobal mode AFunction)) _ _) : args -> do argListAsC <- createArgList indent (mode == ExternalCode) args - let Just (FuncTy _ retTy _) = xobjTy func + let retTy = case xobjTy func of + Just (FuncTy _ rt _) -> rt + _ -> error "failed to emit function application for non-function type." funcToCall = pathToC path if isUnit retTy then do @@ -647,10 +660,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo XObj (Sym _ (LookupGlobal ExternalCode _)) _ _ -> True _ -> False argListAsC <- createArgList indent unwrapLambdas args - let funcTy = case xobjTy func of - Just actualType -> actualType + let (argTys, retTy) = case xobjTy func of + Just (FuncTy at rt _) -> (at, rt) _ -> error ("No type on func " ++ show func) - FuncTy argTys retTy _ = funcTy voidless = remove isUnit argTys castToFn = if unwrapLambdas @@ -700,23 +712,26 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo do let arrayVar = freshVar i len = length xobjs - Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerTy]) = t - appendToSrc - ( addIndent indent ++ "Array " ++ arrayVar - ++ " = { .len = " - ++ show len - ++ "," - ++ " .capacity = " - ++ show len - ++ "," - ++ " .data = CARP_MALLOC(sizeof(" - ++ tyToCLambdaFix innerTy - ++ ") * " - ++ show len - ++ ") };\n" - ) - zipWithM_ (visitArrayElement indent arrayVar innerTy) [0 ..] xobjs - pure arrayVar + case t of + Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerTy]) -> + do + appendToSrc + ( addIndent indent ++ "Array " ++ arrayVar + ++ " = { .len = " + ++ show len + ++ "," + ++ " .capacity = " + ++ show len + ++ "," + ++ " .data = CARP_MALLOC(sizeof(" + ++ tyToCLambdaFix innerTy + ++ ") * " + ++ show len + ++ ") };\n" + ) + zipWithM_ (visitArrayElement indent arrayVar innerTy) [0 ..] xobjs + pure arrayVar + _ -> pure "" -- called with non-array type visitArray _ _ = error "Must visit array!" visitArrayElement :: Int -> String -> Ty -> Int -> XObj -> State EmitterState () visitArrayElement indent arrayVar innerTy index xobj = @@ -741,21 +756,24 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo retVar = arrayVar ++ "_retref" arrayDataVar = arrayVar ++ "_data" len = length xobjs - Just tt@(RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [innerTy]) _) = t - appendToSrc (addIndent indent ++ tyToCLambdaFix innerTy ++ " " ++ arrayDataVar ++ "[" ++ show len ++ "];\n") - appendToSrc - ( addIndent indent ++ "Array " ++ arrayVar - ++ " = { .len = " - ++ show len - ++ "," - ++ " /* .capacity = DOES NOT MATTER, STACK ALLOCATED ARRAY, */" - ++ " .data = " - ++ arrayDataVar - ++ " };\n" - ) - zipWithM_ (visitStaticArrayElement indent arrayDataVar innerTy) [0 ..] xobjs - appendToSrc (addIndent indent ++ tyToCLambdaFix tt ++ " " ++ retVar ++ " = &" ++ arrayVar ++ ";\n") - pure retVar + case t of + Just tt@(RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [innerTy]) _) -> + do + appendToSrc (addIndent indent ++ tyToCLambdaFix innerTy ++ " " ++ arrayDataVar ++ "[" ++ show len ++ "];\n") + appendToSrc + ( addIndent indent ++ "Array " ++ arrayVar + ++ " = { .len = " + ++ show len + ++ "," + ++ " /* .capacity = DOES NOT MATTER, STACK ALLOCATED ARRAY, */" + ++ " .data = " + ++ arrayDataVar + ++ " };\n" + ) + zipWithM_ (visitStaticArrayElement indent arrayDataVar innerTy) [0 ..] xobjs + appendToSrc (addIndent indent ++ tyToCLambdaFix tt ++ " " ++ retVar ++ " = &" ++ arrayVar ++ ";\n") + pure retVar + _ -> pure "" -- called with non-array type visitStaticArray _ _ = error "Must visit static array!" visitStaticArrayElement :: Int -> String -> Ty -> Int -> XObj -> State EmitterState () visitStaticArrayElement indent arrayDataVar _ index xobj = @@ -785,7 +803,9 @@ delete indent i = mapM_ deleterToC (infoDelete i) defnToDeclaration :: MetaData -> SymPath -> [XObj] -> Ty -> String defnToDeclaration meta path@(SymPath _ name) argList retTy = let override = Meta.getString (Meta.getCompilerKey Meta.CNAME) meta - (XObj (Lst annotations) _ _) = fromMaybe emptyList (Meta.get "annotations" meta) + annotations = case fromMaybe emptyList (Meta.get "annotations" meta) of + (XObj (Lst xs) _ _) -> xs + _ -> [] annotationsStr = joinWith " " (map strToC annotations) sep = if not (null annotationsStr) then " " else "" fullname = if (null override) then (pathToC path) else override @@ -895,15 +915,18 @@ toDeclaration :: Binder -> String toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) = case xobjs of [XObj (Defn _) _ _, XObj (Sym path _) _ _, XObj (Arr argList) _ _, _] -> - let (Just (FuncTy _ retTy _)) = ty - in defnToDeclaration meta path argList retTy ++ ";\n" + case ty of + (Just (FuncTy _ retTy _)) -> defnToDeclaration meta path argList retTy ++ ";\n" + _ -> "" -- called with non-function type, emit nothing. [XObj Def _ _, XObj (Sym path _) _ _, _] -> - let Just t = ty - cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta) - fullname = if (null cname) then pathToC path else cname - in if (isUnit t) - then "" - else tyToCLambdaFix t ++ " " ++ fullname ++ ";\n" + case ty of + Just t -> + let cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta) + fullname = if (null cname) then pathToC path else cname + in if (isUnit t) + then "" + else tyToCLambdaFix t ++ " " ++ fullname ++ ";\n" + _ -> "" -- called with no type, emit nothing. XObj (Deftype t) _ _ : XObj (Sym path _) _ _ : rest -> defStructToDeclaration t path rest XObj (DefSumtype t) _ _ : XObj (Sym _ _) _ _ : rest -> @@ -917,8 +940,9 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) = XObj DefDynamic _ _ : _ -> "" [XObj (Instantiate template) _ _, XObj (Sym path _) _ _] -> - let Just t = ty - in templateToDeclaration template path t + case ty of + Just t -> templateToDeclaration template path t + _ -> "" -- called with no type, emit nothing. [XObj (Defalias aliasTy) _ _, XObj (Sym path _) _ _] -> defaliasToDeclaration aliasTy path [XObj (Interface _ _) _ _, _] -> @@ -1015,14 +1039,9 @@ globalsToC globalEnv = typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String typeEnvToDeclarations typeEnv global = let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call. - addEnvToScore tyE = (sortDeclarationBinders tyE global (map snd (Map.toList (binders tyE)))) bindersWithScore = (addEnvToScore typeEnv) mods = (findModules global) - folder = - ( \sorted (XObj (Mod e t) _ _) -> - sorted ++ (foldl folder (addEnvToScore t) (findModules e)) - ) - allScoredBinders = sortOn fst (foldl folder bindersWithScore mods) + allScoredBinders = sortOn fst (foldl go bindersWithScore mods) in do okDecls <- mapM @@ -1033,6 +1052,10 @@ typeEnvToDeclarations typeEnv global = ) allScoredBinders pure (concat okDecls) + where + addEnvToScore tyE = (sortDeclarationBinders tyE global (map snd (Map.toList (binders tyE)))) + go sorted (XObj (Mod e t) _ _) = sorted ++ (foldl go (addEnvToScore t) (findModules e)) + go xs _ = xs envToDeclarations :: TypeEnv -> Env -> Either ToCError String envToDeclarations typeEnv env = diff --git a/src/Env.hs b/src/Env.hs index cc5fa03d2..04d96f133 100644 --- a/src/Env.hs +++ b/src/Env.hs @@ -8,6 +8,7 @@ module Env empty, new, parent, + parentOrEmpty, setParent, nested, recursive, @@ -148,6 +149,13 @@ binders = envBindings . prj parent :: Environment e => e -> Maybe e parent = fmap inj . envParent . prj +-- Attempts to retrieve the parent from an environment. +-- If the environment has no parent, returns the empty environment. +parentOrEmpty :: Environment e => e -> e +parentOrEmpty e = case envParent (prj e) of + Just p -> inj p + Nothing -> empty + -- | Set the parent of an environment. setParent :: Environment e => e -> e -> e setParent e p = inj ((prj e) {envParent = Just (prj p)}) diff --git a/src/Eval.hs b/src/Eval.hs index ac6988fd4..660b69a08 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -279,7 +279,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = Left err -> pure (ctx, Left err) Right newCtx -> do (finalCtx, evaledBody) <- eval newCtx body (PreferLocal (map (\(name, _) -> (SymPath [] name)) binds)) ResolveLocal - let Just e = contextInternalEnv finalCtx + let e = fromMaybe E.empty $ contextInternalEnv finalCtx parentEnv = envParent e pure ( replaceInternalEnvMaybe finalCtx parentEnv, @@ -301,7 +301,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = -- (let [f (fn [x] (if (= x 1) x (f (dec x))))] (f 10)) let origin = (contextInternalEnv ctx') recFix = (E.recursive origin (Just "let-rec-env") 0) - Right envWithSelf = if isFn x then E.insertX recFix (SymPath [] n) x else Right recFix + envWithSelf = fromRight recFix $ if isFn x then E.insertX recFix (SymPath [] n) x else Right recFix ctx'' = replaceInternalEnv ctx' envWithSelf (newCtx, res) <- eval ctx'' x preference resolver case res of @@ -350,18 +350,21 @@ eval ctx xobj@(XObj o info ty) preference resolver = evaluateCommand (AppPat (CommandPat (UnaryCommandFunction unary) _ _) [x]) = do (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x] case evaledArgs of - Right args -> let [x'] = take 1 args in unary c x' + Right [x'] -> unary c x' Left err -> pure (ctx, Left err) + _ -> error "eval: failed to evaluate command arguments" evaluateCommand (AppPat (CommandPat (BinaryCommandFunction binary) _ _) [x, y]) = do (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y] case evaledArgs of - Right args -> let [x', y'] = take 2 args in binary c x' y' + Right [x', y'] -> binary c x' y' Left err -> pure (ctx, Left err) + _ -> error "eval: failed to evaluate command arguments" evaluateCommand (AppPat (CommandPat (TernaryCommandFunction ternary) _ _) [x, y, z]) = do (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z] case evaledArgs of - Right args' -> let [x', y', z'] = take 3 args' in ternary c x' y' z' + Right [x', y', z'] -> ternary c x' y' z' Left err -> pure (ctx, Left err) + _ -> error "eval: failed to evaluate command arguments" evaluateCommand (AppPat (CommandPat (VariadicCommandFunction variadic) _ _) args) = do (c, evaledArgs) <- foldlM successiveEval (ctx, Right []) args case evaledArgs of @@ -629,12 +632,12 @@ catcher ctx exception = specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj) specialCommandWith ctx _ path forms = do - let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx) + let env = fromMaybe (contextGlobalEnv ctx) $ contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx) useThese = envUseModules env env' = env {envUseModules = Set.insert path useThese} ctx' = replaceGlobalEnv ctx env' ctxAfter <- liftIO $ foldM folder ctx' forms - let Just envAfter = contextInternalEnv ctxAfter <|> maybeId (innermostModuleEnv ctxAfter) <|> Just (contextGlobalEnv ctxAfter) + let envAfter = fromMaybe (contextGlobalEnv ctxAfter) (contextInternalEnv ctxAfter <|> maybeId (innermostModuleEnv ctxAfter) <|> Just (contextGlobalEnv ctxAfter)) -- undo ALL use:s made inside the 'with'. ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese}) pure (ctxAfter', dynamicNil) diff --git a/src/Expand.hs b/src/Expand.hs index ef9c58f39..233b4d81e 100644 --- a/src/Expand.hs +++ b/src/Expand.hs @@ -2,6 +2,7 @@ module Expand (expandAll, replaceSourceInfoOnXObj) where import Context import Control.Monad.State (State, evalState, get, put) +import Data.Either (fromRight) import Data.Foldable (foldlM) import Env import EvalError @@ -221,7 +222,7 @@ expand eval ctx xobj = if isSpecialSym f then do (ctx', s) <- eval ctx f - let Right sym = s + let sym = fromRight (error "expand: failed to expand special symbol") $ s expand eval ctx' (XObj (Lst (sym : args)) (xobjInfo xobj) (xobjTy xobj)) else do (_, expandedF) <- expand eval ctx f diff --git a/src/GenerateConstraints.hs b/src/GenerateConstraints.hs index 9fe9cbe70..3474423d6 100644 --- a/src/GenerateConstraints.hs +++ b/src/GenerateConstraints.hs @@ -21,35 +21,37 @@ genConstraints _ root rootSig = fmap sort (gen root) insideBodyConstraints <- gen body xobjType <- toEither (xobjTy xobj) (DefnMissingType xobj) bodyType <- toEither (xobjTy body) (ExpressionMissingType xobj) - let (FuncTy argTys retTy lifetimeTy) = xobjType - bodyConstr = Constraint retTy bodyType xobj body xobj OrdDefnBody - argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (List.map forceTy args) argTys args - -- The constraint generated by type signatures, like (sig foo (Fn ...)): - -- This constraint is ignored for any xobj != rootxobj (ie. (fn) let bindings) - sigConstr = - if root == xobj - then case rootSig of - Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation] - Nothing -> [] - else [] - captureList :: [XObj] - captureList = Set.toList captures - capturesConstrs = - catMaybes - ( zipWith - ( \captureTy captureObj -> - case captureTy of - RefTy _ refLt -> - --trace ("Generated constraint between " ++ show lifetimeTy ++ " and " ++ show refLt) $ - Just (Constraint lifetimeTy refLt captureObj xobj xobj OrdCapture) - _ -> - --trace ("Did not generate constraint for captured variable " ++ show captureObj) $ - Nothing + case xobjType of + (FuncTy argTys retTy lifetimeTy) -> + let bodyConstr = Constraint retTy bodyType xobj body xobj OrdDefnBody + argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (List.map forceTy args) argTys args + -- The constraint generated by type signatures, like (sig foo (Fn ...)): + -- This constraint is ignored for any xobj != rootxobj (ie. (fn) let bindings) + sigConstr = + if root == xobj + then case rootSig of + Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation] + Nothing -> [] + else [] + captureList :: [XObj] + captureList = Set.toList captures + capturesConstrs = + catMaybes + ( zipWith + ( \captureTy captureObj -> + case captureTy of + RefTy _ refLt -> + --trace ("Generated constraint between " ++ show lifetimeTy ++ " and " ++ show refLt) $ + Just (Constraint lifetimeTy refLt captureObj xobj xobj OrdCapture) + _ -> + --trace ("Did not generate constraint for captured variable " ++ show captureObj) $ + Nothing + ) + (List.map forceTy captureList) + captureList ) - (List.map forceTy captureList) - captureList - ) - pure (bodyConstr : argConstrs ++ insideBodyConstraints ++ capturesConstrs ++ sigConstr) + in pure (bodyConstr : argConstrs ++ insideBodyConstraints ++ capturesConstrs ++ sigConstr) + _ -> Left (DefnMissingType xobj) -- TODO: Better error here. gen xobj = case xobjObj xobj of Lst lst -> case lst of @@ -76,21 +78,23 @@ genConstraints _ root rootSig = fmap sort (gen root) insideBodyConstraints <- gen body insideBindingsConstraints <- fmap join (mapM gen bindings) bodyType <- toEither (xobjTy body) (ExpressionMissingType body) - let Just xobjTy' = xobjTy xobj - wholeStatementConstraint = Constraint bodyType xobjTy' body xobj xobj OrdLetBody - bindingsConstraints = - zipWith - ( \(symTy, exprTy) (symObj, exprObj) -> - Constraint symTy exprTy symObj exprObj xobj OrdLetBind - ) - (List.map (forceTy *** forceTy) (pairwise bindings)) - (pairwise bindings) - pure - ( wholeStatementConstraint : - insideBodyConstraints - ++ bindingsConstraints - ++ insideBindingsConstraints - ) + case xobjTy xobj of + Just xobjTy' -> + let wholeStatementConstraint = Constraint bodyType xobjTy' body xobj xobj OrdLetBody + bindingsConstraints = + zipWith + ( \(symTy, exprTy) (symObj, exprObj) -> + Constraint symTy exprTy symObj exprObj xobj OrdLetBind + ) + (List.map (forceTy *** forceTy) (pairwise bindings)) + (pairwise bindings) + in pure + ( wholeStatementConstraint : + insideBodyConstraints + ++ bindingsConstraints + ++ insideBindingsConstraints + ) + Nothing -> Left (ExpressionMissingType xobj) -- If [XObj If _ _, expr, ifTrue, ifFalse] -> do @@ -103,16 +107,18 @@ genConstraints _ root rootSig = fmap sort (gen root) let expected = XObj (Sym (SymPath [] "Condition in if value") Symbol) (xobjInfo expr) (Just BoolTy) let conditionConstraint = Constraint exprType BoolTy expr expected xobj OrdIfCondition sameReturnConstraint = Constraint trueType falseType ifTrue ifFalse xobj OrdIfReturn - Just t = xobjTy xobj - wholeStatementConstraint = Constraint trueType t ifTrue xobj xobj OrdIfWhole - pure - ( conditionConstraint : - sameReturnConstraint : - wholeStatementConstraint : - insideConditionConstraints - ++ insideTrueConstraints - ++ insideFalseConstraints - ) + in case xobjTy xobj of + Just t -> + let wholeStatementConstraint = Constraint trueType t ifTrue xobj xobj OrdIfWhole + in pure + ( conditionConstraint : + sameReturnConstraint : + wholeStatementConstraint : + insideConditionConstraints + ++ insideTrueConstraints + ++ insideFalseConstraints + ) + Nothing -> Left (ExpressionMissingType xobj) -- Match XObj (Match matchMode) _ _ : expr : cases -> do @@ -242,9 +248,11 @@ genConstraints _ root rootSig = fmap sort (gen root) argTys args [0 ..] - Just xobjTy' = xobjTy xobj - retConstraint = Constraint xobjTy' retTy xobj func xobj OrdFuncAppRet - in pure (retConstraint : funcConstraints ++ argConstraints ++ variablesConstraints) + in case xobjTy xobj of + Just xobjTy' -> + let retConstraint = Constraint xobjTy' retTy xobj func xobj OrdFuncAppRet + in pure (retConstraint : funcConstraints ++ argConstraints ++ variablesConstraints) + Nothing -> Left (ExpressionMissingType xobj) funcVarTy@(VarTy _) -> let fabricatedFunctionType = FuncTy (List.map forceTy args) (forceTy xobj) (VarTy "what?!") expected = XObj (Sym (SymPath [] ("Calling '" ++ getName func ++ "'")) Symbol) (xobjInfo func) Nothing @@ -258,42 +266,50 @@ genConstraints _ root rootSig = fmap sort (gen root) [] -> Right [] x : xs -> do insideExprConstraints <- fmap join (mapM gen arr) - let Just headTy = xobjTy x - genObj o n = - XObj - (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol) - (xobjInfo o) - (xobjTy o) - headObj = - XObj - (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol) - (xobjInfo x) - (Just headTy) - Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) = xobjTy xobj - betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..] - headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead - pure (headConstraint : insideExprConstraints ++ betweenExprConstraints) - -- THIS CODE IS VERY MUCH A DUPLICATION OF THE 'ARR' CODE FROM ABOVE: + case xobjTy x of + Nothing -> Left (ExpressionMissingType x) + Just headTy -> + let genObj o n = + XObj + (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol) + (xobjInfo o) + (xobjTy o) + headObj = + XObj + (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol) + (xobjInfo x) + (Just headTy) + in case xobjTy xobj of + Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) -> + let betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..] + headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead + in pure (headConstraint : insideExprConstraints ++ betweenExprConstraints) + _ -> Left (ExpressionMissingType xobj) -- TODO: better error here. + -- THIS CODE IS VERY MUCH A DUPLICATION OF THE 'ARR' CODE FROM ABOVE: (StaticArr arr) -> case arr of [] -> Right [] x : xs -> do insideExprConstraints <- fmap join (mapM gen arr) - let Just headTy = xobjTy x - genObj o n = - XObj - (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol) - (xobjInfo o) - (xobjTy o) - headObj = - XObj - (Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol) - (xobjInfo x) - (Just headTy) - Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [t]) _) = xobjTy xobj - betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..] - headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead - pure (headConstraint : insideExprConstraints ++ betweenExprConstraints) + case xobjTy x of + Nothing -> Left (ExpressionMissingType x) + Just headTy -> + let genObj o n = + XObj + (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol) + (xobjInfo o) + (xobjTy o) + headObj = + XObj + (Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol) + (xobjInfo x) + (Just headTy) + in case xobjTy xobj of + Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [t]) _) -> + let betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..] + headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead + in pure (headConstraint : insideExprConstraints ++ betweenExprConstraints) + _ -> Left (ExpressionMissingType xobj) -- TODO: Better error here. _ -> Right [] genConstraintsForCaseMatcher :: MatchMode -> XObj -> Either TypeError [Constraint] @@ -317,9 +333,11 @@ genConstraintsForCaseMatcher matchMode = gen (zipWith refWrapper variables argTys) variables [0 ..] - Just xobjTy' = xobjTy xobj - retConstraint = Constraint xobjTy' retTy xobj caseName xobj OrdFuncAppRet - in pure (retConstraint : caseNameConstraints ++ argConstraints ++ variablesConstraints) + in case xobjTy xobj of + Nothing -> Left (ExpressionMissingType xobj) + Just t -> + let retConstraint = Constraint t retTy xobj caseName xobj OrdFuncAppRet + in pure (retConstraint : caseNameConstraints ++ argConstraints ++ variablesConstraints) funcVarTy@(VarTy _) -> let fabricatedFunctionType = FuncTy (List.map forceTy variables) (forceTy xobj) (VarTy "what?!") -- TODO: Fix expected = XObj (Sym (SymPath [] ("Matchin on '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) Nothing diff --git a/src/Info.hs b/src/Info.hs index 45fc1dd4d..02993d9ac 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -13,13 +13,14 @@ module Info setDeletersOnInfo, addDeletersToInfo, uniqueDeleter, + infoOrUnknown, ) where +import Data.List (unionBy) import Path (takeFileName) import qualified Set import SymPath -import Data.List (unionBy) -- | Information about where the Obj originated from. data Info = Info @@ -90,6 +91,12 @@ instance Show FilePathPrintLength where dummyInfo :: Info dummyInfo = Info 0 0 "dummy-file" Set.empty (-1) +-- | Attempts to pull the Info out of a Maybe Info, otherwise, returns an Info +-- object representing the fact that Info is missing for the binding. +infoOrUnknown :: Maybe Info -> Info +infoOrUnknown (Just i) = i +infoOrUnknown Nothing = Info 0 0 "unknown" Set.empty (-1) + -- | Returns the line number, column number, and filename associated with an -- Info. getInfo :: Info -> (Int, Int, String) diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs index bd0446409..a4d1f251d 100644 --- a/src/InitialTypes.hs +++ b/src/InitialTypes.hs @@ -1,6 +1,7 @@ module InitialTypes where import Control.Monad.State +import Data.Either (fromRight) import Env as E import Info import qualified Map @@ -202,7 +203,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy) typedNameSymbol = nameSymbol {xobjTy = funcTy} -- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...) - Right envWithSelf = E.insertX funcScopeEnv (SymPath [] name) typedNameSymbol + envWithSelf = fromRight funcScopeEnv (E.insertX funcScopeEnv (SymPath [] name) typedNameSymbol) visitedBody <- visit envWithSelf body visitedArgs <- mapM (visit envWithSelf) argList pure $ do @@ -220,7 +221,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 lt <- genVarTy let funcTy = Just (FuncTy argTypes returnType lt) typedNameSymbol = XObj (Sym path LookupRecursive) si funcTy - Right envWithSelf = E.insertX funcScopeEnv path typedNameSymbol + envWithSelf = fromRight funcScopeEnv (E.insertX funcScopeEnv path typedNameSymbol) visitedBody <- visit envWithSelf body visitedArgs <- mapM (visit envWithSelf) argList pure $ do @@ -401,8 +402,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 | otherwise -> genVarTy pure $ do okValue <- visitedValue - let Just valueTy = xobjTy okValue - pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt))) + let valueTy = case xobjTy okValue of + Just vt -> (Just (RefTy vt lt)) + Nothing -> Nothing + pure (XObj (Lst [refExpr, okValue]) i valueTy) -- Deref (error!) [XObj Deref _ _, _] -> pure (Left (CantUseDerefOutsideFunctionApplication xobj)) diff --git a/src/Interfaces.hs b/src/Interfaces.hs index 05395e96e..7d2dfedc2 100644 --- a/src/Interfaces.hs +++ b/src/Interfaces.hs @@ -151,7 +151,9 @@ retroactivelyRegisterInInterface ctx interface = where env = contextGlobalEnv ctx impls = concat (rights (fmap ((flip Env.findImplementations) (getPath (binderXObj interface))) (env : (Env.lookupChildren env)))) - (resultCtx, err) = foldl' (\(Right context, _) binder -> registerInInterface context binder interface) (Right ctx, Nothing) impls + (resultCtx, err) = foldl' go (Right ctx, Nothing) impls + go (Right context, _) binder = registerInInterface context binder interface + go e _ = e -- | Checks whether an interface is implemented for a certain type signature, -- | e.g. Is "delete" implemented for `(Fn [String] ())` ? diff --git a/src/Memory.hs b/src/Memory.hs index 43ed489bf..91d374073 100644 --- a/src/Memory.hs +++ b/src/Memory.hs @@ -3,6 +3,7 @@ module Memory (manageMemory) where import Control.Monad.State +import Data.Maybe (fromMaybe) import Forms import Info import Managed @@ -93,7 +94,9 @@ manageMemory typeEnv globalEnv root = whenRight (sequence results) $ do -- We know that we want to add a deleter for the static array here let var = varOfXObj xobj - Just (RefTy t@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [_]) _) = xobjTy xobj + t = case xobjTy xobj of + Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [vs]) _) -> (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [vs]) + _ -> error "memory: can't visit static array of non static array type" deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of Just pathOfDeleteFunc -> ProperDeleter pathOfDeleteFunc (getDropFunc typeEnv globalEnv (xobjInfo xobj) t) var @@ -487,7 +490,7 @@ manage typeEnv globalEnv xobj = Just deleter -> do MemState deleters deps lifetimes <- get let newDeleters = Set.insert deleter deleters - Just t = xobjTy xobj + t = fromMaybe (error "memory: can't manage xobj without type") $ xobjTy xobj newDeps = Set.insert t deps put (MemState newDeleters newDeps lifetimes) Nothing -> pure () @@ -495,7 +498,7 @@ manage typeEnv globalEnv xobj = -- | Remove `xobj` from the set of alive variables, in need of deletion at end of scope. unmanage :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ()) unmanage typeEnv globalEnv xobj = - let Just t = xobjTy xobj + let t = fromMaybe (error "memory: can't unmange xobj without type") $ xobjTy xobj in if isManaged typeEnv globalEnv t && not (isGlobalFunc xobj) then do MemState deleters deps lifetimes <- get @@ -528,19 +531,20 @@ transferOwnership typeEnv globalEnv from to = -- see issue #597 exclusiveTransferOwnership :: TypeEnv -> Env -> XObj -> XObj -> State MemState (Either TypeError ()) exclusiveTransferOwnership tenv genv from to = - do result <- unmanage tenv genv from - whenRight result $ do - MemState pre deps lts <- get - put (MemState Set.empty deps lts) -- add just this new deleter to the set - manage tenv genv to - MemState post postDeps postLts <- get - put (MemState (uniqueDeleter post pre) postDeps postLts) -- replace any duplicates and union with the prior set - pure (Right ()) + do + result <- unmanage tenv genv from + whenRight result $ do + MemState pre deps lts <- get + put (MemState Set.empty deps lts) -- add just this new deleter to the set + manage tenv genv to + MemState post postDeps postLts <- get + put (MemState (uniqueDeleter post pre) postDeps postLts) -- replace any duplicates and union with the prior set + pure (Right ()) -- | Control that an `xobj` is OK to reference canBeReferenced :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ()) canBeReferenced typeEnv globalEnv xobj = - let Just t = xobjTy xobj + let t = fromMaybe (error "memory: xobj without type") $ xobjTy xobj isGlobalVariable = case xobj of XObj (Sym _ (LookupGlobal _ _)) _ _ -> True _ -> False @@ -590,9 +594,11 @@ refTargetIsAlive xobj = [] -> --trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ --pure (Right xobj) - pure (case xobjObj xobj of - (Lst (LetPat _ _ body)) -> (Left (UsingDeadReference body deleterName)) - _ -> (Left (UsingDeadReference xobj deleterName))) + pure + ( case xobjObj xobj of + (Lst (LetPat _ _ body)) -> (Left (UsingDeadReference body deleterName)) + _ -> (Left (UsingDeadReference xobj deleterName)) + ) _ -> --trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $ pure (Right xobj) diff --git a/src/Meta.hs b/src/Meta.hs index 5eadfe40f..f51fb84c9 100644 --- a/src/Meta.hs +++ b/src/Meta.hs @@ -11,17 +11,17 @@ module Meta getString, getCompilerKey, validateAndSet, - CompilerKey(..), + CompilerKey (..), ) where +import Data.Either (fromRight) +import Data.Maybe (fromMaybe) import Info import qualified Map import Obj import SymPath import Types -import Data.Maybe(fromMaybe) -import Data.Either(fromRight) -------------------------------------------------------------------------------- -- builtin special meta key values @@ -31,7 +31,7 @@ data CompilerKey = CNAME -- Given a compiler key, returns the key name as a string along with a default value. toKeyValue :: CompilerKey -> (String, XObj) -toKeyValue CNAME = ("c-name", (XObj (Str "") Nothing Nothing)) +toKeyValue CNAME = ("c-name", (XObj (Str "") Nothing Nothing)) -- | Get the key associated with a compiler Meta key as a string. getCompilerKey :: CompilerKey -> String @@ -51,7 +51,7 @@ validateCompilerKeyValue CNAME _ = False validateAndSet :: MetaData -> CompilerKey -> XObj -> Either MetaData MetaData validateAndSet meta key val | validateCompilerKeyValue key (xobjObj val) = - Right (set (getCompilerKey key) val meta) + Right (set (getCompilerKey key) val meta) | otherwise = Left meta -------------------------------------------------------------------------------- diff --git a/src/Obj.hs b/src/Obj.hs index 8f200b0aa..1372fbfa6 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -332,12 +332,11 @@ machineReadableInfoFromXObj fppl xobj = Nothing -> "" -- | Obj with eXtra information. -data XObj - = XObj - { xobjObj :: Obj, - xobjInfo :: Maybe Info, - xobjTy :: Maybe Ty - } +data XObj = XObj + { xobjObj :: Obj, + xobjInfo :: Maybe Info, + xobjTy :: Maybe Ty + } deriving (Show, Eq, Ord) setObj :: XObj -> Obj -> XObj @@ -720,15 +719,14 @@ data EnvMode = ExternalEnv | InternalEnv | RecursionEnv deriving (Show, Eq, Gene instance Hashable EnvMode -- | Environment -data Env - = Env - { envBindings :: Map.Map String Binder, - envParent :: Maybe Env, - envModuleName :: Maybe String, - envUseModules :: Set.Set SymPath, - envMode :: EnvMode, - envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting - } +data Env = Env + { envBindings :: Map.Map String Binder, + envParent :: Maybe Env, + envModuleName :: Maybe String, + envUseModules :: Set.Set SymPath, + envMode :: EnvMode, + envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting + } deriving (Show, Eq, Generic) instance Hashable Env @@ -911,13 +909,12 @@ polymorphicSuffix signature actualType = type VisitedTypes = [Ty] -- | Templates are like macros, but defined inside the compiler and with access to the types they are instantiated with -data Template - = Template - { templateSignature :: Ty, - templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful? - templateDefinition :: Ty -> [Token], - templateDependencies :: Ty -> [XObj] - } +data Template = Template + { templateSignature :: Ty, + templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful? + templateDefinition :: Ty -> [Token], + templateDependencies :: Ty -> [XObj] + } instance Hashable Template where hashWithSalt s Template {..} = s `hashWithSalt` templateSignature @@ -937,7 +934,7 @@ data Token = TokTy Ty TokTyMode -- Some kind of type, will be looked up if it's a type variable. | TokC String -- Plain C code. | TokDecl -- Will emit the declaration (i.e. "foo(int x)"), this is useful - -- for avoiding repetition in the definition part of the template. + -- for avoiding repetition in the definition part of the template. | TokName -- Will emit the name of the instantiated function/variable. deriving (Eq, Ord) @@ -995,19 +992,25 @@ forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (xobjTy xobj) data ExecutionMode = Repl | Build | BuildAndRun | Install String | Check deriving (Show, Eq) -- | Information needed by the REPL -data Context - = Context - { contextGlobalEnv :: Env, - contextInternalEnv :: Maybe Env, - contextTypeEnv :: TypeEnv, - contextPath :: [String], - contextProj :: Project, - contextLastInput :: String, - contextExecMode :: ExecutionMode, - contextHistory :: ![XObj] - } +data Context = Context + { contextGlobalEnv :: Env, + contextInternalEnv :: Maybe Env, + contextTypeEnv :: TypeEnv, + contextPath :: [String], + contextProj :: Project, + contextLastInput :: String, + contextExecMode :: ExecutionMode, + contextHistory :: ![XObj] + } deriving (Show, Generic) +-- required for Hashable >= 1.4.0.0 +instance Eq Context where + c == c' = + (contextGlobalEnv c) == (contextGlobalEnv c') + && (contextInternalEnv c) == (contextInternalEnv c') + && (contextTypeEnv c) == (contextTypeEnv c') + instance Hashable Context where hashWithSalt s Context {..} = s diff --git a/src/Parsing.hs b/src/Parsing.hs index eb4d8d0d7..9a4388c59 100644 --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -292,22 +292,26 @@ escaped = do 'v' -> pure "\v" 'x' -> do hex <- Parsec.many1 (Parsec.oneOf "0123456789abcdefABCDEF") - let [(p, "")] = readHex hex - return [chr p] + case readHex hex of + [(p, "")] -> pure [chr p] + _ -> pure [] 'u' -> do hex <- Parsec.count 4 (Parsec.oneOf "0123456789abcdefABCDEF") - let [(p, "")] = readHex hex - return [chr p] + case readHex hex of + [(p, "")] -> pure [chr p] + _ -> pure [] 'U' -> do hex <- Parsec.count 8 (Parsec.oneOf "0123456789abcdefABCDEF") - let [(p, "")] = readHex hex - return [chr p] + case readHex hex of + [(p, "")] -> pure [chr p] + _ -> pure [] _ -> if elem c "01234567" then do hex <- Parsec.many1 (Parsec.oneOf "01234567") - let [(p, "")] = readHex (c : hex) - return [chr p] + case readHex (c : hex) of + [(p, "")] -> pure [chr p] + _ -> pure [] else pure ('\\' : [c]) escapedQuoteChar :: Parsec.Parsec String ParseState Char @@ -357,8 +361,9 @@ escapedHexChar = do _ <- Parsec.char 'u' hex <- Parsec.count 4 (Parsec.oneOf "0123456789abcdefABCDEF") incColumn 5 - let [(parsed, "")] = readHex hex - pure (toEnum parsed) + case readHex hex of + [(parsed, "")] -> pure (toEnum parsed) + _ -> pure '\0' aChar :: Parsec.Parsec String ParseState XObj aChar = do diff --git a/src/Polymorphism.hs b/src/Polymorphism.hs index d66856c32..4b1d42177 100644 --- a/src/Polymorphism.hs +++ b/src/Polymorphism.hs @@ -9,6 +9,7 @@ where import Data.Either (fromRight, rights) import Data.List (unionBy) +import Data.Maybe (fromMaybe) import Env import Managed import Obj @@ -32,7 +33,7 @@ nameOfPolymorphicFunction _ env functionType functionName = Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) -> Just (SymPath [] name) Right (_, (Binder _ single)) -> - let Just t' = xobjTy single + let t' = fromMaybe (error "polymorphism: binder without type") $ xobjTy single (SymPath pathStrings name) = getPath single suffix = polymorphicSuffix t' functionType concretizedPath = SymPath pathStrings (name ++ suffix) @@ -124,7 +125,7 @@ findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (me -- its generic ancestor. getConcretizedPath :: XObj -> Ty -> SymPath getConcretizedPath defn functionType = - let Just t' = xobjTy defn + let t' = fromMaybe (error "polymorphism: defn without type") $ xobjTy defn SymPath pathStrings name = getPath defn suffix = polymorphicSuffix t' functionType in SymPath pathStrings (name ++ suffix) diff --git a/src/Primitives.hs b/src/Primitives.hs index c10cf8432..eac35fb60 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -135,7 +135,9 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy warn = emitWarning (show (NonExistentInterfaceWarning x)) addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj) addToInterface inter impl = - let (Right newCtx, maybeErr) = registerInInterface ctx impl inter + let (newCtx, maybeErr) = case registerInInterface ctx impl inter of + (Right nc, me) -> (nc, me) + _ -> error "primitives: failed to register in interface" in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj) handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) = @@ -210,7 +212,9 @@ define hidden ctx qualifiedXObj = pure ( Meta.getBinderMetaValue "implements" binder -- TODO: Direct qualification! - >>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces) + >>= \x -> case x of + (XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces) + _ -> pure [] ) >>= \maybeinterfaces -> pure (rights (fmap (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces))) @@ -264,7 +268,7 @@ primitiveRegisterTypeWithFields ctx x t override members = let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy) path' = (qualifyPath ctx (SymPath [] typeModuleName)) update = \c -> insertInGlobalEnv' path' (toBinder typeModuleXObj) c >>= insertTypeBinder' path' (toBinder typeDefinition) - Right ctx' = update ctx + ctx' = fromRight (error "primitives: failed to update context in register type") $ update ctx -- TODO: Another case where define does not get formally qualified deps! contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps) autoDerive @@ -325,7 +329,10 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) = implementsInterface binder binder' = maybe False - (\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls) + ( \x -> case x of + (XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls + _ -> False + ) (Meta.getBinderMetaValue "implements" binder') printIfFound :: Either ContextError Binder -> IO () printIfFound = either (const (pure ())) printer @@ -475,8 +482,8 @@ primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _ defInterface = let interface = defineInterface name t [] (xobjInfo nameXObj) binder = toBinder interface - Right ctx' = insertTypeBinder ctx (markQualified (SymPath [] name)) binder - Right newCtx = retroactivelyRegisterInInterface ctx' binder + ctx' = fromRight (error "primitives: couldn't insert type binder for interface") $ insertTypeBinder ctx (markQualified (SymPath [] name)) binder + newCtx = fromRight (error "primitives: couldn't retroactively register in interface") $ retroactivelyRegisterInInterface ctx' binder in (newCtx, dynamicNil) updateInterface binder = case binder of Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) -> diff --git a/src/Project.hs b/src/Project.hs index e10017d23..726a1eeee 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -24,41 +24,40 @@ instance Show Target where -- -- Otherwise, if the field is truly private and only for internal use in the -- compiler, add the field to the Project record but omit it from the keyMap. -data Project - = Project - { projectTitle :: String, - projectIncludes :: [Includer], - projectPreproc :: [String], - projectCFlags :: [String], - projectLibFlags :: [String], - projectPkgConfigFlags :: [String], - projectFiles :: [(FilePath, ReloadMode)], - projectAlreadyLoaded :: [FilePath], - projectEchoC :: Bool, - projectLibDir :: FilePath, - projectCarpDir :: FilePath, - projectOutDir :: FilePath, - projectDocsDir :: FilePath, - projectDocsLogo :: FilePath, - projectDocsPrelude :: String, - projectDocsURL :: String, - projectDocsGenerateIndex :: Bool, - projectDocsStyling :: String, - projectPrompt :: String, - projectCarpSearchPaths :: [FilePath], - projectPrintTypedAST :: Bool, - projectCompiler :: String, - projectTarget :: Target, - projectCore :: Bool, - projectEchoCompilationCommand :: Bool, - projectCanExecute :: Bool, - projectFilePathPrintLength :: FilePathPrintLength, - projectGenerateOnly :: Bool, - projectBalanceHints :: Bool, - projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`. - projectCModules :: [FilePath], - projectLoadStack :: [FilePath] - } +data Project = Project + { projectTitle :: String, + projectIncludes :: [Includer], + projectPreproc :: [String], + projectCFlags :: [String], + projectLibFlags :: [String], + projectPkgConfigFlags :: [String], + projectFiles :: [(FilePath, ReloadMode)], + projectAlreadyLoaded :: [FilePath], + projectEchoC :: Bool, + projectLibDir :: FilePath, + projectCarpDir :: FilePath, + projectOutDir :: FilePath, + projectDocsDir :: FilePath, + projectDocsLogo :: FilePath, + projectDocsPrelude :: String, + projectDocsURL :: String, + projectDocsGenerateIndex :: Bool, + projectDocsStyling :: String, + projectPrompt :: String, + projectCarpSearchPaths :: [FilePath], + projectPrintTypedAST :: Bool, + projectCompiler :: String, + projectTarget :: Target, + projectCore :: Bool, + projectEchoCompilationCommand :: Bool, + projectCanExecute :: Bool, + projectFilePathPrintLength :: FilePathPrintLength, + projectGenerateOnly :: Bool, + projectBalanceHints :: Bool, + projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`. + projectCModules :: [FilePath], + projectLoadStack :: [FilePath] + } projectFlags :: Project -> String projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj) diff --git a/src/Qualify.hs b/src/Qualify.hs index d9a09ac48..3a65fe5e2 100644 --- a/src/Qualify.hs +++ b/src/Qualify.hs @@ -23,11 +23,11 @@ import Data.Either (fromRight) import qualified Env as E import Info import qualified Map +import qualified Meta import Obj import qualified Set import SymPath import Util -import qualified Meta -------------------------------------------------------------------------------- -- Errors @@ -205,11 +205,14 @@ qualifyFunctionDefinition typeEnv globalEnv env x@(XObj (Lst [defn@(XObj (Defn _ envWithSelf <- fixLeft (E.insertX recursionEnv (SymPath [] functionName) sym) -- Copy the use modules from the local env to ensure they are available from the function env. functionEnv <- fixLeft (pure ((E.nested (Just envWithSelf) (Just (functionName ++ "-function-env")) 0) {envUseModules = (envUseModules env)})) - envWithArgs <- fixLeft (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr) + envWithArgs <- fixLeft (foldM go functionEnv argsArr) qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body) pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t)) where fixLeft = replaceLeft (FailedToQualifyDeclarationName x) + go :: Env -> XObj -> Either E.EnvironmentError Env + go e arg@(XObj (Sym path _) _ _) = E.insertX e path arg + go e _ = pure e qualifyFunctionDefinition _ _ _ xobj = Left $ FailedToQualifyDeclarationName xobj -- | Qualify the symbols in a lambda body. @@ -217,10 +220,14 @@ qualifyLambda :: Qualifier qualifyLambda typeEnv globalEnv env x@(XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) = let lvl = envFunctionNestingLevel env functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1) - in (replaceLeft (FailedToQualifySymbols x) (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr)) + in (replaceLeft (FailedToQualifySymbols x) (foldM go functionEnv argsArr)) >>= \envWithArgs -> liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body) >>= \qualifiedBody -> pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t)) + where + go :: Env -> XObj -> Either E.EnvironmentError Env + go e arg@(XObj (Sym path _) _ _) = E.insertX e path arg + go e _ = pure e qualifyLambda _ _ _ xobj = Left $ FailedToQualifySymbols xobj -- | Qualify the symbols in a The form's body. @@ -246,7 +253,7 @@ qualifyLet typeEnv globalEnv env x@(XObj (Lst [letExpr@(XObj Let _ _), bind@(XOb | not (all isSym (evenIndices bindings)) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error. | otherwise = do - let Just ii = i + let ii = infoOrUnknown i lvl = envFunctionNestingLevel env innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl (innerEnv', qualifiedBindings) <- foldM qualifyBinding (innerEnv, []) (pairwise bindings) @@ -264,7 +271,7 @@ qualifyLet typeEnv globalEnv env x@(XObj (Lst [letExpr@(XObj Let _ _), bind@(XOb -- However, we also need to ensure captured variables are still marked -- as such, which is based on env nesting level, and we need to ensure -- the recursive reference isn't accidentally captured. - let Just origin = E.parent e + let origin = E.parentOrEmpty e recursionEnv <- fixLeft (pure (E.recursive (Just e) (Just ("let-recurse-env")) 0)) envWithSelf <- fixLeft (E.insertX recursionEnv path s) qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv (E.setParent e (E.setParent origin envWithSelf)) o) @@ -291,7 +298,7 @@ qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : qualifiedCases <- pure . map (map unQualified) =<< mapM qualifyCases (pairwise casesXObjs) pure (Qualified (XObj (Lst (matchExpr : qualifiedExpr : concat qualifiedCases)) i t)) where - Just ii = i + ii = infoOrUnknown i lvl = envFunctionNestingLevel env -- Create an inner environment for each case. innerEnv :: Env @@ -378,18 +385,19 @@ qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i nakedInit modenv resolve origin found (Binder meta xobj') = let cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta) - modality = if (null cname) - then (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj')) - else (LookupGlobalOverride cname) + modality = + if (null cname) + then (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj')) + else (LookupGlobalOverride cname) in if (isTypeDef xobj') - then - ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path))) - >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') binder - ) - else case envMode (E.prj found) of - RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t) - InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t) - ExternalEnv -> pure (XObj (Sym (getPath xobj') modality) i t) + then + ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path))) + >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') binder + ) + else case envMode (E.prj found) of + RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t) + InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t) + ExternalEnv -> pure (XObj (Sym (getPath xobj') modality) i t) resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj resolveMulti _ [] = Left (FailedToFindSymbol xobj) diff --git a/src/RenderDocs.hs b/src/RenderDocs.hs index 56cee97cb..092002e51 100644 --- a/src/RenderDocs.hs +++ b/src/RenderDocs.hs @@ -7,6 +7,7 @@ import Control.Monad (when) import qualified Data.List as List import Data.Maybe (fromMaybe) import Data.Text as Text +import qualified Env as E import qualified Map import qualified Meta import Obj @@ -27,10 +28,14 @@ beautifyType t = mappings = Map.fromList ( List.zip - (List.map (\(VarTy name) -> name) tys) + (List.map go tys) (List.map (VarTy . (: [])) ['a' ..]) ) in replaceTyVars mappings t + where + go :: Ty -> String + go (VarTy name) = name + go _ = "" -- called on a non var type. saveDocsForEnvs :: Project -> [(SymPath, Binder)] -> IO () saveDocsForEnvs ctx pathsAndEnvBinders = @@ -63,7 +68,11 @@ saveDocsForEnvs ctx pathsAndEnvBinders = ) ) in envs - ++ getDependenciesForEnvs (Prelude.map (\(n, Binder _ (XObj (Mod env _) _ _)) -> (n, env)) envs) + ++ getDependenciesForEnvs (Prelude.map go envs) + where + go :: (SymPath, Binder) -> (SymPath, Env) + go (n, Binder _ (XObj (Mod env _) _ _)) = (n, env) + go _ = ((SymPath [] ""), E.empty) -- | This function expects a binder that contains an environment, anything else is a runtime error. getEnvAndMetaFromBinder :: Binder -> (Env, MetaData) diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index 7770cac38..066dcd6f8 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -3,6 +3,7 @@ module StartingEnv where import qualified ArrayTemplates import qualified BoxTemplates import Commands +import Data.Maybe (fromMaybe) import qualified Env as E import Eval import Info @@ -148,7 +149,7 @@ functionModule = } where bindEnv env = - let Just name = envModuleName env + let name = fromMaybe (error "env has no module name") $ envModuleName env meta = Meta.set "hidden" trueXObj emptyMeta in (name, Binder meta (XObj (Mod env E.empty) Nothing Nothing)) bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity]) @@ -380,7 +381,7 @@ dynamicStringModule = where path = ["Dynamic", "String"] bindings = - Map.fromList $unaries ++ binaries ++ ternaries + Map.fromList $ unaries ++ binaries ++ ternaries spath = SymPath path unaries = let f = addUnaryCommand . spath @@ -429,7 +430,7 @@ dynamicSymModule = } where path = ["Dynamic", "Symbol"] - bindings = Map.fromList $unaries ++ binaries + bindings = Map.fromList $ unaries ++ binaries spath = SymPath path unaries = let f = addUnaryCommand . spath @@ -455,7 +456,7 @@ dynamicProjectModule = } where path = ["Dynamic", "Project"] - bindings = Map.fromList $unaries ++ binaries + bindings = Map.fromList $ unaries ++ binaries spath = SymPath path unaries = let f = addUnaryCommand . spath diff --git a/src/StaticArrayTemplates.hs b/src/StaticArrayTemplates.hs index fff8f86d5..e9edaa2b1 100644 --- a/src/StaticArrayTemplates.hs +++ b/src/StaticArrayTemplates.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module StaticArrayTemplates where import qualified ArrayTemplates @@ -31,8 +33,9 @@ templateUnsafeNth = "}" ] ) - ( \(FuncTy [RefTy _ _, _] _ _) -> - [] + ( \case + (FuncTy [RefTy _ _, _] _ _) -> [] + _ -> error "static array templates: nth called on non array" ) templateLength :: (String, Binder) @@ -47,8 +50,10 @@ templateLength = defineTypeParameterizedTemplate templateCreator path t docs t (const (toTemplate "int $NAME (Array *a)")) (const (toTemplate "$DECL { return (*a).len; }")) - ( \(FuncTy [RefTy arrayType _] _ _) -> - depsForDeleteFunc typeEnv env arrayType + ( \case + (FuncTy [RefTy arrayType _] _ _) -> + depsForDeleteFunc typeEnv env arrayType + _ -> error "static array templates: length called on non array" ) templateDeleteArray :: (String, Binder) @@ -62,13 +67,17 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc Template t (const (toTemplate "void $NAME (Array a)")) - ( \(FuncTy [arrayType] UnitTy _) -> - [TokDecl, TokC "{\n"] - ++ deleteTy typeEnv env arrayType - ++ [TokC "}\n"] + ( \case + (FuncTy [arrayType] UnitTy _) -> + [TokDecl, TokC "{\n"] + ++ deleteTy typeEnv env arrayType + ++ [TokC "}\n"] + _ -> error "static array templates: delete called on non array" ) - ( \(FuncTy [StructTy _ [insideType]] UnitTy _) -> - depsForDeleteFunc typeEnv env insideType + ( \case + (FuncTy [StructTy _ [insideType]] UnitTy _) -> + depsForDeleteFunc typeEnv env insideType + _ -> error "static array templates: delete called on non array" ) deleteTy :: TypeEnv -> Env -> Ty -> [Token] @@ -90,22 +99,26 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)")) - ( \(FuncTy [_, _, insideTy] _ _) -> - let deleter = ArrayTemplates.insideArrayDeletion typeEnv env insideTy - in ( toTemplate $ - unlines - [ "$DECL {", - " Array a = *aRef;", - " assert(n >= 0);", - " assert(n < a.len);", - deleter "n", - " (($t*)a.data)[n] = newValue;", - "}" - ] - ) + ( \case + (FuncTy [_, _, insideTy] _ _) -> + let deleter = ArrayTemplates.insideArrayDeletion typeEnv env insideTy + in ( toTemplate $ + unlines + [ "$DECL {", + " Array a = *aRef;", + " assert(n >= 0);", + " assert(n < a.len);", + deleter "n", + " (($t*)a.data)[n] = newValue;", + "}" + ] + ) + _ -> error "static array templates: aset bang called on non array" ) - ( \(FuncTy [RefTy arrayType _, _, _] _ _) -> - depsForDeleteFunc typeEnv env arrayType + ( \case + (FuncTy [RefTy arrayType _, _, _] _ _) -> + depsForDeleteFunc typeEnv env arrayType + _ -> error "static array templates: aset bang called on non array" ) templateAsetUninitializedBang :: (String, Binder) @@ -118,23 +131,27 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator \_ _ -> Template t - ( \(FuncTy [_, _, valueType] _ _) -> - case valueType of - UnitTy -> toTemplate "void $NAME (Array *aRef, int n)" - _ -> toTemplate "void $NAME (Array *aRef, int n, $t newValue)" + ( \case + (FuncTy [_, _, valueType] _ _) -> + case valueType of + UnitTy -> toTemplate "void $NAME (Array *aRef, int n)" + _ -> toTemplate "void $NAME (Array *aRef, int n, $t newValue)" + _ -> error "static array templates: aset called on non array" ) - ( \(FuncTy [_, _, valueType] _ _) -> - case valueType of - UnitTy -> ArrayTemplates.unitSetterTemplate - _ -> - multilineTemplate - [ "$DECL {", - " Array a = *aRef;", - " assert(n >= 0);", - " assert(n < a.len);", - " (($t*)a.data)[n] = newValue;", - "}" - ] + ( \case + (FuncTy [_, _, valueType] _ _) -> + case valueType of + UnitTy -> ArrayTemplates.unitSetterTemplate + _ -> + multilineTemplate + [ "$DECL {", + " Array a = *aRef;", + " assert(n >= 0);", + " assert(n < a.len);", + " (($t*)a.data)[n] = newValue;", + "}" + ] + _ -> error "static array templates: aset called on non array" ) (const []) @@ -146,13 +163,17 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs Template t (const (toTemplate "String $NAME (Array* a)")) - ( \(FuncTy [RefTy arrayType _] StringTy _) -> - [TokDecl, TokC " {\n"] - ++ ArrayTemplates.strTy typeEnv env arrayType - ++ [TokC "}\n"] + ( \case + (FuncTy [RefTy arrayType _] StringTy _) -> + [TokDecl, TokC " {\n"] + ++ ArrayTemplates.strTy typeEnv env arrayType + ++ [TokC "}\n"] + _ -> error "static array templates: str called on non array" ) - ( \(FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) -> - depsForPrnFunc typeEnv env insideType + ( \case + (FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) -> + depsForPrnFunc typeEnv env insideType + _ -> error "static array templates: str called on non array" ) path = SymPath ["StaticArray"] "str" t = FuncTy [RefTy (StructTy concreteArray [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 634ca4b96..a9760432a 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -137,9 +137,13 @@ initers candidate = mapM binderForCaseInit (TC.getFields candidate) ft = FuncTy tys generic StaticLifetimeTy binderPath = SymPath (TC.getFullPath candidate) fieldname t = (FuncTy tys (VarTy "p") StaticLifetimeTy) - decl = \(FuncTy _ concrete _) -> tokensForCaseInitDecl generic concrete field - body = \(FuncTy _ concrete _) -> tokensForCaseInit alloc generic concrete field - deps tenv env = \(FuncTy _ concrete _) -> either (const []) id (concretizeType tenv env concrete) + decl (FuncTy _ concrete _) = tokensForCaseInitDecl generic concrete field + decl _ = error "sumtypes: genericCaseInit called with non function type" + body (FuncTy _ concrete _) = tokensForCaseInit alloc generic concrete field + body _ = error "sumtypes: genericCaseInit called with non function type" + deps tenv env = \typ -> case typ of + (FuncTy _ concrete _) -> either (const []) id (concretizeType tenv env concrete) + _ -> [] temp = TemplateCreator $ \tenv env -> Template t decl body (deps tenv env) in defineTypeParameterizedTemplate temp binderPath ft docs genericCaseInit _ _ = error "genericCaseInit" @@ -148,8 +152,10 @@ initers candidate = mapM binderForCaseInit (TC.getFields candidate) binderForTag :: BinderGen binderForTag candidate = let t = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] IntTy StaticLifetimeTy - decl = \(FuncTy [RefTy struct _] _ _) -> toTemplate $ proto struct - body = \(FuncTy [RefTy struct _] _ _) -> toTemplate $ proto struct ++ " { return p->_tag; }" + decl (FuncTy [RefTy struct _] _ _) = toTemplate $ proto struct + decl _ = error "sumtypes: binderForTag called with non function type" + body (FuncTy [RefTy struct _] _ _) = toTemplate $ proto struct ++ " { return p->_tag; }" + body _ = error "sumtypes: binderForTag called with non function type" deps = const [] path' = SymPath (TC.getFullPath candidate) "get-tag" temp = Template t decl body deps diff --git a/src/Template.hs b/src/Template.hs index 3bc0a4f62..5fb8e604b 100644 --- a/src/Template.hs +++ b/src/Template.hs @@ -69,9 +69,8 @@ concretizeTypesInToken mappings cName decl token = -- | The code needed to correctly call a lambda from C. templateCodeForCallingLambda :: String -> Ty -> [String] -> String -templateCodeForCallingLambda functionName t args = - let FuncTy argTys retTy lt = t - castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy lt) +templateCodeForCallingLambda functionName t@(FuncTy argTys retTy lt) args = + let castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy lt) castToFn = tyToCast t in functionName ++ ".env ? " ++ "((" @@ -92,12 +91,13 @@ templateCodeForCallingLambda functionName t args = ++ ".callback)(" ++ joinWithComma args ++ ")" +templateCodeForCallingLambda _ _ _ = "" -- called w/ non function type, emit nothing. -- | Must cast a lambda:s .callback member to the correct type to be able to call it. tyToCast :: Ty -> String -tyToCast t = - let FuncTy argTys retTy _ = t - in "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'. +tyToCast (FuncTy argTys retTy _) = + "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'. +tyToCast _ = "" -- called w/ non function type. Emit nothing. ---------------------------------------------------------------------------------------------------------- -- ACTUAL TEMPLATES diff --git a/src/TypeError.hs b/src/TypeError.hs index f3470a060..da954bae1 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -525,10 +525,12 @@ beautifyTy mappings = f bmappings = beautification mappings beautification :: TypeMappings -> Map.Map String String beautification m = - Map.fromList $ zip (map (\(VarTy name) -> name) tys) beautList + Map.fromList $ zip (map go tys) beautList where tys = nub $ concat $ typeVariablesInOrderOfAppearance <$> tys' tys' = snd <$> Map.assocs m + go (VarTy name) = name + go _ = "" -- called on a non var type. Emit nothing. beautList = [c : s | s <- "" : beautList, c <- ['a' .. 'z']] typeVariablesInOrderOfAppearance :: Ty -> [Ty] From 339722325ec607091f6035866ebedea2b69080fe Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 28 Dec 2022 01:17:48 -0600 Subject: [PATCH 53/59] Document the memory management system further (#1442) --- docs/Memory.md | 205 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 204 insertions(+), 1 deletion(-) diff --git a/docs/Memory.md b/docs/Memory.md index 8674e3b92..4ff9dca22 100644 --- a/docs/Memory.md +++ b/docs/Memory.md @@ -413,7 +413,210 @@ Or `foreach` (works like a foreach loop construct in a lot of other programming ``` -## Under the hood +## Under the Hood: The Implementation of Carp's Memory Management System + +This section explores the implementation of Carp's memory management system in +greater technical detail. Most users won't need to read this, but if you'd like +to have a deeper understanding of how the system works, you'll find an +explanation in this section. + +### AST Info, Identifiers, and Deleters + +Like other portions the Carp compiler, the memory management system operates on +the abstract syntax tree (AST) representation of the forms in your program. When +the compiler compiles your code, it assigns addition *information objects*, +called `Info`, to each form in your program; these objects are particularly +important to the memory management system. Among other things, these `Info` +objects contain unique identifiers for each form in your program. The memory +management system uses these identifiers to keep track of memory as it moves +across different parts of your code. + +In addition to identifiers, form information objects also contain `Deleters`. +These are a special data structure used to hold information about the `delete` +functions needed for each linear value in your program. One of the memory +management system's main responsibilities is to assign and keep track of these +deleters for each form in your program that makes use of a linear value. + +Essentially, as the memory management system examines your code, if it finds a +form that uses a linear value that should be deleted at a certain point, it adds +an appropriate deleter to the info object for the form. If the linear value is +*moved* to some other part of your code, the memory management system will +remove the corresponding deleter, which will be added to the form it's moved +into later. + +The key point to understand is that the memory management system primarily +models the movements of linear values using the presence or absence of these +deleter objects. When the compiler's code emission component encounters a form, +if the form has an associated deleter, the emitter will produce a call to the +deletion routine in the corresponding output C code. + +As we'll see in a moment, there are some further complications, but this is the +basic approach taken by the memory management system. + +### Lifetimes + +The basic operation of the memory management system entails moving deleters +across different Info objects for the forms in your program. As the system +performs this task, it also has to account for the way *references* are used +throughout your code, and how they relate to linear values. In order to track +this, the memory management system uses *lifetimes* which determine whether or +not a reference is valid in a given form. + +The following function provides an example of this reference validity tracking +in action: + +```clojure +(defn invalid-ref [] + &[1 2 3]) +``` + +In the prior example, our `invalid-ref` function returns a reference to the +literal linear array value `[1 2 3]`. This code is problematic because the +linear array value will be deleted at the end of the function, so the returned +reference will point to nothing! The memory management system catches this for +us and let's us know about the problem. + +Contrarily, the following code is perfectly fine: + +```clojure +(def an-array [1 2 3]) + +(defn valid-ref [] + &an-array) +``` + +The `valid-ref` function also returns a reference, but this reference is valid +since it points to a linear array value (`an-array`) that won't be deleted (it +will still be "alive") by the time the function returns the reference. + +The system will also catch cases when we attempt to reference a linear value +that's already been *moved* into a different location/binding: + +```clojure +(defn unowned-ref [] + (let [a [1 2 3] + b a + c &a] + ())) +``` + +In this example, we move the linear array from `a` into `b`, but then try to set +`c` to a reference to `a`, which, after the move, no longer points to anything. + +Internally, the memory management system uses *lifetimes* to model the +relationships between references and linear values and track the validity of +reference across your code. + +#### Lifetimes in Detail + +Carp's lifetimes are made up of two pieces of information. Only references have +lifetimes, and every reference has *exactly one* lifetime assigned to it: + +- A unique type variable that identifies the lifetime. +- A lifetime mode, that indicates if the linear value tied to the reference has + a lexical scope that extends beyond the reference's lexical scope or if it's + limited to the reference's lexical scope. + +In general, a reference is valid only when the value it points to has either an +equivalent or greater lexical scope. This property is encoded in its lifetime. + +Let's look at some examples to help illustrate this: + +```clojure +(def an-array [1 2 3]) + +(defn valid-ref [] + (let [array-ref &an-arry]) ()) +``` + +In this example, the anonymous reference `&an-array` has a unique lifetime that +*extends beyond the lexical scope* of the reference itself. The lexical scope of +the reference value `[1 2 3]` is greater than or equal to the lexical scope of +the reference, which only extends across the let form, so, this reference is +valid. + +Contrarily, the following reference is not valid: + +```clojure +(defn invalid-ref [] + &[1 2 3]) +``` + +Here, the reference has a greater lexical scope than the linear value it points +to. The anonymous linear value `[1 2 3]` will be deleted at the end of the +function scope, but the reference will be returned from the function, so its +lifetime is potentially greater than that of the value it points to. + +The memory management system performs two key checks around ref usage: + +1. Check that a newly created reference doesn't point to a linear value binding + that has already transferred away ownership. +2. Check that a reference is alive at a certain point in the program. + +Both of these are implemented as separate checks, but they may be viewed as +specializations of a general operation that checks if every reference form in +your program is "alive" at the point of use. + +Currently, liveness analysis revolves around checking if the value the reference +points to belongs to the same lexical scope as the reference, and, if so, that +the value has a deleter in that scope, which indicates the scope properly owns +the value. If no such deleter exists, it means the reference outlives the value +it points to, and is invalid. + +### Type Dependencies + +The final key piece of information the memory system manages are the *type +dependencies* of the deletion functions for linear values. + +Since Carp supports generic programming and polymorphic functions, it's possible +that some deleter is needed in a polymorphic context. In particular, generic +functions that "take ownership" of generic values need to be able to find the +correct deletion routines for the value. For example, in the generic function: + +```clojure +(sig my-generic-force-delete (Fn [a] Unit)) + +(defn my-generic-force-delete [a] + ()) +``` + +This `my-generic-force-delete` function takes ownership of whatever argument it +receives and does nothing. Since it takes ownership, however, the value passed +to `a`, if it's linear, needs to be deleted at the end of the function scope. + +Since the function is generic, the memory management system can't know for +certain what value is being passed. In some cases it might be a linear value, in +some cases it might not be. Sometimes it might be a `String`, sometimes an +`Int`, or sometimes an `Array`. Each of these types has a different `delete` +implementation. + +Rather than having the memory management system figure out what function to use, +the system instead just keeps track of the types of all the values for the forms +it analyzes. Later, the component already dedicated to resolving generic +functions handles finding the right deletion routine for the values passed to +the generic function. In order to accomplish this, it uses the type information +captured by the memory system as it analyzes each form. + +### Memory State + +As we've explored, the memory management system needs to keep track of three key +pieces of information as it analyzes the forms in your program: + +1. The deleters assigned to each AST node to track ownership of linear values + and delete them at the right time. +2. The Lifetimes assigned to each reference to check reference validity. +3. The types of each form it analyzes to resolve generic deletion functions. + +Each of these units of information is bundled into a single data structure, +called the *memory state* or `MemState` of your program. + +As the memory management system analyzes each of the AST nodes in your program +source, it updates the memory state accordingly. Deleters are added and removed +from the state at different points as ownership transfers of linear values +occur. When the system finishes analyzing a node, it update's the node's `Info` +object, attaching the deleters associated with the current memory state. At any +point, if the memory management system encounters a problem with the way memory +is being transferred across your program's AST nodes, it reports an error. A simple piece of code: From 7ab466edebd5fd5f3958330ac353477937a11c85 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Tue, 31 Jan 2023 20:46:11 +0100 Subject: [PATCH 54/59] docs: add clarification to SDL comment (#1454) --- core/SDL.carp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/SDL.carp b/core/SDL.carp index c3e202ba9..cca3bb891 100644 --- a/core/SDL.carp +++ b/core/SDL.carp @@ -7,6 +7,8 @@ ;; Only define these if they're not already defined (allows the user to pre-define them before including SDL.carp) ;; Tip: Set them in your profile.carp which is located at ```C:/Users/USERNAME/AppData/Roaming/carp/profile.carp``` on Windows. +;; If you do, please use `defdynamic`, since `defdynamic-once` will not be +;; defined when your profile is loaded. (defdynamic-once sdl-windows-header-path "C:\\REDACTED\vcpkg\installed\x86-windows\include\SDL2\\") (defdynamic-once sdl-windows-library-path "C:\\REDACTED\vcpkg\installed\x86-windows\lib\\") From ca5774b1aeeab2bc4d6fa901b5a55682ebc2d539 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Tue, 31 Jan 2023 20:47:15 +0100 Subject: [PATCH 55/59] chore: remove usage of sprintf (#1453) --- core/carp_pattern.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/carp_pattern.h b/core/carp_pattern.h index e86e8d0f6..c855320df 100644 --- a/core/carp_pattern.h +++ b/core/carp_pattern.h @@ -568,13 +568,13 @@ Array Pattern_match_MINUS_all_MINUS_groups(Pattern *p, String *s) { String Pattern_internal_add_char(String a, Char b) { if (!a) { String buffer = CARP_MALLOC(2); - sprintf(buffer, "%c", b); + snprintf(buffer, 1, "%c", b); return buffer; } int len = strlen(a) + 2; String buffer = CARP_MALLOC(len); - sprintf(buffer, "%s%c", a, b); + snprintf(buffer, len-1, "%s%c", a, b); CARP_FREE(a); return buffer; } @@ -645,7 +645,7 @@ String Pattern_substitute(Pattern *p, String *s, String *t, int ns) { int l = strlen(res) + strlen(str) + 1; String buffer = CARP_MALLOC(l); - sprintf(buffer, "%s%s", res, str); + snprintf(buffer, l-1, "%s%s", res, str); CARP_FREE(res); return buffer; } @@ -671,7 +671,7 @@ String Pattern_str(Pattern *p) { String Pattern_prn(Pattern *p) { int n = strlen(*p) + 4; String buffer = CARP_MALLOC(n); - sprintf(buffer, "#\"%s\"", *p); + snprintf(buffer, n-1, "#\"%s\"", *p); return buffer; } From ed2a4108c43280186005ef5a31a1f24986f87bbe Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Tue, 28 Feb 2023 09:34:12 +0100 Subject: [PATCH 56/59] fix: mangle member name in deletion generator (#1458) --- src/Concretize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index b3127203d..426641665 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -921,7 +921,7 @@ concreteDeleteTakePtr typeEnv env members = memberDeletionGeneral :: String -> TypeEnv -> Env -> (String, Ty) -> String memberDeletionGeneral separator typeEnv env (memberName, memberType) = case findFunctionForMember typeEnv env "delete" (typesDeleterFunctionType memberType) (memberName, memberType) of - FunctionFound functionFullName -> " " ++ functionFullName ++ "(p" ++ separator ++ memberName ++ ");" + FunctionFound functionFullName -> " " ++ functionFullName ++ "(p" ++ separator ++ mangle memberName ++ ");" FunctionNotFound msg -> error msg FunctionIgnored -> " /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */" From 18f497a91bac76b3e501fc44eb427e29aa8c4f37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Tue, 26 Nov 2024 11:34:51 +0100 Subject: [PATCH 57/59] Update README.md --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 272cb63c3..476092c58 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,8 @@ Logo +We now have an official Discord server (![invite](https://discord.gg/yyjnBcMqYM)) &endash; future discussions about the language will most likely happen there, come join! + [![Linux CI](https://github.com/carp-lang/Carp/workflows/Linux%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A%22Linux+CI%22) [![MacOS CI](https://github.com/carp-lang/Carp/workflows/MacOS%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A"MacOS+CI") [![Windows CI](https://github.com/carp-lang/Carp/workflows/Windows%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A"Windows+CI") From c04374a366d0dea7193a8e327ab73ed4cdcdd698 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Tue, 26 Nov 2024 11:58:29 +0100 Subject: [PATCH 58/59] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 476092c58..d6740c33d 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Logo -We now have an official Discord server (![invite](https://discord.gg/yyjnBcMqYM)) &endash; future discussions about the language will most likely happen there, come join! +We now have an official Discord server (![invite](https://discord.gg/yyjnBcMqYM)) - future discussions about the language will most likely happen there, come join! [![Linux CI](https://github.com/carp-lang/Carp/workflows/Linux%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A%22Linux+CI%22) [![MacOS CI](https://github.com/carp-lang/Carp/workflows/MacOS%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A"MacOS+CI") From 3471bd3291c007b0c87e03bda05ed29528ce6034 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Tue, 26 Nov 2024 11:58:51 +0100 Subject: [PATCH 59/59] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index d6740c33d..035ce48eb 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ Logo -We now have an official Discord server (![invite](https://discord.gg/yyjnBcMqYM)) - future discussions about the language will most likely happen there, come join! +We now have an official Discord server ([invite](https://discord.gg/yyjnBcMqYM)) - future discussions about the language will most likely happen there, come join! [![Linux CI](https://github.com/carp-lang/Carp/workflows/Linux%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A%22Linux+CI%22) [![MacOS CI](https://github.com/carp-lang/Carp/workflows/MacOS%20CI/badge.svg)](https://github.com/carp-lang/Carp/actions?query=workflow%3A"MacOS+CI")