diff --git a/bin/index.js b/bin/index.js index de898e899..41cc26080 100755 --- a/bin/index.js +++ b/bin/index.js @@ -24,6 +24,7 @@ const ioRefs = {}; const mVars = {}; const lockedFiles = {}; const processes = {}; +let state = null; const download = function (index, method, url) { const req = https.request(url, { method: method }, (res) => { @@ -433,10 +434,21 @@ const io = { const stats = fs.fstatSync(fd); this.send({ index, value: stats.size }); }, + hFlush: function (index, fd) { + // TODO no-op? + this.send({ index, value: null }); + }, withFile: function (index, filename, mode) { var fd = fs.openSync(filename, mode); this.send({ index, value: fd }); }, + statePut: function (index, value) { + state = value; + this.send({ index, value: null }); + }, + stateGet: function (index) { + this.send({ index, value: state }); + } }; const app = Elm.Terminal.Main.init(); diff --git a/reactor/assets/favicon.ico b/reactor/assets/favicon.ico deleted file mode 100644 index 41edb8103..000000000 Binary files a/reactor/assets/favicon.ico and /dev/null differ diff --git a/reactor/assets/source-code-pro.ttf b/reactor/assets/source-code-pro.ttf deleted file mode 100644 index 268a2e432..000000000 Binary files a/reactor/assets/source-code-pro.ttf and /dev/null differ diff --git a/reactor/assets/source-sans-pro.ttf b/reactor/assets/source-sans-pro.ttf deleted file mode 100644 index 950ff8bd4..000000000 Binary files a/reactor/assets/source-sans-pro.ttf and /dev/null differ diff --git a/reactor/assets/styles.css b/reactor/assets/styles.css deleted file mode 100644 index e6c18ca17..000000000 --- a/reactor/assets/styles.css +++ /dev/null @@ -1,157 +0,0 @@ -@charset "UTF-8"; - - -/* FONTS */ - -@font-face { - font-family: 'Source Code Pro'; - font-style: normal; - font-weight: 400; - src: local('Source Code Pro'), local('SourceCodePro-Regular'), url(/_elm/source-code-pro.ttf) format('truetype'); -} - -@font-face { - font-family: 'Source Sans Pro'; - font-style: normal; - font-weight: 400; - src: local('Source Sans Pro'), local('SourceSansPro-Regular'), url(/_elm/source-sans-pro.ttf) format('truetype'); -} - - -/* GENERIC STUFF */ - -html, head, body { - margin: 0; - height: 100%; -} - -body { - font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif; - color: #293c4b; -} - -a { - color: #60B5CC; - text-decoration: none; -} - -a:hover { - text-decoration: underline; -} - - -/* INDEX */ - -.header { - width: 100%; - background-color: #60B5CC; - height: 8px; -} - -.content { - width: 960px; - margin-left: auto; - margin-right: auto; -} - - -/* COLUMNS */ - -.left-column { - float: left; - width: 600px; - padding-bottom: 80px; -} - -.right-column { - float: right; - width: 300px; - padding-bottom: 80px; -} - - -/* BOXES */ - -.box { - border: 1px solid #c7c7c7; - border-radius: 5px; - margin-bottom: 40px; -} - -.box-header { - display: block; - overflow: hidden; - padding: 7px 12px; - background-color: #fafafa; - text-align: center; - border-radius: 5px; -} - -.box-item { - display: block; - overflow: hidden; - padding: 7px 12px; - border-top: 1px solid #e1e1e1; -} - -.box-footer { - display: block; - overflow: hidden; - padding: 2px 12px; - border-top: 1px solid #e1e1e1; - text-align: center; - background-color: #fafafa; - height: 16px; -} - - -/* ICONS */ - -.icon { - display: inline-block; - vertical-align: middle; - padding-right: 0.5em; -} - - -/* PAGES */ - -.page-name { - float: left; -} - -.page-size { - float: right; - color: #293c4b; -} - -.page-size:hover { - color: #60B5CC; -} - - -/* WAITING */ - -.waiting { - width: 100%; - height: 100%; - display: flex; - flex-direction: column; - justify-content: center; - align-items: center; - color: #9A9A9A; -} - - -/* NOT FOUND */ - -.not-found { - width: 100%; - height: 100%; - display: flex; - flex-direction: column; - justify-content: center; - align-items: center; - background-color: #F5F5F5; - color: #9A9A9A; -} diff --git a/reactor/check.py b/reactor/check.py deleted file mode 100755 index 9aced8b25..000000000 --- a/reactor/check.py +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env python - -import os -import sys - - -## FIGURE OUT NEW MODIFICATION TIME - -def mostRecentModification(directory): - mostRecent = 0 - - for dirpath, dirs, files in os.walk(directory): - for f in files: - lastModified = os.path.getmtime(dirpath + '/' + f) - mostRecent = max(int(lastModified), mostRecent) - - return mostRecent - - -srcTime = mostRecentModification('ui/src') -assetTime = mostRecentModification('ui/assets') -mostRecent = max(srcTime, assetTime) - - -## FIGURE OUT OLD MODIFICATION TIME - -with open('ui/last-modified', 'a') as handle: - pass - - -prevMostRecent = 0 - - -with open('ui/last-modified', 'r+') as handle: - line = handle.read() - prevMostRecent = int(line) if line else 0 - - -## TOUCH FILES IF NECESSARY - -if mostRecent > prevMostRecent: - print "+------------------------------------------------------------+" - print "| Some ui/ code changed. Touching src/Reactor/StaticFiles.hs |" - print "| to trigger a recompilation of the Template Haskell stuff. |" - print "+------------------------------------------------------------+" - os.utime('src/Reactor/StaticFiles.hs', None) - with open('ui/last-modified', 'w') as handle: - handle.write(str(mostRecent)) diff --git a/reactor/elm.json b/reactor/elm.json deleted file mode 100644 index 3a8a77209..000000000 --- a/reactor/elm.json +++ /dev/null @@ -1,31 +0,0 @@ -{ - "type": "application", - "source-directories": [ - "src" - ], - "elm-version": "0.19.1", - "dependencies": { - "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", - "elm/html": "1.0.0", - "elm/http": "2.0.0", - "elm/json": "1.1.2", - "elm/project-metadata-utils": "1.0.0", - "elm/svg": "1.0.1", - "elm-explorations/markdown": "1.0.0" - }, - "indirect": { - "elm/bytes": "1.0.7", - "elm/file": "1.0.1", - "elm/parser": "1.1.0", - "elm/time": "1.0.0", - "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} diff --git a/reactor/src/Deps.elm b/reactor/src/Deps.elm deleted file mode 100644 index 2046bfd16..000000000 --- a/reactor/src/Deps.elm +++ /dev/null @@ -1,1313 +0,0 @@ -module Deps exposing (main) - -import Browser -import Browser.Dom as Dom -import Compiler.Elm.Constraint as Constraint exposing (Constraint) -import Dict exposing (Dict) -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Html.Keyed as Keyed -import Html.Lazy exposing (..) -import Http -import Json.Decode as D -import Json.Encode as E -import Svg -import Svg.Attributes as S -import Task - - - --- MAIN - - -main : Program () Model Msg -main = - Browser.document - { init = init - , view = view - , update = update - , subscriptions = \_ -> Sub.none - } - - - --- MODEL - - -type alias Model = - { status : Status - , id : Int - - -- queries - , search : Search - , registry : Registry - - -- history - , past : List Change - , future : List Change - , origin : Origin - } - - - --- STATUS - - -type Status - = Failure Checkpoint (List Change) - | Waiting Checkpoint (List Change) - | Success Checkpoint - - -type alias Checkpoint = - { direct : Dict String Bounds - , indirect : Dict String Bounds - } - - -type Bounds - = New Version NewBounds - | Old Version Version OldBounds - - -type NewBounds - = NAny - | NCustom Constraint - - -type OldBounds - = OLocked - | OPatch - | OMinor - | OMajor - | OAny - | OCustom Constraint - - - --- CHANGES - - -type Change - = MassLock - | MassPatch - | MassMinor - | MassMajor - | AddDirect String - | TweakOldDirect String OldBounds - | TweakNewDirect String NewBounds - | TweakOldIndirect String OldBounds - | TweakNewIndirect String NewBounds - | DeleteDirect String - | DeleteIndirect String - - - --- PREVIEW - - -type alias Preview = - { direct : Dict String PBounds - , indirect : Dict String PBounds - } - - -type PBounds - = PNew (Maybe Version) NewBounds - | POld Version Version OldBounds - - -toPreview : Origin -> Checkpoint -> List Change -> Preview -toPreview origin checkpoint changes = - let - toPreviewBounds _ bounds = - case bounds of - New vsn nb -> - PNew (Just vsn) nb - - Old old new ob -> - POld old new ob - - start = - { direct = Dict.map toPreviewBounds checkpoint.direct - , indirect = Dict.map toPreviewBounds checkpoint.indirect - } - in - List.foldr (step origin) start changes - - -step : Origin -> Change -> Preview -> Preview -step origin change preview = - case change of - MassLock -> - massChange OLocked preview - - MassPatch -> - massChange OPatch preview - - MassMinor -> - massChange OMinor preview - - MassMajor -> - massChange OMajor preview - - AddDirect pkg -> - let - pBound = - case Dict.get pkg origin.direct of - Just vsn -> - POld vsn vsn OLocked - - Nothing -> - case Dict.get pkg origin.indirect of - Just vsn -> - POld vsn vsn OLocked - - Nothing -> - PNew Nothing NAny - in - { direct = Dict.insert pkg pBound preview.direct - , indirect = Dict.remove pkg preview.indirect - } - - TweakOldDirect pkg oldBounds -> - { direct = Dict.update pkg (alterOld oldBounds) preview.direct - , indirect = preview.indirect - } - - TweakNewDirect pkg newBounds -> - { direct = Dict.update pkg (alterNew newBounds) preview.direct - , indirect = preview.indirect - } - - TweakOldIndirect pkg oldBounds -> - { direct = preview.direct - , indirect = Dict.update pkg (alterOld oldBounds) preview.indirect - } - - TweakNewIndirect pkg newBounds -> - { direct = preview.direct - , indirect = Dict.update pkg (alterNew newBounds) preview.indirect - } - - DeleteDirect pkg -> - { direct = Dict.remove pkg preview.direct - , indirect = preview.indirect - } - - DeleteIndirect pkg -> - { direct = preview.direct - , indirect = Dict.remove pkg preview.indirect - } - - -massChange : OldBounds -> Preview -> Preview -massChange oldBounds preview = - let - changeBounds _ bounds = - case bounds of - PNew vsn newBounds -> - PNew vsn newBounds - - POld old new _ -> - POld old new oldBounds - in - { direct = Dict.map changeBounds preview.direct - , indirect = Dict.map changeBounds preview.indirect - } - - -alterOld : OldBounds -> Maybe PBounds -> Maybe PBounds -alterOld ob maybeBounds = - maybeBounds - |> Maybe.map - (\bounds -> - case bounds of - PNew vsn nb -> - PNew vsn nb - - POld old new _ -> - POld old new ob - ) - - -alterNew : NewBounds -> Maybe PBounds -> Maybe PBounds -alterNew nb maybeBounds = - maybeBounds - |> Maybe.map - (\bounds -> - case bounds of - PNew vsn _ -> - PNew vsn nb - - POld old new ob -> - POld old new ob - ) - - - --- INIT - - -init : () -> ( Model, Cmd Msg ) -init () = - let - origin = - startTODO - - chkp = - toInitialCheckpoint origin - in - await chkp - [] - { status = Waiting chkp [] - , id = 0 - , search = { query = "", focus = Nothing } - , registry = registryTODO - , past = [] - , future = [] - , origin = origin - } - - -type alias Origin = - { direct : Dict String Version - , indirect : Dict String Version - } - - -startTODO : Origin -startTODO = - { direct = - Dict.fromList - [ ( "elm/browser", Version 1 0 1 ) - , ( "elm/core", Version 1 0 2 ) - , ( "elm/html", Version 1 0 0 ) - , ( "elm/http", Version 2 0 0 ) - , ( "elm/json", Version 1 1 2 ) - , ( "elm/project-metadata-utils", Version 1 0 0 ) - , ( "elm/svg", Version 1 0 1 ) - , ( "elm-explorations/markdown", Version 1 0 0 ) - ] - , indirect = - Dict.fromList - [ ( "elm/parser", Version 1 1 0 ) - , ( "elm/time", Version 1 0 0 ) - , ( "elm/url", Version 1 0 0 ) - , ( "elm/virtual-dom", Version 1 0 2 ) - ] - } - - - --- CHECKPOINTS - - -toInitialCheckpoint : Origin -> Checkpoint -toInitialCheckpoint origin = - { direct = Dict.map (\_ v -> Old v v OLocked) origin.direct - , indirect = Dict.map (\_ v -> Old v v OLocked) origin.indirect - } - - -toCheckpoint : Dict String Version -> Preview -> Maybe Checkpoint -toCheckpoint solution preview = - let - direct = - Dict.foldr (addBound solution) Dict.empty preview.direct - - indirect = - Dict.foldr (addBound solution) Dict.empty preview.indirect - in - if Dict.size direct == Dict.size preview.direct then - Just (Checkpoint direct indirect) - - else - Nothing - - -addBound : Dict String Version -> String -> PBounds -> Dict String Bounds -> Dict String Bounds -addBound solution pkg bounds dict = - case Dict.get pkg solution of - Nothing -> - dict - - Just new -> - case bounds of - PNew _ newBounds -> - Dict.insert pkg (New new newBounds) dict - - POld old _ oldBounds -> - Dict.insert pkg (Old old new oldBounds) dict - - - --- UPDATE - - -type Msg - = NoOp - | Commit Change - | Undo - | Redo - | GotSolution Int (Result Http.Error (Dict String Version)) - | SearchTouched SearchMsg - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - NoOp -> - ( model, Cmd.none ) - - Commit latest -> - let - ( checkpoint, changes ) = - getCheckpoint model.status - in - await checkpoint (latest :: changes) { model | future = [] } - - Undo -> - case getCheckpoint model.status of - ( checkpoint, latest :: previous ) -> - await checkpoint previous { model | future = latest :: model.future } - - ( _, [] ) -> - case model.past of - [] -> - ( model, Cmd.none ) - - latest :: previous -> - await (toInitialCheckpoint model.origin) - previous - { model | past = [], future = latest :: model.future } - - Redo -> - case model.future of - [] -> - ( model, Cmd.none ) - - next :: nexterer -> - let - ( checkpoint, changes ) = - getCheckpoint model.status - in - await checkpoint (next :: changes) { model | future = nexterer } - - GotSolution id result -> - if model.id /= id then - ( model, Cmd.none ) - - else - let - ( oldCheckpoint, changes ) = - getCheckpoint model.status - in - case result of - Err _ -> - ( { model | status = Failure oldCheckpoint changes }, Cmd.none ) - - Ok solution -> - case toCheckpoint solution (toPreview model.origin oldCheckpoint changes) of - Nothing -> - ( { model | status = Failure oldCheckpoint changes } - , Cmd.none - ) - - Just newCheckpoint -> - ( { model - | status = Success newCheckpoint - , past = changes ++ model.past - } - , Cmd.none - ) - - SearchTouched searchMsg -> - case updateSearch model.registry searchMsg model.search of - SNone -> - ( model, Cmd.none ) - - SUpdate newSearch -> - ( { model | search = newSearch } - , Cmd.none - ) - - SManualBlur newSearch -> - ( { model | search = newSearch } - , Task.attempt (\_ -> NoOp) (Dom.blur searchDepsID) - ) - - SAdd name -> - let - ( checkpoint, changes ) = - getCheckpoint model.status - in - await checkpoint - (AddDirect name :: changes) - { model - | search = { query = "", focus = Nothing } - , future = [] - } - - -getCheckpoint : Status -> ( Checkpoint, List Change ) -getCheckpoint status = - case status of - Failure chkp cs -> - ( chkp, cs ) - - Waiting chkp cs -> - ( chkp, cs ) - - Success chkp -> - ( chkp, [] ) - - -await : Checkpoint -> List Change -> Model -> ( Model, Cmd Msg ) -await checkpoint changes model = - let - id = - model.id + 1 - - preview = - toPreview model.origin checkpoint changes - in - ( { model - | status = Waiting checkpoint changes - , id = id - } - , Http.post - { url = "/guida-stuff/solve" - , body = - Http.jsonBody <| - E.object - [ ( "direct", E.dict identity encodeConstraint preview.direct ) - , ( "indirect", E.dict identity encodeConstraint preview.indirect ) - ] - , expect = Http.expectJson (GotSolution id) solutionDecoder - } - ) - - - --- VIEW - - -view : Model -> Browser.Document Msg -view model = - { title = "elm.json" - , body = - [ span - [ style "width" "calc(100% - 500px - 2em)" - , style "position" "fixed" - , style "top" "0" - , style "left" "0" - , style "bottom" "0" - , style "overflow-x" "hidden" - , style "overflow-y" "scroll" - , style "filter" "blur(4px)" - , style "white-space" "pre" - , style "font-family" "monospace" - ] - [ text elmJson - ] - , viewEditPanel model - ] - } - - -viewEditPanel : Model -> Html Msg -viewEditPanel model = - div - [ style "width" "500px" - , style "position" "fixed" - , style "top" "0" - , style "right" "0" - , style "bottom" "0" - , style "overflow-y" "scroll" - , style "background-color" "white" - , style "padding" "1em" - ] - [ node "style" [] [ text styles ] - , div - [ style "display" "flex" - , style "justify-content" "space-between" - ] - [ viewMassUpdates - , lazy3 viewUndoRedo model.status model.past model.future - ] - , div - [ style "display" "flex" - , style "justify-content" "space-between" - , style "align-items" "center" - ] - [ h2 [] [ text "Dependencies" ] - , Html.map SearchTouched <| - lazy4 viewSearch searchDepsID "Package Search" model.registry model.search - ] - , lazy2 viewStatus model.origin model.status - ] - - -viewMassUpdates : Html Msg -viewMassUpdates = - div [] - [ text "Mass Updates: " - , activeButton (Commit MassLock) (text "LOCK") - , activeButton (Commit MassPatch) (text "PATCH") - , activeButton (Commit MassMinor) (text "MINOR") - , activeButton (Commit MassMajor) (text "MAJOR") - ] - - -viewUndoRedo : Status -> List Change -> List Change -> Html Msg -viewUndoRedo status past future = - let - hasNoPast = - List.isEmpty past - && (case status of - Failure _ cs -> - List.isEmpty cs - - Waiting _ cs -> - List.isEmpty cs - - Success _ -> - True - ) - - hasNoFuture = - List.isEmpty future - in - div [] - [ if hasNoPast then - inactiveButton undoIcon - - else - activeButton Undo undoIcon - , if hasNoFuture then - inactiveButton redoIcon - - else - activeButton Redo redoIcon - ] - - -activeButton : msg -> Html msg -> Html msg -activeButton msg content = - button [ class "button", onClick msg ] [ content ] - - -inactiveButton : Html msg -> Html msg -inactiveButton content = - button [ class "button-inactive" ] [ content ] - - - --- VIEW STATUS - - -viewStatus : Origin -> Status -> Html Msg -viewStatus origin status = - let - ( directs, indirects ) = - viewStatusRows origin status - in - div [] - [ viewTable "Direct" <| Dict.toList directs - , viewTable "Indirect" <| Dict.toList indirects - ] - - -viewStatusRows : Origin -> Status -> ( Dict String (Html Msg), Dict String (Html Msg) ) -viewStatusRows origin status = - case status of - Failure checkpoint changes -> - let - preview = - toPreview origin checkpoint changes - in - ( Dict.map (lazy2 viewWaitingRow) preview.direct - , Dict.map (lazy2 viewWaitingRow) preview.indirect - ) - - Waiting checkpoint changes -> - let - preview = - toPreview origin checkpoint changes - in - ( Dict.map (lazy2 viewWaitingRow) preview.direct - , Dict.map (lazy2 viewWaitingRow) preview.indirect - ) - - Success checkpoint -> - ( Dict.map (lazy2 viewSuccessRow) checkpoint.direct - , Dict.map (lazy2 viewSuccessRow) checkpoint.indirect - ) - - -viewSuccessRow : String -> Bounds -> Html Msg -viewSuccessRow pkg bounds = - case bounds of - New version _ -> - viewRow pkg (RowNew version) - - Old old new _ -> - viewRow pkg (RowOld old new) - - -viewWaitingRow : String -> PBounds -> Html Msg -viewWaitingRow pkg bounds = - case bounds of - PNew vsn _ -> - viewRow pkg (RowNewGuess vsn) - - POld old new _ -> - viewRow pkg (RowOldGuess old new) - - - --- VIEW TABLE - - -viewTable : String -> List ( String, Html Msg ) -> Html Msg -viewTable title rows = - table [ style "padding-bottom" "1em" ] - [ viewColgroup - , thead [] [ tr [] [ td [ class "table-title" ] [ text title ] ] ] - , Keyed.node "tbody" [] rows - ] - - -viewColgroup : Html msg -viewColgroup = - colgroup [] - [ col [ style "width" "350px" ] [] - , col [ style "width" "50px" ] [] - , col [ style "width" "50px" ] [] - , col [ style "width" "50px" ] [] - ] - - -type RowInfo - = RowNew Version - | RowOld Version Version - | RowNewGuess (Maybe Version) - | RowOldGuess Version Version - - -viewRow : String -> RowInfo -> Html msg -viewRow pkg info = - case info of - RowNew vsn -> - viewRowHelp pkg (text "") (text "") (viewVersion "black" vsn) - - RowNewGuess Nothing -> - viewRowHelp pkg (text "") (text "") (text "") - - RowNewGuess (Just v) -> - viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" v) - - RowOld old new -> - if old == new then - viewRowHelp pkg (text "") (text "") (viewVersion "#cccccc" new) - - else - viewRowHelp pkg (viewVersion "#cccccc" old) (viewArrow "#cccccc") (viewVersion "black" new) - - RowOldGuess old new -> - if old == new then - viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" new) - - else - viewRowHelp pkg (viewVersion "#eeeeee" old) (viewArrow "#eeeeee") (viewVersion "#eeeeee" new) - - -viewRowHelp : String -> Html msg -> Html msg -> Html msg -> Html msg -viewRowHelp pkg oldHtml arrowHtml newHtml = - tr [] - [ td [ style "font-family" "monospace" ] [ text pkg ] - , td [ style "text-align" "right" ] [ oldHtml ] - , td [ style "text-align" "center" ] [ arrowHtml ] - , td [] [ newHtml ] - ] - - -viewVersion : String -> Version -> Html msg -viewVersion color (Version x y z) = - span - [ style "font-family" "monospace" - , style "color" color - , style "transition" "color 1s" - ] - [ text (v2s x y z) - ] - - -viewArrow : String -> Html msg -viewArrow color = - span - [ style "color" color - , style "transition" "color 1s" - ] - [ text "→" - ] - - - --- REGISTRY - - -type alias Registry = - Dict String (List Char) - - -toRegistry : List String -> Registry -toRegistry packages = - Dict.fromList (List.map (\n -> ( n, toSearchChars n )) packages) - - -toSearchChars : String -> List Char -toSearchChars string = - String.toList (String.toLower string) - - -registryTODO : Registry -registryTODO = - toRegistry - [ "elm-explorations/test" - , "elm-explorations/markdown" - , "elm/browser" - , "elm/bytes" - , "elm/core" - , "elm/file" - , "elm/html" - , "elm/http" - , "elm/json" - , "elm/project-metadata-utils" - , "elm/svg" - , "elm/parser" - , "elm/time" - , "elm/url" - , "elm/virtual-dom" - ] - - - --- SEARCH - - -type alias Search = - { query : String - , focus : Maybe Int - } - - -type SearchMsg - = SChanged String - | SUp - | SDown - | SFocus - | SBlur - | SEscape - | SEnter - | SClickAdd - | SClickMatch String - - -type SearchNext - = SNone - | SUpdate Search - | SManualBlur Search - | SAdd String - - -updateSearch : Registry -> SearchMsg -> Search -> SearchNext -updateSearch registry msg search = - case msg of - SChanged query -> - SUpdate { query = query, focus = Just 0 } - - SUp -> - let - newFocus = - Maybe.map (\n -> Basics.max 0 (n - 1)) search.focus - in - SUpdate { search | focus = newFocus } - - SDown -> - let - numMatches = - List.length (getBestMatches search.query registry) - - newFocus = - Maybe.map (\n -> Basics.min numMatches (n + 1)) search.focus - in - SUpdate { search | focus = newFocus } - - SFocus -> - SUpdate { search | focus = Just 0 } - - SBlur -> - SUpdate { search | focus = Nothing } - - SEscape -> - SManualBlur { search | focus = Nothing } - - SEnter -> - case search.focus of - Nothing -> - SNone - - Just 0 -> - if Dict.member search.query registry then - SAdd search.query - - else - SNone - - Just n -> - case getMatch n (getBestMatches search.query registry) of - Just match -> - SUpdate { query = match, focus = Just 0 } - - Nothing -> - SNone - - SClickAdd -> - if Dict.member search.query registry then - SAdd search.query - - else - SNone - - SClickMatch match -> - SUpdate { query = match, focus = Just 0 } - - -getMatch : Int -> List ( Int, String ) -> Maybe String -getMatch n matches = - case matches of - [] -> - Nothing - - ( _, match ) :: worseMatches -> - if n <= 0 then - Nothing - - else if n == 1 then - Just match - - else - getMatch (n - 1) worseMatches - - - --- VIEW SEARCH - - -searchDepsID : String -searchDepsID = - "search-deps" - - -viewSearch : String -> String -> Registry -> Search -> Html SearchMsg -viewSearch searchID ghostText registry search = - div [ style "position" "relative" ] - [ lazy3 viewSearchQuery searchID ghostText search.query - , lazy2 viewSearchAdd search.query registry - , lazy3 viewSearchMatches search.query search.focus registry - ] - - -viewSearchAdd : String -> Registry -> Html SearchMsg -viewSearchAdd query registry = - if Dict.member query registry then - activeButton SClickAdd (text "Add") - - else - inactiveButton (text "Add") - - -viewSearchMatches : String -> Maybe Int -> Registry -> Html SearchMsg -viewSearchMatches query focus registry = - case focus of - Nothing -> - text "" - - Just n -> - if String.isEmpty query then - text "" - - else - case getBestMatches query registry of - [] -> - text "" - - bestMatches -> - div [ class "search-matches" ] <| - List.indexedMap (viewSearchMatch (n - 1)) bestMatches - - -viewSearchMatch : Int -> Int -> ( Int, String ) -> Html SearchMsg -viewSearchMatch target actual ( _, name ) = - div - [ class "search-match" - , classList [ ( "search-match-focused", target == actual ) ] - , onClick (SClickMatch name) - ] - [ div [ style "padding" "0.5em 1em" ] [ text name ] - ] - - - --- VIEW SEARCH QUERY - - -viewSearchQuery : String -> String -> String -> Html SearchMsg -viewSearchQuery searchID ghostText query = - input - [ type_ "text" - , id searchID - , placeholder ghostText - , autocomplete False - , class "search-input" - , value query - , onInput SChanged - , on "keydown" keyDecoder - , onFocus SFocus - , onBlur SBlur - ] - [] - - -keyDecoder : D.Decoder SearchMsg -keyDecoder = - let - check up down enter escape value = - if value == up then - D.succeed SUp - - else if value == down then - D.succeed SDown - - else if value == enter then - D.succeed SEnter - - else if value == escape then - D.succeed SEscape - - else - D.fail "not up or down" - in - D.oneOf - [ D.field "key" D.string - |> D.andThen (check "ArrowUp" "ArrowDown" "Enter" "Escape") - , D.field "keyCode" D.int - |> D.andThen (check 38 40 13 27) - ] - - - --- MATCHES - - -getBestMatches : String -> Registry -> List ( Int, String ) -getBestMatches query registry = - Dict.foldl (addMatch (toSearchChars query)) [] registry - - -addMatch : List Char -> String -> List Char -> List ( Int, String ) -> List ( Int, String ) -addMatch queryChars targetName targetChars bestMatches = - case distance 0 queryChars targetChars of - Nothing -> - bestMatches - - Just dist -> - insert 4 targetName dist bestMatches - - -insert : Int -> String -> Int -> List ( Int, String ) -> List ( Int, String ) -insert limit name dist bestMatches = - if limit <= 0 then - bestMatches - - else - case bestMatches of - [] -> - [ ( dist, name ) ] - - (( bestDist, _ ) as best) :: worseMatches -> - if dist < bestDist then - ( dist, name ) :: List.take (limit - 1) bestMatches - - else - best :: insert (limit - 1) name dist worseMatches - - -distance : Int -> List Char -> List Char -> Maybe Int -distance dist queryChars targetChars = - case queryChars of - [] -> - case dist + List.length targetChars of - 0 -> - Nothing - - n -> - Just n - - qc :: qcs -> - case targetChars of - [] -> - Nothing - - tc :: tcs -> - if qc == tc then - distance dist qcs tcs - - else - distance (dist + 1) queryChars tcs - - - --- ICONS - - -undoIcon : Html msg -undoIcon = - icon "M255.545 8c-66.269.119-126.438 26.233-170.86 68.685L48.971 40.971C33.851 25.851 8 36.559 8 57.941V192c0 13.255 10.745 24 24 24h134.059c21.382 0 32.09-25.851 16.971-40.971l-41.75-41.75c30.864-28.899 70.801-44.907 113.23-45.273 92.398-.798 170.283 73.977 169.484 169.442C423.236 348.009 349.816 424 256 424c-41.127 0-79.997-14.678-110.63-41.556-4.743-4.161-11.906-3.908-16.368.553L89.34 422.659c-4.872 4.872-4.631 12.815.482 17.433C133.798 479.813 192.074 504 256 504c136.966 0 247.999-111.033 248-247.998C504.001 119.193 392.354 7.755 255.545 8z" - - -redoIcon : Html msg -redoIcon = - icon "M256.455 8c66.269.119 126.437 26.233 170.859 68.685l35.715-35.715C478.149 25.851 504 36.559 504 57.941V192c0 13.255-10.745 24-24 24H345.941c-21.382 0-32.09-25.851-16.971-40.971l41.75-41.75c-30.864-28.899-70.801-44.907-113.23-45.273-92.398-.798-170.283 73.977-169.484 169.442C88.764 348.009 162.184 424 256 424c41.127 0 79.997-14.678 110.629-41.556 4.743-4.161 11.906-3.908 16.368.553l39.662 39.662c4.872 4.872 4.631 12.815-.482 17.433C378.202 479.813 319.926 504 256 504 119.034 504 8.001 392.967 8 256.002 7.999 119.193 119.646 7.755 256.455 8z" - - -icon : String -> Html msg -icon path = - div - [ style "display" "inline-flex" - , style "align-self" "center" - , style "top" ".125em" - , style "position" "relative" - ] - [ Svg.svg - [ S.viewBox "0 0 512 512" - , S.width "1em" - , S.height "1em" - ] - [ Svg.path - [ S.fill "currentColor" - , S.d path - ] - [] - ] - ] - - - --- VERSIONS - - -type Version - = Version Int Int Int - - - --- ENCODE CONSTRAINTS - - -encodeConstraint : PBounds -> E.Value -encodeConstraint bounds = - case bounds of - POld (Version x y z) _ oldBounds -> - case oldBounds of - OLocked -> - E.string <| v2s x y z ++ " <= v < " ++ v2s x y (z + 1) - - OPatch -> - E.string <| v2s x y z ++ " <= v < " ++ v2s x y max16 - - OMinor -> - E.string <| v2s x y z ++ " <= v < " ++ v2s x max16 0 - - OMajor -> - E.string <| v2s x y z ++ " <= v < " ++ v2s max16 0 0 - - OAny -> - encodeAny - - OCustom c -> - Constraint.encode c - - PNew _ newBounds -> - case newBounds of - NAny -> - encodeAny - - NCustom c -> - Constraint.encode c - - -encodeAny : E.Value -encodeAny = - E.string <| v2s 1 0 0 ++ " <= v <= " ++ v2s max16 max16 max16 - - -max16 : Int -max16 = - 65535 - - -v2s : Int -> Int -> Int -> String -v2s major minor patch = - String.fromInt major ++ "." ++ String.fromInt minor ++ "." ++ String.fromInt patch - - - --- DECODE SOLUTION - - -solutionDecoder : D.Decoder (Dict String Version) -solutionDecoder = - D.dict versionDecoder - - -versionDecoder : D.Decoder Version -versionDecoder = - let - toVersion str = - case fromString str of - Just vsn -> - D.succeed vsn - - Nothing -> - D.fail "invalid version number" - in - D.andThen toVersion D.string - - -fromString : String -> Maybe Version -fromString string = - case List.map String.toInt (String.split "." string) of - [ Just major, Just minor, Just patch ] -> - fromStringHelp major minor patch - - _ -> - Nothing - - -fromStringHelp : Int -> Int -> Int -> Maybe Version -fromStringHelp major minor patch = - if major >= 0 && minor >= 0 && patch >= 0 then - Just (Version major minor patch) - - else - Nothing - - - --- TODO delete everything below here - - -styles : String -styles = - """ -body { - font-family: sans-serif; - font-size: 16px; - background-color: #cccccc; -} -.search-input { - padding: 0.5em 1em; - border: 1px solid #cccccc; - border-radius: 2px; -} -.search-matches { - position: absolute; - top: 100%; - left: 0; - right: 0; - background-color: white; -} -.search-match { - border-left: 1px solid #cccccc; - border-right: 1px solid #cccccc; - border-bottom: 1px solid #cccccc; -} -.search-match:hover { - background-color: #eeeeee; - cursor: pointer; -} -.search-match-focused { - background-color: #60B5CC !important; - border-color: #60B5CC; - color: white; -} -.button { - padding: 0.5em 1em; - border: 1px solid #60B5CC; - background-color: white; - border-radius: 2px; - color: #60B5CC; -} -.button:hover { - color: white; - background-color: #60B5CC; -} -.button:active { - color: white; - border-color: #5A6378; - background-color: #5A6378; -} -.button-inactive { - padding: 0.5em 1em; - border: 1px solid #cccccc; - background-color: white; - border-radius: 2px; - color: #cccccc; -} -.table-title { - text-transform: uppercase; - color: #cccccc; - font-size: .75em; -} -""" - - -elmJson : String -elmJson = - """ -{ - "type": "application", - "source-directories": [ - "src" - ], - "elm-version": "0.19.0", - "dependencies": { - "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", - "elm/html": "1.0.0", - "elm/http": "2.0.0", - "elm/json": "1.1.2", - "elm/project-metadata-utils": "1.0.0", - "elm/svg": "1.0.1", - "elm-explorations/markdown": "1.0.0" - }, - "indirect": { - "elm/bytes": "1.0.7", - "elm/file": "1.0.1", - "elm/parser": "1.1.0", - "elm/time": "1.0.0", - "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} -""" diff --git a/reactor/src/Errors.elm b/reactor/src/Errors.elm deleted file mode 100644 index ed4b89110..000000000 --- a/reactor/src/Errors.elm +++ /dev/null @@ -1,245 +0,0 @@ -module Errors exposing (main) - -import Browser -import Compiler.Elm.Error as Error -import Html exposing (..) -import Html.Attributes exposing (..) -import Json.Decode as D -import String - - - --- MAIN - - -main : Program D.Value (Result D.Error Error.Error) msg -main = - Browser.document - { init = \flags -> ( D.decodeValue Error.decoder flags, Cmd.none ) - , update = \_ exit -> ( exit, Cmd.none ) - , view = view - , subscriptions = \_ -> Sub.none - } - - - --- VIEW - - -view : Result D.Error Error.Error -> Browser.Document msg -view result = - { title = "Problem!" - , body = - case result of - Err err -> - [ text (D.errorToString err) ] - - Ok error -> - [ viewError error ] - } - - -viewError : Error.Error -> Html msg -viewError error = - div - [ style "width" "100%" - , style "min-height" "100%" - , style "display" "flex" - , style "flex-direction" "column" - , style "align-items" "center" - , style "background-color" "rgb(39, 40, 34)" - , style "color" "rgb(233, 235, 235)" - , style "font-family" "monospace" - ] - [ div - [ style "display" "block" - , style "white-space" "pre-wrap" - , style "background-color" "black" - , style "padding" "2em" - ] - (viewErrorHelp error) - ] - - -viewErrorHelp : Error.Error -> List (Html msg) -viewErrorHelp error = - case error of - Error.GeneralProblem { path, title, message } -> - viewHeader title path :: viewMessage message - - Error.ModuleProblems badModules -> - viewBadModules badModules - - - --- VIEW HEADER - - -viewHeader : String -> Maybe String -> Html msg -viewHeader title maybeFilePath = - let - left = - "-- " ++ title ++ " " - - right = - case maybeFilePath of - Nothing -> - "" - - Just filePath -> - " " ++ filePath - in - span [ style "color" "rgb(51,187,200)" ] [ text (fill left right ++ "\n\n") ] - - -fill : String -> String -> String -fill left right = - left ++ String.repeat (80 - String.length left - String.length right) "-" ++ right - - - --- VIEW BAD MODULES - - -viewBadModules : List Error.BadModule -> List (Html msg) -viewBadModules badModules = - case badModules of - [] -> - [] - - [ badModule ] -> - [ viewBadModule badModule ] - - a :: b :: cs -> - viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs) - - -viewBadModule : Error.BadModule -> Html msg -viewBadModule { path, problems } = - span [] (List.map (viewProblem path) problems) - - -viewProblem : String -> Error.Problem -> Html msg -viewProblem filePath problem = - span [] (viewHeader problem.title (Just filePath) :: viewMessage problem.message) - - -viewSeparator : String -> String -> Html msg -viewSeparator before after = - span [ style "color" "rgb(211,56,211)" ] - [ text <| - String.padLeft 80 ' ' (before ++ " ↑ ") - ++ "\n" - ++ "====o======================================================================o====\n" - ++ " ↓ " - ++ after - ++ "\n\n\n" - ] - - - --- VIEW MESSAGE - - -viewMessage : List Error.Chunk -> List (Html msg) -viewMessage chunks = - case chunks of - [] -> - [ text "\n\n\n" ] - - chunk :: others -> - let - htmlChunk = - case chunk of - Error.Unstyled string -> - text string - - Error.Styled style string -> - span (styleToAttrs style) [ text string ] - in - htmlChunk :: viewMessage others - - -styleToAttrs : Error.Style -> List (Attribute msg) -styleToAttrs { bold, underline, color } = - addBold bold <| addUnderline underline <| addColor color [] - - -addBold : Bool -> List (Attribute msg) -> List (Attribute msg) -addBold bool attrs = - if bool then - style "font-weight" "bold" :: attrs - - else - attrs - - -addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg) -addUnderline bool attrs = - if bool then - style "text-decoration" "underline" :: attrs - - else - attrs - - -addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg) -addColor maybeColor attrs = - case maybeColor of - Nothing -> - attrs - - Just color -> - style "color" (colorToCss color) :: attrs - - -colorToCss : Error.Color -> String -colorToCss color = - case color of - Error.Red -> - "rgb(194,54,33)" - - Error.RED -> - "rgb(252,57,31)" - - Error.Magenta -> - "rgb(211,56,211)" - - Error.MAGENTA -> - "rgb(249,53,248)" - - Error.Yellow -> - "rgb(173,173,39)" - - Error.YELLOW -> - "rgb(234,236,35)" - - Error.Green -> - "rgb(37,188,36)" - - Error.GREEN -> - "rgb(49,231,34)" - - Error.Cyan -> - "rgb(51,187,200)" - - Error.CYAN -> - "rgb(20,240,240)" - - Error.Blue -> - "rgb(73,46,225)" - - Error.BLUE -> - "rgb(88,51,255)" - - Error.White -> - "rgb(203,204,205)" - - Error.WHITE -> - "rgb(233,235,235)" - - Error.Black -> - "rgb(0,0,0)" - - Error.BLACK -> - "rgb(129,131,131)" diff --git a/reactor/src/Index.elm b/reactor/src/Index.elm deleted file mode 100644 index e57d2129f..000000000 --- a/reactor/src/Index.elm +++ /dev/null @@ -1,281 +0,0 @@ -module Index exposing (main) - -import Browser -import Compiler.Elm.License as License -import Compiler.Elm.Package as Package -import Compiler.Elm.Project as Project -import Compiler.Elm.Version as Version -import Dict -import Html exposing (..) -import Html.Attributes exposing (class, href, style) -import Index.Icon as Icon -import Index.Navigator as Navigator -import Index.Skeleton as Skeleton -import Json.Decode as D - - - --- MAIN - - -main : Program D.Value Model Never -main = - Browser.document - { init = \flags -> ( D.decodeValue decoder flags, Cmd.none ) - , update = \_ model -> ( model, Cmd.none ) - , subscriptions = \_ -> Sub.none - , view = view - } - - - --- FLAGS - - -type alias Flags = - { root : String - , pwd : List String - , dirs : List String - , files : List File - , readme : Maybe String - , project : Maybe Project.Project - , exactDeps : Dict.Dict String Version.Version - } - - -type alias File = - { name : String - , runnable : Bool - } - - - --- DECODER - - -decoder : D.Decoder Flags -decoder = - D.map7 Flags - (D.field "root" D.string) - (D.field "pwd" (D.list D.string)) - (D.field "dirs" (D.list D.string)) - (D.field "files" (D.list fileDecoder)) - (D.field "readme" (D.nullable D.string)) - (D.field "outline" (D.nullable Project.decoder)) - (D.field "exactDeps" (D.dict Version.decoder)) - - -fileDecoder : D.Decoder File -fileDecoder = - D.map2 File - (D.field "name" D.string) - (D.field "runnable" D.bool) - - - --- MODEL - - -type alias Model = - Result D.Error Flags - - - --- VIEW - - -view : Model -> Browser.Document msg -view model = - case model of - Err error -> - { title = "???" - , body = - [ text (D.errorToString error) - ] - } - - Ok { root, pwd, dirs, files, readme, project, exactDeps } -> - { title = String.join "/" ("~" :: pwd) - , body = - [ header [ class "header" ] [] - , div [ class "content" ] - [ Navigator.view root pwd - , viewLeftColumn dirs files readme - , viewRightColumn exactDeps project - , div [ style "clear" "both" ] [] - ] - ] - } - - -viewLeftColumn : List String -> List File -> Maybe String -> Html msg -viewLeftColumn dirs files readme = - section [ class "left-column" ] - [ viewFiles dirs files - , viewReadme readme - ] - - -viewRightColumn : ExactDeps -> Maybe Project.Project -> Html msg -viewRightColumn exactDeps maybeProject = - section [ class "right-column" ] <| - case maybeProject of - Nothing -> - [] - - Just project -> - [ viewProjectSummary project - , viewDeps exactDeps project - , viewTestDeps exactDeps project - ] - - - --- VIEW README - - -viewReadme : Maybe String -> Html msg -viewReadme readme = - case readme of - Nothing -> - text "" - - Just markdown -> - Skeleton.readmeBox markdown - - - --- VIEW FILES - - -viewFiles : List String -> List File -> Html msg -viewFiles dirs files = - Skeleton.box - { title = "File Navigation" - , items = - List.filterMap viewDir (List.sort dirs) - ++ List.filterMap viewFile (List.sortBy .name files) - , footer = Nothing - } - - -viewDir : String -> Maybe (List (Html msg)) -viewDir dir = - if String.startsWith "." dir || dir == "guida-stuff" then - Nothing - - else - Just [ a [ href dir ] [ Icon.folder, text dir ] ] - - -viewFile : File -> Maybe (List (Html msg)) -viewFile { name } = - if String.startsWith "." name then - Nothing - - else - Just [ a [ href name ] [ Icon.lookup name, text name ] ] - - - --- VIEW PAGE SUMMARY - - -viewProjectSummary : Project.Project -> Html msg -viewProjectSummary project = - case project of - Project.Application info -> - Skeleton.box - { title = "Source Directories" - , items = List.map (\dir -> [ text dir ]) info.dirs - , footer = Nothing - } - - -- TODO show estimated bundle size here - Project.Package info -> - Skeleton.box - { title = "Package Info" - , items = - [ [ text ("Name: " ++ Package.toString info.name) ] - , [ text ("Version: " ++ Version.toString info.version) ] - , [ text ("License: " ++ License.toString info.license) ] - ] - , footer = Nothing - } - - - --- VIEW DEPENDENCIES - - -type alias ExactDeps = - Dict.Dict String Version.Version - - -viewDeps : ExactDeps -> Project.Project -> Html msg -viewDeps exactDeps project = - let - dependencies = - case project of - Project.Application info -> - List.map viewVersion info.depsDirect - - Project.Package info -> - List.map (viewConstraint exactDeps) info.deps - in - Skeleton.box - { title = "Dependencies" - , items = dependencies - , footer = Nothing -- TODO Just ("/_elm/dependencies", "Add more dependencies?") - } - - -viewTestDeps : ExactDeps -> Project.Project -> Html msg -viewTestDeps exactDeps project = - let - dependencies = - case project of - Project.Application info -> - List.map viewVersion info.testDepsDirect - - Project.Package info -> - List.map (viewConstraint exactDeps) info.testDeps - in - Skeleton.box - { title = "Test Dependencies" - , items = dependencies - , footer = Nothing -- TODO Just ("/_elm/test-dependencies", "Add more test dependencies?") - } - - -viewVersion : ( Package.Name, Version.Version ) -> List (Html msg) -viewVersion ( pkg, version ) = - [ div [ style "float" "left" ] - [ Icon.package - , a [ href (toPackageUrl pkg version) ] [ text (Package.toString pkg) ] - ] - , div [ style "float" "right" ] [ text (Version.toString version) ] - ] - - -viewConstraint : ExactDeps -> ( Package.Name, constraint ) -> List (Html msg) -viewConstraint exactDeps ( pkg, _ ) = - case Dict.get (Package.toString pkg) exactDeps of - Just vsn -> - viewVersion ( pkg, vsn ) - - Nothing -> - [ div [ style "float" "left" ] - [ Icon.package - , text (Package.toString pkg) - ] - , div [ style "float" "right" ] [ text "???" ] - ] - - -toPackageUrl : Package.Name -> Version.Version -> String -toPackageUrl name version = - "https://package.elm-lang.org/packages/" - ++ Package.toString name - ++ "/" - ++ Version.toString version diff --git a/reactor/src/Index/Icon.elm b/reactor/src/Index/Icon.elm deleted file mode 100644 index de5b4632e..000000000 --- a/reactor/src/Index/Icon.elm +++ /dev/null @@ -1,111 +0,0 @@ -module Index.Icon exposing - ( file - , folder - , gift - , home - , image - , lookup - , package - , plus - ) - -import Dict -import Html exposing (Html) -import Svg exposing (..) -import Svg.Attributes exposing (class, d, fill, height, viewBox, width) - - - --- ICON - - -icon : String -> String -> String -> Html msg -icon color size pathString = - svg - [ class "icon" - , width size - , height size - , viewBox "0 0 1792 1792" - ] - [ path [ fill color, d pathString ] [] - ] - - - --- NECESSARY ICONS - - -home : Html msg -home = - icon "#babdb6" "36px" "M1472 992v480q0 26-19 45t-45 19h-384v-384h-256v384h-384q-26 0-45-19t-19-45v-480q0-1 .5-3t.5-3l575-474 575 474q1 2 1 6zm223-69l-62 74q-8 9-21 11h-3q-13 0-21-7l-692-577-692 577q-12 8-24 7-13-2-21-11l-62-74q-8-10-7-23.5t11-21.5l719-599q32-26 76-26t76 26l244 204v-195q0-14 9-23t23-9h192q14 0 23 9t9 23v408l219 182q10 8 11 21.5t-7 23.5z" - - -image : Html msg -image = - icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-128-448v320h-1024v-192l192-192 128 128 384-384zm-832-192q-80 0-136-56t-56-136 56-136 136-56 136 56 56 136-56 136-136 56z" - - -file : Html msg -file = - icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-1024-864q0-14 9-23t23-9h704q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64zm736 224q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704zm0 256q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704z" - - -gift : Html msg -gift = - icon "#babdb6" "16px" "M1056 1356v-716h-320v716q0 25 18 38.5t46 13.5h192q28 0 46-13.5t18-38.5zm-456-844h195l-126-161q-26-31-69-31-40 0-68 28t-28 68 28 68 68 28zm688-96q0-40-28-68t-68-28q-43 0-69 31l-125 161h194q40 0 68-28t28-68zm376 256v320q0 14-9 23t-23 9h-96v416q0 40-28 68t-68 28h-1088q-40 0-68-28t-28-68v-416h-96q-14 0-23-9t-9-23v-320q0-14 9-23t23-9h440q-93 0-158.5-65.5t-65.5-158.5 65.5-158.5 158.5-65.5q107 0 168 77l128 165 128-165q61-77 168-77 93 0 158.5 65.5t65.5 158.5-65.5 158.5-158.5 65.5h440q14 0 23 9t9 23z" - - -folder : Html msg -folder = - icon "#babdb6" "16px" "M1728 608v704q0 92-66 158t-158 66h-1216q-92 0-158-66t-66-158v-960q0-92 66-158t158-66h320q92 0 158 66t66 158v32h672q92 0 158 66t66 158z" - - -package : Html msg -package = - icon "#babdb6" "16px" "M1088 832q0-26-19-45t-45-19h-256q-26 0-45 19t-19 45 19 45 45 19h256q26 0 45-19t19-45zm576-192v960q0 26-19 45t-45 19h-1408q-26 0-45-19t-19-45v-960q0-26 19-45t45-19h1408q26 0 45 19t19 45zm64-448v256q0 26-19 45t-45 19h-1536q-26 0-45-19t-19-45v-256q0-26 19-45t45-19h1536q26 0 45 19t19 45z" - - -plus : Html msg -plus = - icon "#babdb6" "16px" "M1600 736v192q0 40-28 68t-68 28h-416v416q0 40-28 68t-68 28h-192q-40 0-68-28t-28-68v-416h-416q-40 0-68-28t-28-68v-192q0-40 28-68t68-28h416v-416q0-40 28-68t68-28h192q40 0 68 28t28 68v416h416q40 0 68 28t28 68z" - - - --- LOOKUP - - -lookup : String -> Html msg -lookup fileName = - let - extension = - getExtension fileName - in - Maybe.withDefault file (Dict.get extension extensionIcons) - - -extensionIcons : Dict.Dict String (Html msg) -extensionIcons = - Dict.fromList - [ ( "jpg", image ) - , ( "jpeg", image ) - , ( "png", image ) - , ( "gif", image ) - ] - - -getExtension : String -> String -getExtension str = - getExtensionHelp (String.split "." str) - - -getExtensionHelp : List String -> String -getExtensionHelp segments = - case segments of - [] -> - "" - - [ ext ] -> - String.toLower ext - - _ :: rest -> - getExtensionHelp rest diff --git a/reactor/src/Index/Navigator.elm b/reactor/src/Index/Navigator.elm deleted file mode 100644 index 08650e8f4..000000000 --- a/reactor/src/Index/Navigator.elm +++ /dev/null @@ -1,63 +0,0 @@ -module Index.Navigator exposing (view) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Index.Icon as Icon - - - --- VIEW - - -view : String -> List String -> Html msg -view root dirs = - div - [ style "font-size" "2em" - , style "padding" "20px 0" - , style "display" "flex" - , style "align-items" "center" - , style "height" "40px" - ] - (makeLinks root dirs "" []) - - -makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg) -makeLinks root dirs oldPath revAnchors = - case dirs of - dir :: otherDirs -> - let - newPath = - oldPath ++ "/" ++ dir - - anchor = - a [ href newPath ] [ text dir ] - in - makeLinks root otherDirs newPath (anchor :: revAnchors) - - [] -> - let - home = - a - [ href "/" - , title root - , style "display" "inherit" - ] - [ Icon.home - ] - in - case revAnchors of - [] -> - [ home ] - - lastAnchor :: otherRevAnchors -> - home :: slash :: List.foldl addSlash [ lastAnchor ] otherRevAnchors - - -addSlash : Html msg -> List (Html msg) -> List (Html msg) -addSlash front back = - front :: slash :: back - - -slash : Html msg -slash = - span [ style "padding" "0 8px" ] [ text "/" ] diff --git a/reactor/src/Index/Skeleton.elm b/reactor/src/Index/Skeleton.elm deleted file mode 100644 index 60868cd6c..000000000 --- a/reactor/src/Index/Skeleton.elm +++ /dev/null @@ -1,61 +0,0 @@ -module Index.Skeleton exposing - ( box - , readmeBox - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Index.Icon as Icon -import Markdown - - - --- VIEW BOXES - - -type alias BoxArgs msg = - { title : String - , items : List (List (Html msg)) - , footer : Maybe ( String, String ) - } - - -box : BoxArgs msg -> Html msg -box { title, items, footer } = - let - realItems = - List.map (div [ class "box-item" ]) items - in - boxHelp title realItems footer - - -readmeBox : String -> Html msg -readmeBox markdown = - let - readme = - Markdown.toHtml [ class "box-item" ] markdown - in - boxHelp "README" [ readme ] Nothing - - -boxHelp : String -> List (Html msg) -> Maybe ( String, String ) -> Html msg -boxHelp boxTitle items footer = - div [ class "box" ] <| - div [ class "box-header" ] [ text boxTitle ] - :: items - ++ [ boxFooter footer ] - - -boxFooter : Maybe ( String, String ) -> Html msg -boxFooter maybeFooter = - case maybeFooter of - Nothing -> - text "" - - Just ( path, description ) -> - a - [ href path - , title description - ] - [ div [ class "box-footer" ] [ Icon.plus ] - ] diff --git a/reactor/src/NotFound.elm b/reactor/src/NotFound.elm deleted file mode 100644 index 2e1803bf0..000000000 --- a/reactor/src/NotFound.elm +++ /dev/null @@ -1,27 +0,0 @@ -module NotFound exposing (main) - -import Browser -import Html exposing (..) -import Html.Attributes exposing (..) - - -main : Program () () () -main = - Browser.document - { init = \_ -> ( (), Cmd.none ) - , update = \_ _ -> ( (), Cmd.none ) - , subscriptions = \_ -> Sub.none - , view = \_ -> page - } - - -page : Browser.Document () -page = - { title = "Page not found" - , body = - [ div [ class "not-found" ] - [ div [ style "font-size" "12em" ] [ text "404" ] - , div [ style "font-size" "3em" ] [ text "Page not found" ] - ] - ] - } diff --git a/reactor/src/mock.txt b/reactor/src/mock.txt deleted file mode 100644 index 786944769..000000000 --- a/reactor/src/mock.txt +++ /dev/null @@ -1,33 +0,0 @@ -# Dependency Explorer - -Mass Updates: | RESET | PATCH | MINOR | MAJOR | - -⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣇ ←→ - -DEPENDENCIES - - DIRECT - NoRedInk/elm-json-decode-pipeline 1.0.0 → 3.0.0 (MAJOR) - elm/browser 1.0.0 → 1.0.2 (MINOR) - elm/core 1.0.0 → 1.0.5 (CUSTOM: 1.0.0 <= v < 2.0.0) - elm/html 1.0.0 → 6.0.2 (ANY) - elm/http 1.0.0 → 1.0.0 (LOCKED) - elm/json 1.0.0 → 1.0.0 (LOCKED) - elm/time 1.0.0 → 1.0.0 (LOCKED) - elm/url 1.0.0 → 1.0.0 (LOCKED) - elm-explorations/markdown 1.0.0 → 1.0.0 (LOCKED) - rtfeldman/elm-iso8601-date-strings 1.1.0 → (REMOVE) - ADD - - INDIRECT - elm/parser 1.0.0 → 1.0.0 (LOCKED) - elm/virtual-dom 1.0.0 → 1.0.0 (LOCKED) - -TEST DEPENDENCIES - - DIRECT - elm-explorations/test 1.0.0 → 1.0.0 (LOCKED) - ADD - - INDIRECT - elm/random 1.0.0 → 1.0.0 (LOCKED) diff --git a/review/src/ReviewConfig.elm b/review/src/ReviewConfig.elm index 712bb7df1..c61ee63cf 100644 --- a/review/src/ReviewConfig.elm +++ b/review/src/ReviewConfig.elm @@ -43,12 +43,12 @@ config = -- |> Rule.ignoreErrorsForDirectories [ "tests/" ] , NoExposingEverything.rule , NoImportingEverything.rule [] + , NoMissingTypeAnnotation.rule + , NoMissingTypeAnnotationInLetIn.rule + , NoMissingTypeExpose.rule + , NoSimpleLetBody.rule + , NoPrematureLetComputation.rule - --, NoMissingTypeAnnotation.rule - --, NoMissingTypeAnnotationInLetIn.rule - --, NoMissingTypeExpose.rule - --, NoSimpleLetBody.rule - --, NoPrematureLetComputation.rule --, NoUnused.CustomTypeConstructors.rule [] --, NoUnused.CustomTypeConstructorArgs.rule --, NoUnused.Dependencies.rule diff --git a/src/Builder/BackgroundWriter.elm b/src/Builder/BackgroundWriter.elm index bd173b9d3..94f4b0bf0 100644 --- a/src/Builder/BackgroundWriter.elm +++ b/src/Builder/BackgroundWriter.elm @@ -49,6 +49,7 @@ writeBinary encoder (Scope workList) path value = |> IO.bind (\oldWork -> let + newWork : List (Utils.MVar ()) newWork = mvar :: oldWork in diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index dc7626d0c..354d339cd 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -1,6 +1,8 @@ module Builder.Build exposing ( Artifacts(..) + , BResult , CachedInterface(..) + , Dependencies , DocsGoal(..) , Module(..) , ReplArtifacts(..) @@ -142,6 +144,7 @@ fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e |> IO.bind (\mvar -> let + docsNeed : DocsNeed docsNeed = toDocsNeed docsGoal in @@ -328,6 +331,7 @@ type Status crawlDeps : Env -> MVar StatusDict -> List ModuleName.Raw -> a -> IO a crawlDeps env mvar deps blockedValue = let + crawlNew : ModuleName.Raw -> () -> IO (MVar Status) crawlNew name () = fork statusEncoder (crawlModule env mvar (DocsNeed False) name) in @@ -335,9 +339,11 @@ crawlDeps env mvar deps blockedValue = |> IO.bind (\statusDict -> let + depsDict : Dict ModuleName.Raw () depsDict = Map.fromKeys (\_ -> ()) deps + newsDict : Dict ModuleName.Raw () newsDict = Dict.diff depsDict statusDict in @@ -357,6 +363,7 @@ crawlDeps env mvar deps blockedValue = crawlModule : Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status crawlModule ((Env _ root projectType srcDirs buildID locals foreigns) as env) mvar ((DocsNeed needsDocs) as docsNeed) name = let + fileName : String fileName = ModuleName.toFilePath name ++ ".elm" in @@ -432,9 +439,11 @@ crawlFile ((Env _ root projectType _ buildID _ _) as env) mvar docsNeed expected Just ((A.At _ actualName) as name) -> if expectedName == actualName then let + deps : List Name.Name deps = List.map Src.getImportName imports + local : Details.Local local = Details.Local path time deps (List.any isMain values) lastChange buildID in @@ -671,6 +680,7 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep toImportErrors : Env -> ResultDict -> List Src.Import -> NE.Nonempty ( ModuleName.Raw, Import.Problem ) -> NE.Nonempty Import.Error toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = let + knownModules : EverySet.EverySet ModuleName.Raw knownModules = EverySet.fromList compare (List.concat @@ -680,12 +690,15 @@ toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems = ] ) + unimportedModules : EverySet.EverySet ModuleName.Raw unimportedModules = EverySet.diff knownModules (EverySet.fromList compare (List.map Src.getImportName imports)) + regionDict : Dict Name.Name A.Region regionDict = Dict.fromList compare (List.map (\(Src.Import (A.At region name) _ _) -> ( name, region )) imports) + toError : ( Name.Name, Import.Problem ) -> Import.Error toError ( name, problem ) = Import.Error (Utils.find name regionDict) name unimportedModules problem in @@ -801,9 +814,11 @@ checkMidpointAndRoots dmvar statuses sroots = checkForCycles : Dict ModuleName.Raw Status -> Maybe (NE.Nonempty ModuleName.Raw) checkForCycles modules = let + graph : List Node graph = Dict.foldr addToGraph [] modules + sccs : List (Graph.SCC ModuleName.Raw) sccs = Graph.stronglyConnComp graph in @@ -835,6 +850,7 @@ type alias Node = addToGraph : ModuleName.Raw -> Status -> List Node -> List Node addToGraph name status graph = let + dependencies : List ModuleName.Raw dependencies = case status of SCached (Details.Local _ _ deps _ _ _) -> @@ -865,6 +881,7 @@ addToGraph name status graph = checkUniqueRoots : Dict ModuleName.Raw Status -> NE.Nonempty RootStatus -> Maybe Exit.BuildProjectProblem checkUniqueRoots insides sroots = let + outsidesDict : Dict ModuleName.Raw (OneOrMore.OneOrMore FilePath) outsidesDict = Utils.mapFromListWith compare OneOrMore.more (List.filterMap rootStatusToNamePathPair (NE.toList sroots)) in @@ -933,6 +950,7 @@ checkInside name p1 status = compile : Env -> DocsNeed -> Details.Local -> String -> Dict ModuleName.Raw I.Interface -> Src.Module -> IO BResult compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul = let + pkg : Pkg.Name pkg = projectTypeToPkg projectType in @@ -949,12 +967,15 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti Ok docs -> let + name : Name.Name name = Src.getName modul + iface : I.Interface iface = I.fromModule pkg canonical annotations + elmi : String elmi = Stuff.elmi root name in @@ -972,6 +993,7 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti |> IO.fmap (\_ -> let + local : Details.Local local = Details.Local path time deps main lastChange buildID in @@ -986,6 +1008,7 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti |> IO.fmap (\_ -> let + local : Details.Local local = Details.Local path time deps main buildID buildID in @@ -1002,6 +1025,7 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti |> IO.fmap (\_ -> let + local : Details.Local local = Details.Local path time deps main buildID buildID in @@ -1263,6 +1287,7 @@ fromRepl root details source = |> IO.bind (\dmvar -> let + deps : List Name.Name deps = List.map Src.getImportName imports in @@ -1319,9 +1344,11 @@ fromRepl root details source = finalizeReplArtifacts : Env -> String -> Src.Module -> DepsStatus -> ResultDict -> Dict ModuleName.Raw BResult -> IO (Result Exit.Repl ReplArtifacts) finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Module _ _ _ imports _ _ _ _ _) as modul) depsStatus resultMVars results = let + pkg : Pkg.Name pkg = projectTypeToPkg projectType + compileInput : Dict ModuleName.Raw I.Interface -> IO (Result Exit.Repl ReplArtifacts) compileInput ifaces = Compile.compile pkg ifaces modul |> IO.fmap @@ -1329,12 +1356,15 @@ finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Mod case result of Ok (Compile.Artifacts ((Can.Module name _ _ _ _ _ _ _) as canonical) annotations objects) -> let + h : ModuleName.Canonical h = name + m : Module m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects + ms : List Module ms = Dict.foldr addInside [] results in @@ -1406,9 +1436,11 @@ findRoots env paths = checkRoots : NE.Nonempty RootInfo -> Result Exit.BuildProjectProblem (NE.Nonempty RootLocation) checkRoots infos = let + toOneOrMore : RootInfo -> ( FilePath, OneOrMore.OneOrMore RootInfo ) toOneOrMore ((RootInfo absolute _ _) as loc) = ( absolute, OneOrMore.one loc ) + fromOneOrMore : RootInfo -> List RootInfo -> Result Exit.BuildProjectProblem () fromOneOrMore (RootInfo _ relative _) locs = case locs of [] -> @@ -1458,6 +1490,7 @@ getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = else let + absoluteSegments : List String absoluteSegments = Utils.fpSplitDirectories dirs ++ [ final ] in @@ -1467,6 +1500,7 @@ getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = [ ( _, Ok names ) ] -> let + name : String name = String.join "." names in @@ -1476,9 +1510,11 @@ getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath = case matchingDirs of d1 :: d2 :: _ -> let + p1 : FilePath p1 = addRelative d1 (Utils.fpJoinPath names ++ ".elm") + p2 : FilePath p2 = addRelative d2 (Utils.fpJoinPath names ++ ".elm") in @@ -1585,9 +1621,11 @@ crawlRoot ((Env _ _ projectType _ buildID _ _) as env) mvar root = case Parse.fromByteString projectType source of Ok ((Src.Module _ _ _ imports values _ _ _ _) as modul) -> let + deps : List Name.Name deps = List.map Src.getImportName imports + local : Details.Local local = Details.Local path time deps (List.any isMain values) buildID buildID in @@ -1655,9 +1693,11 @@ checkRoot ((Env _ root _ _ _ _ _) as env) results rootStatus = compileOutside : Env -> Details.Local -> String -> Dict ModuleName.Raw I.Interface -> Src.Module -> IO RootResult compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul = let + pkg : Pkg.Name pkg = projectTypeToPkg projectType + name : Name.Name name = Src.getName modul in @@ -1698,6 +1738,7 @@ toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults = gatherProblemsOrMains : Dict ModuleName.Raw BResult -> NE.Nonempty RootResult -> Result (NE.Nonempty Error.Module) (NE.Nonempty Root) gatherProblemsOrMains results (NE.Nonempty rootResult rootResults) = let + addResult : RootResult -> ( List Error.Module, List Root ) -> ( List Error.Module, List Root ) addResult result ( es, roots ) = case result of RInside n -> @@ -1712,6 +1753,7 @@ gatherProblemsOrMains results (NE.Nonempty rootResult rootResults) = ROutsideBlocked -> ( es, roots ) + errors : List Error.Module errors = Dict.foldr (\_ -> addErrors) [] results in diff --git a/src/Builder/Deps/Bump.elm b/src/Builder/Deps/Bump.elm index 1252991f1..c35f5e07b 100644 --- a/src/Builder/Deps/Bump.elm +++ b/src/Builder/Deps/Bump.elm @@ -14,12 +14,15 @@ import Utils.Main as Utils getPossibilities : KnownVersions -> List ( V.Version, V.Version, M.Magnitude ) getPossibilities (KnownVersions latest previous) = let + allVersions : List V.Version allVersions = List.reverse (latest :: previous) + minorPoints : List V.Version minorPoints = List.filterMap List.Extra.last (Utils.listGroupBy sameMajor allVersions) + patchPoints : List V.Version patchPoints = List.filterMap List.Extra.last (Utils.listGroupBy sameMinor allVersions) in diff --git a/src/Builder/Deps/Diff.elm b/src/Builder/Deps/Diff.elm index 7a2f7028e..ec9c18522 100644 --- a/src/Builder/Deps/Diff.elm +++ b/src/Builder/Deps/Diff.elm @@ -44,9 +44,11 @@ type Changes k v getChanges : (k -> k -> Order) -> (v -> v -> Bool) -> Dict k v -> Dict k v -> Changes k v getChanges keyComparison isEquivalent old new = let + overlap : Dict k ( v, v ) overlap = Utils.mapIntersectionWith keyComparison Tuple.pair old new + changed : Dict k ( v, v ) changed = Dict.filter (\_ ( v1, v2 ) -> not (isEquivalent v1 v2)) overlap in @@ -63,6 +65,7 @@ getChanges keyComparison isEquivalent old new = diff : Docs.Documentation -> Docs.Documentation -> PackageChanges diff oldDocs newDocs = let + filterOutPatches : Dict a ModuleChanges -> Dict a ModuleChanges filterOutPatches chngs = Dict.filter (\_ chng -> moduleChangeMagnitude chng /= M.PATCH) chngs @@ -94,6 +97,7 @@ isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newCommen equiv : List Type.Type -> List Type.Type -> Bool equiv oldTypes newTypes = let + allEquivalent : List Bool allEquivalent = List.map2 isEquivalentAlias @@ -189,6 +193,7 @@ diffType oldType newType = isSameName : Name.Name -> Name.Name -> Bool isSameName oldFullName newFullName = let + dedot : String -> List String dedot name = List.reverse (String.split "." name) in @@ -205,24 +210,28 @@ isSameName oldFullName newFullName = diffFields : List ( Name.Name, Type.Type ) -> List ( Name.Name, Type.Type ) -> Maybe (List ( Name.Name, Name.Name )) diffFields oldRawFields newRawFields = - let - sort fields = - List.sortBy Tuple.first fields - - oldFields = - sort oldRawFields - - newFields = - sort newRawFields - in if List.length oldRawFields /= List.length newRawFields then Nothing - else if List.any identity (List.map2 (/=) (List.map Tuple.first oldFields) (List.map Tuple.first newFields)) then - Nothing - else - Maybe.map List.concat (Utils.zipWithM diffType (List.map Tuple.second oldFields) (List.map Tuple.second newFields)) + let + sort : List ( comparable, b ) -> List ( comparable, b ) + sort fields = + List.sortBy Tuple.first fields + + oldFields : List ( Name.Name, Type.Type ) + oldFields = + sort oldRawFields + + newFields : List ( Name.Name, Type.Type ) + newFields = + sort newRawFields + in + if List.any identity (List.map2 (/=) (List.map Tuple.first oldFields) (List.map Tuple.first newFields)) then + Nothing + + else + Maybe.map List.concat (Utils.zipWithM diffType (List.map Tuple.second oldFields) (List.map Tuple.second newFields)) @@ -232,12 +241,15 @@ diffFields oldRawFields newRawFields = isEquivalentRenaming : List ( Name.Name, Name.Name ) -> Bool isEquivalentRenaming varPairs = let + renamings : List ( Name.Name, List Name.Name ) renamings = Dict.toList (List.foldr insert Dict.empty varPairs) + insert : ( Name.Name, Name.Name ) -> Dict Name.Name (List Name.Name) -> Dict Name.Name (List Name.Name) insert ( old, new ) dict = Utils.mapInsertWith compare (++) old [ new ] dict + verify : ( a, List b ) -> Maybe ( a, b ) verify ( old, news ) = case news of [] -> @@ -250,6 +262,7 @@ isEquivalentRenaming varPairs = else Nothing + allUnique : List comparable -> Bool allUnique list = List.length list == EverySet.size (EverySet.fromList compare list) in @@ -333,6 +346,7 @@ bump changes version = toMagnitude : PackageChanges -> M.Magnitude toMagnitude (PackageChanges added changed removed) = let + addMag : M.Magnitude addMag = if List.isEmpty added then M.PATCH @@ -340,6 +354,7 @@ toMagnitude (PackageChanges added changed removed) = else M.MINOR + removeMag : M.Magnitude removeMag = if List.isEmpty removed then M.PATCH @@ -347,6 +362,7 @@ toMagnitude (PackageChanges added changed removed) = else M.MAJOR + changeMags : List M.Magnitude changeMags = List.map moduleChangeMagnitude (Dict.values changed) in @@ -382,9 +398,11 @@ changeMagnitude (Changes added changed removed) = getDocs : Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Result Exit.DocsProblem Docs.Documentation) getDocs cache manager name version = let + home : String home = Stuff.package cache name version + path : String path = home ++ "/docs.json" in @@ -406,6 +424,7 @@ getDocs cache manager name version = else let + url : String url = Website.metadata name version "docs.json" in diff --git a/src/Builder/Deps/Registry.elm b/src/Builder/Deps/Registry.elm index dfef4553e..3608c4ba9 100644 --- a/src/Builder/Deps/Registry.elm +++ b/src/Builder/Deps/Registry.elm @@ -74,12 +74,15 @@ fetch manager cache = post manager "/all-packages" allPkgsDecoder <| \versions -> let + size : Int size = Dict.foldr (\_ -> addEntry) 0 versions + registry : Registry registry = Registry size versions + path : String path = Stuff.registry cache in @@ -99,6 +102,7 @@ allPkgsDecoder = keyDecoder = Pkg.keyDecoder bail + versionsDecoder : D.Decoder () (List V.Version) versionsDecoder = D.list (D.mapError (\_ -> ()) V.decoder) @@ -128,12 +132,15 @@ update manager cache ((Registry size packages) as oldRegistry) = _ :: _ -> let + newSize : Int newSize = size + List.length news + newPkgs : Dict Pkg.Name KnownVersions newPkgs = List.foldr addNew packages news + newRegistry : Registry newRegistry = Registry newSize newPkgs in @@ -144,6 +151,7 @@ update manager cache ((Registry size packages) as oldRegistry) = addNew : ( Pkg.Name, V.Version ) -> Dict Pkg.Name KnownVersions -> Dict Pkg.Name KnownVersions addNew ( name, version ) versions = let + add : Maybe KnownVersions -> KnownVersions add maybeKnowns = case maybeKnowns of Just (KnownVersions v vs) -> @@ -224,6 +232,7 @@ getVersions_ name (Registry _ versions) = post : Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Result Exit.RegistryProblem b) post manager path decoder callback = let + url : String url = Website.route path [] in diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index 2ca7c61fd..3cd19655e 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -6,6 +6,7 @@ module Builder.Deps.Solver exposing , InnerSolver(..) , Solver , SolverResult(..) + , State , addToApp , envDecoder , envEncoder @@ -134,15 +135,19 @@ addToApp : Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> addToApp cache connection registry pkg ((Outline.AppOutline _ _ direct indirect testDirect testIndirect) as outline) = Stuff.withRegistryLock cache <| let + allIndirects : Dict Pkg.Name V.Version allIndirects = Dict.union Pkg.compareName indirect testIndirect + allDirects : Dict Pkg.Name V.Version allDirects = Dict.union Pkg.compareName direct testDirect + allDeps : Dict Pkg.Name V.Version allDeps = Dict.union Pkg.compareName allDirects allIndirects + attempt : (a -> C.Constraint) -> Dict Pkg.Name a -> Solver (Dict Pkg.Name V.Version) attempt toConstraint deps = try (Dict.insert Pkg.compareName pkg C.anything (Dict.map (\_ -> toConstraint) deps)) in @@ -174,15 +179,19 @@ addToApp cache connection registry pkg ((Outline.AppOutline _ _ direct indirect toApp : State -> Pkg.Name -> Outline.AppOutline -> Dict Pkg.Name V.Version -> Dict Pkg.Name V.Version -> AppSolution toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new = let + d : Dict Pkg.Name V.Version d = Dict.intersection new (Dict.insert Pkg.compareName pkg V.one direct) + i : Dict Pkg.Name V.Version i = Dict.diff (getTransitive constraints new (Dict.toList d) Dict.empty) d + td : Dict Pkg.Name V.Version td = Dict.intersection new (Dict.remove pkg testDirect) + ti : Dict Pkg.Name V.Version ti = Dict.diff new (Utils.mapUnions Pkg.compareName [ d, i, td ]) in @@ -204,9 +213,11 @@ getTransitive constraints solution unvisited visited = (Constraints _ newDeps) = Utils.find info constraints + newUnvisited : List ( Pkg.Name, V.Version ) newUnvisited = Dict.toList (Dict.intersection solution (Dict.diff newDeps visited)) + newVisited : Dict Pkg.Name V.Version newVisited = Dict.insert Pkg.compareName pkg vsn visited in @@ -234,6 +245,7 @@ type Goals exploreGoals : Goals -> Solver (Dict Pkg.Name V.Version) exploreGoals (Goals pending solved) = let + compare : ( Pkg.Name, b ) -> String compare ( name, _ ) = Pkg.toString name in @@ -243,9 +255,11 @@ exploreGoals (Goals pending solved) = Just ( ( name, constraint ), otherPending ) -> let + goals1 : Goals goals1 = Goals otherPending solved + addVsn : V.Version -> Solver Goals addVsn = addVersion goals1 name in @@ -329,9 +343,11 @@ getConstraints pkg vsn = Solver <| \((State cache connection registry cDict) as state) -> let + key : ( Pkg.Name, V.Version ) key = ( pkg, vsn ) + compare : ( Pkg.Name, V.Version ) -> ( Pkg.Name, V.Version ) -> Order compare ( pkg1, vsn1 ) ( pkg2, vsn2 ) = case Pkg.compareName pkg1 pkg2 of EQ -> @@ -346,12 +362,15 @@ getConstraints pkg vsn = Nothing -> let + toNewState : Constraints -> State toNewState cs = State cache connection registry (Dict.insert compare key cs cDict) + home : String home = Stuff.package cache pkg vsn + path : String path = home ++ "/elm.json" in @@ -391,6 +410,7 @@ getConstraints pkg vsn = Online manager -> let + url : String url = Website.metadata pkg vsn "elm.json" in @@ -514,37 +534,6 @@ pure a = Solver (\state -> IO.pure (ISOk state a (InnerBackNoOp state))) -apply : Solver a -> Solver (a -> b) -> Solver b -apply (Solver solverArg) (Solver solverFunc) = - Solver <| - \state -> - solverFunc state - |> IO.bind - (\res1 -> - case res1 of - ISOk stateF func backF -> - solverArg stateF - |> IO.fmap - (\res2 -> - case res2 of - ISOk stateA arg backA -> - ISOk stateA (func arg) backA - - ISBack stateA -> - ISBack stateA - - ISErr e -> - ISErr e - ) - - ISBack stateA -> - IO.pure (ISBack stateA) - - ISErr e -> - IO.pure (ISErr e) - ) - - bind : (a -> Solver b) -> Solver a -> Solver b bind callback (Solver solverA) = Solver <| diff --git a/src/Builder/Elm/Details.elm b/src/Builder/Elm/Details.elm index ed80c099c..9c5ce37e6 100644 --- a/src/Builder/Elm/Details.elm +++ b/src/Builder/Elm/Details.elm @@ -1,8 +1,11 @@ module Builder.Elm.Details exposing ( BuildID , Details(..) + , Extras , Foreign(..) + , Interfaces , Local(..) + , Status , ValidOutline(..) , detailsEncoder , load @@ -136,9 +139,11 @@ verifyInstall scope root (Solver.Env cache manager connection registry) outline |> IO.bind (\time -> let + key : Reporting.Key msg key = Reporting.ignorer + env : Env env = Env key scope root cache manager connection registry in @@ -254,9 +259,11 @@ verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) |> Task.bind (\solution -> let + exposedList : List ModuleName.Raw exposedList = Outline.flattenExposed exposed + exactDeps : Dict Pkg.Name V.Version exactDeps = Dict.map (\_ (Solver.Details v _) -> v) solution @@ -404,15 +411,19 @@ verifyDependencies ((Env key scope root cache _ _ _) as env) time outline soluti Ok artifacts -> let + objs : Opt.GlobalGraph objs = Dict.foldr (\_ -> addObjects) Opt.empty artifacts + ifaces : Interfaces ifaces = Dict.foldr (addInterfaces directDeps) Dict.empty artifacts + foreigns : Dict ModuleName.Raw Foreign foreigns = Dict.map (\_ -> OneOrMore.destruct Foreign) (Dict.foldr gatherForeigns Dict.empty (Dict.intersection artifacts directDeps)) + details : Details details = Details time outline 0 Dict.empty foreigns (ArtifactsFresh ifaces objs) in @@ -453,6 +464,7 @@ addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces = gatherForeigns : Pkg.Name -> Artifacts -> Dict ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Dict ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) gatherForeigns pkg (Artifacts ifaces _) foreigns = let + isPublic : I.DependencyInterface -> Maybe (OneOrMore.OneOrMore Pkg.Name) isPublic di = case di of I.Public _ -> @@ -479,6 +491,7 @@ type alias Dep = verifyDep : Env -> MVar (Dict Pkg.Name (MVar Dep)) -> Dict Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg ((Solver.Details vsn directDeps) as details) = let + fingerprint : Dict Pkg.Name V.Version fingerprint = Utils.mapIntersectionWith Pkg.compareName (\(Solver.Details v _) _ -> v) solution directDeps in @@ -569,12 +582,15 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Ok directArtifacts -> let + src : String src = Stuff.package cache pkg vsn ++ "/src" + foreignDeps : Dict ModuleName.Raw ForeignInterface foreignDeps = gatherForeignInterfaces directArtifacts + exposedDict : Dict ModuleName.Raw () exposedDict = Utils.mapFromKeys compare (\_ -> ()) (Outline.flattenExposed exposed) in @@ -615,18 +631,23 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs = Just results -> let + path : String path = Stuff.package cache pkg vsn ++ "/artifacts.json" + ifaces : Dict ModuleName.Raw I.DependencyInterface ifaces = gatherInterfaces exposedDict results + objects : Opt.GlobalGraph objects = gatherObjects results + artifacts : Artifacts artifacts = Artifacts ifaces objects + fingerprints : EverySet Fingerprint fingerprints = EverySet.insert (\_ _ -> EQ) f fs in @@ -674,14 +695,17 @@ addLocalGraph name status graph = gatherInterfaces : Dict ModuleName.Raw () -> Dict ModuleName.Raw DResult -> Dict ModuleName.Raw I.DependencyInterface gatherInterfaces exposed artifacts = let + onLeft : a -> b -> c -> d onLeft _ _ _ = crash "compiler bug manifesting in Elm.Details.gatherInterfaces" + onBoth : comparable -> () -> DResult -> Dict comparable I.DependencyInterface -> Dict comparable I.DependencyInterface onBoth k () iface = toLocalInterface I.public iface |> Maybe.map (Dict.insert compare k) |> Maybe.withDefault identity + onRight : comparable -> DResult -> Dict comparable I.DependencyInterface -> Dict comparable I.DependencyInterface onRight k iface = toLocalInterface I.private iface |> Maybe.map (Dict.insert compare k) @@ -762,6 +786,7 @@ type Status crawlModule : Dict ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status) crawlModule foreignDeps mvar pkg src docsStatus name = let + path : FilePath path = Utils.fpForwardSlash src (Utils.fpAddExtension (ModuleName.toFilePath name) "elm") in @@ -816,9 +841,11 @@ crawlImports foreignDeps mvar pkg src imports = |> IO.bind (\statusDict -> let + deps : Dict Name.Name () deps = Dict.fromList compare (List.map (\i -> ( Src.getImportName i, () )) imports) + news : Dict Name.Name () news = Dict.diff deps statusDict in @@ -835,6 +862,7 @@ crawlImports foreignDeps mvar pkg src imports = crawlKernel : Dict ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status) crawlKernel foreignDeps mvar pkg src name = let + path : FilePath path = Utils.fpForwardSlash src (Utils.fpAddExtension (ModuleName.toFilePath name) "js") in @@ -901,9 +929,11 @@ compile pkg mvar status = Ok (Compile.Artifacts canonical annotations objects) -> let + ifaces : I.Interface ifaces = I.fromModule pkg canonical annotations + docs : Maybe Docs.Module docs = makeDocs docsStatus canonical in @@ -1012,6 +1042,7 @@ toDocs result = downloadPackage : Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Result Exit.PackageProblem ()) downloadPackage cache manager pkg vsn = let + url : String url = Website.metadata pkg vsn "endpoint.json" in diff --git a/src/Builder/Elm/Outline.elm b/src/Builder/Elm/Outline.elm index 17e58f35a..9aadb8e7d 100644 --- a/src/Builder/Elm/Outline.elm +++ b/src/Builder/Elm/Outline.elm @@ -1,5 +1,6 @@ module Builder.Elm.Outline exposing ( AppOutline(..) + , Decoder , Exposed(..) , Outline(..) , PkgOutline(..) @@ -282,9 +283,11 @@ type alias Decoder a = decoder : Decoder Outline decoder = let + application : String application = "application" + package : String package = "package" in @@ -404,9 +407,11 @@ boundParser bound tooLong = P.Parser <| \(P.State src pos end indent row col) -> let + len : Int len = end - pos + newCol : P.Col newCol = col + len in diff --git a/src/Builder/File.elm b/src/Builder/File.elm index 12b6031e8..578139bf5 100644 --- a/src/Builder/File.elm +++ b/src/Builder/File.elm @@ -19,7 +19,6 @@ import Data.IO as IO exposing (IO(..)) import Json.Decode as Decode import Json.Encode as Encode import Time -import Utils.Crash exposing (todo) import Utils.Main as Utils exposing (FilePath, ZipArchive, ZipEntry) @@ -48,6 +47,7 @@ zeroTime = writeBinary : (a -> Encode.Value) -> FilePath -> a -> IO () writeBinary encoder path value = let + dir : FilePath dir = Utils.fpDropFileName path in @@ -107,52 +107,6 @@ readUtf8 path = IO.make Decode.string (IO.Read path) -useZeroIfNotRegularFile : IO.IOException -> IO Int -useZeroIfNotRegularFile _ = - IO.pure 0 - - -hGetContentsSizeHint : IO.Handle -> Int -> Int -> IO String -hGetContentsSizeHint handle = - -- let - -- readChunks chunks readSize incrementSize = - -- BS.mallocByteString readSize - -- |> IO.bind - -- (\fp -> - -- FPtr.withForeignPtr fp <| - -- \buf -> - -- IO.hGetBuf handle buf readSize - -- |> IO.bind - -- (\readCount -> - -- let - -- chunk = - -- BS.PS fp 0 readCount - -- in - -- if readCount < readSize && readSize > 0 then - -- return <| BS.concat (reverse (chunk :: chunks)) - -- else - -- readChunks (chunk :: chunks) incrementSize (min 32752 (readSize + incrementSize)) - -- ) - -- ) - -- in - -- readChunks [] - todo "hGetContentsSizeHint" - - -encodingError : FilePath -> IO.IOError -> IO.IOError -encodingError path ioErr = - -- case ioeGetErrorType ioErr of - -- InvalidArgument -> - -- annotateIOError - -- (userError "Bad encoding; the file must be valid UTF-8") - -- "" - -- Nothing - -- (Just path) - -- _ -> - -- ioErr - todo "encodingError" - - -- WRITE BUILDER @@ -174,6 +128,7 @@ writePackage destination archive = entry :: entries -> let + root : Int root = String.length (Utils.zipERelativePath entry) in @@ -183,6 +138,7 @@ writePackage destination archive = writeEntry : FilePath -> Int -> ZipEntry -> IO () writeEntry destination root entry = let + path : String path = String.dropLeft root (Utils.zipERelativePath entry) in diff --git a/src/Builder/Generate.elm b/src/Builder/Generate.elm index 0142bba8b..fed856730 100644 --- a/src/Builder/Generate.elm +++ b/src/Builder/Generate.elm @@ -1,5 +1,6 @@ module Builder.Generate exposing - ( debug + ( Task + , debug , dev , prod , repl @@ -50,12 +51,15 @@ debug root details (Build.Artifacts pkg ifaces roots modules) = |> Task.fmap (\objects -> let + mode : Mode.Mode mode = Mode.Dev (Just types) + graph : Opt.GlobalGraph graph = objectsToGlobalGraph objects + mains : Dict ModuleName.Canonical Opt.Main mains = gatherMains pkg objects roots in @@ -71,12 +75,15 @@ dev root details (Build.Artifacts pkg _ roots modules) = |> Task.fmap (\objects -> let + mode : Mode.Mode mode = Mode.Dev Nothing + graph : Opt.GlobalGraph graph = objectsToGlobalGraph objects + mains : Dict ModuleName.Canonical Opt.Main mains = gatherMains pkg objects roots in @@ -93,12 +100,15 @@ prod root details (Build.Artifacts pkg _ roots modules) = |> Task.fmap (\_ -> let + graph : Opt.GlobalGraph graph = objectsToGlobalGraph objects + mode : Mode.Mode mode = Mode.Prod (Mode.shortenFieldNames graph) + mains : Dict ModuleName.Canonical Opt.Main mains = gatherMains pkg objects roots in @@ -113,6 +123,7 @@ repl root details ansi (Build.ReplArtifacts home modules localizer annotations) |> Task.fmap (\objects -> let + graph : Opt.GlobalGraph graph = objectsToGlobalGraph objects in @@ -146,6 +157,7 @@ gatherMains pkg (Objects _ locals) roots = lookupMain : Pkg.Name -> Dict ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe ( ModuleName.Canonical, Opt.Main ) lookupMain pkg locals root = let + toPair : N.Name -> Opt.LocalGraph -> Maybe ( ModuleName.Canonical, Opt.Main ) toPair name (Opt.LocalGraph maybeMain _ _) = Maybe.map (Tuple.pair (ModuleName.Canonical pkg name)) maybeMain in @@ -240,6 +252,7 @@ loadTypes root ifaces modules = |> IO.bind (\mvars -> let + foreigns : Extract.Types foreigns = Extract.mergeMany (Dict.values (Dict.map Extract.fromDependencyInterface ifaces)) in diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm index 7da0274ae..e2e7108ab 100644 --- a/src/Builder/Http.elm +++ b/src/Builder/Http.elm @@ -3,6 +3,7 @@ module Builder.Http exposing , Header , HttpExceptionContent(..) , Manager + , MultiPart , Sha , accept , errorDecoder @@ -28,7 +29,6 @@ import Data.IO as IO exposing (IO(..)) import Json.Decode as Decode import Json.Encode as Encode import Url.Builder -import Utils.Crash exposing (todo) import Utils.Main as Utils exposing (HTTPResponse(..), SomeException(..)) @@ -156,25 +156,6 @@ type HttpExceptionContent | ConnectionFailure SomeException -type HttpException - = HttpException - - -handleHttpException : String -> (Error -> e) -> HttpException -> IO (Result e a) -handleHttpException url onError httpException = - -- case httpException of - -- InvalidUrlException _ reason -> - -- IO.pure (Err (onError (BadUrl url reason))) - -- HttpExceptionRequest _ content -> - -- IO.pure (Err (onError (BadHttp url content))) - todo "handleHttpException" - - -handleSomeException : String -> (Error -> e) -> SomeException -> IO (Result e a) -handleSomeException url onError exception = - IO.pure (Err (onError (BadMystery url exception))) - - -- SHA diff --git a/src/Builder/Reporting.elm b/src/Builder/Reporting.elm index d1b647f21..f18a7649e 100644 --- a/src/Builder/Reporting.elm +++ b/src/Builder/Reporting.elm @@ -321,6 +321,7 @@ putTransition ((DState total cached _ rcvd failed built broken) as state) = else let + char : Char char = if rcvd + failed == 0 then '\u{000D}' @@ -382,6 +383,7 @@ trackBuild decoder encoder style callback = |> IO.bind (\chan -> let + chanEncoder : Result BMsg (BResult a) -> CoreEncode.Value chanEncoder = Encode.result bMsgEncoder (bResultEncoder encoder) in @@ -412,6 +414,7 @@ buildLoop decoder chan done = case msg of Err BDone -> let + done1 : Int done1 = done + 1 in @@ -420,9 +423,11 @@ buildLoop decoder chan done = Ok result -> let + message : String message = toFinalMessage done result + width : Int width = 12 + String.length (String.fromInt done) in @@ -481,6 +486,7 @@ reportGenerate style names output = |> IO.bind (\_ -> let + cnames : NE.Nonempty String cnames = NE.map (ModuleName.toChars >> String.fromList) names in @@ -491,6 +497,7 @@ reportGenerate style names output = toGenDiagram : NE.Nonempty String -> String -> String toGenDiagram (NE.Nonempty name names) output = let + width : Int width = 3 + List.foldr (max << String.length) (String.length name) names in diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index fb31afeba..53cb73938 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -236,9 +236,11 @@ diffToReport diff = D.dullyellow <| D.vcat <| let + sameMajor : V.Version -> V.Version -> Bool sameMajor v1 v2 = V.major v1 == V.major v2 + mkRow : List V.Version -> D.Doc mkRow vsns = D.hsep <| List.map D.fromVersion vsns in @@ -754,6 +756,7 @@ publishToReport publish = PublishMissingTag version -> let + vsn : String vsn = V.toChars version in @@ -884,6 +887,7 @@ publishToReport publish = PublishLocalChanges version -> let + vsn : String vsn = V.toChars version in @@ -1398,9 +1402,11 @@ toOutlineReport problem = toOutlineProblemReport : FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report toOutlineProblemReport path source _ region problem = let + toHighlight : Int -> Int -> Maybe A.Region toHighlight row col = Just <| A.Region (A.Position row col) (A.Position row col) + toSnippet : String -> Maybe A.Region -> ( D.Doc, D.Doc ) -> Help.Report toSnippet title highlight pair = Help.jsonReport title (Just path) <| Code.toSnippet source region highlight pair @@ -2058,6 +2064,7 @@ type PackageProblem toPackageProblemReport : Pkg.Name -> V.Version -> PackageProblem -> Help.Report toPackageProblemReport pkg vsn problem = let + thePackage : String thePackage = Pkg.toChars pkg ++ " " ++ V.toChars vsn in @@ -2152,6 +2159,7 @@ toRegistryProblemReport title problem context = toHttpErrorReport : String -> Http.Error -> String -> Help.Report toHttpErrorReport title err context = let + toHttpReport : String -> String -> List D.Doc -> Help.Report toHttpReport intro url details = Help.report title Nothing intro <| D.indent 4 (D.dullyellow (D.fromChars url)) @@ -2675,6 +2683,7 @@ toProjectProblemReport projectProblem = toModuleNameConventionTable : FilePath -> List String -> D.Doc toModuleNameConventionTable srcDir names = let + toPair : String -> ( String, FilePath ) toPair name = ( name , Utils.fpForwardSlash srcDir @@ -2693,18 +2702,23 @@ toModuleNameConventionTable srcDir names = ) ) + namePairs : List ( String, FilePath ) namePairs = List.map toPair names + nameWidth : Int nameWidth = Utils.listMaximum compare (11 :: List.map (String.length << Tuple.first) namePairs) + pathWidth : Int pathWidth = Utils.listMaximum compare (9 :: List.map (String.length << Tuple.second) namePairs) + padded : Int -> String -> String padded width str = str ++ String.repeat (width - String.length str) " " + toRow : ( String, String ) -> D.Doc toRow ( name, path ) = D.fromChars <| "| " @@ -2713,6 +2727,7 @@ toModuleNameConventionTable srcDir names = ++ padded pathWidth path ++ " |" + bar : D.Doc bar = D.fromChars <| "+-" diff --git a/src/Builder/Reporting/Exit/Help.elm b/src/Builder/Reporting/Exit/Help.elm index e3806f283..849993246 100644 --- a/src/Builder/Reporting/Exit/Help.elm +++ b/src/Builder/Reporting/Exit/Help.elm @@ -59,9 +59,11 @@ reportToDoc report_ = Report title maybePath message -> let + makeDashes : Int -> String makeDashes n = String.repeat (max 1 (80 - n)) "-" + errorBarEnd : String errorBarEnd = case maybePath of Nothing -> @@ -72,6 +74,7 @@ reportToDoc report_ = ++ " " ++ path + errorBar : D.Doc errorBar = D.dullcyan (D.fromChars "--" diff --git a/src/Builder/Stuff.elm b/src/Builder/Stuff.elm index dcafbe19e..914f509ef 100644 --- a/src/Builder/Stuff.elm +++ b/src/Builder/Stuff.elm @@ -129,6 +129,7 @@ findRootHelp dirs = withRootLock : String -> IO a -> IO a withRootLock root work = let + dir : String dir = stuff root in @@ -182,6 +183,7 @@ getCacheDir projectName = |> IO.bind (\home -> let + root : Utils.FilePath root = Utils.fpForwardSlash home (Utils.fpForwardSlash compilerVersion projectName) in diff --git a/src/Compiler/AST/Canonical.elm b/src/Compiler/AST/Canonical.elm index 3b92ceb76..f16a4682b 100644 --- a/src/Compiler/AST/Canonical.elm +++ b/src/Compiler/AST/Canonical.elm @@ -15,6 +15,7 @@ module Compiler.AST.Canonical exposing , Expr_(..) , FieldType(..) , FieldUpdate(..) + , FreeVars , Manager(..) , Module(..) , Pattern @@ -222,9 +223,11 @@ type FieldType fieldsToList : Dict Name FieldType -> List ( Name, Type ) fieldsToList fields = let + getIndex : ( a, FieldType ) -> Int getIndex ( _, FieldType index _ ) = index + dropIndex : ( a, FieldType ) -> ( a, Type ) dropIndex ( name, FieldType _ tipe ) = ( name, tipe ) in diff --git a/src/Compiler/AST/Optimized.elm b/src/Compiler/AST/Optimized.elm index 24296da02..96a3b7fc1 100644 --- a/src/Compiler/AST/Optimized.elm +++ b/src/Compiler/AST/Optimized.elm @@ -194,9 +194,11 @@ addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) = addKernel : Name -> List K.Chunk -> GlobalGraph -> GlobalGraph addKernel shortName chunks (GlobalGraph nodes fields) = let + global : Global global = toKernelGlobal shortName + node : Node node = Kernel chunks (List.foldr addKernelDep EverySet.empty chunks) in diff --git a/src/Compiler/Canonicalize/Effects.elm b/src/Compiler/Canonicalize/Effects.elm index 42b0213dc..52c0a9516 100644 --- a/src/Compiler/Canonicalize/Effects.elm +++ b/src/Compiler/Canonicalize/Effects.elm @@ -42,6 +42,7 @@ canonicalize env values unions effects = Src.Ports ports -> let + pairs : R.RResult i w Error.Error (List ( Name.Name, Can.Port )) pairs = R.traverse (canonicalizePort env) ports in @@ -49,6 +50,7 @@ canonicalize env values unions effects = Src.Manager region manager -> let + dict : Dict Name.Name A.Region dict = Dict.fromList compare (List.map toNameRegion values) in diff --git a/src/Compiler/Canonicalize/Environment.elm b/src/Compiler/Canonicalize/Environment.elm index 826203f2f..2b6bce6aa 100644 --- a/src/Compiler/Canonicalize/Environment.elm +++ b/src/Compiler/Canonicalize/Environment.elm @@ -1,6 +1,7 @@ module Compiler.Canonicalize.Environment exposing ( Binop(..) , Ctor(..) + , EResult , Env , Exposed , Info(..) diff --git a/src/Compiler/Canonicalize/Environment/Dups.elm b/src/Compiler/Canonicalize/Environment/Dups.elm index b2cbdca9e..71dfb2693 100644 --- a/src/Compiler/Canonicalize/Environment/Dups.elm +++ b/src/Compiler/Canonicalize/Environment/Dups.elm @@ -1,5 +1,7 @@ module Compiler.Canonicalize.Environment.Dups exposing - ( Tracker + ( Info + , ToError + , Tracker , checkFields , checkFields_ , detect diff --git a/src/Compiler/Canonicalize/Environment/Foreign.elm b/src/Compiler/Canonicalize/Environment/Foreign.elm index ca264e22d..5dffb0d6b 100644 --- a/src/Compiler/Canonicalize/Environment/Foreign.elm +++ b/src/Compiler/Canonicalize/Environment/Foreign.elm @@ -1,4 +1,4 @@ -module Compiler.Canonicalize.Environment.Foreign exposing (createInitialEnv) +module Compiler.Canonicalize.Environment.Foreign exposing (FResult, createInitialEnv) import Compiler.AST.Canonical as Can import Compiler.AST.Source as Src @@ -108,12 +108,15 @@ addImport ifaces state (Src.Import (A.At _ name) maybeAlias exposing_) = (I.Interface pkg defs unions aliases binops) = Utils.find name ifaces + prefix : Name prefix = Maybe.withDefault name maybeAlias + home : ModuleName.Canonical home = ModuleName.Canonical pkg name + rawTypeInfo : Dict Name ( Env.Type, Env.Exposed Env.Ctor ) rawTypeInfo = Dict.union compare (Dict.toList unions @@ -125,36 +128,46 @@ addImport ifaces state (Src.Import (A.At _ name) maybeAlias exposing_) = |> Dict.fromList compare ) + vars : Dict Name (Env.Info Can.Annotation) vars = Dict.map (\_ -> Env.Specific home) defs + types : Dict Name (Env.Info Env.Type) types = Dict.map (\_ -> Env.Specific home << Tuple.first) rawTypeInfo + ctors : Env.Exposed Env.Ctor ctors = Dict.foldr (\_ -> addExposed << Tuple.second) Dict.empty rawTypeInfo + qvs2 : Env.Qualified Can.Annotation qvs2 = addQualified prefix vars state.q_vars + qts2 : Env.Qualified Env.Type qts2 = addQualified prefix types state.q_types + qcs2 : Env.Qualified Env.Ctor qcs2 = addQualified prefix ctors state.q_ctors in case exposing_ of Src.Open -> let + vs2 : Env.Exposed Can.Annotation vs2 = addExposed state.vars vars + ts2 : Env.Exposed Env.Type ts2 = addExposed state.types types + cs2 : Env.Exposed Env.Ctor cs2 = addExposed state.ctors ctors + bs2 : Env.Exposed Env.Binop bs2 = addExposed state.binops (Dict.map (binopToBinop home) binops) in @@ -189,6 +202,7 @@ unionToType home name union = unionToTypeHelp : ModuleName.Canonical -> Name -> Can.Union -> ( Env.Type, Env.Exposed Env.Ctor ) unionToTypeHelp home name ((Can.Union vars ctors _ _) as union) = let + addCtor : Can.Ctor -> Dict Name (Env.Info Env.Ctor) -> Dict Name (Env.Info Env.Ctor) addCtor (Can.Ctor ctor index _ args) dict = Dict.insert compare ctor (Env.Specific home (Env.Ctor home name union index args)) dict in @@ -212,9 +226,11 @@ aliasToTypeHelp home name (Can.Alias vars tipe) = , case tipe of Can.TRecord fields Nothing -> let + avars : List ( Name, Can.Type ) avars = List.map (\var -> ( var, Can.TVar var )) vars + alias_ : Can.Type alias_ = List.foldr (\( _, t1 ) t2 -> Can.TLambda t1 t2) @@ -267,6 +283,7 @@ addExposedValue home vars types binops state exposed = case tipe of Env.Union _ _ -> let + ts2 : Dict Name (Env.Info Env.Type) ts2 = Dict.insert compare name (Env.Specific home tipe) state.types in @@ -274,9 +291,11 @@ addExposedValue home vars types binops state exposed = Env.Alias _ _ _ _ -> let + ts2 : Dict Name (Env.Info Env.Type) ts2 = Dict.insert compare name (Env.Specific home tipe) state.types + cs2 : Env.Exposed Env.Ctor cs2 = addExposed state.ctors ctors in @@ -296,9 +315,11 @@ addExposedValue home vars types binops state exposed = case tipe of Env.Union _ _ -> let + ts2 : Dict Name (Env.Info Env.Type) ts2 = Dict.insert compare name (Env.Specific home tipe) state.types + cs2 : Env.Exposed Env.Ctor cs2 = addExposed state.ctors ctors in @@ -314,6 +335,7 @@ addExposedValue home vars types binops state exposed = case Dict.get op binops of Just binop -> let + bs2 : Dict Name (Env.Info Env.Binop) bs2 = Dict.insert compare op (binopToBinop home op binop) state.binops in @@ -326,9 +348,11 @@ addExposedValue home vars types binops state exposed = checkForCtorMistake : Name -> Dict Name ( Env.Type, Env.Exposed Env.Ctor ) -> List Name checkForCtorMistake givenName types = let + addMatches : a -> ( b, Dict Name (Env.Info Env.Ctor) ) -> List Name -> List Name addMatches _ ( _, exposedCtors ) matches = Dict.foldr addMatch matches exposedCtors + addMatch : Name -> Env.Info Env.Ctor -> List Name -> List Name addMatch ctorName info matches = if ctorName /= givenName then matches diff --git a/src/Compiler/Canonicalize/Environment/Local.elm b/src/Compiler/Canonicalize/Environment/Local.elm index 197843475..29954d49b 100644 --- a/src/Compiler/Canonicalize/Environment/Local.elm +++ b/src/Compiler/Canonicalize/Environment/Local.elm @@ -1,4 +1,4 @@ -module Compiler.Canonicalize.Environment.Local exposing (add) +module Compiler.Canonicalize.Environment.Local exposing (LResult, add) import Compiler.AST.Canonical as Can import Compiler.AST.Source as Src @@ -49,6 +49,7 @@ addVars module_ env = |> R.fmap (\topLevelVars -> let + vs2 : Dict Name Env.Var vs2 = Dict.union compare topLevelVars env.vars in @@ -60,6 +61,7 @@ addVars module_ env = collectVars : Src.Module -> LResult i w (Dict Name.Name Env.Var) collectVars (Src.Module _ _ _ _ values _ _ _ effects) = let + addDecl : A.Located Src.Value -> Dups.Tracker Env.Var -> Dups.Tracker Env.Var addDecl (A.At _ (Src.Value (A.At region name) _ _ _)) = Dups.insert name region (Env.TopLevel region) in @@ -75,6 +77,7 @@ toEffectDups effects = Src.Ports ports -> let + addPort : Src.Port -> Dups.Tracker Env.Var -> Dups.Tracker Env.Var addPort (Src.Port (A.At region name) _) = Dups.insert name region (Env.TopLevel region) in @@ -101,12 +104,15 @@ toEffectDups effects = addTypes : Src.Module -> Env.Env -> LResult i w Env.Env addTypes (Src.Module _ _ _ _ _ unions aliases _ _) env = let + addAliasDups : A.Located Src.Alias -> Dups.Tracker () -> Dups.Tracker () addAliasDups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () + addUnionDups : A.Located Src.Union -> Dups.Tracker () -> Dups.Tracker () addUnionDups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () + typeNameDups : Dups.Tracker () typeNameDups = List.foldl addUnionDups (List.foldl addAliasDups Dups.none aliases) unions in @@ -123,6 +129,7 @@ addUnion home types ((A.At _ (Src.Union (A.At _ name) _ _)) as union) = R.fmap (\arity -> let + one : Env.Info Env.Type one = Env.Specific home (Env.Union arity home) in @@ -138,9 +145,11 @@ addUnion home types ((A.At _ (Src.Union (A.At _ name) _ _)) as union) = addAliases : List (A.Located Src.Alias) -> Env.Env -> LResult i w Env.Env addAliases aliases env = let + nodes : List ( A.Located Src.Alias, Name, List Name ) nodes = List.map toNode aliases + sccs : List (Graph.SCC (A.Located Src.Alias)) sccs = Graph.stronglyConnComp nodes in @@ -158,9 +167,11 @@ addAlias ({ home, vars, types, ctors, binops, q_vars, q_types, q_ctors } as env) |> R.bind (\ctype -> let + one : Env.Info Env.Type one = Env.Specific home (Env.Alias (List.length args) home args ctype) + ts1 : Dict Name (Env.Info Env.Type) ts1 = Dict.insert compare name one types in @@ -176,6 +187,7 @@ addAlias ({ home, vars, types, ctors, binops, q_vars, q_types, q_ctors } as env) |> R.bind (\args -> let + toName : A.Located Src.Alias -> Name toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name in @@ -224,9 +236,11 @@ getEdges (A.At _ tipe) edges = checkUnionFreeVars : A.Located Src.Union -> LResult i w Int checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = let + addArg : A.Located Name -> Dups.Tracker A.Region -> Dups.Tracker A.Region addArg (A.At region arg) dict = Dups.insert arg region region dict + addCtorFreeVars : ( a, List Src.Type ) -> Dict Name A.Region -> Dict Name A.Region addCtorFreeVars ( _, tipes ) freeVars = List.foldl addFreeVars freeVars tipes in @@ -234,6 +248,7 @@ checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = |> R.bind (\boundVars -> let + freeVars : Dict Name A.Region freeVars = List.foldr addCtorFreeVars Dict.empty ctors in @@ -250,6 +265,7 @@ checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = checkAliasFreeVars : A.Located Src.Alias -> LResult i w (List Name.Name) checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) = let + addArg : A.Located Name -> Dups.Tracker A.Region -> Dups.Tracker A.Region addArg (A.At region arg) dict = Dups.insert arg region region dict in @@ -257,9 +273,11 @@ checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) = |> R.bind (\boundVars -> let + freeVars : Dict Name A.Region freeVars = addFreeVars tipe Dict.empty + overlap : Int overlap = Dict.size (Dict.intersection boundVars freeVars) in @@ -293,6 +311,7 @@ addFreeVars (A.At region tipe) freeVars = Src.TRecord fields maybeExt -> let + extFreeVars : Dict Name A.Region extFreeVars = case maybeExt of Nothing -> @@ -330,6 +349,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env = |> R.bind (\ctors -> let + cs2 : Dict Name (Env.Info Env.Ctor) cs2 = Dict.union compare ctors env.ctors in @@ -354,6 +374,7 @@ type alias CtorDups = canonicalizeAlias : Env.Env -> A.Located Src.Alias -> LResult i w ( ( Name.Name, Can.Alias ), CtorDups ) canonicalizeAlias ({ home } as env) (A.At _ (Src.Alias (A.At region name) args tipe)) = let + vars : List Name vars = List.map A.toValue args in @@ -375,9 +396,11 @@ canonicalizeAlias ({ home } as env) (A.At _ (Src.Alias (A.At region name) args t toRecordCtor : ModuleName.Canonical -> Name.Name -> List Name.Name -> Dict Name.Name Can.FieldType -> Env.Ctor toRecordCtor home name vars fields = let + avars : List ( Name, Can.Type ) avars = List.map (\var -> ( var, Can.TVar var )) vars + alias : Can.Type alias = List.foldr (\( _, t1 ) t2 -> Can.TLambda t1 t2) @@ -397,12 +420,15 @@ canonicalizeUnion ({ home } as env) (A.At _ (Src.Union (A.At _ name) avars ctors |> R.bind (\cctors -> let + vars : List Name vars = List.map A.toValue avars + alts : List Can.Ctor alts = List.map A.toValue cctors + union : Can.Union union = Can.Union vars alts (List.length alts) (toOpts ctors) in diff --git a/src/Compiler/Canonicalize/Expression.elm b/src/Compiler/Canonicalize/Expression.elm index 9c26978a0..31d70867e 100644 --- a/src/Compiler/Canonicalize/Expression.elm +++ b/src/Compiler/Canonicalize/Expression.elm @@ -1,5 +1,6 @@ module Compiler.Canonicalize.Expression exposing - ( FreeLocals + ( EResult + , FreeLocals , Uses(..) , canonicalize , gatherTypedArgs @@ -148,6 +149,7 @@ canonicalize env (A.At region expression) = Src.Update (A.At reg name) fields -> let + makeCanFields : R.RResult i w Error.Error (Dict Name (R.RResult FreeLocals (List W.Warning) Error.Error Can.FieldUpdate)) makeCanFields = Dups.checkFields_ (\r t -> R.fmap (Can.FieldUpdate r) (canonicalize env t)) fields in @@ -230,6 +232,7 @@ canonicalizeCaseBranch env ( pattern, expr ) = canonicalizeBinops : A.Region -> Env.Env -> List ( Src.Expr, A.Located Name.Name ) -> Src.Expr -> EResult FreeLocals (List W.Warning) Can.Expr canonicalizeBinops overallRegion env ops final = let + canonicalizeHelp : ( Src.Expr, A.Located Name ) -> R.RResult FreeLocals (List W.Warning) Error.Error ( Can.Expr, Env.Binop ) canonicalizeHelp ( expr, A.At region op ) = R.ok Tuple.pair |> R.apply (canonicalize env expr) @@ -350,6 +353,7 @@ addBindingsHelp bindings (A.At region pattern) = Src.PRecord fields -> let + addField : A.Located Name -> Dups.Tracker A.Region -> Dups.Tracker A.Region addField (A.At fieldRegion name) dict = Dups.insert name fieldRegion fieldRegion dict in @@ -414,9 +418,11 @@ addDefNodes env nodes (A.At _ def) = |> R.bind (\( cbody, freeLocals ) -> let + cdef : Can.Def cdef = Can.Def aname args cbody + node : ( Binding, Name, List Name ) node = ( Define cdef, name, Dict.keys freeLocals ) in @@ -440,9 +446,11 @@ addDefNodes env nodes (A.At _ def) = |> R.bind (\( cbody, freeLocals ) -> let + cdef : Can.Def cdef = Can.TypedDef aname freeVars args cbody resultType + node : ( Binding, Name, List Name ) node = ( Define cdef, name, Dict.keys freeLocals ) in @@ -464,12 +472,15 @@ addDefNodes env nodes (A.At _ def) = case k Dict.empty ws of Ok (R.ROk freeLocals warnings cbody) -> let + names : List (A.Located Name) names = getPatternNames [] pattern + name : Name name = Name.fromManyNames (List.map A.toValue names) + node : ( Binding, Name, List Name ) node = ( Destruct cpattern cbody, name, Dict.keys freeLocals ) in @@ -723,9 +734,11 @@ verifyBindings context bindings (R.RResult k) = case k Dict.empty warnings of Ok (R.ROk freeLocals warnings1 value) -> let + outerFreeLocals : Dict Name Uses outerFreeLocals = Dict.diff freeLocals bindings + warnings2 : List W.Warning warnings2 = -- NOTE: Uses Map.size for O(1) lookup. This means there is -- no dictionary allocation unless a problem is detected. @@ -768,6 +781,7 @@ delayedUsage (R.RResult k) = case k () warnings of Ok (R.ROk () ws ( value, newFreeLocals )) -> let + delayedLocals : Dict Name Uses delayedLocals = Dict.map (\_ -> delayUse) newFreeLocals in @@ -854,12 +868,15 @@ toVarCtor name ctor = case ctor of Env.Ctor home typeName (Can.Union vars _ _ opts) index args -> let + freeVars : Dict Name () freeVars = Dict.fromList compare (List.map (\v -> ( v, () )) vars) + result : Can.Type result = Can.TType home typeName (List.map Can.TVar vars) + tipe : Can.Type tipe = List.foldr Can.TLambda result args in @@ -867,6 +884,7 @@ toVarCtor name ctor = Env.RecordCtor home vars tipe -> let + freeVars : Dict Name () freeVars = Dict.fromList compare (List.map (\v -> ( v, () )) vars) in diff --git a/src/Compiler/Canonicalize/Module.elm b/src/Compiler/Canonicalize/Module.elm index 75c41db5e..76c3711b2 100644 --- a/src/Compiler/Canonicalize/Module.elm +++ b/src/Compiler/Canonicalize/Module.elm @@ -1,4 +1,4 @@ -module Compiler.Canonicalize.Module exposing (canonicalize) +module Compiler.Canonicalize.Module exposing (MResult, canonicalize) import Compiler.AST.Canonical as Can import Compiler.AST.Source as Src @@ -41,9 +41,11 @@ type alias MResult i w a = canonicalize : Pkg.Name -> Dict ModuleName.Raw I.Interface -> Src.Module -> MResult i (List W.Warning) Can.Module canonicalize pkg ifaces ((Src.Module _ exports docs imports values _ _ binops effects) as modul) = let + home : ModuleName.Canonical home = ModuleName.Canonical pkg (Src.getName modul) + cbinops : Dict Name Can.Binop cbinops = Dict.fromList compare (List.map canonicalizeBinop binops) in @@ -129,6 +131,7 @@ detectBadCycles scc = (A.At region name) = extractDefName def + names : List Name names = List.map (A.toValue << extractDefName) defs in @@ -182,6 +185,7 @@ toNodeOne env (A.At _ (Src.Value ((A.At _ name) as aname) srcArgs body maybeType |> R.fmap (\( cbody, freeLocals ) -> let + def : Can.Def def = Can.Def aname args cbody in @@ -208,6 +212,7 @@ toNodeOne env (A.At _ (Src.Value ((A.At _ name) as aname) srcArgs body maybeType |> R.fmap (\( cbody, freeLocals ) -> let + def : Can.Def def = Can.TypedDef aname freeVars args cbody resultType in @@ -259,6 +264,7 @@ canonicalizeExports values unions aliases binops effects (A.At region exposing_) Src.Explicit exposeds -> let + names : Dict Name () names = Dict.fromList compare (List.map valueToName values) in diff --git a/src/Compiler/Canonicalize/Pattern.elm b/src/Compiler/Canonicalize/Pattern.elm index 53f74f3d8..bc2e7fd17 100644 --- a/src/Compiler/Canonicalize/Pattern.elm +++ b/src/Compiler/Canonicalize/Pattern.elm @@ -1,6 +1,7 @@ module Compiler.Canonicalize.Pattern exposing ( Bindings , DupsDict + , PResult , canonicalize , verify ) @@ -119,6 +120,7 @@ canonicalizeCtor env region name patterns ctor = case ctor of Env.Ctor home tipe union index args -> let + toCanonicalArg : Index.ZeroBased -> Src.Pattern -> Can.Type -> R.RResult DupsDict w Error.Error Can.PatternCtorArg toCanonicalArg argIndex argPattern argTipe = R.fmap (Can.PatternCtorArg argIndex argTipe) (canonicalize env argPattern) @@ -181,6 +183,7 @@ logVar name region value = logFields : List (A.Located Name.Name) -> a -> PResult DupsDict w a logFields fields value = let + addField : A.Located Name.Name -> Dups.Tracker A.Region -> Dups.Tracker A.Region addField (A.At region name) dict = Dups.insert name region region dict in diff --git a/src/Compiler/Canonicalize/Type.elm b/src/Compiler/Canonicalize/Type.elm index 39d506d53..f56622e87 100644 --- a/src/Compiler/Canonicalize/Type.elm +++ b/src/Compiler/Canonicalize/Type.elm @@ -1,5 +1,6 @@ module Compiler.Canonicalize.Type exposing - ( canonicalize + ( CResult + , canonicalize , toAnnotation ) @@ -89,6 +90,7 @@ canonicalize env (A.At typeRegion tipe) = canonicalizeFields : Env.Env -> List ( A.Located Name.Name, Src.Type ) -> List ( A.Located Name.Name, CResult i w Can.FieldType ) canonicalizeFields env fields = let + canonicalizeField : Int -> ( a, Src.Type ) -> ( a, R.RResult i w Error.Error Can.FieldType ) canonicalizeField index ( name, srcType ) = ( name, R.fmap (Can.FieldType index) (canonicalize env srcType) ) in @@ -118,6 +120,7 @@ canonicalizeType env region name args info = checkArity : Int -> A.Region -> Name.Name -> List (A.Located arg) -> answer -> CResult i w answer checkArity expected region name args answer = let + actual : Int actual = List.length args in diff --git a/src/Compiler/Data/Name.elm b/src/Compiler/Data/Name.elm index 72bfddc33..f6f20d08e 100644 --- a/src/Compiler/Data/Name.elm +++ b/src/Compiler/Data/Name.elm @@ -229,9 +229,11 @@ fromTypeVariableScheme scheme = -- writeDigitsAtEnd mba size extra -- freeze mba let + letter : Int letter = remainderBy 26 scheme + extra : Int extra = max 0 (scheme - letter) in diff --git a/src/Compiler/Data/NonEmptyList.elm b/src/Compiler/Data/NonEmptyList.elm index f9eb6313c..f28002fbe 100644 --- a/src/Compiler/Data/NonEmptyList.elm +++ b/src/Compiler/Data/NonEmptyList.elm @@ -63,6 +63,7 @@ foldl1 step (Nonempty x xs) = sortBy : (a -> comparable) -> Nonempty a -> Nonempty a sortBy toRank (Nonempty x xs) = let + comparison : a -> a -> Order comparison a b = compare (toRank a) (toRank b) in diff --git a/src/Compiler/Elm/Compiler/Type.elm b/src/Compiler/Elm/Compiler/Type.elm index effd4bf15..a26cebd72 100644 --- a/src/Compiler/Elm/Compiler/Type.elm +++ b/src/Compiler/Elm/Compiler/Type.elm @@ -151,6 +151,7 @@ fromRawType (A.At _ astType) = Src.TRecord fields ext -> let + fromField : ( A.Located a, Src.Type ) -> ( a, Type ) fromField ( A.At _ field, tipe ) = ( field, fromRawType tipe ) in diff --git a/src/Compiler/Elm/Compiler/Type/Extract.elm b/src/Compiler/Elm/Compiler/Type/Extract.elm index b2f1058c1..da35c1d52 100644 --- a/src/Compiler/Elm/Compiler/Type/Extract.elm +++ b/src/Compiler/Elm/Compiler/Type/Extract.elm @@ -1,5 +1,6 @@ module Compiler.Elm.Compiler.Type.Extract exposing ( Types(..) + , Types_ , fromAnnotation , fromDependencyInterface , fromInterface @@ -157,9 +158,11 @@ fromMsg types message = extractTransitive : Types -> Deps -> Deps -> ( List T.Alias, List T.Union ) extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) = let + aliases : EverySet Opt.Global aliases = EverySet.diff nextAliases seenAliases + unions : EverySet Opt.Global unions = EverySet.diff nextUnions seenUnions in @@ -175,6 +178,7 @@ extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnio |> apply (traverse (extractUnion types) (EverySet.toList unions)) ) + oldDeps : Deps oldDeps = Deps (EverySet.union Opt.compareGlobal seenAliases nextAliases) (EverySet.union Opt.compareGlobal seenUnions nextUnions) @@ -202,6 +206,7 @@ extractUnion (Types dict) (Opt.Global home name) = else let + pname : Name.Name pname = toPublicName home name diff --git a/src/Compiler/Elm/Docs.elm b/src/Compiler/Elm/Docs.elm index fc3a67af8..980f8b39f 100644 --- a/src/Compiler/Elm/Docs.elm +++ b/src/Compiler/Elm/Docs.elm @@ -1,6 +1,7 @@ module Compiler.Elm.Docs exposing ( Alias(..) , Binop(..) + , Comment , Documentation , Error(..) , Module(..) @@ -271,12 +272,15 @@ encodeAssoc assoc = assocDecoder : D.Decoder Error Binop.Associativity assocDecoder = let + left : String left = "left" + non : String non = "non" + right : String right = "right" in @@ -429,6 +433,7 @@ chompUntilDocs = ( ( isDocs, newPos ), ( newRow, newCol ) ) = untilDocs src pos end row col + newState : P.State newState = P.State src newPos end indent newRow newCol in @@ -443,6 +448,7 @@ untilDocs src pos end row col = else let + word : Char word = P.unsafeIndex src pos in @@ -451,6 +457,7 @@ untilDocs src pos end row col = else let + pos5 : Int pos5 = pos + 5 in @@ -467,6 +474,7 @@ untilDocs src pos end row col = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -548,9 +556,11 @@ onlyInExports name (A.At region _) = checkDefs : Dict Name (A.Located Can.Export) -> Src.Comment -> Dict Name Src.Comment -> Can.Module -> Result E.Error Module checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) = let + types : Types types = gatherTypes decls Dict.empty + info : Info info = Info comments types unions aliases infixes effects in @@ -749,6 +759,7 @@ addDef types def = Can.TypedDef (A.At _ name) _ typedArgs _ resultType -> let + tipe : Can.Type tipe = List.foldr Can.TLambda resultType (List.map Tuple.second typedArgs) in diff --git a/src/Compiler/Elm/Kernel.elm b/src/Compiler/Elm/Kernel.elm index 89291924a..f69010945 100644 --- a/src/Compiler/Elm/Kernel.elm +++ b/src/Compiler/Elm/Kernel.elm @@ -1,6 +1,7 @@ module Compiler.Elm.Kernel exposing ( Chunk(..) , Content(..) + , Foreigns , chunkDecoder , chunkEncoder , countFields @@ -150,6 +151,7 @@ chompChunks : VarTable -> Enums -> Fields -> String -> Int -> Int -> Row -> Col chompChunks vs es fs src pos end row col lastPos revChunks = if pos >= end then let + js : String js = toByteString src lastPos end in @@ -157,19 +159,23 @@ chompChunks vs es fs src pos end row col lastPos revChunks = else let + word : Char word = P.unsafeIndex src pos in if word == '_' then let + pos1 : Int pos1 = pos + 1 + pos3 : Int pos3 = pos + 3 in if pos3 <= end && P.unsafeIndex src pos1 == '_' then let + js : String js = toByteString src lastPos pos in @@ -183,6 +189,7 @@ chompChunks vs es fs src pos end row col lastPos revChunks = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -200,10 +207,12 @@ type alias Fields = toByteString : String -> Int -> Int -> String toByteString src pos end = let + off : Int off = -- pos - unsafeForeignPtrToPtr src pos + len : Int len = end - pos in @@ -216,14 +225,17 @@ chompTag vs es fs src pos end row col revChunks = ( newPos, newCol ) = Var.chompInnerChars src pos end col + tagPos : Int tagPos = pos + -1 + word : Char word = P.unsafeIndex src tagPos in if word == '$' then let + name : Name name = Name.fromPtr src pos newPos in @@ -232,9 +244,11 @@ chompTag vs es fs src pos end row col revChunks = else let + name : Name name = Name.fromPtr src tagPos newPos + code : Int code = Char.toCode word in @@ -277,6 +291,7 @@ lookupField name fields = Nothing -> let + n : Int n = Dict.size fields in @@ -286,9 +301,11 @@ lookupField name fields = lookupEnum : Char -> Name -> Enums -> ( Int, Enums ) lookupEnum word var allEnums = let + code : Int code = Char.toCode word + enums : Dict Name Int enums = Dict.get code allEnums |> Maybe.withDefault Dict.empty @@ -299,6 +316,7 @@ lookupEnum word var allEnums = Nothing -> let + n : Int n = Dict.size enums in @@ -327,9 +345,11 @@ addImport pkg foreigns (Src.Import (A.At _ importName) maybeAlias exposing_) vta Nothing -> let + home : Name home = Name.getKernel importName + add : Name -> Dict Name Chunk -> Dict Name Chunk add name table = Dict.insert compare (Name.sepBy '_' home name) (JsVar home name) table in @@ -337,12 +357,15 @@ addImport pkg foreigns (Src.Import (A.At _ importName) maybeAlias exposing_) vta else let + home : ModuleName.Canonical home = ModuleName.Canonical (Dict.get importName foreigns |> Maybe.withDefault pkg) importName + prefix : Name prefix = toPrefix importName maybeAlias + add : Name -> Dict Name Chunk -> Dict Name Chunk add name table = Dict.insert compare (Name.sepBy '_' prefix name) (ElmVar home name) table in diff --git a/src/Compiler/Elm/Licenses.elm b/src/Compiler/Elm/Licenses.elm index fa8801798..a20abaa42 100644 --- a/src/Compiler/Elm/Licenses.elm +++ b/src/Compiler/Elm/Licenses.elm @@ -54,6 +54,7 @@ check givenCode = else let + pairs : List ( String, String ) pairs = List.map (\code -> ( code, code )) (Dict.keys osiApprovedSpdxLicenses) ++ Dict.toList osiApprovedSpdxLicenses diff --git a/src/Compiler/Elm/Magnitude.elm b/src/Compiler/Elm/Magnitude.elm index 0abad4a51..ac21d0fd2 100644 --- a/src/Compiler/Elm/Magnitude.elm +++ b/src/Compiler/Elm/Magnitude.elm @@ -35,6 +35,7 @@ toString = compare : Magnitude -> Magnitude -> Order compare m1 m2 = let + toInt : Magnitude -> number toInt m = case m of PATCH -> diff --git a/src/Compiler/Elm/ModuleName.elm b/src/Compiler/Elm/ModuleName.elm index a861566aa..fbbe91071 100644 --- a/src/Compiler/Elm/ModuleName.elm +++ b/src/Compiler/Elm/ModuleName.elm @@ -114,6 +114,7 @@ parser = in if isGood && (newPos - pos) < 256 then let + newState : P.State newState = P.State src newPos end indent row newCol in @@ -130,6 +131,7 @@ parser = chompStart : String -> Int -> Int -> Int -> ( Bool, Int, Int ) chompStart src pos end col = let + width : Int width = Var.getUpperWidth src pos end in @@ -147,9 +149,11 @@ chompInner src pos end col = else let + word : Char word = P.unsafeIndex src pos + width : Int width = Var.getInnerWidthHelp src pos end word in diff --git a/src/Compiler/Elm/Package.elm b/src/Compiler/Elm/Package.elm index 2f990b890..9fc1e48e3 100644 --- a/src/Compiler/Elm/Package.elm +++ b/src/Compiler/Elm/Package.elm @@ -189,12 +189,15 @@ elm_explorations = suggestions : Dict String Name suggestions = let + random : Name random = toName elm "random" + time : Name time = toName elm "time" + file : Name file = toName elm "file" in @@ -223,12 +226,15 @@ suggestions = nearbyNames : Name -> List Name -> List Name nearbyNames (Name author1 project1) possibleNames = let + authorDist : Author -> Int authorDist = authorDistance author1 + projectDist : Project -> Int projectDist = projectDistance project1 + nameDistance : Name -> Int nameDistance (Name author2 project2) = authorDist author2 + projectDist project2 in @@ -266,6 +272,7 @@ encode name = keyDecoder : (Row -> Col -> x) -> D.KeyDecoder x Name keyDecoder toError = let + keyParser : P.Parser x Name keyParser = P.specialize (\( r, c ) _ _ -> toError r c) parser in @@ -297,6 +304,7 @@ parseName isGoodStart isGoodInner = else let + word : Char word = P.unsafeIndex src pos in @@ -308,14 +316,17 @@ parseName isGoodStart isGoodInner = ( isGood, newPos ) = chompName isGoodInner src (pos + 1) end False + len : Int len = newPos - pos + newCol : Col newCol = col + len in if isGood && len < 256 then let + newState : P.State newState = P.State src newPos end indent row newCol in @@ -347,6 +358,7 @@ chompName isGoodChar src pos end prevWasDash = else let + word : Char word = P.unsafeIndex src pos in diff --git a/src/Compiler/Elm/String.elm b/src/Compiler/Elm/String.elm index 08d633170..d3f4ecd3b 100644 --- a/src/Compiler/Elm/String.elm +++ b/src/Compiler/Elm/String.elm @@ -18,30 +18,9 @@ type Chunk fromChunks : String -> List Chunk -> String fromChunks src chunks = - let - len = - List.sum (List.map chunkToWidth chunks) - in writeChunks src "" 0 chunks -chunkToWidth : Chunk -> Int -chunkToWidth chunk = - case chunk of - Slice _ len -> - len - - Escape _ -> - 2 - - CodePoint c -> - if c < 0xFFFF then - 6 - - else - 12 - - writeChunks : String -> String -> Int -> List Chunk -> String writeChunks src mba offset chunks = case chunks of @@ -52,6 +31,7 @@ writeChunks src mba offset chunks = case chunk of Slice ptr len -> let + newOffset : Int newOffset = offset + len in @@ -59,6 +39,7 @@ writeChunks src mba offset chunks = Escape word -> let + newOffset : Int newOffset = offset + 2 in @@ -67,6 +48,7 @@ writeChunks src mba offset chunks = CodePoint code -> if code < 0xFFFF then let + newOffset : Int newOffset = offset + 6 in @@ -74,6 +56,7 @@ writeChunks src mba offset chunks = else let + newOffset : Int newOffset = offset + 12 in diff --git a/src/Compiler/Elm/Version.elm b/src/Compiler/Elm/Version.elm index 413568c4f..6a6592d63 100644 --- a/src/Compiler/Elm/Version.elm +++ b/src/Compiler/Elm/Version.elm @@ -173,11 +173,13 @@ numberParser = else let + word : Char word = P.unsafeIndex src pos in if word == '0' then let + newState : P.State newState = P.State src (pos + 1) end indent row (col + 1) in @@ -188,6 +190,7 @@ numberParser = ( total, newPos ) = chompWord16 src (pos + 1) end (Char.toCode word - 0x30) + newState : P.State newState = P.State src newPos end indent row (col + (newPos - pos)) in @@ -204,6 +207,7 @@ chompWord16 src pos end total = else let + word : Char word = P.unsafeIndex src pos in diff --git a/src/Compiler/Generate/JavaScript.elm b/src/Compiler/Generate/JavaScript.elm index dee087335..137a987ce 100644 --- a/src/Compiler/Generate/JavaScript.elm +++ b/src/Compiler/Generate/JavaScript.elm @@ -1,5 +1,6 @@ module Compiler.Generate.JavaScript exposing - ( generate + ( Mains + , generate , generateForRepl , generateForReplEndpoint ) @@ -42,6 +43,7 @@ type alias Mains = generate : Mode.Mode -> Opt.GlobalGraph -> Mains -> String generate mode (Opt.GlobalGraph graph _) mains = let + state : State state = Dict.foldr (addMain mode graph) emptyState mains in @@ -78,12 +80,15 @@ perfNote mode = generateForRepl : Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> String generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) = let + mode : Mode.Mode mode = Mode.Dev Nothing + debugState : State debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString") + evalState : State evalState = addGlobal mode graph debugState (Opt.Global home name) in @@ -96,15 +101,19 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ print : Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> String print ansi localizer home name tipe = let + value : JsName.Name value = JsName.fromGlobal home name + toString : JsName.Name toString = JsName.fromKernel Name.debug "toAnsiString" + tipeDoc : D.Doc tipeDoc = RT.canToDoc localizer RT.None tipe + bool : String bool = if ansi then "true" @@ -132,15 +141,19 @@ print ansi localizer home name tipe = generateForReplEndpoint : L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> String generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) = let + name : Name.Name name = Maybe.maybe Name.replValueToPrint identity maybeName + mode : Mode.Mode mode = Mode.Dev Nothing + debugState : State debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString") + evalState : State evalState = addGlobal mode graph debugState (Opt.Global home name) in @@ -152,18 +165,23 @@ generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can. postMessage : L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> String postMessage localizer home maybeName tipe = let + name : Name.Name name = Maybe.maybe Name.replValueToPrint identity maybeName + value : JsName.Name value = JsName.fromGlobal home name + toString : JsName.Name toString = JsName.fromKernel Name.debug "toAnsiString" + tipeDoc : D.Doc tipeDoc = RT.canToDoc localizer RT.None tipe + toName : String -> String toName n = "\"" ++ n ++ "\"" in @@ -210,8 +228,10 @@ addGlobal mode graph ((State revKernels builders seen) as state) global = addGlobalHelp : Mode.Mode -> Graph -> Opt.Global -> State -> State addGlobalHelp mode graph global state = let + addDeps : EverySet Opt.Global -> State -> State addDeps deps someState = let + sortedDeps : List Opt.Global sortedDeps = -- This is required given that it looks like `Data.Set.union` sorts its elements List.sortWith Opt.compareGlobal (EverySet.toList deps) @@ -346,9 +366,11 @@ generateSafeCycle mode home ( name, expr ) = generateRealCycle : ModuleName.Canonical -> ( Name.Name, expr ) -> JS.Stmt generateRealCycle home ( name, _ ) = let + safeName : JsName.Name safeName = JsName.fromCycle home name + realName : JsName.Name realName = JsName.fromGlobal home name in @@ -363,15 +385,19 @@ generateRealCycle home ( name, _ ) = drawCycle : List Name.Name -> String drawCycle names = let + topLine : String topLine = "\\n ┌─────┐" + nameLine : String -> String nameLine name = "\\n │ " ++ name + midLine : String midLine = "\\n │ ↓" + bottomLine : String bottomLine = "\\n └─────┘" in @@ -476,6 +502,7 @@ generatePort mode (Opt.Global home name) makePort converter = generateManager : Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State generateManager mode graph (Opt.Global ((ModuleName.Canonical _ moduleName) as home) _) effectsType state = let + managerLVar : JS.LValue managerLVar = JS.LBracket (JS.ExprRef (JsName.fromKernel Name.platform "effectManagers")) @@ -484,6 +511,7 @@ generateManager mode graph (Opt.Global ((ModuleName.Canonical _ moduleName) as h ( deps, args, stmts ) = generateManagerHelp home effectsType + createManager : JS.Stmt createManager = JS.ExprStmt <| JS.ExprAssign managerLVar <| @@ -507,9 +535,11 @@ leaf = generateManagerHelp : ModuleName.Canonical -> Opt.EffectsType -> ( List Opt.Global, List JS.Expr, List JS.Stmt ) generateManagerHelp home effectsType = let + dep : Name.Name -> Opt.Global dep name = Opt.Global home name + ref : Name.Name -> JS.Expr ref name = JS.ExprRef (JsName.fromGlobal home name) in @@ -542,9 +572,11 @@ generateManagerHelp home effectsType = toMainExports : Mode.Mode -> Mains -> String toMainExports mode mains = let + export : JsName.Name export = JsName.fromKernel Name.platform "export" + exports : String exports = generateExports mode (Dict.foldr addToTrie emptyTrie mains) in @@ -554,6 +586,7 @@ toMainExports mode mains = generateExports : Mode.Mode -> Trie -> String generateExports mode (Trie maybeMain subs) = let + starter : String -> String starter end = case maybeMain of Nothing -> diff --git a/src/Compiler/Generate/JavaScript/Builder.elm b/src/Compiler/Generate/JavaScript/Builder.elm index c958a1c96..a26992067 100644 --- a/src/Compiler/Generate/JavaScript/Builder.elm +++ b/src/Compiler/Generate/JavaScript/Builder.elm @@ -151,6 +151,7 @@ levelZero = makeLevel : Int -> String -> Level makeLevel level oldTabs = let + tabs : String tabs = if level <= String.length oldTabs then oldTabs @@ -339,6 +340,7 @@ merge a b = linesMap : (a -> ( Lines, b )) -> List a -> ( Bool, List b ) linesMap func xs = let + pairs : List ( Lines, b ) pairs = List.map func xs in @@ -461,12 +463,15 @@ fromExpr ((Level indent nextLevel) as level) grouping expression = ExprIf condExpr thenExpr elseExpr -> let + condB : String condB = Tuple.second (fromExpr level Atomic condExpr) + thenB : String thenB = Tuple.second (fromExpr level Atomic thenExpr) + elseB : String elseB = Tuple.second (fromExpr level Atomic elseExpr) in diff --git a/src/Compiler/Generate/JavaScript/Expression.elm b/src/Compiler/Generate/JavaScript/Expression.elm index 336426517..16b1fab7b 100644 --- a/src/Compiler/Generate/JavaScript/Expression.elm +++ b/src/Compiler/Generate/JavaScript/Expression.elm @@ -129,6 +129,7 @@ generate mode expression = Opt.Destruct (Opt.Destructor name path) body -> let + pathDef : JS.Stmt pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path) in @@ -184,11 +185,13 @@ generate mode expression = Opt.Shader src attributes uniforms -> let + toTranlation : Name.Name -> ( JsName.Name, JS.Expr ) toTranlation field = ( JsName.fromLocal field , JS.ExprString (generateField mode field) ) + toTranslationObject : EverySet.EverySet Name.Name -> JS.Expr toTranslationObject fields = JS.ExprObject (List.map toTranlation (EverySet.toList fields)) in @@ -267,9 +270,11 @@ toChar = generateCtor : Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code generateCtor mode (Opt.Global home name) index arity = let + argNames : List JsName.Name argNames = Index.indexedMap (\i _ -> JsName.fromIndex i) (List.range 1 arity) + ctorTag : JS.Expr ctorTag = case mode of Mode.Dev _ -> @@ -300,6 +305,7 @@ ctorToInt home name index = generateRecord : Mode.Mode -> Dict Name.Name Opt.Expr -> JS.Expr generateRecord mode fields = let + toPair : ( Name.Name, Opt.Expr ) -> ( JsName.Name, JS.Expr ) toPair ( field, value ) = ( generateField mode field, generateJsExpr mode value ) in @@ -373,6 +379,7 @@ generateFunction args body = Nothing -> let + addArg : JsName.Name -> Code -> Code addArg arg code = JsExpr <| JS.ExprFunction Nothing [ arg ] <| @@ -542,6 +549,7 @@ generateBasicsCall mode home name args = case args of [ elmArg ] -> let + arg : JS.Expr arg = generateJsExpr mode elmArg in @@ -576,9 +584,11 @@ generateBasicsCall mode home name args = _ -> let + left : JS.Expr left = generateJsExpr mode elmLeft + right : JS.Expr right = generateJsExpr mode elmRight in @@ -699,6 +709,7 @@ apply func value = append : Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr append mode left right = let + seqs : List JS.Expr seqs = generateJsExpr mode left :: toSeqs mode right in @@ -809,9 +820,11 @@ strictNEq left right = generateTailCall : Mode.Mode -> Name.Name -> List ( Name.Name, Opt.Expr ) -> List JS.Stmt generateTailCall mode name args = let + toTempVars : ( String, Opt.Expr ) -> ( JsName.Name, JS.Expr ) toTempVars ( argName, arg ) = ( JsName.makeTemp argName, generateJsExpr mode arg ) + toRealVars : ( Name.Name, b ) -> JS.Stmt toRealVars ( argName, _ ) = JS.ExprStmt <| JS.ExprAssign (JS.LRef (JsName.fromLocal argName)) (JS.ExprRef (JsName.makeTemp argName)) in @@ -880,14 +893,17 @@ generateIf mode givenBranches givenFinal = ( branches, final ) = crushIfs givenBranches givenFinal + convertBranch : ( Opt.Expr, Opt.Expr ) -> ( JS.Expr, Code ) convertBranch ( condition, expr ) = ( generateJsExpr mode condition , generate mode expr ) + branchExprs : List ( JS.Expr, Code ) branchExprs = List.map convertBranch branches + finalCode : Code finalCode = generate mode final in @@ -954,6 +970,7 @@ generateCase mode label root decider jumps = goto : Mode.Mode -> Name.Name -> ( Int, Opt.Expr ) -> List JS.Stmt -> List JS.Stmt goto mode label ( index, branch ) stmts = let + labeledDeciderStmt : JS.Stmt labeledDeciderStmt = JS.Labelled (JsName.makeLabel label index) @@ -992,12 +1009,14 @@ generateDecider mode label root decisionTree = generateIfTest : Mode.Mode -> Name.Name -> ( DT.Path, DT.Test ) -> JS.Expr generateIfTest mode root ( path, test ) = let + value : JS.Expr value = pathToJsExpr mode root path in case test of DT.IsCtor home name index _ opts -> let + tag : JS.Expr tag = case mode of Mode.Dev _ -> @@ -1099,6 +1118,7 @@ generateCaseValue mode test = generateCaseTest : Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr generateCaseTest mode root path exampleTest = let + value : JS.Expr value = pathToJsExpr mode root path in diff --git a/src/Compiler/Generate/JavaScript/Name.elm b/src/Compiler/Generate/JavaScript/Name.elm index ce2ccb055..f5f1c03b1 100644 --- a/src/Compiler/Generate/JavaScript/Name.elm +++ b/src/Compiler/Generate/JavaScript/Name.elm @@ -241,11 +241,13 @@ intToAsciiHelp width blockSize badFields n = (BadFields renamings) :: biggerBadFields -> let + availableSize : Int availableSize = blockSize - Dict.size renamings in if n < availableSize then let + name : Name.Name name = unsafeIntToAscii width [] n in @@ -266,9 +268,11 @@ unsafeIntToAscii width bytes n = else let + quotient : Int quotient = n // numInnerBytes + remainder : Int remainder = n - (numInnerBytes * quotient) in @@ -331,6 +335,7 @@ type alias Renamings = allBadFields : List BadFields allBadFields = let + add : String -> Dict Int BadFields -> Dict Int BadFields add keyword dict = Dict.update compare (String.length keyword) (Just << addRenaming keyword) dict in @@ -340,9 +345,11 @@ allBadFields = addRenaming : String -> Maybe BadFields -> BadFields addRenaming keyword maybeBadFields = let + width : Int width = String.length keyword + maxName : Int maxName = numStartBytes * numInnerBytes ^ (width - 1) - 1 in diff --git a/src/Compiler/Generate/Mode.elm b/src/Compiler/Generate/Mode.elm index 55d719ae4..689f79bf9 100644 --- a/src/Compiler/Generate/Mode.elm +++ b/src/Compiler/Generate/Mode.elm @@ -62,6 +62,7 @@ addToShortNames fields shortNames = addField : Name.Name -> ShortFieldNames -> ShortFieldNames addField field shortNames = let + rename : JsName.Name rename = JsName.fromInt (Dict.size shortNames) in diff --git a/src/Compiler/Json/Decode.elm b/src/Compiler/Json/Decode.elm index b26464848..5a911cd79 100644 --- a/src/Compiler/Json/Decode.elm +++ b/src/Compiler/Json/Decode.elm @@ -699,9 +699,11 @@ pString start = \(P.State src pos end indent row col) -> if pos < end && P.unsafeIndex src pos == '"' then let + pos1 : Int pos1 = pos + 1 + col1 : Col col1 = col + 1 @@ -711,13 +713,16 @@ pString start = case status of GoodString -> let + off : Int off = -- FIXME pos1 - unsafeForeignPtrToPtr src pos1 + len : Int len = (newPos - pos1) - 1 + snp : P.Snippet snp = P.Snippet { fptr = src @@ -727,6 +732,7 @@ pString start = , offCol = col1 } + newState : P.State newState = P.State src newPos end indent newRow newCol in @@ -759,6 +765,7 @@ pStringHelp src pos end row col = '\\' -> let + pos1 : Int pos1 = pos + 1 in @@ -798,6 +805,7 @@ pStringHelp src pos end row col = {- u -} 'u' -> let + pos6 : Int pos6 = pos + 6 in @@ -822,6 +830,7 @@ pStringHelp src pos end row col = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -831,6 +840,7 @@ pStringHelp src pos end row col = isHex : Char -> Bool isHex word = let + code : Int code = Char.toCode word in @@ -859,6 +869,7 @@ spaces = else let + newState : P.State newState = P.State src newPos end indent newRow newCol in @@ -902,6 +913,7 @@ pInt = else let + word : Char word = P.unsafeIndex src pos in @@ -910,14 +922,17 @@ pInt = else if word == '0' then let + pos1 : Int pos1 = pos + 1 + newState : P.State newState = P.State src pos1 end indent row (col + 1) in if pos1 < end then let + word1 : Char word1 = P.unsafeIndex src pos1 in @@ -938,12 +953,14 @@ pInt = ( status, n, newPos ) = chompInt src (pos + 1) end (Char.toCode word - 0x30 {- 0 -}) + len : Int len = newPos - pos in case status of GoodInt -> let + newState : P.State newState = P.State src newPos end indent row (col + len) in @@ -962,11 +979,13 @@ chompInt : String -> Int -> Int -> Int -> ( IntStatus, Int, Int ) chompInt src pos end n = if pos < end then let + word : Char word = P.unsafeIndex src pos in if isDecimalDigit word then let + m : Int m = 10 * n + (Char.toCode word - 0x30 {- 0 -}) in @@ -985,6 +1004,7 @@ chompInt src pos end n = isDecimalDigit : Char -> Bool isDecimalDigit word = let + code : Int code = Char.toCode word in diff --git a/src/Compiler/Json/Encode.elm b/src/Compiler/Json/Encode.elm index 0efa1bc10..26636b22b 100644 --- a/src/Compiler/Json/Encode.elm +++ b/src/Compiler/Json/Encode.elm @@ -27,7 +27,6 @@ module Compiler.Json.Encode exposing import Compiler.Data.NonEmptyList as NE import Compiler.Data.OneOrMore exposing (OneOrMore(..)) -import Compiler.Json.String as Json import Data.IO as IO exposing (IO(..)) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) @@ -186,6 +185,7 @@ escape chrs = c :: cs -> let + escapedChar : String escapedChar = case c of '\u{000D}' -> @@ -320,12 +320,15 @@ encodeHelp indent value = encodeArray : String -> Value -> List Value -> String encodeArray indent first rest = let + newIndent : String newIndent = indent ++ " " + closer : String closer = "\n" ++ indent ++ "]" + addValue : Value -> String -> String addValue field builder = ",\n" ++ newIndent ++ encodeHelp newIndent field ++ builder in @@ -339,12 +342,15 @@ encodeArray indent first rest = encodeObject : String -> ( String, Value ) -> List ( String, Value ) -> String encodeObject indent first rest = let + newIndent : String newIndent = indent ++ " " + closer : String closer = "\n" ++ indent ++ "}" + addValue : ( String, Value ) -> String -> String addValue field builder = ",\n" ++ newIndent ++ encodeField newIndent field ++ builder in diff --git a/src/Compiler/Json/String.elm b/src/Compiler/Json/String.elm index 37fdd3057..c113723ee 100644 --- a/src/Compiler/Json/String.elm +++ b/src/Compiler/Json/String.elm @@ -55,9 +55,11 @@ toChars = fromComment : P.Snippet -> String fromComment ((P.Snippet { fptr, offset, length }) as snippet) = let + pos : Int pos = offset + end : Int end = pos + length in @@ -71,6 +73,7 @@ chompChunks src pos end start revChunks = else let + word : Char word = P.unsafeIndex src pos in @@ -87,6 +90,7 @@ chompChunks src pos end start revChunks = {- \r -} '\u{000D}' -> let + newPos : Int newPos = pos + 1 in @@ -94,9 +98,11 @@ chompChunks src pos end start revChunks = _ -> let + width : Int width = P.getCharWidth word + newPos : Int newPos = pos + width in @@ -106,6 +112,7 @@ chompChunks src pos end start revChunks = chompEscape : String -> Char -> Int -> Int -> Int -> List Chunk -> List Chunk chompEscape src escape pos end start revChunks = let + pos1 : Int pos1 = pos + 1 in diff --git a/src/Compiler/Nitpick/PatternMatches.elm b/src/Compiler/Nitpick/PatternMatches.elm index de38816a5..1f6b07fbf 100644 --- a/src/Compiler/Nitpick/PatternMatches.elm +++ b/src/Compiler/Nitpick/PatternMatches.elm @@ -122,6 +122,7 @@ nil = unit : Can.Union unit = let + ctor : Can.Ctor ctor = Can.Ctor unitName Index.first 0 [] in @@ -131,6 +132,7 @@ unit = pair : Can.Union pair = let + ctor : Can.Ctor ctor = Can.Ctor pairName Index.first 2 [ Can.TVar "a", Can.TVar "b" ] in @@ -140,6 +142,7 @@ pair = triple : Can.Union triple = let + ctor : Can.Ctor ctor = Can.Ctor tripleName Index.first 3 [ Can.TVar "a", Can.TVar "b", Can.TVar "c" ] in @@ -149,9 +152,11 @@ triple = list : Can.Union list = let + nilCtor : Can.Ctor nilCtor = Can.Ctor nilName Index.first 0 [] + consCtor : Can.Ctor consCtor = Can.Ctor consName Index.second @@ -440,9 +445,11 @@ isExhaustive matrix n = else let + ctors : Dict Name.Name Can.Union ctors = collectCtors matrix + numSeen : Int numSeen = Dict.size ctors in @@ -462,6 +469,7 @@ isExhaustive matrix n = else let + isAltExhaustive : Can.Ctor -> List (List Pattern) isAltExhaustive (Can.Ctor name _ arity _) = List.map (recoverCtor alts name arity) (isExhaustive @@ -511,6 +519,7 @@ toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns = ((A.At region _) as pattern) :: rest -> let + nextRow : List Pattern nextRow = [ simplify pattern ] in @@ -561,6 +570,7 @@ isUseful matrix vector = -- of those. But what if some of those Ctors have subpatterns -- that make them less general? If so, this actually is useful! let + isUsefulAlt : Can.Ctor -> Bool isUsefulAlt (Can.Ctor name _ arity _) = isUseful (List.filterMap (specializeRowByCtor name arity) matrix) @@ -657,9 +667,11 @@ type Complete isComplete : List (List Pattern) -> Complete isComplete matrix = let + ctors : Dict Name.Name Can.Union ctors = collectCtors matrix + numSeen : Int numSeen = Dict.size ctors in diff --git a/src/Compiler/Optimize/Case.elm b/src/Compiler/Optimize/Case.elm index 89cdedcf9..f06461c4d 100644 --- a/src/Compiler/Optimize/Case.elm +++ b/src/Compiler/Optimize/Case.elm @@ -21,9 +21,11 @@ optimize temp root optBranches = ( patterns, indexedBranches ) = List.unzip (List.indexedMap indexify optBranches) + decider : Opt.Decider Int decider = treeToDecider (DT.compile patterns) + targetCounts : Dict Int Int targetCounts = countTargets decider @@ -92,6 +94,7 @@ treeToDecider tree = toChain : DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int toChain path test successTree failureTree = let + failure : Opt.Decider Int failure = treeToDecider failureTree in @@ -143,6 +146,7 @@ createChoices targetCounts ( target, branch ) = insertChoices : Dict Int Opt.Choice -> Opt.Decider Int -> Opt.Decider Opt.Choice insertChoices choiceDict decider = let + go : Opt.Decider Int -> Opt.Decider Opt.Choice go = insertChoices choiceDict in diff --git a/src/Compiler/Optimize/DecisionTree.elm b/src/Compiler/Optimize/DecisionTree.elm index 020e35c74..a2806ea88 100644 --- a/src/Compiler/Optimize/DecisionTree.elm +++ b/src/Compiler/Optimize/DecisionTree.elm @@ -51,6 +51,7 @@ of this module though. compile : List ( Can.Pattern, Int ) -> DecisionTree compile rawBranches = let + format : ( Can.Pattern, Int ) -> Branch format ( pattern, index ) = Branch index [ ( Empty, pattern ) ] in @@ -147,6 +148,7 @@ type Branch toDecisionTree : List Branch -> DecisionTree toDecisionTree rawBranches = let + branches : List Branch branches = List.map flattenPatterns rawBranches in @@ -156,12 +158,14 @@ toDecisionTree rawBranches = Nothing -> let + path : Path path = pickPath branches ( edges, fallback ) = gatherEdges branches path + decisionEdges : List ( Test, DecisionTree ) decisionEdges = List.map (Tuple.mapSecond toDecisionTree) edges in @@ -324,12 +328,15 @@ checkForMatch branches = gatherEdges : List Branch -> Path -> ( List ( Test, List Branch ), List Branch ) gatherEdges branches path = let + relevantTests : List Test relevantTests = testsAtPath path branches + allEdges : List ( Test, List Branch ) allEdges = List.map (edgesFor path branches) relevantTests + fallbacks : List Branch fallbacks = if isComplete relevantTests then [] @@ -347,9 +354,11 @@ gatherEdges branches path = testsAtPath : Path -> List Branch -> List Test testsAtPath selectedPath branches = let + allTests : List Test allTests = List.filterMap (testAtPath selectedPath) branches + skipVisited : Test -> ( List Test, EverySet.EverySet Test ) -> ( List Test, EverySet.EverySet Test ) skipVisited test (( uniqueTests, visitedTests ) as curr) = if EverySet.member test visitedTests then curr @@ -437,10 +446,6 @@ toRelevantBranch test path ((Branch goal pathPatterns) as branch) = Found start (A.At region pattern) end -> case pattern of Can.PCtor { union, name, args } -> - let - (Can.Union _ _ numAlts _) = - union - in case test of IsCtor _ testName _ _ _ -> if name == testName then @@ -448,6 +453,10 @@ toRelevantBranch test path ((Branch goal pathPatterns) as branch) = (Branch goal <| case List.map dearg args of (arg :: []) as args_ -> + let + (Can.Union _ _ numAlts _) = + union + in if numAlts == 1 then start ++ (( Unbox path, arg ) :: end) @@ -476,6 +485,7 @@ toRelevantBranch test path ((Branch goal pathPatterns) as branch) = case test of IsCons -> let + tl_ : A.Located Can.Pattern_ tl_ = A.At region (Can.PList tl) in @@ -662,6 +672,7 @@ needsTests (A.At _ pattern) = pickPath : List Branch -> Path pickPath branches = let + allPaths : List Path allPaths = List.filterMap isChoicePath (List.concatMap (\(Branch _ patterns) -> patterns) branches) in @@ -695,6 +706,7 @@ bests allPaths = ( headPath, headWeight ) :: weightedPaths -> let + gatherMinimum : ( a, comparable ) -> ( comparable, List a ) -> ( comparable, List a ) gatherMinimum ( path, weight ) (( minWeight, paths ) as acc) = if weight == minWeight then ( minWeight, path :: paths ) diff --git a/src/Compiler/Optimize/Expression.elm b/src/Compiler/Optimize/Expression.elm index 549d88ca5..0f633e6f0 100644 --- a/src/Compiler/Optimize/Expression.elm +++ b/src/Compiler/Optimize/Expression.elm @@ -1,5 +1,6 @@ module Compiler.Optimize.Expression exposing - ( destructArgs + ( Cycle + , destructArgs , optimize , optimizePotentialTailCall ) @@ -116,6 +117,7 @@ optimize cycle (A.At region expression) = Can.If branches finally -> let + optimizeBranch : ( Can.Expr, Can.Expr ) -> Names.Tracker ( Opt.Expr, Opt.Expr ) optimizeBranch ( condition, branch ) = optimize cycle condition |> Names.bind @@ -170,6 +172,7 @@ optimize cycle (A.At region expression) = Can.Case expr branches -> let + optimizeBranch : Name.Name -> Can.CaseBranch -> Names.Tracker ( Can.Pattern, Opt.Expr ) optimizeBranch root (Can.CaseBranch pattern branch) = destructCase root pattern |> Names.bind @@ -295,6 +298,7 @@ optimizeDefHelp cycle name args expr body = |> Names.fmap (\( argNames, destructors ) -> let + ofunc : Opt.Expr ofunc = Opt.Function argNames (List.foldr Opt.Destruct oexpr destructors) in @@ -356,6 +360,7 @@ destructHelp path (A.At region pattern) revDs = Can.PRecord fields -> let + toDestruct : Name.Name -> Opt.Destructor toDestruct name = Opt.Destructor name (Opt.Field name path) in @@ -383,6 +388,7 @@ destructHelp path (A.At region pattern) revDs = |> Names.bind (\name -> let + newRoot : Opt.Path newRoot = Opt.Root name in @@ -413,12 +419,12 @@ destructHelp path (A.At region pattern) revDs = Names.pure revDs Can.PCtor { union, args } -> - let - (Can.Union _ _ _ opts) = - union - in case args of [ Can.PatternCtorArg _ _ arg ] -> + let + (Can.Union _ _ _ opts) = + union + in case opts of Can.Normal -> destructHelp (Opt.Index Index.first path) arg revDs @@ -458,6 +464,7 @@ destructTwo path a b revDs = |> Names.bind (\name -> let + newRoot : Opt.Path newRoot = Opt.Root name in @@ -503,6 +510,7 @@ optimizeTail cycle rootName argNames ((A.At _ expression) as locExpr) = |> Names.bind (\oargs -> let + isMatchingName : Bool isMatchingName = case A.toValue func of Can.VarLocal name -> @@ -530,6 +538,7 @@ optimizeTail cycle rootName argNames ((A.At _ expression) as locExpr) = Can.If branches finally -> let + optimizeBranch : ( Can.Expr, Can.Expr ) -> Names.Tracker ( Opt.Expr, Opt.Expr ) optimizeBranch ( condition, branch ) = optimize cycle condition |> Names.bind @@ -584,6 +593,7 @@ optimizeTail cycle rootName argNames ((A.At _ expression) as locExpr) = Can.Case expr branches -> let + optimizeBranch : Name.Name -> Can.CaseBranch -> Names.Tracker ( Can.Pattern, Opt.Expr ) optimizeBranch root (Can.CaseBranch pattern branch) = destructCase root pattern |> Names.bind diff --git a/src/Compiler/Optimize/Module.elm b/src/Compiler/Optimize/Module.elm index 0d7de521f..74061fa11 100644 --- a/src/Compiler/Optimize/Module.elm +++ b/src/Compiler/Optimize/Module.elm @@ -1,4 +1,4 @@ -module Compiler.Optimize.Module exposing (optimize) +module Compiler.Optimize.Module exposing (Annotations, MResult, optimize) import Compiler.AST.Canonical as Can import Compiler.AST.Optimized as Opt @@ -60,6 +60,7 @@ addUnion home (Can.Union _ ctors _ opts) nodes = addCtorNode : ModuleName.Canonical -> Can.CtorOpts -> Can.Ctor -> Nodes -> Nodes addCtorNode home opts (Can.Ctor name index numArgs _) nodes = let + node : Opt.Node node = case opts of Can.Normal -> @@ -88,11 +89,13 @@ addAlias home name (Can.Alias _ tipe) ((Opt.LocalGraph main nodes fieldCounts) a case tipe of Can.TRecord fields Nothing -> let + function : Opt.Expr function = Opt.Function (List.map Tuple.first (Can.fieldsToList fields)) <| Opt.Record <| Dict.map (\field _ -> Opt.VarLocal field) fields + node : Opt.Node node = Opt.Define function EverySet.empty in @@ -125,18 +128,23 @@ addEffects home effects ((Opt.LocalGraph main nodes fields) as graph) = Can.Manager _ _ _ manager -> let + fx : Opt.Global fx = Opt.Global home "$fx$" + cmd : Opt.Global cmd = Opt.Global home "command" + sub : Opt.Global sub = Opt.Global home "subscription" + link : Opt.Node link = Opt.Link fx + newNodes : Dict Opt.Global Opt.Node newNodes = case manager of Can.Cmd _ -> @@ -163,6 +171,7 @@ addPort home name port_ graph = ( deps, fields, decoder ) = Names.run (Port.toDecoder payload) + node : Opt.Node node = Opt.PortIncoming decoder deps in @@ -173,6 +182,7 @@ addPort home name port_ graph = ( deps, fields, encoder ) = Names.run (Port.toEncoder payload) + node : Opt.Node node = Opt.PortOutgoing encoder deps in @@ -204,6 +214,7 @@ addDecls home annotations decls graph = Can.DeclareRec d ds subDecls -> let + defs : List Can.Def defs = d :: ds in @@ -280,6 +291,7 @@ addDefHelp region annotations home name args body ((Opt.LocalGraph _ nodes field (Can.Forall _ tipe) = Utils.find name annotations + addMain : ( EverySet Opt.Global, Dict Name.Name Int, Opt.Main ) -> Opt.LocalGraph addMain ( deps, fields, main ) = addDefNode home name args body deps <| Opt.LocalGraph (Just main) nodes (Utils.mapUnionWith compare (+) fields fieldCounts) @@ -346,15 +358,19 @@ type State addRecDefs : ModuleName.Canonical -> List Can.Def -> Opt.LocalGraph -> Opt.LocalGraph addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) = let + names : List Name.Name names = List.reverse (List.map toName defs) + cycleName : Opt.Global cycleName = Opt.Global home (Name.fromManyNames names) + cycle : EverySet Name.Name cycle = List.foldr addValueName EverySet.empty defs + links : Dict Opt.Global Opt.Node links = List.foldr (addLink home (Opt.Link cycleName)) Dict.empty defs diff --git a/src/Compiler/Optimize/Names.elm b/src/Compiler/Optimize/Names.elm index f3a1999d1..58d6e80e4 100644 --- a/src/Compiler/Optimize/Names.elm +++ b/src/Compiler/Optimize/Names.elm @@ -71,6 +71,7 @@ registerGlobal home name = Tracker <| \uid deps fields -> let + global : Opt.Global global = Opt.Global home name in @@ -82,6 +83,7 @@ registerDebug name home region = Tracker <| \uid deps fields -> let + global : Opt.Global global = Opt.Global ModuleName.debug name in @@ -93,9 +95,11 @@ registerCtor home name index opts = Tracker <| \uid deps fields -> let + global : Opt.Global global = Opt.Global home name + newDeps : EverySet Opt.Global newDeps = EverySet.insert Opt.compareGlobal global deps in diff --git a/src/Compiler/Optimize/Port.elm b/src/Compiler/Optimize/Port.elm index 487eac8d8..197cb4ec1 100644 --- a/src/Compiler/Optimize/Port.elm +++ b/src/Compiler/Optimize/Port.elm @@ -79,11 +79,13 @@ toEncoder tipe = Can.TRecord fields Nothing -> let + encodeField : ( Name, Can.FieldType ) -> Names.Tracker Opt.Expr encodeField ( name, Can.FieldType _ fieldType ) = toEncoder fieldType |> Names.fmap (\encoder -> let + value : Opt.Expr value = Opt.Call encoder [ Opt.Access (Opt.VarLocal Name.dollar) name ] in @@ -152,9 +154,11 @@ encodeArray tipe = encodeTuple : Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr encodeTuple a b maybeC = let + let_ : Name -> Index.ZeroBased -> Opt.Expr -> Opt.Expr let_ arg index body = Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root Name.dollar))) body + encodeArg : Name -> Can.Type -> Names.Tracker Opt.Expr encodeArg arg tipe = toEncoder tipe |> Names.fmap (\encoder -> Opt.Call encoder [ Opt.VarLocal arg ]) @@ -370,6 +374,7 @@ decodeTuple a b maybeC = case maybeC of Nothing -> let + tuple : Opt.Expr tuple = Opt.Tuple (toLocal 0) (toLocal 1) Nothing in @@ -378,6 +383,7 @@ decodeTuple a b maybeC = Just c -> let + tuple : Opt.Expr tuple = Opt.Tuple (toLocal 0) (toLocal 1) (Just (toLocal 2)) in @@ -420,9 +426,11 @@ indexAndThen i tipe decoder = decodeRecord : Dict Name.Name Can.FieldType -> Names.Tracker Opt.Expr decodeRecord fields = let + toFieldExpr : Name -> b -> Opt.Expr toFieldExpr name _ = Opt.VarLocal name + record : Opt.Expr record = Opt.Record (Dict.map toFieldExpr fields) in diff --git a/src/Compiler/Parse/Declaration.elm b/src/Compiler/Parse/Declaration.elm index 4bd7b0580..48cc9380f 100644 --- a/src/Compiler/Parse/Declaration.elm +++ b/src/Compiler/Parse/Declaration.elm @@ -119,9 +119,11 @@ chompDefArgsAndBody maybeDocs start name tipe revArgs = |> P.fmap (\( body, end ) -> let + value : Src.Value value = Src.Value name (List.reverse revArgs) body tipe + avalue : A.Located Src.Value avalue = A.at start end value in @@ -169,6 +171,7 @@ typeDecl maybeDocs start = |> P.fmap (\( tipe, end ) -> let + alias : A.Located Src.Alias alias = A.at start end (Src.Alias name args tipe) in @@ -187,6 +190,7 @@ typeDecl maybeDocs start = |> P.fmap (\( variants, end ) -> let + union : A.Located Src.Union union = A.at start end (Src.Union name args variants) in @@ -307,9 +311,11 @@ portDecl maybeDocs = infix_ : P.Parser E.Module (A.Located Src.Infix) infix_ = let + err : P.Row -> P.Col -> E.Module err = E.Infix + err_ : a -> P.Row -> P.Col -> E.Module err_ = \_ -> E.Infix in diff --git a/src/Compiler/Parse/Expression.elm b/src/Compiler/Parse/Expression.elm index 4c64df2a7..af9e398d6 100644 --- a/src/Compiler/Parse/Expression.elm +++ b/src/Compiler/Parse/Expression.elm @@ -182,9 +182,11 @@ tuple ((A.Position row col) as start) = |> P.bind (\_ -> let + exprStart : A.Position exprStart = A.Position row (col + 2) + expr : A.Located Src.Expr_ expr = A.at exprStart end (Src.Negate negatedExpr) in @@ -423,6 +425,7 @@ chompExprEnd start (State { ops, expr, args, end }) = |> P.bind (\_ -> let + arg : A.Located Src.Expr_ arg = A.at opStart newEnd (Src.Negate negatedExpr) in @@ -440,6 +443,7 @@ chompExprEnd start (State { ops, expr, args, end }) = else let + err : P.Row -> P.Col -> E.Expr err = E.OperatorRight opName in @@ -455,6 +459,7 @@ chompExprEnd start (State { ops, expr, args, end }) = |> P.bind (\_ -> let + newOps : List ( Src.Expr, A.Located Name.Name ) newOps = ( toCall expr args, op ) :: ops in @@ -479,9 +484,11 @@ chompExprEnd start (State { ops, expr, args, end }) = |> P.fmap (\( newLast, newEnd ) -> let + newOps : List ( Src.Expr, A.Located Name.Name ) newOps = ( toCall expr args, op ) :: ops + finalExpr : Src.Expr_ finalExpr = Src.Binops (List.reverse newOps) newLast in @@ -559,6 +566,7 @@ chompIfEnd start branches = |> P.bind (\_ -> let + newBranches : List ( Src.Expr, Src.Expr ) newBranches = ( condition, thenBranch ) :: branches in @@ -569,6 +577,7 @@ chompIfEnd start branches = |> P.fmap (\( elseBranch, elseEnd ) -> let + ifExpr : Src.Expr_ ifExpr = Src.If (List.reverse newBranches) elseBranch in @@ -600,6 +609,7 @@ function start = |> P.fmap (\( body, end ) -> let + funcExpr : Src.Expr_ funcExpr = Src.Lambda (List.reverse revArgs) body in diff --git a/src/Compiler/Parse/Keyword.elm b/src/Compiler/Parse/Keyword.elm index 2d9be1094..ffb822598 100644 --- a/src/Compiler/Parse/Keyword.elm +++ b/src/Compiler/Parse/Keyword.elm @@ -167,6 +167,7 @@ subscription_ toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos12 : Int pos12 = pos + 12 in @@ -187,6 +188,7 @@ subscription_ toError = && (Var.getInnerWidth src pos12 end == 0) then let + s : P.State s = P.State src pos12 end indent row (col + 12) in @@ -205,6 +207,7 @@ k2 w1 w2 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos2 : Int pos2 = pos + 2 in @@ -215,6 +218,7 @@ k2 w1 w2 toError = && (Var.getInnerWidth src pos2 end == 0) then let + s : P.State s = P.State src pos2 end indent row (col + 2) in @@ -229,6 +233,7 @@ k3 w1 w2 w3 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos3 : Int pos3 = pos + 3 in @@ -240,6 +245,7 @@ k3 w1 w2 w3 toError = && (Var.getInnerWidth src pos3 end == 0) then let + s : P.State s = P.State src pos3 end indent row (col + 3) in @@ -254,6 +260,7 @@ k4 w1 w2 w3 w4 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos4 : Int pos4 = pos + 4 in @@ -266,6 +273,7 @@ k4 w1 w2 w3 w4 toError = && (Var.getInnerWidth src pos4 end == 0) then let + s : P.State s = P.State src pos4 end indent row (col + 4) in @@ -280,6 +288,7 @@ k5 w1 w2 w3 w4 w5 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos5 : Int pos5 = pos + 5 in @@ -293,6 +302,7 @@ k5 w1 w2 w3 w4 w5 toError = && (Var.getInnerWidth src pos5 end == 0) then let + s : P.State s = P.State src pos5 end indent row (col + 5) in @@ -307,6 +317,7 @@ k6 w1 w2 w3 w4 w5 w6 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos6 : Int pos6 = pos + 6 in @@ -321,6 +332,7 @@ k6 w1 w2 w3 w4 w5 w6 toError = && (Var.getInnerWidth src pos6 end == 0) then let + s : P.State s = P.State src pos6 end indent row (col + 6) in @@ -335,6 +347,7 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos7 : Int pos7 = pos + 7 in @@ -350,6 +363,7 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError = && (Var.getInnerWidth src pos7 end == 0) then let + s : P.State s = P.State src pos7 end indent row (col + 7) in @@ -364,6 +378,7 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError = P.Parser <| \(P.State src pos end indent row col) -> let + pos8 : Int pos8 = pos + 8 in @@ -380,6 +395,7 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError = && (Var.getInnerWidth src pos8 end == 0) then let + s : P.State s = P.State src pos8 end indent row (col + 8) in diff --git a/src/Compiler/Parse/Number.elm b/src/Compiler/Parse/Number.elm index 13d5883cc..0d3271a54 100644 --- a/src/Compiler/Parse/Number.elm +++ b/src/Compiler/Parse/Number.elm @@ -46,6 +46,7 @@ number toExpectation toError = else let + word : Char word = String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ' in @@ -54,6 +55,7 @@ number toExpectation toError = else let + outcome : Outcome outcome = if word == '0' then chompZero src (pos + 1) end @@ -64,6 +66,7 @@ number toExpectation toError = case outcome of Err_ newPos problem -> let + newCol : Col newCol = col + (newPos - pos) in @@ -71,12 +74,15 @@ number toExpectation toError = OkInt newPos n -> let + newCol : Col newCol = col + (newPos - pos) + integer : Number integer = Int n + newState : P.State newState = P.State src newPos end indent row newCol in @@ -84,9 +90,11 @@ number toExpectation toError = OkFloat newPos -> let + newCol : Col newCol = col + (newPos - pos) + copy : Float copy = case String.toFloat (String.slice pos newPos src) of Just copy_ -> @@ -95,9 +103,11 @@ number toExpectation toError = Nothing -> todo "Failed `String.toFloat`" + float : Number float = Float copy + newState : P.State newState = P.State src newPos end indent row newCol in @@ -125,6 +135,7 @@ chompInt src pos end n = else let + word : Char word = String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ' in @@ -151,6 +162,7 @@ chompInt src pos end n = chompFraction : String -> Int -> Int -> Int -> Outcome chompFraction src pos end n = let + pos1 : Int pos1 = pos + 1 in @@ -171,6 +183,7 @@ chompFractionHelp src pos end = else let + word : Char word = String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ' in @@ -198,6 +211,7 @@ chompExponent src pos end = else let + word : Char word = String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ' in @@ -206,6 +220,7 @@ chompExponent src pos end = else if word == '+' || word == '-' then let + pos1 : Int pos1 = pos + 1 in @@ -242,6 +257,7 @@ chompZero src pos end = else let + word : Char word = String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ' in @@ -290,6 +306,7 @@ chompHexHelp src pos end answer accumulator = else let + newAnswer : Int newAnswer = stepHex src pos end (String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ') accumulator in @@ -337,6 +354,7 @@ precedence toExpectation = else let + word : Char word = String.uncons (String.dropLeft pos src) |> Maybe.map Tuple.first |> Maybe.withDefault ' ' in diff --git a/src/Compiler/Parse/Pattern.elm b/src/Compiler/Parse/Pattern.elm index 650e0c104..b6cc4de5f 100644 --- a/src/Compiler/Parse/Pattern.elm +++ b/src/Compiler/Parse/Pattern.elm @@ -47,6 +47,7 @@ termHelp start = |> P.fmap (\end -> let + region : A.Region region = A.Region start end in @@ -73,6 +74,7 @@ termHelp start = P.Parser <| \(P.State _ _ _ _ row col) -> let + width : Int width = String.fromFloat float |> String.length @@ -100,9 +102,11 @@ wildcard = else let + newPos : Int newPos = pos + 1 + newCol : P.Col newCol = col + 1 in @@ -115,6 +119,7 @@ wildcard = else let + newState : P.State newState = P.State src newPos end indent row newCol in @@ -290,6 +295,7 @@ exprHelp start revPatterns ( pattern, end ) = |> P.fmap (\_ -> let + alias_ : A.Located Name.Name alias_ = A.at nameStart newEnd name in diff --git a/src/Compiler/Parse/Primitives.elm b/src/Compiler/Parse/Primitives.elm index 1ea083fa5..88522a147 100644 --- a/src/Compiler/Parse/Primitives.elm +++ b/src/Compiler/Parse/Primitives.elm @@ -192,6 +192,7 @@ bind callback (Parser parserA) = fromByteString : Parser x a -> (Row -> Col -> x) -> String -> Result x a fromByteString (Parser parser) toBadEnd src = let + initialState : State initialState = State src 0 (String.length src) 0 1 1 in @@ -234,6 +235,7 @@ type Snippet fromSnippet : Parser x a -> (Row -> Col -> x) -> Snippet -> Result x a fromSnippet (Parser parser) toBadEnd (Snippet { fptr, offset, length, offRow, offCol }) = let + initialState : State initialState = State fptr offset (offset + length) 0 offRow offCol in @@ -298,6 +300,7 @@ setIndent indent = Parser <| \(State src pos end _ row col) -> let + newState : State newState = State src pos end indent row col in @@ -371,6 +374,7 @@ word1 word toError = \(State src pos end indent row col) -> if pos < end && unsafeIndex src pos == word then let + newState : State newState = State src (pos + 1) end indent row (col + 1) in @@ -385,11 +389,13 @@ word2 w1 w2 toError = Parser <| \(State src pos end indent row col) -> let + pos1 : Int pos1 = pos + 1 in if pos < end && unsafeIndex src pos == w1 && unsafeIndex src pos1 == w2 then let + newState : State newState = State src (pos + 2) end indent row (col + 2) in diff --git a/src/Compiler/Parse/Shader.elm b/src/Compiler/Parse/Shader.elm index ebfaa1103..15d17562c 100644 --- a/src/Compiler/Parse/Shader.elm +++ b/src/Compiler/Parse/Shader.elm @@ -41,6 +41,7 @@ parseBlock = P.Parser <| \(P.State src pos end indent row col) -> let + pos6 : Int pos6 = pos + 6 in @@ -60,15 +61,19 @@ parseBlock = case status of Good -> let + off : Int off = pos6 + len : Int len = newPos - pos6 + block : String block = String.left len (String.dropLeft off src) + newState : P.State newState = P.State src (newPos + 2) end indent newRow (newCol + 2) in @@ -93,6 +98,7 @@ eatShader src pos end row col = else let + word : Char word = P.unsafeIndex src pos in @@ -104,6 +110,7 @@ eatShader src pos end row col = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -123,13 +130,16 @@ parseGlsl startRow startCol src = Err { position, messages } -> -- FIXME this should be moved into guida-lang/glsl let + lines : List String lines = String.left position src |> String.lines + row : Int row = List.length lines + col : Int col = case List.reverse lines of lastLine :: _ -> @@ -138,6 +148,7 @@ parseGlsl startRow startCol src = _ -> 0 + msg : String msg = showErrorMessages messages in diff --git a/src/Compiler/Parse/Space.elm b/src/Compiler/Parse/Space.elm index 655375f60..cf39664c8 100644 --- a/src/Compiler/Parse/Space.elm +++ b/src/Compiler/Parse/Space.elm @@ -37,6 +37,7 @@ chomp toError = case status of Good -> let + newState : P.State newState = P.State src newPos end indent newRow newCol in @@ -102,6 +103,7 @@ chompAndCheckIndent toSpaceError toIndentError = Good -> if newCol > indent && newCol > 1 then let + newState : P.State newState = P.State src newPos end indent newRow newCol in @@ -145,6 +147,7 @@ eatSpaces src pos end row col = '-' -> let + pos1 : Int pos1 = pos + 1 in @@ -175,6 +178,7 @@ eatLineComment src pos end row col = else let + word : Char word = P.unsafeIndex src pos in @@ -183,6 +187,7 @@ eatLineComment src pos end row col = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -196,36 +201,40 @@ eatLineComment src pos end row col = eatMultiComment : String -> Int -> Int -> Row -> Col -> ( ( Status, Int ), ( Row, Col ) ) eatMultiComment src pos end row col = let - pos1 = - pos + 1 - + pos2 : Int pos2 = pos + 2 in if pos2 >= end then ( ( Good, pos ), ( row, col ) ) - else if P.unsafeIndex src pos1 == '-' then - if P.unsafeIndex src pos2 == '|' then - ( ( Good, pos ), ( row, col ) ) + else + let + pos1 : Int + pos1 = + pos + 1 + in + if P.unsafeIndex src pos1 == '-' then + if P.unsafeIndex src pos2 == '|' then + ( ( Good, pos ), ( row, col ) ) - else - let - ( ( status, newPos ), ( newRow, newCol ) ) = - eatMultiCommentHelp src pos2 end row (col + 2) 1 - in - case status of - MultiGood -> - eatSpaces src newPos end newRow newCol + else + let + ( ( status, newPos ), ( newRow, newCol ) ) = + eatMultiCommentHelp src pos2 end row (col + 2) 1 + in + case status of + MultiGood -> + eatSpaces src newPos end newRow newCol - MultiTab -> - ( ( HasTab, newPos ), ( newRow, newCol ) ) + MultiTab -> + ( ( HasTab, newPos ), ( newRow, newCol ) ) - MultiEndless -> - ( ( EndlessMultiComment, pos ), ( row, col ) ) + MultiEndless -> + ( ( EndlessMultiComment, pos ), ( row, col ) ) - else - ( ( Good, pos ), ( row, col ) ) + else + ( ( Good, pos ), ( row, col ) ) type MultiStatus @@ -241,6 +250,7 @@ eatMultiCommentHelp src pos end row col openComments = else let + word : Char word = P.unsafeIndex src pos in @@ -262,6 +272,7 @@ eatMultiCommentHelp src pos end row col openComments = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -277,6 +288,7 @@ docComment toExpectation toSpaceError = P.Parser <| \(P.State src pos end indent row col) -> let + pos3 : Int pos3 = pos + 3 in @@ -287,6 +299,7 @@ docComment toExpectation toSpaceError = && (P.unsafeIndex src (pos + 2) == '|') then let + col3 : Col col3 = col + 3 @@ -296,12 +309,15 @@ docComment toExpectation toSpaceError = case status of MultiGood -> let + off : Int off = pos3 + len : Int len = newPos - pos3 - 2 + snippet : P.Snippet snippet = P.Snippet { fptr = src @@ -311,9 +327,11 @@ docComment toExpectation toSpaceError = , offCol = col3 } + comment : Src.Comment comment = Src.Comment snippet + newState : P.State newState = P.State src newPos end indent newRow newCol in diff --git a/src/Compiler/Parse/String.elm b/src/Compiler/Parse/String.elm index 0f7f52335..d35b764fa 100644 --- a/src/Compiler/Parse/String.elm +++ b/src/Compiler/Parse/String.elm @@ -28,9 +28,11 @@ character toExpectation toError = else let + newState : P.State newState = P.State src newPos end indent row newCol + char : String char = ES.fromChunks src [ mostRecent ] in @@ -57,6 +59,7 @@ chompChar src pos end row col numChars mostRecent = else let + word : Char word = P.unsafeIndex src pos in @@ -85,9 +88,11 @@ chompChar src pos end row col numChars mostRecent = else let + width : Int width = P.getCharWidth word + newPos : Int newPos = pos + width in @@ -104,20 +109,24 @@ string toExpectation toError = (\(P.State src pos end indent row col) -> if isDoubleQuote src pos end then let + pos1 : Int pos1 = pos + 1 in case if isDoubleQuote src pos1 end then let + pos2 : Int pos2 = pos + 2 in if isDoubleQuote src pos2 end then let + pos3 : Int pos3 = pos + 3 + col3 : Col col3 = col + 3 in @@ -131,6 +140,7 @@ string toExpectation toError = of SROk newPos newRow newCol utf8 -> let + newState : P.State newState = P.State src newPos end indent newRow newCol in @@ -186,6 +196,7 @@ singleString src pos end row col initialPos revChunks = else let + word : Char word = P.unsafeIndex src pos in @@ -198,6 +209,7 @@ singleString src pos end row col initialPos revChunks = else if word == '\'' then let + newPos : Int newPos = pos + 1 in @@ -211,6 +223,7 @@ singleString src pos end row col initialPos revChunks = EscapeUnicode delta code -> let + newPos : Int newPos = pos + delta in @@ -225,6 +238,7 @@ singleString src pos end row col initialPos revChunks = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -242,6 +256,7 @@ multiString src pos end row col initialPos sr sc revChunks = else let + word : Char word = P.unsafeIndex src pos in @@ -251,6 +266,7 @@ multiString src pos end row col initialPos sr sc revChunks = else if word == '\'' then let + pos1 : Int pos1 = pos + 1 in @@ -259,6 +275,7 @@ multiString src pos end row col initialPos sr sc revChunks = else if word == '\n' then let + pos1 : Int pos1 = pos + 1 in @@ -267,6 +284,7 @@ multiString src pos end row col initialPos sr sc revChunks = else if word == '\u{000D}' then let + pos1 : Int pos1 = pos + 1 in @@ -280,6 +298,7 @@ multiString src pos end row col initialPos sr sc revChunks = EscapeUnicode delta code -> let + newPos : Int newPos = pos + delta in @@ -294,6 +313,7 @@ multiString src pos end row col initialPos sr sc revChunks = else let + newPos : Int newPos = pos + P.getCharWidth word in @@ -350,12 +370,14 @@ eatUnicode src pos end row col = else let + digitPos : Int digitPos = pos + 1 ( newPos, code ) = Number.chompHex src digitPos end + numDigits : Int numDigits = newPos - digitPos in diff --git a/src/Compiler/Parse/Symbol.elm b/src/Compiler/Parse/Symbol.elm index 51d245c9d..21a090ea7 100644 --- a/src/Compiler/Parse/Symbol.elm +++ b/src/Compiler/Parse/Symbol.elm @@ -30,6 +30,7 @@ operator toExpectation toError = P.Parser <| \(P.State src pos end indent row col) -> let + newPos : Int newPos = chompOps src pos end in @@ -55,9 +56,11 @@ operator toExpectation toError = op -> let + newCol : Col newCol = col + (newPos - pos) + newState : P.State newState = P.State src newPos end indent row newCol in @@ -86,6 +89,7 @@ isBinopChar src pos = isBinopCharHelp : Char -> Bool isBinopCharHelp char = let + code : Int code = Char.toCode char in diff --git a/src/Compiler/Parse/Type.elm b/src/Compiler/Parse/Type.elm index cd3416891..88cb792d8 100644 --- a/src/Compiler/Parse/Type.elm +++ b/src/Compiler/Parse/Type.elm @@ -30,6 +30,7 @@ term = |> P.fmap (\end -> let + region : A.Region region = A.Region start end in @@ -161,6 +162,7 @@ expression = |> P.fmap (\( tipe2, end2 ) -> let + tipe : A.Located Src.Type_ tipe = A.at start end2 (Src.TLambda tipe1 tipe2) in @@ -194,9 +196,11 @@ app start = |> P.fmap (\( args, end ) -> let + region : A.Region region = A.Region start upperEnd + tipe : Src.Type_ tipe = case upper of Var.Unqualified name -> diff --git a/src/Compiler/Parse/Variable.elm b/src/Compiler/Parse/Variable.elm index 0fc0dab22..c3047963d 100644 --- a/src/Compiler/Parse/Variable.elm +++ b/src/Compiler/Parse/Variable.elm @@ -36,6 +36,7 @@ upper toError = else let + name : Name name = Name.fromPtr src pos newPos in @@ -59,6 +60,7 @@ lower toError = else let + name : Name name = Name.fromPtr src pos newPos in @@ -67,6 +69,7 @@ lower toError = else let + newState : P.State newState = P.State src newPos end indent row newCol in @@ -116,9 +119,11 @@ moduleName toError = case status of Good -> let + name : Name name = Name.fromPtr src pos newPos + newState : P.State newState = P.State src newPos end indent row newCol in @@ -137,6 +142,7 @@ moduleNameHelp : String -> Int -> Int -> Col -> ( ModuleNameStatus, Int, Col ) moduleNameHelp src pos end col = if isDot src pos end then let + pos1 : Int pos1 = pos + 1 @@ -175,18 +181,22 @@ foreignUpper toError = else let + newState : P.State newState = P.State src upperEnd end indent row newCol + name : Name name = Name.fromPtr src upperStart upperEnd + upperName : Upper upperName = if upperStart == pos then Unqualified name else let + home : Name home = Name.fromPtr src pos (upperStart + -1) in @@ -228,9 +238,11 @@ foreignAlpha toError = else let + name : Name name = Name.fromPtr src alphaStart alphaEnd + newState : P.State newState = P.State src alphaEnd end indent row newCol in @@ -243,6 +255,7 @@ foreignAlpha toError = else let + home : Name home = Name.fromPtr src pos (alphaStart + -1) in @@ -290,6 +303,7 @@ isDot src pos end = chompUpper : String -> Int -> Int -> Col -> ( Int, Col ) chompUpper src pos end col = let + width : Int width = getUpperWidth src pos end in @@ -312,6 +326,7 @@ getUpperWidth src pos end = getUpperWidthHelp : String -> Int -> Int -> Char -> Int getUpperWidthHelp src pos _ word = let + code : Int code = Char.toCode word in @@ -353,6 +368,7 @@ getUpperWidthHelp src pos _ word = chompLower : String -> Int -> Int -> Col -> ( Int, Col ) chompLower src pos end col = let + width : Int width = getLowerWidth src pos end in @@ -375,6 +391,7 @@ getLowerWidth src pos end = getLowerWidthHelp : String -> Int -> Int -> Char -> Int getLowerWidthHelp src pos _ word = let + code : Int code = Char.toCode word in @@ -416,6 +433,7 @@ getLowerWidthHelp src pos _ word = chompInnerChars : String -> Int -> Int -> Col -> ( Int, Col ) chompInnerChars src pos end col = let + width : Int width = getInnerWidth src pos end in @@ -438,6 +456,7 @@ getInnerWidth src pos end = getInnerWidthHelp : String -> Int -> Int -> Char -> Int getInnerWidthHelp src pos _ word = let + code : Int code = Char.toCode word in @@ -488,15 +507,19 @@ getInnerWidthHelp src pos _ word = chr2 : String -> Int -> Char -> Char chr2 src pos firstWord = let + i1 : Int i1 = unpack firstWord + i2 : Int i2 = unpack (P.unsafeIndex src (pos + 1)) + c1 : Int c1 = Bitwise.shiftLeftBy 6 (i1 - 0xC0) + c2 : Int c2 = i2 - 0x80 in @@ -506,21 +529,27 @@ chr2 src pos firstWord = chr3 : String -> Int -> Char -> Char chr3 src pos firstWord = let + i1 : Int i1 = unpack firstWord + i2 : Int i2 = unpack (P.unsafeIndex src (pos + 1)) + i3 : Int i3 = unpack (P.unsafeIndex src (pos + 2)) + c1 : Int c1 = Bitwise.shiftLeftBy 12 (i1 - 0xE0) + c2 : Int c2 = Bitwise.shiftLeftBy 6 (i2 - 0x80) + c3 : Int c3 = i3 - 0x80 in @@ -530,27 +559,35 @@ chr3 src pos firstWord = chr4 : String -> Int -> Char -> Char chr4 src pos firstWord = let + i1 : Int i1 = unpack firstWord + i2 : Int i2 = unpack (P.unsafeIndex src (pos + 1)) + i3 : Int i3 = unpack (P.unsafeIndex src (pos + 2)) + i4 : Int i4 = unpack (P.unsafeIndex src (pos + 3)) + c1 : Int c1 = Bitwise.shiftLeftBy 18 (i1 - 0xF0) + c2 : Int c2 = Bitwise.shiftLeftBy 12 (i2 - 0x80) + c3 : Int c3 = Bitwise.shiftLeftBy 6 (i3 - 0x80) + c4 : Int c4 = i4 - 0x80 in diff --git a/src/Compiler/Reporting/Doc.elm b/src/Compiler/Reporting/Doc.elm index 81de2cc88..cfd1918e6 100644 --- a/src/Compiler/Reporting/Doc.elm +++ b/src/Compiler/Reporting/Doc.elm @@ -30,7 +30,6 @@ import List.Extra as List import Prelude import System.Console.Ansi as Ansi import Text.PrettyPrint.ANSI.Leijen as P -import Utils.Crash exposing (crash) @@ -79,6 +78,7 @@ toString doc = toLine : Doc -> String toLine doc = let + maxBound : number maxBound = 2147483647 in @@ -218,27 +218,32 @@ ordinal index = intToOrdinal : Int -> String intToOrdinal number = let - remainder10 = - modBy 10 number - + remainder100 : Int remainder100 = modBy 100 number + ending : String ending = if List.member remainder100 [ 11, 12, 13 ] then "th" - else if remainder10 == 1 then - "st" - - else if remainder10 == 2 then - "nd" - - else if remainder10 == 3 then - "rd" - else - "th" + let + remainder10 : Int + remainder10 = + modBy 10 number + in + if remainder10 == 1 then + "st" + + else if remainder10 == 2 then + "nd" + + else if remainder10 == 3 then + "rd" + + else + "th" in String.fromInt number ++ ending @@ -246,6 +251,7 @@ intToOrdinal number = cycle : Int -> Name -> List Name -> Doc cycle indent_ name names = let + toLn : Name -> P.Doc toLn n = P.append cycleLn (P.dullyellow (fromName n)) in @@ -338,17 +344,10 @@ type Color toJsonHelp : Style -> List String -> P.SimpleDoc -> List E.Value toJsonHelp style revChunks simpleDoc = case simpleDoc of - P.SFail -> - crash <| - "according to the main implementation, @SFail@ can not appear uncaught in a rendered @SimpleDoc@" - P.SEmpty -> [ encodeChunks style revChunks ] - P.SChar char rest -> - toJsonHelp style (String.fromChar char :: revChunks) rest - - P.SText _ string rest -> + P.SText string rest -> toJsonHelp style (string :: revChunks) rest P.SLine indent_ rest -> @@ -426,6 +425,7 @@ toColor layer intensity color = Ansi.Foreground -> let + pick : b -> b -> b pick dull vivid = case intensity of Ansi.Dull -> @@ -464,6 +464,7 @@ toColor layer intensity color = encodeChunks : Style -> List String -> E.Value encodeChunks (Style bold underline color) revChunks = let + chars : String chars = String.concat (List.reverse revChunks) in diff --git a/src/Compiler/Reporting/Error.elm b/src/Compiler/Reporting/Error.elm index 11a922ba0..837e18ece 100644 --- a/src/Compiler/Reporting/Error.elm +++ b/src/Compiler/Reporting/Error.elm @@ -127,9 +127,11 @@ toDocHelp root module1 modules = toSeparator : Module -> Module -> D.Doc toSeparator beforeModule afterModule = let + before : ModuleName.Raw before = beforeModule.name ++ " ↑ " + after : String after = " ↓ " ++ afterModule.name in @@ -150,9 +152,11 @@ toSeparator beforeModule afterModule = moduleToDoc : String -> Module -> D.Doc moduleToDoc root { absolutePath, source, error } = let + reports : NE.Nonempty Report.Report reports = toReports (Code.toSource source) error + relativePath : Utils.FilePath relativePath = Utils.fpMakeRelative root absolutePath in @@ -172,6 +176,7 @@ reportToDoc relativePath (Report.Report title _ _ message) = toMessageBar : String -> String -> D.Doc toMessageBar title filePath = let + usedSpace : Int usedSpace = 4 + String.length title + 1 + String.length filePath in @@ -192,6 +197,7 @@ toMessageBar title filePath = toJson : Module -> E.Value toJson { name, absolutePath, source, error } = let + reports : NE.Nonempty Report.Report reports = toReports (Code.toSource source) error in diff --git a/src/Compiler/Reporting/Error/Canonicalize.elm b/src/Compiler/Reporting/Error/Canonicalize.elm index 9041a633a..43522a966 100644 --- a/src/Compiler/Reporting/Error/Canonicalize.elm +++ b/src/Compiler/Reporting/Error/Canonicalize.elm @@ -168,9 +168,11 @@ toReport source err = case err of AnnotationTooShort region name index leftovers -> let + numTypeArgs : Int numTypeArgs = Index.toMachine index + numDefArgs : Int numDefArgs = numTypeArgs + leftovers in @@ -213,6 +215,7 @@ toReport source err = BadArity region badArityContext name expected actual -> let + thing : String thing = case badArityContext of TypeArity -> @@ -363,6 +366,7 @@ toReport source err = ExportDuplicate name r1 r2 -> let + messageThatEndsWithPunctuation : String messageThatEndsWithPunctuation = "You are trying to expose `" ++ name ++ "` multiple times!" in @@ -380,6 +384,7 @@ toReport source err = ExportNotFound region kind rawName possibleNames -> let + suggestions : List String suggestions = List.take 4 <| Suggest.sort rawName identity possibleNames in @@ -503,6 +508,7 @@ toReport source err = ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames -> let + suggestions : List String suggestions = List.take 4 <| Suggest.sort home identity possibleNames in @@ -603,9 +609,11 @@ toReport source err = else let + suggestions : List String suggestions = List.take 2 <| Suggest.sort op identity (EverySet.toList locals) + format : D.Doc -> D.Doc format altOp = D.green (D.fromChars "(" @@ -658,6 +666,7 @@ toReport source err = PortPayloadInvalid region portName _ invalidPayload -> let + formatDetails : ( String, D.Doc ) -> Report.Report formatDetails ( aBadKindOfThing, elaboration ) = Report.Report "PORT ERROR" region [] <| Code.toSnippet source @@ -708,6 +717,7 @@ toReport source err = PortTypeInvalid region name portProblem -> let + formatDetails : ( String, D.Doc ) -> Report.Report formatDetails ( before, after ) = Report.Report "BAD PORT" region [] <| Code.toSnippet source @@ -734,6 +744,7 @@ toReport source err = CmdExtraArgs n -> ( "The `" ++ name ++ "` port can only send ONE value out to JavaScript." , let + theseItemsInSomething : String theseItemsInSomething = if n == 2 then "both of these items into a tuple or record" @@ -775,6 +786,7 @@ toReport source err = RecursiveDecl region name names -> let + makeTheory : String -> String -> D.Doc makeTheory question details = D.fillSep <| List.map (D.dullyellow << D.fromChars) (String.words question) ++ List.map D.fromChars (String.words details) in @@ -805,6 +817,7 @@ toReport source err = case names of [] -> let + makeTheory : String -> String -> D.Doc makeTheory question details = D.fillSep <| List.map (D.dullyellow << D.fromChars) (String.words question) ++ List.map D.fromChars (String.words details) in @@ -827,6 +840,7 @@ toReport source err = Shadowing name r1 r2 -> let + advice : D.Doc advice = D.stack [ D.reflow <| "Think of a more helpful name for one of them and you should be all set!" @@ -864,11 +878,13 @@ toReport source err = case ( unusedVars, unboundVars ) of ( unused :: unuseds, [] ) -> let + backQuote : Name -> D.Doc backQuote name = D.fromChars "`" |> D.a (D.fromName name) |> D.a (D.fromChars "`") + allUnusedNames : List Name allUnusedNames = List.map Tuple.first unusedVars @@ -927,12 +943,15 @@ toReport source err = ( _, _ ) -> let + unused : List Name unused = List.map Tuple.first unusedVars + unbound : List Name unbound = List.map Tuple.first unboundVars + theseAreUsed : List D.Doc theseAreUsed = case unbound of [ x ] -> @@ -973,6 +992,7 @@ toReport source err = , D.fromChars "declared." ] + butTheseAreUnused : List D.Doc butTheseAreUnused = case unused of [ x ] -> @@ -1012,6 +1032,7 @@ toReport source err = unboundTypeVars : Code.Source -> A.Region -> List D.Doc -> Name.Name -> List Name.Name -> ( Name.Name, A.Region ) -> List ( Name.Name, A.Region ) -> Report.Report unboundTypeVars source declRegion tipe typeName allVars ( unboundVar, varRegion ) unboundVars = let + backQuote : Name -> D.Doc backQuote name = D.fromChars "`" |> D.a (D.fromName name) @@ -1093,6 +1114,7 @@ nameClash source r1 r2 messageThatEndsWithPunctuation = ambiguousName : Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report ambiguousName source region maybePrefix name h hs thing = let + possibleHomes : List ModuleName.Canonical possibleHomes = List.sortWith ModuleName.compareCanonical (h :: OneOrMore.destruct (::) hs) in @@ -1101,6 +1123,7 @@ ambiguousName source region maybePrefix name h hs thing = case maybePrefix of Nothing -> let + homeToYellowDoc : ModuleName.Canonical -> D.Doc homeToYellowDoc (ModuleName.Canonical _ home) = D.dullyellow (D.fromName home @@ -1122,6 +1145,7 @@ ambiguousName source region maybePrefix name h hs thing = Just prefix -> let + homeToYellowDoc : ModuleName.Canonical -> D.Doc homeToYellowDoc (ModuleName.Canonical _ home) = if prefix == home then D.cyan (D.fromChars "import") @@ -1133,6 +1157,7 @@ ambiguousName source region maybePrefix name h hs thing = |> D.plus (D.cyan (D.fromChars "as")) |> D.plus (D.fromName prefix) + eitherOrAny : String eitherOrAny = if List.length possibleHomes == 2 then "either" @@ -1157,19 +1182,24 @@ ambiguousName source region maybePrefix name h hs thing = notFound : Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> String -> PossibleNames -> Report.Report notFound source region maybePrefix name thing { locals, quals } = let + givenName : Name givenName = Maybe.withDefault name (Maybe.map2 toQualString maybePrefix (Just name)) + possibleNames : List String possibleNames = let + addQuals : Name -> EverySet Name -> List String -> List String addQuals prefix localSet allNames = EverySet.foldr (\x xs -> toQualString prefix x :: xs) allNames localSet in Dict.foldr addQuals (EverySet.toList locals) quals + nearbyNames : List String nearbyNames = List.take 4 (Suggest.sort givenName identity possibleNames) + toDetails : String -> String -> D.Doc toDetails noSuggestionDetails yesSuggestionDetails = case nearbyNames of [] -> @@ -1216,32 +1246,6 @@ toQualString prefix name = --- ARG MISMATCH - - -argMismatchReport : Code.Source -> A.Region -> String -> Name -> Int -> Int -> Report.Report -argMismatchReport source region kind name expected actual = - let - numArgs = - "too " - ++ (if actual < expected then - "few" - - else - "many" - ) - ++ " arguments" - in - Report.Report numArgs region [] <| - Code.toSnippet source - region - Nothing - ( D.reflow <| kind ++ " " ++ name ++ " has " ++ numArgs ++ "." - , D.reflow <| "Expecting " ++ String.fromInt expected ++ ", but got " ++ String.fromInt actual ++ "." - ) - - - -- BAD ALIAS RECURSION diff --git a/src/Compiler/Reporting/Error/Docs.elm b/src/Compiler/Reporting/Error/Docs.elm index 69b43a2c7..6cae49dca 100644 --- a/src/Compiler/Reporting/Error/Docs.elm +++ b/src/Compiler/Reporting/Error/Docs.elm @@ -89,8 +89,10 @@ toReports source err = toSyntaxProblemReport : Code.Source -> SyntaxProblem -> Report.Report toSyntaxProblemReport source problem = let + toSyntaxReport : Row -> Col -> String -> Report.Report toSyntaxReport row col details = let + region : A.Region region = toRegion row col in @@ -128,6 +130,7 @@ toSyntaxProblemReport source problem = toRegion : Row -> Col -> A.Region toRegion row col = let + pos : A.Position pos = A.Position row col in diff --git a/src/Compiler/Reporting/Error/Json.elm b/src/Compiler/Reporting/Error/Json.elm index 8b7d74e07..09bc0cd16 100644 --- a/src/Compiler/Reporting/Error/Json.elm +++ b/src/Compiler/Reporting/Error/Json.elm @@ -45,14 +45,18 @@ because (ExplicitReason iNeedThings) problem = parseErrorToReport : String -> Code.Source -> ParseError -> Reason -> Help.Report parseErrorToReport path source parseError reason = let + toSnippet : String -> Int -> Int -> ( String, D.Doc ) -> Help.Report toSnippet title row col ( problem, details ) = let + pos : A.Position pos = A.Position row col + surroundings : A.Region surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos + region : A.Region region = A.Region pos pos in @@ -370,6 +374,7 @@ expectationToReport path source context (A.Region start end) expectation reason (A.Position er _) = end + region : A.Region region = if sr == er then todo "region" @@ -377,6 +382,7 @@ expectationToReport path source context (A.Region start end) expectation reason else A.Region start start + introduction : String introduction = case context of CRoot -> @@ -395,6 +401,7 @@ expectationToReport path source context (A.Region start end) expectation reason CIndex index _ -> "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:" + toSnippet : String -> List D.Doc -> Help.Report toSnippet title aThing = Help.jsonReport title (Just path) <| Code.toSnippet source diff --git a/src/Compiler/Reporting/Error/Main.elm b/src/Compiler/Reporting/Error/Main.elm index 5a11e684f..bdc6d4f10 100644 --- a/src/Compiler/Reporting/Error/Main.elm +++ b/src/Compiler/Reporting/Error/Main.elm @@ -58,6 +58,7 @@ toReport localizer source err = BadFlags region _ invalidPayload -> let + formatDetails : ( String, D.Doc ) -> Report.Report formatDetails ( aBadKindOfThing, butThatIsNoGood ) = Report.Report "BAD FLAGS" region [] <| Code.toSnippet source region Nothing <| diff --git a/src/Compiler/Reporting/Error/Pattern.elm b/src/Compiler/Reporting/Error/Pattern.elm index 0b1ae8f20..554d0b083 100644 --- a/src/Compiler/Reporting/Error/Pattern.elm +++ b/src/Compiler/Reporting/Error/Pattern.elm @@ -133,6 +133,7 @@ patternToDoc context pattern = NonList (P.Ctor _ name args) -> let + ctorDoc : D.Doc ctorDoc = D.hsep (D.fromChars name :: List.map (patternToDoc Arg) args) in @@ -149,6 +150,7 @@ patternToDoc context pattern = FiniteList entries -> let + entryDocs : List D.Doc entryDocs = List.map (patternToDoc Unambiguous) entries in @@ -158,6 +160,7 @@ patternToDoc context pattern = Conses conses finalPattern -> let + consDoc : D.Doc consDoc = List.foldr (\hd tl -> diff --git a/src/Compiler/Reporting/Error/Syntax.elm b/src/Compiler/Reporting/Error/Syntax.elm index e1f616fca..261997cc2 100644 --- a/src/Compiler/Reporting/Error/Syntax.elm +++ b/src/Compiler/Reporting/Error/Syntax.elm @@ -480,6 +480,7 @@ toReport source err = case err of ModuleNameUnspecified name -> let + region : A.Region region = toRegion 1 1 in @@ -642,6 +643,7 @@ toParseErrorReport source modul = ModuleProblem row col -> let + region : A.Region region = toRegion row col in @@ -674,6 +676,7 @@ toParseErrorReport source modul = ModuleName row col -> let + region : A.Region region = toRegion row col in @@ -721,6 +724,7 @@ toParseErrorReport source modul = PortModuleProblem row col -> let + region : A.Region region = toRegion row col in @@ -754,6 +758,7 @@ toParseErrorReport source modul = PortModuleName row col -> let + region : A.Region region = toRegion row col in @@ -791,6 +796,7 @@ toParseErrorReport source modul = Effect row col -> let + region : A.Region region = toRegion row col in @@ -804,9 +810,11 @@ toParseErrorReport source modul = FreshLine row col -> let + region : A.Region region = toRegion row col + toBadFirstLineReport : String -> Report.Report toBadFirstLineReport keyword = Report.Report "TOO MUCH INDENTATION" region [] <| Code.toSnippet source region Nothing <| @@ -861,6 +869,7 @@ toParseErrorReport source modul = ImportName row col -> let + region : A.Region region = toRegion row col in @@ -905,6 +914,7 @@ toParseErrorReport source modul = ImportAlias row col -> let + region : A.Region region = toRegion row col in @@ -959,6 +969,7 @@ toParseErrorReport source modul = ImportIndentExposingList row col -> let + region : A.Region region = toRegion row col in @@ -991,6 +1002,7 @@ toParseErrorReport source modul = Infix row col -> let + region : A.Region region = toRegion row col in @@ -1015,6 +1027,7 @@ toWeirdEndReport source row col = case Code.whatIsNext source row col of Code.Keyword keyword -> let + region : A.Region region = toKeywordRegion row col keyword in @@ -1027,6 +1040,7 @@ toWeirdEndReport source row col = Code.Operator op -> let + region : A.Region region = toKeywordRegion row col op in @@ -1039,6 +1053,7 @@ toWeirdEndReport source row col = Code.Close term bracket -> let + region : A.Region region = toRegion row col in @@ -1050,6 +1065,7 @@ toWeirdEndReport source row col = Code.Lower c cs -> let + region : A.Region region = toKeywordRegion row col (String.cons c cs) in @@ -1061,6 +1077,7 @@ toWeirdEndReport source row col = Code.Upper c cs -> let + region : A.Region region = toKeywordRegion row col (String.fromChar c ++ cs) in @@ -1072,6 +1089,7 @@ toWeirdEndReport source row col = Code.Other maybeChar -> let + region : A.Region region = toRegion row col in @@ -1156,6 +1174,7 @@ toWeirdEndSyntaxProblemReport source region = toImportReport : Code.Source -> Row -> Col -> Report.Report toImportReport source row col = let + region : A.Region region = toRegion row col in @@ -1209,9 +1228,11 @@ toExposingReport source exposing_ startRow startCol = ExposingStart row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1258,9 +1279,11 @@ toExposingReport source exposing_ startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -1272,9 +1295,11 @@ toExposingReport source exposing_ startRow startCol = Code.Operator op -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col op in @@ -1299,9 +1324,11 @@ toExposingReport source exposing_ startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1331,9 +1358,11 @@ toExposingReport source exposing_ startRow startCol = ExposingOperator row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1371,9 +1400,11 @@ toExposingReport source exposing_ startRow startCol = ExposingOperatorReserved op row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1417,9 +1448,11 @@ toExposingReport source exposing_ startRow startCol = ExposingOperatorRightParen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1450,9 +1483,11 @@ toExposingReport source exposing_ startRow startCol = ExposingEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1464,9 +1499,11 @@ toExposingReport source exposing_ startRow startCol = ExposingTypePrivacy row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1507,9 +1544,11 @@ toExposingReport source exposing_ startRow startCol = ExposingIndentEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1538,9 +1577,11 @@ toExposingReport source exposing_ startRow startCol = ExposingIndentValue row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1560,6 +1601,7 @@ toSpaceReport source space row col = case space of HasTab -> let + region : A.Region region = toRegion row col in @@ -1571,6 +1613,7 @@ toSpaceReport source space row col = EndlessMultiComment -> let + region : A.Region region = toWiderRegion row col 2 in @@ -1592,6 +1635,7 @@ toSpaceReport source space row col = toRegion : Row -> Col -> A.Region toRegion row col = let + pos : A.Position pos = A.Position row col in @@ -1632,6 +1676,7 @@ toDeclarationsReport source decl = DeclFreshLineAfterDocComment row col -> let + region : A.Region region = toRegion row col in @@ -1647,6 +1692,7 @@ toDeclStartReport source row col = case Code.whatIsNext source row col of Code.Close term bracket -> let + region : A.Region region = toRegion row col in @@ -1658,6 +1704,7 @@ toDeclStartReport source row col = Code.Keyword keyword -> let + region : A.Region region = toKeywordRegion row col keyword in @@ -1713,6 +1760,7 @@ toDeclStartReport source row col = Code.Upper c cs -> let + region : A.Region region = toRegion row col in @@ -1746,6 +1794,7 @@ toDeclStartReport source row col = Code.Other (Just char) -> let + region : A.Region region = toRegion row col in @@ -1815,9 +1864,11 @@ toPortReport source port_ startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -1829,9 +1880,11 @@ toPortReport source port_ startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1866,9 +1919,11 @@ toPortReport source port_ startRow startCol = PortColon row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1886,9 +1941,11 @@ toPortReport source port_ startRow startCol = PortIndentName row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1923,9 +1980,11 @@ toPortReport source port_ startRow startCol = PortIndentColon row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -1940,9 +1999,11 @@ toPortReport source port_ startRow startCol = PortIndentType row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2006,9 +2067,11 @@ toDeclTypeReport source declType startRow startCol = DT_Name row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2053,9 +2116,11 @@ toDeclTypeReport source declType startRow startCol = DT_IndentName row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2101,9 +2166,11 @@ toTypeAliasReport source typeAlias startRow startCol = AliasName row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2144,9 +2211,11 @@ toTypeAliasReport source typeAlias startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -2165,9 +2234,11 @@ toTypeAliasReport source typeAlias startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2185,9 +2256,11 @@ toTypeAliasReport source typeAlias startRow startCol = AliasIndentEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2202,9 +2275,11 @@ toTypeAliasReport source typeAlias startRow startCol = AliasIndentBody row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2269,9 +2344,11 @@ toCustomTypeReport source customType startRow startCol = CT_Name row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2312,9 +2389,11 @@ toCustomTypeReport source customType startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -2332,9 +2411,11 @@ toCustomTypeReport source customType startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2349,9 +2430,11 @@ toCustomTypeReport source customType startRow startCol = CT_Bar row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2366,9 +2449,11 @@ toCustomTypeReport source customType startRow startCol = CT_Variant row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2411,9 +2496,11 @@ toCustomTypeReport source customType startRow startCol = CT_IndentEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2428,9 +2515,11 @@ toCustomTypeReport source customType startRow startCol = CT_IndentBar row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2445,9 +2534,11 @@ toCustomTypeReport source customType startRow startCol = CT_IndentAfterBar row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2462,9 +2553,11 @@ toCustomTypeReport source customType startRow startCol = CT_IndentAfterEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2507,9 +2600,11 @@ toDeclDefReport source name declDef startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -2575,9 +2670,11 @@ toDeclDefReport source name declDef startRow startCol = Code.Operator "->" -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toWiderRegion row col 2 in @@ -2633,9 +2730,11 @@ toDeclDefReport source name declDef startRow startCol = Code.Operator op -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col op in @@ -2662,9 +2761,11 @@ toDeclDefReport source name declDef startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2700,9 +2801,11 @@ toDeclDefReport source name declDef startRow startCol = DeclDefNameRepeat row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2720,9 +2823,11 @@ toDeclDefReport source name declDef startRow startCol = DeclDefNameMatch defName row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2747,9 +2852,11 @@ toDeclDefReport source name declDef startRow startCol = DeclDefIndentType row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2767,9 +2874,11 @@ toDeclDefReport source name declDef startRow startCol = DeclDefIndentEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2787,9 +2896,11 @@ toDeclDefReport source name declDef startRow startCol = DeclDefIndentBody row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -2901,6 +3012,7 @@ toExprReport source context expr startRow startCol = Dot row col -> let + region : A.Region region = toRegion row col in @@ -2925,6 +3037,7 @@ toExprReport source context expr startRow startCol = Access row col -> let + region : A.Region region = toRegion row col in @@ -2952,12 +3065,15 @@ toExprReport source context expr startRow startCol = OperatorRight op row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col + isMath : Bool isMath = List.member op [ "-", "+", "*", "/", "^" ] in @@ -3071,9 +3187,11 @@ toExprReport source context expr startRow startCol = InNode NBranch r c _ -> ( r, c, "a `case` expression" ) + surroundings : A.Region surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3126,6 +3244,7 @@ toExprReport source context expr startRow startCol = EndlessShader row col -> let + region : A.Region region = toWiderRegion row col 6 in @@ -3137,6 +3256,7 @@ toExprReport source context expr startRow startCol = ShaderProblem problem row col -> let + region : A.Region region = toRegion row col in @@ -3151,9 +3271,11 @@ toExprReport source context expr startRow startCol = IndentOperatorRight op row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3202,6 +3324,7 @@ toCharReport source char row col = case char of CharEndless -> let + region : A.Region region = toRegion row col in @@ -3217,6 +3340,7 @@ toCharReport source char row col = CharNotString width -> let + region : A.Region region = toWiderRegion row col width in @@ -3245,6 +3369,7 @@ toStringReport source string row col = case string of StringEndless_Single -> let + region : A.Region region = toRegion row col in @@ -3293,6 +3418,7 @@ toStringReport source string row col = StringEndless_Multi -> let + region : A.Region region = toWiderRegion row col 3 in @@ -3331,6 +3457,7 @@ toEscapeReport source escape row col = case escape of EscapeUnknown -> let + region : A.Region region = toWiderRegion row col 2 in @@ -3357,6 +3484,7 @@ toEscapeReport source escape row col = BadUnicodeFormat width -> let + region : A.Region region = toWiderRegion row col width in @@ -3379,6 +3507,7 @@ toEscapeReport source escape row col = BadUnicodeCode width -> let + region : A.Region region = toWiderRegion row col width in @@ -3390,6 +3519,7 @@ toEscapeReport source escape row col = BadUnicodeLength width numDigits badCode -> let + region : A.Region region = toWiderRegion row col width in @@ -3398,9 +3528,11 @@ toEscapeReport source escape row col = if numDigits < 4 then ( D.reflow "Every code point needs at least four digits:" , let + goodCode : String goodCode = String.repeat (4 - numDigits) "0" ++ String.toUpper (Hex.toString badCode) + suggestion : D.Doc suggestion = D.fromChars ("\\u{" ++ goodCode ++ "}") in @@ -3448,6 +3580,7 @@ toEscapeReport source escape row col = toNumberReport : Code.Source -> Number -> Row -> Col -> Report.Report toNumberReport source number row col = let + region : A.Region region = toRegion row col in @@ -3520,6 +3653,7 @@ toOperatorReport source context operator row col = case operator of BadDot -> let + region : A.Region region = toRegion row col in @@ -3531,6 +3665,7 @@ toOperatorReport source context operator row col = BadPipe -> let + region : A.Region region = toRegion row col in @@ -3542,6 +3677,7 @@ toOperatorReport source context operator row col = BadArrow -> let + region : A.Region region = toWiderRegion row col 2 in @@ -3577,6 +3713,7 @@ toOperatorReport source context operator row col = BadEquals -> let + region : A.Region region = toRegion row col in @@ -3604,6 +3741,7 @@ toOperatorReport source context operator row col = BadHasType -> let + region : A.Region region = toRegion row col in @@ -3672,9 +3810,11 @@ toLetReport source context let_ startRow startCol = LetIn row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3709,9 +3849,11 @@ toLetReport source context let_ startRow startCol = LetDefAlignment _ row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3748,9 +3890,11 @@ toLetReport source context let_ startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -3812,9 +3956,11 @@ toLetReport source context let_ startRow startCol = toUnfinishLetReport : Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report toUnfinishLetReport source row col startRow startCol message = let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3869,9 +4015,11 @@ toLetDefReport source name def startRow startCol = DefNameRepeat row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3886,9 +4034,11 @@ toLetDefReport source name def startRow startCol = DefNameMatch defName row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -3913,9 +4063,11 @@ toLetDefReport source name def startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -3981,9 +4133,11 @@ toLetDefReport source name def startRow startCol = Code.Operator "->" -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toWiderRegion row col 2 in @@ -4036,9 +4190,11 @@ toLetDefReport source name def startRow startCol = Code.Operator op -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col op in @@ -4062,9 +4218,11 @@ toLetDefReport source name def startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4091,9 +4249,11 @@ toLetDefReport source name def startRow startCol = DefIndentEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4108,9 +4268,11 @@ toLetDefReport source name def startRow startCol = DefIndentType row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4125,9 +4287,11 @@ toLetDefReport source name def startRow startCol = DefIndentBody row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4142,12 +4306,15 @@ toLetDefReport source name def startRow startCol = DefAlignment indent row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col + offset : Int offset = indent - col in @@ -4199,9 +4366,11 @@ toLetDestructReport source destruct startRow startCol = DestructEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4224,9 +4393,11 @@ toLetDestructReport source destruct startRow startCol = DestructIndentEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4238,9 +4409,11 @@ toLetDestructReport source destruct startRow startCol = DestructIndentBody row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4287,9 +4460,11 @@ toCaseReport source context case_ startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -4302,9 +4477,11 @@ toCaseReport source context case_ startRow startCol = Code.Operator ":" -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4333,9 +4510,11 @@ toCaseReport source context case_ startRow startCol = Code.Operator "=" -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4359,9 +4538,11 @@ toCaseReport source context case_ startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4460,9 +4641,11 @@ toCaseReport source context case_ startRow startCol = toUnfinishCaseReport : Code.Source -> Int -> Int -> Int -> Int -> D.Doc -> Report.Report toUnfinishCaseReport source row col startRow startCol message = let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4520,9 +4703,11 @@ toIfReport source context if_ startRow startCol = IfThen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4544,9 +4729,11 @@ toIfReport source context if_ startRow startCol = IfElse row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4568,9 +4755,11 @@ toIfReport source context if_ startRow startCol = IfElseBranchStart row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4591,9 +4780,11 @@ toIfReport source context if_ startRow startCol = IfIndentCondition row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4624,9 +4815,11 @@ toIfReport source context if_ startRow startCol = IfIndentThen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4651,9 +4844,11 @@ toIfReport source context if_ startRow startCol = IfIndentThenBranch row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4668,9 +4863,11 @@ toIfReport source context if_ startRow startCol = IfIndentElseBranch row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4687,9 +4884,11 @@ toIfReport source context if_ startRow startCol = case Code.nextLineStartsWithKeyword "else" source row of Just ( elseRow, elseCol ) -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position elseRow elseCol) + region : A.Region region = toWiderRegion elseRow elseCol 4 in @@ -4718,9 +4917,11 @@ toIfReport source context if_ startRow startCol = Nothing -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4770,9 +4971,11 @@ toRecordReport source context record startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -4785,9 +4988,11 @@ toRecordReport source context record startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4826,9 +5031,11 @@ toRecordReport source context record startRow startCol = RecordEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4867,9 +5074,11 @@ toRecordReport source context record startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -4881,9 +5090,11 @@ toRecordReport source context record startRow startCol = Code.Other (Just ',') -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4899,9 +5110,11 @@ toRecordReport source context record startRow startCol = Code.Close _ '}' -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4916,9 +5129,11 @@ toRecordReport source context record startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -4957,9 +5172,11 @@ toRecordReport source context record startRow startCol = RecordEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5004,9 +5221,11 @@ toRecordReport source context record startRow startCol = RecordIndentOpen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5039,9 +5258,11 @@ toRecordReport source context record startRow startCol = case Code.nextLineStartsWithCloseCurly source row of Just ( curlyRow, curlyCol ) -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol) + region : A.Region region = toRegion curlyRow curlyCol in @@ -5056,9 +5277,11 @@ toRecordReport source context record startRow startCol = Nothing -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5094,9 +5317,11 @@ toRecordReport source context record startRow startCol = RecordIndentField row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5111,9 +5336,11 @@ toRecordReport source context record startRow startCol = RecordIndentEquals row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5137,9 +5364,11 @@ toRecordReport source context record startRow startCol = RecordIndentExpr row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5208,9 +5437,11 @@ toTupleReport source context tuple startRow startCol = TupleEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5235,9 +5466,11 @@ toTupleReport source context tuple startRow startCol = TupleOperatorClose row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5262,9 +5495,11 @@ toTupleReport source context tuple startRow startCol = TupleOperatorReserved operator row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5341,9 +5576,11 @@ toTupleReport source context tuple startRow startCol = TupleIndentExpr1 row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5374,9 +5611,11 @@ toTupleReport source context tuple startRow startCol = TupleIndentExprN row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5409,9 +5648,11 @@ toTupleReport source context tuple startRow startCol = TupleIndentEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5443,9 +5684,11 @@ toListReport source context list startRow startCol = ListOpen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5485,9 +5728,11 @@ toListReport source context list startRow startCol = case expr of Start r c -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position r c) + region : A.Region region = toRegion r c in @@ -5513,9 +5758,11 @@ toListReport source context list startRow startCol = ListEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5553,9 +5800,11 @@ toListReport source context list startRow startCol = ListIndentOpen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5614,9 +5863,11 @@ toListReport source context list startRow startCol = ListIndentEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5656,9 +5907,11 @@ toListReport source context list startRow startCol = ListIndentExpr row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5696,9 +5949,11 @@ toFuncReport source context func startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -5710,9 +5965,11 @@ toFuncReport source context func startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5744,9 +6001,11 @@ toFuncReport source context func startRow startCol = FuncIndentArg row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5775,9 +6034,11 @@ toFuncReport source context func startRow startCol = FuncIndentArrow row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5812,9 +6073,11 @@ toFuncReport source context func startRow startCol = FuncIndentBody row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5872,12 +6135,15 @@ toPatternReport source context pattern startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword + inThisThing : String inThisThing = case context of PArg -> @@ -5899,9 +6165,11 @@ toPatternReport source context pattern startRow startCol = Code.Operator "-" -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5915,9 +6183,11 @@ toPatternReport source context pattern startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -5968,6 +6238,7 @@ toPatternReport source context pattern startRow startCol = PFloat width row col -> let + region : A.Region region = toWiderRegion row col width in @@ -6003,6 +6274,7 @@ toPatternReport source context pattern startRow startCol = PAlias row col -> let + region : A.Region region = toRegion row col in @@ -6060,9 +6332,11 @@ toPatternReport source context pattern startRow startCol = PWildcardNotVar name width row col -> let + region : A.Region region = toWiderRegion row col width + examples : List D.Doc examples = case String.uncons (String.filter ((/=) '_') name) of Nothing -> @@ -6111,9 +6385,11 @@ toPatternReport source context pattern startRow startCol = PIndentStart row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6159,6 +6435,7 @@ toPatternReport source context pattern startRow startCol = PIndentAlias row col -> let + region : A.Region region = toRegion row col in @@ -6245,9 +6522,11 @@ toPRecordReport source record startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6300,9 +6579,11 @@ toPRecordReport source record startRow startCol = toUnfinishRecordPatternReport : Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report toUnfinishRecordPatternReport source row col startRow startCol message = let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6342,9 +6623,11 @@ toPTupleReport source context tuple startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6360,9 +6643,11 @@ toPTupleReport source context tuple startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6398,9 +6683,11 @@ toPTupleReport source context tuple startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6416,9 +6703,11 @@ toPTupleReport source context tuple startRow startCol = Code.Operator op -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col op in @@ -6434,9 +6723,11 @@ toPTupleReport source context tuple startRow startCol = Code.Close term bracket -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6456,9 +6747,11 @@ toPTupleReport source context tuple startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6495,9 +6788,11 @@ toPTupleReport source context tuple startRow startCol = PTupleIndentEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6524,9 +6819,11 @@ toPTupleReport source context tuple startRow startCol = PTupleIndentExpr1 row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6560,9 +6857,11 @@ toPTupleReport source context tuple startRow startCol = PTupleIndentExprN row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6608,9 +6907,11 @@ toPListReport source context list startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6622,9 +6923,11 @@ toPListReport source context list startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6646,9 +6949,11 @@ toPListReport source context list startRow startCol = PListEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6676,9 +6981,11 @@ toPListReport source context list startRow startCol = PListIndentOpen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6703,9 +7010,11 @@ toPListReport source context list startRow startCol = PListIndentEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6730,9 +7039,11 @@ toPListReport source context list startRow startCol = PListIndentExpr row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6770,9 +7081,11 @@ toTypeReport source context tipe startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6784,12 +7097,15 @@ toTypeReport source context tipe startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col + thing : String thing = case context of TC_Annotation _ -> @@ -6804,6 +7120,7 @@ toTypeReport source context tipe startRow startCol = TC_Port -> "port" + something : String something = case context of TC_Annotation name -> @@ -6845,12 +7162,15 @@ toTypeReport source context tipe startRow startCol = TIndentStart row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col + thing : String thing = case context of TC_Annotation _ -> @@ -6898,9 +7218,11 @@ toTRecordReport source context record startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6912,9 +7234,11 @@ toTRecordReport source context record startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6942,9 +7266,11 @@ toTRecordReport source context record startRow startCol = TRecordEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -6983,9 +7309,11 @@ toTRecordReport source context record startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -6997,9 +7325,11 @@ toTRecordReport source context record startRow startCol = Code.Other (Just ',') -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7015,9 +7345,11 @@ toTRecordReport source context record startRow startCol = Code.Close _ '}' -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7032,9 +7364,11 @@ toTRecordReport source context record startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7072,9 +7406,11 @@ toTRecordReport source context record startRow startCol = TRecordColon row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7118,9 +7454,11 @@ toTRecordReport source context record startRow startCol = TRecordIndentOpen row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7153,9 +7491,11 @@ toTRecordReport source context record startRow startCol = case Code.nextLineStartsWithCloseCurly source row of Just ( curlyRow, curlyCol ) -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol) + region : A.Region region = toRegion curlyRow curlyCol in @@ -7170,9 +7510,11 @@ toTRecordReport source context record startRow startCol = Nothing -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7208,9 +7550,11 @@ toTRecordReport source context record startRow startCol = TRecordIndentField row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7225,9 +7569,11 @@ toTRecordReport source context record startRow startCol = TRecordIndentColon row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7251,9 +7597,11 @@ toTRecordReport source context record startRow startCol = TRecordIndentType row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7318,9 +7666,11 @@ toTTupleReport source context tuple startRow startCol = case Code.whatIsNext source row col of Code.Keyword keyword -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toKeywordRegion row col keyword in @@ -7334,9 +7684,11 @@ toTTupleReport source context tuple startRow startCol = _ -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7364,9 +7716,11 @@ toTTupleReport source context tuple startRow startCol = TTupleEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7399,9 +7753,11 @@ toTTupleReport source context tuple startRow startCol = TTupleIndentType1 row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7433,9 +7789,11 @@ toTTupleReport source context tuple startRow startCol = TTupleIndentTypeN row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in @@ -7470,9 +7828,11 @@ toTTupleReport source context tuple startRow startCol = TTupleIndentEnd row col -> let + surroundings : A.Region surroundings = A.Region (A.Position startRow startCol) (A.Position row col) + region : A.Region region = toRegion row col in diff --git a/src/Compiler/Reporting/Error/Type.elm b/src/Compiler/Reporting/Error/Type.elm index 82b3f13e3..a558a8aca 100644 --- a/src/Compiler/Reporting/Error/Type.elm +++ b/src/Compiler/Reporting/Error/Type.elm @@ -599,7 +599,7 @@ problemToHint problem = "It looks like it takes too many arguments. I see " ++ String.fromInt (x - y) ++ " extra." ] - T.BadFlexSuper direction super _ tipe -> + T.BadFlexSuper direction super tipe -> case tipe of T.Lambda _ _ _ -> badFlexSuper direction super tipe @@ -935,6 +935,7 @@ badRigidSuper super aThing = badFlexFlexSuper : T.Super -> T.Super -> List D.Doc badFlexFlexSuper s1 s2 = let + likeThis : T.Super -> String likeThis super = case super of T.Number -> @@ -981,6 +982,7 @@ toExprReport source localizer exprRegion category tipe expected = FromAnnotation name _ subContext expectedType -> let + thing : String thing = case subContext of TypedIfBranch index -> @@ -992,6 +994,7 @@ toExprReport source localizer exprRegion category tipe expected = TypedBody -> "body of the `" ++ name ++ "` definition:" + itIs : String itIs = case subContext of TypedIfBranch index -> @@ -1016,6 +1019,7 @@ toExprReport source localizer exprRegion category tipe expected = FromContext region context expectedType -> let + mismatch : ( ( Maybe A.Region, String ), ( String, String, List D.Doc ) ) -> Report.Report mismatch ( ( maybeHighlight, problem ), ( thisIs, insteadOf, furtherDetails ) ) = Report.Report "TYPE MISMATCH" exprRegion [] <| Code.toSnippet source @@ -1025,6 +1029,7 @@ toExprReport source localizer exprRegion category tipe expected = , typeComparison localizer tipe expectedType (addCategory thisIs category) insteadOf furtherDetails ) + badType : ( ( Maybe A.Region, String ), ( String, List D.Doc ) ) -> Report.Report badType ( ( maybeHighlight, problem ), ( thisIs, furtherDetails ) ) = Report.Report "TYPE MISMATCH" exprRegion [] <| Code.toSnippet source @@ -1034,6 +1039,7 @@ toExprReport source localizer exprRegion category tipe expected = , loneType localizer tipe expectedType (D.reflow (addCategory thisIs category)) furtherDetails ) + custom : Maybe A.Region -> ( D.Doc, D.Doc ) -> Report.Report custom maybeHighlight docPair = Report.Report "TYPE MISMATCH" exprRegion [] <| Code.toSnippet source region maybeHighlight docPair @@ -1041,6 +1047,7 @@ toExprReport source localizer exprRegion category tipe expected = case context of ListEntry index -> let + ith : String ith = D.ordinal index in @@ -1118,6 +1125,7 @@ toExprReport source localizer exprRegion category tipe expected = IfBranch index -> let + ith : String ith = D.ordinal index in @@ -1137,6 +1145,7 @@ toExprReport source localizer exprRegion category tipe expected = CaseBranch index -> let + ith : String ith = D.ordinal index in @@ -1160,6 +1169,7 @@ toExprReport source localizer exprRegion category tipe expected = case countArgs tipe of 0 -> let + thisValue : String thisValue = case maybeFuncName of NoName -> @@ -1180,6 +1190,7 @@ toExprReport source localizer exprRegion category tipe expected = n -> let + thisFunction : String thisFunction = case maybeFuncName of NoName -> @@ -1200,9 +1211,11 @@ toExprReport source localizer exprRegion category tipe expected = CallArg maybeFuncName index -> let + ith : String ith = D.ordinal index + thisFunction : String thisFunction = case maybeFuncName of NoName -> @@ -1306,9 +1319,11 @@ toExprReport source localizer exprRegion category tipe expected = ( field, Can.FieldUpdate fieldRegion _ ) :: _ -> let + rStr : String rStr = "`" ++ record ++ "`" + fStr : String fStr = "`" ++ field ++ "`" in @@ -2025,7 +2040,7 @@ badAppendRight localizer category tipe expected = ] ) - ( _, _ ) -> + _ -> EmphBoth ( D.reflow "The (++) operator cannot append these two values:" , typeComparison localizer @@ -2054,15 +2069,19 @@ badCast op thisThenThat = ++ op ++ ") to be the exact same type. Both Int or both Float." , let + anInt : List D.Doc anInt = [ D.fromChars "an", D.dullyellow (D.fromChars "Int") ] + aFloat : List D.Doc aFloat = [ D.fromChars "a", D.dullyellow (D.fromChars "Float") ] + toFloat : D.Doc toFloat = D.green (D.fromChars "toFloat") + round : D.Doc round = D.green (D.fromChars "round") in diff --git a/src/Compiler/Reporting/Outcome.elm b/src/Compiler/Reporting/Outcome.elm index 336aa1165..74d808c18 100644 --- a/src/Compiler/Reporting/Outcome.elm +++ b/src/Compiler/Reporting/Outcome.elm @@ -66,6 +66,7 @@ mapError func (Outcome k) = Outcome (\i w bad good -> let + bad1 : a -> b -> OneOrMore e -> c bad1 i1 w1 e1 = bad i1 w1 (OneOrMore.map func e1) in diff --git a/src/Compiler/Reporting/Render/Code.elm b/src/Compiler/Reporting/Render/Code.elm index 50562e599..33212baef 100644 --- a/src/Compiler/Reporting/Render/Code.elm +++ b/src/Compiler/Reporting/Render/Code.elm @@ -16,7 +16,6 @@ import Compiler.Parse.Variable exposing (reservedWords) import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D exposing (Doc) import Data.Set as EverySet -import List.Extra as List import Prelude @@ -77,14 +76,17 @@ toPair source r1 r2 ( oneStart, oneEnd ) ( twoStart, twoMiddle, twoEnd ) = render : Source -> A.Region -> Maybe A.Region -> Doc render sourceLines ((A.Region (A.Position startLine _) (A.Position endLine _)) as region) maybeSubRegion = let + relevantLines : List ( Int, String ) relevantLines = sourceLines |> List.drop (startLine - 1) |> List.take (1 + endLine - startLine) + width : Int width = String.length (String.fromInt (Tuple.first (Prelude.last relevantLines))) + smallerRegion : A.Region smallerRegion = Maybe.withDefault region maybeSubRegion in @@ -103,9 +105,11 @@ makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end else let + spaces : String spaces = String.repeat (c1 + width + 1) " " + zigzag : String zigzag = String.repeat (max 1 (c2 - c1)) "^" in @@ -130,12 +134,15 @@ drawLine addZigZag width startLine endLine ( n, line ) = addLineNumber : Bool -> Int -> Int -> Int -> Int -> Doc -> Doc addLineNumber addZigZag width start end n line = let + number : String number = String.fromInt n + lineNumber : String lineNumber = String.repeat (width - String.length number) " " ++ number ++ "|" + spacer : Doc spacer = if addZigZag && start <= n && n <= end then D.red (D.fromChars ">") @@ -166,21 +173,27 @@ renderPair source region1 region2 = in if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then let + lineNumber : String lineNumber = String.fromInt startRow1 + spaces1 : String spaces1 = String.repeat (startCol1 + String.length lineNumber + 1) " " + zigzag1 : String zigzag1 = String.repeat (endCol1 - startCol1) "^" + spaces2 : String spaces2 = String.repeat (startCol2 - endCol1) " " + zigzag2 : String zigzag2 = String.repeat (endCol2 - startCol2) "^" + line : String line = List.head (List.filter (\( row, _ ) -> row == startRow1) source) |> Maybe.map Tuple.second |> Maybe.withDefault "" in @@ -250,9 +263,11 @@ whatIsNext sourceLines row col = detectKeywords : Char -> String -> Next detectKeywords c rest = let + cs : String cs = List.filter isInner (String.toList rest) |> String.fromList + name : String name = String.fromChar c ++ cs in diff --git a/src/Compiler/Reporting/Render/Type.elm b/src/Compiler/Reporting/Render/Type.elm index 2a53d1f97..df22000fe 100644 --- a/src/Compiler/Reporting/Render/Type.elm +++ b/src/Compiler/Reporting/Render/Type.elm @@ -33,6 +33,7 @@ type Context lambda : Context -> D.Doc -> D.Doc -> List D.Doc -> D.Doc lambda context arg1 arg2 args = let + lambdaDoc : D.Doc lambdaDoc = D.align <| D.sep (arg1 :: List.map (\a -> D.plus a (D.fromChars "->")) (arg2 :: args)) in @@ -55,6 +56,7 @@ apply context name args = _ -> let + applyDoc : D.Doc applyDoc = D.hang 4 <| D.sep (name :: args) in @@ -72,6 +74,7 @@ apply context name args = tuple : D.Doc -> D.Doc -> List D.Doc -> D.Doc tuple a b cs = let + entries : List D.Doc entries = List.interweave (D.fromChars "( " :: List.repeat (List.length (b :: cs)) (D.fromChars ", ")) (a :: b :: cs) in @@ -113,9 +116,11 @@ entryToDoc ( fieldName, fieldType ) = vrecordSnippet : ( D.Doc, D.Doc ) -> List ( D.Doc, D.Doc ) -> D.Doc vrecordSnippet entry entries = let + field : D.Doc field = D.fromChars "{" |> D.plus (entryToDoc entry) + fields : List D.Doc fields = List.intersperse (D.fromChars ",") (List.map entryToDoc entries ++ [ D.fromChars "..." ]) |> List.intersperse (D.fromChars " ") diff --git a/src/Compiler/Reporting/Result.elm b/src/Compiler/Reporting/Result.elm index b23a8faf3..0f281a5ce 100644 --- a/src/Compiler/Reporting/Result.elm +++ b/src/Compiler/Reporting/Result.elm @@ -6,7 +6,6 @@ module Compiler.Reporting.Result exposing , bind , fmap , indexedTraverse - , mapError , mapTraverseWithKey , ok , pure @@ -79,15 +78,6 @@ throw e = Err (RErr i w (OneOrMore.one e)) -mapError : (e -> e_) -> RResult i w e a -> RResult i w e_ a -mapError func (RResult k) = - RResult <| - \i w -> - Result.mapError - (\(RErr i1 w1 e1) -> RErr i1 w1 (OneOrMore.map func e1)) - (k i w) - - -- FANCY INSTANCE STUFF diff --git a/src/Compiler/Reporting/Suggest.elm b/src/Compiler/Reporting/Suggest.elm index 8e6f953f7..7acb919bb 100644 --- a/src/Compiler/Reporting/Suggest.elm +++ b/src/Compiler/Reporting/Suggest.elm @@ -36,9 +36,11 @@ sort target toString = rank : String -> (a -> String) -> List a -> List ( Int, a ) rank target toString values = let + toRank : a -> Int toRank v = distance (String.toLower target) (String.toLower (toString v)) + addRank : a -> ( Int, a ) addRank v = ( toRank v, v ) in diff --git a/src/Compiler/Reporting/Warning.elm b/src/Compiler/Reporting/Warning.elm index d8bb355db..6987e728f 100644 --- a/src/Compiler/Reporting/Warning.elm +++ b/src/Compiler/Reporting/Warning.elm @@ -46,6 +46,7 @@ toReport localizer source warning = UnusedVariable region context name -> let + title : String title = defOrPat context "unused definition" "unused variable" in diff --git a/src/Compiler/Type/Constrain/Expression.elm b/src/Compiler/Type/Constrain/Expression.elm index 7c53b598b..46d00016b 100644 --- a/src/Compiler/Type/Constrain/Expression.elm +++ b/src/Compiler/Type/Constrain/Expression.elm @@ -1,5 +1,5 @@ module Compiler.Type.Constrain.Expression exposing - ( constrain + ( RTV , constrainDef , constrainRecursiveDefs ) @@ -84,6 +84,7 @@ constrain rtv (A.At region expression) expected = |> IO.bind (\numberVar -> let + numberType : Type numberType = VarN numberVar in @@ -91,6 +92,7 @@ constrain rtv (A.At region expression) expected = |> IO.fmap (\numberCon -> let + negateCon : Constraint negateCon = CEqual region E.Number numberType expected in @@ -133,12 +135,15 @@ constrain rtv (A.At region expression) expected = |> IO.fmap (\fieldVar -> let + extType : Type extType = VarN extVar + fieldType : Type fieldType = VarN fieldVar + recordType : Type recordType = RecordN (Dict.singleton field fieldType) extType in @@ -154,15 +159,19 @@ constrain rtv (A.At region expression) expected = |> IO.bind (\fieldVar -> let + extType : Type extType = VarN extVar + fieldType : Type fieldType = VarN fieldVar + recordType : Type recordType = RecordN (Dict.singleton field fieldType) extType + context : Context context = RecordAccess (A.toRegion expr) (getAccessName expr) accessRegion field in @@ -222,6 +231,7 @@ constrainLambda rtv region args body expected = constrainCall : RTV -> A.Region -> Can.Expr -> List Can.Expr -> E.Expected Type -> IO Constraint constrainCall rtv region ((A.At funcRegion _) as func) args expected = let + maybeName : MaybeName maybeName = getName func in @@ -232,9 +242,11 @@ constrainCall rtv region ((A.At funcRegion _) as func) args expected = |> IO.bind (\resultVar -> let + funcType : Type funcType = VarN funcVar + resultType : Type resultType = VarN resultVar in @@ -245,9 +257,11 @@ constrainCall rtv region ((A.At funcRegion _) as func) args expected = |> IO.fmap (\( argVars, argTypes, argCons ) -> let + arityType : Type arityType = List.foldr FunN resultType argTypes + category : Category category = CallResult maybeName in @@ -271,6 +285,7 @@ constrainArg rtv region maybeName index arg = |> IO.bind (\argVar -> let + argType : Type argType = VarN argVar in @@ -339,18 +354,23 @@ constrainBinop rtv region op annotation leftExpr rightExpr expected = |> IO.bind (\answerVar -> let + leftType : Type leftType = VarN leftVar + rightType : Type rightType = VarN rightVar + answerType : Type answerType = VarN answerVar + binopType : Type binopType = Type.funType leftType (Type.funType rightType answerType) + opCon : Constraint opCon = CForeign region op annotation (NoExpectation binopType) in @@ -385,9 +405,11 @@ constrainList rtv region entries expected = |> IO.bind (\entryVar -> let + entryType : Type entryType = VarN entryVar + listType : Type listType = AppN ModuleName.list Name.list [ entryType ] in @@ -416,6 +438,7 @@ constrainListEntry rtv region tipe index expr = constrainIf : RTV -> A.Region -> List ( Can.Expr, Can.Expr ) -> Can.Expr -> E.Expected Type -> IO Constraint constrainIf rtv region branches final expected = let + boolExpect : Expected Type boolExpect = FromContext region IfCondition Type.bool @@ -438,6 +461,7 @@ constrainIf rtv region branches final expected = |> IO.bind (\branchVar -> let + branchType : Type branchType = VarN branchVar in @@ -469,6 +493,7 @@ constrainCase rtv region expr branches expected = |> IO.bind (\ptrnVar -> let + ptrnType : Type ptrnType = VarN ptrnVar in @@ -494,6 +519,7 @@ constrainCase rtv region expr branches expected = |> IO.bind (\branchVar -> let + branchType : Type branchType = VarN branchVar in @@ -539,18 +565,23 @@ constrainRecord rtv region fields expected = |> IO.fmap (\dict -> let + getType : a -> ( b, c, d ) -> c getType _ ( _, t, _ ) = t + recordType : Type recordType = RecordN (Dict.map getType dict) EmptyRecordN + recordCon : Constraint recordCon = CEqual region Record recordType expected + vars : List UF.Variable vars = Dict.foldr (\_ ( v, _, _ ) vs -> v :: vs) [] dict + cons : List Constraint cons = Dict.foldr (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] dict in @@ -564,6 +595,7 @@ constrainField rtv expr = |> IO.bind (\var -> let + tipe : Type tipe = VarN var in @@ -591,22 +623,28 @@ constrainUpdate rtv region name expr fields expected = |> IO.bind (\recordVar -> let + recordType : Type recordType = VarN recordVar + fieldsType : Type fieldsType = RecordN (Dict.map (\_ ( _, t, _ ) -> t) fieldDict) (VarN extVar) -- NOTE: fieldsType is separate so that Error propagates better + fieldsCon : Constraint fieldsCon = CEqual region Record recordType (NoExpectation fieldsType) + recordCon : Constraint recordCon = CEqual region Record recordType expected + vars : List UF.Variable vars = Dict.foldr (\_ ( v, _, _ ) vs -> v :: vs) [ recordVar, extVar ] fieldDict + cons : List Constraint cons = Dict.foldr (\_ ( _, _, c ) cs -> c :: cs) [ recordCon ] fieldDict in @@ -623,6 +661,7 @@ constrainUpdateField rtv region field (Can.FieldUpdate _ expr) = |> IO.bind (\var -> let + tipe : Type tipe = VarN var in @@ -644,9 +683,11 @@ constrainTuple rtv region a b maybeC expected = |> IO.bind (\bVar -> let + aType : Type aType = VarN aVar + bType : Type bType = VarN bVar in @@ -659,9 +700,11 @@ constrainTuple rtv region a b maybeC expected = case maybeC of Nothing -> let + tupleType : Type tupleType = TupleN aType bType Nothing + tupleCon : Constraint tupleCon = CEqual region Tuple tupleType expected in @@ -672,6 +715,7 @@ constrainTuple rtv region a b maybeC expected = |> IO.bind (\cVar -> let + cType : Type cType = VarN cVar in @@ -679,9 +723,11 @@ constrainTuple rtv region a b maybeC expected = |> IO.fmap (\cCon -> let + tupleType : Type tupleType = TupleN aType bType (Just cType) + tupleCon : Constraint tupleCon = CEqual region Tuple tupleType expected in @@ -707,12 +753,15 @@ constrainShader region (Shader.Types attributes uniforms varyings) expected = |> IO.fmap (\unifVar -> let + attrType : Type attrType = VarN attrVar + unifType : Type unifType = VarN unifVar + shaderType : Type shaderType = AppN ModuleName.webgl Name.shader @@ -770,6 +819,7 @@ constrainDestruct rtv region pattern expr bodyCon = |> IO.bind (\patternVar -> let + patternType : Type patternType = VarN patternVar in @@ -814,6 +864,7 @@ constrainDef rtv def bodyCon = Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> let + newNames : Dict Name () newNames = Dict.diff freeVars rtv in @@ -821,6 +872,7 @@ constrainDef rtv def bodyCon = |> IO.bind (\newRigids -> let + newRtv : Dict Name Type newRtv = Dict.union compare rtv (Dict.map (\_ -> VarN) newRigids) in @@ -828,6 +880,7 @@ constrainDef rtv def bodyCon = |> IO.bind (\(TypedArgs tipe resultType (Pattern.State headers pvars revCons)) -> let + expected : Expected Type expected = FromAnnotation name (List.length typedArgs) TypedBody resultType in @@ -897,6 +950,7 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo = |> IO.bind (\exprCon -> let + defCon : Constraint defCon = CLet [] pvars @@ -913,6 +967,7 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo = Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType -> let + newNames : Dict Name () newNames = Dict.diff freeVars rtv in @@ -920,6 +975,7 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo = |> IO.bind (\newRigids -> let + newRtv : Dict Name Type newRtv = Dict.union compare rtv (Dict.map (\_ -> VarN) newRigids) in @@ -930,6 +986,7 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo = |> IO.bind (\exprCon -> let + defCon : Constraint defCon = CLet [] pvars @@ -975,6 +1032,7 @@ argsHelp args state = |> IO.fmap (\resultVar -> let + resultType : Type resultType = VarN resultVar in @@ -986,6 +1044,7 @@ argsHelp args state = |> IO.bind (\argVar -> let + argType : Type argType = VarN argVar in @@ -1026,6 +1085,7 @@ typedArgsHelp rtv name index args srcResultType state = |> IO.bind (\argType -> let + expected : PExpected Type expected = PFromContext region (PTypedArg name index) argType in diff --git a/src/Compiler/Type/Constrain/Module.elm b/src/Compiler/Type/Constrain/Module.elm index 82f02a87a..d5a30ae57 100644 --- a/src/Compiler/Type/Constrain/Module.elm +++ b/src/Compiler/Type/Constrain/Module.elm @@ -9,7 +9,7 @@ import Compiler.Type.Constrain.Expression as Expr import Compiler.Type.Instantiate as Instantiate import Compiler.Type.Type as Type exposing (Constraint(..), Type(..), mkFlexVar, nameToRigid) import Data.IO as IO exposing (IO) -import Data.Map as Dict +import Data.Map as Dict exposing (Dict) import Utils.Main as Utils @@ -77,6 +77,7 @@ letPort name port_ makeConstraint = |> IO.bind (\tipe -> let + header : Dict Name (A.Located Type) header = Dict.singleton name (A.At A.zero tipe) in @@ -92,6 +93,7 @@ letPort name port_ makeConstraint = |> IO.bind (\tipe -> let + header : Dict Name (A.Located Type) header = Dict.singleton name (A.At A.zero tipe) in @@ -110,12 +112,15 @@ letCmd home tipe constraint = |> IO.fmap (\msgVar -> let + msg : Type msg = VarN msgVar + cmdType : Type cmdType = FunN (AppN home tipe [ msg ]) (AppN ModuleName.cmd Name.cmd [ msg ]) + header : Dict Name (A.Located Type) header = Dict.singleton "command" (A.At A.zero cmdType) in @@ -129,12 +134,15 @@ letSub home tipe constraint = |> IO.fmap (\msgVar -> let + msg : Type msg = VarN msgVar + subType : Type subType = FunN (AppN home tipe [ msg ]) (AppN ModuleName.sub Name.sub [ msg ]) + header : Dict Name (A.Located Type) header = Dict.singleton "subscription" (A.At A.zero subType) in @@ -166,30 +174,39 @@ constrainEffects home r0 r1 r2 manager = |> IO.bind (\sm2 -> let + state0 : Type state0 = VarN s0 + state1 : Type state1 = VarN s1 + state2 : Type state2 = VarN s2 + msg1 : Type msg1 = VarN m1 + msg2 : Type msg2 = VarN m2 + self1 : Type self1 = VarN sm1 + self2 : Type self2 = VarN sm2 + onSelfMsg : Type onSelfMsg = Type.funType (router msg2 self2) (Type.funType self2 (Type.funType state2 (task state2))) + onEffects : Type onEffects = case manager of Can.Cmd cmd -> @@ -201,6 +218,7 @@ constrainEffects home r0 r1 r2 manager = Can.Fx cmd sub -> Type.funType (router msg1 self1) (Type.funType (effectList home cmd msg1) (Type.funType (effectList home sub msg1) (Type.funType state1 (task state1)))) + effectCons : Constraint effectCons = CAnd [ CLocal r0 "init" (E.NoExpectation (task state0)) @@ -256,9 +274,11 @@ checkMap name home tipe constraint = |> IO.fmap (\b -> let + mapType : Type mapType = toMapType home tipe (VarN a) (VarN b) + mapCon : Constraint mapCon = CLocal A.zero name (E.NoExpectation mapType) in diff --git a/src/Compiler/Type/Constrain/Pattern.elm b/src/Compiler/Type/Constrain/Pattern.elm index 82af4df03..091595211 100644 --- a/src/Compiler/Type/Constrain/Pattern.elm +++ b/src/Compiler/Type/Constrain/Pattern.elm @@ -1,5 +1,6 @@ module Compiler.Type.Constrain.Pattern exposing - ( State(..) + ( Header + , State(..) , add , emptyState ) @@ -50,6 +51,7 @@ add (A.At region pattern) expectation state = (State headers vars revCons) = state + unitCon : Type.Constraint unitCon = Type.CPattern region E.PUnit Type.UnitN expectation in @@ -70,9 +72,11 @@ add (A.At region pattern) expectation state = |> IO.bind (\entryVar -> let + entryType : Type entryType = Type.VarN entryVar + listType : Type listType = Type.AppN ModuleName.list Name.list [ entryType ] in @@ -80,6 +84,7 @@ add (A.At region pattern) expectation state = |> IO.fmap (\(State headers vars revCons) -> let + listCon : Type.Constraint listCon = Type.CPattern region E.PList listType expectation in @@ -92,15 +97,19 @@ add (A.At region pattern) expectation state = |> IO.bind (\entryVar -> let + entryType : Type entryType = Type.VarN entryVar + listType : Type listType = Type.AppN ModuleName.list Name.list [ entryType ] + headExpectation : E.PExpected Type headExpectation = E.PNoExpectation entryType + tailExpectation : E.PExpected Type tailExpectation = E.PFromContext region E.PTail listType in @@ -109,6 +118,7 @@ add (A.At region pattern) expectation state = |> IO.fmap (\(State headers vars revCons) -> let + listCon : Type.Constraint listCon = Type.CPattern region E.PList listType expectation in @@ -121,6 +131,7 @@ add (A.At region pattern) expectation state = |> IO.bind (\extVar -> let + extType : Type extType = Type.VarN extVar in @@ -128,15 +139,18 @@ add (A.At region pattern) expectation state = |> IO.fmap (\fieldVars -> let + fieldTypes : Dict Name.Name Type fieldTypes = Dict.fromList compare (List.map (Tuple.mapSecond Type.VarN) fieldVars) + recordType : Type recordType = Type.RecordN fieldTypes extType (State headers vars revCons) = state + recordCon : Type.Constraint recordCon = Type.CPattern region E.PRecord recordType expectation in @@ -152,6 +166,7 @@ add (A.At region pattern) expectation state = (State headers vars revCons) = state + intCon : Type.Constraint intCon = Type.CPattern region E.PInt Type.int expectation in @@ -162,6 +177,7 @@ add (A.At region pattern) expectation state = (State headers vars revCons) = state + strCon : Type.Constraint strCon = Type.CPattern region E.PStr Type.string expectation in @@ -172,6 +188,7 @@ add (A.At region pattern) expectation state = (State headers vars revCons) = state + chrCon : Type.Constraint chrCon = Type.CPattern region E.PChr Type.char expectation in @@ -182,6 +199,7 @@ add (A.At region pattern) expectation state = (State headers vars revCons) = state + boolCon : Type.Constraint boolCon = Type.CPattern region E.PBool Type.bool expectation in @@ -200,9 +218,11 @@ emptyState = addToHeaders : A.Region -> Name.Name -> E.PExpected Type -> State -> State addToHeaders region name expectation (State headers vars revCons) = let + tipe : Type tipe = getType expectation + newHeaders : Dict Name.Name (A.Located Type) newHeaders = Dict.insert compare name (A.At region tipe) headers in @@ -226,6 +246,7 @@ getType expectation = addEntry : A.Region -> Type -> State -> ( Index.ZeroBased, Can.Pattern ) -> IO State addEntry listRegion tipe state ( index, pattern ) = let + expectation : E.PExpected Type expectation = E.PFromContext listRegion (E.PListEntry index) tipe in @@ -245,9 +266,11 @@ addTuple region a b maybeC expectation state = |> IO.bind (\bVar -> let + aType : Type aType = Type.VarN aVar + bType : Type bType = Type.VarN bVar in @@ -258,6 +281,7 @@ addTuple region a b maybeC expectation state = |> IO.fmap (\(State headers vars revCons) -> let + tupleCon : Type.Constraint tupleCon = Type.CPattern region E.PTuple (Type.TupleN aType bType Nothing) expectation in @@ -269,6 +293,7 @@ addTuple region a b maybeC expectation state = |> IO.bind (\cVar -> let + cType : Type cType = Type.VarN cVar in @@ -278,6 +303,7 @@ addTuple region a b maybeC expectation state = |> IO.fmap (\(State headers vars revCons) -> let + tupleCon : Type.Constraint tupleCon = Type.CPattern region E.PTuple (Type.TupleN aType bType (Just cType)) expectation in @@ -303,9 +329,11 @@ addCtor region home typeName typeVarNames ctorName args expectation state = |> IO.bind (\varPairs -> let + typePairs : List ( Name.Name, Type ) typePairs = List.map (Tuple.mapSecond Type.VarN) varPairs + freeVarDict : Dict Name.Name Type freeVarDict = Dict.fromList compare typePairs in @@ -313,9 +341,11 @@ addCtor region home typeName typeVarNames ctorName args expectation state = |> IO.bind (\(State headers vars revCons) -> let + ctorType : Type ctorType = Type.AppN home typeName (List.map Tuple.second typePairs) + ctorCon : Type.Constraint ctorCon = Type.CPattern region (E.PCtor ctorName) ctorType expectation in @@ -333,6 +363,7 @@ addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType p |> IO.bind (\tipe -> let + expectation : E.PExpected Type expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe in diff --git a/src/Compiler/Type/Error.elm b/src/Compiler/Type/Error.elm index 81060a417..a4117691b 100644 --- a/src/Compiler/Type/Error.elm +++ b/src/Compiler/Type/Error.elm @@ -140,9 +140,11 @@ fieldsToDocs localizer fields = addField : L.Localizer -> Name -> Type -> List ( D.Doc, D.Doc ) -> List ( D.Doc, D.Doc ) addField localizer fieldName fieldType docs = let + f : D.Doc f = D.fromName fieldName + t : D.Doc t = toDoc localizer RT.None fieldType in @@ -184,7 +186,7 @@ type Problem | AnythingToBool | AnythingFromMaybe | ArityMismatch Int Int - | BadFlexSuper Direction Super Name Type + | BadFlexSuper Direction Super Type | BadRigidVar Name Type | BadRigidSuper Super Name Type | FieldTypo Name (List Name) @@ -317,6 +319,7 @@ toDiff localizer ctx tipe1 tipe2 = else let + f : Type -> D.Doc f = toDoc localizer RT.Func in @@ -445,9 +448,11 @@ toDiff localizer ctx tipe1 tipe2 = toDiffOtherwise : L.Localizer -> RT.Context -> ( Type, Type ) -> Diff D.Doc toDiffOtherwise localizer ctx (( tipe1, tipe2 ) as pair) = let + doc1 : D.Doc doc1 = D.dullyellow (toDoc localizer ctx tipe1) + doc2 : D.Doc doc2 = D.dullyellow (toDoc localizer ctx tipe2) in @@ -456,8 +461,8 @@ toDiffOtherwise localizer ctx (( tipe1, tipe2 ) as pair) = ( RigidVar x, other ) -> Bag.one <| BadRigidVar x other - ( FlexSuper s x, other ) -> - Bag.one <| BadFlexSuper Have s x other + ( FlexSuper s _, other ) -> + Bag.one <| BadFlexSuper Have s other ( RigidSuper s x, other ) -> Bag.one <| BadRigidSuper s x other @@ -465,8 +470,8 @@ toDiffOtherwise localizer ctx (( tipe1, tipe2 ) as pair) = ( other, RigidVar x ) -> Bag.one <| BadRigidVar x other - ( other, FlexSuper s x ) -> - Bag.one <| BadFlexSuper Need s x other + ( other, FlexSuper s _ ) -> + Bag.one <| BadFlexSuper Need s other ( other, RigidSuper s x ) -> Bag.one <| BadRigidSuper s x other @@ -496,7 +501,7 @@ toDiffOtherwise localizer ctx (( tipe1, tipe2 ) as pair) = else Bag.empty - ( _, _ ) -> + _ -> Bag.empty @@ -507,6 +512,7 @@ toDiffOtherwise localizer ctx (( tipe1, tipe2 ) as pair) = same : L.Localizer -> RT.Context -> Type -> Diff D.Doc same localizer ctx tipe = let + doc : D.Doc doc = toDoc localizer ctx tipe in @@ -643,6 +649,7 @@ diffAliasedRecord localizer t1 t2 = diffRecord : L.Localizer -> Dict Name Type -> Extension -> Dict Name Type -> Extension -> Diff D.Doc diffRecord localizer fields1 ext1 fields2 ext2 = let + toUnknownDocs : Name -> Type -> ( D.Doc, D.Doc ) toUnknownDocs field tipe = ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe ) @@ -650,18 +657,11 @@ diffRecord localizer fields1 ext1 fields2 ext2 = toOverlapDocs field t1 t2 = fmapDiff (Tuple.pair (D.fromName field)) <| toDiff localizer RT.None t1 t2 + left : Dict Name ( D.Doc, D.Doc ) left = Dict.map toUnknownDocs (Dict.diff fields1 fields2) - both : Dict Name (Diff ( D.Doc, D.Doc )) - both = - Dict.merge (\_ _ acc -> acc) - (\field t1 t2 acc -> Dict.insert compare field (toOverlapDocs field t1 t2) acc) - (\_ _ acc -> acc) - fields1 - fields2 - Dict.empty - + right : Dict Name ( D.Doc, D.Doc ) right = Dict.map toUnknownDocs (Dict.diff fields2 fields1) @@ -671,6 +671,15 @@ diffRecord localizer fields1 ext1 fields2 ext2 = fieldsDiffDict : Diff (Dict Name ( D.Doc, D.Doc )) fieldsDiffDict = let + both : Dict Name (Diff ( D.Doc, D.Doc )) + both = + Dict.merge (\_ _ acc -> acc) + (\field t1 t2 acc -> Dict.insert compare field (toOverlapDocs field t1 t2) acc) + (\_ _ acc -> acc) + fields1 + fields2 + Dict.empty + sequenceA : Dict Name (Diff ( D.Doc, D.Doc )) -> Diff (Dict Name ( D.Doc, D.Doc )) sequenceA = Dict.foldr (\k x acc -> applyDiff acc (fmapDiff (Dict.insert compare k) x)) (pureDiff Dict.empty) @@ -679,9 +688,6 @@ diffRecord localizer fields1 ext1 fields2 ext2 = sequenceA both else - -- Map.union - -- <$> sequenceA both - -- <*> Diff left right (Different Bag.empty) liftA2 (Dict.union compare) (sequenceA both) (Diff left right (Different Bag.empty)) @@ -698,6 +704,7 @@ diffRecord localizer fields1 ext1 fields2 ext2 = case ( hasFixedFields ext1, hasFixedFields ext2 ) of ( True, True ) -> let + minView : Maybe ( Name, ( D.Doc, D.Doc ) ) minView = Dict.toList left |> List.sortBy Tuple.first @@ -716,6 +723,7 @@ diffRecord localizer fields1 ext1 fields2 ext2 = ( False, True ) -> let + minView : Maybe ( Name, ( D.Doc, D.Doc ) ) minView = Dict.toList left |> List.sortBy Tuple.first @@ -730,6 +738,7 @@ diffRecord localizer fields1 ext1 fields2 ext2 = ( True, False ) -> let + minView : Maybe ( Name, ( D.Doc, D.Doc ) ) minView = Dict.toList right |> List.sortBy Tuple.first @@ -766,12 +775,15 @@ hasFixedFields ext = extToDiff : Extension -> Extension -> Diff (Maybe D.Doc) extToDiff ext1 ext2 = let + status : Status status = extToStatus ext1 ext2 + extDoc1 : Maybe D.Doc extDoc1 = extToDoc ext1 + extDoc2 : Maybe D.Doc extDoc2 = extToDoc ext2 in diff --git a/src/Compiler/Type/Instantiate.elm b/src/Compiler/Type/Instantiate.elm index e21454a5d..9a8cead02 100644 --- a/src/Compiler/Type/Instantiate.elm +++ b/src/Compiler/Type/Instantiate.elm @@ -23,7 +23,7 @@ type alias FreeVars = -- FROM SOURCE TYPE -fromSrcType : Dict Name Type -> Can.Type -> IO Type +fromSrcType : FreeVars -> Can.Type -> IO Type fromSrcType freeVars sourceType = case sourceType of Can.TLambda arg result -> diff --git a/src/Compiler/Type/Occurs.elm b/src/Compiler/Type/Occurs.elm index 6a8ecc9be..2f4f9e432 100644 --- a/src/Compiler/Type/Occurs.elm +++ b/src/Compiler/Type/Occurs.elm @@ -1,6 +1,5 @@ module Compiler.Type.Occurs exposing (occurs) -import Compiler.Type.Type as Type import Compiler.Type.UnionFind as UF import Data.IO as IO exposing (IO) import Data.Map as Dict @@ -39,6 +38,7 @@ occursHelp seen var foundCycle = UF.Structure term -> let + newSeen : List UF.Variable newSeen = var :: seen in diff --git a/src/Compiler/Type/Solve.elm b/src/Compiler/Type/Solve.elm index 047517614..1503b6b19 100644 --- a/src/Compiler/Type/Solve.elm +++ b/src/Compiler/Type/Solve.elm @@ -4,7 +4,6 @@ import Array exposing (Array) import Compiler.AST.Canonical as Can import Compiler.Data.Name as Name import Compiler.Data.NonEmptyList as NE -import Compiler.Elm.Kernel exposing (Chunk(..)) import Compiler.Reporting.Annotation as A import Compiler.Reporting.Error.Type as Error import Compiler.Reporting.Render.Type as RT @@ -200,6 +199,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = |> IO.bind (\locals -> let + newEnv : Env newEnv = Dict.union compare env (Dict.map (\_ -> A.toValue) locals) in @@ -214,6 +214,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = CLet rigids flexs header headerCon subCon -> let -- work in the next pool to localize header + nextRank : Int nextRank = rank + 1 in @@ -233,6 +234,7 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = (\nextPools -> let -- introduce variables + vars : List Variable vars = rigids ++ flexs in @@ -255,12 +257,15 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = |> IO.bind (\(State savedEnv mark errors) -> let + youngMark : Mark youngMark = mark + visitMark : Mark visitMark = nextMark youngMark + finalMark : Mark finalMark = nextMark visitMark in @@ -276,9 +281,11 @@ solve env rank pools ((State _ sMark sErrors) as state) constraint = |> IO.bind (\_ -> let + newEnv : Env newEnv = Dict.union compare env (Dict.map (\_ -> A.toValue) locals) + tempState : State tempState = State savedEnv finalMark errors in @@ -524,6 +531,7 @@ adjustRank youngMark visitMark groupRank var = else let + minRank : Int minRank = min groupRank rank in @@ -536,6 +544,7 @@ adjustRank youngMark visitMark groupRank var = adjustRankContent : Mark -> Mark -> Int -> Content -> IO Int adjustRankContent youngMark visitMark groupRank content = let + go : Variable -> IO Int go = adjustRank youngMark visitMark groupRank in @@ -647,6 +656,7 @@ typeToVariable rank pools tipe = typeToVar : Int -> Pools -> Dict Name.Name Variable -> Type -> IO Variable typeToVar rank pools aliasDict tipe = let + go : Type -> IO Variable go = typeToVar rank pools aliasDict in @@ -746,6 +756,7 @@ unit1 = srcTypeToVariable : Int -> Pools -> Dict Name.Name () -> Can.Type -> IO Variable srcTypeToVariable rank pools freeVars srcType = let + nameToContent : Name.Name -> Content nameToContent name = if Name.isNumberType name then UF.FlexSuper UF.Number (Just name) @@ -762,6 +773,7 @@ srcTypeToVariable rank pools freeVars srcType = else UF.FlexVar (Just name) + makeVar : Name.Name -> b -> IO Variable makeVar name _ = UF.fresh (Descriptor (nameToContent name) rank Type.noMark Nothing) in @@ -776,6 +788,7 @@ srcTypeToVariable rank pools freeVars srcType = srcTypeToVar : Int -> Pools -> Dict Name.Name Variable -> Can.Type -> IO Variable srcTypeToVar rank pools flexVars srcType = let + go : Can.Type -> IO Variable go = srcTypeToVar rank pools flexVars in @@ -888,6 +901,7 @@ makeCopyHelp maxRank pools variable = else let + makeDescriptor : Content -> Descriptor makeDescriptor c = Descriptor c maxRank Type.noMark Nothing in diff --git a/src/Compiler/Type/Type.elm b/src/Compiler/Type/Type.elm index dbdc310e1..d01c6145a 100644 --- a/src/Compiler/Type/Type.elm +++ b/src/Compiler/Type/Type.elm @@ -621,6 +621,7 @@ getFreshVarName = getFreshVarNameHelp : Int -> Dict Name () -> ( Name, Int, Dict Name () ) getFreshVarNameHelp index taken = let + name : Name name = Name.fromTypeVariableScheme index in @@ -691,6 +692,7 @@ getFreshSuper prefix getter setter = getFreshSuperHelp : Name -> Int -> Dict Name () -> ( Name, Int, Dict Name () ) getFreshSuperHelp prefix index taken = let + name : Name name = Name.fromTypeVariable prefix index in @@ -782,6 +784,7 @@ getVarNames var takenNames = addName : Int -> Name -> UF.Variable -> (Name -> UF.Content) -> Dict Name UF.Variable -> IO (Dict Name UF.Variable) addName index givenName var makeContent takenNames = let + indexedName : Name indexedName = Name.fromTypeVariable givenName index in diff --git a/src/Compiler/Type/Unify.elm b/src/Compiler/Type/Unify.elm index 021cea317..b91dec8b5 100644 --- a/src/Compiler/Type/Unify.elm +++ b/src/Compiler/Type/Unify.elm @@ -532,7 +532,7 @@ unifyAlias ((Context _ _ second _) as context) home name args realVar otherConte if name == otherName && home == otherHome then Unify (\vars -> - unifyAliasArgs vars context args otherArgs + unifyAliasArgs vars args otherArgs |> IO.bind (\res -> case res of @@ -556,8 +556,8 @@ unifyAlias ((Context _ _ second _) as context) home name args realVar otherConte merge context UF.Error -unifyAliasArgs : List UF.Variable -> Context -> List ( Name.Name, UF.Variable ) -> List ( Name.Name, UF.Variable ) -> IO (Result UnifyErr (UnifyOk ())) -unifyAliasArgs vars context args1 args2 = +unifyAliasArgs : List UF.Variable -> List ( Name.Name, UF.Variable ) -> List ( Name.Name, UF.Variable ) -> IO (Result UnifyErr (UnifyOk ())) +unifyAliasArgs vars args1 args2 = case args1 of ( _, arg1 ) :: others1 -> case args2 of @@ -569,10 +569,10 @@ unifyAliasArgs vars context args1 args2 = (\res1 -> case res1 of Ok (UnifyOk vs ()) -> - unifyAliasArgs vs context others1 others2 + unifyAliasArgs vs others1 others2 Err (UnifyErr vs ()) -> - unifyAliasArgs vs context others1 others2 + unifyAliasArgs vs others1 others2 |> IO.fmap (\res2 -> case res2 of @@ -624,7 +624,7 @@ unifyStructure ((Context first _ second _) as context) flatType content otherCon if home == otherHome && name == otherName then Unify (\vars -> - unifyArgs vars context args otherArgs + unifyArgs vars args otherArgs |> IO.bind (\unifiedArgs -> case unifiedArgs of @@ -704,8 +704,8 @@ unifyStructure ((Context first _ second _) as context) flatType content otherCon -- UNIFY ARGS -unifyArgs : List UF.Variable -> Context -> List UF.Variable -> List UF.Variable -> IO (Result UnifyErr (UnifyOk ())) -unifyArgs vars context args1 args2 = +unifyArgs : List UF.Variable -> List UF.Variable -> List UF.Variable -> IO (Result UnifyErr (UnifyOk ())) +unifyArgs vars args1 args2 = case args1 of arg1 :: others1 -> case args2 of @@ -717,10 +717,10 @@ unifyArgs vars context args1 args2 = (\result -> case result of Ok (UnifyOk vs ()) -> - unifyArgs vs context others1 others2 + unifyArgs vs others1 others2 Err (UnifyErr vs ()) -> - unifyArgs vs context others1 others2 + unifyArgs vs others1 others2 |> IO.fmap (Result.andThen (\(UnifyOk vs_ ()) -> @@ -748,12 +748,15 @@ unifyArgs vars context args1 args2 = unifyRecord : Context -> RecordStructure -> RecordStructure -> Unify () unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) = let + sharedFields : Dict Name.Name ( UF.Variable, UF.Variable ) sharedFields = Utils.mapIntersectionWith compare Tuple.pair fields1 fields2 + uniqueFields1 : Dict Name.Name UF.Variable uniqueFields1 = Dict.diff fields1 fields2 + uniqueFields2 : Dict Name.Name UF.Variable uniqueFields2 = Dict.diff fields2 fields1 in @@ -780,6 +783,7 @@ unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2 else let + otherFields : Dict Name.Name UF.Variable otherFields = Dict.union compare uniqueFields1 uniqueFields2 in diff --git a/src/Compiler/Type/UnionFind.elm b/src/Compiler/Type/UnionFind.elm index b23522886..14b506ecb 100644 --- a/src/Compiler/Type/UnionFind.elm +++ b/src/Compiler/Type/UnionFind.elm @@ -566,6 +566,7 @@ union p1 p2 newDesc = |> IO.bind (\weight2 -> let + newWeight : Int newWeight = weight1 + weight2 in diff --git a/src/Data/Graph.elm b/src/Data/Graph.elm index 43d0944ff..11761efd8 100644 --- a/src/Data/Graph.elm +++ b/src/Data/Graph.elm @@ -1,13 +1,12 @@ module Data.Graph exposing - ( Bounds + ( Array + , Bounds , Edge , Graph , SCC(..) , Table , Vertex - -- , bcc , buildG - -- , components , dff , dfs , edges @@ -17,13 +16,9 @@ module Data.Graph exposing , graphFromEdges_ , indegree , outdegree - -- , path - -- , reachable - -- , reverseTopSort , scc , stronglyConnComp , stronglyConnCompR - -- , topSort , transposeG , vertices ) @@ -79,6 +74,7 @@ array ( l, u ) = accumArray : (e -> a -> e) -> e -> ( Int, Int ) -> List ( Int, a ) -> Array i e accumArray f initial ( l, u ) ies = let + initialArr : Dict Int e initialArr = List.repeat ((u + 1) - l) () |> List.indexedMap (\i _ -> ( l + i, initial )) @@ -153,11 +149,14 @@ stronglyConnCompR edges0 = ( graph, vertexFn, _ ) = graphFromEdges edges0 + forest : List (Tree Vertex) forest = scc graph + decode : Tree Vertex -> SCC ( node, comparable, List comparable ) decode tree = let + v : Vertex v = Tree.label tree in @@ -172,9 +171,11 @@ stronglyConnCompR edges0 = ts -> CyclicSCC (vertexFn v :: List.foldr dec [] ts) + dec : Tree Vertex -> List ( node, comparable, List comparable ) -> List ( node, comparable, List comparable ) dec node vs = vertexFn (Tree.label node) :: List.foldr dec vs (Tree.children node) + mentionsItself : Int -> Bool mentionsItself v = List.member v (find v graph) in @@ -389,43 +390,51 @@ Get the label for a given key. graphFromEdges : List ( node, comparable, List comparable ) -> ( Graph, Vertex -> ( node, comparable, List comparable ), comparable -> Maybe Vertex ) graphFromEdges edges0 = let + maxV : Int maxV = List.length edges0 - 1 + bounds0 : ( number, Int ) bounds0 = ( 0, maxV ) + sortedEdges : List ( node, comparable, List comparable ) sortedEdges = List.sortWith (\( _, k1, _ ) ( _, k2, _ ) -> compare k1 k2) edges0 + edges1 : List ( Int, ( node, comparable, List comparable ) ) edges1 = List.map2 Tuple.pair (List.indexedMap (\i _ -> i) (List.repeat (List.length sortedEdges) ())) sortedEdges + graph : Array i (List Int) graph = edges1 |> List.map (\( v, ( _, _, ks ) ) -> ( v, List.filterMap keyVertex ks )) |> array bounds0 + keyMap : Array i comparable keyMap = edges1 |> List.map (\( v, ( _, k, _ ) ) -> ( v, k )) |> array bounds0 + vertexMap : Array i ( node, comparable, List comparable ) vertexMap = array bounds0 edges1 - -- keyVertex :: key -> Maybe Vertex - -- returns Nothing for non-interesting vertices + keyVertex : comparable -> Maybe Int keyVertex k = let + findVertex : Int -> Int -> Maybe Int findVertex a b = if a > b then Nothing else let + mid : Int mid = a + (b - a) // 2 in diff --git a/src/Data/IO.elm b/src/Data/IO.elm index a24b1b85f..7a99d57e0 100644 --- a/src/Data/IO.elm +++ b/src/Data/IO.elm @@ -10,6 +10,7 @@ module Data.IO exposing , IOMode(..) , IORef(..) , Process(..) + , ProcessHandle , StateT(..) , StdStream(..) , apply @@ -50,13 +51,10 @@ module Data.IO exposing , pure , pureStateT , putStr - , readFile , readIORef , runStateT , stderr - , stdin , stdout - , utf8 , vectorForM_ , vectorImapM_ , vectorUnsafeFreeze @@ -129,7 +127,9 @@ type Effect | ReplGetInputLineWithInitial String ( String, String ) | HClose Handle | HFileSize Handle + | HFlush Handle | WithFile String IOMode + | StatePut Encode.Value | StateGet | ProcWithCreateProcess CreateProcess | ProcWaitForProcess Int @@ -216,15 +216,6 @@ type IORef a = IORef Int -type TextEncoding - = UTF8 - - -utf8 : TextEncoding -utf8 = - UTF8 - - catch : (e -> IO a) -> IO (Result e a) -> IO a catch handler (IO io) = -- IO @@ -255,11 +246,6 @@ newIORef encoder value = make (Decode.map IORef Decode.int) (NewIORef (encoder value)) -readFile : String -> IO String -readFile _ = - todo "readFile" - - readIORef : Decode.Decoder a -> IORef a -> IO a readIORef decoder (IORef ref) = make decoder (ReadIORef ref) @@ -318,6 +304,7 @@ bind cont (IO fn) = foldrM : (a -> b -> IO b) -> b -> List a -> IO b foldrM f z0 xs = let + c : a -> (b -> IO c) -> b -> IO c c x k z = bind k (f x z) in @@ -545,11 +532,6 @@ type Handle = Handle Int -stdin : Handle -stdin = - Handle 0 - - stdout : Handle stdout = Handle 1 @@ -562,7 +544,7 @@ stderr = hFlush : Handle -> IO () hFlush handle = - make (Decode.succeed ()) NoOp + make (Decode.succeed ()) (HFlush handle) hFileSize : Handle -> IO Int @@ -641,6 +623,7 @@ exitWith exitCode = IO (\_ -> let + code : Int code = case exitCode of ExitSuccess -> diff --git a/src/Data/Map.elm b/src/Data/Map.elm index 4dab838b2..e560deb46 100644 --- a/src/Data/Map.elm +++ b/src/Data/Map.elm @@ -215,6 +215,7 @@ consider using `get` in conjunction with `insert` instead.) update : (k -> k -> Order) -> k -> (Maybe v -> Maybe v) -> Dict k v -> Dict k v update keyComparison targetKey alter ((D alist) as dict) = let + maybeValue : Maybe v maybeValue = get targetKey dict in @@ -282,6 +283,7 @@ Preference is given to values in the first dictionary. intersection : Dict k a -> Dict k b -> Dict k a intersection dict1 dict2 = let + keys2 : List k keys2 = keys dict2 in @@ -329,6 +331,7 @@ merge leftStep bothStep rightStep ((D leftAlist) as leftDict) (D rightAlist) ini ) rightAlist + intermediateResult : result intermediateResult = List.foldr (\( rKey, rValue ) result -> diff --git a/src/Terminal/Bump.elm b/src/Terminal/Bump.elm index 1bf5b1bac..ca623e203 100644 --- a/src/Terminal/Bump.elm +++ b/src/Terminal/Bump.elm @@ -85,6 +85,7 @@ bump ((Env root _ _ registry ((Outline.PkgOutline pkg _ _ vsn _ _ _ _) as outlin case Registry.getVersions pkg registry of Just knownVersions -> let + bumpableVersions : List V.Version bumpableVersions = List.map (\( old, _, _ ) -> old) (Bump.getPossibilities knownVersions) in @@ -134,18 +135,23 @@ suggestVersion (Env root cache manager _ ((Outline.PkgOutline pkg _ _ vsn _ _ _ |> Task.bind (\newDocs -> let + changes : Diff.PackageChanges changes = Diff.diff oldDocs newDocs + newVersion : V.Version newVersion = Diff.bump changes vsn + old : D.Doc old = D.fromVersion vsn + new : D.Doc new = D.fromVersion newVersion + mag : D.Doc mag = D.fromChars <| M.toChars (Diff.toMagnitude changes) in diff --git a/src/Terminal/Develop.elm b/src/Terminal/Develop.elm deleted file mode 100644 index 5a0ffaf8d..000000000 --- a/src/Terminal/Develop.elm +++ /dev/null @@ -1,277 +0,0 @@ -module Terminal.Develop exposing - ( Flags(..) - , run - ) - -import Builder.BackgroundWriter as BW -import Builder.Build as Build -import Builder.Elm.Details as Details -import Builder.Generate -import Builder.Reporting -import Builder.Reporting.Exit as Exit -import Builder.Reporting.Task as Task -import Builder.Stuff -import Compiler.Data.NonEmptyList as NE -import Compiler.Generate.Html as Html -import Data.IO as IO exposing (IO) -import Data.Map as Dict exposing (Dict) -import Data.Maybe as Maybe -import Prelude -import Terminal.Develop.Generate.Help as Help -import Terminal.Develop.Generate.Index as Index -import Terminal.Develop.StaticFiles as StaticFiles -import Utils.Crash exposing (todo) -import Utils.Main as Utils exposing (FilePath) - - - --- RUN THE DEV SERVER - - -type Flags - = Flags (Maybe Int) - - -run : () -> Flags -> IO () -run () (Flags maybePort) = - let - port_ = - Maybe.maybe 8000 identity maybePort - in - Prelude.putStrLn ("Go to http://localhost:" ++ String.fromInt port_ ++ " to see your project dashboard.") - |> IO.bind - (\_ -> - -- Utils.httpServe (config port_) - -- (serveFiles - -- (Utils.serveDirectoryWith directoryConfig ".") - -- serveAssets - -- error404 - -- ) - todo "run" - ) - - -config : Int -> Utils.HttpServerConfig -config port_ = - let - defaultConfig = - Utils.defaultHttpServerConfig - in - -- setVerbose False <| - -- setPort port_ <| - -- setAccessLog ConfigNoLog <| - -- setErrorLog ConfigNoLog <| - -- defaultConfig - { defaultConfig - | verbose = Just False - , port_ = Just port_ - } - - - --- INDEX --- directoryConfig : Utils.DirectoryConfig m --- directoryConfig = --- fancyDirectoryConfig --- { indexFiles = [] --- , indexGenerator = --- \pwd -> --- do modifyResponse <| --- setContentType "text/html;charset=utf-8" --- writeBuilder --- =<< liftIO (Index.generate pwd) --- } --- NOT FOUND --- error404 : Snap () --- error404 = --- do modifyResponse <| --- setResponseStatus 404 --- "Not Found" --- modifyResponse --- <| --- setContentType "text/html;charset=utf-8" --- writeBuilder --- <| --- Help.makePageHtml "NotFound" Nothing --- SERVE FILES - - -serveFiles : Utils.HttpServerSnap () -serveFiles = - -- getSafePath - -- |> Snap.bind - -- (\path -> - -- Snap.bind guard (liftIO (Utils.dirDoesFileExist path)) - -- |> Snap.bind (serveElm path (serveFilePretty path)) - -- ) - todo "serveFiles" - - - --- SERVE FILES + CODE HIGHLIGHTING --- serveFilePretty : FilePath -> Snap () --- serveFilePretty path = --- let --- possibleExtensions = --- getSubExts (takeExtensions path) --- in --- case mconcat (map lookupMimeType possibleExtensions) of --- Nothing -> --- serveCode path --- Just mimeType -> --- serveFileAs mimeType path - - -getSubExts : String -> List String -getSubExts fullExtension = - if String.isEmpty fullExtension then - [] - - else - fullExtension :: getSubExts (Utils.fpTakeExtension (String.dropLeft 1 fullExtension)) - - - --- serveCode : String -> Snap () --- serveCode path = --- liftIO (BS.readFile path) --- |> IO.bind --- (\code -> --- modifyResponse (setContentType "text/html") --- |> IO.bind --- (\_ -> --- writeBuilder <| --- Help.makeCodeHtml ('~' :: '/' :: path) (B.byteString code) --- ) --- ) --- SERVE ELM --- serveElm : FilePath -> Snap () --- serveElm path = --- guard (takeExtension path == ".elm") --- |> IO.bind (\_ -> modifyResponse (setContentType "text/html")) --- |> IO.bind (\_ -> liftIO <| compile path) --- |> IO.bind --- (\result -> --- case result of --- Ok builder -> --- writeBuilder builder --- Err exit -> --- writeBuilder <| --- Help.makePageHtml "Errors" <| --- Just <| --- Exit.toJson <| --- Exit.reactorToReport exit --- ) --- compile : FilePath -> IO (Result Exit.Reactor String) --- compile path = --- Stuff.findRoot --- |> IO.bind --- (\maybeRoot -> --- case maybeRoot of --- Nothing -> --- IO.pure <| Err <| Exit.ReactorNoOutline --- Just root -> --- BW.withScope --- (\scope -> --- Stuff.withRootLock root <| --- Task.run <| --- (Task.eio Exit.ReactorBadDetails (Details.load Reporting.silent scope root) --- |> IO.bind --- (\details -> --- Task.eio Exit.ReactorBadBuild (Build.fromPaths Reporting.silent root details (NE.Nonempty path [])) --- |> IO.bind --- (\artifacts -> --- Task.mapError Exit.ReactorBadGenerate (Generate.dev root details artifacts) --- |> IO.fmap --- (\javascript -> --- let --- (NE.Nonempty name _) = --- Build.getRootNames artifacts --- in --- Html.sandwich name javascript --- ) --- ) --- ) --- ) --- ) --- ) --- SERVE STATIC ASSETS --- serveAssets : Snap () --- serveAssets = --- getSafePath --- |> Snap.bind --- (\path -> --- case StaticFiles.lookup path of --- Nothing -> --- pass --- Just ( content, mimeType ) -> --- modifyResponse (setContentType (mimeType ++ ";charset=utf-8")) --- |> Snap.bind (\_ -> writeBS content) --- ) --- MIME TYPES - - -lookupMimeType : FilePath -> Maybe String -lookupMimeType ext = - Dict.get ext mimeTypeDict - - -mimeTypeDict : Dict FilePath String -mimeTypeDict = - Dict.fromList compare - [ ( ".asc", "text/plain" ) - , ( ".asf", "video/x-ms-asf" ) - , ( ".asx", "video/x-ms-asf" ) - , ( ".avi", "video/x-msvideo" ) - , ( ".bz2", "application/x-bzip" ) - , ( ".css", "text/css" ) - , ( ".dtd", "text/xml" ) - , ( ".dvi", "application/x-dvi" ) - , ( ".gif", "image/gif" ) - , ( ".gz", "application/x-gzip" ) - , ( ".htm", "text/html" ) - , ( ".html", "text/html" ) - , ( ".ico", "image/x-icon" ) - , ( ".jpeg", "image/jpeg" ) - , ( ".jpg", "image/jpeg" ) - , ( ".js", "text/javascript" ) - , ( ".json", "application/json" ) - , ( ".m3u", "audio/x-mpegurl" ) - , ( ".mov", "video/quicktime" ) - , ( ".mp3", "audio/mpeg" ) - , ( ".mp4", "video/mp4" ) - , ( ".mpeg", "video/mpeg" ) - , ( ".mpg", "video/mpeg" ) - , ( ".ogg", "application/ogg" ) - , ( ".otf", "font/otf" ) - , ( ".pac", "application/x-ns-proxy-autoconfig" ) - , ( ".pdf", "application/pdf" ) - , ( ".png", "image/png" ) - , ( ".qt", "video/quicktime" ) - , ( ".sfnt", "font/sfnt" ) - , ( ".sig", "application/pgp-signature" ) - , ( ".spl", "application/futuresplash" ) - , ( ".svg", "image/svg+xml" ) - , ( ".swf", "application/x-shockwave-flash" ) - , ( ".tar", "application/x-tar" ) - , ( ".tar.bz2", "application/x-bzip-compressed-tar" ) - , ( ".tar.gz", "application/x-tgz" ) - , ( ".tbz", "application/x-bzip-compressed-tar" ) - , ( ".text", "text/plain" ) - , ( ".tgz", "application/x-tgz" ) - , ( ".ttf", "font/ttf" ) - , ( ".txt", "text/plain" ) - , ( ".wav", "audio/x-wav" ) - , ( ".wax", "audio/x-ms-wax" ) - , ( ".webm", "video/webm" ) - , ( ".webp", "image/webp" ) - , ( ".wma", "audio/x-ms-wma" ) - , ( ".wmv", "video/x-ms-wmv" ) - , ( ".woff", "font/woff" ) - , ( ".woff2", "font/woff2" ) - , ( ".xbm", "image/x-xbitmap" ) - , ( ".xml", "text/xml" ) - , ( ".xpm", "image/x-xpixmap" ) - , ( ".xwd", "image/x-xwindowdump" ) - , ( ".zip", "application/zip" ) - ] diff --git a/src/Terminal/Develop/Generate/Help.elm b/src/Terminal/Develop/Generate/Help.elm deleted file mode 100644 index f6858ac02..000000000 --- a/src/Terminal/Develop/Generate/Help.elm +++ /dev/null @@ -1,57 +0,0 @@ -module Terminal.Develop.Generate.Help exposing - ( makeCodeHtml - , makePageHtml - ) - -import Compiler.Data.Name as Name -import Compiler.Json.Encode as Encode -import Data.Maybe as Maybe - - - --- PAGES - - -makePageHtml : Name.Name -> Maybe Encode.Value -> String -makePageHtml moduleName maybeFlags = - """ - - - - - - - - - - -""" - - - --- CODE - - -makeCodeHtml : String -> String -> String -makeCodeHtml title code = - """ - - - - """ ++ title ++ """ - - - - - - -
""" ++ code ++ """
- - -""" diff --git a/src/Terminal/Develop/Generate/Index.elm b/src/Terminal/Develop/Generate/Index.elm deleted file mode 100644 index 0fed15531..000000000 --- a/src/Terminal/Develop/Generate/Index.elm +++ /dev/null @@ -1,249 +0,0 @@ -module Terminal.Develop.Generate.Index exposing (generate) - -import Builder.BackgroundWriter as BW -import Builder.Elm.Details as Details -import Builder.Elm.Outline as Outline -import Builder.Reporting as Reporting -import Builder.Stuff as Stuff -import Compiler.Elm.Package as Pkg -import Compiler.Elm.Version as V -import Compiler.Json.Encode as E -import Data.IO as IO exposing (IO) -import Data.Map as Dict exposing (Dict) -import Data.Maybe as Maybe -import List.Extra as List -import Terminal.Develop.Generate.Help as Help -import Utils.Main as Utils exposing (FilePath) - - - --- GENERATE - - -generate : FilePath -> IO String -generate pwd = - getFlags pwd - |> IO.fmap - (\flags -> - Help.makePageHtml "Index" (Just (encode flags)) - ) - - - --- FLAGS - - -type Flags - = Flags FilePath (List String) (List String) (List File) (Maybe String) (Maybe Outline.Outline) (Dict Pkg.Name V.Version) - - -type File - = File FilePath Bool - - - --- GET FLAGS - - -getFlags : FilePath -> IO Flags -getFlags pwd = - Utils.dirGetDirectoryContents pwd - |> IO.bind - (\contents -> - Utils.dirGetCurrentDirectory - |> IO.bind - (\root -> - getDirs pwd contents - |> IO.bind - (\dirs -> - getFiles pwd contents - |> IO.bind - (\files -> - getReadme pwd - |> IO.bind - (\readme -> - getOutline - |> IO.bind - (\outline -> - getExactDeps outline - |> IO.fmap - (\exactDeps -> - Flags root - (List.dropWhile ((==) ".") (Utils.fpSplitDirectories pwd)) - dirs - files - readme - outline - exactDeps - ) - ) - ) - ) - ) - ) - ) - - - --- README - - -getReadme : FilePath -> IO (Maybe String) -getReadme dir = - let - readmePath = - dir ++ "/README.md" - in - Utils.dirDoesFileExist readmePath - |> IO.bind - (\exists -> - if exists then - IO.fmap Just (IO.readFile readmePath) - - else - IO.pure Nothing - ) - - - --- GET DIRECTORIES - - -getDirs : FilePath -> List FilePath -> IO (List FilePath) -getDirs pwd contents = - Utils.filterM (Utils.dirDoesDirectoryExist << Utils.fpForwardSlash pwd) contents - - - --- GET FILES - - -getFiles : FilePath -> List FilePath -> IO (List File) -getFiles pwd contents = - Utils.filterM (Utils.dirDoesFileExist << Utils.fpForwardSlash pwd) contents - |> IO.bind - (\paths -> - Utils.mapM (toFile pwd) paths - ) - - -toFile : FilePath -> FilePath -> IO File -toFile pwd path = - if Utils.fpTakeExtension path == ".elm" then - IO.readFile (Utils.fpForwardSlash pwd path) - |> IO.fmap - (\source -> - let - hasMain = - String.contains "\nmain " source - in - File path hasMain - ) - - else - IO.pure (File path False) - - - --- GET OUTLINE - - -getOutline : IO (Maybe Outline.Outline) -getOutline = - Stuff.findRoot - |> IO.bind - (\maybeRoot -> - case maybeRoot of - Nothing -> - IO.pure Nothing - - Just root -> - Outline.read root - |> IO.fmap - (\result -> - case result of - Err _ -> - Nothing - - Ok outline -> - Just outline - ) - ) - - - --- GET EXACT DEPS - - -{-| TODO revamp how `elm reactor` works so that this can go away. -I am trying to "just get it working again" at this point though. --} -getExactDeps : Maybe Outline.Outline -> IO (Dict Pkg.Name V.Version) -getExactDeps maybeOutline = - case maybeOutline of - Nothing -> - IO.pure Dict.empty - - Just outline -> - case outline of - Outline.App _ -> - IO.pure Dict.empty - - Outline.Pkg _ -> - Stuff.findRoot - |> IO.bind - (\maybeRoot -> - case maybeRoot of - Nothing -> - IO.pure Dict.empty - - Just root -> - BW.withScope - (\scope -> - Details.load Reporting.silent scope root - |> IO.fmap - (\result -> - case result of - Err _ -> - Dict.empty - - Ok (Details.Details _ validOutline _ _ _ _) -> - case validOutline of - Details.ValidApp _ -> - Dict.empty - - Details.ValidPkg _ _ solution -> - solution - ) - ) - ) - - - --- ENCODE - - -encode : Flags -> E.Value -encode (Flags root pwd dirs files readme outline exactDeps) = - E.object - [ ( "root", encodeFilePath root ) - , ( "pwd", E.list encodeFilePath pwd ) - , ( "dirs", E.list encodeFilePath dirs ) - , ( "files", E.list encodeFile files ) - , ( "readme", Maybe.maybe E.null E.string readme ) - , ( "outline", Maybe.maybe E.null Outline.encode outline ) - , ( "exactDeps", E.dict Pkg.compareName Pkg.toJsonString V.encode exactDeps ) - ] - - -encodeFilePath : FilePath -> E.Value -encodeFilePath filePath = - E.string filePath - - -encodeFile : File -> E.Value -encodeFile (File path hasMain) = - E.object - [ ( "name", encodeFilePath path ) - , ( "runnable", E.bool hasMain ) - ] diff --git a/src/Terminal/Develop/Socket.elm b/src/Terminal/Develop/Socket.elm deleted file mode 100644 index 44c21584f..000000000 --- a/src/Terminal/Develop/Socket.elm +++ /dev/null @@ -1,40 +0,0 @@ -module Terminal.Develop.Socket exposing (a) - -import Data.IO exposing (IO) - - -a = - 0 - - - ---watchFile : FilePath -> WS.PendingConnection -> IO () ---watchFile watchedFile pendingConnection = --- do connection <- WS.acceptRequest pendingConnection --- --- Notify.withManager <| \mgmt -> --- do stop <- Notify.treeExtAny mgmt "." ".elm" print --- tend connection --- stop --- --- ---tend : WS.Connection -> IO () ---tend connection = --- let --- pinger : Integer -> IO a --- pinger n = --- do threadDelay (5 * 1000 * 1000) --- WS.sendPing connection (BS.pack (show n)) --- pinger (n + 1) --- --- receiver : IO () --- receiver = --- do _ <- WS.receiveDataMessage connection --- receiver --- --- shutdown : SomeException -> IO () --- shutdown _ = --- return () --- in --- do _pid <- forkIO (receiver `catch` shutdown) --- pinger 1 `catch` shutdown diff --git a/src/Terminal/Develop/StaticFiles.elm b/src/Terminal/Develop/StaticFiles.elm deleted file mode 100644 index 5f0bd5f7e..000000000 --- a/src/Terminal/Develop/StaticFiles.elm +++ /dev/null @@ -1,109 +0,0 @@ -module Terminal.Develop.StaticFiles exposing - ( cssPath - , elmPath - , lookup - , waitingPath - ) - -import Data.Map as Dict exposing (Dict) -import Utils.Crash exposing (todo) - - - --- FILE LOOKUP - - -type alias MimeType = - String - - -lookup : String -> Maybe ( String, MimeType ) -lookup path = - Dict.get path dict - - -dict : Dict String ( String, MimeType ) -dict = - -- Dict.fromList - -- [ ( faviconPath, ( favicon, "image/x-icon" ) ) - -- , ( elmPath, ( elm, "application/javascript" ) ) - -- , ( cssPath, ( css, "text/css" ) ) - -- , ( codeFontPath, ( codeFont, "font/ttf" ) ) - -- , ( sansFontPath, ( sansFont, "font/ttf" ) ) - -- ] - todo "dict" - - - --- PATHS - - -faviconPath : String -faviconPath = - "favicon.ico" - - -waitingPath : String -waitingPath = - "_elm/waiting.gif" - - -elmPath : String -elmPath = - "_elm/elm.js" - - -cssPath : String -cssPath = - "_elm/styles.css" - - -codeFontPath : String -codeFontPath = - "_elm/source-code-pro.ttf" - - -sansFontPath : String -sansFontPath = - "_elm/source-sans-pro.ttf" - - - ----- ELM --- --- ---elm : String ---elm = --- bsToExp =<< runIO Build.buildReactorFrontEnd --- --- --- ----- CSS --- --- ---css : String ---css = --- bsToExp =<< runIO (Build.readAsset "styles.css") --- --- --- ----- FONTS --- --- ---codeFont : String ---codeFont = --- bsToExp =<< runIO (Build.readAsset "source-code-pro.ttf") --- --- ---sansFont : String ---sansFont = --- bsToExp =<< runIO (Build.readAsset "source-sans-pro.ttf") --- --- --- ----- IMAGES --- --- ---favicon : String ---favicon = --- bsToExp =<< runIO (Build.readAsset "favicon.ico") diff --git a/src/Terminal/Develop/StaticFiles/Build.elm b/src/Terminal/Develop/StaticFiles/Build.elm deleted file mode 100644 index eb61cb890..000000000 --- a/src/Terminal/Develop/StaticFiles/Build.elm +++ /dev/null @@ -1,77 +0,0 @@ -module Terminal.Develop.StaticFiles.Build exposing - ( buildReactorFrontEnd - , readAsset - ) - -import Builder.BackgroundWriter as BW -import Builder.Build as Build -import Builder.Elm.Details as Details -import Builder.Generate as Generate -import Builder.Reporting as Reporting -import Builder.Reporting.Exit as Exit -import Builder.Reporting.Task as Task -import Compiler.Data.NonEmptyList as NE -import Data.IO as IO exposing (IO) -import Utils.Crash exposing (crash) -import Utils.Main as Utils exposing (FilePath) - - - --- ASSETS - - -readAsset : FilePath -> IO String -readAsset path = - Utils.bsReadFile ("reactor/assets/" ++ path) - - - --- BUILD REACTOR ELM - - -buildReactorFrontEnd : IO String -buildReactorFrontEnd = - BW.withScope - (\scope -> - Utils.dirWithCurrentDirectory "reactor" - (Utils.dirGetCurrentDirectory - |> IO.bind - (\root -> - runTaskUnsafe - (Task.eio Exit.ReactorBadDetails (Details.load Reporting.silent scope root) - |> Task.bind - (\details -> - Task.eio Exit.ReactorBadBuild (Build.fromPaths Reporting.silent root details paths) - |> Task.bind - (\artifacts -> - Task.mapError Exit.ReactorBadGenerate (Generate.prod root details artifacts) - ) - ) - ) - ) - ) - ) - - -paths : NE.Nonempty FilePath -paths = - NE.Nonempty - "src/NotFound.elm" - [ "src/Errors.elm" - , "src/Index.elm" - ] - - -runTaskUnsafe : Task.Task Exit.Reactor a -> IO a -runTaskUnsafe task = - Task.run task - |> IO.bind - (\result -> - case result of - Ok a -> - IO.pure a - - Err exit -> - Exit.toStderr (Exit.reactorToReport exit) - |> IO.fmap (\_ -> crash "\n--------------------------------------------------------\nError in Develop.StaticFiles.Build.buildReactorFrontEnd\nCompile with `elm make` directly to figure it out faster\n--------------------------------------------------------\n") - ) diff --git a/src/Terminal/Diff.elm b/src/Terminal/Diff.elm index 15931a869..4e6ec699a 100644 --- a/src/Terminal/Diff.elm +++ b/src/Terminal/Diff.elm @@ -227,9 +227,11 @@ generateDocs (Env maybeRoot _ _ _) = writeDiff : Docs.Documentation -> Docs.Documentation -> Task () writeDiff oldDocs newDocs = let + changes : PackageChanges changes = DD.diff oldDocs newDocs + localizer : L.Localizer localizer = L.fromNames (Dict.union compare oldDocs newDocs) in @@ -249,14 +251,17 @@ toDoc localizer ((PackageChanges added changed removed) as changes) = else let + magDoc : D.Doc magDoc = D.fromChars (M.toChars (DD.toMagnitude changes)) + header : D.Doc header = D.fromChars "This is a" |> D.plus (D.green magDoc) |> D.plus (D.fromChars "change.") + addedChunk : List Chunk addedChunk = if List.isEmpty added then [] @@ -267,6 +272,7 @@ toDoc localizer ((PackageChanges added changed removed) as changes) = List.map D.fromName added ] + removedChunk : List Chunk removedChunk = if List.isEmpty removed then [] @@ -277,6 +283,7 @@ toDoc localizer ((PackageChanges added changed removed) as changes) = List.map D.fromName removed ] + chunks : List Chunk chunks = addedChunk ++ removedChunk ++ List.map (changesToChunk localizer) (Dict.toList changed) in @@ -290,6 +297,7 @@ type Chunk chunkToDoc : Chunk -> D.Doc chunkToDoc (Chunk title magnitude details) = let + header : D.Doc header = D.fromChars "----" |> D.plus (D.fromChars title) @@ -309,6 +317,7 @@ chunkToDoc (Chunk title magnitude details) = changesToChunk : L.Localizer -> ( Name.Name, ModuleChanges ) -> Chunk changesToChunk localizer ( name, (ModuleChanges unions aliases values binops) as changes ) = let + magnitude : M.Magnitude magnitude = DD.moduleChangeMagnitude changes @@ -337,9 +346,11 @@ changesToChunk localizer ( name, (ModuleChanges unions aliases values binops) as changesToDocTriple : (k -> v -> D.Doc) -> Changes k v -> ( List D.Doc, List D.Doc, List D.Doc ) changesToDocTriple entryToDoc (Changes added changed removed) = let + indented : ( k, v ) -> D.Doc indented ( name, value ) = D.indent 4 (entryToDoc name value) + diffed : ( k, ( v, v ) ) -> D.Doc diffed ( name, ( oldValue, newValue ) ) = D.vcat [ D.fromChars " - " |> D.a (entryToDoc name oldValue) @@ -371,11 +382,13 @@ changesToDoc categoryName unions aliases values binops = unionToDoc : L.Localizer -> Name.Name -> Docs.Union -> D.Doc unionToDoc localizer name (Docs.Union _ tvars ctors) = let + setup : D.Doc setup = D.fromChars "type" |> D.plus (D.fromName name) |> D.plus (D.hsep (List.map D.fromName tvars)) + ctorDoc : ( Name.Name, List Type.Type ) -> D.Doc ctorDoc ( ctor, tipes ) = typeDoc localizer (Type.Type ctor tipes) in @@ -392,6 +405,7 @@ unionToDoc localizer name (Docs.Union _ tvars ctors) = aliasToDoc : L.Localizer -> Name.Name -> Docs.Alias -> D.Doc aliasToDoc localizer name (Docs.Alias _ tvars tipe) = let + declaration : D.Doc declaration = D.plus (D.fromChars "type") (D.plus (D.fromChars "alias") @@ -411,6 +425,7 @@ valueToDoc localizer name (Docs.Value _ tipe) = binopToDoc : L.Localizer -> Name.Name -> Docs.Binop -> D.Doc binopToDoc localizer name (Docs.Binop _ tipe associativity n) = let + details : D.Doc details = D.plus (D.fromChars " (") (D.plus (D.fromName assoc) @@ -421,6 +436,7 @@ binopToDoc localizer name (Docs.Binop _ tipe associativity n) = ) ) + assoc : String assoc = case associativity of Binop.Left -> diff --git a/src/Terminal/Init.elm b/src/Terminal/Init.elm index 5299318b4..8ecb09cb5 100644 --- a/src/Terminal/Init.elm +++ b/src/Terminal/Init.elm @@ -104,12 +104,15 @@ init = Solver.SolverOk details -> let + solution : Dict Pkg.Name V.Version solution = Dict.map (\_ (Solver.Details vsn _) -> vsn) details + directs : Dict Pkg.Name V.Version directs = Dict.intersection solution defaults + indirects : Dict Pkg.Name V.Version indirects = Dict.diff solution defaults in diff --git a/src/Terminal/Install.elm b/src/Terminal/Install.elm index ccb414ed9..e40f4e361 100644 --- a/src/Terminal/Install.elm +++ b/src/Terminal/Install.elm @@ -158,9 +158,11 @@ attemptChanges root env oldOutline toChars changes = Changes changeDict newOutline -> let + widths : Widths widths = Dict.foldr (widen toChars) (Widths 0 0 0) changeDict + changeDocs : ChangeDocs changeDocs = Dict.foldr (addChange toChars widths) (Docs [] [] []) changeDict in @@ -322,9 +324,11 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline nam Ok (Registry.KnownVersions _ _) -> let + old : Dict Pkg.Name C.Constraint old = Dict.union Pkg.compareName deps test + cons : Dict Pkg.Name C.Constraint cons = Dict.insert Pkg.compareName pkg C.anything old in @@ -337,15 +341,19 @@ makePkgPlan (Solver.Env cache _ connection registry) pkg (Outline.PkgOutline nam (Solver.Details vsn _) = Utils.find pkg solution + con : C.Constraint con = C.untilNextMajor vsn + new : Dict Pkg.Name C.Constraint new = Dict.insert Pkg.compareName pkg con old + changes : Dict Pkg.Name (Change C.Constraint) changes = detectChanges old new + news : Dict Pkg.Name C.Constraint news = Utils.mapMapMaybe Pkg.compareName keepNew changes in @@ -531,9 +539,11 @@ type Widths widen : (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths widen toChars pkg change (Widths name left right) = let + toLength : a -> Int toLength a = String.length (toChars a) + newName : Int newName = max name (String.length (Pkg.toChars pkg)) in diff --git a/src/Terminal/Main.elm b/src/Terminal/Main.elm index b13137325..cae862e74 100644 --- a/src/Terminal/Main.elm +++ b/src/Terminal/Main.elm @@ -9,7 +9,6 @@ import Json.Decode as Decode import Json.Encode as Encode import Task import Terminal.Bump as Bump -import Terminal.Develop as Develop import Terminal.Diff as Diff import Terminal.Init as Init import Terminal.Install as Install @@ -50,6 +49,7 @@ addFork portOut maybeFork ( model, cmd ) = Decode.map (\( process, effect, _ ) -> let + nextIndex : Int nextIndex = Array.length model in @@ -491,6 +491,16 @@ effectToCmd index portOut effect = ] } + IO.HFlush (IO.Handle fd) -> + portOut + { index = index + , value = + Encode.object + [ ( "fn", Encode.string "hFlush" ) + , ( "args", Encode.list Encode.int [ fd ] ) + ] + } + IO.WithFile filename mode -> portOut { index = index @@ -603,13 +613,30 @@ effectToCmd index portOut effect = ] } + IO.StatePut value -> + portOut + { index = index + , value = + Encode.object + [ ( "fn", Encode.string "statePut" ) + , ( "args", Encode.list identity [ value ] ) + ] + } + + IO.StateGet -> + portOut + { index = index + , value = + Encode.object + [ ( "fn", Encode.string "stateGet" ) + , ( "args", Encode.list identity [] ) + ] + } + IO.NoOp -> Task.succeed Encode.null |> Task.perform (Msg index) - notImplementedEffect -> - effectToCmd index portOut (IO.Exit ("Effect not implemented: " ++ Debug.toString notImplementedEffect) 254) - step : Encode.Value -> IO.Process -> Result Decode.Error ( IO.Process, IO.Effect, Maybe (IO ()) ) step value (IO.Process decoder) = @@ -626,6 +653,7 @@ main = { init = \() -> let + decoder : Decode.Decoder ( IO.Process, IO.Effect, Maybe (IO ()) ) decoder = start main_ in @@ -682,7 +710,6 @@ main_ = outro [ repl , init - , reactor , make , install , bump @@ -730,12 +757,15 @@ outro = init : Terminal.Command init = let + summary : String summary = "Start an Elm project. It creates a starter elm.json file and provides a link explaining what to do from there." + details : String details = "The `init` command helps start Elm projects:" + example : D.Doc example = reflow "It will ask permission to create an elm.json file, the one thing common to all Elm projects. It also provides a link explaining what to do from there." @@ -764,16 +794,20 @@ init = repl : Terminal.Command repl = let + summary : String summary = "Open up an interactive programming session. Type in Elm expressions like (2 + 2) or (String.length \"test\") and see if they equal four!" + details : String details = "The `repl` command opens up an interactive programming session:" + example : D.Doc example = reflow "Start working through to learn how to use this! It has a whole chapter that uses the REPL for everything, so that is probably the quickest way to get started." + replFlags : Terminal.Flags replFlags = Terminal.flags |> Terminal.more (Terminal.flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs.") @@ -809,64 +843,17 @@ interpreter = --- REACTOR - - -reactor : Terminal.Command -reactor = - let - summary = - "Compile code with a click. It opens a file viewer in your browser, and when you click on an Elm file, it compiles and you see the result." - - details = - "The `reactor` command starts a local server on your computer:" - - example = - reflow - "After running that command, you would have a server at that helps with development. It shows your files like a file viewer. If you click on an Elm file, it will compile it for you! And you can just press the refresh button in the browser to recompile things." - - reactorFlags = - Terminal.flags - |> Terminal.more (Terminal.flag "port" port_ "The port of the server (default: 8000)") - in - Terminal.Command "reactor" (Terminal.Common summary) details example Terminal.noArgs reactorFlags <| - \chunks -> - Chomp.chomp Nothing - chunks - [ Chomp.chompExactly (Chomp.pure ()) - ] - (Chomp.pure Develop.Flags - |> Chomp.apply (Chomp.chompNormalFlag "port" port_ String.toInt) - |> Chomp.bind - (\value -> - Chomp.checkForUnknownFlags reactorFlags - |> Chomp.fmap (\_ -> value) - ) - ) - |> Tuple.second - |> Result.map (\( args, flags ) -> Develop.run args flags) - - -port_ : Terminal.Parser -port_ = - Terminal.Parser - { singular = "port" - , plural = "ports" - , suggest = \_ -> IO.pure [] - , examples = \_ -> IO.pure [ "3000", "8000" ] - } - - - -- MAKE make : Terminal.Command make = let + details : String details = "The `make` command compiles Elm code into JS or HTML:" + example : D.Doc example = stack [ reflow "For example:" @@ -874,6 +861,7 @@ make = , reflow "This tries to compile an Elm file named src/Main.elm, generating an index.html file if possible." ] + makeFlags : Terminal.Flags makeFlags = Terminal.flags |> Terminal.more (Terminal.onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!") @@ -911,9 +899,11 @@ make = install : Terminal.Command install = let + details : String details = "The `install` command fetches packages from for use in your project:" + example : D.Doc example = stack [ reflow @@ -930,6 +920,7 @@ install = "What if two projects use different versions of the same package? No problem! Each project is independent, so there cannot be conflicts like that!" ] + installArgs : Terminal.Args installArgs = Terminal.oneOf [ Terminal.require0 @@ -968,9 +959,11 @@ install = publish : Terminal.Command publish = let + details : String details = "The `publish` command publishes your package on so that anyone in the Elm community can use it." + example : D.Doc example = stack [ reflow @@ -1007,9 +1000,11 @@ publish = bump : Terminal.Command bump = let + details : String details = "The `bump` command figures out the next version number based on API changes:" + example : D.Doc example = reflow "Say you just published version 1.0.0, but then decided to remove a function. I will compare the published API to what you have locally, figure out that it is a MAJOR change, and bump your version number to 2.0.0. I do this with all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!" @@ -1038,9 +1033,11 @@ bump = diff : Terminal.Command diff = let + details : String details = "The `diff` command detects API changes:" + example : D.Doc example = stack [ reflow @@ -1050,6 +1047,7 @@ diff = "Sometimes a MAJOR change is not actually very big, so this can help you plan your upgrade timelines." ] + diffArgs : Terminal.Args diffArgs = Terminal.oneOf [ Terminal.require0 diff --git a/src/Terminal/Make.elm b/src/Terminal/Make.elm index a2b942ab7..6a6e0e0ef 100644 --- a/src/Terminal/Make.elm +++ b/src/Terminal/Make.elm @@ -203,6 +203,7 @@ getExposed (Details.Details _ validOutline _ _ _ _) = buildExposed : Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.Nonempty ModuleName.Raw -> Task () buildExposed style root details maybeDocs exposed = let + docsGoal : Build.DocsGoal () docsGoal = Maybe.maybe Build.ignoreDocs Build.writeDocs maybeDocs in diff --git a/src/Terminal/Publish.elm b/src/Terminal/Publish.elm index 7ac09f5a9..ac912675d 100644 --- a/src/Terminal/Publish.elm +++ b/src/Terminal/Publish.elm @@ -87,6 +87,7 @@ publish ((Env root _ manager registry outline) as env) = Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) -> let + maybeKnownVersions : Maybe Registry.KnownVersions maybeKnownVersions = Registry.getVersions pkg registry in @@ -161,6 +162,7 @@ noExposed exposed = verifyReadme : String -> Task.Task Exit.Publish () verifyReadme root = let + readmePath : String readmePath = root ++ "/README.md" in @@ -192,6 +194,7 @@ verifyReadme root = verifyLicense : String -> Task.Task Exit.Publish () verifyLicense root = let + licensePath : String licensePath = root ++ "/LICENSE" in @@ -263,6 +266,7 @@ getGit = Git (\args -> let + process : { cmdspec : IO.CmdSpec, std_in : IO.StdStream, std_out : IO.StdStream, std_err : IO.StdStream } process = IO.procProc git args |> (\cp -> @@ -298,6 +302,7 @@ verifyTag (Git run_) manager pkg vsn = IO.ExitSuccess -> let + url : String url = toTagUrl pkg vsn in @@ -353,6 +358,7 @@ verifyZip (Env root _ manager _ _) pkg vsn = withPrepublishDir root <| \prepublishDir -> let + url : String url = toZipUrl pkg vsn in @@ -384,6 +390,7 @@ toZipUrl pkg vsn = withPrepublishDir : String -> (String -> Task.Task x a) -> Task.Task x a withPrepublishDir root callback = let + dir : String dir = Stuff.prepublishDir root in @@ -470,9 +477,11 @@ verifyBump (Env _ cache manager _ _) pkg vsn newDocs ((Registry.KnownVersions la Ok oldDocs -> let + changes : Diff.PackageChanges changes = Diff.diff oldDocs newDocs + realNew : V.Version realNew = Diff.bump changes old in @@ -492,6 +501,7 @@ verifyBump (Env _ cache manager _ _) pkg vsn newDocs ((Registry.KnownVersions la register : Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task.Task Exit.Publish () register manager pkg vsn docs commitHash sha = let + url : String url = Website.route "/register" [ ( "name", Pkg.toChars pkg ) @@ -555,15 +565,19 @@ reportBuildCheck = reportSemverCheck : V.Version -> IO (Result x GoodVersion) -> Task.Task x () reportSemverCheck version work = let + vsn : String vsn = V.toChars version + waiting : String waiting = "Checking semantic versioning rules. Is " ++ vsn ++ " correct?" + failure : String failure = "Version " ++ vsn ++ " is not correct!" + success : GoodVersion -> String success result = case result of GoodStart -> @@ -623,9 +637,11 @@ reportCheck waiting success failure work = reportCustomCheck : String -> (a -> String) -> String -> IO (Result x a) -> Task.Task x a reportCustomCheck waiting success failure work = let + putFlush : D.Doc -> IO () putFlush doc = - Help.toStdout doc |> IO.fmap (\_ -> IO.hFlush IO.stdout) + Help.toStdout doc |> IO.bind (\_ -> IO.hFlush IO.stdout) + padded : String -> String padded message = message ++ String.repeat (String.length waiting - String.length message) " " in diff --git a/src/Terminal/Repl.elm b/src/Terminal/Repl.elm index 14dfe4cac..ebb53cf86 100644 --- a/src/Terminal/Repl.elm +++ b/src/Terminal/Repl.elm @@ -6,9 +6,7 @@ module Terminal.Repl exposing , Output(..) , Prefill(..) , State(..) - , categorize , run - , toByteString ) import Builder.BackgroundWriter as BW @@ -87,13 +85,16 @@ run () flags = printWelcomeMessage : IO () printWelcomeMessage = let + vsn : String vsn = V.toChars V.compiler + title : D.Doc title = D.fromChars "Elm" |> D.plus (D.fromChars vsn) + dashes : String dashes = String.repeat (70 - String.length vsn) "-" in @@ -190,6 +191,7 @@ read = Just chars -> let + lines : Lines lines = Lines (stripLegacyBackslash chars) [] in @@ -213,6 +215,7 @@ readMore previousLines prefill = Just chars -> let + lines : Lines lines = addLine (stripLegacyBackslash chars) previousLines in @@ -332,9 +335,11 @@ categorize lines = attemptImport : Lines -> CategorizedInput attemptImport lines = let + src : String src = linesToByteString lines + parser : P.Parser () Src.Import parser = P.specialize (\_ _ _ -> ()) PM.chompImport in @@ -367,12 +372,11 @@ ifDone lines input = attemptDeclOrExpr : Lines -> CategorizedInput attemptDeclOrExpr lines = let + src : String src = linesToByteString lines - exprParser = - P.specialize (toExprPosition src) PE.expression - + declParser : P.Parser ( Row, Col ) ( PD.Decl, A.Position ) declParser = P.specialize (toDeclPosition src) PD.declaration in @@ -399,6 +403,11 @@ attemptDeclOrExpr lines = Done Port else + let + exprParser : P.Parser ( Row, Col ) ( Src.Expr, A.Position ) + exprParser = + P.specialize (toExprPosition src) PE.expression + in case P.fromByteString exprParser Tuple.pair src of Ok _ -> ifDone lines (Expr src) @@ -448,6 +457,7 @@ toCommand lines = startsWithKeyword : String -> Lines -> Bool startsWithKeyword keyword lines = let + line : String line = getFirstLine lines in @@ -464,6 +474,7 @@ startsWithKeyword keyword lines = toExprPosition : String -> ES.Expr -> Row -> Col -> ( Row, Col ) toExprPosition src expr row col = let + decl : ES.Decl decl = ES.DeclDef N.replValueToPrint (ES.DeclDefBody expr row col) row col in @@ -473,9 +484,11 @@ toExprPosition src expr row col = toDeclPosition : String -> ES.Decl -> Row -> Col -> ( Row, Col ) toDeclPosition src decl r c = let + err : ES.Error err = ES.ParseError (ES.Declarations decl r c) + report : Report.Report report = ES.toReport (Code.toSource src) err @@ -488,9 +501,11 @@ toDeclPosition src decl r c = annotation : P.Parser () N.Name annotation = let + err : Row -> Col -> () err _ _ = () + err_ : x -> Row -> Col -> () err_ _ _ _ = () in @@ -501,7 +516,7 @@ annotation = |> P.bind (\_ -> P.word1 ':' err) |> P.bind (\_ -> PS.chompAndCheckIndent err_ err) |> P.bind (\_ -> P.specialize err_ PT.expression) - |> P.bind (\( _, _ ) -> PS.checkFreshLine err) + |> P.bind (\_ -> PS.checkFreshLine err) |> P.fmap (\_ -> name) ) @@ -543,6 +558,7 @@ eval env ((State imports types decls) as state) input = Import name src -> let + newState : State newState = State (Dict.insert compare name src imports) types decls in @@ -550,6 +566,7 @@ eval env ((State imports types decls) as state) input = Type name src -> let + newState : State newState = State imports (Dict.insert compare name src types) decls in @@ -561,6 +578,7 @@ eval env ((State imports types decls) as state) input = Decl name src -> let + newState : State newState = State imports types (Dict.insert compare name src decls) in @@ -627,6 +645,7 @@ attemptEval (Env root interpreter ansi) oldState newState output = interpret : FilePath -> String -> IO IO.ExitCode interpret interpreter javascript = let + createProcess : { cmdspec : IO.CmdSpec, std_out : IO.StdStream, std_err : IO.StdStream, std_in : IO.StdStream } createProcess = IO.procProc interpreter [] |> (\cp -> { cp | std_in = IO.CreatePipe }) @@ -730,6 +749,7 @@ getRoot = |> IO.bind (\cache -> let + root : String root = cache ++ "/tmp" in @@ -855,6 +875,7 @@ addMatches string isFinished dict completions = addMatch : String -> Bool -> N.Name -> v -> List Utils.ReplCompletion -> List Utils.ReplCompletion addMatch string isFinished name _ completions = let + suggestion : String suggestion = String.fromList (N.toChars name) in diff --git a/src/Terminal/Terminal.elm b/src/Terminal/Terminal.elm index ac33552fe..02538ce41 100644 --- a/src/Terminal/Terminal.elm +++ b/src/Terminal/Terminal.elm @@ -1,7 +1,5 @@ module Terminal.Terminal exposing ( app - , args - , exactly , flag , flags , more @@ -20,9 +18,8 @@ import Compiler.Elm.Version as V import Compiler.Reporting.Doc as D import Data.IO as IO exposing (IO) import List.Extra as List -import Prelude import Terminal.Terminal.Error as Error -import Terminal.Terminal.Internal exposing (Args(..), Command(..), CompleteArgs(..), Flag(..), Flags(..), Parser(..), RequiredArgs(..), Summary(..), toName) +import Terminal.Terminal.Internal exposing (Args(..), Command(..), CompleteArgs(..), Flag(..), Flags(..), Parser, RequiredArgs(..), toName) import Utils.Main as Utils @@ -66,80 +63,6 @@ app intro outro commands = --- AUTO-COMPLETE - - -getCompIndex : String -> IO ( Int, List String ) -getCompIndex line = - Utils.envLookupEnv "COMP_POINT" - |> IO.bind - (\maybePoint -> - case Maybe.andThen String.toInt maybePoint of - Nothing -> - let - chunks = - String.words line - in - IO.pure ( List.length chunks, chunks ) - - Just point -> - let - lineChars = - String.toList line - - lineIndexes = - List.repeat (String.length line) () - |> List.indexedMap (\i _ -> i) - - groups = - Utils.listGroupBy grouper - (List.zip lineChars lineIndexes) - - rawChunks = - List.drop 1 (List.filter (List.all (not << isSpace << Tuple.first)) groups) - in - IO.pure - ( findIndex 1 point rawChunks - , List.map (String.fromList << List.map Tuple.first) rawChunks - ) - ) - - -grouper : ( Char, Int ) -> ( Char, Int ) -> Bool -grouper ( c1, _ ) ( c2, _ ) = - isSpace c1 == isSpace c2 - - -isSpace : Char -> Bool -isSpace char = - char == ' ' || char == '\t' || char == '\n' - - -findIndex : Int -> Int -> List (List ( Char, Int )) -> Int -findIndex index point chunks = - case chunks of - [] -> - index - - chunk :: cs -> - let - lo = - Tuple.second (Prelude.head chunk) - - hi = - Tuple.second (Prelude.last chunk) - in - if point < lo then - 0 - - else if point <= hi + 1 then - index - - else - findIndex (index + 1) point cs - - - -- FLAGS diff --git a/src/Terminal/Terminal/Chomp.elm b/src/Terminal/Terminal/Chomp.elm index fb4d9d85d..37682b749 100644 --- a/src/Terminal/Terminal/Chomp.elm +++ b/src/Terminal/Terminal/Chomp.elm @@ -1,5 +1,8 @@ module Terminal.Terminal.Chomp exposing - ( apply + ( Chomper + , Chunk + , Suggest + , apply , bind , checkForUnknownFlags , chomp @@ -15,8 +18,7 @@ module Terminal.Terminal.Chomp exposing import Basics.Extra exposing (flip) import Data.IO as IO exposing (IO) import Data.Maybe as Maybe -import Terminal.Terminal.Internal exposing (ArgError(..), Args(..), CompleteArgs(..), Error(..), Expectation(..), Flag(..), FlagError(..), Flags(..), Parser(..), RequiredArgs(..)) -import Utils.Crash exposing (todo) +import Terminal.Terminal.Internal exposing (ArgError(..), Error(..), Expectation(..), Flag(..), FlagError(..), Flags(..), Parser(..)) @@ -146,23 +148,6 @@ addSuggest everything suggest = -- COMPLETE ARGS -chompCompleteArgs : Suggest -> List Chunk -> CompleteArgs -> (String -> Maybe a) -> ( Suggest, Result ArgError a ) -chompCompleteArgs suggest chunks completeArgs parserFn = - let - numChunks = - List.length chunks - in - case completeArgs of - Exactly requiredArgs -> - chompExactly (chompRequiredArgs numChunks requiredArgs) suggest chunks - - Optional requiredArgs parser -> - chompOptional (chompRequiredArgs numChunks requiredArgs) parser parserFn suggest chunks - - Multiple requiredArgs parser -> - chompMultiple (chompRequiredArgs numChunks requiredArgs) parser parserFn suggest chunks - - chompExactly : Chomper ArgError a -> Suggest -> List Chunk -> ( Suggest, Result ArgError a ) chompExactly (Chomper chomper) suggest chunks = case chomper suggest chunks of @@ -178,31 +163,6 @@ chompExactly (Chomper chomper) suggest chunks = ( s, Err argError ) -chompOptional : Chomper ArgError (Maybe a -> b) -> Parser -> (String -> Maybe a) -> Suggest -> List Chunk -> ( Suggest, Result ArgError b ) -chompOptional (Chomper chomper) parser parserFn suggest chunks = - case chomper suggest chunks of - ChomperOk s1 cs func -> - case cs of - [] -> - ( s1, Ok (func Nothing) ) - - (Chunk index string) :: others -> - case tryToParse s1 parser parserFn index string of - ( s2, Err expectation ) -> - ( s2, Err (ArgBad string expectation) ) - - ( s2, Ok value ) -> - case List.map (\(Chunk _ chunk) -> chunk) others of - [] -> - ( s2, Ok (func (Just value)) ) - - es -> - ( s2, Err (ArgExtras es) ) - - ChomperErr s1 argError -> - ( s1, Err argError ) - - chompMultiple : Chomper ArgError (List a -> b) -> Parser -> (String -> Maybe a) -> Suggest -> List Chunk -> ( Suggest, Result ArgError b ) chompMultiple (Chomper chomper) parser parserFn suggest chunks = case chomper suggest chunks of @@ -232,21 +192,6 @@ chompMultipleHelp parser parserFn revArgs suggest chunks func = -- REQUIRED ARGS -chompRequiredArgs : Int -> RequiredArgs -> Chomper ArgError a -chompRequiredArgs numChunks args = - -- case args of - -- Done value -> - -- pure value - -- Required funcArgs argParser -> - -- chompRequiredArgs numChunks funcArgs - -- |> bind - -- (\func -> - -- chompArg numChunks argParser - -- |> fmap (\arg -> func arg) - -- ) - todo ("chompRequiredArgs: " ++ Debug.toString ( numChunks, args )) - - chompArg : Int -> Parser -> (String -> Maybe a) -> Chomper ArgError a chompArg numChunks ((Parser { singular, examples }) as parser) parserFn = Chomper <| @@ -254,9 +199,11 @@ chompArg numChunks ((Parser { singular, examples }) as parser) parserFn = case chunks of [] -> let + newSuggest : Suggest newSuggest = makeSuggestion suggest (suggestArg parser numChunks) + theError : ArgError theError = ArgMissing (Expectation singular (examples "")) in @@ -287,6 +234,7 @@ suggestArg (Parser { suggest }) numChunks targetIndex = tryToParse : Suggest -> Parser -> (String -> Maybe a) -> Int -> String -> ( Suggest, Result Expectation a ) tryToParse suggest (Parser parser) parserFn index string = let + newSuggest : Suggest newSuggest = makeSuggestion suggest <| \targetIndex -> @@ -296,6 +244,7 @@ tryToParse suggest (Parser parser) parserFn index string = else Nothing + outcome : Result Expectation a outcome = case parserFn string of Nothing -> @@ -308,48 +257,9 @@ tryToParse suggest (Parser parser) parserFn index string = --- FLAGS - - -chompFlags : Flags -> Chomper FlagError a -chompFlags flags = - chompFlagsHelp flags - |> bind - (\value -> - checkForUnknownFlags flags - |> fmap (\_ -> value) - ) - - -chompFlagsHelp : Flags -> Chomper FlagError a -chompFlagsHelp flags = - -- case flags of - -- FDone value -> - -- pure value - -- FMore funcFlags argFlag -> - -- chompFlagsHelp funcFlags - -- |> bind - -- (\func -> - -- chompFlag argFlag - -- |> fmap (\arg -> func arg) - -- ) - todo "chompFlagsHelp" - - - -- FLAG -chompFlag : Flag -> Chomper FlagError a -chompFlag flag = - -- case flag of - -- OnOff flagName _ -> - -- chompOnOffFlag flagName - -- Flag flagName parser _ -> - -- chompNormalFlag flagName parser - todo "chompFlag" - - chompOnOffFlag : String -> Chomper FlagError Bool chompOnOffFlag flagName = Chomper <| @@ -380,6 +290,7 @@ chompNormalFlag flagName ((Parser { singular, examples }) as parser) parserFn = Just (FoundFlag before value after) -> let + attempt : Int -> String -> ChomperResult FlagError (Maybe a) attempt index string = case tryToParse suggest parser parserFn index string of ( newSuggest, Err expectation ) -> @@ -421,9 +332,11 @@ findFlag flagName chunks = findFlagHelp : List Chunk -> String -> String -> List Chunk -> Maybe FoundFlag findFlagHelp revPrev loneFlag flagPrefix chunks = let + succeed : Value -> List Chunk -> Maybe FoundFlag succeed value after = Just (FoundFlag (List.reverse revPrev) value after) + deprefix : String -> String deprefix string = String.dropLeft (String.length flagPrefix) string in @@ -536,6 +449,7 @@ apply (Chomper argChomper) (Chomper funcChomper) = Chomper <| \s cs -> let + ok1 : Suggest -> List Chunk -> (a -> b) -> ChomperResult x b ok1 s1 cs1 func = case argChomper s1 cs1 of ChomperOk s2 cs2 value -> diff --git a/src/Terminal/Terminal/Error.elm b/src/Terminal/Terminal/Error.elm index b8780f6b3..d5d97fada 100644 --- a/src/Terminal/Terminal/Error.elm +++ b/src/Terminal/Terminal/Error.elm @@ -131,9 +131,6 @@ argsToDoc command args = Multiple required (Parser { plural }) -> argsToDocHelp command required [ "zero or more " ++ plural ] - Optional required (Parser { singular }) -> - argsToDocHelp command required [ "optional " ++ singular ] - argsToDocHelp : String -> RequiredArgs -> List String -> P.Doc argsToDocHelp command args names = @@ -171,6 +168,7 @@ flagsToDocs flags docs = FMore more flag -> let + flagDoc : P.Doc flagDoc = P.vcat <| case flag of @@ -225,12 +223,15 @@ toSummary exeName (Command name summary _ _ (Args args) _ _) = toCommandList : String -> List Command -> P.Doc toCommandList exeName commands = let + names : List String names = List.map toName commands + width : Int width = Utils.listMaximum compare (List.map String.length names) + toExample : String -> P.Doc toExample name = P.text (exeName @@ -250,9 +251,11 @@ toCommandList exeName commands = exitWithUnknown : String -> List String -> IO a exitWithUnknown unknown knowns = let + nearbyKnowns : List ( Int, String ) nearbyKnowns = List.takeWhile (\( r, _ ) -> r <= 3) (Suggest.rank unknown identity knowns) + suggestions : List P.Doc suggestions = case List.map toGreen (List.map Tuple.second nearbyKnowns) of [] -> @@ -508,6 +511,7 @@ flagErrorToDocs flagError = flagErrorHelp "I do not recognize this flag:" unknown (let + unknownName : String unknownName = List.takeWhile ((/=) '=') (List.dropWhile ((==) '-') (String.toList unknown)) |> String.fromList diff --git a/src/Terminal/Terminal/Helpers.elm b/src/Terminal/Terminal/Helpers.elm index c4e2b2c0e..97ffeb451 100644 --- a/src/Terminal/Terminal/Helpers.elm +++ b/src/Terminal/Terminal/Helpers.elm @@ -51,9 +51,11 @@ suggestVersion _ = exampleVersions : String -> List String exampleVersions chars = let + chunks : List String chunks = String.split "." chars + isNumber : String -> Bool isNumber cs = not (String.isEmpty cs) && String.all Char.isDigit cs in diff --git a/src/Terminal/Terminal/Internal.elm b/src/Terminal/Terminal/Internal.elm index 2e73514b7..b45ac488d 100644 --- a/src/Terminal/Terminal/Internal.elm +++ b/src/Terminal/Terminal/Internal.elm @@ -81,7 +81,6 @@ type Args type CompleteArgs = Exactly RequiredArgs | Multiple RequiredArgs Parser - | Optional RequiredArgs Parser type RequiredArgs diff --git a/src/Text/PrettyPrint/ANSI/Leijen.elm b/src/Text/PrettyPrint/ANSI/Leijen.elm index 425e96baa..a62e24ade 100644 --- a/src/Text/PrettyPrint/ANSI/Leijen.elm +++ b/src/Text/PrettyPrint/ANSI/Leijen.elm @@ -10,7 +10,6 @@ module Text.PrettyPrint.ANSI.Leijen exposing , blue , cat , cyan - , defaultStyle , displayIO , displayS , dullcyan @@ -32,8 +31,6 @@ module Text.PrettyPrint.ANSI.Leijen exposing , sep , text , underline - , updateColor - , updateStyle , vcat , yellow ) @@ -42,7 +39,6 @@ import Data.IO as IO exposing (IO) import Pretty as P import Pretty.Renderer as PR import System.Console.Ansi as Ansi -import Utils.Crash exposing (todo) type alias Doc = @@ -50,10 +46,8 @@ type alias Doc = type SimpleDoc - = SFail - | SEmpty - | SChar Char SimpleDoc - | SText Int String SimpleDoc + = SEmpty + | SText String SimpleDoc | SLine Int SimpleDoc | SSGR (List Ansi.SGR) SimpleDoc @@ -69,10 +63,11 @@ renderPretty _ w doc = { init = { styled = False, newline = False, list = [] } , tagged = \style str acc -> - { acc | styled = True, list = SText (String.length str) str :: SSGR (styleToSgrs style) :: acc.list } + { acc | styled = True, list = SText str :: SSGR (styleToSgrs style) :: acc.list } , untagged = \str acc -> let + newAcc : { styled : Bool, newline : Bool, list : List (SimpleDoc -> SimpleDoc) } newAcc = if acc.styled then { acc | styled = False, list = SSGR [ Ansi.Reset ] :: acc.list } @@ -84,7 +79,7 @@ renderPretty _ w doc = { newAcc | newline = False, list = SLine (String.length str) :: newAcc.list } else - { newAcc | list = SText (String.length str) str :: newAcc.list } + { newAcc | list = SText str :: newAcc.list } , newline = \acc -> { acc | newline = True } , outer = \{ list } -> List.foldl (<|) SEmpty list } @@ -144,16 +139,10 @@ styleToSgrs style = displayS : SimpleDoc -> String -> String displayS simpleDoc acc = case simpleDoc of - SFail -> - todo "SFail" - SEmpty -> acc - SChar char sd -> - displayS sd (acc ++ String.fromChar char) - - SText _ str sd -> + SText str sd -> displayS sd (acc ++ str) SLine n sd -> diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 854b6ca12..e5c453973 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -1,13 +1,13 @@ module Utils.Main exposing ( AsyncException(..) + , ChItem , Chan , FilePath , HTTPResponse(..) - , HttpServerConfig - , HttpServerSnap , LockSharedExclusive(..) , MVar(..) , ReplCompletion(..) + , ReplCompletionFunc , ReplInputT , ReplSettings(..) , SomeException(..) @@ -17,11 +17,7 @@ module Utils.Main exposing , binaryDecodeFileOrFail , binaryEncodeFile , bracket_ - , bsHPut - , bsReadFile , builderHPutBuilder - , chItemDecoder - , defaultHttpServerConfig , dictMapM_ , dirCanonicalizePath , dirCreateDirectoryIfMissing @@ -30,7 +26,6 @@ module Utils.Main exposing , dirFindExecutable , dirGetAppUserDataDirectory , dirGetCurrentDirectory - , dirGetDirectoryContents , dirGetModificationTime , dirRemoveDirectoryRecursive , dirRemoveFile @@ -44,10 +39,8 @@ module Utils.Main exposing , filterM , find , foldM - , foldl1 , foldl1_ , foldr1 - , forMArray , forM_ , forkIO , fpAddExtension @@ -67,7 +60,6 @@ module Utils.Main exposing , fromException , httpResponseDecoder , httpResponseEncoder - , httpServe , indexedForA , indexedTraverse , indexedZipWithA @@ -125,8 +117,6 @@ module Utils.Main exposing , replRunInputT , replWithInterrupt , sequenceADict - , sequenceAList - , sequenceAListIO , sequenceDictMaybe , sequenceDictResult , sequenceDictResult_ @@ -150,13 +140,12 @@ module Utils.Main exposing , zipZEntries ) -import Array exposing (Array) import Basics.Extra exposing (flip) import Builder.Reporting.Task as Task exposing (Task) import Compiler.Data.Index as Index import Compiler.Data.NonEmptyList as NE import Compiler.Reporting.Result as R -import Data.IO as IO exposing (IO(..), IORef(..)) +import Data.IO as IO exposing (IO(..)) import Data.Map as Dict exposing (Dict) import Data.Set as EverySet exposing (EverySet) import Json.Decode as Decode @@ -177,11 +166,6 @@ liftIOInputT = identity -bsHPut : IO.Handle -> String -> IO () -bsHPut handle str = - IO.make (Decode.succeed ()) (IO.HPutStr handle str) - - fpDropFileName : FilePath -> FilePath fpDropFileName path = case List.reverse (String.split "/" path) of @@ -275,7 +259,7 @@ find k items = item Nothing -> - crash ("Map.!: given key is not an element in the map (key:`" ++ Debug.toString k ++ "`, keys: `" ++ Debug.toString (Dict.keys items) ++ "`)") + crash "Map.!: given key is not an element in the map" mapLookupMin : Dict comparable a -> Maybe ( comparable, a ) @@ -417,6 +401,7 @@ keysSet keyComparison = unzip3 : List ( a, b, c ) -> ( List a, List b, List c ) unzip3 pairs = let + step : ( a, b, c ) -> ( List a, List b, List c ) -> ( List a, List b, List c ) step ( x, y, z ) ( xs, ys, zs ) = ( x :: xs, y :: ys, z :: zs ) in @@ -426,6 +411,7 @@ unzip3 pairs = mapM_ : (a -> IO b) -> List a -> IO () mapM_ f = let + c : a -> IO () -> IO () c x k = IO.bind (\_ -> k) (f x) in @@ -435,6 +421,7 @@ mapM_ f = dictMapM_ : (a -> IO b) -> Dict k a -> IO () dictMapM_ f = let + c : k -> a -> IO () -> IO () c _ x k = IO.bind (\_ -> k) (f x) in @@ -451,11 +438,6 @@ maybeMapM = listMaybeTraverse -mapMArray : (a -> IO b) -> Array a -> IO (Array b) -mapMArray = - arrayTraverse - - mapMinViewWithKey : (k -> k -> Order) -> (( k, a ) -> comparable) -> Dict k a -> Maybe ( ( k, a ), Dict k a ) mapMinViewWithKey keyComparison compare dict = case List.sortBy compare (Dict.toList dict) of @@ -473,11 +455,6 @@ mapMapMaybe keyComparison func = >> Dict.fromList keyComparison -forMArray : Array a -> (a -> IO b) -> IO (Array b) -forMArray array f = - mapMArray f array - - forM_ : List a -> (a -> IO b) -> IO () forM_ list f = mapM_ f list @@ -547,12 +524,6 @@ listTraverseStateT f = (IO.pureStateT []) -arrayTraverse : (a -> IO b) -> Array a -> IO (Array b) -arrayTraverse f = - Array.foldl (\a -> IO.bind (\c -> IO.fmap (\va -> Array.push va c) (f a))) - (IO.pure Array.empty) - - tupleTraverse : (b -> IO c) -> ( a, b ) -> IO ( a, c ) tupleTraverse f ( a, b ) = IO.fmap (Tuple.pair a) (f b) @@ -650,6 +621,7 @@ listLookup key list = foldl1 : (a -> a -> a) -> List a -> a foldl1 f xs = let + mf : a -> Maybe a -> Maybe a mf x m = Just (case m of @@ -676,6 +648,7 @@ foldl1_ f = foldr1 : (a -> a -> a) -> List a -> a foldr1 f xs = let + mf : a -> Maybe a -> Maybe a mf x m = Just (case m of @@ -825,16 +798,12 @@ fpTakeDirectory filename = type LockSharedExclusive - = LockShared - | LockExclusive + = LockExclusive lockWithFileLock : String -> LockSharedExclusive -> (() -> IO a) -> IO a lockWithFileLock path mode ioFunc = case mode of - LockShared -> - crash "lockWithFileLock for `LockShared` is not implemeted!" - LockExclusive -> lockFile path |> IO.bind ioFunc @@ -909,11 +878,6 @@ dirCanonicalizePath path = IO.make Decode.string (IO.DirCanonicalizePath path) -dirGetDirectoryContents : FilePath -> IO (List FilePath) -dirGetDirectoryContents _ = - todo "dirGetDirectoryContents" - - dirWithCurrentDirectory : FilePath -> IO a -> IO a dirWithCurrentDirectory dir action = dirGetCurrentDirectory @@ -1186,15 +1150,6 @@ exitSuccess = --- Data.ByteString - - -bsReadFile : String -> IO String -bsReadFile _ = - todo "bsReadFile" - - - -- Data.ByteString.Builder @@ -1285,6 +1240,7 @@ replGetInputLineWithInitial prompt ( left, right ) = stateGet : Decode.Decoder s -> IO.StateT s s stateGet decoder = let + io : IO s io = IO.make decoder IO.StateGet in @@ -1293,7 +1249,7 @@ stateGet decoder = statePut : (s -> Encode.Value) -> s -> IO () statePut encoder s = - IO.pure () + IO.make (Decode.succeed ()) (IO.StatePut (encoder s)) @@ -1342,76 +1298,3 @@ httpResponseEncoder _ = httpResponseDecoder : Decode.Decoder (HTTPResponse a) httpResponseDecoder = Decode.succeed HTTPResponse - - - --- Snap.Http.Server - - -type HttpServerProxyType - = HttpServerNoProxy - | HttpServerHaProxy - | HttpServerX_Forwarded_For - - -type HttpServerConfigLog - = HttpServerConfigNoLog - | HttpServerConfigFileLog FilePath - | HttpServerConfigIoLog (String -> IO ()) - - -type alias HttpServerConfig = - { hostname : Maybe String - , accessLog : Maybe HttpServerConfigLog - , errorLog : Maybe HttpServerConfigLog - , locale : Maybe String - , port_ : Maybe Int - , bind : Maybe String - - -- , sslport : Maybe Int - , sslbind : Maybe String - , sslcert : Maybe FilePath - , sslchaincert : Maybe Bool - , sslkey : Maybe FilePath - - -- , unixsocket : Maybe FilePath - -- , unixaccessmode : Maybe Int - , compression : Maybe Bool - , verbose : Maybe Bool - - -- , errorHandler : Maybe (SomeException -> HttpServerSnap ()) - , defaultTimeout : Maybe Int - - -- , other : Maybe a - -- , proxyType : Maybe HttpServerProxyType - -- , startupHook : Maybe (StartupInfo a -> IO ()) - } - - -defaultHttpServerConfig : HttpServerConfig -defaultHttpServerConfig = - { hostname = Just "localhost" - , accessLog = Just <| HttpServerConfigFileLog "log/access.log" - , errorLog = Just <| HttpServerConfigFileLog "log/error.log" - , locale = Just "en_US" - , port_ = Nothing - , compression = Just True - , verbose = Just True - - -- , errorHandler = Just defaultErrorHandler - , bind = Just "0.0.0.0" - , sslbind = Nothing - , sslcert = Nothing - , sslkey = Nothing - , sslchaincert = Nothing - , defaultTimeout = Just 60 - } - - -type HttpServerSnap a - = HttpServerSnap - - -httpServe : HttpServerConfig -> HttpServerSnap () -> IO () -httpServe _ _ = - IO.pure ()