diff --git a/src/stdlib/mexpr/generate-eq.mc b/src/stdlib/mexpr/generate-eq.mc new file mode 100644 index 000000000..81d891b8e --- /dev/null +++ b/src/stdlib/mexpr/generate-eq.mc @@ -0,0 +1,199 @@ +-- Generate code required to compare two arbitrary (monomorphic, +-- non-function) values based on their structure + +include "ast.mc" +include "type-check.mc" + +include "mlang/loader.mc" + +lang GenerateEq = Ast + type GEqEnv = + { conFunctions : Map Name Name -- For TyCons + , varFunctions : Map Name Name -- For TyVars + , newFunctions : [(Name, Expr)] -- To be defined + + , tcEnv : TCEnv -- Current typechecking environment + + , eqSeq : Name + , eqBool : Name + } + + sem getEqFunction : GEqEnv -> Type -> (GEqEnv, Expr) + sem getEqFunction env = | ty -> _getEqFunction env (unwrapType ty) + + sem _getEqFunction : GEqEnv -> Type -> (GEqEnv, Expr) +end + +lang GenerateEqInt = GenerateEq + IntTypeAst + CmpIntAst + sem _getEqFunction env = + | TyInt _ -> (env, uconst_ (CEqi ())) +end + +lang GenerateEqFloat = GenerateEq + FloatTypeAst + CmpFloatAst + sem _getEqFunction env = + | TyFloat _ -> (env, uconst_ (CEqf ())) +end + +lang GenerateEqBool = GenerateEq + BoolTypeAst + sem _getEqFunction env = + | TyBool _ -> (env, nvar_ env.eqBool) +end + +lang GenerateEqSeq = GenerateEq + SeqTypeAst + sem _getEqFunction env = + | TySeq x -> + match getEqFunction env x.ty with (env, elemF) in + (env, app_ (nvar_ env.eqSeq) elemF) +end + +lang GenerateEqChar = GenerateEq + CharTypeAst + CmpCharAst + sem _getEqFunction env = + | TyChar _ -> + (env, uconst_ (CEqc ())) +end + +lang GenerateEqRecord = GenerateEq + RecordTypeAst + sem _getEqFunction env = + | ty & TyRecord x -> + if mapIsEmpty x.fields then (env, ulam_ "" (ulam_ "" true_)) else + + let lName = nameSym "l" in + let l = withType ty (nvar_ lName) in + let rName = nameSym "r" in + let r = withType ty (nvar_ rName) in + + let genRecElem = lam acc. lam label. lam ty. snoc acc (lam env. + match getEqFunction env ty with (env, eqF) in + let label = sidToString label in + (env, appf2_ eqF (recordproj_ label l) (recordproj_ label r))) in + let elems = mapFoldWithKey genRecElem [] x.fields in + match mapAccumL (lam env. lam f. f env) env elems with (env, [first] ++ elems) in + + let f = lam acc. lam elem. if_ elem acc false_ in + (env, nulam_ lName (nulam_ rName (foldl f first elems))) +end + +lang GenerateEqApp = GenerateEq + AppTypeAst + sem _getEqFunction env = + | TyApp x -> + match getEqFunction env x.lhs with (env, lhs) in + match getEqFunction env x.rhs with (env, rhs) in + (env, app_ lhs rhs) +end + +lang GenerateEqCon = GenerateEq + ConTypeAst + sem _getEqFunction env = + | TyCon x -> + -- TODO(vipa, 2025-01-27): Invalidate old eq functions if + -- we've introduced constructors to pre-existing types + match mapLookup x.ident env.conFunctions with Some n then (env, nvar_ n) else + + let fname = nameSym (concat "eq" (nameGetStr x.ident)) in + let env = {env with conFunctions = mapInsert x.ident fname env.conFunctions} in + + -- TODO(vipa, 2025-01-27): We cannot see locally defined types + -- here, which might be an issue + let params = match mapLookup x.ident env.tcEnv.tyConEnv with Some (_, params, _) + then params + else errorSingle [x.info] (concat "Typecheck environment does not contain information about type " (nameGetStr x.ident)) in + let paramFNames = foldl (lam acc. lam n. mapInsert n (nameSetNewSym n) acc) (mapEmpty nameCmp) params in + let prevVarFunctions = env.varFunctions in + let env = {env with varFunctions = mapUnion env.varFunctions paramFNames} in + + let constructors = mapIntersectWith + (lam. lam pair. pair.1) + (mapLookupOr (setEmpty nameCmp) x.ident env.tcEnv.conDeps) + env.tcEnv.conEnv in + + let lName = nameSym "l" in + let rName = nameSym "r" in + let addMatch = lam acc. lam c. lam t. + match acc with (env, tm) in + match getEqFunction env t with (env, subf) in + let subl = nameSym "subl" in + let subr = nameSym "subr" in + let tm = match_ (nvar_ lName) (npcon_ c (npvar_ subl)) + (match_ (nvar_ rName) (npcon_ c (npvar_ subr)) + (appf2_ subf (nvar_ subl) (nvar_ subr)) + false_) + tm in + (env, tm) in + match mapFoldWithKey addMatch (env, never_) constructors with (env, matchChain) in + let matchChain = nulam_ lName (nulam_ rName matchChain) in + let body = foldr (lam pname. lam body. nulam_ (mapFindExn pname paramFNames) body) matchChain params in + + let env = {env with varFunctions = prevVarFunctions, newFunctions = snoc env.newFunctions (fname, body)} in + (env, nvar_ fname) +end + +lang GenerateEqVar = GenerateEq + VarTypeAst + -- NOTE(vipa, 2025-01-27): This function will error when it + -- encounters a polymorphic value of unknown type. We could + -- arbitrarily say "equal" or "not equal", but that seems error + -- prone, or we could somehow ask surrounding code to be rewritten + -- to carry an extra eq function for the polymorphic type. + sem _getEqFunction env = + | TyVar x -> + match mapLookup x.ident env.varFunctions with Some fname + then (env, nvar_ fname) + else errorSingle [x.info] (join ["I don't know how to compare values of the polymorphic type ", nameGetStr x.ident]) +end + +lang MExprGenerateEq + = GenerateEqRecord + + GenerateEqBool + + GenerateEqInt + + GenerateEqFloat + + GenerateEqSeq + + GenerateEqChar + + GenerateEqApp + + GenerateEqCon + + GenerateEqVar +end + +lang GenerateEqLoader = MCoreLoader + GenerateEq + syn Hook = + | EqHook + { baseEnv : GEqEnv + , functions : Ref (Map Name Name) -- Names for TyCon related Eq functions + } + + sem enableEqGeneration : Loader -> Loader + sem enableEqGeneration = | loader -> + if hasHook (lam x. match x with EqHook _ then true else false) loader then loader else + + match includeFileExn "." "stdlib::seq.mc" loader with (seqEnv, loader) in + match includeFileExn "." "stdlib::bool.mc" loader with (boolEnv, loader) in + + let baseEnv = + { conFunctions = mapEmpty nameCmp + , varFunctions = mapEmpty nameCmp + , newFunctions = [] + , tcEnv = typcheckEnvEmpty + , eqSeq = _getVarExn "eqSeq" seqEnv + , eqBool = _getVarExn "eqBool" boolEnv + } in + + let hook = EqHook + { baseEnv = baseEnv + , functions = ref (mapEmpty nameCmp) + } in + addHook loader hook + + sem _eqFunctionsFor : [Type] -> Loader -> Hook -> Option (Loader, [Expr]) + sem _eqFunctionsFor tys loader = + | _ -> None () + | EqHook hook -> + match mapAccumL getEqFunction {hook.baseEnv with conFunctions = deref hook.functions, tcEnv = _getTCEnv loader} tys + with (env, printFs) in + + modref hook.functions env.conFunctions; + let loader = if null env.newFunctions + then loader + else _addDeclExn loader (decl_nureclets_ env.newFunctions) in + Some (loader, printFs) + + sem eqFunctionsFor : [Type] -> Loader -> (Loader, [Expr]) + sem eqFunctionsFor tys = | loader -> + withHookState (_eqFunctionsFor tys) loader +end diff --git a/src/stdlib/mexpr/generate-json-serializers.mc b/src/stdlib/mexpr/generate-json-serializers.mc index 5f5d55a47..8bdc8abc1 100644 --- a/src/stdlib/mexpr/generate-json-serializers.mc +++ b/src/stdlib/mexpr/generate-json-serializers.mc @@ -9,6 +9,7 @@ include "symbolize.mc" include "type.mc" include "utils.mc" include "duplicate-code-elimination.mc" +include "mlang/loader.mc" include "json.mc" include "stdlib.mc" @@ -40,8 +41,8 @@ lang GenerateJsonSerializers = type GJSEnv = { -- Information from the given program - namedTypes: Map Name Expr, -- Expr only TmTypes - constructors: Map Name [Expr], -- [Expr] only TmConDefs + namedTypes: Map Name {params : [Name], tyIdent : Type}, + constructors: Map Name [{ident : Name, tyIdent : Type}], -- Required libraries for the generation lib: Expr, @@ -55,7 +56,6 @@ lang GenerateJsonSerializers = sString: Name, dString: Name, sSeq: Name, dSeq: Name, sTensor: Name, dTensorInt: Name, dTensorFloat: Name, dTensorDense: Name, jsonObject: Name, jsonString: Name, - jsonParse: Name, jsonParseExn: Name, json2string: Name, mapInsert: Name, mapEmpty: Name, mapLookup: Name, cmpString: Name, some: Name, none: Name @@ -101,7 +101,6 @@ lang GenerateJsonSerializers = "jsonDeserializeTensorCArrayInt","jsonDeserializeTensorCArrayFloat", "jsonDeserializeTensorDense", "JsonObject", "JsonString", - "jsonParse", "jsonParseExn", "json2string", "mapInsert", "mapEmpty", "mapLookup", "cmpString", "Some", "None" @@ -114,7 +113,6 @@ lang GenerateJsonSerializers = ssq, dsq, st, dti, dtf, dtd, jo, js, - jp,jpe,j2s, mi,me,ml, cs, s,n @@ -128,7 +126,6 @@ lang GenerateJsonSerializers = sString = ss, dString = ds, sSeq = ssq, dSeq = dsq, sTensor = st, dTensorInt = dti, dTensorFloat = dtf, dTensorDense = dtd, jsonObject = jo, jsonString = js, - jsonParse = jp, jsonParseExn = jpe, json2string = j2s, mapInsert = mi, mapEmpty = me, mapLookup = ml, cmpString = cs, some = s, none = n @@ -146,15 +143,10 @@ lang GenerateJsonSerializers = sem _addType: GJSEnv -> Expr -> GJSEnv sem _addType env = | TmType r & t -> - { env with namedTypes = mapInsert r.ident t env.namedTypes } + { env with namedTypes = mapInsert r.ident {params = r.params, tyIdent = r.tyIdent} env.namedTypes } | TmConDef r & t -> match getConDefType r.tyIdent with TyCon c then - let ident = c.ident in - let condefs = - match mapLookup ident env.constructors with Some condefs then condefs - else [] - in - { env with constructors = mapInsert ident (cons t condefs) env.constructors } + { env with constructors = mapInsertWith concat c.ident [{ident = r.ident, tyIdent = r.tyIdent}] env.constructors } else error "Not a TyCon at RHS of TmConDef type" | _ -> env @@ -253,7 +245,7 @@ lang GenerateJsonSerializers = (acc, { serializer = nvar_ s.serializerName, deserializer = nvar_ s.deserializerName }) else - match mapLookup t.ident env.namedTypes with Some TmType tt then + match mapLookup t.ident env.namedTypes with Some tt then -- Variant type case match tt.tyIdent with TyVariant _ then @@ -271,8 +263,6 @@ lang GenerateJsonSerializers = } acc in match mapAccumL (lam acc. lam tcd. - let tcd = match tcd with TmConDef tcd then tcd - else error "Impossible" in match stripTyAll tcd.tyIdent with (tyalls,tyIdent) in let varEnv = foldl2 (lam varEnv. lam ta. lam ps. match ta with (n,_) in @@ -393,6 +383,101 @@ lang GenerateJsonSerializers = end +lang JsonSerializationLoader = MCoreLoader + GenerateJsonSerializers + syn Hook = + | JsonSerializationHook + { gjsAcc : Ref (Map Name GJSNamedSerializer) -- No implementations, only names (implementations have already been inserted in the program) + , baseEnv : GJSEnv -- Only the library names matter, everything else is populated later + } + + -- Makes the given loader capable of generating json serializers and + -- deserializers upon request + sem enableJsonSerialization : Loader -> Loader + sem enableJsonSerialization = | loader -> + if hasHook (lam x. match x with JsonSerializationHook _ then true else false) loader then loader else + + match includeFileExn "." "stdlib::json.mc" loader with (jsonEnv, loader) in + match includeFileExn "." "stdlib::map.mc" loader with (mapEnv, loader) in + match includeFileExn "." "stdlib::string.mc" loader with (stringEnv, loader) in + match includeFileExn "." "stdlib::basic-types.mc" loader with (optionEnv, loader) in + + let baseEnv = + let v = lam env. lam str. _getVarExn str env in + let c = lam env. lam str. _getConExn str env in + { namedTypes = mapEmpty nameCmp + , constructors = mapEmpty nameCmp + , lib = unit_ + , varEnv = mapEmpty nameCmp + + , sBool = v jsonEnv "jsonSerializeBool", dBool = v jsonEnv "jsonDeserializeBool" + , sInt = v jsonEnv "jsonSerializeInt", dInt = v jsonEnv "jsonDeserializeInt" + , sFloat = v jsonEnv "jsonSerializeFloat", dFloat = v jsonEnv "jsonDeserializeFloat" + , sChar = v jsonEnv "jsonSerializeChar", dChar = v jsonEnv "jsonDeserializeChar" + + , sString = v jsonEnv "jsonSerializeString", dString = v jsonEnv "jsonDeserializeString" + , sSeq = v jsonEnv "jsonSerializeSeq", dSeq = v jsonEnv "jsonDeserializeSeq" + + , sTensor = v jsonEnv "jsonSerializeTensor" + , dTensorInt = v jsonEnv "jsonDeserializeTensorCArrayInt" + , dTensorFloat = v jsonEnv "jsonDeserializeTensorCArrayFloat" + , dTensorDense = v jsonEnv "jsonDeserializeTensorDense" + + , jsonObject = c jsonEnv "JsonObject" + , jsonString = c jsonEnv "JsonString" + + , mapInsert = v mapEnv "mapInsert" + , mapEmpty = v mapEnv "mapEmpty" + , mapLookup = v mapEnv "mapLookup" + + , cmpString = v stringEnv "cmpString" + + , some = c optionEnv "Some", none = c optionEnv "None" + } in + + let hook = JsonSerializationHook + { baseEnv = baseEnv + , gjsAcc = ref (mapEmpty nameCmp) + } in + addHook loader hook + + sem _serializationPairsFor : [Type] -> Loader -> Hook -> Option (Loader, [GJSSerializer]) + sem _serializationPairsFor tys loader = + | _ -> None () + | JsonSerializationHook hook -> + let tcEnv = _getTCEnv loader in + -- OPT(vipa, 2024-12-13): This reconstruction for each request is + -- potentially a bit expensive + let namedTypes = mapMap (lam x. {params = x.1, tyIdent = x.2}) tcEnv.tyConEnv in + let constructors = mapMap + (lam cs. mapValues + (mapIntersectWithKey (lam c. lam. lam x. {ident = c, tyIdent = x.1}) cs tcEnv.conEnv)) + tcEnv.conDeps in + let env = {hook.baseEnv with namedTypes = namedTypes, constructors = constructors} in + match mapAccumL (_generateType env) (deref hook.gjsAcc) tys with (gjsAcc, tys) in + + let f = lam bindings. lam. lam namedSer. + match namedSer with {serializer = Some serializer, deserializer = Some deserializer} then + let eta = lam tm. match tm with TmLam _ + then tm + else let n = nameSym "x" in nulam_ n (app_ tm (nvar_ n)) in + ( concat bindings + [ (namedSer.serializerName, eta serializer) + , (namedSer.deserializerName, eta deserializer) + ] + , {namedSer with serializer = None (), deserializer = None ()} + ) + else (bindings, namedSer) in + match mapMapAccum f [] gjsAcc with (bindings, gjsAcc) in + modref hook.gjsAcc gjsAcc; + if null bindings then Some (loader, tys) else + let decl = decl_nureclets_ bindings in + Some (_addSymbolizedDeclExn loader decl, tys) + + sem serializationPairsFor : [Type] -> Loader -> (Loader, [GJSSerializer]) + sem serializationPairsFor tys = | loader -> + withHookState (_serializationPairsFor tys) loader +end + lang Test = GenerateJsonSerializers + MExprPrettyPrint + MExprEq end mexpr @@ -582,8 +667,8 @@ utest test false [tycon_ "Either", tycon_ "MyType"] " type Either a b in - con Left: all a. all b. a -> Either a b in con Right: all a. all b. b -> Either a b in + con Left: all a. all b. a -> Either a b in type MyType = Either Int Bool in () " @@ -628,8 +713,8 @@ utest test false [tycon_ "List"] " type List a in - con Node: all a. List a -> List a in con Leaf: all a. () -> List a in + con Node: all a. List a -> List a in () " [("List", "serializeList", " @@ -719,4 +804,3 @@ with true in -- printLn res2; () - diff --git a/src/stdlib/mexpr/generate-pprint.mc b/src/stdlib/mexpr/generate-pprint.mc new file mode 100644 index 000000000..0dfb80a41 --- /dev/null +++ b/src/stdlib/mexpr/generate-pprint.mc @@ -0,0 +1,233 @@ +-- Generate code required to print an arbitrary (monomorphic, +-- non-function) value based on its structure + +include "ast.mc" +include "pprint.mc" +include "type-check.mc" + +include "mlang/loader.mc" + +lang GeneratePprint = Ast + PrettyPrint + type GPprintEnv = + { conFunctions : Map Name Name -- For TyCons + , varFunctions : Map Name Name -- For TyVars + , newFunctions : [(Name, Expr)] -- To be defined + + , tcEnv : TCEnv -- Current typechecking environment + + , int2string : Name + , bool2string : Name + , seq2string : Name + , escapeString : Name + , escapeChar : Name + } + + sem getPprintFunction : GPprintEnv -> Type -> (GPprintEnv, Expr) + sem getPprintFunction env = | ty -> _getPprintFunction env (unwrapType ty) + + sem _getPprintFunction : GPprintEnv -> Type -> (GPprintEnv, Expr) + sem _getPprintFunction env = | ty -> + errorSingle [infoTy ty] (concat "Missing case for _getPprintFunction " (type2str ty)) +end + +lang GeneratePprintInt = GeneratePprint + IntTypeAst + sem _getPprintFunction env = + | TyInt _ -> (env, nvar_ env.int2string) +end + +lang GeneratePprintFloat = GeneratePprint + FloatTypeAst + FloatStringConversionAst + sem _getPprintFunction env = + | TyFloat _ -> (env, uconst_ (CFloat2string ())) +end + +lang GeneratePprintBool = GeneratePprint + BoolTypeAst + sem _getPprintFunction env = + | TyBool _ -> (env, nvar_ env.bool2string) +end + +lang GeneratePprintSeq = GeneratePprint + SeqTypeAst + sem _getPprintFunction env = + | TySeq x -> + match getPprintFunction env x.ty with (env, elemF) in + (env, app_ (nvar_ env.seq2string) elemF) +end + +lang GeneratePprintString = GeneratePprint + SeqTypeAst + CharTypeAst + sem _getPprintFunction env = + | TySeq {ty = TyChar _} -> + let n = nameSym "x" in + (env, nulam_ n (cons_ (char_ '"') (snoc_ (app_ (nvar_ env.escapeString) (nvar_ n)) (char_ '"')))) +end + +lang GeneratePprintChar = GeneratePprint + CharTypeAst + sem _getPprintFunction env = + | TyChar _ -> + let n = nameSym "c" in + (env, nulam_ n (seq_ [char_ '\'', app_ (nvar_ env.escapeChar) (nvar_ n), char_ '\''])) +end + +lang GeneratePprintRecord = GeneratePprint + RecordTypeAst + MExprIdentifierPrettyPrint + sem _getPprintFunction env = + | ty & TyRecord x -> + if mapIsEmpty x.fields then (env, ulam_ "" (str_ "()")) else + + let recName = nameSym "r" in + let rec = withType ty (nvar_ recName) in + + let genTupElem = lam i. lam ty. lam env. + match getPprintFunction env ty with (env, printF) in + (env, app_ printF (tupleproj_ i rec)) in + let genRecElem = lam acc. lam label. lam ty. snoc acc (lam env. + match getPprintFunction env ty with (env, printF) in + let prefix = concat (pprintLabelString label) " = " in + let label = sidToString label in + (env, concat_ (str_ prefix) (app_ printF (recordproj_ label rec)))) in + match + match record2tuple x.fields with Some tys + then (true, mapi genTupElem tys) + else (false, mapFoldWithKey genRecElem [] x.fields) + with (isTuple, elems) in + match mapAccumL (lam env. lam f. f env) env elems with (env, rest ++ [last]) in + + let withComma = lam here. lam rest. + concat_ here (concat_ (str_ ", ") rest) in + let body = snoc_ + (cons_ + (char_ (if isTuple then '(' else '{')) + (foldr withComma last rest)) + (char_ (if isTuple then ')' else '}')) in + (env, nulam_ recName body) +end + +lang GeneratePprintApp = GeneratePprint + AppTypeAst + sem _getPprintFunction env = + | TyApp x -> + match getPprintFunction env x.lhs with (env, lhs) in + match getPprintFunction env x.rhs with (env, rhs) in + (env, app_ lhs rhs) +end + +lang GeneratePprintCon = GeneratePprint + ConTypeAst + sem _getPprintFunction env = + | TyCon x -> + -- TODO(vipa, 2025-01-27): Invalidate old pprint functions if + -- we've introduced constructors to pre-existing types + match mapLookup x.ident env.conFunctions with Some n then (env, nvar_ n) else + + let fname = nameSym (concat "pprint" (nameGetStr x.ident)) in + let env = {env with conFunctions = mapInsert x.ident fname env.conFunctions} in + + -- TODO(vipa, 2025-01-27): We cannot see locally defined types + -- here, which might be an issue + let params = match mapLookup x.ident env.tcEnv.tyConEnv with Some (_, params, _) + then params + else errorSingle [x.info] (concat "Typecheck environment does not contain information about type " (nameGetStr x.ident)) in + let paramFNames = foldl (lam acc. lam n. mapInsert n (nameSetNewSym n) acc) (mapEmpty nameCmp) params in + let prevVarFunctions = env.varFunctions in + let env = {env with varFunctions = mapUnion env.varFunctions paramFNames} in + + let constructors = mapIntersectWith + (lam. lam pair. pair.1) + (mapLookupOr (setEmpty nameCmp) x.ident env.tcEnv.conDeps) + env.tcEnv.conEnv in + + let targetName = nameSym "_target" in + let addMatch = lam acc. lam c. lam t. + match acc with (env, tm) in + match getPprintFunction env t with (env, subf) in + let sub = nameSym "x" in + let tm = match_ (nvar_ targetName) (npcon_ c (npvar_ sub)) + (cons_ (char_ '(') (snoc_ (concat_ (str_ (pprintConString (nameGetStr c))) (cons_ (char_ ' ') (app_ subf (nvar_ sub)))) (char_ ')'))) + tm in + (env, tm) in + match mapFoldWithKey addMatch (env, never_) constructors with (env, matchChain) in + let matchChain = nulam_ targetName matchChain in + let body = foldr (lam pname. lam body. nulam_ (mapFindExn pname paramFNames) body) matchChain params in + + let env = {env with varFunctions = prevVarFunctions, newFunctions = snoc env.newFunctions (fname, body)} in + (env, nvar_ fname) +end + +lang GeneratePprintVar = GeneratePprint + VarTypeAst + -- NOTE(vipa, 2025-01-27): This function will print a constant + -- `` when it encounters a polymorphic + -- value of unknown type. We could error instead, or somehow ask + -- surrounding code to be rewritten to carry an extra pprint + -- function for the polymorphic type. + sem _getPprintFunction env = + | TyVar x -> + match mapLookup x.ident env.varFunctions with Some fname + then (env, nvar_ fname) + else (env, ulam_ "" (str_ (join [""]))) +end + +lang GeneratePprintTensor = GeneratePprint + TensorTypeAst + sem _getPprintFunction env = + | TyTensor x -> + (env, ulam_ "" (str_ "")) +end + +lang MExprGeneratePprint + = GeneratePprintRecord + + GeneratePprintBool + + GeneratePprintInt + + GeneratePprintFloat + + GeneratePprintSeq + + GeneratePprintString + + GeneratePprintChar + + GeneratePprintApp + + GeneratePprintCon + + GeneratePprintVar + + GeneratePprintTensor +end + +lang GeneratePprintLoader = MCoreLoader + GeneratePprint + syn Hook = + | PprintHook + { baseEnv : GPprintEnv + , functions : Ref (Map Name Name) -- Names for TyCon related pprint functions + } + + sem enablePprintGeneration : Loader -> Loader + sem enablePprintGeneration = | loader -> + if hasHook (lam x. match x with PprintHook _ then true else false) loader then loader else + + match includeFileExn "." "stdlib::string.mc" loader with (stringEnv, loader) in + match includeFileExn "." "stdlib::bool.mc" loader with (boolEnv, loader) in + match includeFileExn "." "stdlib::char.mc" loader with (charEnv, loader) in + + let baseEnv = + { conFunctions = mapEmpty nameCmp + , varFunctions = mapEmpty nameCmp + , newFunctions = [] + , tcEnv = typcheckEnvEmpty + , int2string = _getVarExn "int2string" stringEnv + , bool2string = _getVarExn "bool2string" boolEnv + , seq2string = _getVarExn "seq2string" stringEnv + , escapeString = _getVarExn "escapeString" stringEnv + , escapeChar = _getVarExn "escapeChar" charEnv + } in + + let hook = PprintHook + { baseEnv = baseEnv + , functions = ref (mapEmpty nameCmp) + } in + addHook loader hook + + sem _pprintFunctionsFor : [Type] -> Loader -> Hook -> Option (Loader, [Expr]) + sem _pprintFunctionsFor tys loader = + | _ -> None () + | PprintHook hook -> + match mapAccumL getPprintFunction {hook.baseEnv with conFunctions = deref hook.functions, tcEnv = _getTCEnv loader} tys + with (env, printFs) in + + modref hook.functions env.conFunctions; + let loader = if null env.newFunctions + then loader + else _addDeclExn loader (decl_nureclets_ env.newFunctions) in + Some (loader, printFs) + + sem pprintFunctionsFor : [Type] -> Loader -> (Loader, [Expr]) + sem pprintFunctionsFor tys = | loader -> + withHookState (_pprintFunctionsFor tys) loader +end diff --git a/src/stdlib/mexpr/generate-utest.mc b/src/stdlib/mexpr/generate-utest.mc new file mode 100644 index 000000000..a97ead0a5 --- /dev/null +++ b/src/stdlib/mexpr/generate-utest.mc @@ -0,0 +1,127 @@ +include "generate-pprint.mc" +include "generate-eq.mc" + +include "mlang/loader.mc" + +lang StripUtestLoader = MCoreLoader + UtestAst + syn Hook = + | StripUtestHook () + + sem stripUtests : Expr -> Expr + sem stripUtests = + | TmUtest t -> stripUtests t.next + | t -> smap_Expr_Expr stripUtests t + + sem _postTypecheck loader decl = | StripUtestHook _ -> + let decl = match decl with DeclUtest x + then DeclLet + { ident = nameNoSym "" + , tyAnnot = tyunknown_ + , tyBody = tyunit_ + , body = unit_ + , info = x.info + } + else smap_Decl_Expr stripUtests decl + in (loader, decl) +end + +lang UtestLoader = MCoreLoader + GenerateEqLoader + GeneratePprintLoader + StripUtestLoader + syn Hook = + | UtestHook + { defaultOnFail : Name + , runner : Name + , exitOnFailure : Name + } + + -- Enable code generation replacing `utest` with equivalent + -- code. Will remove `StripUtestHook` if present. + sem enableUtestGeneration : Loader -> Loader + sem enableUtestGeneration = | loader -> + if hasHook (lam x. match x with UtestHook _ then true else false) loader then loader else + + -- NOTE(vipa, 2025-01-27): We strip utests found in files before + -- we're ready. Notably, this means that we can never utest things + -- that eq-generation, pprint-generation, or the utest-runtime + -- depend on. + let loader = addHook loader (StripUtestHook ()) in + let loader = enableEqGeneration loader in + let loader = enablePprintGeneration loader in + match includeFileExn "." "stdlib::mexpr/utest-runtime.mc" loader with (utestEnv, loader) in + + let hook = + { defaultOnFail = _getVarExn "utestDefaultOnFail" utestEnv + , runner = _getVarExn "utestRunner" utestEnv + , exitOnFailure = _getVarExn "utestExitOnFailure" utestEnv + } in + let loader = remHook (lam x. match x with StripUtestHook _ then true else false) loader in + addHook loader (UtestHook hook) + + -- Should be called when the entire program has been loaded and + -- constructed. Inserts the code that checks if any tests have + -- failed and, if so, exits the program. + sem insertUtestExitCheck : Loader -> Loader + sem insertUtestExitCheck = | loader -> + let f = lam loader. lam x. + match x with UtestHook hook then + let decl = DeclLet + { ident = nameNoSym "" + , tyAnnot = tyunknown_ + , tyBody = tyunknown_ + , body = app_ (nvar_ (hook.exitOnFailure)) unit_ + , info = NoInfo () + } in + Some (_addDeclExn loader decl, ()) + else None () in + (withHookState f loader).0 + + sem _postTypecheck loader decl = | UtestHook hook -> + match decl with DeclUtest d then + match replaceUtests hook loader (declAsExpr unit_ decl) with (loader, expr) in + let decl = DeclLet + { ident = nameNoSym "" + , tyAnnot = tyunit_ + , tyBody = tyunit_ + , body = expr + , info = d.info + } in + (loader, decl) + else + smapAccumL_Decl_Expr (replaceUtests hook) loader decl + + sem replaceUtests hook loader = + | tm -> smapAccumL_Expr_Expr (replaceUtests hook) loader tm + | TmUtest x -> + let infoStr = str_ (info2str x.info) in + + match + match x.tusing with Some eqfn + then (loader, str_ (concat " Using: " (expr2str eqfn)), eqfn) + else match eqFunctionsFor [tyTm x.expected] loader with (loader, [eqfn]) in (loader, str_ "", eqfn) + with (loader, usingStr, eqFn) in + + match + match x.tonfail with Some ppfn then (loader, ppfn) else + match pprintFunctionsFor [tyTm x.test, tyTm x.expected] loader with (loader, [testF, expectedF]) in + (loader, appf2_ (nvar_ hook.defaultOnFail) testF expectedF) + with (loader, onFailFn) in + + -- NOTE(vipa, 2025-01-27): This doesn't replace utests occurring + -- in `using` or `else`, which is consistent with the old + -- implementation, but maybe not ideal? It should be *very* rare + -- that it matters though. + match replaceUtests hook loader x.test with (loader, test) in + match replaceUtests hook loader x.expected with (loader, expected) in + match replaceUtests hook loader x.next with (loader, next) in + + let test = appSeq_ (nvar_ hook.runner) [infoStr, usingStr, onFailFn, eqFn, test, expected] in + let tm = TmLet + { ident = nameNoSym "" + , tyAnnot = tyunknown_ + , tyBody = tyunit_ + , body = test + , inexpr = next + , ty = tyTm next + , info = x.info + } in + (loader, tm) +end diff --git a/src/stdlib/mexpr/symbolize.mc b/src/stdlib/mexpr/symbolize.mc index cb913569c..a81d43a42 100644 --- a/src/stdlib/mexpr/symbolize.mc +++ b/src/stdlib/mexpr/symbolize.mc @@ -65,6 +65,14 @@ type SymEnv = { namespaceEnv : Map String Name } +let mergeSymEnv : SymEnv -> SymEnv -> SymEnv = lam l. lam r. + { allowFree = l.allowFree + , ignoreExternals = l.ignoreExternals + , currentEnv = mergeNameEnv l.currentEnv r.currentEnv + , langEnv = mapUnion l.langEnv r.langEnv + , namespaceEnv = mapUnion l.namespaceEnv r.namespaceEnv + } + let symbolizeUpdateVarEnv = lam env : SymEnv . lam varEnv : Map String Name. {env with currentEnv = {env.currentEnv with varEnv = varEnv}} diff --git a/src/stdlib/mexpr/utest-generate.mc b/src/stdlib/mexpr/utest-generate.mc index 9ef5358b5..897f040a1 100644 --- a/src/stdlib/mexpr/utest-generate.mc +++ b/src/stdlib/mexpr/utest-generate.mc @@ -1,3 +1,8 @@ +-- NOTE(vipa, 2025-02-17): If you want the functionality provided by +-- this file, consider looking at `generate-utest.mc` instead. We want +-- to move to using that file and the loader approach rather than this +-- file, which should be replaced somewhere down the line. + -- Defines the generation of unit test code from utest expressions. This -- includes a small runtime which keeps track of the number of failing tests -- (defined in stdlib/mexpr/utest-runtime.mc), as well as the automated diff --git a/src/stdlib/mlang/loader.mc b/src/stdlib/mlang/loader.mc new file mode 100644 index 000000000..382220ccf --- /dev/null +++ b/src/stdlib/mlang/loader.mc @@ -0,0 +1,353 @@ +-- This file provides a streamlined interface for loading files and their +-- dependencies, and ensuring they are symbolized and type-checked. +-- +-- Usage centers around the Loader type, which represents a set of +-- loaded files and all their declarations. New files can be loaded +-- incrementally. Note that loading a file is a no-op if the file is +-- already loaded. Note also that since type-checking uses +-- side-effects for unification you cannot generally use a Loader as a +-- persistent value, i.e., always only use the newly returned Loader, +-- do not keep the old value. +-- +-- NOTE(vipa, 2024-11-26): The implementation wraps the `boot` backed +-- pipeline rather than the new mlang-pipeline present in this +-- folder. This is temporary, until the new pipeline is sufficiently +-- stable. The external interface should remain largely the same +-- however. + +include "mexpr/boot-parser.mc" +include "stdlib.mc" +include "ast.mc" +include "symbolize.mc" +include "type-check.mc" +include "pprint.mc" +include "mexpr/json-debug.mc" + +lang SymGetters = Sym + -- Helpers for looking up names from known symbolization + -- environments + sem _getVarExn : String -> {path : String, env : SymEnv} -> Name + sem _getVarExn str = | {path = path, env = env} -> + match mapLookup str env.currentEnv.varEnv + with Some n then n + else error (join + [ "Compiler error: expected variable \"", str, "\" to be defined in\n" + , path + ]) + sem _getConExn : String -> {path : String, env : SymEnv} -> Name + sem _getConExn str = | {path = path, env = env} -> + match mapLookup str env.currentEnv.conEnv + with Some n then n + else error (join + [ "Compiler error: expected constructor \"", str, "\" to be defined in\n" + , path + ]) + sem _getTyConExn : String -> {path : String, env : SymEnv} -> Name + sem _getTyConExn str = | {path = path, env = env} -> + match mapLookup str env.currentEnv.tyConEnv + with Some n then n + else error (join + [ "Compiler error: expected type \"", str, "\" to be defined in\n" + , path + ]) +end + +lang MCoreLoader + = Ast + DeclAst + DeclSym + DeclTypeCheck + SymGetters + + -- The loader itself + syn Loader = + -- How to load a given file + syn FileType = + + + -- === External interface, when using a Loader === + + sem mkLoader : SymEnv -> TCEnv -> [Hook] -> Loader + sem addHook : Loader -> Hook -> Loader + sem remHook : (Hook -> Bool) -> Loader -> Loader + sem hasHook : (Hook -> Bool) -> Loader -> Bool + sem withHookState : all a. (Loader -> Hook -> Option (Loader, a)) -> Loader -> (Loader, a) + -- Include a file (second String) relative to a directory (first + -- String). Returns a symbolization enviroment containing only + -- definitions from that specific file + sem includeFileExn : String -> String -> Loader -> ({path : String, env : SymEnv}, Loader) + sem includeFileExn dir path = | loader -> includeFileTypeExn (_fileType path) dir path loader + sem includeFileTypeExn : FileType -> String -> String -> Loader -> ({path : String, env : SymEnv}, Loader) + sem getDecls : Loader -> [Decl] + sem buildFullAst : Loader -> Expr + + + -- === Internal interface, for supporting new files + + -- Called with a fully resolved path to a file to load. Paired to + -- enable special handling based on file type. Should ensure that + -- the same file isn't loaded twice. + sem _loadFile : String -> (FileType, Loader) -> (SymEnv, Loader) + + -- Called to automatically determine how to load a given file based + -- on its path, typically by the file extension. + sem _fileType : String -> FileType + sem _fileType = + | path -> errorSingle [] "No known handler for this file" + + -- Used to carry extra state for hooks + syn Hook = + + -- Add decls to the loader. Added code is symbolized and + -- type-checked, unless the used function contains `Symbolized` (in + -- which case only type-checking is run) or `Typechecked` (in which + -- case neither is run). The `WithEnv` variant runs symbolize with + -- the given environment instead of the running one. Note that new + -- names are still added to the running environment as well. + sem _addDeclExn : Loader -> Decl -> Loader + sem _addDeclWithEnvExn : SymEnv -> Loader -> Decl -> (SymEnv, Loader) + sem _addSymbolizedDeclExn : Loader -> Decl -> Loader + sem _addTypecheckedDecl : Loader -> Decl -> Loader + + -- Symbolization related functions + sem _getSymEnv : Loader -> SymEnv + sem _setSymEnv : SymEnv -> Loader -> Loader + + -- Type-checking related functions + sem _getTCEnv : Loader -> TCEnv + sem _setTCEnv : TCEnv -> Loader -> Loader + + -- Hooks for additional processing around each phase + sem _preSymbolize : Loader -> Decl -> Hook -> (Loader, Decl) + sem _preSymbolize loader decl = | _ -> (loader, decl) + sem _postSymbolize : Loader -> Decl -> Hook -> (Loader, Decl) + sem _postSymbolize loader decl = | _ -> (loader, decl) + sem _preTypecheck : Loader -> Decl -> Hook -> (Loader, Decl) + sem _preTypecheck loader decl = | _ -> (loader, decl) + sem _postTypecheck : Loader -> Decl -> Hook -> (Loader, Decl) + sem _postTypecheck loader decl = | _ -> (loader, decl) +end + +-- Use MCore-style path resolution, e.g., using libraries set in +-- MCORE_LIBS +lang MCorePathResolution = MCoreLoader + sem includeFileTypeExn ftype dir path = | loader -> + let resolved = stdlibResolveFileOr (lam x. error x) dir path in + match _loadFile resolved (ftype, loader) with (env, loader) in + ({path = resolved, env = env}, loader) +end + +lang BootParserLoader = MCorePathResolution + DeclAst + ExprAsDecl + BootParser + + LetDeclAst + RecLetsDeclAst + TypeDeclAst + DataDeclAst + ExtDeclAst + + MLangPrettyPrint + AstToJson + type LoaderRec = + { decls : [Decl] + -- NOTE(vipa, 2024-11-27): We check each Decl if their info field + -- points to a file in this set. The set is updated only after all + -- decls from a file have been filtered (but before they've been + -- added, symbolized, and type-checked), thus we can do simpler + -- de-duplication than previously. + , includedFiles : Map String SymEnv + , symEnv : SymEnv + , tcEnv : TCEnv + , hooks : [Hook] + } + syn Loader = + | Loader LoaderRec + syn FileType = + | FMCore () + + sem mkLoader symEnv tcEnv = | hooks -> Loader + { decls = [] + , includedFiles = mapEmpty cmpString + , symEnv = symEnv + , tcEnv = tcEnv + , hooks = hooks + } + sem addHook loader = | hook -> + match loader with Loader x in + Loader {x with hooks = snoc x.hooks hook} + sem remHook check = | Loader x -> + Loader {x with hooks = filter (lam x. not (check x)) x.hooks} + sem hasHook check = | Loader x -> + optionIsSome (find check x.hooks) + sem withHookState f = | loader & Loader x -> + match findMap (f loader) x.hooks with Some res + then res + else error "Compiler error: missing hook in loader" + + sem _getSymEnv = | Loader x -> x.symEnv + sem _setSymEnv symEnv = | Loader x -> Loader {x with symEnv = symEnv} + + sem _getTCEnv = | Loader x -> x.tcEnv + sem _setTCEnv tcEnv = | Loader x -> Loader {x with tcEnv = tcEnv} + + sem getDecls = | Loader x -> x.decls + sem buildFullAst = | Loader x -> foldr (lam decl. lam cont. declAsExpr cont decl) unit_ x.decls + + sem _fileType = | _ ++ ".mc" -> FMCore () + + sem _loadFile path = | (FMCore _, loader & Loader x) -> + -- NOTE(vipa, 2024-12-05): Don't reload previously loaded files + match mapLookup path x.includedFiles with Some symEnv then (symEnv, loader) else + let args = + { _defaultBootParserParseMCoreFileArg () + -- NOTE(vipa, 2024-12-03): It's important to not remove dead + -- code, because that code might end up not-dead later, at which + -- point it would end up included then, out of order and in + -- various ways messing with assumptions made in the loader. + with eliminateDeadCode = false + -- NOTE(vipa, 2024-12-03): This largely lets us error later, + -- which gives better error messages. + , allowFree = true + } in + let ast = parseMCoreFile args path in + recursive let f = lam decls. lam ast. + match exprAsDecl ast with Some (decl, ast) + then f (snoc decls decl) ast + else decls in + match _addDeclsByFile loader (f [] ast) with loader & Loader x in + match mapLookup path x.includedFiles with Some env + then (env, loader) + else (_symEnvEmpty, Loader {x with includedFiles = mapInsert path _symEnvEmpty x.includedFiles}) + + -- Conceptually, take a list of decls from multiple files, split them to one list per file + sem _addDeclsByFile : Loader -> [Decl] -> Loader + sem _addDeclsByFile loader = + | [first] ++ rest -> + let getFName = lam decl. + match infoDecl decl with Info {filename = filename} + then filename + else errorSingle [] "Missing info for decl" in + recursive + let newFile = lam filename. lam decl. lam loader. lam decls. + match loader with Loader x in + if mapMem filename x.includedFiles then + dropNext filename loader decls + else + let loader = Loader {x with includedFiles = mapInsert filename _symEnvEmpty x.includedFiles} in + addNext filename (_addDeclExn loader decl) decls + let addNext = lam currFilename. lam loader. lam decls. + match decls with [decl] ++ decls then + let newFilename = getFName decl in + if eqString newFilename currFilename then + addNext currFilename (_addDeclExn loader decl) decls + else + newFile newFilename decl loader decls + else loader + let dropNext = lam currFilename. lam loader. lam decls. + match decls with [decl] ++ decls then + let newFilename = getFName decl in + if eqString newFilename currFilename then + dropNext currFilename loader decls + else + newFile newFilename decl loader decls + else loader + in newFile (getFName first) first loader rest + | [] -> loader + + sem _doHook : (Loader -> Decl -> Hook -> (Loader, Decl)) -> Loader -> Decl -> (Loader, Decl) + sem _doHook f loader = | decl -> + match loader with Loader {hooks = hooks} in + foldl (lam acc. lam cb. f acc.0 acc.1 cb) (loader, decl) hooks + + sem _addDeclWithEnvExn symEnv loader = | decl -> + match _doHook _preSymbolize loader decl with (Loader x, decl) in + match symbolizeDecl symEnv decl with (newEnv, decl) in + let symEnv = _addDefinition x.symEnv decl in + match _doHook _postSymbolize (Loader {x with symEnv = symEnv}) decl with (loader, decl) in + + match _doHook _preTypecheck loader decl with (Loader x, decl) in + match typeCheckDecl x.tcEnv decl with (tcEnv, decl) in + match _doHook _postTypecheck (Loader {x with tcEnv = tcEnv}) decl with (Loader x, decl) in + + let includedFiles = match infoDecl decl with Info {filename = filename} + then mapUpdate filename (optionMap (lam env. _addDefinition env decl)) x.includedFiles + else x.includedFiles in + + (newEnv, Loader {x with decls = snoc x.decls decl, includedFiles = includedFiles}) + + sem _addDeclExn loader = | decl -> + match _doHook _preSymbolize loader decl with (Loader x, decl) in + match symbolizeDecl x.symEnv decl with (symEnv, decl) in + match _doHook _postSymbolize (Loader {x with symEnv = symEnv}) decl with (loader, decl) in + + match _doHook _preTypecheck loader decl with (Loader x, decl) in + match typeCheckDecl x.tcEnv decl with (tcEnv, decl) in + match _doHook _postTypecheck (Loader {x with tcEnv = tcEnv}) decl with (Loader x, decl) in + + let includedFiles = match infoDecl decl with Info {filename = filename} + then mapUpdate filename (optionMap (lam env. _addDefinition env decl)) x.includedFiles + else x.includedFiles in + + Loader {x with decls = snoc x.decls decl, includedFiles = includedFiles} + + sem _addSymbolizedDeclExn loader = | decl -> + match _doHook _preTypecheck loader decl with (Loader x, decl) in + match typeCheckDecl x.tcEnv decl with (tcEnv, decl) in + match _doHook _postTypecheck (Loader {x with tcEnv = tcEnv}) decl with (Loader x, decl) in + + let includedFiles = match infoDecl decl with Info {filename = filename} + then mapUpdate filename (optionMap (lam env. _addDefinition env decl)) x.includedFiles + else x.includedFiles in + + Loader {x with decls = snoc x.decls decl} + + sem _addTypecheckedDecl loader = | decl -> + match loader with Loader x in + + let includedFiles = match infoDecl decl with Info {filename = filename} + then mapUpdate filename (optionMap (lam env. _addDefinition env decl)) x.includedFiles + else x.includedFiles in + + Loader {x with decls = snoc x.decls decl} + + sem _addDefinition : SymEnv -> Decl -> SymEnv + sem _addDefinition env = + | _ -> env + | DeclLet t -> + let varEnv = mapInsert (nameGetStr t.ident) t.ident env.currentEnv.varEnv in + symbolizeUpdateVarEnv env varEnv + | DeclType t -> + let tyConEnv = mapInsert (nameGetStr t.ident) t.ident env.currentEnv.tyConEnv in + symbolizeUpdateTyConEnv env tyConEnv + | DeclRecLets t -> + let add = lam acc. lam b. mapInsert (nameGetStr b.ident) b.ident acc in + let varEnv = foldl add env.currentEnv.varEnv t.bindings in + symbolizeUpdateVarEnv env varEnv + | DeclConDef t -> + let conEnv = mapInsert (nameGetStr t.ident) t.ident env.currentEnv.conEnv in + symbolizeUpdateConEnv env conEnv + | DeclExt t -> + let varEnv = mapInsert (nameGetStr t.ident) t.ident env.currentEnv.varEnv in + symbolizeUpdateVarEnv env varEnv +end + +lang MCoreLoader + = MCorePathResolution + BootParserLoader + MExprAsDecl + + MExprSym + MLangSym + + MExprTypeCheck + MLangTypeCheck +end + +mexpr + +use MCoreLoader in +use MExprCmp in + +-- TODO(vipa, 2024-11-28): In the absence of proper comparison of +-- decls, we just compare the contained exprs +let declCmp = lam a. lam b. + let as = sfold_Decl_Expr snoc [] a in + let bs = sfold_Decl_Expr snoc [] b in + seqCmp cmpExpr as bs in + +-- Loading actually loads something +let loader = mkLoader _symEnvEmpty typcheckEnvDefault [] in +match includeFileExn (sysGetCwd ()) "stdlib::bool.mc" loader with (symEnv, loader) in +utest length (getDecls loader) with 1 using lam count. lam limit. geqi count limit in +utest mapLookup "eqBool" symEnv.env.currentEnv.varEnv with () using lam x. lam. optionIsSome x in + +-- Inclusion is idempotent +let loader = mkLoader _symEnvEmpty typcheckEnvDefault [] in +let loader = (includeFileExn (sysGetCwd ()) "stdlib::seq.mc" loader).1 in +let boolDecls = getDecls loader in +let loader = (includeFileExn (sysGetCwd ()) "stdlib::seq.mc" loader).1 in +utest boolDecls with getDecls loader using lam a. lam b. eqi 0 (seqCmp declCmp a b) in + +() diff --git a/src/stdlib/stdlib.mc b/src/stdlib/stdlib.mc index 84be494fa..fc4bafaf5 100644 --- a/src/stdlib/stdlib.mc +++ b/src/stdlib/stdlib.mc @@ -60,6 +60,8 @@ let stdlibLoc = mapFindExn "stdlib" stdlibMCoreLibs -- `relativeTo`. Applies path normalization. The `doError` function -- will be called with an error message if an error occurs. Follows -- these rules: +-- - If path has the form "/absolute/path/to/file", return the path +-- unchanged -- - If path has the form "lib::path/to/file" and MCORE_LIBS contains -- "lib=path/to/lib", return "path/to/lib/path/to/file". -- - If path has the form "./path/to/file" or "../path/to/file", @@ -68,7 +70,9 @@ let stdlibLoc = mapFindExn "stdlib" stdlibMCoreLibs -- the given directory or in the stdlib. Checks for ambiguity, -- errors if both exist. Priority: existing file, then local file. let stdlibResolveFileOr : (String -> String) -> String -> String -> String = lam doError. lam relativeTo. lam path. - match strSplit "::" path with [lib, path] ++ paths then + match path with "/" ++ _ then + path + else match strSplit "::" path with [lib, path] ++ paths then -- Explicit library use match mapLookup lib stdlibMCoreLibs with Some libPath then fileutilsNormalize (filepathConcat libPath (strJoin "::" (cons path paths))) diff --git a/src/stdlib/string.mc b/src/stdlib/string.mc index d8b459e57..dce1338d8 100644 --- a/src/stdlib/string.mc +++ b/src/stdlib/string.mc @@ -277,6 +277,14 @@ utest strJoin "--" [] with emptyStr utest strJoin "--" ["coffee"] with "coffee" utest strJoin "water" ["coffee", "tea"] with "coffeewatertea" +let seq2string : all a. (a -> String) -> [a] -> String + = lam f. lam seq. + join ["[", strJoin ", " (map f seq), "]"] + +utest seq2string int2string [1, 2, 3] with "[1, 2, 3]" +utest seq2string int2string [] with "[]" +utest seq2string int2string [37] with "[37]" + -- Replaces all occurrences of the string by the replacement let strReplace: String -> String -> String -> String = subseqReplace eqChar