├── .gitignore ├── .gitlab-ci.yml ├── LICENSE ├── Makefile ├── README.md ├── elm.json ├── example ├── apps │ └── TodoApp │ │ ├── Actor │ │ ├── TodoItem.elm │ │ ├── TodoList.elm │ │ └── TodoService.elm │ │ ├── ActorName.elm │ │ ├── Bootstrap.elm │ │ ├── Component │ │ ├── TodoItem.elm │ │ ├── TodoList.elm │ │ └── TodoService.elm │ │ ├── Main.elm │ │ └── Msg.elm ├── assert │ ├── AssertExample1.elm │ └── AssertExample1Sandbox.elm ├── elm.json └── snippets │ ├── ElmUI │ ├── LayoutComponent.elm │ ├── LayoutComponentSandbox.elm │ ├── UIComponent.elm │ └── UIComponentSandbox.elm │ ├── Html │ ├── LayoutComponent.elm │ ├── LayoutComponentSandbox.elm │ ├── UIComponent.elm │ └── UIComponentSandbox.elm │ ├── ServiceComponent.elm │ └── ServiceComponentSandbox.elm └── src └── Webbhuset ├── Actor.elm ├── ActorSystem.elm ├── Component.elm ├── Component ├── Sandbox.elm ├── Sandbox │ ├── Layout.elm │ ├── LoremIpsum.elm │ └── Navigation.elm └── SystemEvent.elm ├── Internal ├── Msg.elm ├── PID.elm └── SystemEvent.elm ├── PID.elm └── PID └── Set.elm /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff 2 | docs.json 3 | example/snippets/Webbhuset 4 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | stages: 2 | - compile 3 | - prepare 4 | - deploy 5 | 6 | 7 | ########### 8 | ## BUILD ## 9 | ########### 10 | compile-elm: 11 | stage: compile 12 | tags: 13 | - elm 14 | before_script: 15 | - source /etc/profile 16 | script: 17 | - rm -rf ./elm-stuff/ 18 | - make docs 19 | - tar -czf ${CI_COMMIT_SHA}.tar.gz docs.json README.md 20 | - echo "export BUILD_JOB_ID=${CI_JOB_ID}" > variables 21 | artifacts: 22 | expire_in: 1 day 23 | name: $CI_COMMIT_SHA 24 | when: on_success 25 | paths: 26 | - ./$CI_COMMIT_SHA.tar.gz 27 | - ./variables 28 | only: 29 | - master 30 | - /^\d*-.*/ 31 | 32 | 33 | prepare-docs: 34 | stage: prepare 35 | tags: 36 | - shell 37 | variables: 38 | GIT_STRATEGY: none 39 | before_script: 40 | - source variables 41 | script: 42 | - ssh -i ~/.ssh/id_rsa -t deploy@saltmaster2.webbhuset.com "sudo /root/deploy/deploy.sh 43 | --action prepare 44 | --deploy-type site 45 | --target sandbox 46 | --root-dir /var/www/elm-doc/${CI_PROJECT_NAME}/${CI_COMMIT_REF_SLUG} 47 | --project-type elm 48 | --project ${CI_PROJECT_NAME} 49 | --namespace ${CI_PROJECT_NAMESPACE} 50 | --commit ${CI_COMMIT_SHA} 51 | --build ${BUILD_JOB_ID}" 52 | only: 53 | - master 54 | - /^\d*-.*/ 55 | 56 | 57 | deploy-docs: 58 | stage: deploy 59 | tags: 60 | - shell 61 | variables: 62 | GIT_STRATEGY: none 63 | before_script: 64 | - source variables 65 | script: 66 | - ssh -i ~/.ssh/id_rsa -t deploy@saltmaster2.webbhuset.com "sudo /root/deploy/deploy.sh 67 | --action deploy 68 | --deploy-type site 69 | --target sandbox 70 | --root-dir /var/www/elm-doc/${CI_PROJECT_NAME}/${CI_COMMIT_REF_SLUG} 71 | --symlink-subdir . 72 | --project-type elm 73 | --project ${CI_PROJECT_NAME} 74 | --namespace ${CI_PROJECT_NAMESPACE} 75 | --commit ${CI_COMMIT_SHA} 76 | --build ${BUILD_JOB_ID}" 77 | dependencies: [] 78 | environment: 79 | name: docs-$CI_COMMIT_REF_SLUG 80 | url: http://elm-doc.stage.webbhuset.com/?repo=$CI_PROJECT_NAME&version=$CI_COMMIT_REF_SLUG 81 | only: 82 | - master 83 | - /^\d*-.*/ 84 | 85 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Webbhuset / Frontend 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | rwildcard=$(wildcard $1$2) $(foreach d,$(wildcard $1*),$(call rwildcard,$d/,$2)) 3 | 4 | SNIPPETS = $(patsubst example/%.elm,%,$(call rwildcard,example/snippets/,*Sandbox.elm)) 5 | 6 | 7 | all: package snippets apps docs 8 | 9 | package: 10 | elm make 11 | 12 | snippets: $(SNIPPETS) 13 | 14 | apps: 15 | cd example; elm make apps/ElmUIApp/Main.elm --output /dev/null 16 | 17 | 18 | 19 | $(SNIPPETS): 20 | cd example; elm make $@.elm --output /dev/null 21 | 22 | docs: 23 | elm make --docs=docs.json 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Actor model in Elm 2 | 3 | Don't use this for production code (yet). 4 | I'm working on a few changes to the API that will be breaking changes. 5 | 6 | ## Concepts 7 | 8 | Some concepts / vocabulary. 9 | 10 | ### Component 11 | 12 | - Like an Elm program with out-messages. 13 | - Can NOT know anything about other components. 14 | - Is self contained and can be run as a standalone app. This makes development/testing easy. 15 | - When a component is started (instantiated) it is called a process. 16 | - Each process is identified by a unique PID (process id). 17 | - Knowing a PID, you can send messages to that process. 18 | 19 | There are three types of components: 20 | 21 | - UI Component 22 | - Service Component 23 | - Layout Component 24 | 25 | See Webbhuset.Component for more info. 26 | 27 | ### Actor 28 | 29 | - An *actor* is a *component* that has been "wrapped" to be part of a system. 30 | - The actor defines how a component's out-messages should be handled. 31 | - Maps received messages to the component's in-message type. 32 | - An actor implements the connections between components. 33 | - The actor uses the `ActorSystem` module to perform actions, such as sending messages, spawning processes. 34 | 35 | ### System 36 | 37 | - Defines which components are avaiable and bootstraps them. 38 | - The "runtime", routes messages, spawns actors etc. 39 | 40 | 41 | -------------------------------------------------------------------------------- /elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "package", 3 | "name": "webbhuset/elm-actor-model", 4 | "summary": "Framework for Component based systems using the Actor Model", 5 | "license": "MIT", 6 | "version": "4.0.0", 7 | "exposed-modules": { 8 | "Components": [ 9 | "Webbhuset.Component", 10 | "Webbhuset.Component.Sandbox", 11 | "Webbhuset.Component.SystemEvent", 12 | "Webbhuset.PID", 13 | "Webbhuset.PID.Set" 14 | ], 15 | "Actor System": [ 16 | "Webbhuset.Actor", 17 | "Webbhuset.ActorSystem" 18 | ] 19 | }, 20 | "elm-version": "0.19.0 <= v < 0.20.0", 21 | "dependencies": { 22 | "elm/browser": "1.0.1 <= v < 2.0.0", 23 | "elm/core": "1.0.2 <= v < 2.0.0", 24 | "elm/html": "1.0.0 <= v < 2.0.0", 25 | "elm/random": "1.0.0 <= v < 2.0.0", 26 | "elm/url": "1.0.0 <= v < 2.0.0", 27 | "elm-community/list-extra": "8.2.0 <= v < 9.0.0", 28 | "elm-explorations/markdown": "1.0.0 <= v < 2.0.0" 29 | }, 30 | "test-dependencies": {} 31 | } -------------------------------------------------------------------------------- /example/apps/TodoApp/Actor/TodoItem.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Actor.TodoItem exposing (..) 2 | 3 | import Webbhuset.ActorSystem as System 4 | import Webbhuset.Actor as Actor exposing (Actor) 5 | import Webbhuset.PID exposing (PID) 6 | import TodoApp.Msg as Msg exposing (Msg) 7 | import TodoApp.Component.TodoItem as TodoItem 8 | 9 | 10 | type alias Model = 11 | TodoItem.Model 12 | 13 | actor : (TodoItem.Model -> appModel) -> Actor Model appModel Msg 14 | actor toAppModel = 15 | Actor.fromUI 16 | { wrapModel = toAppModel 17 | , wrapMsg = Msg.TodoItem 18 | , mapIn = mapIn 19 | , mapOut = mapOut 20 | } 21 | TodoItem.component 22 | 23 | 24 | mapIn : Msg.AppMsg -> Maybe TodoItem.MsgIn 25 | mapIn appMsg = 26 | case appMsg of 27 | Msg.TodoItem msgIn -> 28 | Just msgIn 29 | 30 | _ -> 31 | Nothing 32 | 33 | 34 | mapOut : PID -> TodoItem.MsgOut -> Msg 35 | mapOut pid msgOut = 36 | System.none 37 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Actor/TodoList.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Actor.TodoList exposing (..) 2 | 3 | import Webbhuset.ActorSystem as System 4 | import Webbhuset.Actor as Actor exposing (Actor) 5 | import Webbhuset.PID exposing (PID) 6 | import TodoApp.Msg as Msg exposing (Msg) 7 | import TodoApp.Component.TodoList as TodoList 8 | 9 | 10 | type alias Model = 11 | TodoList.Model 12 | 13 | actor : (TodoList.Model -> appModel) -> Actor Model appModel Msg 14 | actor toAppModel = 15 | Actor.fromLayout 16 | { wrapModel = toAppModel 17 | , wrapMsg = Msg.TodoList 18 | , mapIn = mapIn 19 | , mapOut = mapOut 20 | } 21 | TodoList.component 22 | 23 | 24 | mapIn : Msg.AppMsg -> Maybe TodoList.MsgIn 25 | mapIn appMsg = 26 | case appMsg of 27 | Msg.TodoList msgIn -> 28 | Just msgIn 29 | 30 | _ -> 31 | Nothing 32 | 33 | 34 | mapOut : PID -> TodoList.MsgOut -> Msg 35 | mapOut pid msgOut = 36 | System.none 37 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Actor/TodoService.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Actor.TodoService exposing (..) 2 | 3 | import Webbhuset.ActorSystem as System 4 | import Webbhuset.Actor as Actor exposing (Actor) 5 | import Webbhuset.PID as PID exposing (PID) 6 | import TodoApp.Msg as Msg exposing (Msg) 7 | import TodoApp.Component.TodoService as TodoService 8 | import TodoApp.ActorName as ActorName 9 | 10 | 11 | type alias Model = 12 | TodoService.Model 13 | 14 | actor : (TodoService.Model -> appModel) -> Actor Model appModel Msg 15 | actor toAppModel = 16 | Actor.fromService 17 | { wrapModel = toAppModel 18 | , wrapMsg = Msg.TodoService 19 | , mapIn = mapIn 20 | , mapOut = mapOut 21 | } 22 | (TodoService.component ()) 23 | 24 | 25 | mapIn : Msg.AppMsg -> Maybe TodoService.MsgIn 26 | mapIn appMsg = 27 | case appMsg of 28 | Msg.TodoService msgIn -> 29 | Just msgIn 30 | 31 | _ -> 32 | Nothing 33 | 34 | 35 | mapOut : PID -> TodoService.MsgOut -> Msg 36 | mapOut self msgOut = 37 | case msgOut of 38 | TodoService.Init -> 39 | System.none 40 | -------------------------------------------------------------------------------- /example/apps/TodoApp/ActorName.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.ActorName exposing (..) 2 | 3 | 4 | type ActorName 5 | = TodoList 6 | | TodoItem 7 | | TodoService 8 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Bootstrap.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Bootstrap exposing (..) 2 | 3 | 4 | import Webbhuset.ActorSystem as System 5 | import TodoApp.Msg as Msg 6 | import TodoApp.ActorName as ActorName 7 | 8 | import TodoApp.Actor.TodoList as TodoList 9 | import TodoApp.Actor.TodoItem as TodoItem 10 | import TodoApp.Actor.TodoService as TodoService 11 | 12 | 13 | type Model 14 | = TodoList TodoList.Model 15 | | TodoItem TodoItem.Model 16 | | TodoService TodoService.Model 17 | 18 | 19 | actors = 20 | { todoList = TodoList.actor TodoList 21 | , todoItem = TodoItem.actor TodoItem 22 | , todoService = TodoService.actor TodoService 23 | } 24 | 25 | 26 | spawn actor = 27 | case actor of 28 | ActorName.TodoList -> 29 | actors.todoList.init 30 | 31 | ActorName.TodoItem -> 32 | actors.todoItem.init 33 | 34 | ActorName.TodoService -> 35 | actors.todoService.init 36 | 37 | 38 | applyModel model = 39 | case model of 40 | TodoList m -> 41 | System.applyModel actors.todoList m 42 | 43 | TodoItem m -> 44 | System.applyModel actors.todoItem m 45 | 46 | TodoService m -> 47 | System.applyModel actors.todoService m 48 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Component/TodoItem.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Component.TodoItem exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Html exposing (Html) 9 | import Webbhuset.Component as Component exposing (PID) 10 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 11 | 12 | 13 | type MsgIn 14 | = NoIn 15 | 16 | 17 | type MsgOut 18 | = NoOut 19 | 20 | 21 | type alias Model = 22 | { pid : PID 23 | } 24 | 25 | 26 | -- 27 | -- Component 28 | -- 29 | 30 | component : Component.UI Model MsgIn MsgOut 31 | component = 32 | { init = init 33 | , update = update 34 | , view = view 35 | , onSystem = always SystemEvent.default 36 | , subs = subs 37 | } 38 | 39 | 40 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 41 | init pid = 42 | ( { pid = pid 43 | } 44 | , [] 45 | , Cmd.none 46 | ) 47 | 48 | 49 | subs : Model -> Sub MsgIn 50 | subs model = 51 | Sub.none 52 | 53 | 54 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 55 | update msgIn model = 56 | case msgIn of 57 | NoIn -> 58 | ( model 59 | , [] 60 | , Cmd.none 61 | ) 62 | 63 | 64 | view : Model -> Html MsgIn 65 | view model = 66 | Html.div 67 | [] 68 | [ Html.text "Todo item" 69 | ] 70 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Component/TodoList.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Component.TodoList exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Webbhuset.Component as Component exposing (PID) 9 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 10 | import Html exposing (Html) 11 | 12 | 13 | type MsgIn 14 | = NoIn 15 | | ReceiveChild PID 16 | 17 | 18 | type MsgOut 19 | = NoOut 20 | 21 | 22 | type alias Model = 23 | { pid : PID 24 | , children : List PID 25 | } 26 | 27 | 28 | -- 29 | -- Component 30 | -- 31 | 32 | component : Component.Layout Model MsgIn MsgOut msg 33 | component = 34 | { init = init 35 | , update = update 36 | , view = view 37 | , onSystem = always SystemEvent.default 38 | , subs = subs 39 | } 40 | 41 | 42 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 43 | init pid = 44 | ( { pid = pid 45 | , children = [] 46 | } 47 | , [] 48 | , Cmd.none 49 | ) 50 | 51 | 52 | kill : Model -> List MsgOut 53 | kill model = 54 | [] 55 | 56 | 57 | subs : Model -> Sub MsgIn 58 | subs model = 59 | Sub.none 60 | 61 | 62 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 63 | update msgIn model = 64 | case msgIn of 65 | NoIn -> 66 | ( model 67 | , [] 68 | , Cmd.none 69 | ) 70 | 71 | ReceiveChild pid -> 72 | ( { model | children = model.children ++ [ pid ] } 73 | , [] 74 | , Cmd.none 75 | ) 76 | 77 | 78 | view : (MsgIn -> msg) -> Model -> (PID -> Html msg) -> Html msg 79 | view toSelf model renderPID = 80 | Html.div 81 | [] 82 | [ Html.h2 [] [ Html.text "Todo list" ] 83 | , model.children 84 | |> List.map renderPID 85 | |> Html.div [] 86 | ] 87 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Component/TodoService.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Component.TodoService exposing 2 | ( Config 3 | , MsgIn(..) 4 | , MsgOut(..) 5 | , Model 6 | , component 7 | ) 8 | 9 | {-| 10 | 11 | @docs Config 12 | @docs MsgIn 13 | @docs MsgOut 14 | 15 | @docs component, Model 16 | -} 17 | 18 | import Webbhuset.Component as Component exposing (PID) 19 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 20 | 21 | 22 | {-| Component Config 23 | -} 24 | type alias Config = 25 | () 26 | 27 | 28 | {-| Message In 29 | -} 30 | type MsgIn 31 | = NoIn 32 | | UnSub PID 33 | 34 | 35 | {-| Message Out 36 | -} 37 | type MsgOut 38 | = Init 39 | 40 | 41 | 42 | {-| Component Model. This component has an init and a running state. 43 | -} 44 | type Model 45 | = InitState InitModel 46 | | RunningState RunningModel 47 | 48 | 49 | type alias InitModel = 50 | { pid : PID 51 | } 52 | 53 | 54 | type alias RunningModel = 55 | { pid : PID 56 | } 57 | 58 | {-| Component Record 59 | -} 60 | component : Config -> Component.Service Model MsgIn MsgOut 61 | component config = 62 | { init = init config 63 | , update = update config 64 | , onSystem = onSystem 65 | , subs = subs 66 | } 67 | 68 | 69 | init : Config -> PID -> ( Model , List MsgOut, Cmd MsgIn ) 70 | init config pid = 71 | ( { pid = pid 72 | } 73 | |> InitState 74 | , [ Init 75 | ] 76 | , Cmd.none 77 | ) 78 | 79 | 80 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 81 | onSystem event = 82 | case event of 83 | SystemEvent.Kill -> 84 | SystemEvent.default 85 | 86 | SystemEvent.PIDNotFound pid -> 87 | UnSub pid 88 | |> SystemEvent.iWillHandleIt 89 | 90 | 91 | subs : Model -> Sub MsgIn 92 | subs model = 93 | Sub.none 94 | 95 | 96 | update : Config -> MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 97 | update config msgIn model = 98 | case model of 99 | InitState initModel -> 100 | updateInit config msgIn initModel 101 | 102 | RunningState runningModel -> 103 | updateRunning config msgIn runningModel 104 | |> Component.mapFirst RunningState 105 | 106 | 107 | 108 | updateInit : Config -> MsgIn -> InitModel -> ( Model, List MsgOut, Cmd MsgIn ) 109 | updateInit config msgIn model = 110 | case msgIn of 111 | NoIn -> 112 | ( model 113 | |> InitState 114 | , [] 115 | , Cmd.none 116 | ) 117 | 118 | UnSub pid -> 119 | ( model 120 | |> InitState 121 | , [] 122 | , Cmd.none 123 | ) 124 | 125 | 126 | updateRunning : Config -> MsgIn -> RunningModel -> ( RunningModel, List MsgOut, Cmd MsgIn ) 127 | updateRunning config msgIn model = 128 | case msgIn of 129 | NoIn -> 130 | ( model 131 | , [] 132 | , Cmd.none 133 | ) 134 | 135 | UnSub pid -> 136 | ( model 137 | , [] 138 | , Cmd.none 139 | ) 140 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Main.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Main exposing (..) 2 | 3 | import Html exposing (Html) 4 | import Webbhuset.ActorSystem as System 5 | import TodoApp.Msg as Msg exposing (Msg) 6 | import TodoApp.Bootstrap as Bootstrap 7 | import TodoApp.ActorName as ActorName exposing (ActorName) 8 | 9 | type alias Model = 10 | System.Model ActorName Bootstrap.Model 11 | 12 | 13 | main : Program () Model Msg 14 | main = 15 | System.element 16 | { spawn = Bootstrap.spawn 17 | , apply = Bootstrap.applyModel 18 | , init = init 19 | , view = view 20 | , onDebug = \error -> 21 | Debug.log "error" error 22 | |> always System.none 23 | } 24 | 25 | 26 | init : () -> Msg 27 | init flags = 28 | [ System.withSingletonPID ActorName.TodoList System.addView 29 | , System.spawnSingleton ActorName.TodoService 30 | , Msg.Dummy 31 | |> System.sendToSingleton ActorName.TodoService 32 | ] 33 | |> System.batch 34 | 35 | 36 | 37 | view : List (Html Msg) -> Html Msg 38 | view actorOutput = 39 | Html.div 40 | [ 41 | ] 42 | actorOutput 43 | 44 | 45 | 46 | type alias State s a = 47 | s -> ( a, s ) 48 | 49 | 50 | return : a -> State s a 51 | return a = 52 | \s -> ( a, s ) 53 | 54 | 55 | runState : s -> State s a -> ( a, s ) 56 | runState s st = 57 | st s 58 | 59 | 60 | andThen : (a -> State s b) -> State s a -> State s b 61 | andThen cont state = 62 | \s1 -> 63 | let 64 | ( a, s2 ) = state s1 65 | in 66 | cont a s2 67 | 68 | 69 | try = 70 | return "prefix" 71 | |> andThen one 72 | |> andThen one 73 | |> runState 1 74 | 75 | 76 | init2 = 77 | spawn "auth" "arga" <| \auth -> 78 | spawn "test" "argt" <| \test -> 79 | return 80 | { test = test 81 | , auth = auth 82 | } 83 | 84 | 85 | runInit = 86 | init2 87 | |> runState ( 1, [] ) 88 | 89 | 90 | spawn name arg cont = 91 | spawn_ name arg 92 | |> andThen cont 93 | 94 | 95 | spawn_ name arg ( p, ns ) = 96 | ( p 97 | , ( p + 1, ( p, name, arg) :: ns ) 98 | ) 99 | 100 | 101 | one a s = 102 | ( a ++ (String.fromInt s) 103 | , s + 1 104 | ) 105 | 106 | 107 | type alias Init = 108 | { last : Int 109 | , list : List ( String, Int ) 110 | } 111 | 112 | 113 | {- 114 | tspawn : Name -> (Int -> State Init a) -> State Init a -> State Init b 115 | tspawn name cont state = 116 | 117 | 118 | tspawn_ : State -> Name -> (Int -> a) -> State 119 | tspawn_ ( p, l ) name cont = 120 | let 121 | _ = cont p 122 | in 123 | ( p + 1, 124 | , ( name, p ) :: list 125 | ) 126 | 127 | 128 | tspawn : Name -> (Int -> a) -> State 129 | tspawn name cont = 130 | tspawn_ ( 1, [] ) 131 | 132 | 133 | tstart : a -> Writer a 134 | tstart a = 135 | ( a, [] ) 136 | 137 | 138 | init2 flags system = 139 | tspawn "auth" <| \authPid -> 140 | tspawn "router" <| \routerPid -> 141 | tstart 142 | { auth = authPid 143 | , router = routerPid 144 | } 145 | 146 | -} 147 | -------------------------------------------------------------------------------- /example/apps/TodoApp/Msg.elm: -------------------------------------------------------------------------------- 1 | module TodoApp.Msg exposing (..) 2 | 3 | import Webbhuset.ActorSystem as System 4 | import TodoApp.ActorName exposing (ActorName) 5 | 6 | import TodoApp.Component.TodoList as TodoList 7 | import TodoApp.Component.TodoItem as TodoItem 8 | import TodoApp.Component.TodoService as TodoService 9 | 10 | 11 | type alias Msg = 12 | System.SysMsg ActorName AppMsg 13 | 14 | 15 | type AppMsg 16 | = TodoList TodoList.MsgIn 17 | | TodoItem TodoItem.MsgIn 18 | | TodoService TodoService.MsgIn 19 | | Dummy 20 | -------------------------------------------------------------------------------- /example/assert/AssertExample1.elm: -------------------------------------------------------------------------------- 1 | module AssertExample1 exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Html exposing (Html) 9 | import Html.Attributes as HA 10 | import Html.Events as Events 11 | import Webbhuset.Component as Component exposing (PID) 12 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 13 | import Webbhuset.PID.Set as PIDSet 14 | 15 | 16 | 17 | 18 | type MsgIn 19 | = GoodButtonClicked 20 | | BadButtonClicked 21 | | ObserveSomething PID 22 | | ChangeSomething String 23 | 24 | 25 | type MsgOut 26 | = SomethingGood Int 27 | | SomethingBad Int 28 | | SomethingWasChanged (List PID) String 29 | 30 | 31 | type alias Model = 32 | { pid : PID 33 | , howGood : Int 34 | , something : String 35 | , observers : PIDSet.Set 36 | } 37 | 38 | 39 | -- 40 | -- Component 41 | -- 42 | 43 | component : Component.UI Model MsgIn MsgOut 44 | component = 45 | { init = init 46 | , update = update 47 | , view = view 48 | , onSystem = onSystem 49 | , subs = subs 50 | } 51 | 52 | 53 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 54 | init pid = 55 | ( { pid = pid 56 | , howGood = 0 57 | , something = "" 58 | , observers = PIDSet.empty 59 | } 60 | , [] 61 | , Cmd.none 62 | ) 63 | 64 | 65 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 66 | onSystem event = 67 | SystemEvent.default 68 | 69 | 70 | subs : Model -> Sub MsgIn 71 | subs model = 72 | Sub.none 73 | 74 | 75 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 76 | update msgIn model = 77 | case msgIn of 78 | GoodButtonClicked -> 79 | ( { model | howGood = model.howGood + 1 } 80 | , [ SomethingGood (model.howGood + 1) 81 | ] 82 | , Cmd.none 83 | ) 84 | 85 | BadButtonClicked -> 86 | ( { model | howGood = model.howGood - 1 } 87 | , [ SomethingBad (model.howGood - 1) 88 | ] 89 | , Cmd.none 90 | ) 91 | 92 | ObserveSomething pid -> 93 | ( { model | observers = PIDSet.insert pid model.observers } 94 | , [ SomethingWasChanged [ pid ] model.something 95 | ] 96 | , Cmd.none 97 | ) 98 | 99 | ChangeSomething newThing -> 100 | ( { model | something = newThing } 101 | , [ SomethingWasChanged (PIDSet.toList model.observers) newThing 102 | ] 103 | , Cmd.none 104 | ) 105 | 106 | view : Model -> Html MsgIn 107 | view model = 108 | Html.div 109 | [ HA.class "example" 110 | ] 111 | [ Html.node "style" [] [ Html.text css ] 112 | , Html.button 113 | [ Events.onClick GoodButtonClicked 114 | ] 115 | [ Html.text "Good button" 116 | ] 117 | , Html.button 118 | [ Events.onClick BadButtonClicked 119 | ] 120 | [ Html.text "Bad button" 121 | ] 122 | , Html.span 123 | [] 124 | [ Html.text "My Status: " 125 | , Html.text 126 | (if model.howGood < 0 then 127 | "This sucks!!!" 128 | else if model.howGood == 0 then 129 | "Bad" 130 | else if model.howGood == 1 then 131 | "Not that bad" 132 | else if model.howGood == 2 then 133 | "Acceptable (lagom)" 134 | else if model.howGood == 3 then 135 | "Good" 136 | else if model.howGood == 4 then 137 | "Really Good" 138 | else 139 | "Can't get better than this" 140 | ) 141 | ] 142 | ] 143 | 144 | 145 | css = 146 | """ 147 | .example > * { 148 | margin: 0.5rem; 149 | } 150 | """ 151 | -------------------------------------------------------------------------------- /example/assert/AssertExample1Sandbox.elm: -------------------------------------------------------------------------------- 1 | module Html.UIComponentSandbox exposing (..) 2 | 3 | import Webbhuset.Component.Sandbox as Sandbox exposing (SandboxProgram) 4 | import Webbhuset.PID as PID 5 | import AssertExample1 as Example 6 | import Html exposing (Html) 7 | import Html.Attributes as HA 8 | 9 | 10 | main : SandboxProgram Example.Model Example.MsgIn Example.MsgOut 11 | main = 12 | Sandbox.ui 13 | { title = "Examples of Asserts" 14 | , component = Example.component 15 | , cases = 16 | [ test_click 17 | , test_timeout 18 | , test_timeout2 19 | , test_timeout3 20 | , test_pid 21 | ] 22 | ++ (Sandbox.permuteInitOrder test_initOrder) 23 | , stringifyMsgIn = Debug.toString 24 | , stringifyMsgOut = Debug.toString 25 | , wrapView = view 26 | } 27 | 28 | view : Html Example.MsgIn -> Html Example.MsgIn 29 | view componentHtml = 30 | Html.div 31 | [ HA.class "component" 32 | ] 33 | [ Html.node "style" [] [ Html.text css ] 34 | , componentHtml 35 | ] 36 | 37 | 38 | css : String 39 | css = 40 | """ 41 | .component { 42 | font-family: monospace; 43 | padding: 1rem; 44 | } 45 | """ 46 | 47 | 48 | test_click : Sandbox.TestCase Example.MsgIn Example.MsgOut 49 | test_click = 50 | { title = "Assert out messages" 51 | , desc = 52 | """ 53 | Click the "Good Button" until the level becomes "Really good" for this test to pass. 54 | 55 | Levels are: 56 | - This sucks!!! 57 | - Bad 58 | - Not that bad 59 | - Acceptable 60 | - Good 61 | - Really Good 62 | - Too good 63 | 64 | """ 65 | , init = 66 | [ 67 | ] 68 | , onMsgOut = \outMsg -> 69 | case outMsg of 70 | Example.SomethingBad _ -> 71 | [ Sandbox.fail "You ruined it...." 72 | ] 73 | 74 | Example.SomethingGood 4 -> 75 | [ Sandbox.pass 76 | ] 77 | 78 | Example.SomethingGood 5 -> 79 | [ Sandbox.fail "Now it was too good, don't get carried away." 80 | ] 81 | 82 | _ -> 83 | [ ] 84 | } 85 | 86 | test_timeout : Sandbox.TestCase Example.MsgIn Example.MsgOut 87 | test_timeout = 88 | { title = "Timeout" 89 | , desc = 90 | """ 91 | Once you clicked "Good Button" you have one second to reach "Acceptable". 92 | Try waiting and the test will fail. 93 | """ 94 | , init = 95 | [ 96 | ] 97 | , onMsgOut = \outMsg -> 98 | case outMsg of 99 | Example.SomethingBad _ -> 100 | [ Sandbox.fail "You ruined it...." 101 | ] 102 | 103 | Example.SomethingGood 1 -> 104 | [ Sandbox.timeout 1000 105 | ] 106 | 107 | Example.SomethingGood 2 -> 108 | [ Sandbox.pass 109 | ] 110 | 111 | _ -> 112 | [ Sandbox.fail "Don't get carried away." 113 | ] 114 | } 115 | 116 | 117 | test_timeout2 : Sandbox.TestCase Example.MsgIn Example.MsgOut 118 | test_timeout2 = 119 | { title = "Timeout on next update" 120 | , desc = 121 | """ 122 | If you set the timeout to zero the test will timeout on next animation frame. 123 | This has to do with how Elm batches updates and synchronizes them with 124 | `requestAniamtionFrame`. 125 | 126 | Since `GoodButtonClicked` is sent directly from init this test passes. 127 | """ 128 | , init = 129 | [ Sandbox.timeout 0 130 | , Sandbox.sendMsg Example.GoodButtonClicked 131 | , Sandbox.sendMsg Example.GoodButtonClicked 132 | ] 133 | , onMsgOut = \outMsg -> 134 | case outMsg of 135 | Example.SomethingBad _ -> 136 | [ Sandbox.fail "You ruined it...." 137 | ] 138 | 139 | Example.SomethingGood 2 -> 140 | [ Sandbox.pass 141 | ] 142 | 143 | _ -> 144 | [ ] 145 | } 146 | 147 | 148 | test_timeout3 : Sandbox.TestCase Example.MsgIn Example.MsgOut 149 | test_timeout3 = 150 | { title = "Timeout is unpredictable" 151 | , desc = 152 | """ 153 | Here, the timeout is set to 30ms. Two messages are sent in a sequence with 154 | 10ms delay for each. Sometimes this test passes and sometimes it fails, try 155 | reloading the test multiple times. This is 156 | due to Elm's internals (I think) trying to syncronize updates with request 157 | animation frame. 158 | """ 159 | , init = 160 | [ Sandbox.timeout 30 161 | , Sandbox.sendMsg Example.GoodButtonClicked 162 | |> Sandbox.delay 10 163 | ] 164 | , onMsgOut = \outMsg -> 165 | case outMsg of 166 | Example.SomethingBad _ -> 167 | [ Sandbox.fail "You ruined it...." 168 | ] 169 | 170 | Example.SomethingGood 1 -> 171 | [ Sandbox.sendMsg Example.GoodButtonClicked 172 | |> Sandbox.delay 10 173 | ] 174 | 175 | Example.SomethingGood 2 -> 176 | [ Sandbox.pass 177 | ] 178 | 179 | _ -> 180 | [ ] 181 | } 182 | 183 | 184 | test_pid : Sandbox.TestCase Example.MsgIn Example.MsgOut 185 | test_pid = 186 | let 187 | fakePID = 188 | Sandbox.mockPID "a-component" 189 | 190 | fakePID2 = 191 | Sandbox.mockPID "another-component" 192 | in 193 | { title = "Assert PIDs" 194 | , desc = 195 | """ 196 | You can assert PIDs when using with the observer pattern. 197 | 198 | Check that both observers receive the string "new thing". 199 | """ 200 | , init = 201 | [ Sandbox.timeout 30 202 | , Example.ObserveSomething fakePID 203 | |> Sandbox.sendMsg 204 | , Example.ObserveSomething fakePID2 205 | |> Sandbox.sendMsg 206 | , Example.ChangeSomething "new thing" 207 | |> Sandbox.sendMsg 208 | ] 209 | , onMsgOut = \outMsg -> 210 | case outMsg of 211 | Example.SomethingWasChanged pids thing -> 212 | if List.any ((==) fakePID) pids 213 | && List.any ((==) fakePID2) pids 214 | && thing == "new thing" 215 | then 216 | [ Sandbox.pass 217 | ] 218 | else 219 | [] 220 | 221 | _ -> 222 | [ ] 223 | } 224 | 225 | 226 | test_initOrder : Sandbox.TestCase Example.MsgIn Example.MsgOut 227 | test_initOrder = 228 | { title = "Example permuteInitOrder" 229 | , desc = 230 | """ 231 | Sometimes it is useful to test if the order of your init messages would 232 | affect the test result. One way to do so is by permuting all possible 233 | orders and test them. This is what `permuteInitOrder` does. 234 | 235 | In this test case, `GoodButtonClicked` must be sent before `BadButtonClicked` for the 236 | test to pass. 237 | 238 | As you can see, there are 6 permutations of our test since it has 3 init messages. (3! or 3 x 2 x 1). 239 | Half of the tests fail since the they have the "wrong" order. 240 | 241 | """ 242 | , init = 243 | [ Sandbox.timeout 30 244 | , Sandbox.sendMsg Example.GoodButtonClicked 245 | , Sandbox.sendMsg (Example.ChangeSomething "") 246 | , Sandbox.sendMsg Example.BadButtonClicked 247 | ] 248 | , onMsgOut = \outMsg -> 249 | case outMsg of 250 | Example.SomethingBad x -> 251 | if x < 0 then 252 | [ Sandbox.fail "Got BadButtonClicked before GoodButtonClicked" 253 | ] 254 | else 255 | [] 256 | 257 | Example.SomethingGood x -> 258 | if x == 1 then 259 | [ Sandbox.pass 260 | ] 261 | else 262 | [] 263 | 264 | 265 | _ -> 266 | [ ] 267 | } 268 | -------------------------------------------------------------------------------- /example/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "../src", 5 | "apps", 6 | "assert", 7 | "snippets" 8 | ], 9 | "elm-version": "0.19.0", 10 | "dependencies": { 11 | "direct": { 12 | "elm/browser": "1.0.1", 13 | "elm/core": "1.0.2", 14 | "elm/html": "1.0.0", 15 | "elm/random": "1.0.0", 16 | "elm/url": "1.0.0", 17 | "elm-community/list-extra": "8.2.0", 18 | "elm-explorations/markdown": "1.0.0" 19 | }, 20 | "indirect": { 21 | "elm/json": "1.1.3", 22 | "elm/time": "1.0.0", 23 | "elm/virtual-dom": "1.0.2" 24 | } 25 | }, 26 | "test-dependencies": { 27 | "direct": {}, 28 | "indirect": {} 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /example/snippets/ElmUI/LayoutComponent.elm: -------------------------------------------------------------------------------- 1 | module ElmUI.LayoutComponent exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Element exposing (Element) 9 | import Webbhuset.ElmUI.Component as Component exposing (PID) 10 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 11 | 12 | 13 | type MsgIn 14 | = NoIn 15 | | ReceiveChild PID 16 | 17 | 18 | type MsgOut 19 | = SpawnRendererFor String 20 | 21 | 22 | type alias Model = 23 | { pid : PID 24 | , children : List PID 25 | } 26 | 27 | 28 | -- 29 | -- Component 30 | -- 31 | 32 | component : Component.Layout Model MsgIn MsgOut msg 33 | component = 34 | { init = init 35 | , update = update 36 | , view = view 37 | , onSystem = onSystem 38 | , subs = subs 39 | } 40 | 41 | 42 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 43 | init pid = 44 | ( { pid = pid 45 | , children = [] 46 | } 47 | , [] 48 | , Cmd.none 49 | ) 50 | 51 | 52 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 53 | onSystem event = 54 | SystemEvent.default 55 | 56 | 57 | subs : Model -> Sub MsgIn 58 | subs model = 59 | Sub.none 60 | 61 | 62 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 63 | update msgIn model = 64 | case msgIn of 65 | NoIn -> 66 | ( model 67 | , [] 68 | , Cmd.none 69 | ) 70 | 71 | ReceiveChild pid -> 72 | ( { model | children = model.children ++ [ pid ] } 73 | , [] 74 | , Cmd.none 75 | ) 76 | 77 | 78 | view : (MsgIn -> msg) -> Model -> (PID -> Element msg) -> Element msg 79 | view toSelf model renderPID = 80 | Element.column 81 | [] 82 | [ Element.el [] (Element.text "Layout Component" ) 83 | , model.children 84 | |> List.map renderPID 85 | |> Element.column [] 86 | ] 87 | -------------------------------------------------------------------------------- /example/snippets/ElmUI/LayoutComponentSandbox.elm: -------------------------------------------------------------------------------- 1 | module ElmUI.LayoutComponentSandbox exposing (..) 2 | 3 | import Webbhuset.ElmUI.Sandbox as Sandbox exposing (SandboxProgram) 4 | import Webbhuset.PID as PID 5 | import ElmUI.LayoutComponent as ComponentAlias 6 | import Element exposing (Element) 7 | import Html exposing (Html) 8 | 9 | 10 | type alias Model = ComponentAlias.Model 11 | type alias MsgIn = ComponentAlias.MsgIn 12 | type alias MsgOut = ComponentAlias.MsgOut 13 | 14 | 15 | main : SandboxProgram Model MsgIn MsgOut 16 | main = 17 | Sandbox.layout 18 | { title = "Elm UI Layout Component" 19 | , component = ComponentAlias.component 20 | , cases = 21 | [ test_init 22 | ] 23 | , stringifyMsgIn = Debug.toString -- Or roll your own if you want prettier messages. 24 | , stringifyMsgOut = Debug.toString 25 | , wrapView = view 26 | } 27 | 28 | 29 | {-| You can wrap the output of your component. 30 | 31 | This is useful when you want to add CSS style or some extra test buttons. 32 | -} 33 | view : (MsgIn -> msg) -> Element msg -> Html msg 34 | view toSelf componentHtml = 35 | componentHtml 36 | |> Element.layout [] 37 | 38 | 39 | test_init : Sandbox.TestCase MsgIn MsgOut 40 | test_init = 41 | { title = "Test case title" 42 | , desc = 43 | """ 44 | # Describe test case here. 45 | 46 | You can use Markdown 47 | """ 48 | , init = 49 | [ Sandbox.sendMsg ComponentAlias.NoIn -- A list of MsgIn to put the tested componet in the right state. 50 | , Sandbox.spawnChild "Hello child" ComponentAlias.ReceiveChild 51 | ] 52 | , onMsgOut = always [] 53 | } 54 | 55 | 56 | -------------------------------------------------------------------------------- /example/snippets/ElmUI/UIComponent.elm: -------------------------------------------------------------------------------- 1 | module ElmUI.UIComponent exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Element exposing (Element) 9 | import Webbhuset.ElmUI.Component as Component exposing (PID) 10 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 11 | 12 | 13 | 14 | 15 | type MsgIn 16 | = NoIn 17 | 18 | 19 | type MsgOut 20 | = NoOut 21 | 22 | 23 | type alias Model = 24 | { pid : PID 25 | } 26 | 27 | 28 | -- 29 | -- Component 30 | -- 31 | 32 | component : Component.UI Model MsgIn MsgOut 33 | component = 34 | { init = init 35 | , update = update 36 | , view = view 37 | , onSystem = onSystem 38 | , subs = subs 39 | } 40 | 41 | 42 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 43 | init pid = 44 | ( { pid = pid 45 | } 46 | , [] 47 | , Cmd.none 48 | ) 49 | 50 | 51 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 52 | onSystem event = 53 | SystemEvent.default 54 | 55 | 56 | subs : Model -> Sub MsgIn 57 | subs model = 58 | Sub.none 59 | 60 | 61 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 62 | update msgIn model = 63 | case msgIn of 64 | NoIn -> 65 | ( model 66 | , [] 67 | , Cmd.none 68 | ) 69 | 70 | 71 | view : Model -> Element MsgIn 72 | view model = 73 | Element.column 74 | [] 75 | [ Element.text "Empty Component" 76 | ] 77 | -------------------------------------------------------------------------------- /example/snippets/ElmUI/UIComponentSandbox.elm: -------------------------------------------------------------------------------- 1 | module ElmUI.UIComponentSandbox exposing (..) 2 | 3 | import Webbhuset.ElmUI.Sandbox as Sandbox exposing (SandboxProgram) 4 | import Webbhuset.PID as PID 5 | import ElmUI.UIComponent as ComponentAlias 6 | import Html exposing (Html) 7 | import Element exposing (Element) 8 | 9 | 10 | type alias Model = ComponentAlias.Model 11 | type alias MsgIn = ComponentAlias.MsgIn 12 | type alias MsgOut = ComponentAlias.MsgOut 13 | 14 | 15 | main : SandboxProgram Model MsgIn MsgOut 16 | main = 17 | Sandbox.ui 18 | { title = "Elm UI UI Component" 19 | , component = ComponentAlias.component 20 | , cases = 21 | [ test_init 22 | ] 23 | , stringifyMsgIn = Debug.toString -- Or roll your own if you want prettier messages. 24 | , stringifyMsgOut = Debug.toString 25 | , wrapView = view 26 | } 27 | 28 | {-| You can wrap the output of your component. 29 | 30 | This is useful when you want to add CSS style or some extra test buttons. 31 | -} 32 | view : Element MsgIn -> Html MsgIn 33 | view componentHtml = 34 | componentHtml 35 | |> Element.layout [] 36 | 37 | 38 | 39 | test_init : Sandbox.TestCase MsgIn MsgOut 40 | test_init = 41 | { title = "Test case title" 42 | , desc = 43 | """ 44 | # Describe test case here. 45 | 46 | You can use Markdown 47 | """ 48 | , init = 49 | [ Sandbox.sendMsg ComponentAlias.NoIn -- A list of MsgIn to put the tested componet in the right state. 50 | ] 51 | , onMsgOut = always [] 52 | } 53 | -------------------------------------------------------------------------------- /example/snippets/Html/LayoutComponent.elm: -------------------------------------------------------------------------------- 1 | module Html.LayoutComponent exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Html exposing (Html) 9 | import Html.Attributes as HA 10 | import Webbhuset.Component as Component exposing (PID) 11 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 12 | 13 | 14 | type MsgIn 15 | = Show String 16 | | ReceiveChild PID 17 | 18 | 19 | type MsgOut 20 | = SpawnRendererFor String 21 | 22 | 23 | type alias Model = 24 | { pid : PID 25 | , children : List PID 26 | } 27 | 28 | 29 | -- 30 | -- Component 31 | -- 32 | 33 | component : Component.Layout Model MsgIn MsgOut msg 34 | component = 35 | { init = init 36 | , update = update 37 | , view = view 38 | , onSystem = onSystem 39 | , subs = subs 40 | } 41 | 42 | 43 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 44 | init pid = 45 | ( { pid = pid 46 | , children = [] 47 | } 48 | , [] 49 | , Cmd.none 50 | ) 51 | 52 | 53 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 54 | onSystem event = 55 | SystemEvent.default 56 | 57 | 58 | subs : Model -> Sub MsgIn 59 | subs model = 60 | Sub.none 61 | 62 | 63 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 64 | update msgIn model = 65 | case msgIn of 66 | Show str -> 67 | ( model 68 | , [ SpawnRendererFor str 69 | ] 70 | , Cmd.none 71 | ) 72 | 73 | ReceiveChild pid -> 74 | ( { model | children = model.children ++ [ pid ] } 75 | , [] 76 | , Cmd.none 77 | ) 78 | 79 | 80 | view : (MsgIn -> msg) -> Model -> (PID -> Html msg) -> Html msg 81 | view toSelf model renderPID = 82 | Html.div 83 | [] 84 | [ Html.h1 [] [ Html.text "Layout Component" ] 85 | , model.children 86 | |> List.map renderPID 87 | |> Html.div [] 88 | ] 89 | -------------------------------------------------------------------------------- /example/snippets/Html/LayoutComponentSandbox.elm: -------------------------------------------------------------------------------- 1 | module Html.LayoutComponentSandbox exposing (..) 2 | 3 | import Webbhuset.Component.Sandbox as Sandbox exposing (SandboxProgram) 4 | import Webbhuset.PID as PID 5 | import Html exposing (Html) 6 | import Html.Attributes as HA 7 | import Html.LayoutComponent as ComponentAlias 8 | 9 | 10 | type alias Model = ComponentAlias.Model 11 | type alias MsgIn = ComponentAlias.MsgIn 12 | type alias MsgOut = ComponentAlias.MsgOut 13 | 14 | 15 | main : SandboxProgram Model MsgIn MsgOut 16 | main = 17 | Sandbox.layout 18 | { title = "Layout Component" 19 | , component = ComponentAlias.component 20 | , cases = 21 | [ test_init 22 | , test_init 23 | ] 24 | , stringifyMsgIn = Debug.toString -- Or roll your own if you want prettier messages. 25 | , stringifyMsgOut = Debug.toString 26 | , wrapView = view 27 | } 28 | 29 | 30 | {-| You can wrap the output of your component. 31 | 32 | This is useful when you want to add CSS style or some extra test buttons. 33 | -} 34 | view : (MsgIn -> msg) -> Html msg -> Html msg 35 | view toSelf componentHtml = 36 | Html.div 37 | [ HA.class "component" 38 | ] 39 | [ Html.node "style" [] [ Html.text css ] 40 | , componentHtml 41 | ] 42 | 43 | 44 | css : String 45 | css = 46 | """ 47 | .component { 48 | font-family: monospace; 49 | } 50 | """ 51 | 52 | 53 | 54 | test_init : Sandbox.TestCase MsgIn MsgOut 55 | test_init = 56 | { title = "Test case title" 57 | , desc = 58 | """ 59 | # Describe test case here. 60 | 61 | You can use Markdown 62 | """ 63 | , init = 64 | [ Sandbox.sendMsg (ComponentAlias.Show "Hej") 65 | |> Sandbox.delay 500 66 | ] 67 | , onMsgOut = \msgOut -> 68 | case msgOut of 69 | ComponentAlias.SpawnRendererFor str -> 70 | [ Sandbox.spawnChild str ComponentAlias.ReceiveChild 71 | |> Sandbox.delay 500 72 | ] 73 | } 74 | 75 | 76 | -------------------------------------------------------------------------------- /example/snippets/Html/UIComponent.elm: -------------------------------------------------------------------------------- 1 | module Html.UIComponent exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | import Html exposing (Html) 9 | import Html.Attributes as HA 10 | import Webbhuset.Component as Component exposing (PID) 11 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 12 | 13 | 14 | 15 | 16 | type MsgIn 17 | = NoIn 18 | 19 | 20 | type MsgOut 21 | = NoOut 22 | 23 | 24 | type alias Model = 25 | { pid : PID 26 | } 27 | 28 | 29 | -- 30 | -- Component 31 | -- 32 | 33 | component : Component.UI Model MsgIn MsgOut 34 | component = 35 | { init = init 36 | , update = update 37 | , view = view 38 | , onSystem = onSystem 39 | , subs = subs 40 | } 41 | 42 | 43 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 44 | init pid = 45 | ( { pid = pid 46 | } 47 | , [] 48 | , Cmd.none 49 | ) 50 | 51 | 52 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 53 | onSystem event = 54 | SystemEvent.default 55 | 56 | 57 | subs : Model -> Sub MsgIn 58 | subs model = 59 | Sub.none 60 | 61 | 62 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 63 | update msgIn model = 64 | case msgIn of 65 | NoIn -> 66 | ( model 67 | , [] 68 | , Cmd.none 69 | ) 70 | 71 | 72 | view : Model -> Html MsgIn 73 | view model = 74 | Html.div 75 | [] 76 | [ Html.text "Empty Component" 77 | ] 78 | -------------------------------------------------------------------------------- /example/snippets/Html/UIComponentSandbox.elm: -------------------------------------------------------------------------------- 1 | module Html.UIComponentSandbox exposing (..) 2 | 3 | import Webbhuset.Component.Sandbox as Sandbox exposing (SandboxProgram) 4 | import Webbhuset.PID as PID 5 | import Html.UIComponent as ComponentAlias 6 | import Html exposing (Html) 7 | import Html.Attributes as HA 8 | 9 | 10 | type alias Model = ComponentAlias.Model 11 | type alias MsgIn = ComponentAlias.MsgIn 12 | type alias MsgOut = ComponentAlias.MsgOut 13 | 14 | 15 | main : SandboxProgram Model MsgIn MsgOut 16 | main = 17 | Sandbox.ui 18 | { title = "UI Component" 19 | , component = ComponentAlias.component 20 | , cases = 21 | [ test_init 22 | ] 23 | , stringifyMsgIn = Debug.toString -- Or roll your own if you want prettier messages. 24 | , stringifyMsgOut = Debug.toString 25 | , wrapView = view 26 | } 27 | 28 | {-| You can wrap the output of your component. 29 | 30 | This is useful when you want to add CSS style or some extra test buttons. 31 | -} 32 | view : Html MsgIn -> Html MsgIn 33 | view componentHtml = 34 | Html.div 35 | [ HA.class "component" 36 | ] 37 | [ Html.node "style" [] [ Html.text css ] 38 | , componentHtml 39 | ] 40 | 41 | 42 | css : String 43 | css = 44 | """ 45 | .component { 46 | font-family: monospace; 47 | } 48 | """ 49 | 50 | 51 | test_init : Sandbox.TestCase MsgIn MsgOut 52 | test_init = 53 | { title = "Test case title" 54 | , desc = 55 | """ 56 | # Describe test case here. 57 | 58 | You can use Markdown 59 | """ 60 | , init = 61 | [ Sandbox.sendMsg ComponentAlias.NoIn -- A list of MsgIn to put the tested componet in the right state. 62 | ] 63 | , onMsgOut = always [] 64 | } 65 | -------------------------------------------------------------------------------- /example/snippets/ServiceComponent.elm: -------------------------------------------------------------------------------- 1 | module ServiceComponent exposing 2 | ( Config 3 | , MsgIn(..) 4 | , MsgOut(..) 5 | , Model 6 | , component 7 | ) 8 | 9 | {-| 10 | 11 | @docs Config 12 | @docs MsgIn 13 | @docs MsgOut 14 | 15 | @docs component, Model 16 | -} 17 | 18 | import Webbhuset.Component as Component exposing (PID) 19 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 20 | 21 | 22 | {-| Component Config 23 | -} 24 | type alias Config = 25 | () 26 | 27 | 28 | {-| Message In 29 | -} 30 | type MsgIn 31 | = NoIn 32 | 33 | 34 | {-| Message Out 35 | -} 36 | type MsgOut 37 | = NoOut 38 | 39 | 40 | 41 | {-| Component Model. This component has an init and a running state. 42 | -} 43 | type Model 44 | = InitState InitModel 45 | | RunningState RunningModel 46 | 47 | 48 | type alias InitModel = 49 | { pid : PID 50 | } 51 | 52 | 53 | type alias RunningModel = 54 | { pid : PID 55 | } 56 | 57 | {-| Component Record 58 | -} 59 | component : Config -> Component.Service Model MsgIn MsgOut 60 | component config = 61 | { init = init config 62 | , update = update config 63 | , onSystem = onSystem 64 | , subs = subs 65 | } 66 | 67 | 68 | init : Config -> PID -> ( Model , List MsgOut, Cmd MsgIn ) 69 | init config pid = 70 | ( { pid = pid 71 | } 72 | |> InitState 73 | , [] 74 | , Cmd.none 75 | ) 76 | 77 | 78 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 79 | onSystem event = 80 | SystemEvent.default 81 | 82 | 83 | subs : Model -> Sub MsgIn 84 | subs model = 85 | Sub.none 86 | 87 | 88 | update : Config -> MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 89 | update config msgIn model = 90 | case model of 91 | InitState initModel -> 92 | updateInit config msgIn initModel 93 | 94 | RunningState runningModel -> 95 | updateRunning config msgIn runningModel 96 | |> Component.mapFirst RunningState 97 | 98 | 99 | 100 | updateInit : Config -> MsgIn -> InitModel -> ( Model, List MsgOut, Cmd MsgIn ) 101 | updateInit config msgIn model = 102 | case msgIn of 103 | NoIn -> 104 | ( model 105 | |> InitState 106 | , [] 107 | , Cmd.none 108 | ) 109 | 110 | 111 | updateRunning : Config -> MsgIn -> RunningModel -> ( RunningModel, List MsgOut, Cmd MsgIn ) 112 | updateRunning config msgIn model = 113 | case msgIn of 114 | NoIn -> 115 | ( model 116 | , [] 117 | , Cmd.none 118 | ) 119 | 120 | 121 | -------------------------------------------------------------------------------- /example/snippets/ServiceComponentSandbox.elm: -------------------------------------------------------------------------------- 1 | module ServiceComponentSandbox exposing (..) 2 | 3 | import Webbhuset.Component.Sandbox as Sandbox exposing (SandboxProgram) 4 | import Webbhuset.Component as Component 5 | import Html exposing (Html) 6 | import ServiceComponent as ComponentAlias 7 | 8 | 9 | type alias Model = ComponentAlias.Model 10 | type alias MsgIn = ComponentAlias.MsgIn 11 | type alias MsgOut = ComponentAlias.MsgOut 12 | 13 | 14 | main : SandboxProgram Model MsgIn MsgOut 15 | main = 16 | Sandbox.service 17 | { title = "Service Component" 18 | , component = ComponentAlias.component () 19 | , cases = 20 | [ test_init 21 | ] 22 | , stringifyMsgIn = Debug.toString -- Or roll your own if you want prettier messages. 23 | , stringifyMsgOut = Debug.toString 24 | , view = view 25 | } 26 | 27 | 28 | 29 | {-| Sometimes it is useful to render some internals of your 30 | service component's model. 31 | 32 | -} 33 | view : Model -> Html MsgIn 34 | view model = 35 | Html.text "Hello" 36 | 37 | 38 | 39 | test_init : Sandbox.TestCase MsgIn MsgOut 40 | test_init = 41 | { title = "Test case title" 42 | , desc = 43 | """ 44 | # Describe test case here. 45 | 46 | You can use Markdown 47 | """ 48 | , init = 49 | [ Sandbox.sendMsg ComponentAlias.NoIn -- A list of MsgIn to put the tested componet in the right state. 50 | ] 51 | , onMsgOut = always [] 52 | } 53 | 54 | 55 | -------------------------------------------------------------------------------- /src/Webbhuset/Actor.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Actor exposing 2 | ( Actor 3 | , PID 4 | , Args 5 | , fromLayout 6 | , fromService 7 | , fromUI 8 | , wrapSystem 9 | , wrapSub 10 | , wrapInit 11 | , wrapUpdate 12 | , sendTo 13 | ) 14 | 15 | {-| 16 | 17 | # Actor 18 | 19 | When a component is incorporated in a system it becomes an Actor. The actor module 20 | implements the connections to the other components in the system. 21 | In practice that means mapping and sending the component's out messages to other 22 | actors in the system. 23 | 24 | Here is an example of wrapping a login form component to an actor in a system. 25 | 26 | 27 | This is the global model for the System: 28 | ``` 29 | module AppModel exposing (..) 30 | 31 | type AppModel 32 | = LoginFormModel LoginForm.Model 33 | | OtherComponent ... 34 | ``` 35 | 36 | This is the global appMsg type for the System: 37 | ``` 38 | module AppMsg exposing (..) 39 | 40 | type AppMsg 41 | = FormMsg LoginForm.MsgIn 42 | | AuthServiceMsg AuthService.MsgIn 43 | | OtherComponent ... 44 | 45 | ``` 46 | 47 | This is the login form actor: 48 | ``` 49 | module Actor.LoginForm exposing (..) 50 | 51 | import Webbhuset.ActorSystem as System 52 | import Webbhuset.Actor as Actor exposing (Actor) 53 | import Component.LoginForm as LoginForm 54 | import Component.AuthService as AuthService 55 | import AppMsg exposing (AppMsg) 56 | import AppModel exposing (AppModel) 57 | 58 | 59 | actor : Actor LoginForm.Model AppModel AppMsg 60 | actor = 61 | Actor.fromUI 62 | { wrapModel = AppModel.LoginFormModel 63 | , wrapMsg = AppMsg.FormMsg 64 | , mapIn = mapFormIn 65 | , mapOut = mapFormOut 66 | } 67 | LoginForm.component 68 | 69 | 70 | mapFormIn : AppMsg -> Maybe LoginForm.MsgIn 71 | mapFormIn appMsg = 72 | case appMsg of 73 | AppMsg.FormMsg formMsg -> 74 | Just formMsg 75 | 76 | _ -> 77 | Nothing 78 | 79 | 80 | mapFormOut : PID -> LoginForm.MsgOut -> System.SysMsg name AppMsg 81 | mapFormOut self formMsg = 82 | case formMsg of 83 | LoginForm.Submit user password -> 84 | AuthService.Login user password self 85 | |> AppMsg.AuthServiceMsg 86 | |> System.toAppMsg 87 | |> System.sendToSingleton AuthService 88 | 89 | ``` 90 | 91 | @docs PID 92 | 93 | ## Create Actors from Components 94 | 95 | @docs fromUI, fromService, fromLayout 96 | 97 | ## For package authors. 98 | 99 | You probably don't need this when you are using the actor model. 100 | These are useful if you need to create support for a different output type. 101 | 102 | @docs Actor 103 | , Args 104 | , wrapSystem 105 | , wrapSub 106 | , wrapInit 107 | , wrapUpdate 108 | , sendTo 109 | 110 | -} 111 | import Html exposing (Html) 112 | import Html.Lazy as Html 113 | import Webbhuset.Component as Component 114 | import Webbhuset.PID as PID 115 | import Webbhuset.ActorSystem as System 116 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 117 | import Webbhuset.Internal.Msg as Msg 118 | 119 | type alias SysMsg name appMsg = 120 | System.SysMsg name appMsg 121 | 122 | {-| A PID is an identifier for a Process. 123 | 124 | -} 125 | type alias PID = 126 | PID.PID 127 | 128 | 129 | {-| An actor is acomponent where the types are wrapped 130 | to fit the System types. 131 | 132 | -} 133 | type alias Actor compModel appModel msg = 134 | System.Actor compModel appModel (Html msg) msg 135 | 136 | 137 | {-| Args 138 | 139 | -} 140 | type alias Args name compModel appModel msgIn msgOut appMsg = 141 | { wrapModel : compModel -> appModel 142 | , wrapMsg : msgIn -> appMsg 143 | , mapIn : appMsg -> Maybe msgIn 144 | , mapOut : PID -> msgOut -> SysMsg name appMsg 145 | } 146 | 147 | 148 | 149 | {-| Create an actor from a Layout Component 150 | 151 | -} 152 | fromLayout : 153 | { wrapModel : compModel -> appModel 154 | , wrapMsg : msgIn -> appMsg 155 | , mapIn : appMsg -> Maybe msgIn 156 | , mapOut : PID -> msgOut -> SysMsg name appMsg 157 | } 158 | -> Component.Layout compModel msgIn msgOut (SysMsg name appMsg) 159 | -> Actor compModel appModel (SysMsg name appMsg) 160 | fromLayout args component = 161 | { init = wrapInit args component.init 162 | , update = wrapUpdate args component.update 163 | , view = layoutView args component.view 164 | , onSystem = wrapSystem args.wrapMsg component.onSystem 165 | , subs = wrapSub args.wrapMsg component.subs 166 | } 167 | 168 | 169 | layoutView : Args name compModel appModel msgIn msgOut appMsg 170 | -> ((msgIn -> SysMsg name appMsg) 171 | -> compModel 172 | -> (PID -> Html (SysMsg name appMsg)) 173 | -> Html (SysMsg name appMsg) 174 | ) 175 | -> compModel 176 | -> PID 177 | -> (PID -> Maybe (Html (SysMsg name appMsg))) 178 | -> Html (SysMsg name appMsg) 179 | layoutView args view model pid renderPID = 180 | view 181 | (sendTo args.wrapMsg pid) 182 | model 183 | (renderPID >> Maybe.withDefault (Html.text "")) 184 | 185 | 186 | {-| Create an actor from a UI Component 187 | 188 | 189 | -} 190 | fromUI : 191 | { wrapModel : compModel -> appModel 192 | , wrapMsg : msgIn -> appMsg 193 | , mapIn : appMsg -> Maybe msgIn 194 | , mapOut : PID -> msgOut -> SysMsg name appMsg 195 | } 196 | -> Component.UI compModel msgIn msgOut 197 | -> Actor compModel appModel (SysMsg name appMsg) 198 | fromUI args component = 199 | { init = wrapInit args component.init 200 | , update = wrapUpdate args component.update 201 | , view = uiView args component.view 202 | , onSystem = wrapSystem args.wrapMsg component.onSystem 203 | , subs = wrapSub args.wrapMsg component.subs 204 | } 205 | 206 | 207 | uiView : Args name compModel appModel msgIn msgOut appMsg 208 | -> (compModel -> Html msgIn) 209 | -> compModel 210 | -> PID 211 | -> renderPID 212 | -> Html (SysMsg name appMsg) 213 | uiView args view model pid _ = 214 | Html.lazy4 uiView_ view model args.wrapMsg pid 215 | 216 | 217 | uiView_ : (compModel -> Html msgIn) -> compModel -> (msgIn -> appMsg) -> PID -> Html (SysMsg actor appMsg) 218 | uiView_ view model toSelf pid = 219 | view model 220 | |> Html.map 221 | (sendTo toSelf pid) 222 | 223 | 224 | {-| Create an actor from a Service Component 225 | 226 | -} 227 | fromService : 228 | { wrapModel : compModel -> appModel 229 | , wrapMsg : msgIn -> appMsg 230 | , mapIn : appMsg -> Maybe msgIn 231 | , mapOut : PID -> msgOut -> SysMsg name appMsg 232 | } 233 | -> Component.Service compModel msgIn msgOut 234 | -> Actor compModel appModel (SysMsg name appMsg) 235 | fromService args component = 236 | { init = wrapInit args component.init 237 | , update = wrapUpdate args component.update 238 | , view = serviceView 239 | , onSystem = wrapSystem args.wrapMsg component.onSystem 240 | , subs = wrapSub args.wrapMsg component.subs 241 | } 242 | 243 | 244 | serviceView : a -> b -> c -> Html msg 245 | serviceView _ _ _ = 246 | Html.text "" 247 | 248 | 249 | {-| Convert a component `onSystem` field to an actor `onSystem` field 250 | -} 251 | wrapSystem : (msgIn -> appMsg) 252 | -> (SystemEvent -> SystemEvent.Handling msgIn) 253 | -> SystemEvent 254 | -> PID 255 | -> SystemEvent.Handling (SysMsg name appMsg) 256 | wrapSystem toSelf onSystem event pid = 257 | onSystem event 258 | |> SystemEvent.mapHandling (sendTo toSelf pid) 259 | 260 | 261 | {-| Convert a component `subs` field to an actor `subs` field 262 | -} 263 | wrapSub : 264 | (msgIn -> appMsg) 265 | -> (compModel -> Sub msgIn) 266 | -> compModel 267 | -> PID 268 | -> Sub (SysMsg name appMsg) 269 | wrapSub toSelf subs model pid = 270 | let 271 | sub = 272 | subs model 273 | in 274 | if sub == Sub.none then 275 | Sub.none 276 | 277 | else 278 | Sub.map 279 | (sendTo toSelf pid) 280 | sub 281 | 282 | 283 | {-| Convert a component `init` field to an actor `init` field 284 | -} 285 | wrapInit : Args name compModel appModel msgIn msgOut appMsg 286 | -> (PID -> ( compModel, List msgOut, Cmd msgIn )) 287 | -> PID 288 | -> ( appModel, SysMsg name appMsg ) 289 | wrapInit args implInit pid = 290 | implInit pid 291 | |> wrapTriple args pid 292 | |> Tuple.mapFirst args.wrapModel 293 | 294 | 295 | wrapTriple : Args name compModel appModel msgIn msgOut appMsg 296 | -> PID 297 | -> ( compModel, List msgOut, Cmd msgIn ) 298 | -> ( compModel, SysMsg name appMsg ) 299 | wrapTriple args pid ( model, msgsOut, cmd ) = 300 | let 301 | msgCmd = 302 | if cmd == Cmd.none then 303 | Msg.None 304 | 305 | else 306 | Cmd.map 307 | (sendTo args.wrapMsg pid) 308 | cmd 309 | |> Msg.Cmd 310 | |> Msg.Ctrl 311 | 312 | msg = 313 | List.map (args.mapOut pid) msgsOut 314 | |> (::) msgCmd 315 | |> Msg.Batch 316 | |> Msg.Ctrl 317 | |> Msg.Context pid 318 | in 319 | ( model 320 | , msg 321 | ) 322 | 323 | 324 | {-| Convert a component `update` field to an actor `update` field 325 | -} 326 | wrapUpdate : Args name compModel appModel msgIn msgOut msg 327 | -> (msgIn -> compModel -> ( compModel, List msgOut, Cmd msgIn )) 328 | -> (compModel -> SysMsg name msg -> PID -> ( appModel, SysMsg name msg )) 329 | wrapUpdate args update model msg pid = 330 | case msg of 331 | Msg.AppMsg appMsg -> 332 | case args.mapIn appMsg of 333 | Just msgIn -> 334 | update msgIn model 335 | |> wrapTriple args pid 336 | |> Tuple.mapFirst args.wrapModel 337 | 338 | Nothing -> 339 | ( args.wrapModel model, Msg.UnmappedMsg pid appMsg ) 340 | 341 | _ -> 342 | ( args.wrapModel model, Msg.None ) 343 | 344 | {-| Send to pid. 345 | -} 346 | sendTo : (msgIn -> appMsg) -> PID -> msgIn -> SysMsg name appMsg 347 | sendTo wrapper pid = 348 | wrapper 349 | >> Msg.AppMsg 350 | >> Msg.SendToPID pid 351 | >> Msg.Ctrl 352 | -------------------------------------------------------------------------------- /src/Webbhuset/ActorSystem.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.ActorSystem exposing 2 | ( AppliedActor 3 | , Actor 4 | , Model 5 | , SysMsg 6 | , Error(..) 7 | , PID 8 | , addView 9 | , application 10 | , applyModel 11 | , batch 12 | , element 13 | , kill 14 | , none 15 | , sendToPID 16 | , sendToSingleton 17 | , spawn 18 | , spawnSingleton 19 | , setDocumentTitle 20 | , withSingletonPID 21 | ) 22 | 23 | {-| 24 | 25 | @docs PID 26 | 27 | ## Build and Initialize the System 28 | 29 | @docs element 30 | , application 31 | 32 | 33 | ## System Messages 34 | 35 | @docs none 36 | , batch 37 | 38 | ## Processes 39 | 40 | Actors can be spawned (instantiated or started). A spawned actor is 41 | called Process. A process is referenced by its PID. 42 | 43 | Knowing an Actor's PID you can send messages to it or kill it. 44 | 45 | @docs spawn 46 | , sendToPID 47 | , kill 48 | 49 | ## Singleton Processes 50 | 51 | It can be helpful to treat some actors as a singleton process. They 52 | are started on application init and will always be running. 53 | Some examples are the Router actor or the Navigation. It does not make 54 | much sense having multiple of them either. 55 | 56 | A singleton process is just a normal actor that you can reference by 57 | its name instead of its PID. 58 | 59 | @docs spawnSingleton 60 | , sendToSingleton 61 | , withSingletonPID 62 | 63 | 64 | ## Program Output 65 | 66 | You Elm program's Html output (view function) is controlled here. 67 | You need to add at least one process to actually see anything more 68 | than just a blank page. 69 | 70 | @docs addView 71 | , setDocumentTitle 72 | 73 | 74 | ## Debug logging 75 | 76 | @docs Error 77 | 78 | ## Bootstrap 79 | 80 | Don't worry about these for now. 81 | 82 | @docs AppliedActor 83 | , Actor 84 | , Model 85 | , SysMsg 86 | , applyModel 87 | -} 88 | 89 | import Browser 90 | import Browser.Navigation as Nav 91 | import Dict exposing (Dict) 92 | import Set exposing (Set) 93 | import Html exposing (Html) 94 | import List.Extra as List 95 | import Random 96 | import Url exposing (Url) 97 | import Webbhuset.Internal.PID as PID exposing (PID(..)) 98 | import Webbhuset.Internal.Msg as Msg exposing (Msg(..), Control(..)) 99 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 100 | import Webbhuset.Internal.SystemEvent as Handling 101 | 102 | 103 | {-| A PID is an identifier for a Process. 104 | 105 | -} 106 | type alias PID = 107 | PID.PID 108 | 109 | 110 | 111 | {-| Your Elm Program will have this as its Msg type. 112 | 113 | -} 114 | type alias SysMsg name appMsg = 115 | Msg name appMsg 116 | 117 | 118 | 119 | {-| The Global Model 120 | 121 | -} 122 | type Model name appModel = 123 | Model (ModelRecord name appModel) 124 | 125 | 126 | type alias ModelRecord name appModel = 127 | { instances : Dict Int (Instance name appModel) 128 | , children : Dict Int (Set Int) 129 | , lastPID : Int 130 | , prefix : String 131 | , singleton : List ( name, PID ) 132 | , views : List PID 133 | , documentTitle : String 134 | } 135 | 136 | 137 | type alias Instance name appModel = 138 | { pid : PID 139 | , name : name 140 | , appModel : appModel 141 | } 142 | 143 | {-| An actor is a component that is configured to be part of the system. 144 | 145 | -} 146 | type alias Actor compModel appModel output msg = 147 | { init : PID -> ( appModel, msg ) 148 | , update : compModel -> msg -> PID -> ( appModel, msg ) 149 | , view : compModel -> PID -> (PID -> Maybe output) -> output 150 | , onSystem : SystemEvent -> PID -> SystemEvent.Handling msg 151 | , subs : compModel -> PID -> Sub msg 152 | } 153 | 154 | 155 | {-| An actor after the model has been applied 156 | 157 | -} 158 | type AppliedActor appModel output msg = 159 | AppliedActor 160 | { init : PID -> ( appModel, msg ) 161 | , update : msg -> PID -> ( appModel, msg ) 162 | , view : PID -> (PID -> Maybe output) -> output 163 | , onSystem : SystemEvent -> PID -> SystemEvent.Handling msg 164 | , subs : PID -> Sub msg 165 | } 166 | 167 | 168 | type alias Impl name appModel output appMsg a = 169 | { a 170 | | spawn : name -> PID -> ( appModel, SysMsg name appMsg ) 171 | , apply : appModel -> AppliedActor appModel output (SysMsg name appMsg) 172 | , onDebug : Error name appMsg -> SysMsg name appMsg 173 | } 174 | 175 | 176 | {-| The implementation of a Browser.element program 177 | 178 | -} 179 | type alias ElementImpl flags name appModel output appMsg = 180 | { init : flags -> SysMsg name appMsg 181 | , spawn : name -> PID -> ( appModel, SysMsg name appMsg ) 182 | , apply : appModel -> AppliedActor appModel output (SysMsg name appMsg) 183 | , view : List output -> Html (SysMsg name appMsg) 184 | , onDebug : Error name appMsg -> SysMsg name appMsg 185 | } 186 | 187 | 188 | {-| The implementation of a Browser.application program 189 | 190 | -} 191 | type alias ApplicationImpl flags name appModel output appMsg = 192 | { init : flags -> Url -> Nav.Key -> SysMsg name appMsg 193 | , spawn : name -> PID -> ( appModel, SysMsg name appMsg ) 194 | , apply : appModel -> AppliedActor appModel output (SysMsg name appMsg) 195 | , view : List output -> Html (SysMsg name appMsg) 196 | , onUrlRequest : Browser.UrlRequest -> SysMsg name appMsg 197 | , onUrlChange : Url -> SysMsg name appMsg 198 | , onDebug : Error name appMsg -> SysMsg name appMsg 199 | } 200 | 201 | 202 | {-| Developer errors 203 | 204 | -} 205 | type Error name appMsg 206 | = UnmappedInMsgFor name appMsg 207 | | Bug String 208 | 209 | 210 | {-| Don't send or do anything. 211 | 212 | Similar concept to `Cmd.none` 213 | 214 | -} 215 | none : SysMsg name appMsg 216 | none = 217 | None 218 | 219 | 220 | {-| Batch control messages 221 | 222 | Similar concept to `Cmd.batch` 223 | 224 | -} 225 | batch : List (SysMsg name appMsg) -> SysMsg name appMsg 226 | batch list = 227 | Ctrl (Batch list) 228 | 229 | 230 | {-| Send a message to a Process. 231 | 232 | If the target process does not exists the sender component will 233 | receive the `PIDNotFound` system event. (`onSystem`). 234 | 235 | -} 236 | sendToPID : PID -> appMsg -> SysMsg name appMsg 237 | sendToPID pid msg = 238 | Ctrl (SendToPID pid (AppMsg msg)) 239 | 240 | 241 | {-| Send a message to a Singleton Process 242 | 243 | -} 244 | sendToSingleton : name -> appMsg -> SysMsg name appMsg 245 | sendToSingleton name msg = 246 | Ctrl (SendToSingleton name (AppMsg msg)) 247 | 248 | 249 | {-| Start an Actor. This will create a process. The PID will 250 | be sent in a message using the provied message constructor. 251 | 252 | The new process will become a child process of the process that sent the 253 | spawn message. This relationship is used when a process is killed. 254 | 255 | 256 | Example - `Actor/PageLayout.elm`: 257 | 258 | System.spawn 259 | ActorName.LoginForm 260 | (\spawnedPID -> 261 | PageLayout.SetContent spawnedPID 262 | |> Msg.PageLayout 263 | |> System.sendToPID pageLayoutPID 264 | ) 265 | 266 | In this case the `LoginForm` will be a child of `PageLayout`. If `PageLayout` 267 | is killed the `LoginForm` will also be killed. 268 | 269 | -} 270 | spawn : name -> (PID -> SysMsg name appMsg) -> SysMsg name appMsg 271 | spawn name replyMsg = 272 | Ctrl (Spawn name replyMsg) 273 | 274 | 275 | {-| Spawn a singleton process. 276 | 277 | -} 278 | spawnSingleton : name -> SysMsg name appMsg 279 | spawnSingleton name = 280 | Ctrl (SpawnSingleton name) 281 | 282 | 283 | {-| Kill a process. This will also kill all the child processes by default. 284 | See Webbhuset.Component.SystemEvent. 285 | 286 | Singleton processes can not be killed. Attempts to do so will be ignored. 287 | 288 | -} 289 | kill : PID -> SysMsg name appMsg 290 | kill pid = 291 | Ctrl (Kill pid) 292 | 293 | 294 | {-| Add a process to the global output. 295 | 296 | -} 297 | addView : PID -> SysMsg name appMsg 298 | addView pid = 299 | Ctrl (AddView pid) 300 | 301 | 302 | {-| Set the document title. Only works with System.application 303 | 304 | -} 305 | setDocumentTitle : String -> SysMsg name appMsg 306 | setDocumentTitle title = 307 | SetDocumentTitle title 308 | 309 | 310 | {-| Do something with a singleton PID. 311 | 312 | Sometimes you want to send a singleton PID to a process. 313 | 314 | For example, add the root layout component to the system output. 315 | 316 | init flags = 317 | [ System.withSingletonPID ActorName.PageLayout System.addView 318 | ] 319 | 320 | 321 | Another example, you want to treat the site Header as a singleton 322 | which makes it easier to send messages to it. 323 | 324 | 325 | System.withSingletonPID 326 | ActorName.Header 327 | (\pid -> 328 | PageLayout.SetHeader pid 329 | |> Msg.PageLayout 330 | |> System.sendToSingleton ActorName.PageLayout 331 | ) 332 | 333 | -} 334 | withSingletonPID : name -> (PID -> SysMsg name appMsg) -> SysMsg name appMsg 335 | withSingletonPID name toMsg = 336 | Ctrl (WithSingletonPID name toMsg) 337 | 338 | 339 | 340 | {-| Apply the compModel to an actor. 341 | 342 | -} 343 | applyModel : Actor compModel appModel output msg -> compModel -> AppliedActor appModel output msg 344 | applyModel actor model = 345 | AppliedActor 346 | { init = actor.init 347 | , update = actor.update model 348 | , view = actor.view model 349 | , onSystem = actor.onSystem 350 | , subs = actor.subs model 351 | } 352 | 353 | 354 | {-| Create a [Browser.element] from your Actor System 355 | 356 | [Browser.element]: https://package.elm-lang.org/packages/elm/browser/latest/Browser#element 357 | 358 | -} 359 | element : 360 | { init : flags -> SysMsg name appMsg 361 | , spawn : name -> PID -> ( appModel, SysMsg name appMsg ) 362 | , apply : appModel -> AppliedActor appModel output (SysMsg name appMsg) 363 | , view : List output -> Html (SysMsg name appMsg) 364 | , onDebug : Error name appMsg -> SysMsg name appMsg 365 | } 366 | -> Program flags (Model name appModel) (SysMsg name appMsg) 367 | element impl = 368 | Browser.element 369 | { init = initElement impl 370 | , update = update impl Nothing 371 | , subscriptions = subscriptions impl 372 | , view = impl.view << view impl 373 | } 374 | 375 | 376 | {-| Create a [Browser.application] from your Actor System 377 | 378 | [Browser.application]: https://package.elm-lang.org/packages/elm/browser/latest/Browser#application 379 | 380 | -} 381 | application : 382 | { init : flags -> Url -> Nav.Key -> SysMsg name appMsg 383 | , spawn : name -> PID -> ( appModel, SysMsg name appMsg ) 384 | , apply : appModel -> AppliedActor appModel output (SysMsg name appMsg) 385 | , view : List output -> Html (SysMsg name appMsg) 386 | , onUrlRequest : Browser.UrlRequest -> SysMsg name appMsg 387 | , onUrlChange : Url -> SysMsg name appMsg 388 | , onDebug : Error name appMsg -> SysMsg name appMsg 389 | } 390 | -> Program flags (Model name appModel) (SysMsg name appMsg) 391 | application impl = 392 | Browser.application 393 | { init = initApplication impl 394 | , update = update impl Nothing 395 | , subscriptions = subscriptions impl 396 | , view = applicationView impl 397 | , onUrlRequest = impl.onUrlRequest 398 | , onUrlChange = impl.onUrlChange 399 | } 400 | 401 | 402 | applicationView : ApplicationImpl flags name appModel output appMsg 403 | -> Model name appModel 404 | -> Browser.Document (SysMsg name appMsg) 405 | applicationView impl ((Model modelRecord) as model) = 406 | view impl model 407 | |> impl.view 408 | |> (\html -> { title = modelRecord.documentTitle, body = [ html ] }) 409 | 410 | 411 | initElement : ElementImpl flags name appModel output appMsg -> flags -> ( Model name appModel, Cmd (SysMsg name appMsg) ) 412 | initElement impl flags = 413 | ( { instances = Dict.empty 414 | , children = Dict.empty 415 | , lastPID = 100 416 | , prefix = "" 417 | , singleton = [] 418 | , views = [] 419 | , documentTitle = "" 420 | } 421 | |> Model 422 | , Random.generate 423 | (Init (impl.init flags)) 424 | prefixGenerator 425 | ) 426 | 427 | 428 | initApplication : 429 | ApplicationImpl flags name appModel output appMsg 430 | -> flags 431 | -> Url 432 | -> Nav.Key 433 | -> ( Model name appModel, Cmd (SysMsg name appMsg) ) 434 | initApplication impl flags url key = 435 | ( { instances = Dict.empty 436 | , children = Dict.empty 437 | , lastPID = 100 438 | , prefix = "" 439 | , singleton = [] 440 | , views = [] 441 | , documentTitle = "" 442 | } 443 | |> Model 444 | , Random.generate 445 | (Init (impl.init flags url key)) 446 | prefixGenerator 447 | ) 448 | 449 | 450 | prefixGenerator : Random.Generator String 451 | prefixGenerator = 452 | Random.int 0 60 453 | |> Random.list 16 454 | |> Random.map 455 | (List.map 456 | (\n -> 457 | if n < 10 then 458 | Char.fromCode (n + 48) 459 | 460 | else if n < 35 then 461 | Char.fromCode (n + 55) 462 | 463 | else 464 | Char.fromCode (n + 62) 465 | ) 466 | >> String.fromList 467 | ) 468 | 469 | 470 | collectAppMsgs : SysMsg name appMsg -> List (SysMsg name appMsg) 471 | collectAppMsgs msg = 472 | case msg of 473 | AppMsg _ -> 474 | [ msg ] 475 | 476 | Ctrl (Batch list) -> 477 | List.concatMap collectAppMsgs list 478 | 479 | _ -> 480 | [] 481 | 482 | 483 | composeSysMsg : SysMsg name appMsg -> SysMsg name appMsg -> SysMsg name appMsg 484 | composeSysMsg msg1 msg2 = 485 | if msg1 == None then 486 | msg2 487 | else if msg2 == None then 488 | msg1 489 | else 490 | [ msg1, msg2 ] 491 | |> Batch 492 | |> Ctrl 493 | 494 | 495 | update : 496 | Impl name appModel output appMsg a 497 | -> Maybe PID 498 | -> SysMsg name appMsg 499 | -> Model name appModel 500 | -> ( Model name appModel, Cmd (SysMsg name appMsg) ) 501 | update impl context msg ((Model modelRecord) as model) = 502 | case msg of 503 | None -> 504 | ( model, Cmd.none ) 505 | 506 | AppMsg _ -> 507 | update 508 | impl 509 | context 510 | (Bug "AppMsg on the fly. This should never happen." 511 | |> impl.onDebug 512 | ) 513 | model 514 | 515 | Init initMsg prefix -> 516 | { modelRecord | prefix = prefix } 517 | |> Model 518 | |> update impl context initMsg 519 | 520 | UnmappedMsg pid appMsg -> 521 | case getProcess pid modelRecord of 522 | Just process -> 523 | update 524 | impl 525 | context 526 | (UnmappedInMsgFor process.name appMsg 527 | |> impl.onDebug 528 | ) 529 | model 530 | 531 | Nothing -> 532 | update 533 | impl 534 | context 535 | (Bug "Process does not exist. This should never happen." 536 | |> impl.onDebug 537 | ) 538 | model 539 | 540 | Context pid subMsg -> 541 | update impl (Just pid) subMsg model 542 | 543 | SetDocumentTitle title -> 544 | ( { modelRecord | documentTitle = title } 545 | |> Model 546 | , Cmd.none 547 | ) 548 | 549 | Ctrl ctrlMsg -> 550 | case ctrlMsg of 551 | Batch listOfMsgs -> 552 | listOfMsgs 553 | |> List.foldl 554 | (\batchMsg previous -> 555 | cmdAndThen (update impl context batchMsg) previous 556 | ) 557 | ( model, Cmd.none ) 558 | 559 | Cmd cmd -> 560 | ( model, cmd ) 561 | 562 | SendToPID pid message -> 563 | case getProcess pid modelRecord of 564 | Just { name, appModel } -> 565 | let 566 | appMsgs = 567 | collectAppMsgs message 568 | 569 | ( m2, newMsg ) = 570 | appMsgs 571 | |> List.foldl 572 | (\appMsg ( mod0, sysMsg0 ) -> 573 | let 574 | (AppliedActor applied) = 575 | impl.apply mod0 576 | 577 | (mod1, sysMsg1) = 578 | applied.update appMsg pid 579 | in 580 | ( mod1 581 | , composeSysMsg sysMsg0 sysMsg1 582 | ) 583 | 584 | ) 585 | (appModel, None) 586 | |> Tuple.mapFirst (updateInstanceIn modelRecord name pid >> Model) 587 | in 588 | update impl context newMsg m2 589 | 590 | Nothing -> 591 | context 592 | |> Maybe.map 593 | (\senderPID -> 594 | case getProcess senderPID modelRecord of 595 | Just senderProcess -> 596 | let 597 | (AppliedActor applied) = 598 | impl.apply senderProcess.appModel 599 | 600 | whatToDo = 601 | applied.onSystem (SystemEvent.PIDNotFound pid) senderPID 602 | in 603 | case whatToDo of 604 | Handling.Default -> 605 | ( model, Cmd.none ) 606 | 607 | Handling.DoNothing -> 608 | ( model, Cmd.none ) 609 | 610 | Handling.HandleWith senderMsg -> 611 | update impl context senderMsg model 612 | 613 | Nothing -> 614 | ( model, Cmd.none ) -- Should never happen. 615 | ) 616 | |> Maybe.withDefault 617 | ( model, Cmd.none ) 618 | 619 | SendToSingleton name message -> 620 | case findSingletonPID name modelRecord of 621 | Just pid -> 622 | update impl context (Ctrl (SendToPID pid message)) model 623 | 624 | Nothing -> 625 | update impl context (spawnSingleton name) model 626 | |> cmdAndThen (update impl context msg) 627 | 628 | Spawn name replyMsg -> 629 | let 630 | ( m2, pid ) = 631 | newPID context False modelRecord 632 | 633 | ( m3, newMsg ) = 634 | spawn_ impl name pid m2 635 | in 636 | update impl context newMsg (Model m3) 637 | |> cmdAndThen (update impl context (replyMsg pid)) 638 | 639 | Kill pid -> 640 | handleKill impl context pid model 641 | 642 | SpawnSingleton name -> 643 | let 644 | ( m2, pid ) = 645 | newPID context True modelRecord 646 | 647 | ( m3, newMsg ) = 648 | appendSingleton name pid m2 649 | |> spawn_ impl name pid 650 | in 651 | update impl context newMsg (Model m3) 652 | 653 | AddView pid -> 654 | ( { modelRecord | views = pid :: modelRecord.views } 655 | |> Model 656 | , Cmd.none 657 | ) 658 | 659 | WithSingletonPID name makeMsg -> 660 | case findSingletonPID name modelRecord of 661 | Just pid -> 662 | update impl context (makeMsg pid) model 663 | 664 | Nothing -> 665 | update impl context (spawnSingleton name) model 666 | |> cmdAndThen (update impl context msg) 667 | 668 | 669 | handleKill : Impl name appMod output appMsg a 670 | -> Maybe PID 671 | -> PID 672 | -> Model name appMod 673 | -> ( Model name appMod, Cmd (SysMsg name appMsg) ) 674 | handleKill impl context ((PID pidMeta) as pid) ((Model modelRecord) as model) = 675 | if pidMeta.isSingleton then 676 | ( model, Cmd.none ) 677 | else 678 | let 679 | children = 680 | Dict.get pidMeta.key modelRecord.children 681 | |> Maybe.map 682 | (Set.toList 683 | >> List.filterMap 684 | (\key -> 685 | Dict.get key modelRecord.instances 686 | |> Maybe.map .pid 687 | ) 688 | ) 689 | |> Maybe.withDefault [] 690 | in 691 | case Dict.get pidMeta.key modelRecord.instances of 692 | Just { appModel } -> 693 | let 694 | (AppliedActor applied) = 695 | impl.apply appModel 696 | 697 | whatToDo = 698 | applied.onSystem (SystemEvent.Kill) pid 699 | in 700 | case whatToDo of 701 | Handling.Default -> 702 | children 703 | |> List.foldl 704 | (\childPID previous -> 705 | cmdAndThen (handleKill impl context childPID) previous 706 | ) 707 | ( model, Cmd.none ) 708 | |> Tuple.mapFirst 709 | (\(Model modelRecord_) -> 710 | { modelRecord_ 711 | | instances = Dict.remove pidMeta.key modelRecord_.instances 712 | , children = Dict.remove pidMeta.key modelRecord_.children 713 | } 714 | |> Model 715 | ) 716 | 717 | Handling.DoNothing -> 718 | ( model, Cmd.none ) 719 | 720 | Handling.HandleWith componentLastWords -> 721 | { modelRecord 722 | | instances = Dict.remove pidMeta.key modelRecord.instances 723 | , children = Dict.remove pidMeta.key modelRecord.children 724 | } 725 | |> Model 726 | |> update impl context componentLastWords 727 | 728 | Nothing -> 729 | ( model, Cmd.none ) 730 | 731 | 732 | spawn_ : Impl name appModel output appMsg a -> name -> PID -> ModelRecord name appModel -> ( ModelRecord name appModel, SysMsg name appMsg ) 733 | spawn_ impl name pid model = 734 | impl.spawn name pid 735 | |> Tuple.mapFirst (updateInstanceIn model name pid) 736 | 737 | 738 | newPID : Maybe PID -> Bool -> ModelRecord name appModel -> ( ModelRecord name appModel, PID ) 739 | newPID context isSingleton model = 740 | let 741 | parent = 742 | Maybe.map (\(PID { key }) -> key) context 743 | |> Maybe.withDefault 0 744 | in 745 | { key = model.lastPID 746 | , prefix = model.prefix 747 | , isSingleton = isSingleton 748 | , spawnedBy = parent 749 | } 750 | |> PID 751 | |> Tuple.pair 752 | { model 753 | | lastPID = 1 + model.lastPID 754 | , children = 755 | Dict.update 756 | parent 757 | (\mbSet -> 758 | case mbSet of 759 | Just set -> 760 | Set.insert model.lastPID set 761 | |> Just 762 | 763 | Nothing -> 764 | Set.singleton model.lastPID 765 | |> Just 766 | ) 767 | model.children 768 | } 769 | 770 | 771 | getProcess : PID -> ModelRecord name appModel -> Maybe (Instance name appModel) 772 | getProcess (PID { key }) model = 773 | Dict.get key model.instances 774 | 775 | 776 | updateInstanceIn : ModelRecord name appModel -> name -> PID -> appModel -> ModelRecord name appModel 777 | updateInstanceIn model name ((PID { key }) as pid) appModel = 778 | { model 779 | | instances = Dict.insert key { pid = pid, name = name, appModel = appModel } model.instances 780 | } 781 | 782 | 783 | appendSingleton : name -> PID -> ModelRecord name appModel -> ModelRecord name appModel 784 | appendSingleton name pid model = 785 | { model 786 | | singleton = ( name, pid ) :: model.singleton 787 | } 788 | 789 | 790 | findSingletonPID : name -> ModelRecord name appModel -> Maybe PID 791 | findSingletonPID name model = 792 | model.singleton 793 | |> List.find (\( a, _ ) -> a == name) 794 | |> Maybe.map Tuple.second 795 | 796 | 797 | subscriptions : Impl name appModel output appMsg a -> Model name appModel -> Sub (SysMsg name appMsg) 798 | subscriptions impl (Model model) = 799 | model.instances 800 | |> Dict.foldl 801 | (\key { pid, appModel } subs -> 802 | let 803 | (AppliedActor applied) = 804 | impl.apply appModel 805 | 806 | sub = 807 | applied.subs pid 808 | in 809 | if sub == Sub.none then 810 | subs 811 | 812 | else 813 | sub :: subs 814 | ) 815 | [] 816 | |> Sub.batch 817 | 818 | 819 | view : Impl name appModel output appMsg a -> Model name appModel -> List output 820 | view impl (Model model) = 821 | model.views 822 | |> List.filterMap 823 | (renderPID 824 | (\{ appModel } -> 825 | let 826 | (AppliedActor applied) = 827 | impl.apply appModel 828 | in 829 | applied.view 830 | ) 831 | model.instances 832 | ) 833 | 834 | 835 | renderPID : (appModel -> PID -> (PID -> Maybe output) -> output) -> Dict Int appModel -> PID -> Maybe output 836 | renderPID renderActor dict ((PID { key }) as pid) = 837 | Dict.get key dict 838 | |> Maybe.map 839 | (\appModel -> 840 | renderActor appModel pid (renderPID renderActor dict) 841 | ) 842 | 843 | 844 | cmdAndThen : (m -> ( m, Cmd msg )) -> ( m, Cmd msg ) -> ( m, Cmd msg ) 845 | cmdAndThen fn ( m0, cmd0 ) = 846 | let 847 | ( m1, cmd1 ) = 848 | fn m0 849 | in 850 | ( m1, Cmd.batch [ cmd0, cmd1 ] ) 851 | -------------------------------------------------------------------------------- /src/Webbhuset/Component.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Component exposing 2 | ( Layout 3 | , Service 4 | , UI 5 | , PID 6 | , Queue 7 | , addCmd 8 | , addOutMsg 9 | , addToQueue 10 | , emptyQueue 11 | , andThen 12 | , mapFirst 13 | , mapSecond 14 | , mapThird 15 | , runQueue 16 | , toCmd 17 | , toCmdWithDelay 18 | ) 19 | 20 | {-| 21 | 22 | @docs PID 23 | 24 | # Components 25 | 26 | A component is a independent part in the system and has a single responsibility. They 27 | can not import other components. 28 | 29 | Components are like normal elm programs. They have their own 30 | model, they can do commands and subscriptions. In addition to that 31 | they also have out messages. 32 | 33 | This means you will have two `Msg` types: `MsgIn` and `MsgOut`. MsgIn 34 | is conceptually the same as your normal `Msg` type would be. 35 | 36 | MsgOut is a way to "tell" the rest of the system that something happened in your component. 37 | 38 | For Example, the msg types for a login form component could look like this: 39 | 40 | type MsgIn 41 | = EmailFieldChanged String 42 | | PasswordFieldChanged String 43 | | SubmitbuttonClicked 44 | 45 | type MsgOut 46 | = FormWasSubmitted 47 | { email : String 48 | , password : String 49 | } 50 | 51 | From the system's perspective, this is all you need to care about. This 52 | is the public API for the component. 53 | 54 | The normal output tuple from the `init` and `update` functions are replaced with 55 | a 3-Tuple: 56 | 57 | ( Model, List MsgOut, Cmd MsgIn ) 58 | 59 | ## UI Component 60 | 61 | A UI-component is very similar in concept to a Browser.element program. 62 | 63 | @docs UI 64 | 65 | ## Service Component 66 | 67 | The service component does not have any view function. Remember `Platform.worker`? 68 | 69 | @docs Service 70 | 71 | ## Layout Component 72 | 73 | A layout component can render other components using their PID as a reference. 74 | The difference comparing to a UI component is the view function. 75 | 76 | @docs Layout 77 | 78 | ## Helpers for the output 3-Tuple 79 | 80 | There is no native elm module for a Tuple with three arguments. 81 | 82 | @docs mapFirst 83 | , mapSecond 84 | , mapThird 85 | , andThen 86 | , addOutMsg 87 | , addCmd 88 | , toCmd 89 | , toCmdWithDelay 90 | 91 | ## Helper for Queue 92 | 93 | Sometimes you'd want to put messages in a queue. Maybe your 94 | component is in a state where it can't process them at this point, eg. an InitState. 95 | 96 | @docs Queue 97 | , emptyQueue 98 | , addToQueue 99 | , runQueue 100 | -} 101 | import Html exposing (Html) 102 | import Webbhuset.Internal.PID as PID 103 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 104 | import Task 105 | import Process 106 | 107 | 108 | {-| A PID is an identifier for a Process. 109 | 110 | -} 111 | type alias PID = 112 | PID.PID 113 | 114 | 115 | {-| Service Component Type 116 | 117 | -} 118 | type alias Service model msgIn msgOut = 119 | { init : PID -> ( model, List msgOut, Cmd msgIn ) 120 | , update : msgIn -> model -> ( model, List msgOut, Cmd msgIn ) 121 | , onSystem : SystemEvent -> SystemEvent.Handling msgIn 122 | , subs : model -> Sub msgIn 123 | } 124 | 125 | 126 | {-| UI Component Type 127 | 128 | - **init**: Is called everytime the component is instantiated. 129 | - **update**: When the component recieves a message. 130 | - **view**: Is called when the app needs to re-render. 131 | - **onSystem**: Called when a system event happens. See Webbhuset.Component.SystemEvent. 132 | - **subs**: Normal Elm Subscriptions, called after update. 133 | 134 | -} 135 | type alias UI model msgIn msgOut = 136 | { init : PID -> ( model, List msgOut, Cmd msgIn ) 137 | , update : msgIn -> model -> ( model, List msgOut, Cmd msgIn ) 138 | , view : model -> Html msgIn 139 | , onSystem : SystemEvent -> SystemEvent.Handling msgIn 140 | , subs : model -> Sub msgIn 141 | } 142 | 143 | 144 | {-| Layout Component Type 145 | 146 | The `view` function of a layout component: 147 | 148 | view : (MsgIn -> msg) -> Model -> (PID -> Html msg) -> Html msg 149 | view toSelf model renderPID = 150 | div 151 | [] 152 | [ renderPID model.child 153 | , button [ onClick (toSelf ButtonWasClicked) ] [ text "Button!" ] 154 | ] 155 | 156 | The `view` function has three arguments: 157 | 158 | - `toSelf` is used to wrap all event-handlers from Html.Events 159 | - `renderPID` is used to render other components. 160 | 161 | As you can see, the output type of the `view` function is `Html msg`. This is 162 | necessary to allow components to be composed. What would the return type be on 163 | `renderPID` if they were not mapped to the same type? 164 | -} 165 | type alias Layout model msgIn msgOut msg = 166 | { init : PID -> ( model, List msgOut, Cmd msgIn ) 167 | , update : msgIn -> model -> ( model, List msgOut, Cmd msgIn ) 168 | , view : (msgIn -> msg) -> model -> (PID -> Html msg) -> Html msg 169 | , onSystem : SystemEvent -> SystemEvent.Handling msgIn 170 | , subs : model -> Sub msgIn 171 | } 172 | 173 | 174 | {-| Store messages in a queue. 175 | 176 | -} 177 | type Queue msgIn = 178 | Queue (List msgIn) 179 | 180 | {-| Run a series of updates on the model 181 | 182 | The msgOut's and Cmd's will be composed using `System.batch` and 183 | `Cmd.batch`. 184 | 185 | ( model, [], Cmd.none ) 186 | |> Component.andThen doSomethingWithModel 187 | -} 188 | andThen : 189 | (model -> ( model, List msgOut, Cmd msgIn )) 190 | -> ( model, List msgOut, Cmd msgIn ) 191 | -> ( model, List msgOut, Cmd msgIn ) 192 | andThen fn ( m0, out0, cmd0 ) = 193 | let 194 | ( m1, out1, cmd1 ) = 195 | fn m0 196 | in 197 | ( m1 198 | , out0 ++ out1 199 | , Cmd.batch 200 | [ cmd0 201 | , cmd1 202 | ] 203 | ) 204 | 205 | 206 | {-| Map the first argument (Model). 207 | 208 | -} 209 | mapFirst : (input -> out) -> ( input, x, y ) -> ( out, x, y ) 210 | mapFirst fn ( a, x, y ) = 211 | ( fn a, x, y ) 212 | 213 | 214 | {-| Map the second argument (List MsgOut). 215 | 216 | -} 217 | mapSecond : (input -> out) -> ( x, input, y ) -> ( x, out, y ) 218 | mapSecond fn ( x, a, y ) = 219 | ( x, fn a, y ) 220 | 221 | 222 | {-| Map the third argument (Cmd). 223 | 224 | -} 225 | mapThird : (input -> out) -> ( x, y, input ) -> ( x, y, out ) 226 | mapThird fn ( x, y, a ) = 227 | ( x, y, fn a ) 228 | 229 | 230 | {-| Add an out message to the output 3-Tuple. 231 | 232 | ( model, [], Cmd.none ) 233 | |> Component.addOutMsg SomeOutMsg 234 | -} 235 | addOutMsg : msg -> ( x, List msg, y ) -> ( x, List msg, y ) 236 | addOutMsg msg ( x, list, y ) = 237 | ( x, msg :: list, y ) 238 | 239 | 240 | {-| Add a Cmd to the output 3-Tuple. 241 | 242 | ( model, [], Cmd.none ) 243 | |> Component.addCmd cmd 244 | -} 245 | addCmd : Cmd msg -> ( x, y, Cmd msg ) -> ( x, y, Cmd msg ) 246 | addCmd cmd1 ( x, y, cmd0 ) = 247 | ( x, y, Cmd.batch [ cmd0, cmd1 ] ) 248 | 249 | 250 | {-| Convert a msg to Cmd. 251 | 252 | -} 253 | toCmd : msg -> Cmd msg 254 | toCmd msg = 255 | Task.perform identity 256 | (Task.succeed msg) 257 | 258 | 259 | {-| Convert a msg to Cmd with a timeout in milliseconds. 260 | 261 | -} 262 | toCmdWithDelay : Float -> msg -> Cmd msg 263 | toCmdWithDelay delay msg = 264 | Task.perform identity 265 | (Process.sleep delay 266 | |> Task.andThen (\_ -> Task.succeed msg) 267 | ) 268 | 269 | 270 | {-| Create an Empty Queue 271 | 272 | { model 273 | | queue = Component.emptyQueue 274 | } 275 | -} 276 | emptyQueue : Queue msgIn 277 | emptyQueue = 278 | Queue [] 279 | 280 | 281 | {-| Run the `update` function on all messages in the queue 282 | and compose all output. 283 | 284 | ( model, [], Cmd.none ) 285 | |> Component.runQueue queue update 286 | -} 287 | runQueue : 288 | Queue msgIn 289 | -> (msgIn -> model -> ( model, List msgOut, Cmd msgIn )) 290 | -> ( model, List msgOut, Cmd msgIn ) 291 | -> ( model, List msgOut, Cmd msgIn ) 292 | runQueue (Queue queuedMsgs) update initial = 293 | List.foldr 294 | (\qMsg triplet -> andThen (update qMsg) triplet) 295 | initial 296 | queuedMsgs 297 | 298 | 299 | {-| Add a msg to the queue 300 | 301 | { model 302 | | queue = Component.addToQueue msgIn model.queue 303 | } 304 | -} 305 | addToQueue : msgIn -> Queue msgIn -> Queue msgIn 306 | addToQueue msg (Queue queue) = 307 | msg :: queue 308 | |> Queue 309 | -------------------------------------------------------------------------------- /src/Webbhuset/Component/Sandbox.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Component.Sandbox exposing 2 | ( SandboxProgram 3 | , TestCase 4 | , Action 5 | , Msg 6 | , ui 7 | , layout 8 | , service 9 | , sendMsg 10 | , delay 11 | , spawnChild 12 | , pass 13 | , fail 14 | , timeout 15 | , permuteInitOrder 16 | , mockPID 17 | , checkPID 18 | , assertPID 19 | ) 20 | 21 | {-| 22 | 23 | # Sandbox 24 | 25 | The sandbox module is helpful when developing components. It lets you 26 | run the component using `elm reactor` outside the system and define several test cases. 27 | 28 | If you want to run your sandbox on a CI you can add #markdown to the URL. This 29 | will output the test results as a markdown string inside a pre element: 30 | 31 | 
 Results here
