--module Main exposing (Model, Msg, update, view, init) port module Main exposing (..) import Browser import Html exposing (Html, Attribute, button, div, h1, p, text) import Html.Attributes as HAttr exposing (class, classList, value) import Html.Events as HEvent exposing (onClick, onInput, preventDefaultOn) import Html.Lazy exposing (lazy) import Tuple import Array exposing (get) --import Html exposing (address) import Json.Encode as JE import Json.Decode as JD --import Html.Events exposing (targetValue) import Http -- DragDrop import Task import Process import File exposing (File) import File.Select as Select import File.Download as Download -- PC Stuff import PC.Types exposing (..) import PC.PC as PC import PC.Json import PC.Helpers exposing (..) -- Note that general Stuff is at the end of the document examplesListUrl = "examples-list.json" -- #################################################### -- PORTS -- #################################################### port sendUUpdate : String -> Cmd msg port localStorageSend : String -> Cmd msg port sendProcessing : String -> Cmd msg -- ##################################################################### -- ##################################################################### type alias Model = { pc_model : PC_Model , autoscroll : Bool , examples : List Example , exampleChooserOpen : Bool , examplesListStatus : LoaderState , exampleLoaderStatus : LoaderState , dragDrop : DragDrop , showAlert : Bool } type alias Example = { title : String , version : String , url : String , enabled : Bool } type alias DragDrop = { hover : Bool , state : DragDropState , file : Maybe File , fileContent : Maybe String } type DragDropState = DS_Ready | DS_Processing | DS_Sucess | DS_Failure type LoaderState = Failure String | Waiting | Success -- ##################################################################### -- Update -- ##################################################################### -- DEsmpl = Dialog Examples -- DrgDrp = DragDrop type Msg = Msg_PC PC_Msg | Msg_Autoscroll_Toggle | Msg_DEsmpl_Open Bool | Msg_DEsmpl_EClick Int | Msg_DEsmpl_LoadWithDelay Example | Msg_DEsmpl_ExampleLoaded (Result Http.Error Model) | Msg_DEsmpl_ListLoaded (Result Http.Error (List Example)) | Msg_DEsmpl_Download | Msg_DEsmpl_Upload | Msg_DrgDrp_Hover Bool | Msg_DrgDrp_GotFiles File (List File) | Msg_DrgDrp_DecodedFiles String | Msg_Alert_Hide | Msg_Nothing update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = let old_dragDrop = model.dragDrop in case msg of Msg_PC pc_msg -> -- PC is updated let (new_pc, pua) = PC.update pc_msg model.pc_model new_model = {model | pc_model = new_pc} in case pua of PUA_Nothing -> ( new_model , Cmd.none) PUA_Storage -> ( new_model , cmd_up_lStorage new_model) PUA_Scroller -> ( new_model , cmd_scoller new_model ) PUA_Storage_And_Scroller -> ( new_model , cmd_up_lStorage_n_Scroller new_model ) PUA_Alert -> ( { new_model | showAlert = True } , cmd_up_lStorage new_model ) Msg_Autoscroll_Toggle -> -- User toggled automatic scrolling checkbox let new_model = { model | autoscroll = not model.autoscroll } in ( new_model, cmd_up_lStorage_n_Scroller new_model ) Msg_DEsmpl_Open True -> -- When the user clicks on "open examples" ( { model | exampleChooserOpen = True } , Http.get { url = examplesListUrl , expect = Http.expectJson Msg_DEsmpl_ListLoaded exampleListDecoder } ) Msg_DEsmpl_Open False -> -- User closes Dialog ( { model | exampleChooserOpen = False }, Cmd.none ) Msg_DEsmpl_EClick i -> -- User chose example. Load it. case valueAt i model.examples of Just example -> ( { model | dragDrop = { old_dragDrop | state = DS_Processing } } , Task.perform (\_ -> Msg_DEsmpl_LoadWithDelay example) <| Process.sleep 500 ) Nothing -> ( model, Cmd.none ) Msg_DEsmpl_LoadWithDelay example -> ( model , Http.get { url = example.url , expect = Http.expectJson Msg_DEsmpl_ExampleLoaded modelDecoder } ) Msg_DEsmpl_ExampleLoaded result -> -- When a single example is loaded case result of Ok example_model -> let new_model = { model | pc_model = example_model.pc_model , exampleLoaderStatus = Success , exampleChooserOpen = False , dragDrop = { old_dragDrop | state = DS_Sucess } } in ( new_model , cmd_up_lStorage_n_Scroller new_model ) Err err -> ( { model | exampleLoaderStatus = Failure <| printHttpError err , dragDrop = { old_dragDrop | state = DS_Sucess } } , Cmd.none ) Msg_DEsmpl_ListLoaded result -> case result of Ok exampleList -> ( { model | examples = exampleList, examplesListStatus = Success } , Cmd.none ) Err err -> ( { model | examplesListStatus = Failure <| printHttpError err } , Cmd.none ) Msg_DEsmpl_Download -> ( model , Download.string "johnny-export.json" "application/json" <| doEncodeModel model ) Msg_DEsmpl_Upload -> ( model , Select.files ["application/json"] Msg_DrgDrp_GotFiles ) Msg_DrgDrp_Hover new_hover -> ( { model | dragDrop = {old_dragDrop | hover = new_hover, state = DS_Ready } } , Cmd.none ) Msg_DrgDrp_GotFiles file _ -> if File.size file > 10000 then -- Big File ( { model | dragDrop = { old_dragDrop | hover = False , state = DS_Processing , file = Just file } } , Task.perform Msg_DrgDrp_DecodedFiles (File.toString file) ) else ( { model | dragDrop = { old_dragDrop | hover = False , state = DS_Processing , file = Just file } } , Task.perform Msg_DrgDrp_DecodedFiles ( Process.sleep 2000 |> Task.andThen (\_ -> File.toString file) ) ) Msg_DrgDrp_DecodedFiles content -> case doDecodeModel content of Just new_model -> ( { model | exampleChooserOpen = False , dragDrop = { old_dragDrop | state = DS_Sucess , hover = False , fileContent = Just content } , pc_model = new_model.pc_model } , sendProcessing "Done" ) Nothing -> ( { model | exampleChooserOpen = False , dragDrop = { old_dragDrop | state = DS_Failure , hover = False , fileContent = Just content } } , sendProcessing "Done" ) Msg_Alert_Hide -> ( {model | showAlert = False} , Cmd.none) Msg_Nothing -> (model, Cmd.none) -- ############################################################################### cmd_up_lStorage : Model -> Cmd Msg cmd_up_lStorage model = localStorageSend (doEncodeModel model) cmd_scoller : Model -> Cmd Msg cmd_scoller model = sendUUpdate "update" cmd_up_lStorage_n_Scroller : Model -> Cmd Msg cmd_up_lStorage_n_Scroller model = Cmd.batch [ cmd_up_lStorage model , cmd_scoller model ] -- ############################################################################### -- ############################################################################### -- ############################################################################### -- Encoders and Decoders -- ############################################################################### exampleListDecoder : JD.Decoder (List Example) exampleListDecoder = JD.field "available" <| JD.list <| JD.map4 Example ( JD.field "title" JD.string ) ( JD.field "version" JD.string ) ( JD.field "url" JD.string ) ( JD.field "enabled" (JD.map (\s -> s == 1) JD.int) ) doEncodeModel : Model -> String doEncodeModel model = JE.object [ ( "model-version" , JE.string pcModelVersion ) , ( "pc_model" , PC.Json.pcModelEncoder model.pc_model ) , ( "autoscroll" , JE.bool model.autoscroll ) ] |> JE.encode 0 doDecodeModel : String -> Maybe Model doDecodeModel jText = let error2maybe err = case err of Ok val -> Just val _ -> Nothing in jText |> JD.decodeString modelDecoder |> error2maybe modelDecoder : JD.Decoder Model modelDecoder = let mainDecoder : String -> JD.Decoder Model mainDecoder version = if (version == pcModelVersion) then JD.map2 (\a b -> Model a b [] False Waiting Waiting initDragDrop False ) ( JD.field "pc_model" PC.Json.pcModelDecoder ) ( JD.field "autoscroll" JD.bool ) else JD.fail <| "Outdated version: '" ++ version ++ "'" in JD.field "model-version" JD.string |> JD.andThen mainDecoder dropDecoder : JD.Decoder Msg dropDecoder = JD.at ["dataTransfer","files"] (JD.oneOrMore Msg_DrgDrp_GotFiles File.decoder) -- ##################################################################### -- ##################################################################### -- ##################################################################### -- VIEWERS -- ##################################################################### view : Model -> Html Msg view model = div [] [ lazy viewPC model , viewDragDrop model , viewAlert model ] viewPC : Model -> Html Msg viewPC model = div ([ class "pc" ] ++ dragDropAttributes) [ div [ class "controls", class "grid-fullwidth" ] [ button [ onClick <| Msg_PC PM_B_UCycleStep ] [ text "µCycle" ] , button [ onClick <| Msg_PC PM_B_InstructionStep ] [ text "Instruction" ] , button [ onClick <| Msg_PC PM_B_Reset ] [ text "Reset PC" ] , div [ classList [ ("checker", True) , ("button", True) , ("checked", model.autoscroll) ] , onClick Msg_Autoscroll_Toggle ] [ Html.input [ HAttr.type_ "checkbox" , HAttr.id "enableScrolling" , HAttr.checked model.autoscroll , onClick Msg_Autoscroll_Toggle ] [] , Html.label [ HAttr.for "enableScrolling" ] [ text "Autoscroll" ] ] , button [ onClick <| Msg_DEsmpl_Open True ] [ text "Configs" ] ] , div [class "pc-main"] [ Html.map Msg_PC <| PC.view model.pc_model ] , lazy viewExamples model , lazy viewExamplesLoaderError model ] viewExamples : Model -> Html Msg viewExamples model = div [ classList [("modal", True), ("hidden", (not model.exampleChooserOpen))] ] [ div [] [] , div [ class "modal-card" ] [ Html.a [ class "modal-close", onClick <| Msg_DEsmpl_Open False ] [] , div [ class "button-group" ] [ button [ onClick Msg_DEsmpl_Download ] [ text "Download current config" ] , button [ onClick Msg_DEsmpl_Upload ] [ text "Upload" ] ] , Html.span [ class "example-scroller-label" ] [ text "Premade examples" ] , lazy viewExamplesEntrys model ] ] viewExamplesEntrys : Model -> Html Msg viewExamplesEntrys model = let entry2html (id, example) = Html.tr [] [ Html.td [] [ text <| "Example: " ++ example.title ] , Html.td [] [ button [ onClick <| Msg_DEsmpl_EClick id ] [ text "Laden" ] ] ] in case model.examplesListStatus of Failure msg -> div [] [ text <| "That didn't work: " ++ msg] Waiting -> div [] [ text "Loading..." ] Success -> div [ class "scroller", class "examples-list" ] [ Html.table [] <| List.map entry2html <| List.indexedMap Tuple.pair model.examples ] viewExamplesLoaderError : Model -> Html Msg viewExamplesLoaderError model = case model.exampleLoaderStatus of Failure msg -> div [ class "modal" ] [ div [] [] , div [ class "modal-card" ] [ Html.p [] [ text "Something didn't work. Please refresh the page"] , Html.p [] [ text msg ] ] ] _ -> text "" viewDragDrop : Model -> Html Msg viewDragDrop model = div ([ classList [ ("dragDrop", True) , ("hover", model.dragDrop.hover || model.dragDrop.state == DS_Failure) , ("loading", model.dragDrop.state == DS_Processing) ] ] ++ dragDropAttributes) [ div [ class "loader" ] <| List.repeat 10 <| div [] [] , p [] [ case (model.dragDrop.hover, model.dragDrop.state) of (_,DS_Failure) -> text <| "Oh no, that didn't work. " (_,DS_Processing) -> text "Loading. Hold on tight." (True,_) -> text "Let go to load the file." (_,DS_Sucess) -> text <| "Success" (_,DS_Ready) -> text "Let go to load the file." ] ] viewAlert : Model -> Html Msg viewAlert model = div [ classList [("modal", True) , ("hidden", not model.showAlert)] ] [ div [] [] , div [ class "modal-card" ] [ p [] [ text "End of Program reached" ] , button [ onClick Msg_Alert_Hide ] [ text "Ok" ] ] ] dragDropAttributes : List (Attribute Msg) dragDropAttributes = [ hiJackOn "dragenter" <| JD.succeed <| Msg_DrgDrp_Hover True , hiJackOn "dragover" <| JD.succeed <| Msg_DrgDrp_Hover True , hiJackOn "dragleave" <| JD.succeed <| Msg_DrgDrp_Hover False , hiJackOn "drop" dropDecoder ] -- END VIEWERS -- ##################################################################### -- ##################################################################### -- ##################################################################### -- HELPERS -- ##################################################################### --changeAtUCode : Int -> UAction -> List UAction -> List UAction --changeAtUCode pos newVal list = -- changeAt pos newVal ActNothing list hiJack : msg -> (msg, Bool) hiJack msg = (msg, True) -- Thanks to https://elm-lang.org/examples/drag-and-drop hiJackOn : String -> JD.Decoder msg -> Attribute msg hiJackOn event decoder = preventDefaultOn event (JD.map hiJack decoder) -- END HELPERS -- ##################################################################### -- ##################################################################### -- ##################################################################### -- GENERAL -- ##################################################################### subscriptions : Model -> Sub Msg subscriptions model = Sub.none --localStorageRecieve Msg_LocalStorageLoaded -- TODO: Make it load localStorage when starting init : String -> ( Model, Cmd Msg ) init mayLocalStorage = case doDecodeModel mayLocalStorage of Just init_model -> ({ pc_model = init_model.pc_model , autoscroll = init_model.autoscroll , examples = [] , exampleChooserOpen = False , examplesListStatus = Waiting , exampleLoaderStatus = Waiting , dragDrop = initDragDrop , showAlert = False } , Cmd.none ) Nothing -> ({ pc_model = PC.init , autoscroll = True , examples = [] , exampleChooserOpen = False , examplesListStatus = Waiting , exampleLoaderStatus = Waiting , dragDrop = initDragDrop , showAlert = False } , Cmd.none ) initDragDrop : DragDrop initDragDrop = { hover = False , state = DS_Ready , file = Nothing , fileContent = Nothing } main : Program String Model Msg main = Browser.element { init = init , view = view , update = update , subscriptions = subscriptions } -- ##################################################################### -- ##################################################################### -- Done.