diff --git a/.gitmodules b/.gitmodules index 6890f1a7dc..eef118a96a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -995,6 +995,9 @@ [submodule "vendor/grammars/riot-syntax-highlight"] path = vendor/grammars/riot-syntax-highlight url = https://github.com/riot/syntax-highlight +[submodule "vendor/grammars/roc-vscode-unofficial"] + path = vendor/grammars/roc-vscode-unofficial + url = https://github.com/ivan-demchenko/roc-vscode-unofficial.git [submodule "vendor/grammars/ruby-slim.tmbundle"] path = vendor/grammars/ruby-slim.tmbundle url = https://github.com/slim-template/ruby-slim.tmbundle diff --git a/grammars.yml b/grammars.yml index e9c84c6522..8c81bc65f9 100644 --- a/grammars.yml +++ b/grammars.yml @@ -919,6 +919,8 @@ vendor/grammars/rez.tmbundle: - source.rez vendor/grammars/riot-syntax-highlight: - text.html.riot +vendor/grammars/roc-vscode-unofficial: +- source.roc vendor/grammars/ruby-slim.tmbundle: - text.slim vendor/grammars/rust-syntax: diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index 3441a3f316..40a6d3616a 100644 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -5996,6 +5996,14 @@ RobotFramework: tm_scope: text.robot ace_mode: text language_id: 324 +Roc: + type: programming + color: "#7c38f5" + extensions: + - ".roc" + tm_scope: source.roc + ace_mode: text + language_id: 440182480 Roff: type: markup color: "#ecdebe" diff --git a/samples/Roc/ParserString.roc b/samples/Roc/ParserString.roc new file mode 100644 index 0000000000..cf7e162d3c --- /dev/null +++ b/samples/Roc/ParserString.roc @@ -0,0 +1,378 @@ +# From https://github.com/lukewilliamboswell/roc-parser/blob/main/package/String.roc +# License is UPL +interface String + exposes [ + Utf8, + parseStr, + parseStrPartial, + parseUtf8, + parseUtf8Partial, + string, + utf8, + codeunit, + codeunitSatisfies, + anyString, + anyThing, + anyCodeunit, + scalar, + oneOf, + digit, + digits, + strFromUtf8, + ] + imports [ + Core.{ Parser, ParseResult, const, map, skip, sepBy, keep, oneOrMore, parse, parsePartial, buildPrimitiveParser, chompUntil, chompWhile }, + ] + +## ``` +## Utf8 : List U8 +## ``` +Utf8 : List U8 + +## Parse a [Str] using a [Parser] +## ``` +## color : Parser Utf8 [Red, Green, Blue] +## color = +## oneOf [ +## const Red |> skip (string "red"), +## const Green |> skip (string "green"), +## const Blue |> skip (string "blue"), +## ] +## +## expect parseStr color "green" == Ok Green +## ``` +parseStr : Parser Utf8 a, Str -> Result a [ParsingFailure Str, ParsingIncomplete Str] +parseStr = \parser, input -> + parser + |> parseUtf8 (strToRaw input) + |> Result.mapErr \problem -> + when problem is + ParsingFailure msg -> ParsingFailure msg + ParsingIncomplete leftoverRaw -> ParsingIncomplete (strFromUtf8 leftoverRaw) + +## Runs a parser against the start of a string, allowing the parser to consume it only partially. +## +## - If the parser succeeds, returns the resulting value as well as the leftover input. +## - If the parser fails, returns `Err (ParsingFailure msg)` +## +## +## ``` +## atSign : Parser Utf8 [AtSign] +## atSign = const AtSign |> skip (codeunit '@') +## +## expect parseStr atSign "@" == Ok AtSign +## expect parseStrPartial atSign "@" |> Result.map .val == Ok AtSign +## expect parseStrPartial atSign "$" |> Result.isErr +## ``` +parseStrPartial : Parser Utf8 a, Str -> ParseResult Str a +parseStrPartial = \parser, input -> + parser + |> parseUtf8Partial (strToRaw input) + |> Result.map \{ val: val, input: restRaw } -> + { val: val, input: strFromUtf8 restRaw } + +## Runs a parser against a string, requiring the parser to consume it fully. +## +## - If the parser succeeds, returns `Ok a` +## - If the parser fails, returns `Err (ParsingFailure Str)` +## - If the parser succeeds but does not consume the full string, returns `Err (ParsingIncomplete (List U8))` +parseUtf8 : Parser Utf8 a, Utf8 -> Result a [ParsingFailure Str, ParsingIncomplete Utf8] +parseUtf8 = \parser, input -> + parse parser input (\leftover -> List.len leftover == 0) + +## Runs a parser against the start of a list of scalars, allowing the parser to consume it only partially. +parseUtf8Partial : Parser Utf8 a, Utf8 -> ParseResult Utf8 a +parseUtf8Partial = \parser, input -> + parsePartial parser input + +## ``` +## isDigit : U8 -> Bool +## isDigit = \b -> b >= '0' && b <= '9' +## +## expect parseStr (codeunitSatisfies isDigit) "0" == Ok '0' +## expect parseStr (codeunitSatisfies isDigit) "*" |> Result.isErr +## ``` +codeunitSatisfies : (U8 -> Bool) -> Parser Utf8 U8 +codeunitSatisfies = \check -> + buildPrimitiveParser \input -> + { before: start, others: inputRest } = List.split input 1 + + when List.get start 0 is + Err OutOfBounds -> + Err (ParsingFailure "expected a codeunit satisfying a condition, but input was empty.") + + Ok startCodeunit -> + if check startCodeunit then + Ok { val: startCodeunit, input: inputRest } + else + otherChar = strFromCodeunit startCodeunit + inputStr = strFromUtf8 input + + Err (ParsingFailure "expected a codeunit satisfying a condition but found `\(otherChar)`.\n While reading: `\(inputStr)`") + +## ``` +## atSign : Parser Utf8 [AtSign] +## atSign = const AtSign |> skip (codeunit '@') +## +## expect parseStr atSign "@" == Ok AtSign +## expect parseStrPartial atSign "$" |> Result.isErr +## ``` +codeunit : U8 -> Parser Utf8 U8 +codeunit = \expectedCodeUnit -> + buildPrimitiveParser \input -> + when input is + [] -> + Err (ParsingFailure "expected char `\(strFromCodeunit expectedCodeUnit)` but input was empty.") + [first, .. as rest] if first == expectedCodeUnit -> + Ok { val: expectedCodeUnit, input: rest } + [first, .. as rest] -> + Err (ParsingFailure "expected char `\(strFromCodeunit expectedCodeUnit)` but found `\(strFromCodeunit first)`.\n While reading: `\(strFromUtf8 input)`") + +## Parse an extact sequence of utf8 +utf8 : List U8 -> Parser Utf8 (List U8) +utf8 = \expectedString -> + # Implemented manually instead of a sequence of codeunits + # because of efficiency and better error messages + buildPrimitiveParser \input -> + { before: start, others: inputRest } = List.split input (List.len expectedString) + + if start == expectedString then + Ok { val: expectedString, input: inputRest } + else + errorString = strFromUtf8 expectedString + otherString = strFromUtf8 start + inputString = strFromUtf8 input + + Err (ParsingFailure "expected string `\(errorString)` but found `\(otherString)`.\nWhile reading: \(inputString)") + +## Parse the given [Str] +## ``` +## expect parseStr (string "Foo") "Foo" == Ok "Foo" +## expect parseStr (string "Foo") "Bar" |> Result.isErr +## ``` +string : Str -> Parser Utf8 Str +string = \expectedString -> + strToRaw expectedString + |> utf8 + |> map \_val -> expectedString + +## Matches any [U8] codeunit +## ``` +## expect parseStr anyCodeunit "a" == Ok 'a' +## expect parseStr anyCodeunit "$" == Ok '$' +## ``` +anyCodeunit : Parser Utf8 U8 +anyCodeunit = codeunitSatisfies (\_ -> Bool.true) + +expect parseStr anyCodeunit "a" == Ok 'a' +expect parseStr anyCodeunit "$" == Ok '$' + +## Matches any [Utf8] and consumes all the input without fail. +## ``` +## expect +## bytes = Str.toUtf8 "consumes all the input" +## parse anyThing bytes List.isEmpty == Ok bytes +## ``` +anyThing : Parser Utf8 Utf8 +anyThing = buildPrimitiveParser \input -> Ok { val: input, input: [] } + +expect + bytes = Str.toUtf8 "consumes all the input" + parse anyThing bytes List.isEmpty == Ok bytes + +# Matches any string +# as long as it is valid UTF8. +anyString : Parser Utf8 Str +anyString = buildPrimitiveParser \fieldUtf8ing -> + when Str.fromUtf8 fieldUtf8ing is + Ok stringVal -> + Ok { val: stringVal, input: [] } + + Err (BadUtf8 _ _) -> + Err (ParsingFailure "Expected a string field, but its contents cannot be parsed as UTF8.") + +## ``` +## expect parseStr digit "0" == Ok 0 +## expect parseStr digit "not a digit" |> Result.isErr +## ``` +digit : Parser Utf8 Nat +digit = + buildPrimitiveParser \input -> + when input is + [] -> + Err (ParsingFailure "Expected a digit from 0-9 but input was empty.") + [first, .. as rest] if first >= '0' && first <= '9' -> + Ok { val: Num.toNat (first - '0'), input: rest } + _ -> + Err (ParsingFailure "Not a digit") + +## Parse a sequence of digits into a [Nat] accepting leading zeroes +## ``` +## expect parseStr digits "0123" == Ok 123 +## expect parseStr digits "not a digit" |> Result.isErr +## ``` +digits : Parser Utf8 Nat +digits = + oneOrMore digit + |> map \ds -> List.walk ds 0 (\sum, d -> sum * 10 + d) + +## Try a bunch of different parsers. +## +## The first parser which is tried is the one at the front of the list, +## and the next one is tried until one succeeds or the end of the list was reached. +## ``` +## boolParser : Parser Utf8 Bool +## boolParser = +## oneOf [string "true", string "false"] +## |> map (\x -> if x == "true" then Bool.true else Bool.false) +## +## expect parseStr boolParser "true" == Ok Bool.true +## expect parseStr boolParser "false" == Ok Bool.false +## expect parseStr boolParser "not a bool" |> Result.isErr +## ``` +oneOf : List (Parser Utf8 a) -> Parser Utf8 a +oneOf = \parsers -> + buildPrimitiveParser \input -> + List.walkUntil parsers (Err (ParsingFailure "(no possibilities)")) \_, parser -> + when parseUtf8Partial parser input is + Ok val -> + Break (Ok val) + + Err problem -> + Continue (Err problem) + +scalar : U32 -> Parser Utf8 U32 +scalar = \expectedScalar -> + expectedScalar + |> strFromScalar + |> string + |> map \_ -> expectedScalar + +strFromUtf8 : Utf8 -> Str +strFromUtf8 = \rawStr -> + rawStr + |> Str.fromUtf8 + |> Result.withDefault "Unexpected problem while turning a List U8 (that was originally a Str) back into a Str. This should never happen!" + +strToRaw : Str -> Utf8 +strToRaw = \str -> + str |> Str.toUtf8 + +strFromScalar : U32 -> Str +strFromScalar = \scalarVal -> + Str.appendScalar "" (Num.intCast scalarVal) + |> Result.withDefault "Unexpected problem while turning a U32 (that was probably originally a scalar constant) into a Str. This should never happen!" + +strFromCodeunit : U8 -> Str +strFromCodeunit = \cu -> + strFromUtf8 [cu] + +# -------------------- example snippets used in docs -------------------- + +parseU32 : Parser Utf8 U32 +parseU32 = + const Num.toU32 + |> keep digits + +expect parseStr parseU32 "123" == Ok 123u32 + +color : Parser Utf8 [Red, Green, Blue] +color = + oneOf [ + const Red |> skip (string "red"), + const Green |> skip (string "green"), + const Blue |> skip (string "blue"), + ] + +expect parseStr color "green" == Ok Green + +parseNumbers : Parser Utf8 (List Nat) +parseNumbers = + digits |> sepBy (codeunit ',') + +expect parseStr parseNumbers "1,2,3" == Ok [1,2,3] + +expect parseStr (string "Foo") "Foo" == Ok "Foo" +expect parseStr (string "Foo") "Bar" |> Result.isErr + +ignoreText : Parser Utf8 Nat +ignoreText = + const (\d -> d) + |> skip (chompUntil ':') + |> skip (codeunit ':') + |> keep digits + +expect parseStr ignoreText "ignore preceding text:123" == Ok 123 + +ignoreNumbers : Parser Utf8 Str +ignoreNumbers = + const (\str -> str) + |> skip (chompWhile \b -> b >= '0' && b <= '9') + |> keep (string "TEXT") + +expect parseStr ignoreNumbers "0123456789876543210TEXT" == Ok "TEXT" + +isDigit : U8 -> Bool +isDigit = \b -> b >= '0' && b <= '9' + +expect parseStr (codeunitSatisfies isDigit) "0" == Ok '0' +expect parseStr (codeunitSatisfies isDigit) "*" |> Result.isErr + +atSign : Parser Utf8 [AtSign] +atSign = const AtSign |> skip (codeunit '@') + +expect parseStr atSign "@" == Ok AtSign +expect parseStrPartial atSign "@" |> Result.map .val == Ok AtSign +expect parseStrPartial atSign "$" |> Result.isErr + +Requirement : [ Green Nat, Red Nat, Blue Nat ] +RequirementSet : List Requirement +Game : { id: Nat, requirements: List RequirementSet } + +parseGame : Str -> Result Game [ParsingError] +parseGame = \s -> + green = const Green |> keep digits |> skip (string " green") + red = const Red |> keep digits |> skip (string " red") + blue = const Blue |> keep digits |> skip (string " blue") + + requirementSet : Parser _ RequirementSet + requirementSet = (oneOf [green, red, blue]) |> sepBy (string ", ") + + requirements : Parser _ (List RequirementSet) + requirements = requirementSet |> sepBy (string "; ") + + game : Parser _ Game + game = + const (\id -> \r -> { id, requirements: r }) + |> skip (string "Game ") + |> keep digits + |> skip (string ": ") + |> keep requirements + + when parseStr game s is + Ok g -> Ok g + Err (ParsingFailure _) | Err (ParsingIncomplete _) -> Err ParsingError + +expect parseGame "Game 1: 3 blue, 4 red; 1 red, 2 green, 6 blue; 2 green" == Ok { + id: 1, + requirements: [ + [Blue 3, Red 4], + [Red 1, Green 2, Blue 6], + [Green 2], + ] + } + +expect parseStr digit "0" == Ok 0 +expect parseStr digit "not a digit" |> Result.isErr + +expect parseStr digits "0123" == Ok 123 +expect parseStr digits "not a digit" |> Result.isErr + +boolParser : Parser Utf8 Bool +boolParser = + oneOf [string "true", string "false"] + |> map (\x -> if x == "true" then Bool.true else Bool.false) + +expect parseStr boolParser "true" == Ok Bool.true +expect parseStr boolParser "false" == Ok Bool.false +expect parseStr boolParser "not a bool" |> Result.isErr diff --git a/samples/Roc/PgCmd.roc b/samples/Roc/PgCmd.roc new file mode 100644 index 0000000000..05e8c19718 --- /dev/null +++ b/samples/Roc/PgCmd.roc @@ -0,0 +1,140 @@ +# From https://github.com/agu-z/roc-pg/blob/main/src/Cmd.roc +# License is UPL +interface Cmd exposes + [ + Cmd, + Params, + Limit, + Kind, + fromSql, + prepared, + params, + withLimit, + decode, + withDecode, + map, + bind, + Binding, + encodeBindings, + ] imports [ + Protocol.Frontend.{ FormatCode }, + Protocol.Backend.{ RowField }, + Pg.Result.{ CmdResult }, + ] + +Cmd a err := Params { decode : CmdResult -> Result a err } [] + +Limit : [None, Limit I32] + +Params p k : { + kind : Kind k, + bindings : List Binding, + limit : Limit, +}p + +Kind k : [ + SqlCmd Str, + PreparedCmd + { + name : Str, + fields : List RowField, + }, +]k + +fromSql : Str -> Cmd CmdResult [] +fromSql = \sql -> + new (SqlCmd sql) + +prepared : { name : Str, fields : List RowField } -> Cmd CmdResult [] +prepared = \prep -> + new (PreparedCmd prep) + +new : Kind [] -> Cmd CmdResult [] +new = \kind -> + @Cmd { + kind, + limit: None, + bindings: [], + decode: Ok, + } + +params : Cmd a err -> Params {} [] +params = \@Cmd { kind, bindings, limit } -> + { kind, bindings, limit } + +withLimit : Cmd a err, I32 -> Cmd a err +withLimit = \@Cmd cmd, limit -> + @Cmd { cmd & limit: Limit limit } + +decode : CmdResult, Cmd a err -> Result a err +decode = \r, @Cmd cmd -> + cmd.decode r + +withDecode : Cmd * *, (CmdResult -> Result a err) -> Cmd a err +withDecode = \@Cmd cmd, fn -> + @Cmd { + kind: cmd.kind, + limit: cmd.limit, + bindings: cmd.bindings, + decode: fn, + } + +map : Cmd a err, (a -> b) -> Cmd b err +map = \@Cmd cmd, fn -> + @Cmd { + kind: cmd.kind, + limit: cmd.limit, + bindings: cmd.bindings, + decode: \r -> cmd.decode r |> Result.map fn, + } + +bind : Cmd a err, List Binding -> Cmd a err +bind = \@Cmd cmd, bindings -> + @Cmd { cmd & bindings } + +Binding : [ + Null, + Text Str, + Binary (List U8), +] + +encodeBindings : List Binding + -> { + formatCodes : List FormatCode, + paramValues : List [Null, Value (List U8)], + } +encodeBindings = \bindings -> + count = List.len bindings + + empty = { + formatCodes: List.withCapacity count, + paramValues: List.withCapacity count, + } + + List.walk bindings empty \state, binding -> + { format, value } = encodeSingle binding + + { + formatCodes: state.formatCodes |> List.append format, + paramValues: state.paramValues |> List.append value, + } + +encodeSingle = \binding -> + when binding is + Null -> + { + value: Null, + format: Binary, + } + + Binary value -> + { + value: Value value, + format: Binary, + } + + Text value -> + { + value: Value (Str.toUtf8 value), + format: Text, + } diff --git a/samples/Roc/PgProtocolBackend.roc b/samples/Roc/PgProtocolBackend.roc new file mode 100644 index 0000000000..1f723cdee3 --- /dev/null +++ b/samples/Roc/PgProtocolBackend.roc @@ -0,0 +1,367 @@ +# From https://github.com/agu-z/roc-pg/blob/main/src/Protocol/Backend.roc +# License is UPL +interface Protocol.Backend + exposes [ + header, + message, + Message, + KeyData, + Status, + RowField, + Error, + ] + imports [ + Bytes.Decode.{ + Decode, + await, + map, + succeed, + fail, + loop, + u8, + i16, + i32, + cStr, + take, + }, + ] + +Message : [ + AuthOk, + AuthCleartextPassword, + AuthUnsupported, + ParameterStatus { name : Str, value : Str }, + BackendKeyData KeyData, + ReadyForQuery Status, + ErrorResponse Error, + ParseComplete, + BindComplete, + NoData, + RowDescription (List RowField), + ParameterDescription, + DataRow (List (List U8)), + PortalSuspended, + CommandComplete Str, + EmptyQueryResponse, + CloseComplete, +] + +header : Decode { msgType : U8, len : I32 } _ +header = + msgType <- await u8 + len <- map i32 + + { msgType, len: len - 4 } + +message : U8 -> Decode Message _ +message = \msgType -> + when msgType is + 'R' -> + authRequest + + 'S' -> + paramStatus + + 'K' -> + backendKeyData + + 'Z' -> + readyForQuery + + 'E' -> + errorResponse + + '1' -> + succeed ParseComplete + + '2' -> + succeed BindComplete + + 'n' -> + succeed NoData + + 'T' -> + rowDescription + + 't' -> + succeed ParameterDescription + + 'D' -> + dataRow + + 's' -> + succeed PortalSuspended + + 'C' -> + commandComplete + + 'I' -> + succeed EmptyQueryResponse + + '3' -> + succeed CloseComplete + + _ -> + fail (UnrecognizedBackendMessage msgType) + +authRequest : Decode Message _ +authRequest = + authType <- map i32 + + when authType is + 0 -> + AuthOk + + 3 -> + AuthCleartextPassword + + _ -> + AuthUnsupported + +paramStatus : Decode Message _ +paramStatus = + name <- await cStr + value <- await cStr + succeed (ParameterStatus { name, value }) + +KeyData : { processId : I32, secretKey : I32 } + +backendKeyData : Decode Message _ +backendKeyData = + processId <- await i32 + secretKey <- await i32 + succeed (BackendKeyData { processId, secretKey }) + +Status : [Idle, TransactionBlock, FailedTransactionBlock] + +readyForQuery : Decode Message _ +readyForQuery = + status <- await u8 + + when status is + 'I' -> + succeed (ReadyForQuery Idle) + + 'T' -> + succeed (ReadyForQuery TransactionBlock) + + 'E' -> + succeed (ReadyForQuery FailedTransactionBlock) + + _ -> + fail (UnrecognizedBackendStatus status) + +Error : { + localizedSeverity : Str, + severity : Result ErrorSeverity {}, + code : Str, + message : Str, + detail : Result Str {}, + hint : Result Str {}, + position : Result U32 {}, + internalPosition : Result U32 {}, + internalQuery : Result Str {}, + ewhere : Result Str {}, + schemaName : Result Str {}, + tableName : Result Str {}, + columnName : Result Str {}, + dataTypeName : Result Str {}, + constraintName : Result Str {}, + file : Result Str {}, + line : Result Str {}, + routine : Result Str {}, +} + +errorResponse : Decode Message _ +errorResponse = + dict <- await knownStrFields + + localizedSeverity <- 'S' |> requiredField dict + severity <- 'V' |> optionalFieldWith dict decodeSeverity + code <- 'C' |> requiredField dict + msg <- 'M' |> requiredField dict + position <- 'P' |> optionalFieldWith dict Str.toU32 + internalPosition <- 'p' |> optionalFieldWith dict Str.toU32 + + ErrorResponse { + localizedSeverity, + severity, + code, + message: msg, + detail: 'D' |> optionalField dict, + hint: 'H' |> optionalField dict, + position, + internalPosition, + internalQuery: 'q' |> optionalField dict, + ewhere: 'W' |> optionalField dict, + schemaName: 's' |> optionalField dict, + tableName: 't' |> optionalField dict, + columnName: 'c' |> optionalField dict, + dataTypeName: 'd' |> optionalField dict, + constraintName: 'n' |> optionalField dict, + file: 'F' |> optionalField dict, + line: 'L' |> optionalField dict, + routine: 'R' |> optionalField dict, + } + |> succeed + +optionalField = \fieldId, dict -> + when Dict.get dict fieldId is + Ok value -> + Ok value + + Err _ -> + Err {} + +optionalFieldWith = \fieldId, dict, validate, callback -> + result = Dict.get dict fieldId + + when result is + Ok value -> + when validate value is + Ok validated -> + callback (Ok validated) + + Err err -> + fail err + + Err _ -> + callback (Err {}) + +requiredField = \fieldId, dict, callback -> + result = Dict.get dict fieldId + + when result is + Ok value -> + callback value + + Err _ -> + fail (MissingField fieldId) + +ErrorSeverity : [ + Error, + Fatal, + Panic, + Warning, + Notice, + Debug, + Info, + Log, +] + +decodeSeverity = \str -> + when str is + "ERROR" -> + Ok Error + + "FATAL" -> + Ok Fatal + + "PANIC" -> + Ok Panic + + "WARNING" -> + Ok Warning + + "NOTICE" -> + Ok Notice + + "DEBUG" -> + Ok Debug + + "INFO" -> + Ok Info + + "LOG" -> + Ok Log + + _ -> + Err (InvalidSeverity str) + +knownStrFields : Decode (Dict U8 Str) _ +knownStrFields = + collected <- loop (Dict.empty {}) + + fieldId <- await u8 + + if fieldId == 0 then + succeed (Done collected) + else + value <- map cStr + + collected + |> Dict.insert fieldId value + |> Loop + +RowField : { + name : Str, + column : Result { tableOid : I32, attributeNumber : I16 } [NotAColumn], + dataTypeOid : I32, + dataTypeSize : I16, + typeModifier : I32, + formatCode : I16, +} + +rowDescription : Decode Message _ +rowDescription = + fieldCount <- await i16 + + fixedList fieldCount rowField + |> map RowDescription + +rowField : Decode RowField _ +rowField = + name <- await cStr + tableOid <- await i32 + attributeNumber <- await i16 + dataTypeOid <- await i32 + dataTypeSize <- await i16 + typeModifier <- await i32 + formatCode <- map i16 + + column = + if tableOid != 0 && attributeNumber != 0 then + Ok { tableOid, attributeNumber } + else + Err NotAColumn + + { + name, + column, + dataTypeOid, + dataTypeSize, + typeModifier, + formatCode, + } + +dataRow : Decode Message _ +dataRow = + columnCount <- await i16 + + fixedList + columnCount + ( + valueLen <- await i32 + + if valueLen == -1 then + succeed [] + else + take (Num.toNat valueLen) \x -> x + ) + |> map DataRow + +fixedList = \count, itemDecode -> + collected <- loop (List.withCapacity (Num.toNat count)) + + item <- map itemDecode + + added = List.append collected item + + if List.len added == Num.toNat count then + Done added + else + Loop added + +commandComplete : Decode Message _ +commandComplete = + map cStr CommandComplete diff --git a/samples/Roc/PgSchema.roc b/samples/Roc/PgSchema.roc new file mode 100644 index 0000000000..c1d4dd6ded --- /dev/null +++ b/samples/Roc/PgSchema.roc @@ -0,0 +1,223 @@ +# From https://github.com/agu-z/roc-pg/blob/main/sql-cli/src/Schema.roc +# License is UPL +interface Schema + exposes [ + Schema, + ColumnId, + Table, + Column, + new, + getName, + getTables, + primaryColumn, + ] + imports [] + +Nullable a : [Null, NotNull a] + +Schema := { + name : Str, + tables : List Table, + references : Dict ColumnId ColumnId, + primaryColumns : Dict ColumnId { tableName : Str, columnName : Str }, +} + +ColumnId : (I32, I16) + +Table : { + id : I32, + name : Str, + columns : List Column, + constraints : List Constraint, +} + +Column : { + num : I16, + name : Str, + dataType : Str, + typeCategory : Str, + elemDataType : Nullable Str, + isNullable : Bool, +} + +Constraint : { + type : Str, + columns : List I16, + foreignTable : I32, # pg sets this to 0 if not foreign key + foreignColumns : List I16, +} + +new : Str, List Table -> Schema +new = \schemaName, tables -> + tablesLen : Nat + tablesLen = List.len tables + + keys : { + primaryColumns : Dict ColumnId { tableName : Str, columnName : Str }, + references : Dict ColumnId ColumnId, + } + keys = + stateTable, table <- List.walk tables { + primaryColumns: Dict.withCapacity tablesLen, + references: Dict.withCapacity (tablesLen * 4), + } + state, constraint <- List.walk table.constraints stateTable + + when constraint.type is + "p" -> + newPrimaryColumns = + constraint.columns + |> List.map \colNum -> + + names = + when List.findFirst table.columns \col -> col.num == colNum is + Ok { name } -> + { + tableName: table.name, + columnName: name, + } + + Err NotFound -> + { + tableName: "\(Num.toStr table.id)", + columnName: "\(Num.toStr colNum)", + } + + ((table.id, colNum), names) + |> Dict.fromList + + { state & primaryColumns: Dict.insertAll state.primaryColumns newPrimaryColumns } + + "f" -> + newReferences = + constraint.columns + |> List.map2 constraint.foreignColumns \colNum, foreignColumn -> + ((table.id, colNum), (constraint.foreignTable, foreignColumn)) + |> Dict.fromList + + { state & references: Dict.insertAll state.references newReferences } + + _ -> + state + + @Schema { + name: schemaName, + tables, + primaryColumns: keys.primaryColumns, + references: keys.references, + } + +getTables : Schema -> List Table +getTables = \@Schema schema -> schema.tables + +getName : Schema -> Str +getName = \@Schema schema -> schema.name + +## Recursively find the final column referenced by another column. +## +## Returns itself if it's part of a primary key and no foreign key. +primaryColumn : Schema, + ColumnId + -> Result + { + id : ColumnId, + tableName : Str, + columnName : Str, + } + [KeyNotFound] +primaryColumn = \@Schema schema, column -> + when Dict.get schema.references column is + Ok refColumn -> + primaryColumn (@Schema schema) refColumn + + Err KeyNotFound -> + Dict.get schema.primaryColumns column + |> Result.map \names -> { + id: column, + tableName: names.tableName, + columnName: names.columnName, + } + +expect primaryColumn testSchema (1, 1) == Ok { id: (1, 1), tableName: "users", columnName: "id" } +expect primaryColumn testSchema (1, 2) == Err KeyNotFound +expect primaryColumn testSchema (2, 1) == Ok { id: (2, 1), tableName: "posts", columnName: "id" } +expect primaryColumn testSchema (2, 2) == Ok { id: (1, 1), tableName: "users", columnName: "id" } +expect primaryColumn testSchema (2, 3) == Err KeyNotFound + +testSchema = + new "public" [ + { + id: 1, + name: "users", + columns: [ + { + num: 1, + name: "id", + dataType: "int4", + typeCategory: "N", + elemDataType: Null, + isNullable: Bool.false, + }, + { + num: 2, + name: "name", + dataType: "text", + typeCategory: "S", + elemDataType: Null, + isNullable: Bool.false, + }, + ], + constraints: [ + { + type: "p", + columns: [1], + foreignTable: 0, + foreignColumns: [], + }, + ], + }, + { + id: 2, + name: "posts", + columns: [ + { + num: 1, + name: "id", + dataType: "int4", + typeCategory: "N", + elemDataType: Null, + isNullable: Bool.false, + }, + { + num: 2, + name: "user_id", + dataType: "int4", + typeCategory: "N", + elemDataType: Null, + isNullable: Bool.false, + }, + { + num: 3, + name: "title", + dataType: "text", + typeCategory: "S", + elemDataType: Null, + isNullable: Bool.false, + }, + ], + constraints: [ + { + type: "p", + columns: [1], + foreignTable: 0, + foreignColumns: [], + }, + { + type: "f", + columns: [2], + foreignTable: 1, + foreignColumns: [1], + }, + ], + }, + ] diff --git a/vendor/README.md b/vendor/README.md index 98d03e1c29..dbc31ba562 100644 --- a/vendor/README.md +++ b/vendor/README.md @@ -477,6 +477,7 @@ This is a list of grammars that Linguist selects to provide syntax highlighting - **Ring:** [MahmoudFayed/atom-language-ring](https://github.com/MahmoudFayed/atom-language-ring) - **Riot:** [riot/syntax-highlight](https://github.com/riot/syntax-highlight) - **RobotFramework:** [shellderp/sublime-robot-plugin](https://github.com/shellderp/sublime-robot-plugin) +- **Roc:** [ivan-demchenko/roc-vscode-unofficial](https://github.com/ivan-demchenko/roc-vscode-unofficial) - **Roff:** [Alhadis/language-roff](https://github.com/Alhadis/language-roff) - **Roff Manpage:** [Alhadis/language-roff](https://github.com/Alhadis/language-roff) - **Rouge:** [atom/language-clojure](https://github.com/atom/language-clojure) diff --git a/vendor/grammars/roc-vscode-unofficial b/vendor/grammars/roc-vscode-unofficial new file mode 160000 index 0000000000..51a7a603b0 --- /dev/null +++ b/vendor/grammars/roc-vscode-unofficial @@ -0,0 +1 @@ +Subproject commit 51a7a603b0648c7cec4ab8aa655a2ca320e1652f diff --git a/vendor/licenses/git_submodule/roc-vscode-unofficial.dep.yml b/vendor/licenses/git_submodule/roc-vscode-unofficial.dep.yml new file mode 100644 index 0000000000..cdeb6e7b4c --- /dev/null +++ b/vendor/licenses/git_submodule/roc-vscode-unofficial.dep.yml @@ -0,0 +1,31 @@ +--- +name: roc-vscode-unofficial +version: 51a7a603b0648c7cec4ab8aa655a2ca320e1652f +type: git_submodule +homepage: https://github.com/ivan-demchenko/roc-vscode-unofficial.git +license: mit +licenses: +- sources: LICENSE + text: | + MIT License + + Copyright (c) 2023 Ivan Demchenko + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. +notices: []