32 | 33 | This way you can complile the sandbox, run it in a headless Chrome and dump 34 | the DOM. From the DOM you can extract the results. 35 | 36 | @docs SandboxProgram 37 | 38 | 39 | # Create Sandbox 40 | 41 | Wrap a component in a sandbox application. 42 | 43 | This will render each test case and log all messages. 44 | Create a test file with a `main` function where you declare all 45 | test cases. 46 | 47 | A sandbox module example for `YourComponent`: 48 | 49 | import YourComponent exposing (Model, MsgIn, MsgOut) 50 | 51 | main : SandboxProgram Model MsgIn MsgOut 52 | main = 53 | Sandbox.ui 54 | { title = "Title of your component" 55 | , component = YourComponent.component 56 | , cases = 57 | [ testCase1 58 | , testCase2 59 | ] 60 | , stringifyMsgIn = Debug.toString -- Or roll your own if you want prettier messages. 61 | , stringifyMsgOut = Debug.toString 62 | , wrapView = identity 63 | } 64 | 65 | 66 | @docs ui, layout, service 67 | 68 | # Create a Test Case 69 | 70 | Test cases defines scenarios for the requirements of your component. 71 | 72 | A Test Case is just a record with a title and description together 73 | with a list of Actions you want to perform on your sandboxed component. 74 | You can also map the component's out messages to actions to simulate the outside system. 75 | 76 | @docs TestCase 77 | 78 | testCase1 : Sandbox.TestCase MsgIn MsgOut 79 | testCase1 = 80 | { title = "Test Case Title" 81 | , desc = "Test Case Description" 82 | , init = 83 | [ Sandbox.sendMsg YourComponent.Hello 84 | , Sandbox.spawnChild "Child Title" YourComponent.ReceiveChildPID 85 | ] 86 | , onMsgOut = \msgOut -> 87 | case msgOut of 88 | YourComponent.ObserveSomething id -> 89 | [ YourComponent.RecevieDataFor id "Some data" 90 | |> Sandbox.sendMsg 91 | |> Sandbox.delay 1000 92 | ] 93 | 94 | ## Actions 95 | 96 | @docs Action, sendMsg, spawnChild, delay 97 | 98 | ## Assertions 99 | 100 | Sometimes it is useful to test your expectations or requirements on a component. 101 | 102 | You can express them using assertions. Assertions have three states: waiting, pass 103 | or fail. The state of a test case is visible in the sandbox UI. 104 | 105 | In this example we expect that `GoodMsg` is sent by the component within 1s. 106 | 107 | testGoodMsg : Sandbox.TestCase MsgIn MsgOut 108 | testGoodMsg = 109 | { title = "Good messages are good" 110 | , desc = "`GoodMsg` must be sent within 1 second. No other messages are allowed." 111 | , init = 112 | [ Sandbox.timeout 1000 113 | , Sandbox.sendMsg YourComponent.SomeInput 114 | ] 115 | , onMsgOut = \msgOut -> 116 | case msgOut of 117 | YourComponent.GoodMsg -> 118 | [ Sandbox.pass 119 | ] 120 | 121 | YourComponent.BadMsg -> 122 | [ Sandbox.fail "I don't like bad messages" 123 | ] 124 | 125 | 126 | @docs pass, fail, timeout 127 | 128 | ## Permutate the init order 129 | 130 | Sometimes it is useful to test if the order of your init messages would 131 | affect the test result. One way to do so is by permuting all possible 132 | orders and test them. 133 | 134 | @docs permuteInitOrder 135 | 136 | ## Assert PIDs 137 | 138 | @docs mockPID, checkPID, assertPID 139 | 140 | @docs Msg 141 | 142 | -} 143 | 144 | import Dict exposing (Dict) 145 | import Html exposing (Html) 146 | import Html.Attributes as HA 147 | import Html.Events as Events 148 | import Webbhuset.Actor as Actor exposing (Actor) 149 | import Webbhuset.ActorSystem as System 150 | import Webbhuset.Component as Component 151 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 152 | import Webbhuset.Component.Sandbox.Navigation as Navigation 153 | import Webbhuset.Component.Sandbox.LoremIpsum as LoremIpsum 154 | import Webbhuset.Component.Sandbox.Layout as Layout 155 | import Webbhuset.Internal.PID exposing (PID(..)) 156 | import Webbhuset.PID as PID 157 | import Browser.Navigation as Nav 158 | import Browser 159 | import Markdown 160 | import Url exposing (Url) 161 | import List.Extra as List 162 | 163 | 164 | {-| The Application model 165 | 166 | -} 167 | type alias Model m o = 168 | System.Model ActorName (Process m o) 169 | 170 | 171 | {-| The Program type of your main function. 172 | 173 | -} 174 | type alias SandboxProgram model msgIn msgOut = 175 | Program () (Model model msgOut) (Msg msgIn msgOut) 176 | 177 | 178 | {-| A test case for the Component 179 | 180 | -} 181 | type alias TestCase msgIn msgOut = 182 | { title : String 183 | , desc : String 184 | , init : List (Action msgIn) 185 | , onMsgOut : msgOut -> List (Action msgIn) 186 | } 187 | 188 | 189 | {-| An action to perform on your sandboxed component. 190 | 191 | -} 192 | type alias Action msgIn 193 | = Layout.Action msgIn 194 | 195 | {-| Spawn a child component and send the PID to your component. 196 | 197 | You can provide a String which will be displayed when the child 198 | component is rendered (using `renderPID` in your layout component). 199 | 200 | 201 | Sandbox.spawnChild "Hello child" YourComponent.ReceiveChild 202 | 203 | -} 204 | spawnChild : String -> (PID -> msgIn) -> Action msgIn 205 | spawnChild = 206 | Layout.SpawnChild 207 | 208 | 209 | 210 | {-| Perform a delayed action on your sandboxed component. Delay in 211 | milliseconds. 212 | 213 | Sandbox.sendMsg YourComponent.SomeMessage 214 | |> Sandbox.delay 1000 215 | 216 | -} 217 | delay : Float -> Action msgIn -> Action msgIn 218 | delay = 219 | Layout.Delay 220 | 221 | 222 | {-| Send a message to you sandboxed component 223 | 224 | Sandbox.sendMsg YourComponent.SomeMessage 225 | 226 | -} 227 | sendMsg : msgIn -> Action msgIn 228 | sendMsg = 229 | Layout.SendMsg 230 | 231 | 232 | {-| Flag test case as passed. 233 | 234 | Sandbox.pass 235 | -} 236 | pass : Action msgIn 237 | pass = 238 | Layout.Pass 239 | 240 | 241 | {-| Flag test case as failed. You can supply a message explaining what 242 | went wrong. 243 | 244 | Sandbox.fail "Didn't receive some important out msg" 245 | -} 246 | fail : String -> Action msgIn 247 | fail reason = 248 | Layout.Fail reason 249 | 250 | 251 | {-| Set a timeout in milliseconds. This will cause the test to automatically fail 252 | after the timeout if the test havn't been flagged as passed by then. 253 | 254 | Sandbox.timeout 1000 255 | -} 256 | timeout : Float -> Action msgIn 257 | timeout t = 258 | "Timeout: " ++ (String.fromFloat t) ++ "ms" 259 | |> Layout.Timeout 260 | |> Layout.Delay t 261 | 262 | 263 | {-| Take one test case and permute all possible orders of init messages. 264 | 265 | 266 | -} 267 | permuteInitOrder : TestCase msgIn msgOut -> List (TestCase msgIn msgOut) 268 | permuteInitOrder testCase = 269 | let 270 | (affected, notAffected) = 271 | testCase.init 272 | |> List.partition isAffectedByOrder 273 | in 274 | List.permutations affected 275 | |> List.indexedMap 276 | (\idx permutation -> 277 | { testCase 278 | | init = permutation ++ notAffected 279 | , title = testCase.title ++ " (permutation " ++ (String.fromInt <| 1 + idx) ++ ")" 280 | } 281 | ) 282 | 283 | 284 | isAffectedByOrder : Action i -> Bool 285 | isAffectedByOrder action = 286 | case action of 287 | Layout.SendMsg _ -> 288 | True 289 | 290 | Layout.SpawnChild _ _ -> 291 | True 292 | 293 | Layout.Delay _ a -> 294 | isAffectedByOrder a 295 | 296 | Layout.Pass -> 297 | False 298 | 299 | Layout.Fail _ -> 300 | False 301 | 302 | Layout.Timeout _ -> 303 | False 304 | 305 | {-| Create a mock PID for testing purposes. 306 | 307 | mockPID "form-component" 308 | 309 | -} 310 | mockPID : String -> PID 311 | mockPID label = 312 | PID 313 | { isSingleton = False 314 | , prefix = label 315 | , key = 0 316 | , spawnedBy = 0 317 | } 318 | 319 | 320 | {-| Check that a mock pid matches an expected label. 321 | 322 | This will return `True` 323 | 324 | mockPID "form-component" 325 | |> checkPID "form-component" 326 | 327 | -} 328 | checkPID : String -> PID -> Bool 329 | checkPID label (PID { prefix } ) = 330 | label == prefix 331 | 332 | 333 | {-| Assert that a PID matches a label. 334 | 335 | This will result in action `pass` 336 | 337 | mockPID "form-component" 338 | |> assertPID "form-component" 339 | 340 | This will result in the action 341 | `fail "PID form-component does not match expectation other-component"` 342 | 343 | mockPID "form-component" 344 | |> assertPID "other-component" 345 | 346 | -} 347 | assertPID : String -> PID -> Action msgIn 348 | assertPID expected (PID { prefix }) = 349 | if prefix == expected then 350 | pass 351 | else 352 | "PID \"" ++ prefix ++ "\"does not match expectation \"" ++ expected 353 | |> fail 354 | 355 | 356 | {-| Sandbox a UI Component 357 | 358 | -} 359 | ui : 360 | { title : String 361 | , component : Component.UI model msgIn msgOut 362 | , cases : List (TestCase msgIn msgOut) 363 | , stringifyMsgIn : msgIn -> String 364 | , stringifyMsgOut : msgOut -> String 365 | , wrapView : Html msgIn -> Html msgIn 366 | } 367 | -> SandboxProgram model msgIn msgOut 368 | ui ({ component } as args) = 369 | Actor.fromUI 370 | { wrapModel = P_Component 371 | , wrapMsg = ComponentMsg 372 | , mapIn = testedMapIn 373 | , mapOut = testedMapOut args.stringifyMsgOut 374 | } 375 | { init = component.init 376 | , update = component.update 377 | , onSystem = component.onSystem 378 | , subs = component.subs 379 | , view = component.view >> args.wrapView 380 | } 381 | |> toApplication 382 | { title = args.title 383 | , cases = args.cases 384 | , stringifyMsgIn = args.stringifyMsgIn 385 | , stringifyMsgOut = args.stringifyMsgOut 386 | } 387 | 388 | 389 | {-| Sandbox a Layout Component 390 | 391 | -} 392 | layout : 393 | { title : String 394 | , component : Component.Layout model msgIn msgOut (Msg msgIn msgOut) 395 | , cases : List (TestCase msgIn msgOut) 396 | , stringifyMsgIn : msgIn -> String 397 | , stringifyMsgOut : msgOut -> String 398 | , wrapView : (msgIn -> Msg msgIn msgOut) -> Html (Msg msgIn msgOut) -> Html (Msg msgIn msgOut) 399 | } 400 | -> SandboxProgram model msgIn msgOut 401 | layout ({ component } as args) = 402 | Actor.fromLayout 403 | { wrapModel = P_Component 404 | , wrapMsg = ComponentMsg 405 | , mapIn = testedMapIn 406 | , mapOut = testedMapOut args.stringifyMsgOut 407 | } 408 | { component 409 | | view = \toSelf model renderPID -> 410 | (component.view toSelf model renderPID) 411 | |> args.wrapView toSelf 412 | } 413 | |> toApplication 414 | { title = args.title 415 | , cases = args.cases 416 | , stringifyMsgIn = args.stringifyMsgIn 417 | , stringifyMsgOut = args.stringifyMsgOut 418 | } 419 | 420 | 421 | {-| Sandbox a Service Component 422 | 423 | You need to provied a `view` function which renders the model of 424 | your service component. 425 | 426 | -} 427 | service : 428 | { title : String 429 | , component : Component.Service model msgIn msgOut 430 | , cases : List (TestCase msgIn msgOut) 431 | , view : model -> Html msgIn 432 | , stringifyMsgIn : msgIn -> String 433 | , stringifyMsgOut : msgOut -> String 434 | } 435 | -> SandboxProgram model msgIn msgOut 436 | service args = 437 | Actor.fromUI 438 | { wrapModel = P_Component 439 | , wrapMsg = ComponentMsg 440 | , mapIn = testedMapIn 441 | , mapOut = testedMapOut args.stringifyMsgOut 442 | } 443 | { init = args.component.init 444 | , update = args.component.update 445 | , onSystem = args.component.onSystem 446 | , subs = args.component.subs 447 | , view = args.view 448 | } 449 | |> toApplication 450 | { title = args.title 451 | , cases = args.cases 452 | , stringifyMsgIn = args.stringifyMsgIn 453 | , stringifyMsgOut = args.stringifyMsgOut 454 | } 455 | 456 | 457 | 458 | toApplication : Args i o 459 | -> Actor model (Process model o) (Msg i o) 460 | -> SandboxProgram model i o 461 | toApplication args testedActor = 462 | System.application 463 | { init = initApp 464 | , spawn = spawn args testedActor 465 | , apply = applyModel args testedActor 466 | , view = Html.div [] 467 | , onUrlRequest = 468 | \urlRequest -> 469 | case urlRequest of 470 | Browser.Internal url -> 471 | Url.toString url 472 | |> Navigation.Push 473 | |> NavMsg 474 | |> System.sendToSingleton Navigation 475 | 476 | Browser.External str -> 477 | str 478 | |> Navigation.Load 479 | |> NavMsg 480 | |> System.sendToSingleton Navigation 481 | , onUrlChange = 482 | Layout.UrlChanged 483 | >> LayoutMsg 484 | >> System.sendToSingleton LayoutActor 485 | , onDebug = always System.none 486 | } 487 | 488 | 489 | initApp : () -> Url -> Nav.Key -> Msg msgIn msgOut 490 | initApp _ url key = 491 | System.batch 492 | [ System.withSingletonPID LayoutActor System.addView 493 | , Navigation.Init key url 494 | |> NavMsg 495 | |> System.sendToSingleton Navigation 496 | , Layout.UrlChanged url 497 | |> LayoutMsg 498 | |> System.sendToSingleton LayoutActor 499 | ] 500 | 501 | 502 | testedMapIn : AppMsg i o -> Maybe i 503 | testedMapIn appMsg = 504 | case appMsg of 505 | ComponentMsg msg -> 506 | Just msg 507 | 508 | _ -> 509 | Nothing 510 | 511 | 512 | testedMapOut : (msgOut -> String) -> PID -> msgOut -> Msg msgIn msgOut 513 | testedMapOut toString pid componentMsg = 514 | componentMsg 515 | |> Layout.HandleMsgOut pid 516 | |> LayoutMsg 517 | |> System.sendToSingleton LayoutActor 518 | 519 | 520 | 521 | -- SYSTEM 522 | 523 | 524 | type ActorName 525 | = LayoutActor 526 | | TestedActor 527 | | Navigation 528 | | LoremIpsum 529 | 530 | 531 | type Process model o 532 | = P_Layout (Layout.Model o) 533 | | P_Component model 534 | | P_Nav Navigation.Model 535 | | P_LoremIpsum LoremIpsum.Model 536 | 537 | {-| Sadbox Msg 538 | -} 539 | type alias Msg msgIn msgOut = 540 | System.SysMsg ActorName (AppMsg msgIn msgOut) 541 | 542 | 543 | type AppMsg msgIn msgOut 544 | = LayoutMsg (Layout.MsgIn msgIn msgOut) 545 | | ComponentMsg msgIn 546 | | NavMsg Navigation.MsgIn 547 | | LoremIpsumMsg LoremIpsum.MsgIn 548 | 549 | 550 | spawn : Args i o 551 | -> Actor model (Process model o) (Msg i o) 552 | -> ActorName 553 | -> PID 554 | -> ( Process model o, Msg i o ) 555 | spawn args tested name = 556 | case name of 557 | LayoutActor -> 558 | .init (layoutActor args) 559 | 560 | TestedActor -> 561 | tested.init 562 | 563 | Navigation -> 564 | navigation.init 565 | 566 | LoremIpsum -> 567 | loremIpsum.init 568 | 569 | 570 | applyModel : 571 | Args i o 572 | -> Actor model (Process model o) (Msg i o) 573 | -> Process model o 574 | -> System.AppliedActor (Process model o) (Html (Msg i o)) (Msg i o) 575 | applyModel args testedActor process = 576 | case process of 577 | P_Layout model -> 578 | System.applyModel (layoutActor args) model 579 | 580 | P_Component model -> 581 | System.applyModel testedActor model 582 | 583 | P_Nav model -> 584 | System.applyModel navigation model 585 | 586 | P_LoremIpsum model -> 587 | System.applyModel loremIpsum model 588 | 589 | -- Lorem Ipsum 590 | 591 | loremIpsum : Actor LoremIpsum.Model (Process model o) (Msg i o) 592 | loremIpsum = 593 | Actor.fromUI 594 | { wrapModel = P_LoremIpsum 595 | , wrapMsg = LoremIpsumMsg 596 | , mapIn = loremIpsumMapIn 597 | , mapOut = \_ _ -> System.none 598 | } 599 | LoremIpsum.component 600 | 601 | 602 | loremIpsumMapIn : AppMsg i o -> Maybe LoremIpsum.MsgIn 603 | loremIpsumMapIn appMsg = 604 | case appMsg of 605 | LoremIpsumMsg msg -> 606 | Just msg 607 | 608 | _ -> 609 | Nothing 610 | 611 | -- Navigation 612 | 613 | navigation : Actor Navigation.Model (Process model o) (Msg i msgOut) 614 | navigation = 615 | Actor.fromService 616 | { wrapModel = P_Nav 617 | , wrapMsg = NavMsg 618 | , mapIn = navigationMapIn 619 | , mapOut = navigationMapOut 620 | } 621 | Navigation.component 622 | 623 | 624 | navigationMapIn : AppMsg i o -> Maybe Navigation.MsgIn 625 | navigationMapIn appMsg = 626 | case appMsg of 627 | NavMsg msg -> 628 | Just msg 629 | 630 | _ -> 631 | Nothing 632 | 633 | 634 | navigationMapOut : PID -> Navigation.MsgOut -> Msg i msgOut 635 | navigationMapOut self componentMsg = 636 | case componentMsg of 637 | Navigation.NoOut -> 638 | System.none 639 | 640 | -- Test Runner Actor 641 | 642 | type alias Args i o = 643 | { title : String 644 | , cases : List (TestCase i o) 645 | , stringifyMsgIn : i -> String 646 | , stringifyMsgOut : o -> String 647 | } 648 | 649 | 650 | layoutActor : Args i o -> Actor (Layout.Model o) (Process model o) (Msg i o) 651 | layoutActor args = 652 | Actor.fromLayout 653 | { wrapModel = P_Layout 654 | , wrapMsg = LayoutMsg 655 | , mapIn = layoutMapIn 656 | , mapOut = layoutMapOut args.stringifyMsgIn 657 | } 658 | (Layout.component 659 | { cases = 660 | List.indexedMap Tuple.pair args.cases 661 | |> Dict.fromList 662 | , stringifyMsgOut = args.stringifyMsgOut 663 | , title = args.title 664 | } 665 | ) 666 | 667 | 668 | layoutMapIn : AppMsg i o -> Maybe (Layout.MsgIn i o) 669 | layoutMapIn appMsg = 670 | case appMsg of 671 | LayoutMsg msg -> 672 | Just msg 673 | 674 | _ -> 675 | Nothing 676 | 677 | 678 | layoutMapOut : (msgIn -> String) -> PID -> Layout.MsgOut msgIn msgOut -> Msg msgIn msgOut 679 | layoutMapOut toString p componentMsg = 680 | case componentMsg of 681 | Layout.Spawn replyPID reply -> 682 | reply 683 | >> LayoutMsg 684 | >> System.sendToPID replyPID 685 | |> System.spawn TestedActor 686 | 687 | Layout.SetPageTitle title -> 688 | System.setDocumentTitle title 689 | 690 | Layout.PerformAction subject action -> 691 | case action of 692 | Layout.SendMsg msg -> 693 | System.batch 694 | [ toString msg 695 | |> Layout.InMessage 696 | |> Layout.LogMsg subject 697 | |> LayoutMsg 698 | |> System.sendToSingleton LayoutActor 699 | , ComponentMsg msg 700 | |> System.sendToPID subject 701 | ] 702 | 703 | Layout.Delay _ _ -> 704 | System.none -- handled in sandbox component 705 | 706 | Layout.Pass -> 707 | System.none -- handled in sandbox component 708 | 709 | Layout.Fail _ -> 710 | System.none -- handled in sandbox component 711 | 712 | Layout.Timeout _ -> 713 | System.none -- handled in sandbox component 714 | 715 | Layout.SpawnChild title reply -> 716 | System.spawn LoremIpsum 717 | (\newPid -> 718 | System.batch 719 | [ reply newPid 720 | |> ComponentMsg 721 | |> System.sendToPID subject 722 | , LoremIpsum.SetText title 723 | |> LoremIpsumMsg 724 | |> System.sendToPID newPid 725 | , reply newPid 726 | |> toString 727 | |> Layout.InMessage 728 | |> Layout.LogMsg subject 729 | |> LayoutMsg 730 | |> System.sendToSingleton LayoutActor 731 | ] 732 | ) 733 | 734 | Layout.NavigateToHref href -> 735 | Navigation.Push href 736 | |> NavMsg 737 | |> System.sendToSingleton Navigation 738 | 739 | 740 | -------------------------------------------------------------------------------- /src/Webbhuset/Component/Sandbox/Layout.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Component.Sandbox.Layout exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | import Html exposing (Html) 5 | import Html.Attributes as HA 6 | import Html.Events as Events 7 | import Webbhuset.Actor as Actor exposing (Actor) 8 | import Webbhuset.ActorSystem as System 9 | import Webbhuset.Component as Component 10 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 11 | import Webbhuset.Component.Sandbox.Navigation as Navigation 12 | import Webbhuset.Component.Sandbox.LoremIpsum as LoremIpsum 13 | import Webbhuset.Internal.PID exposing (PID(..)) 14 | import Webbhuset.PID as PID 15 | import Browser.Navigation as Nav 16 | import Browser 17 | import Markdown 18 | import Url exposing (Url) 19 | import List.Extra as List 20 | 21 | 22 | type alias Config msgIn msgOut = 23 | { cases : Dict Int (TestCase msgIn msgOut) 24 | , stringifyMsgOut : msgOut -> String 25 | , title : String 26 | } 27 | 28 | 29 | type alias TestCase msgIn msgOut = 30 | { title : String 31 | , desc : String 32 | , init : List (Action msgIn) 33 | , onMsgOut : msgOut -> List (Action msgIn) 34 | } 35 | 36 | 37 | {-| An action to perform on your sandboxed component. 38 | 39 | -} 40 | type Action msgIn 41 | = SendMsg msgIn 42 | | SpawnChild String (PID -> msgIn) 43 | | Delay Float (Action msgIn) 44 | | Pass 45 | | Fail String 46 | | Timeout String 47 | 48 | 49 | component : Config i o -> Component.Layout (Model o) (MsgIn i o) (MsgOut i o) msg 50 | component config = 51 | { init = init config 52 | , update = update config 53 | , view = view config 54 | , onSystem = always SystemEvent.default 55 | , subs = always Sub.none 56 | } 57 | 58 | 59 | 60 | type alias Child = 61 | { pid : PID 62 | } 63 | 64 | 65 | type Message 66 | = InMessage String 67 | | OutMessage String 68 | 69 | type TestResult 70 | = Waiting 71 | | TestFail String 72 | | TestPass 73 | 74 | 75 | type alias Model msgOut = 76 | { pid : PID 77 | , pids : Dict Int Child 78 | , testResult : Dict String TestResult 79 | , initMsgsQueue : Dict String (List msgOut) 80 | , messages : Dict String (List Message) 81 | , displayCase : Maybe Int 82 | , cardMode : Maybe Int 83 | , title : String 84 | , currentUrl : Maybe Url 85 | } 86 | 87 | 88 | 89 | -- 90 | -- Message Types 91 | -- 92 | 93 | 94 | type MsgIn msgIn msgOut 95 | = NewPID Int PID 96 | | ReInit Int 97 | | SetTitle String 98 | | LogMsg PID Message 99 | | UrlChanged Url 100 | | NavigateTo String 101 | | RunAction PID (Action msgIn) 102 | | HandleMsgOut PID msgOut 103 | 104 | 105 | type MsgOut msgIn msgOut 106 | = Spawn PID (PID -> MsgIn msgIn msgOut) 107 | | SetPageTitle String 108 | | PerformAction PID (Action msgIn) 109 | | NavigateToHref String 110 | 111 | 112 | 113 | -- 114 | -- Component 115 | -- 116 | 117 | 118 | init : Config i o -> PID -> ( Model o, List (MsgOut i o), Cmd (MsgIn i o) ) 119 | init config pid = 120 | ( { pid = pid 121 | , pids = Dict.empty 122 | , testResult = Dict.empty 123 | , initMsgsQueue = Dict.empty 124 | , displayCase = Nothing 125 | , cardMode = Nothing 126 | , messages = Dict.empty 127 | , currentUrl = Nothing 128 | , title = config.title 129 | } 130 | , config.cases 131 | |> Dict.keys 132 | |> List.map 133 | (\idx -> 134 | Spawn pid (NewPID idx) 135 | ) 136 | , Cmd.none 137 | ) 138 | 139 | 140 | update : Config i o -> (MsgIn i o) -> Model o -> ( Model o, List (MsgOut i o), Cmd (MsgIn i o) ) 141 | update config msgIn model = 142 | case msgIn of 143 | NewPID idx pid -> 144 | let 145 | queuedMsgOut = 146 | Dict.get (PID.toString pid) model.initMsgsQueue 147 | |> Maybe.withDefault [] 148 | 149 | ( testResults, outMsgs, cmds ) = 150 | Dict.get idx config.cases 151 | |> Maybe.map 152 | (\testCase -> 153 | List.concatMap testCase.onMsgOut queuedMsgOut 154 | ++ testCase.init 155 | |> runActions model.testResult pid 156 | ) 157 | |> Maybe.withDefault ( model.testResult, [], Cmd.none ) 158 | in 159 | ( { model 160 | | pids = Dict.insert idx (Child pid) model.pids 161 | , initMsgsQueue = Dict.remove (PID.toString pid) model.initMsgsQueue 162 | , testResult = testResults 163 | } 164 | , outMsgs 165 | , cmds 166 | ) 167 | 168 | RunAction pid action -> 169 | let 170 | ( testResults, msgs, cmds ) = 171 | runActions model.testResult pid [ action ] 172 | in 173 | ( { model | testResult = testResults } 174 | , msgs 175 | , cmds 176 | ) 177 | 178 | HandleMsgOut pid msgOut -> 179 | let 180 | message = 181 | config.stringifyMsgOut msgOut 182 | |> OutMessage 183 | 184 | maybeIdx = 185 | findIdxFromPID pid model.pids 186 | 187 | ( testResults, outMsgs, cmds ) = 188 | maybeIdx 189 | |> Maybe.andThen (\idx -> Dict.get idx config.cases) 190 | |> Maybe.map 191 | (\test -> 192 | test.onMsgOut msgOut 193 | |> runActions model.testResult pid 194 | ) 195 | |> Maybe.withDefault ( model.testResult, [], Cmd.none ) 196 | 197 | m2 = 198 | case maybeIdx of 199 | Just _ -> 200 | model 201 | 202 | Nothing -> 203 | { model 204 | | initMsgsQueue = 205 | Dict.update 206 | (PID.toString pid) 207 | (\maybeMsgs -> 208 | case maybeMsgs of 209 | Just msgs -> 210 | Just <| msgs ++ [ msgOut ] 211 | 212 | Nothing -> 213 | Just [ msgOut ] 214 | ) 215 | model.initMsgsQueue 216 | } 217 | in 218 | ( { m2 219 | | messages = logMessage pid message m2.messages 220 | , testResult = testResults 221 | } 222 | , outMsgs 223 | , cmds 224 | ) 225 | 226 | ReInit idx -> 227 | ( model 228 | , [ Spawn model.pid (NewPID idx) 229 | ] 230 | , Cmd.none 231 | ) 232 | 233 | SetTitle t -> 234 | ( { model | title = t } 235 | , [] 236 | , Cmd.none 237 | ) 238 | 239 | LogMsg pid message -> 240 | ( { model 241 | | messages = logMessage pid message model.messages 242 | } 243 | , [] 244 | , Cmd.none 245 | ) 246 | 247 | UrlChanged url -> 248 | let 249 | ( path, query ) = 250 | parseUrl url 251 | 252 | strParam key default = 253 | Dict.get key query 254 | |> Maybe.withDefault default 255 | in 256 | case path of 257 | [ "testcase", n ] -> 258 | let 259 | idx = 260 | String.toInt n 261 | 262 | title = 263 | idx 264 | |> Maybe.andThen (\i -> Dict.get i config.cases) 265 | |> Maybe.map .title 266 | |> Maybe.withDefault model.title 267 | in 268 | ( { model 269 | | displayCase = idx 270 | , cardMode = Nothing 271 | , currentUrl = Just url 272 | } 273 | , [ SetPageTitle title ] 274 | , Cmd.none 275 | ) 276 | 277 | [ "cardmode", n ] -> 278 | let 279 | cols = 280 | String.toInt n 281 | |> Maybe.map (clamp 1 8) 282 | in 283 | ( { model 284 | | displayCase = Nothing 285 | , cardMode = cols 286 | , currentUrl = Just url 287 | } 288 | , [ SetPageTitle model.title ] 289 | , Cmd.none 290 | ) 291 | 292 | _ -> 293 | ( { model 294 | | displayCase = Nothing 295 | , currentUrl = Just url 296 | , cardMode = Nothing 297 | } 298 | , [ SetPageTitle model.title ] 299 | , Cmd.none 300 | ) 301 | 302 | NavigateTo href -> 303 | ( model 304 | , [ NavigateToHref href ] 305 | , Cmd.none 306 | ) 307 | 308 | logMessage : PID -> Message -> Dict String (List Message) -> Dict String (List Message) 309 | logMessage pid message dict = 310 | Dict.update 311 | (PID.toString pid) 312 | (\mbMsg -> 313 | case mbMsg of 314 | Just messages -> 315 | message 316 | :: messages 317 | |> Just 318 | 319 | Nothing -> 320 | [ message ] 321 | |> Just 322 | ) 323 | dict 324 | 325 | 326 | parseUrl : Url -> ( List String, Dict String String ) 327 | parseUrl url = 328 | let 329 | toPath pathStr = 330 | pathStr 331 | |> String.split "/" 332 | |> List.map String.trim 333 | 334 | toQuery queryStr = 335 | queryStr 336 | |> String.split "&" 337 | |> List.filterMap 338 | (\paramStr -> 339 | case String.split "=" paramStr of 340 | [ key, val ] -> 341 | Just 342 | ( String.trim key 343 | , String.trim val 344 | ) 345 | _ -> 346 | Nothing 347 | 348 | ) 349 | |> Dict.fromList 350 | in 351 | url.fragment 352 | |> Maybe.map 353 | (String.split "?" 354 | >> (\ls -> 355 | case ls of 356 | [ pathStr, queryStr ] -> 357 | ( toPath pathStr 358 | , toQuery queryStr 359 | ) 360 | 361 | [ pathStr ] -> 362 | ( toPath pathStr 363 | , Dict.empty 364 | ) 365 | 366 | _ -> 367 | ( [], Dict.empty ) 368 | ) 369 | ) 370 | |> Maybe.withDefault ( [], Dict.empty ) 371 | 372 | 373 | buildHref : List String -> Dict String String -> String 374 | buildHref path query = 375 | let 376 | queryString = 377 | query 378 | |> Dict.toList 379 | |> List.map (\( k, v ) -> k ++ "=" ++ v) 380 | |> String.join "&" 381 | 382 | pathString = 383 | String.join "/" path 384 | in 385 | if Dict.isEmpty query then 386 | "#" ++ pathString 387 | else 388 | "#" ++ pathString ++ "?" ++ queryString 389 | 390 | 391 | 392 | findIdxFromPID : PID -> Dict Int Child -> Maybe Int 393 | findIdxFromPID pid dict = 394 | dict 395 | |> Dict.toList 396 | |> List.find (\( _, child ) -> child.pid == pid) 397 | |> Maybe.map Tuple.first 398 | 399 | 400 | runActions : Dict String TestResult 401 | -> PID 402 | -> List (Action i) 403 | -> ( Dict String TestResult, List (MsgOut i o), Cmd (MsgIn i o) ) 404 | runActions testResults pid actions = 405 | actions 406 | |> List.foldl 407 | (\action ( results, msgs, cmds ) -> 408 | case action of 409 | Delay delay_ delayedAction -> 410 | ( results 411 | , msgs 412 | , cmds 413 | ++ [ Component.toCmdWithDelay 414 | delay_ 415 | (delayedAction 416 | |> RunAction pid 417 | ) 418 | ] 419 | ) 420 | 421 | Pass -> 422 | ( case Dict.get (PID.toString pid) results of 423 | Just (TestFail _)-> 424 | results 425 | 426 | _ -> 427 | Dict.insert (PID.toString pid) TestPass results 428 | , msgs 429 | , cmds 430 | ) 431 | 432 | Fail reason -> 433 | ( case Dict.get (PID.toString pid) results of 434 | Just (TestFail _)-> 435 | results 436 | 437 | _ -> 438 | Dict.insert (PID.toString pid) (TestFail reason) results 439 | , msgs 440 | , cmds 441 | ) 442 | 443 | Timeout reason -> 444 | ( case Dict.get (PID.toString pid) results of 445 | Just TestPass -> 446 | results 447 | 448 | Just (TestFail _)-> 449 | results 450 | 451 | _ -> 452 | Dict.insert (PID.toString pid) (TestFail reason) results 453 | , msgs 454 | , cmds 455 | ) 456 | 457 | _ -> 458 | ( results 459 | , msgs ++ [ PerformAction pid action ] 460 | , cmds 461 | ) 462 | ) 463 | ( testResults, [], [] ) 464 | |> Component.mapThird Cmd.batch 465 | 466 | 467 | testResult : PID -> Dict String TestResult -> TestResult 468 | testResult pid dict = 469 | Dict.get (PID.toString pid) dict 470 | |> Maybe.withDefault Waiting 471 | 472 | 473 | -- VIEW 474 | 475 | 476 | type alias ColorConfig = 477 | { bgColor : String 478 | , testCaseBgColor : String 479 | , componentBgColor : String 480 | } 481 | 482 | 483 | defaultColors : ColorConfig 484 | defaultColors = 485 | { bgColor = "#888" 486 | , testCaseBgColor = "#fff" 487 | , componentBgColor = "transparent" 488 | } 489 | 490 | 491 | colorsFromQueryParams : Dict String String -> ColorConfig 492 | colorsFromQueryParams queryParams = 493 | let 494 | default = 495 | defaultColors 496 | in 497 | { bgColor = 498 | Dict.get "bgColor" queryParams 499 | |> Maybe.withDefault default.bgColor 500 | , testCaseBgColor = 501 | Dict.get "testCaseBgColor" queryParams 502 | |> Maybe.withDefault default.testCaseBgColor 503 | , componentBgColor = 504 | Dict.get "componentBgColor" queryParams 505 | |> Maybe.withDefault default.componentBgColor 506 | } 507 | 508 | 509 | view : Config msgIn msgOut -> ((MsgIn msgIn msgOut) -> msg) -> Model msgOut -> (PID -> Html msg) -> Html msg 510 | view config toSelf model renderPID = 511 | let 512 | ( currentPath, queryParams ) = 513 | model.currentUrl 514 | |> Maybe.map parseUrl 515 | |> Maybe.withDefault ( [], Dict.empty ) 516 | 517 | color = 518 | colorsFromQueryParams queryParams 519 | 520 | fullScreenMode = 521 | let 522 | resolve maybe fn = 523 | maybe 524 | |> Maybe.andThen fn 525 | in 526 | resolve (Dict.get "fullscreen" queryParams) <|\_ -> 527 | resolve model.displayCase <| \caseIdx -> 528 | resolve (Dict.get caseIdx config.cases) <| \testCase -> 529 | resolve (Dict.get caseIdx model.pids) <| \child -> 530 | Just ( caseIdx, testCase, child.pid ) 531 | 532 | ( passed, failed, waiting ) = 533 | config.cases 534 | |> Dict.keys 535 | |> List.map 536 | (\idx -> 537 | Dict.get idx model.pids 538 | |> Maybe.map (\child -> testResult child.pid model.testResult) 539 | |> Maybe.withDefault Waiting 540 | ) 541 | |> List.foldl 542 | (\result ( p, f, w ) -> 543 | case result of 544 | Waiting -> 545 | ( p, f, w + 1 ) 546 | 547 | TestPass -> 548 | ( p + 1, f, w ) 549 | 550 | TestFail _ -> 551 | ( p, f + 1, w ) 552 | ) 553 | ( 0, 0, 0 ) 554 | 555 | in 556 | case (currentPath, fullScreenMode) of 557 | ( [ "markdown" ], _ ) -> 558 | renderCli config model { pass = passed, fail = failed, wait = waiting } 559 | |> Html.text 560 | |> List.singleton 561 | |> Html.pre 562 | [ HA.id "markdown-output" 563 | ] 564 | 565 | ( _, Just ( caseIdx, testCase, pid ) ) -> 566 | renderPID pid 567 | 568 | _ -> 569 | Html.div 570 | [ HA.class "ams-pagewrap" 571 | , HA.style "background" color.bgColor 572 | ] 573 | [ Html.node "style" 574 | [] 575 | [ css 576 | |> String.replace "{{bgColor}}" color.bgColor 577 | |> String.replace "{{testCaseBg}}" color.testCaseBgColor 578 | |> String.replace "{{componentBg}}" color.componentBgColor 579 | |> Html.text 580 | ] 581 | , pageHeader toSelf model color 582 | , Html.hr [ HA.class "ams-hr" ] [] 583 | , Html.div 584 | [ HA.class "ams-above-cases" 585 | ] 586 | [ Html.div 587 | [ HA.class "ams-test-summary" 588 | ] 589 | [ Html.span [ HA.class "ams-test-summary--pass" ] [ Html.text <| "pass: " ++ (String.fromInt passed) ] 590 | , Html.span [ HA.class "ams-test-summary--fail" ] [ Html.text <| " fail: " ++ (String.fromInt failed) ] 591 | , Html.span [ HA.class "ams-test-summary--wait" ] [ Html.text <| " wait: " ++ (String.fromInt waiting) ] 592 | ] 593 | , testCaseSelectBox config toSelf model 594 | ] 595 | , renderCases config toSelf renderPID model 596 | ] 597 | 598 | 599 | renderCli : Config i o -> Model o -> { pass : Int, fail : Int, wait : Int } -> String 600 | renderCli config model summary = 601 | config.cases 602 | |> Dict.toList 603 | |> List.map 604 | (\( idx, test ) -> 605 | Dict.get idx model.pids 606 | |> Maybe.map 607 | (\child -> 608 | let 609 | result = 610 | testResult child.pid model.testResult 611 | in 612 | case result of 613 | Waiting -> 614 | [ ( "title", test.title ) 615 | , ( "status","wait" ) 616 | ] 617 | 618 | TestPass -> 619 | [ ( "title", test.title ) 620 | , ( "status", "pass" ) 621 | ] 622 | 623 | TestFail reason -> 624 | [ ( "title", test.title ) 625 | , ( "status", "fail" ) 626 | , ( "reason", reason ) 627 | ] 628 | ) 629 | |> Maybe.withDefault ([ ( "title", test.title ) ]) 630 | |> List.map 631 | (\( k, v ) -> 632 | "- " ++ k ++ ": " ++ v 633 | ) 634 | |> String.join "\n" 635 | ) 636 | |> List.indexedMap 637 | (\i t -> 638 | "## Test " ++ (String.fromInt i) ++ "\n" ++ t 639 | ) 640 | |> String.join "\n\n" 641 | |> (\tests -> 642 | "# " 643 | ++ config.title 644 | ++ "\n\nsandbox version: 3" 645 | ++ "\n\nSummary:" 646 | ++ "\n- total pass: " ++ (String.fromInt summary.pass) 647 | ++ "\n- total fail: " ++ (String.fromInt summary.fail) 648 | ++ "\n- total wait: " ++ (String.fromInt summary.wait) 649 | ++ "\n\n" 650 | ++ tests 651 | ) 652 | 653 | 654 | renderCases config toSelf renderPID model = 655 | let 656 | testCases = 657 | config.cases 658 | |> Dict.toList 659 | 660 | pids = 661 | model.pids 662 | |> Dict.values 663 | |> List.map .pid 664 | in 665 | case model.cardMode of 666 | Just columnCount -> 667 | let 668 | width = 669 | "calc(" 670 | ++ (100 / (toFloat columnCount) |> String.fromFloat) 671 | ++ "% - " 672 | ++ ((toFloat columnCount - 1) / (toFloat columnCount) |> String.fromFloat) 673 | ++ "rem)" 674 | 675 | in 676 | List.greedyGroupsOf columnCount pids 677 | |> List.map 678 | (\row -> 679 | Html.div 680 | [ HA.class "ams-card__row" 681 | ] 682 | (List.map 683 | (\col -> 684 | Html.div 685 | [ HA.style "width" width 686 | , HA.class "ams-card__cell" 687 | ] 688 | [ renderPID col ] 689 | ) 690 | row 691 | ) 692 | ) 693 | |> Html.div 694 | [ HA.class "ams-card" 695 | ] 696 | 697 | Nothing -> 698 | Html.div 699 | [] 700 | ( model.displayCase 701 | |> Maybe.andThen 702 | (\idx -> 703 | Dict.get idx config.cases 704 | |> Maybe.map 705 | (\testCase -> 706 | let 707 | child = 708 | Dict.get idx model.pids 709 | in 710 | Maybe.map (renderChild model toSelf renderPID idx testCase) child 711 | |> Maybe.withDefault (Html.text "") 712 | |> List.singleton 713 | ) 714 | ) 715 | |> Maybe.withDefault 716 | ( testCases 717 | |> List.map 718 | (\( idx, testCase ) -> 719 | let 720 | child = 721 | Dict.get idx model.pids 722 | in 723 | Maybe.map (renderChild model toSelf renderPID idx testCase) child 724 | |> Maybe.withDefault (Html.text "") 725 | ) 726 | ) 727 | ) 728 | 729 | 730 | pageHeader : (MsgIn msgIn msgOut -> msg) -> Model msgOut -> ColorConfig -> Html msg 731 | pageHeader toSelf model color = 732 | let 733 | ( currentPath, queryParams ) = 734 | model.currentUrl 735 | |> Maybe.map parseUrl 736 | |> Maybe.withDefault ( [], Dict.empty ) 737 | 738 | colorHref key val = 739 | buildHref 740 | currentPath 741 | (Dict.insert key val queryParams) 742 | 743 | resetColors = 744 | queryParams 745 | |> Dict.remove "bgColor" 746 | |> Dict.remove "testCaseBgColor" 747 | |> Dict.remove "componentBgColor" 748 | |> buildHref currentPath 749 | |> NavigateTo 750 | |> toSelf 751 | in 752 | Html.div 753 | [ HA.class "ams-page-header" 754 | ] 755 | [ Html.h1 756 | [ HA.class "ams-pagetitle" 757 | ] 758 | [ Html.text model.title 759 | ] 760 | , Html.div 761 | [ HA.class "ams-colortoolbar" 762 | ] 763 | [ colorInput 764 | "body-bg" 765 | "Body Bg" 766 | color.bgColor 767 | (colorHref "bgColor" 768 | >> NavigateTo 769 | >> toSelf 770 | ) 771 | , colorInput 772 | "body-bg" 773 | "Test case Bg" 774 | color.testCaseBgColor 775 | (colorHref "testCaseBgColor" 776 | >> NavigateTo 777 | >> toSelf 778 | ) 779 | , colorInput 780 | "body-bg" 781 | "Component Bg" 782 | color.componentBgColor 783 | (colorHref "componentBgColor" 784 | >> NavigateTo 785 | >> toSelf 786 | ) 787 | , Html.button 788 | [ Events.onClick resetColors 789 | , HA.class "ams-button--alt" 790 | , HA.style "margin-left" "16px" 791 | ] 792 | [ Html.text "Reset colors" 793 | ] 794 | ] 795 | ] 796 | 797 | 798 | 799 | fullscreenToggle : (MsgIn msgIn msgOut -> msg) -> Model msgOut -> Int -> Html msg 800 | fullscreenToggle toSelf model testCaseIdx = 801 | let 802 | ( currentPath, queryParams ) = 803 | model.currentUrl 804 | |> Maybe.map parseUrl 805 | |> Maybe.withDefault ( [], Dict.empty ) 806 | 807 | isSelected = 808 | Dict.get "fullscreen" queryParams 809 | |> Maybe.map (always True) 810 | |> Maybe.withDefault False 811 | 812 | onClick = 813 | Dict.insert "fullscreen" "on" queryParams 814 | |> buildHref [ "testcase", String.fromInt testCaseIdx ] 815 | |> NavigateTo 816 | |> toSelf 817 | |> Events.onClick 818 | in 819 | Html.button 820 | [ HA.class "ams-button ams-fullscreen-toggle" 821 | , onClick 822 | ] 823 | [ Html.text "View fullscreen" 824 | ] 825 | 826 | 827 | testCaseSelectBox : Config msgIn msgOut -> (MsgIn msgIn msgOut -> msg) -> Model msgOut -> Html msg 828 | testCaseSelectBox config toSelf model = 829 | let 830 | testCases = 831 | config.cases 832 | |> Dict.toList 833 | 834 | cardLayouts = 835 | List.range 2 8 836 | |> List.map (\i -> ( i, (String.fromInt i) ++ " Columns")) 837 | |> (::) ( 1, "1 Column" ) 838 | 839 | ( currentPath, queryParams ) = 840 | model.currentUrl 841 | |> Maybe.map parseUrl 842 | |> Maybe.withDefault ( [], Dict.empty ) 843 | in 844 | Html.div 845 | [ HA.class "ams-select-testcase" 846 | ] 847 | [ Html.select 848 | [ Events.onInput (toSelf << NavigateTo) 849 | ] 850 | (cardLayouts 851 | |> List.map 852 | (\( cols, label ) -> 853 | Html.option 854 | [ HA.value <| buildHref [ "cardmode", String.fromInt cols ] queryParams 855 | , if model.cardMode == Just cols then 856 | HA.selected True 857 | else 858 | HA.selected False 859 | ] 860 | [ Html.text label 861 | ] 862 | ) 863 | |> (::) 864 | ( Html.option 865 | [ HA.value <| buildHref [] Dict.empty 866 | ] 867 | [ Html.text "-- Show UI Cards --" 868 | ] 869 | ) 870 | ) 871 | , Html.select 872 | [ Events.onInput (toSelf << NavigateTo) 873 | ] 874 | (testCases 875 | |> List.map 876 | (\( idx, testCase ) -> 877 | let 878 | result = 879 | Dict.get idx model.pids 880 | |> Maybe.map 881 | (\child -> 882 | testResult child.pid model.testResult 883 | ) 884 | |> Maybe.withDefault Waiting 885 | in 886 | Html.option 887 | [ HA.value <| buildHref [ "testcase", String.fromInt idx ] queryParams 888 | , if model.displayCase == Just idx then 889 | HA.selected True 890 | else 891 | HA.selected False 892 | , HA.style 893 | "color" 894 | (case result of 895 | Waiting -> "" 896 | TestPass -> "#009911" 897 | TestFail _ -> "#aa0000" 898 | ) 899 | ] 900 | [ Html.text testCase.title 901 | ] 902 | ) 903 | |> (::) 904 | ( Html.option 905 | [ HA.value <| buildHref [] queryParams 906 | ] 907 | [ Html.text "-- Show all test cases --" 908 | ] 909 | ) 910 | ) 911 | ] 912 | 913 | 914 | colorInput : String -> String -> String -> (String -> msg) -> Html msg 915 | colorInput htmlID label color toMsg = 916 | Html.div 917 | [ HA.class "ams-colorinput__row" 918 | ] 919 | [ Html.input 920 | [ HA.type_ "color" 921 | , Events.onInput toMsg 922 | -- , HA.value color 923 | , HA.id htmlID 924 | , HA.class "ams-colorinput__input" 925 | ] 926 | [] 927 | , Html.label 928 | [ HA.for htmlID 929 | , HA.class "ams-colorinput__label" 930 | ] 931 | [ Html.text label 932 | ] 933 | ] 934 | 935 | 936 | renderChild : Model o -> ((MsgIn i o) -> msg) -> (PID -> Html msg) -> Int -> TestCase i o -> Child -> Html msg 937 | renderChild model toSelf renderPID idx testCase child = 938 | let 939 | result = 940 | testResult child.pid model.testResult 941 | in 942 | Html.div 943 | [ HA.class "ams-testcase" 944 | ] 945 | [ Html.div 946 | [ HA.class 947 | ( "ams-testcase__header" 948 | ++ ( case result of 949 | Waiting -> " ams-testcase__header--waiting" 950 | TestPass -> " ams-testcase__header--pass" 951 | TestFail _ -> " ams-testcase__header--fail" 952 | ) 953 | ) 954 | ] 955 | [ Html.div 956 | [ HA.class "ams-testcase__result" 957 | ] 958 | [ case result of 959 | Waiting -> 960 | Html.text "Waiting..." 961 | 962 | TestPass -> 963 | Html.text "Pass" 964 | 965 | TestFail reason -> 966 | Html.text reason 967 | ] 968 | , Html.div 969 | [ HA.class 970 | ("ams-testcase__toolbar" 971 | ) 972 | ] 973 | [ child.pid 974 | |> (\(PID { key }) -> "PID: " ++ String.fromInt key) 975 | |> Html.text 976 | |> List.singleton 977 | |> Html.span [ HA.class "ams-testcase__pidLabel" ] 978 | , fullscreenToggle toSelf model idx 979 | , Html.button 980 | [ Events.onClick (toSelf <| ReInit idx) 981 | , HA.class "ams-button" 982 | ] 983 | [ Html.text "Reset test" 984 | ] 985 | ] 986 | ] 987 | , Html.div 988 | [ HA.class "ams-testcase__content" 989 | ] 990 | [ Html.h2 991 | [ HA.class "ams-testcase__title" 992 | ] 993 | [ Html.text testCase.title 994 | ] 995 | , Markdown.toHtml 996 | [ HA.class "ams-testcase__desc" 997 | ] 998 | testCase.desc 999 | , section 1000 | [ heading 5 "Component view:" 1001 | , Html.div 1002 | [ HA.class "ams-testcase__componentview" 1003 | ] 1004 | [ renderPID child.pid 1005 | ] 1006 | ] 1007 | , section 1008 | [ heading 5 "Message log:" 1009 | , Html.div 1010 | [ HA.class "ams-messagelog" 1011 | ] 1012 | (model.messages 1013 | |> Dict.get (PID.toString child.pid) 1014 | |> Maybe.map 1015 | (List.reverse 1016 | >> List.map 1017 | (\message -> 1018 | case message of 1019 | InMessage inMsg -> 1020 | "> " 1021 | ++ inMsg 1022 | |> Html.text 1023 | |> List.singleton 1024 | |> Html.span 1025 | [ HA.class "ams-messagelog__inmsg" 1026 | ] 1027 | 1028 | OutMessage outMsg -> 1029 | " -> " 1030 | ++ outMsg 1031 | |> Html.text 1032 | |> List.singleton 1033 | |> Html.span 1034 | [ HA.class "ams-messagelog__outmsg" 1035 | ] 1036 | ) 1037 | ) 1038 | |> Maybe.withDefault [] 1039 | ) 1040 | ] 1041 | ] 1042 | ] 1043 | 1044 | 1045 | section : List (Html msg) -> Html msg 1046 | section = 1047 | Html.div 1048 | [ HA.class "ams-section" 1049 | ] 1050 | 1051 | 1052 | heading : Int -> String -> Html msg 1053 | heading lvl txt = 1054 | let 1055 | elem = 1056 | case lvl of 1057 | 1 -> Html.h1 1058 | 2 -> Html.h2 1059 | 3 -> Html.h3 1060 | 4 -> Html.h4 1061 | 5 -> Html.h5 1062 | _ -> Html.h5 1063 | in 1064 | elem 1065 | [ HA.class "ams-heading" 1066 | ] 1067 | [ Html.text txt 1068 | ] 1069 | 1070 | 1071 | css : String 1072 | css = 1073 | """ 1074 | html, body { 1075 | margin: 0; 1076 | padding: 0; 1077 | font-size: 16px; 1078 | } 1079 | body { 1080 | background: {{bgColor}}; 1081 | } 1082 | 1083 | 1084 | /** Page **/ 1085 | 1086 | .ams-pagewrap { 1087 | max-width: 1400px; 1088 | margin: 0 auto; 1089 | padding: 0 1rem; 1090 | } 1091 | .ams-section { 1092 | margin: 3rem 0; 1093 | } 1094 | .ams-page-header { 1095 | display: flex; 1096 | flex-direction: row; 1097 | justify-content: center; 1098 | align-items: center; 1099 | flex-wrap: wrap; 1100 | margin: 1rem 0 0 0; 1101 | } 1102 | .ams-pagetitle { 1103 | font-family: sans-serif; 1104 | color: #fff; 1105 | margin: 0; 1106 | flex: 1 1 auto; 1107 | } 1108 | 1109 | .ams-color-settings { 1110 | flex: 0 0 auto; 1111 | } 1112 | 1113 | .ams-select-testcase { 1114 | display: flex; 1115 | flex-direction: row; 1116 | align-items: center; 1117 | justify-content: flex-end; 1118 | } 1119 | 1120 | .ams-select-testcase select { 1121 | } 1122 | 1123 | .ams-heading { 1124 | font-family: sans-serif; 1125 | margin: 0; 1126 | color: #333; 1127 | } 1128 | 1129 | h1.ams-heading { font-size: 2.5rem; margin-top: 2.5rem; } 1130 | h2.ams-heading { font-size: 1.8rem; margin-top: 1.8rem; } 1131 | h3.ams-heading { font-size: 1.5rem; margin-top: 1.5rem; } 1132 | h4.ams-heading { font-size: 1.25rem; margin-top: 1.25rem; } 1133 | h5.ams-heading { font-size: 0.8rem; margin-top: 0.8rem; } 1134 | 1135 | .ams-hr { 1136 | border-color: #fff; 1137 | } 1138 | 1139 | .ams-button, 1140 | .ams-button--alt { 1141 | -webkit-appearance: none; 1142 | background: #888; 1143 | padding: 0.25rem 1rem; 1144 | border: none; 1145 | color: #fff; 1146 | border-radius: 2px; 1147 | line-height: 1rem; 1148 | transition: background 0.1s ease-out; 1149 | cursor: pointer; 1150 | outline: none; 1151 | font-family: sans-serif; 1152 | } 1153 | 1154 | .ams-button--alt { 1155 | background: #555; 1156 | } 1157 | 1158 | .ams-button--alt:hover { 1159 | background: #000; 1160 | } 1161 | 1162 | .ams-button:hover { 1163 | background: #555; 1164 | } 1165 | 1166 | .ams-colortoolbar { 1167 | display: flex; 1168 | flex-direction: row; 1169 | align-items: center; 1170 | justify-content: flex-end; 1171 | flex-wrap: wrap; 1172 | } 1173 | 1174 | .ams-colorinput__row { 1175 | display: flex; 1176 | flex-direction: row; 1177 | align-items: center; 1178 | } 1179 | 1180 | @media all and (max-width: 650px) { 1181 | .ams-colorinput__row { 1182 | width: 100%; 1183 | } 1184 | } 1185 | 1186 | .ams-colorinput__label { 1187 | padding: 0 1rem; 1188 | line-height: 1; 1189 | font-size: 0.8rem; 1190 | color: #fff; 1191 | font-family: monospace; 1192 | } 1193 | .ams-above-cases { 1194 | display: flex; 1195 | justify-content: space-between; 1196 | } 1197 | 1198 | .ams-test-summary { 1199 | font-family: monospace; 1200 | } 1201 | 1202 | .ams-test-summary--pass { 1203 | color: #005511; 1204 | } 1205 | 1206 | .ams-test-summary--fail { 1207 | color: #aa0000; 1208 | } 1209 | 1210 | /** Test Case **/ 1211 | .ams-testcase { 1212 | border-radius: 4px; 1213 | margin: 1rem 0; 1214 | background: {{testCaseBg}}; 1215 | position: relative; 1216 | } 1217 | 1218 | .ams-testcase__content { 1219 | border-radius: 4px; 1220 | background: {{testCaseBg}}; 1221 | position: relative; 1222 | padding: 1rem; 1223 | } 1224 | 1225 | .ams-testcase__content > *:last-child { 1226 | margin-bottom: 0; 1227 | } 1228 | .ams-testcase__title { 1229 | font-family: sans-serif; 1230 | color: #333; 1231 | font-size: 1.5rem; 1232 | margin: 0; 1233 | } 1234 | .ams-testcase__desc { 1235 | font-family: sans-serif; 1236 | max-width: 50rem; 1237 | } 1238 | .ams-testcase__desc code { 1239 | background-color: #eee; 1240 | padding: 1px 5px; 1241 | } 1242 | .ams-testcase__componentview { 1243 | border: 1px solid #e7e7e7; 1244 | border-radius: 4px; 1245 | background: {{componentBg}}; 1246 | } 1247 | 1248 | .ams-testcase__header { 1249 | display: flex; 1250 | flex-direction: row; 1251 | justify-content: space-between; 1252 | align-items: center; 1253 | border-bottom: 1px solid #f6f6f6; 1254 | padding: 0.5rem 0; 1255 | background: #f6f6f6; 1256 | border-top-left-radius: 4px; 1257 | border-top-right-radius: 4px; 1258 | } 1259 | .ams-testcase__header--pass { 1260 | background: #44f655; 1261 | } 1262 | .ams-testcase__header--fail { 1263 | background: #f65555; 1264 | } 1265 | .ams-testcase__result { 1266 | margin-left: 1rem; 1267 | font-family: monospace; 1268 | } 1269 | 1270 | .ams-testcase__toolbar { 1271 | display: flex; 1272 | flex-direction: row; 1273 | justify-content: flex-end; 1274 | align-items: center; 1275 | } 1276 | .ams-testcase__toolbar > * { 1277 | margin-right: 1rem; 1278 | } 1279 | .ams-testcase__pidLabel { 1280 | font-family: monospace; 1281 | font-size: 0.8rem; 1282 | color: #333; 1283 | } 1284 | 1285 | /** Card Mode **/ 1286 | .ams-card__row { 1287 | display: flex; 1288 | flex-direction: row; 1289 | justify-content: space-between; 1290 | margin-top: 1rem; 1291 | } 1292 | 1293 | .ams-card__cell { 1294 | position: relative; 1295 | } 1296 | 1297 | /** Message Log **/ 1298 | .ams-messagelog { 1299 | border-radius: 4px; 1300 | background: #eee; 1301 | padding: 0.5rem 1rem; 1302 | min-height: 16px; 1303 | margin: 0; 1304 | overflow: auto; 1305 | } 1306 | .ams-messagelog__inmsg { 1307 | font-family: monospace; 1308 | color: #c15858; 1309 | display: block; 1310 | white-space: pre; 1311 | } 1312 | .ams-messagelog__outmsg { 1313 | font-family: monospace; 1314 | color: #3075b7; 1315 | display: block; 1316 | white-space: pre; 1317 | } 1318 | """ 1319 | -------------------------------------------------------------------------------- /src/Webbhuset/Component/Sandbox/LoremIpsum.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Component.Sandbox.LoremIpsum exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | 9 | import Html exposing (Html) 10 | import Html.Attributes as HA 11 | import Html.Events as Events 12 | import Random 13 | import Webbhuset.Component as Component exposing (PID) 14 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 15 | 16 | 17 | 18 | type MsgIn 19 | = More 20 | | Less 21 | | SetText String 22 | 23 | 24 | type MsgOut 25 | = NoOut 26 | 27 | 28 | type alias Model = 29 | { pid : PID 30 | , count : Int 31 | , text : String 32 | } 33 | 34 | 35 | -- 36 | -- Component 37 | -- 38 | 39 | component : Component.UI Model MsgIn MsgOut 40 | component = 41 | { init = init 42 | , update = update 43 | , view = view 44 | , onSystem = always SystemEvent.default 45 | , subs = subs 46 | } 47 | 48 | 49 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 50 | init pid = 51 | ( { pid = pid 52 | , count = 10 53 | , text = "" 54 | } 55 | , [] 56 | , Cmd.none 57 | ) 58 | 59 | 60 | subs : Model -> Sub MsgIn 61 | subs model = 62 | Sub.none 63 | 64 | 65 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 66 | update msgIn model = 67 | case msgIn of 68 | More -> 69 | ( { model | count = model.count * 2 } 70 | , [] 71 | , Cmd.none 72 | ) 73 | 74 | Less -> 75 | ( { model | count = model.count // 2 } 76 | , [] 77 | , Cmd.none 78 | ) 79 | 80 | SetText str -> 81 | ( { model | text = str } 82 | , [] 83 | , Cmd.none 84 | ) 85 | 86 | 87 | view : Model -> Html MsgIn 88 | view model = 89 | Html.div 90 | [ HA.style "border" "solid 1px black" 91 | ] 92 | [ Html.button 93 | [ Events.onClick Less 94 | ] 95 | [ Html.text "Less" 96 | ] 97 | , Html.button 98 | [ Events.onClick More 99 | ] 100 | [ Html.text "More" 101 | ] 102 | , Html.div 103 | [ 104 | ] 105 | [ List.repeat model.count model.text 106 | |> String.join " " 107 | |> Html.text 108 | ] 109 | ] 110 | -------------------------------------------------------------------------------- /src/Webbhuset/Component/Sandbox/Navigation.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Component.Sandbox.Navigation exposing 2 | ( MsgIn(..) 3 | , MsgOut(..) 4 | , Model 5 | , component 6 | ) 7 | 8 | {-| 9 | 10 | @docs MsgIn 11 | @docs MsgOut 12 | 13 | @docs component, Model 14 | -} 15 | 16 | import Webbhuset.Component as Component exposing (PID) 17 | import Webbhuset.Component.SystemEvent as SystemEvent exposing (SystemEvent) 18 | import Browser.Navigation as Nav exposing (Key) 19 | import Url exposing (Url) 20 | 21 | 22 | 23 | {-| Message In 24 | -} 25 | type MsgIn 26 | = Init Key Url 27 | | Push String 28 | | Load String 29 | 30 | 31 | {-| Message Out 32 | -} 33 | type MsgOut 34 | = NoOut 35 | 36 | 37 | 38 | {-| Component Model. This component has an init and a running state. 39 | -} 40 | type Model 41 | = InitState InitModel 42 | | RunningState RunningModel 43 | 44 | 45 | type alias InitModel = 46 | { pid : PID 47 | } 48 | 49 | 50 | type alias RunningModel = 51 | { pid : PID 52 | , key : Key 53 | } 54 | 55 | {-| Component Record 56 | -} 57 | component : Component.Service Model MsgIn MsgOut 58 | component = 59 | { init = init 60 | , update = update 61 | , onSystem = always SystemEvent.default 62 | , subs = subs 63 | } 64 | 65 | 66 | init : PID -> ( Model , List MsgOut, Cmd MsgIn ) 67 | init pid = 68 | ( { pid = pid 69 | } 70 | |> InitState 71 | , [] 72 | , Cmd.none 73 | ) 74 | 75 | 76 | subs : Model -> Sub MsgIn 77 | subs model = 78 | Sub.none 79 | 80 | 81 | update : MsgIn -> Model -> ( Model, List MsgOut, Cmd MsgIn ) 82 | update msgIn model = 83 | case model of 84 | InitState initModel -> 85 | updateInit msgIn initModel 86 | 87 | RunningState runningModel -> 88 | updateRunning msgIn runningModel 89 | |> Component.mapFirst RunningState 90 | 91 | 92 | 93 | updateInit : MsgIn -> InitModel -> ( Model, List MsgOut, Cmd MsgIn ) 94 | updateInit msgIn model = 95 | case msgIn of 96 | Init key url -> 97 | ( { pid = model.pid 98 | , key = key 99 | } 100 | |> RunningState 101 | , [] 102 | , Cmd.none 103 | ) 104 | 105 | Push href -> 106 | ( model 107 | |> InitState 108 | , [] 109 | , Cmd.none 110 | ) 111 | 112 | Load href -> 113 | ( model 114 | |> InitState 115 | , [] 116 | , Cmd.none 117 | ) 118 | 119 | 120 | updateRunning : MsgIn -> RunningModel -> ( RunningModel, List MsgOut, Cmd MsgIn ) 121 | updateRunning msgIn model = 122 | case msgIn of 123 | Init key url -> 124 | ( model 125 | , [] 126 | , Cmd.none 127 | ) 128 | 129 | Push href -> 130 | ( model 131 | , [] 132 | , Nav.pushUrl model.key href 133 | ) 134 | 135 | Load url -> 136 | ( model 137 | , [] 138 | , Nav.load url 139 | ) 140 | -------------------------------------------------------------------------------- /src/Webbhuset/Component/SystemEvent.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Component.SystemEvent exposing 2 | ( SystemEvent(..) 3 | , Handling 4 | , default 5 | , doNothing 6 | , iWillHandleIt 7 | , mapHandling 8 | ) 9 | 10 | {-| 11 | 12 | # System Events 13 | 14 | @docs SystemEvent 15 | 16 | System events are sent to a component's `onSystem` function. 17 | 18 | onSystem : SystemEvent -> SystemEvent.Handling MsgIn 19 | onSystem event = 20 | case event of 21 | PIDNotFound pid -> 22 | UnObserveData pid 23 | |> SystemEvent.iWillHandleIt 24 | 25 | Kill -> 26 | SystemEvent.default 27 | 28 | This gives you the choice of how to handle them by returning `Handling`. 29 | 30 | If you don't care you can just set the handling to default in your component's 31 | record. 32 | 33 | component = 34 | { init = init 35 | , onSystem = always SystemEvent.default 36 | ... 37 | } 38 | 39 | ## PIDNotFound 40 | 41 | If your component sends a message to a PID that does not exist 42 | anymore you will receive a `PIDNotFound` event containing the PID of the 43 | killed process. 44 | This lets you clean up any PID's you stored in your model for example. 45 | 46 | **Default handling** for this event is to do nothing. 47 | 48 | ## Kill 49 | 50 | Kill is received when your component is going to be killed. You 51 | have the chance to say some last words before dying. 52 | 53 | **Default handling** for Kill is to also kill all the children of 54 | the process. 55 | 56 | 57 | # Handling 58 | 59 | @docs Handling, default, doNothing, iWillHandleIt, mapHandling 60 | 61 | -} 62 | import Webbhuset.Internal.PID exposing (PID) 63 | import Webbhuset.Internal.SystemEvent as Internal 64 | 65 | 66 | {-| System Event 67 | 68 | -} 69 | type SystemEvent 70 | = PIDNotFound PID 71 | | Kill 72 | 73 | 74 | {-| How should events be handeled. 75 | 76 | -} 77 | type alias Handling msgIn = 78 | Internal.Handling msgIn 79 | 80 | 81 | {-| Use event default handling. 82 | 83 | -} 84 | default : Handling msgIn 85 | default = 86 | Internal.Default 87 | 88 | 89 | {-| Don't do anyting. 90 | 91 | -} 92 | doNothing : Handling msgIn 93 | doNothing = 94 | Internal.DoNothing 95 | 96 | 97 | {-| Handle it yourself. 98 | 99 | -} 100 | iWillHandleIt : msgIn -> Handling msgIn 101 | iWillHandleIt msgIn = 102 | Internal.HandleWith msgIn 103 | 104 | 105 | {-| Map the Handling type. 106 | 107 | -} 108 | mapHandling : (msg1 -> msg2) -> Handling msg1 -> Handling msg2 109 | mapHandling fn handling = 110 | case handling of 111 | Internal.Default -> 112 | Internal.Default 113 | 114 | Internal.DoNothing -> 115 | Internal.DoNothing 116 | 117 | Internal.HandleWith msg1 -> 118 | Internal.HandleWith (fn msg1) 119 | 120 | -------------------------------------------------------------------------------- /src/Webbhuset/Internal/Msg.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Internal.Msg exposing (..) 2 | 3 | import Webbhuset.Internal.PID as PID exposing (PID(..)) 4 | 5 | 6 | type Msg name appMsg 7 | = None 8 | | AppMsg appMsg 9 | | UnmappedMsg PID appMsg 10 | | Ctrl (Control name (Msg name appMsg)) 11 | | Context PID (Msg name appMsg) 12 | | Init (Msg name appMsg) String 13 | | SetDocumentTitle String 14 | 15 | 16 | type Control name msg 17 | = Batch (List msg) 18 | | Cmd (Cmd msg) 19 | | Kill PID 20 | | SendToPID PID msg 21 | | SendToSingleton name msg 22 | | Spawn name (PID -> msg) 23 | | SpawnSingleton name 24 | | AddView PID 25 | | WithSingletonPID name (PID -> msg) 26 | 27 | -------------------------------------------------------------------------------- /src/Webbhuset/Internal/PID.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Internal.PID exposing (PID(..), Meta) 2 | 3 | 4 | type PID 5 | = PID Meta 6 | 7 | 8 | type alias Meta = 9 | { isSingleton : Bool 10 | , prefix : String 11 | , spawnedBy : Int 12 | , key : Int 13 | } 14 | -------------------------------------------------------------------------------- /src/Webbhuset/Internal/SystemEvent.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.Internal.SystemEvent exposing (Handling(..)) 2 | 3 | 4 | type Handling msgIn 5 | = Default 6 | | DoNothing 7 | | HandleWith msgIn 8 | -------------------------------------------------------------------------------- /src/Webbhuset/PID.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.PID exposing 2 | ( PID 3 | , null 4 | , toString 5 | ) 6 | 7 | {-| 8 | 9 | ## PID 10 | 11 | @docs PID, toString, null 12 | 13 | -} 14 | 15 | import Webbhuset.Internal.PID as PID exposing (PID(..)) 16 | 17 | 18 | {-| A PID is an identifier for a Process. 19 | 20 | A process is an instance of an Actor / Component 21 | -} 22 | type alias PID = 23 | PID.PID 24 | 25 | 26 | {-| Stringify PID 27 | 28 | This is useful when you need to make a unique string id, for example 29 | to use as html ids. 30 | 31 | The string is unique for the component instance. 32 | 33 | -} 34 | toString : PID -> String 35 | toString (PID { prefix, key }) = 36 | prefix ++ String.fromInt key 37 | 38 | 39 | {-| PID for testing purposes. 40 | 41 | Deprecated, see Webbhuset.Sandbox.mockPID instead 42 | 43 | -} 44 | null : PID 45 | null = 46 | PID 47 | { isSingleton = False 48 | , prefix = "null" 49 | , key = 0 50 | , spawnedBy = 0 51 | } 52 | 53 | 54 | -------------------------------------------------------------------------------- /src/Webbhuset/PID/Set.elm: -------------------------------------------------------------------------------- 1 | module Webbhuset.PID.Set exposing 2 | ( PID 3 | , Set 4 | , empty 5 | , insert 6 | , isEmpty 7 | , remove 8 | , toList 9 | ) 10 | 11 | {-| 12 | 13 | ## Set of PID 14 | 15 | Since PIDs are not comparable they can not be used with the Set in elm/core. 16 | 17 | When using an event/observer pattern in the actor model it is useful 18 | to gather PIDs that are observing an event in a Set. 19 | 20 | @docs Set 21 | , PID 22 | , empty 23 | , insert 24 | , isEmpty 25 | , remove 26 | , toList 27 | -} 28 | 29 | import Dict exposing (Dict) 30 | import Webbhuset.Internal.PID as PID exposing (PID(..)) 31 | 32 | 33 | {-| A PID is an identifier for a Process. 34 | 35 | A process is an instance of an Actor / Component 36 | -} 37 | type alias PID = 38 | PID.PID 39 | 40 | 41 | {-| Store PIDs in a Set 42 | 43 | -} 44 | type Set 45 | = PIDSet (Dict (String, Int) PID) 46 | 47 | 48 | {-| Create an empty set 49 | 50 | -} 51 | empty : Set 52 | empty = 53 | PIDSet Dict.empty 54 | 55 | 56 | {-| Insert PID in a Set 57 | 58 | -} 59 | insert : PID -> Set -> Set 60 | insert ((PID { prefix, key } as pid)) (PIDSet dict) = 61 | Dict.insert (prefix, key) pid dict 62 | |> PIDSet 63 | 64 | 65 | {-| Remove a PID from a Set 66 | 67 | -} 68 | remove : PID -> Set -> Set 69 | remove (PID { prefix, key }) (PIDSet dict) = 70 | Dict.remove (prefix, key) dict 71 | |> PIDSet 72 | 73 | 74 | {-| Get all pids as a List 75 | 76 | -} 77 | toList : Set -> List PID 78 | toList (PIDSet dict) = 79 | Dict.values dict 80 | 81 | 82 | {-| Check if a Set is empty. 83 | 84 | -} 85 | isEmpty : Set -> Bool 86 | isEmpty (PIDSet dict) = 87 | Dict.isEmpty dict 88 | --------------------------------------------------------------------------------