From b4499738ae8d952c68eb0e27b4d0e9eff0a9a3a3 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Tue, 17 Sep 2024 23:02:27 +0100 Subject: [PATCH] Add more examples #22 --- compiler/src/Data/Graph.elm | 24 +- compiler/src/Parse/Shader.elm | 91 +- compiler/src/Reporting/Doc.elm | 10 +- compiler/src/Reporting/Render/Type.elm | 3 +- examples/elm.json | 7 +- examples/src/Animation.elm | 27 + examples/src/Book.elm | 90 ++ examples/src/Crate.elm | 228 ++++ examples/src/Cube.elm | 189 +++ examples/src/CurrentTime.elm | 96 ++ examples/src/DragAndDrop.elm | 139 +++ examples/src/FirstPerson.elm | 376 ++++++ examples/src/Forms.elm | 87 ++ examples/src/Groceries.elm | 23 + examples/src/ImagePreviews.elm | 163 +++ examples/src/Keyboard.elm | 26 + examples/src/Mario.elm | 103 ++ examples/src/Mouse.elm | 31 + examples/src/Numbers.elm | 85 ++ examples/src/Picture.elm | 18 + examples/src/Positions.elm | 97 ++ examples/src/{HttpQuotes.elm => Quotes.elm} | 2 +- examples/src/Shapes.elm | 80 ++ examples/src/TextFields.elm | 61 + examples/src/Thwomp.elm | 296 +++++ examples/src/Triangle.elm | 140 +++ examples/src/Turtle.elm | 35 + examples/src/Upload.elm | 87 ++ review/src/ReviewConfig.elm | 4 +- src/Language/GLSL/Parser.elm | 1226 +++++++++++++++++++ src/Language/GLSL/Syntax.elm | 358 ++++++ terminal/src/Develop/Socket.elm | 8 +- tests/backwards-compatibility.test.js | 66 +- 33 files changed, 4201 insertions(+), 75 deletions(-) create mode 100644 examples/src/Animation.elm create mode 100644 examples/src/Book.elm create mode 100644 examples/src/Crate.elm create mode 100644 examples/src/Cube.elm create mode 100644 examples/src/CurrentTime.elm create mode 100644 examples/src/DragAndDrop.elm create mode 100644 examples/src/FirstPerson.elm create mode 100644 examples/src/Forms.elm create mode 100644 examples/src/Groceries.elm create mode 100644 examples/src/ImagePreviews.elm create mode 100644 examples/src/Keyboard.elm create mode 100644 examples/src/Mario.elm create mode 100644 examples/src/Mouse.elm create mode 100644 examples/src/Numbers.elm create mode 100644 examples/src/Picture.elm create mode 100644 examples/src/Positions.elm rename examples/src/{HttpQuotes.elm => Quotes.elm} (98%) create mode 100644 examples/src/Shapes.elm create mode 100644 examples/src/TextFields.elm create mode 100644 examples/src/Thwomp.elm create mode 100644 examples/src/Triangle.elm create mode 100644 examples/src/Turtle.elm create mode 100644 examples/src/Upload.elm create mode 100644 src/Language/GLSL/Parser.elm create mode 100644 src/Language/GLSL/Syntax.elm diff --git a/compiler/src/Data/Graph.elm b/compiler/src/Data/Graph.elm index 9c55c6f55..f4bbf1cc2 100644 --- a/compiler/src/Data/Graph.elm +++ b/compiler/src/Data/Graph.elm @@ -4,12 +4,10 @@ module Data.Graph exposing , Graph , SCC(..) , Table - , Vertex - -- , bcc - - , buildG - -- , components - + , Vertex + -- , bcc + , buildG + -- , components , dff , dfs , edges @@ -18,16 +16,14 @@ module Data.Graph exposing , graphFromEdges , graphFromEdges_ , indegree - , outdegree - -- , path - -- , reachable - -- , reverseTopSort - + , outdegree + -- , path + -- , reachable + -- , reverseTopSort , scc , stronglyConnComp - , stronglyConnCompR - -- , topSort - + , stronglyConnCompR + -- , topSort , transposeG , vertices ) diff --git a/compiler/src/Parse/Shader.elm b/compiler/src/Parse/Shader.elm index 9726c05f1..83b4b71b7 100644 --- a/compiler/src/Parse/Shader.elm +++ b/compiler/src/Parse/Shader.elm @@ -1,12 +1,16 @@ module Parse.Shader exposing (shader) +-- import Language.GLSL.Parser as GLP + import AST.Source as Src import AST.Utils.Shader as Shader import Data.Map as Dict import Data.Name as Name +import Language.GLSL.Syntax as GLS import Parse.Primitives as P exposing (Col, Parser, Row) import Reporting.Annotation as A import Reporting.Error.Syntax as E +import Utils.Crash as Crash @@ -157,41 +161,54 @@ emptyTypes = Shader.Types Dict.empty Dict.empty Dict.empty +addInput : ( GLS.StorageQualifier, Shader.Type, String ) -> Shader.Types -> Shader.Types +addInput ( qual, tipe, name ) (Shader.Types attribute uniform varying) = + case qual of + GLS.Attribute -> + Shader.Types (Dict.insert compare name tipe attribute) uniform varying + + GLS.Uniform -> + Shader.Types attribute (Dict.insert compare name tipe uniform) varying + + GLS.Varying -> + Shader.Types attribute uniform (Dict.insert compare name tipe varying) + + _ -> + Crash.crash "Should never happen due to `extractInputs` function" + + +extractInputs : GLS.ExternalDeclaration -> List ( GLS.StorageQualifier, Shader.Type, String ) +extractInputs decl = + case decl of + GLS.Declaration (GLS.InitDeclaration (GLS.TypeDeclarator (GLS.FullType (Just (GLS.TypeQualSto qual)) (GLS.TypeSpec _ (GLS.TypeSpecNoPrecision tipe _)))) [ GLS.InitDecl name _ _ ]) -> + if List.member qual [ GLS.Attribute, GLS.Varying, GLS.Uniform ] then + case tipe of + GLS.Vec2 -> + [ ( qual, Shader.V2, name ) ] + + GLS.Vec3 -> + [ ( qual, Shader.V3, name ) ] + + GLS.Vec4 -> + [ ( qual, Shader.V4, name ) ] + + GLS.Mat4 -> + [ ( qual, Shader.M4, name ) ] + + GLS.Int -> + [ ( qual, Shader.Int, name ) ] + + GLS.Float -> + [ ( qual, Shader.Float, name ) ] + + GLS.Sampler2D -> + [ ( qual, Shader.Texture, name ) ] + + _ -> + [] + + else + [] --- addInput : ( GLS.StorageQualifier, Shader.Type, String ) -> Shader.Types -> Shader.Types --- addInput ( qual, tipe, name ) glDecls = --- case qual of --- GLS.Attribute -> --- { glDecls | attribute = Dict.insert (Name.fromChars name) tipe glDecls.attribute } --- GLS.Uniform -> --- { glDecls | uniform = Dict.insert (Name.fromChars name) tipe glDecls.uniform } --- GLS.Varying -> --- { glDecls | varying = Dict.insert (Name.fromChars name) tipe glDecls.varying } --- _ -> --- Debug.crash "Should never happen due to `extractInputs` function" --- extractInputs : GLS.ExternalDeclaration -> List ( GLS.StorageQualifier, Shader.Type, String ) --- extractInputs decl = --- case decl of --- GLS.Declaration (GLS.InitDeclaration (GLS.TypeDeclarator (GLS.FullType (Just (GLS.TypeQualSto qual)) (GLS.TypeSpec _ prec (GLS.TypeSpecNoPrecision tipe _ mexpr1)))) [ GLS.InitDecl name _ mexpr2 _ mexpr3 ]) -> --- if List.member qual [ GLS.Attribute, GLS.Varying, GLS.Uniform ] then --- case tipe of --- GLS.Vec2 -> --- [ ( qual, Shader.V2, name ) ] --- GLS.Vec3 -> --- [ ( qual, Shader.V3, name ) ] --- GLS.Vec4 -> --- [ ( qual, Shader.V4, name ) ] --- GLS.Mat4 -> --- [ ( qual, Shader.M4, name ) ] --- GLS.Int -> --- [ ( qual, Shader.Int, name ) ] --- GLS.Float -> --- [ ( qual, Shader.Float, name ) ] --- GLS.Sampler2D -> --- [ ( qual, Shader.Texture, name ) ] --- _ -> --- [] --- else --- [] --- _ -> --- [] + _ -> + [] diff --git a/compiler/src/Reporting/Doc.elm b/compiler/src/Reporting/Doc.elm index 03acdcdd2..657a44623 100644 --- a/compiler/src/Reporting/Doc.elm +++ b/compiler/src/Reporting/Doc.elm @@ -26,16 +26,14 @@ module Reporting.Doc exposing , fromPackage , fromVersion , green - , hang - -- , hcat - + , hang + -- , hcat , hsep , indent , intToOrdinal , join - , link - -- , magenta - + , link + -- , magenta , makeLink , makeNakedLink , moreArgs diff --git a/compiler/src/Reporting/Render/Type.elm b/compiler/src/Reporting/Render/Type.elm index 46a578879..13254d753 100644 --- a/compiler/src/Reporting/Render/Type.elm +++ b/compiler/src/Reporting/Render/Type.elm @@ -73,8 +73,7 @@ tuple : D.Doc -> D.Doc -> List D.Doc -> D.Doc tuple a b cs = let entries = - List.interweave (D.fromChars "(" :: List.repeat (List.length (b :: cs)) (D.fromChars ",")) (a :: b :: cs) - |> List.intersperse (D.fromChars " ") + List.interweave (D.fromChars "( " :: List.repeat (List.length (b :: cs)) (D.fromChars ", ")) (a :: b :: cs) in D.align <| D.sep [ D.cat entries, D.fromChars ")" ] diff --git a/examples/elm.json b/examples/elm.json index 6a1a998a3..1f59dad67 100644 --- a/examples/elm.json +++ b/examples/elm.json @@ -8,16 +8,19 @@ "direct": { "elm/browser": "1.0.2", "elm/core": "1.0.5", + "elm/file": "1.0.5", "elm/html": "1.0.0", "elm/http": "2.0.0", "elm/json": "1.1.3", "elm/random": "1.0.0", "elm/svg": "1.0.1", - "elm/time": "1.0.0" + "elm/time": "1.0.0", + "elm-explorations/linear-algebra": "1.0.3", + "elm-explorations/webgl": "1.1.3", + "evancz/elm-playground": "1.0.3" }, "indirect": { "elm/bytes": "1.0.8", - "elm/file": "1.0.5", "elm/url": "1.0.0", "elm/virtual-dom": "1.0.3" } diff --git a/examples/src/Animation.elm b/examples/src/Animation.elm new file mode 100644 index 000000000..24f398e57 --- /dev/null +++ b/examples/src/Animation.elm @@ -0,0 +1,27 @@ +module Animation exposing (main) + +-- Create animations that spin, wave, and zig-zag. +-- This one is a little red wagon bumping along a dirt road. +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + animation view + + +view time = + [ octagon darkGray 36 + |> moveLeft 100 + |> rotate (spin 3 time) + , octagon darkGray 36 + |> moveRight 100 + |> rotate (spin 3 time) + , rectangle red 300 80 + |> moveUp (wave 50 54 2 time) + |> rotate (zigzag -2 2 8 time) + ] diff --git a/examples/src/Book.elm b/examples/src/Book.elm new file mode 100644 index 000000000..bdd67198a --- /dev/null +++ b/examples/src/Book.elm @@ -0,0 +1,90 @@ +module Book exposing (main) + +-- Make a GET request to load a book called "Public Opinion" +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/http.html +-- + +import Browser +import Html exposing (Html, pre, text) +import Http + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type Model + = Failure + | Loading + | Success String + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Loading + , Http.get + { url = "https://elm-lang.org/assets/public-opinion.txt" + , expect = Http.expectString GotText + } + ) + + + +-- UPDATE + + +type Msg + = GotText (Result Http.Error String) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + GotText result -> + case result of + Ok fullText -> + ( Success fullText, Cmd.none ) + + Err _ -> + ( Failure, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + case model of + Failure -> + text "I was unable to load your book." + + Loading -> + text "Loading..." + + Success fullText -> + pre [] [ text fullText ] diff --git a/examples/src/Crate.elm b/examples/src/Crate.elm new file mode 100644 index 000000000..55a97c312 --- /dev/null +++ b/examples/src/Crate.elm @@ -0,0 +1,228 @@ +module Crate exposing (..) + +-- Demonstrate how to load textures and put them on a cube. +-- +-- Dependencies: +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- + +import Browser +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector2 as Vec2 exposing (Vec2, vec2) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import Result +import Task +import WebGL +import WebGL.Texture as Texture + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = \msg model -> ( update msg model, Cmd.none ) + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { angle : Float + , texture : Maybe Texture.Texture + } + + +init : () -> ( Model, Cmd Msg ) +init () = + ( { angle = 0 + , texture = Nothing + } + , Task.attempt GotTexture (Texture.load "https://elm-lang.org/images/wood-crate.jpg") + ) + + + +-- UPDATE + + +type Msg + = TimeDelta Float + | GotTexture (Result Texture.Error Texture.Texture) + + +update : Msg -> Model -> Model +update msg model = + case msg of + TimeDelta dt -> + { model | angle = model.angle + dt / 5000 } + + GotTexture result -> + { model | texture = Result.toMaybe result } + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + E.onAnimationFrameDelta TimeDelta + + + +-- VIEW + + +view : Model -> Html Msg +view model = + case model.texture of + Nothing -> + Html.text "Loading texture..." + + Just texture -> + WebGL.toHtml + [ width 400 + , height 400 + , style "display" "block" + ] + [ WebGL.entity vertexShader fragmentShader crateMesh (toUniforms model.angle texture) + ] + + + +-- UNIFORMS + + +type alias Uniforms = + { rotation : Mat4 + , perspective : Mat4 + , camera : Mat4 + , texture : Texture.Texture + } + + +toUniforms : Float -> Texture.Texture -> Uniforms +toUniforms angle texture = + { rotation = + Mat4.mul + (Mat4.makeRotate (3 * angle) (vec3 0 1 0)) + (Mat4.makeRotate (2 * angle) (vec3 1 0 0)) + , perspective = perspective + , camera = camera + , texture = texture + } + + +perspective : Mat4 +perspective = + Mat4.makePerspective 45 1 0.01 100 + + +camera : Mat4 +camera = + Mat4.makeLookAt (vec3 0 0 5) (vec3 0 0 0) (vec3 0 1 0) + + + +-- MESH + + +type alias Vertex = + { position : Vec3 + , coord : Vec2 + } + + +crateMesh : WebGL.Mesh Vertex +crateMesh = + WebGL.triangles <| + List.concatMap rotatedSquare <| + [ ( 0, 0 ) + , ( 90, 0 ) + , ( 180, 0 ) + , ( 270, 0 ) + , ( 0, 90 ) + , ( 0, 270 ) + ] + + +rotatedSquare : ( Float, Float ) -> List ( Vertex, Vertex, Vertex ) +rotatedSquare ( angleXZ, angleYZ ) = + let + transformMat = + Mat4.mul + (Mat4.makeRotate (degrees angleXZ) Vec3.j) + (Mat4.makeRotate (degrees angleYZ) Vec3.i) + + transform vertex = + { vertex | position = Mat4.transform transformMat vertex.position } + + transformTriangle ( a, b, c ) = + ( transform a, transform b, transform c ) + in + List.map transformTriangle square + + +square : List ( Vertex, Vertex, Vertex ) +square = + let + topLeft = + Vertex (vec3 -1 1 1) (vec2 0 1) + + topRight = + Vertex (vec3 1 1 1) (vec2 1 1) + + bottomLeft = + Vertex (vec3 -1 -1 1) (vec2 0 0) + + bottomRight = + Vertex (vec3 1 -1 1) (vec2 1 0) + in + [ ( topLeft, topRight, bottomLeft ) + , ( bottomLeft, topRight, bottomRight ) + ] + + + +-- SHADERS + + +vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec2 coord; + uniform mat4 perspective; + uniform mat4 camera; + uniform mat4 rotation; + varying vec2 vcoord; + + void main () { + gl_Position = perspective * camera * rotation * vec4(position, 1.0); + vcoord = coord; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 } +fragmentShader = + [glsl| + precision mediump float; + uniform sampler2D texture; + varying vec2 vcoord; + + void main () { + gl_FragColor = texture2D(texture, vcoord); + } + |] diff --git a/examples/src/Cube.elm b/examples/src/Cube.elm new file mode 100644 index 000000000..dcfed360c --- /dev/null +++ b/examples/src/Cube.elm @@ -0,0 +1,189 @@ +module Cube exposing (main) + +-- Render a spinning cube. +-- +-- Dependencies: +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- + +import Browser +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import WebGL + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + Float + + +init : () -> ( Model, Cmd Msg ) +init () = + ( 0, Cmd.none ) + + + +-- UPDATE + + +type Msg + = TimeDelta Float + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg angle = + case msg of + TimeDelta dt -> + ( angle + dt / 5000, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + E.onAnimationFrameDelta TimeDelta + + + +-- VIEW + + +view : Model -> Html Msg +view angle = + WebGL.toHtml + [ width 400 + , height 400 + , style "display" "block" + ] + [ WebGL.entity vertexShader fragmentShader cubeMesh (uniforms angle) + ] + + +type alias Uniforms = + { rotation : Mat4 + , perspective : Mat4 + , camera : Mat4 + } + + +uniforms : Float -> Uniforms +uniforms angle = + { rotation = + Mat4.mul + (Mat4.makeRotate (3 * angle) (vec3 0 1 0)) + (Mat4.makeRotate (2 * angle) (vec3 1 0 0)) + , perspective = Mat4.makePerspective 45 1 0.01 100 + , camera = Mat4.makeLookAt (vec3 0 0 5) (vec3 0 0 0) (vec3 0 1 0) + } + + + +-- MESH + + +type alias Vertex = + { color : Vec3 + , position : Vec3 + } + + +cubeMesh : WebGL.Mesh Vertex +cubeMesh = + let + rft = + vec3 1 1 1 + + lft = + vec3 -1 1 1 + + lbt = + vec3 -1 -1 1 + + rbt = + vec3 1 -1 1 + + rbb = + vec3 1 -1 -1 + + rfb = + vec3 1 1 -1 + + lfb = + vec3 -1 1 -1 + + lbb = + vec3 -1 -1 -1 + in + WebGL.triangles <| + List.concat <| + [ face (vec3 115 210 22) rft rfb rbb rbt -- green + , face (vec3 52 101 164) rft rfb lfb lft -- blue + , face (vec3 237 212 0) rft lft lbt rbt -- yellow + , face (vec3 204 0 0) rfb lfb lbb rbb -- red + , face (vec3 117 80 123) lft lfb lbb lbt -- purple + , face (vec3 245 121 0) rbt rbb lbb lbt -- orange + ] + + +face : Vec3 -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> List ( Vertex, Vertex, Vertex ) +face color a b c d = + let + vertex position = + Vertex (Vec3.scale (1 / 255) color) position + in + [ ( vertex a, vertex b, vertex c ) + , ( vertex c, vertex d, vertex a ) + ] + + + +-- SHADERS + + +vertexShader : WebGL.Shader Vertex Uniforms { vcolor : Vec3 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec3 color; + uniform mat4 perspective; + uniform mat4 camera; + uniform mat4 rotation; + varying vec3 vcolor; + void main () { + gl_Position = perspective * camera * rotation * vec4(position, 1.0); + vcolor = color; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcolor : Vec3 } +fragmentShader = + [glsl| + precision mediump float; + varying vec3 vcolor; + void main () { + gl_FragColor = 0.8 * vec4(vcolor, 1.0); + } + |] diff --git a/examples/src/CurrentTime.elm b/examples/src/CurrentTime.elm new file mode 100644 index 000000000..bd62a51f5 --- /dev/null +++ b/examples/src/CurrentTime.elm @@ -0,0 +1,96 @@ +module CurrentTime exposing (main) + +-- Show the current time in your time zone. +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/time.html +-- +-- For an analog clock, check out this SVG example: +-- https://elm-lang.org/examples/clock +-- + +import Browser +import Html exposing (..) +import Task +import Time + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { zone : Time.Zone + , time : Time.Posix + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model Time.utc (Time.millisToPosix 0) + , Task.perform AdjustTimeZone Time.here + ) + + + +-- UPDATE + + +type Msg + = Tick Time.Posix + | AdjustTimeZone Time.Zone + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Tick newTime -> + ( { model | time = newTime } + , Cmd.none + ) + + AdjustTimeZone newZone -> + ( { model | zone = newZone } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Time.every 1000 Tick + + + +-- VIEW + + +view : Model -> Html Msg +view model = + let + hour = + String.fromInt (Time.toHour model.zone model.time) + + minute = + String.fromInt (Time.toMinute model.zone model.time) + + second = + String.fromInt (Time.toSecond model.zone model.time) + in + h1 [] [ text (hour ++ ":" ++ minute ++ ":" ++ second) ] diff --git a/examples/src/DragAndDrop.elm b/examples/src/DragAndDrop.elm new file mode 100644 index 000000000..80651eaee --- /dev/null +++ b/examples/src/DragAndDrop.elm @@ -0,0 +1,139 @@ +module DragAndDrop exposing (main) + +-- Image upload with a drag and drop zone. +-- +-- Dependencies: +-- elm install elm/file +-- elm install elm/json +-- + +import Browser +import File exposing (File) +import File.Select as Select +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Json.Decode as D + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { hover : Bool + , files : List File + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model False [], Cmd.none ) + + + +-- UPDATE + + +type Msg + = Pick + | DragEnter + | DragLeave + | GotFiles File (List File) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Pick -> + ( model + , Select.files [ "image/*" ] GotFiles + ) + + DragEnter -> + ( { model | hover = True } + , Cmd.none + ) + + DragLeave -> + ( { model | hover = False } + , Cmd.none + ) + + GotFiles file files -> + ( { model + | files = file :: files + , hover = False + } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div + [ style "border" + (if model.hover then + "6px dashed purple" + + else + "6px dashed #ccc" + ) + , style "border-radius" "20px" + , style "width" "480px" + , style "height" "100px" + , style "margin" "100px auto" + , style "padding" "20px" + , style "display" "flex" + , style "flex-direction" "column" + , style "justify-content" "center" + , style "align-items" "center" + , hijackOn "dragenter" (D.succeed DragEnter) + , hijackOn "dragover" (D.succeed DragEnter) + , hijackOn "dragleave" (D.succeed DragLeave) + , hijackOn "drop" dropDecoder + ] + [ button [ onClick Pick ] [ text "Upload Images" ] + , span [ style "color" "#ccc" ] [ text (Debug.toString model) ] + ] + + +dropDecoder : D.Decoder Msg +dropDecoder = + D.at [ "dataTransfer", "files" ] (D.oneOrMore GotFiles File.decoder) + + +hijackOn : String -> D.Decoder msg -> Attribute msg +hijackOn event decoder = + preventDefaultOn event (D.map hijack decoder) + + +hijack : msg -> ( msg, Bool ) +hijack msg = + ( msg, True ) diff --git a/examples/src/FirstPerson.elm b/examples/src/FirstPerson.elm new file mode 100644 index 000000000..a14dca978 --- /dev/null +++ b/examples/src/FirstPerson.elm @@ -0,0 +1,376 @@ +module FirstPerson exposing (main) + +-- Walk around in 3D space using the keyboard. +-- +-- Dependencies: +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- +-- Try adding the ability to crouch or to land on top of the crate! +-- + +import Browser +import Browser.Dom as Dom +import Browser.Events as E +import Html exposing (Html, div, p, text) +import Html.Attributes exposing (height, style, width) +import Json.Decode as D +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector2 as Vec2 exposing (Vec2, vec2) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import Task +import WebGL +import WebGL.Texture as Texture + + + +-- MAIN + + +main : Program () Model Msg +main = + Browser.element + { init = init + , view = view + , update = \msg model -> ( update msg model, Cmd.none ) + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { keys : Keys + , width : Float + , height : Float + , person : Person + , texture : Maybe Texture.Texture + } + + +type alias Keys = + { up : Bool + , left : Bool + , down : Bool + , right : Bool + , space : Bool + } + + +type alias Person = + { position : Vec3 + , velocity : Vec3 + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( { keys = noKeys + , width = 400 + , height = 400 + , person = Person (vec3 0 eyeLevel -10) (vec3 0 0 0) + , texture = Nothing + } + , Cmd.batch + [ Task.attempt GotTexture (Texture.load "https://elm-lang.org/images/wood-crate.jpg") + , Task.perform (\{ viewport } -> Resized viewport.width viewport.height) Dom.getViewport + ] + ) + + +eyeLevel : Float +eyeLevel = + 2 + + +noKeys : Keys +noKeys = + Keys False False False False False + + + +-- UPDATE + + +type Msg + = GotTexture (Result Texture.Error Texture.Texture) + | KeyChanged Bool String + | TimeDelta Float + | Resized Float Float + | VisibilityChanged E.Visibility + + +update : Msg -> Model -> Model +update msg model = + case msg of + GotTexture result -> + { model | texture = Result.toMaybe result } + + KeyChanged isDown key -> + { model | keys = updateKeys isDown key model.keys } + + TimeDelta dt -> + { model | person = updatePerson dt model.keys model.person } + + Resized width height -> + { model + | width = width + , height = height + } + + VisibilityChanged _ -> + { model | keys = noKeys } + + +updateKeys : Bool -> String -> Keys -> Keys +updateKeys isDown key keys = + case key of + " " -> + { keys | space = isDown } + + "ArrowUp" -> + { keys | up = isDown } + + "ArrowLeft" -> + { keys | left = isDown } + + "ArrowDown" -> + { keys | down = isDown } + + "ArrowRight" -> + { keys | right = isDown } + + _ -> + keys + + +updatePerson : Float -> Keys -> Person -> Person +updatePerson dt keys person = + let + velocity = + stepVelocity dt keys person + + position = + Vec3.add person.position (Vec3.scale (dt / 500) velocity) + in + if Vec3.getY position < eyeLevel then + { position = Vec3.setY eyeLevel position + , velocity = Vec3.setY 0 velocity + } + + else + { position = position + , velocity = velocity + } + + +stepVelocity : Float -> Keys -> Person -> Vec3 +stepVelocity dt { left, right, up, down, space } person = + if Vec3.getY person.position > eyeLevel then + Vec3.setY (Vec3.getY person.velocity - dt / 250) person.velocity + + else + let + toV positive negative = + (if positive then + 1 + + else + 0 + ) + - (if negative then + 1 + + else + 0 + ) + in + vec3 (toV left right) + (if space then + 2 + + else + 0 + ) + (toV up down) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.batch + [ E.onResize (\w h -> Resized (toFloat w) (toFloat h)) + , E.onKeyUp (D.map (KeyChanged False) (D.field "key" D.string)) + , E.onKeyDown (D.map (KeyChanged True) (D.field "key" D.string)) + , E.onAnimationFrameDelta TimeDelta + , E.onVisibilityChange VisibilityChanged + ] + + + +-- VIEW + + +view : Model -> Html Msg +view model = + let + entities = + case model.texture of + Nothing -> + [] + + Just texture -> + [ viewCrate model.width model.height model.person texture ] + in + div + [ style "position" "absolute" + , style "left" "0" + , style "top" "0" + , style "width" (String.fromFloat model.width ++ "px") + , style "height" (String.fromFloat model.height ++ "px") + ] + [ WebGL.toHtmlWith [ WebGL.depth 1, WebGL.clearColor 1 1 1 1 ] + [ style "display" "block" + , width (round model.width) + , height (round model.height) + ] + entities + , keyboardInstructions model.keys + ] + + +viewCrate : Float -> Float -> Person -> Texture.Texture -> WebGL.Entity +viewCrate width height person texture = + let + perspective = + Mat4.mul + (Mat4.makePerspective 45 (width / height) 0.01 100) + (Mat4.makeLookAt person.position (Vec3.add person.position Vec3.k) Vec3.j) + in + WebGL.entity vertexShader + fragmentShader + crate + { texture = texture + , perspective = perspective + } + + +keyboardInstructions : Keys -> Html msg +keyboardInstructions keys = + div + [ style "position" "absolute" + , style "font-family" "monospace" + , style "text-align" "center" + , style "left" "20px" + , style "right" "20px" + , style "top" "20px" + ] + [ p [] [ text "Walk around with a first person perspective." ] + , p [] [ text "Arrows keys to move, space bar to jump." ] + ] + + + +-- MESH + + +type alias Vertex = + { position : Vec3 + , coord : Vec2 + } + + +crate : WebGL.Mesh Vertex +crate = + WebGL.triangles <| + List.concatMap rotatedSquare <| + [ ( 0, 0 ) + , ( 90, 0 ) + , ( 180, 0 ) + , ( 270, 0 ) + , ( 0, 90 ) + , ( 0, -90 ) + ] + + +rotatedSquare : ( Float, Float ) -> List ( Vertex, Vertex, Vertex ) +rotatedSquare ( angleXZ, angleYZ ) = + let + transformMat = + Mat4.mul + (Mat4.makeRotate (degrees angleXZ) Vec3.j) + (Mat4.makeRotate (degrees angleYZ) Vec3.i) + + transform vertex = + { vertex + | position = + Mat4.transform transformMat vertex.position + } + + transformTriangle ( a, b, c ) = + ( transform a, transform b, transform c ) + in + List.map transformTriangle square + + +square : List ( Vertex, Vertex, Vertex ) +square = + let + topLeft = + Vertex (vec3 -1 1 1) (vec2 0 1) + + topRight = + Vertex (vec3 1 1 1) (vec2 1 1) + + bottomLeft = + Vertex (vec3 -1 -1 1) (vec2 0 0) + + bottomRight = + Vertex (vec3 1 -1 1) (vec2 1 0) + in + [ ( topLeft, topRight, bottomLeft ) + , ( bottomLeft, topRight, bottomRight ) + ] + + + +-- SHADERS + + +type alias Uniforms = + { texture : Texture.Texture + , perspective : Mat4 + } + + +vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec2 coord; + uniform mat4 perspective; + varying vec2 vcoord; + + void main () { + gl_Position = perspective * vec4(position, 1.0); + vcoord = coord; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 } +fragmentShader = + [glsl| + precision mediump float; + uniform sampler2D texture; + varying vec2 vcoord; + + void main () { + gl_FragColor = texture2D(texture, vcoord); + } + |] diff --git a/examples/src/Forms.elm b/examples/src/Forms.elm new file mode 100644 index 000000000..97d3dbd7d --- /dev/null +++ b/examples/src/Forms.elm @@ -0,0 +1,87 @@ +module Forms exposing (main) + +-- Input a user name and password. Make sure the password matches. +-- +-- Read how it works: +-- https://guide.elm-lang.org/architecture/forms.html +-- + +import Browser +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (onInput) + + + +-- MAIN + + +main = + Browser.sandbox { init = init, update = update, view = view } + + + +-- MODEL + + +type alias Model = + { name : String + , password : String + , passwordAgain : String + } + + +init : Model +init = + Model "" "" "" + + + +-- UPDATE + + +type Msg + = Name String + | Password String + | PasswordAgain String + + +update : Msg -> Model -> Model +update msg model = + case msg of + Name name -> + { model | name = name } + + Password password -> + { model | password = password } + + PasswordAgain password -> + { model | passwordAgain = password } + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ viewInput "text" "Name" model.name Name + , viewInput "password" "Password" model.password Password + , viewInput "password" "Re-enter Password" model.passwordAgain PasswordAgain + , viewValidation model + ] + + +viewInput : String -> String -> String -> (String -> msg) -> Html msg +viewInput t p v toMsg = + input [ type_ t, placeholder p, value v, onInput toMsg ] [] + + +viewValidation : Model -> Html msg +viewValidation model = + if model.password == model.passwordAgain then + div [ style "color" "green" ] [ text "OK" ] + + else + div [ style "color" "red" ] [ text "Passwords do not match!" ] diff --git a/examples/src/Groceries.elm b/examples/src/Groceries.elm new file mode 100644 index 000000000..80a55a13f --- /dev/null +++ b/examples/src/Groceries.elm @@ -0,0 +1,23 @@ +module Groceries exposing (main) + +-- Show a list of items I need to buy at the grocery store. +-- + +import Html exposing (..) + + +main = + div [] + [ h1 [] [ text "My Grocery List" ] + , ul [] + [ li [] [ text "Black Beans" ] + , li [] [ text "Limes" ] + , li [] [ text "Greek Yogurt" ] + , li [] [ text "Cilantro" ] + , li [] [ text "Honey" ] + , li [] [ text "Sweet Potatoes" ] + , li [] [ text "Cumin" ] + , li [] [ text "Chili Powder" ] + , li [] [ text "Quinoa" ] + ] + ] diff --git a/examples/src/ImagePreviews.elm b/examples/src/ImagePreviews.elm new file mode 100644 index 000000000..c92e300d5 --- /dev/null +++ b/examples/src/ImagePreviews.elm @@ -0,0 +1,163 @@ +module ImagePreviews exposing (main) + +-- Image upload with a drag and drop zone. See image previews! +-- +-- Dependencies: +-- elm install elm/file +-- elm install elm/json +-- + +import Browser +import File exposing (File) +import File.Select as Select +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Json.Decode as D +import Task + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { hover : Bool + , previews : List String + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model False [], Cmd.none ) + + + +-- UPDATE + + +type Msg + = Pick + | DragEnter + | DragLeave + | GotFiles File (List File) + | GotPreviews (List String) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Pick -> + ( model + , Select.files [ "image/*" ] GotFiles + ) + + DragEnter -> + ( { model | hover = True } + , Cmd.none + ) + + DragLeave -> + ( { model | hover = False } + , Cmd.none + ) + + GotFiles file files -> + ( { model | hover = False } + , Task.perform GotPreviews <| + Task.sequence <| + List.map File.toUrl (file :: files) + ) + + GotPreviews urls -> + ( { model | previews = urls } + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div + [ style "border" + (if model.hover then + "6px dashed purple" + + else + "6px dashed #ccc" + ) + , style "border-radius" "20px" + , style "width" "480px" + , style "margin" "100px auto" + , style "padding" "40px" + , style "display" "flex" + , style "flex-direction" "column" + , style "justify-content" "center" + , style "align-items" "center" + , hijackOn "dragenter" (D.succeed DragEnter) + , hijackOn "dragover" (D.succeed DragEnter) + , hijackOn "dragleave" (D.succeed DragLeave) + , hijackOn "drop" dropDecoder + ] + [ button [ onClick Pick ] [ text "Upload Images" ] + , div + [ style "display" "flex" + , style "align-items" "center" + , style "height" "60px" + , style "padding" "20px" + ] + (List.map viewPreview model.previews) + ] + + +viewPreview : String -> Html msg +viewPreview url = + div + [ style "width" "60px" + , style "height" "60px" + , style "background-image" ("url('" ++ url ++ "')") + , style "background-position" "center" + , style "background-repeat" "no-repeat" + , style "background-size" "contain" + ] + [] + + +dropDecoder : D.Decoder Msg +dropDecoder = + D.at [ "dataTransfer", "files" ] (D.oneOrMore GotFiles File.decoder) + + +hijackOn : String -> D.Decoder msg -> Attribute msg +hijackOn event decoder = + preventDefaultOn event (D.map hijack decoder) + + +hijack : msg -> ( msg, Bool ) +hijack msg = + ( msg, True ) diff --git a/examples/src/Keyboard.elm b/examples/src/Keyboard.elm new file mode 100644 index 000000000..a3e6752b0 --- /dev/null +++ b/examples/src/Keyboard.elm @@ -0,0 +1,26 @@ +module Keyboard exposing (main) + +-- Move a square around with the arrow keys: UP, DOWN, LEFT, RIGHT +-- Try making it move around more quickly! +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + game view update ( 0, 0 ) + + +view computer ( x, y ) = + [ square blue 40 + |> move x y + ] + + +update computer ( x, y ) = + ( x + toX computer.keyboard + , y + toY computer.keyboard + ) diff --git a/examples/src/Mario.elm b/examples/src/Mario.elm new file mode 100644 index 000000000..2e8a889db --- /dev/null +++ b/examples/src/Mario.elm @@ -0,0 +1,103 @@ +module Mario exposing (main) + +-- Walk around with the arrow keys. Press the UP arrow to jump! +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + + +-- MAIN + + +main = + game view + update + { x = 0 + , y = 0 + , vx = 0 + , vy = 0 + , dir = "right" + } + + + +-- VIEW + + +view computer mario = + let + w = + computer.screen.width + + h = + computer.screen.height + + b = + computer.screen.bottom + in + [ rectangle (rgb 174 238 238) w h + , rectangle (rgb 74 163 41) w 100 + |> moveY b + , image 70 70 (toGif mario) + |> move mario.x (b + 76 + mario.y) + ] + + +toGif mario = + if mario.y > 0 then + "https://elm-lang.org/images/mario/jump/" ++ mario.dir ++ ".gif" + + else if mario.vx /= 0 then + "https://elm-lang.org/images/mario/walk/" ++ mario.dir ++ ".gif" + + else + "https://elm-lang.org/images/mario/stand/" ++ mario.dir ++ ".gif" + + + +-- UPDATE + + +update computer mario = + let + dt = + 1.666 + + vx = + toX computer.keyboard + + vy = + if mario.y == 0 then + if computer.keyboard.up then + 5 + + else + 0 + + else + mario.vy - dt / 8 + + x = + mario.x + dt * vx + + y = + mario.y + dt * vy + in + { x = x + , y = max 0 y + , vx = vx + , vy = vy + , dir = + if vx == 0 then + mario.dir + + else if vx < 0 then + "left" + + else + "right" + } diff --git a/examples/src/Mouse.elm b/examples/src/Mouse.elm new file mode 100644 index 000000000..ed30453a8 --- /dev/null +++ b/examples/src/Mouse.elm @@ -0,0 +1,31 @@ +module Mouse exposing (main) + +-- Draw a cicle around the mouse. Change its color by pressing down. +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + game view update () + + +view computer memory = + [ circle lightPurple 30 + |> moveX computer.mouse.x + |> moveY computer.mouse.y + |> fade + (if computer.mouse.down then + 0.2 + + else + 1 + ) + ] + + +update computer memory = + memory diff --git a/examples/src/Numbers.elm b/examples/src/Numbers.elm new file mode 100644 index 000000000..5af8b6fa0 --- /dev/null +++ b/examples/src/Numbers.elm @@ -0,0 +1,85 @@ +module Numbers exposing (main) + +-- Press a button to generate a random number between 1 and 6. +-- +-- Read how it works: +-- https://guide.elm-lang.org/effects/random.html +-- + +import Browser +import Html exposing (..) +import Html.Events exposing (..) +import Random + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type alias Model = + { dieFace : Int + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model 1 + , Cmd.none + ) + + + +-- UPDATE + + +type Msg + = Roll + | NewFace Int + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Roll -> + ( model + , Random.generate NewFace (Random.int 1 6) + ) + + NewFace newFace -> + ( Model newFace + , Cmd.none + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ h1 [] [ text (String.fromInt model.dieFace) ] + , button [ onClick Roll ] [ text "Roll" ] + ] diff --git a/examples/src/Picture.elm b/examples/src/Picture.elm new file mode 100644 index 000000000..d767383be --- /dev/null +++ b/examples/src/Picture.elm @@ -0,0 +1,18 @@ +module Picture exposing (main) + +-- Create pictures from simple shapes. Like a tree! +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + picture + [ rectangle brown 40 200 + |> moveDown 80 + , circle green 100 + |> moveUp 100 + ] diff --git a/examples/src/Positions.elm b/examples/src/Positions.elm new file mode 100644 index 000000000..568c7cf34 --- /dev/null +++ b/examples/src/Positions.elm @@ -0,0 +1,97 @@ +module Positions exposing (main) + +-- A button that moves to random positions when pressed. +-- +-- Dependencies: +-- elm install elm/random +-- + +import Browser +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Random + + + +-- MAIN + + +main = + Browser.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + + +-- MODEL + + +type alias Model = + { x : Int + , y : Int + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( Model 100 100 + , Cmd.none + ) + + + +-- UPDATE + + +type Msg + = Clicked + | NewPosition ( Int, Int ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Clicked -> + ( model + , Random.generate NewPosition positionGenerator + ) + + NewPosition ( x, y ) -> + ( Model x y + , Cmd.none + ) + + +positionGenerator : Random.Generator ( Int, Int ) +positionGenerator = + Random.map2 Tuple.pair + (Random.int 50 350) + (Random.int 50 350) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + button + [ style "position" "absolute" + , style "top" (String.fromInt model.x ++ "px") + , style "left" (String.fromInt model.y ++ "px") + , onClick Clicked + ] + [ text "Click me!" ] diff --git a/examples/src/HttpQuotes.elm b/examples/src/Quotes.elm similarity index 98% rename from examples/src/HttpQuotes.elm rename to examples/src/Quotes.elm index c35b7ac8b..c0a03490a 100644 --- a/examples/src/HttpQuotes.elm +++ b/examples/src/Quotes.elm @@ -1,4 +1,4 @@ -module HttpQuotes exposing (main) +module Quotes exposing (main) -- Press a button to send a GET request for random quotes. -- diff --git a/examples/src/Shapes.elm b/examples/src/Shapes.elm new file mode 100644 index 000000000..8ba7d19e6 --- /dev/null +++ b/examples/src/Shapes.elm @@ -0,0 +1,80 @@ +module Shapes exposing (main) + +-- Scalable Vector Graphics (SVG) can be a nice way to draw things in 2D. +-- Here are some common SVG shapes. +-- +-- Dependencies: +-- elm install elm/svg +-- + +import Html exposing (Html) +import Svg exposing (..) +import Svg.Attributes exposing (..) + + +main : Html msg +main = + svg + [ viewBox "0 0 400 400" + , width "400" + , height "400" + ] + [ circle + [ cx "50" + , cy "50" + , r "40" + , fill "red" + , stroke "black" + , strokeWidth "3" + ] + [] + , rect + [ x "100" + , y "10" + , width "40" + , height "40" + , fill "green" + , stroke "black" + , strokeWidth "2" + ] + [] + , line + [ x1 "20" + , y1 "200" + , x2 "200" + , y2 "20" + , stroke "blue" + , strokeWidth "10" + , strokeLinecap "round" + ] + [] + , polyline + [ points "200,40 240,40 240,80 280,80 280,120 320,120 320,160" + , fill "none" + , stroke "red" + , strokeWidth "4" + , strokeDasharray "20,2" + ] + [] + , text_ + [ x "130" + , y "130" + , fill "black" + , textAnchor "middle" + , dominantBaseline "central" + , transform "rotate(-45 130,130)" + ] + [ text "Welcome to Shapes Club" + ] + ] + + + +-- There are a lot of odd things about SVG, so always try to find examples +-- to help you understand the weird stuff. Like these: +-- +-- https://www.w3schools.com/graphics/svg_examples.asp +-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d +-- +-- If you cannot find relevant examples, make an experiment. If you push +-- through the weirdness, you can do a lot with SVG. diff --git a/examples/src/TextFields.elm b/examples/src/TextFields.elm new file mode 100644 index 000000000..ba13e9221 --- /dev/null +++ b/examples/src/TextFields.elm @@ -0,0 +1,61 @@ +module TextFields exposing (main) + +-- A text input for reversing text. Very useful! +-- +-- Read how it works: +-- https://guide.elm-lang.org/architecture/text_fields.html +-- + +import Browser +import Html exposing (Attribute, Html, div, input, text) +import Html.Attributes exposing (..) +import Html.Events exposing (onInput) + + + +-- MAIN + + +main = + Browser.sandbox { init = init, update = update, view = view } + + + +-- MODEL + + +type alias Model = + { content : String + } + + +init : Model +init = + { content = "" } + + + +-- UPDATE + + +type Msg + = Change String + + +update : Msg -> Model -> Model +update msg model = + case msg of + Change newContent -> + { model | content = newContent } + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ input [ placeholder "Text to reverse", value model.content, onInput Change ] [] + , div [] [ text (String.reverse model.content) ] + ] diff --git a/examples/src/Thwomp.elm b/examples/src/Thwomp.elm new file mode 100644 index 000000000..4258b332e --- /dev/null +++ b/examples/src/Thwomp.elm @@ -0,0 +1,296 @@ +module Thwomp exposing (main) + +-- Thwomp looks at your mouse. What is it up to? +-- +-- Dependencies: +-- elm install elm/json +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl +-- +-- Thanks to The PaperNES Guy for the texture: +-- https://the-papernes-guy.deviantart.com/art/Thwomps-Thwomps-Thwomps-186879685 + +import Browser +import Browser.Dom as Dom +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Json.Decode as D +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector2 as Vec2 exposing (Vec2, vec2) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import Result +import Task +import WebGL +import WebGL.Texture as Texture + + + +-- MAIN + + +main : Program () Model Msg +main = + Browser.element + { init = init + , view = view + , update = \msg model -> ( update msg model, Cmd.none ) + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + { width : Float + , height : Float + , x : Float + , y : Float + , side : Maybe Texture.Texture + , face : Maybe Texture.Texture + } + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( { width = 0 + , height = 0 + , x = 0 + , y = 0 + , face = Nothing + , side = Nothing + } + , Cmd.batch + [ Task.perform GotViewport Dom.getViewport + , Task.attempt GotFace (Texture.loadWith options "https://elm-lang.org/images/thwomp-face.jpg") + , Task.attempt GotSide (Texture.loadWith options "https://elm-lang.org/images/thwomp-side.jpg") + ] + ) + + +options : Texture.Options +options = + { magnify = Texture.nearest + , minify = Texture.nearest + , horizontalWrap = Texture.repeat + , verticalWrap = Texture.repeat + , flipY = True + } + + + +-- UPDATE + + +type Msg + = GotFace (Result Texture.Error Texture.Texture) + | GotSide (Result Texture.Error Texture.Texture) + | GotViewport Dom.Viewport + | Resized Int Int + | MouseMoved Float Float + + +update : Msg -> Model -> Model +update msg model = + case msg of + GotFace result -> + { model + | face = Result.toMaybe result + } + + GotSide result -> + { model + | side = Result.toMaybe result + } + + GotViewport { viewport } -> + { model + | width = viewport.width + , height = viewport.height + } + + Resized width height -> + { model + | width = toFloat width + , height = toFloat height + } + + MouseMoved x y -> + { model + | x = x + , y = y + } + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + Sub.batch + [ E.onResize Resized + , E.onMouseMove decodeMovement + ] + + +decodeMovement : D.Decoder Msg +decodeMovement = + D.map2 MouseMoved + (D.field "pageX" D.float) + (D.field "pageY" D.float) + + + +-- VIEW + + +view : Model -> Html Msg +view model = + case Maybe.map2 Tuple.pair model.face model.side of + Nothing -> + Html.text "Loading textures..." + + Just ( face, side ) -> + let + perspective = + toPerspective model.x model.y model.width model.height + in + WebGL.toHtml + [ style "display" "block" + , style "position" "absolute" + , style "left" "0" + , style "top" "0" + , width (round model.width) + , height (round model.height) + ] + [ WebGL.entity vertexShader + fragmentShader + faceMesh + { perspective = perspective + , texture = face + } + , WebGL.entity vertexShader + fragmentShader + sidesMesh + { perspective = perspective + , texture = side + } + ] + + +toPerspective : Float -> Float -> Float -> Float -> Mat4 +toPerspective x y width height = + let + eye = + Vec3.scale 6 <| + Vec3.normalize <| + vec3 (0.5 - x / width) (y / height - 0.5) 1 + in + Mat4.mul + (Mat4.makePerspective 45 (width / height) 0.01 100) + (Mat4.makeLookAt eye (vec3 0 0 0) Vec3.j) + + + +-- MESHES + + +type alias Vertex = + { position : Vec3 + , coord : Vec2 + } + + +faceMesh : WebGL.Mesh Vertex +faceMesh = + WebGL.triangles square + + +sidesMesh : WebGL.Mesh Vertex +sidesMesh = + WebGL.triangles <| + List.concatMap rotatedSquare <| + [ ( 90, 0 ) + , ( 180, 0 ) + , ( 270, 0 ) + , ( 0, 90 ) + , ( 0, 270 ) + ] + + +rotatedSquare : ( Float, Float ) -> List ( Vertex, Vertex, Vertex ) +rotatedSquare ( angleXZ, angleYZ ) = + let + transformMat = + Mat4.mul + (Mat4.makeRotate (degrees angleXZ) Vec3.j) + (Mat4.makeRotate (degrees angleYZ) Vec3.i) + + transform vertex = + { vertex | position = Mat4.transform transformMat vertex.position } + + transformTriangle ( a, b, c ) = + ( transform a, transform b, transform c ) + in + List.map transformTriangle square + + +square : List ( Vertex, Vertex, Vertex ) +square = + let + topLeft = + Vertex (vec3 -1 1 1) (vec2 0 1) + + topRight = + Vertex (vec3 1 1 1) (vec2 1 1) + + bottomLeft = + Vertex (vec3 -1 -1 1) (vec2 0 0) + + bottomRight = + Vertex (vec3 1 -1 1) (vec2 1 0) + in + [ ( topLeft, topRight, bottomLeft ) + , ( bottomLeft, topRight, bottomRight ) + ] + + + +-- SHADERS + + +type alias Uniforms = + { perspective : Mat4 + , texture : Texture.Texture + } + + +vertexShader : WebGL.Shader Vertex Uniforms { vcoord : Vec2 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec2 coord; + uniform mat4 perspective; + varying vec2 vcoord; + + void main () { + gl_Position = perspective * vec4(position, 1.0); + vcoord = coord.xy; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcoord : Vec2 } +fragmentShader = + [glsl| + precision mediump float; + uniform sampler2D texture; + varying vec2 vcoord; + + void main () { + gl_FragColor = texture2D(texture, vcoord); + } + |] diff --git a/examples/src/Triangle.elm b/examples/src/Triangle.elm new file mode 100644 index 000000000..751bf9edb --- /dev/null +++ b/examples/src/Triangle.elm @@ -0,0 +1,140 @@ +module Triangle exposing (main) + +-- elm install elm-explorations/linear-algebra +-- elm install elm-explorations/webgl + +import Browser +import Browser.Events as E +import Html exposing (Html) +import Html.Attributes exposing (height, style, width) +import Math.Matrix4 as Mat4 exposing (Mat4) +import Math.Vector3 as Vec3 exposing (Vec3, vec3) +import WebGL + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + Float + + +init : () -> ( Model, Cmd Msg ) +init () = + ( 0, Cmd.none ) + + + +-- UPDATE + + +type Msg + = TimeDelta Float + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg currentTime = + case msg of + TimeDelta delta -> + ( delta + currentTime, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions _ = + E.onAnimationFrameDelta TimeDelta + + + +-- VIEW + + +view : Model -> Html msg +view t = + WebGL.toHtml + [ width 400 + , height 400 + , style "display" "block" + ] + [ WebGL.entity vertexShader fragmentShader mesh { perspective = perspective (t / 1000) } + ] + + +perspective : Float -> Mat4 +perspective t = + Mat4.mul + (Mat4.makePerspective 45 1 0.01 100) + (Mat4.makeLookAt (vec3 (4 * cos t) 0 (4 * sin t)) (vec3 0 0 0) (vec3 0 1 0)) + + + +-- MESH + + +type alias Vertex = + { position : Vec3 + , color : Vec3 + } + + +mesh : WebGL.Mesh Vertex +mesh = + WebGL.triangles + [ ( Vertex (vec3 0 0 0) (vec3 1 0 0) + , Vertex (vec3 1 1 0) (vec3 0 1 0) + , Vertex (vec3 1 -1 0) (vec3 0 0 1) + ) + ] + + + +-- SHADERS + + +type alias Uniforms = + { perspective : Mat4 + } + + +vertexShader : WebGL.Shader Vertex Uniforms { vcolor : Vec3 } +vertexShader = + [glsl| + attribute vec3 position; + attribute vec3 color; + uniform mat4 perspective; + varying vec3 vcolor; + + void main () { + gl_Position = perspective * vec4(position, 1.0); + vcolor = color; + } + |] + + +fragmentShader : WebGL.Shader {} Uniforms { vcolor : Vec3 } +fragmentShader = + [glsl| + precision mediump float; + varying vec3 vcolor; + + void main () { + gl_FragColor = vec4(vcolor, 1.0); + } + |] diff --git a/examples/src/Turtle.elm b/examples/src/Turtle.elm new file mode 100644 index 000000000..f10e4aab9 --- /dev/null +++ b/examples/src/Turtle.elm @@ -0,0 +1,35 @@ +module Turtle exposing (main) + +-- Use arrow keys to move the turtle around. +-- +-- Forward with UP and turn with LEFT and RIGHT. +-- +-- Learn more about the playground here: +-- https://package.elm-lang.org/packages/evancz/elm-playground/latest/ +-- + +import Playground exposing (..) + + +main = + game view + update + { x = 0 + , y = 0 + , angle = 0 + } + + +view computer turtle = + [ rectangle blue computer.screen.width computer.screen.height + , image 96 96 "https://elm-lang.org/images/turtle.gif" + |> move turtle.x turtle.y + |> rotate turtle.angle + ] + + +update computer turtle = + { x = turtle.x + toY computer.keyboard * cos (degrees turtle.angle) + , y = turtle.y + toY computer.keyboard * sin (degrees turtle.angle) + , angle = turtle.angle - toX computer.keyboard + } diff --git a/examples/src/Upload.elm b/examples/src/Upload.elm new file mode 100644 index 000000000..13f3925e4 --- /dev/null +++ b/examples/src/Upload.elm @@ -0,0 +1,87 @@ +module Upload exposing (main) + +-- File upload with the node. +-- +-- Dependencies: +-- elm install elm/file +-- elm install elm/json +-- + +import Browser +import File exposing (File) +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Json.Decode as D + + + +-- MAIN + + +main = + Browser.element + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + + + +-- MODEL + + +type alias Model = + List File + + +init : () -> ( Model, Cmd Msg ) +init _ = + ( [], Cmd.none ) + + + +-- UPDATE + + +type Msg + = GotFiles (List File) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + GotFiles files -> + ( files, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Sub.none + + + +-- VIEW + + +view : Model -> Html Msg +view model = + div [] + [ input + [ type_ "file" + , multiple True + , on "change" (D.map GotFiles filesDecoder) + ] + [] + , div [] [ text (Debug.toString model) ] + ] + + +filesDecoder : D.Decoder (List File) +filesDecoder = + D.at [ "target", "files" ] (D.list File.decoder) diff --git a/review/src/ReviewConfig.elm b/review/src/ReviewConfig.elm index 32d948b10..712bb7df1 100644 --- a/review/src/ReviewConfig.elm +++ b/review/src/ReviewConfig.elm @@ -36,12 +36,14 @@ import Simplify config : List Rule config = [ --Docs.ReviewAtDocs.rule - NoConfusingPrefixOperator.rule + NoConfusingPrefixOperator.rule , NoDebug.Log.rule + --, NoDebug.TodoOrToString.rule -- |> Rule.ignoreErrorsForDirectories [ "tests/" ] , NoExposingEverything.rule , NoImportingEverything.rule [] + --, NoMissingTypeAnnotation.rule --, NoMissingTypeAnnotationInLetIn.rule --, NoMissingTypeExpose.rule diff --git a/src/Language/GLSL/Parser.elm b/src/Language/GLSL/Parser.elm new file mode 100644 index 000000000..8fa31dc0c --- /dev/null +++ b/src/Language/GLSL/Parser.elm @@ -0,0 +1,1226 @@ +module Language.GLSL.Parser exposing (..) + +-- import Text.ParserCombinators.Parsec +-- import Text.ParserCombinators.Parsec.Expr + +import Language.GLSL.Syntax exposing (..) + + + +---------------------------------------------------------------------- +-- Parser state, hold a symbol table. +---------------------------------------------------------------------- + + +type S + = S + + +type P a + = GenParser Char S a + + + +---------------------------------------------------------------------- +-- Reserved words +---------------------------------------------------------------------- +-- List of keywords. + + +keywords : List String +keywords = + List.concat <| + List.map String.words <| + [ "attribute const uniform varying" + , "layout" + , "centroid flat smooth noperspective" + , "break continue do for while switch case default" + , "if else" + , "in out inout" + , "float int void bool true false" + , "invariant" + , "discard return" + , "mat2 mat3 mat4" + , "mat2x2 mat2x3 mat2x4" + , "mat3x2 mat3x3 mat3x4" + , "mat4x2 mat4x3 mat4x4" + , "vec2 vec3 vec4 ivec2 ivec3 ivec4 bvec2 bvec3 bvec4" + , "uint uvec2 uvec3 uvec4" + , "lowp mediump highp precision" + , "sampler1D sampler2D sampler3D samplerCube" + , "sampler1DShadow sampler2DShadow samplerCubeShadow" + , "sampler1DArray sampler2DArray" + , "sampler1DArrayShadow sampler2DArrayShadow" + , "isampler1D isampler2D isampler3D isamplerCube" + , "isampler1DArray isampler2DArray" + , "usampler1D usampler2D usampler3D usamplerCube" + , "usampler1DArray usampler2DArray" + , "sampler2DRect sampler2DRectShadow isampler2DRect usampler2DRect" + , "samplerBuffer isamplerBuffer usamplerBuffer" + , "sampler2DMS isampler2DMS usampler2DMS" + , "sampler2DMSArray isampler2DMSArray usampler2DMSArray" + , "struct" + ] + + + +-- List of keywords reserved for future use. + + +reservedWords : List String +reservedWords = + List.concat <| + List.map String.words <| + [ "common partition active" + , "asm" + , "class union enum typedef template this packed" + , "goto" + , "inline noinline volatile public static extern external interface" + , "long short double half fixed unsigned superp" + , "input output" + , "hvec2 hvec3 hvec4 dvec2 dvec3 dvec4 fvec2 fvec3 fvec4" + , "sampler3DRect" + , "filter" + , "image1D image2D image3D imageCube" + , "iimage1D iimage2D iimage3D iimageCube" + , "uimage1D uimage2D uimage3D uimageCube" + , "image1DArray image2DArray" + , "iimage1DArray iimage2DArray uimage1DArray uimage2DArray" + , "image1DShadow image2DShadow" + , "image1DArrayShadow image2DArrayShadow" + , "imageBuffer iimageBuffer uimageBuffer" + , "sizeof cast" + , "namespace using" + , "row_major" + ] + + + +---------------------------------------------------------------------- +-- Convenience parsers +---------------------------------------------------------------------- + + +comment : P () +comment = + -- do + -- _ <- char '/' + -- _ <- choice + -- [ do _ <- char '*' + -- manyTill anyChar (try $ string "*/") + -- , do _ <- char '/' + -- manyTill anyChar ((newline >> return ()) <|> eof) + -- ] + -- return () + Debug.todo "comment" + + +blank : P () +blank = + -- try comment <|> (space >> return ()) + Debug.todo "blank" + + + +-- Acts like p and discards any following space character. + + +lexeme : P a -> P a +lexeme p = + -- do + -- x <- p + -- skipMany blank + -- return x + Debug.todo "lexeme" + + +parse : String -> Result ParseError TranslationUnit +parse = + -- runParser (do {skipMany blank ; r <- translationUnit ; eof ; return r}) + -- S "GLSL" + Debug.todo "parse" + + + +---------------------------------------------------------------------- +-- Lexical elements (tokens) +---------------------------------------------------------------------- + + +semicolon : P () +semicolon = + -- lexeme $ char ';' >> return () + Debug.todo "semicolon" + + +comma : P () +comma = + -- lexeme $ char ',' >> return () + Debug.todo "comma" + + +colon : P () +colon = + -- lexeme $ char ':' >> return () + Debug.todo "colon" + + +lbrace : P () +lbrace = + -- lexeme $ char '{' >> return () + Debug.todo "lbrace" + + +rbrace : P () +rbrace = + -- lexeme $ char '}' >> return () + Debug.todo "rbrace" + + +lbracket : P () +lbracket = + -- lexeme $ char '[' >> return () + Debug.todo "lbracket" + + +rbracket : P () +rbracket = + -- lexeme $ char ']' >> return () + Debug.todo "rbracket" + + +lparen : P () +lparen = + -- lexeme $ char '(' >> return () + Debug.todo "lparen" + + +rparen : P () +rparen = + -- lexeme $ char ')' >> return () + Debug.todo "rparen" + + + +-- Try to parse a given string, making sure it is not a +-- prefix of an identifier. + + +keyword : String -> P () +keyword w = + -- lexeme $ try (string w >> notFollowedBy identifierTail) + Debug.todo "keyword" + + + +-- Parses and returns an identifier. +-- TODO an identifier can't start with "gl_" unless +-- it is to redeclare a predeclared "gl_" identifier. + + +identifier : P String +identifier = + -- lexeme $ do + -- h <- identifierHead + -- t <- many identifierTail + -- check (h:t) + -- where check i | i `elem` reservedWords = fail $ + -- i ++ " is reserved" + -- | i `elem` keywords = fail $ + -- i ++ " is a keyword" + -- | otherwise = checkUnderscore i i + -- checkUnderscore i ('_':'_':_) = fail $ + -- i ++ " is reserved (two consecutive underscores)" + -- checkUnderscore i (_:cs) = checkUnderscore i cs + -- checkUnderscore i [] = return i + Debug.todo "identifier" + + + +-- TODO the size of the int should fit its type. + + +intConstant : P Expr +intConstant = + choice + [ hexadecimal + , octal + , badOctal >> fail "Invalid octal number" + , decimal + ] + + +floatingConstant : P Expr +floatingConstant = + choice + [ floatExponent + , floatPoint + , pointFloat + ] + + + +-- Try to parse a given string, and allow identifier characters +-- (or anything else) to directly follow. + + +operator : String -> P String +operator = + -- lexeme . try . string + Debug.todo "operator" + + + +---------------------------------------------------------------------- +-- Lexical elements helpers +---------------------------------------------------------------------- + + +identifierHead : P Char +identifierHead = + -- letter <|> char '_' + Debug.todo "identifierHead" + + +identifierTail : P Char +identifierTail = + -- alphaNum <|> char '_' + Debug.todo "identifierTail" + + +hexadecimal : P Expr +hexadecimal = + -- lexeme $ try $ do + -- _ <- char '0' + -- _ <- oneOf "Xx" + -- d <- many1 hexDigit + -- m <- optionMaybe $ oneOf "Uu" -- TODO + -- return $ IntConstant Hexadecimal $ read ("0x" ++ d) + Debug.todo "hexadecimal" + + +octal : P Expr +octal = + -- lexeme $ try $ do + -- _ <- char '0' + -- d <- many1 octDigit + -- m <- optionMaybe $ oneOf "Uu" -- TODO + -- return $ IntConstant Octal $ read ("0o" ++ d) + Debug.todo "octal" + + +badOctal : P () +badOctal = + -- lexeme $ try $ char '0' >> many1 hexDigit >> return () + Debug.todo "badOctal" + + +decimal : P Expr +decimal = + -- lexeme $ try $ do + -- d <- many1 digit + -- notFollowedBy (char '.' <|> (exponent >> return ' ')) + -- m <- optionMaybe $ oneOf "Uu" -- TODO + -- return $ IntConstant Decimal $ read d + Debug.todo "decimal" + + +floatExponent : P Expr +floatExponent = + -- lexeme $ try $ do + -- d <- many1 digit + -- e <- exponent + -- m <- optionMaybe $ oneOf "Ff" -- TODO + -- return $ FloatConstant $ read $ d ++ e + Debug.todo "floatExponent" + + +floatPoint : P Expr +floatPoint = + -- lexeme $ try $ do + -- d <- many1 digit + -- _ <- char '.' + -- d' <- many digit + -- let d'' = if null d' then "0" else d' + -- e <- optionMaybe exponent + -- m <- optionMaybe $ oneOf "Ff" -- TODO + -- return $ FloatConstant $ read $ d ++ "." ++ d'' ++ maybe "" id e + Debug.todo "floatPoint" + + +pointFloat : P Expr +pointFloat = + -- lexeme $ try $ do + -- _ <- char '.' + -- d <- many1 digit + -- e <- optionMaybe exponent + -- m <- optionMaybe $ oneOf "Ff" + -- return $ FloatConstant $ read $ "0." ++ d ++ maybe "" id e + Debug.todo "pointFloat" + + +exponent : P String +exponent = + -- lexeme $ try $ do + -- _ <- oneOf "Ee" + -- s <- optionMaybe (oneOf "+-") + -- d <- many1 digit + -- return $ "e" ++ maybe "" (:[]) s ++ d + Debug.todo "exponent" + + + +---------------------------------------------------------------------- +-- Tables for buildExpressionParser +---------------------------------------------------------------------- + + +infixLeft : String -> (a -> a -> a) -> Operator Char S a +infixLeft s r = + -- Infix (lexeme (try $ string s) >> return r) AssocLeft + Debug.todo "infixLeft" + + +infixLeft_ : String -> (a -> a -> a) -> Operator Char S a +infixLeft_ s r = + -- Infix (lexeme (try $ string s >> notFollowedBy (char '=')) >> return r) AssocLeft + Debug.todo "infixLeft_" + + +infixLeft__ : Char -> (a -> a -> a) -> Operator Char S a +infixLeft__ c r = + -- Infix (lexeme (try $ char c >> notFollowedBy (oneOf (c:"="))) >> return r) AssocLeft + Debug.todo "infixLeft__" + + +infixRight : String -> (a -> a -> a) -> Operator Char S a +infixRight s r = + -- Infix (lexeme (try $ string s) >> return r) AssocRight + Debug.todo "infixRight" + + +conditionalTable : List (List (Operator Char S Expr)) +conditionalTable = + [ [ infixLeft_ "*" Mul, infixLeft_ "/" Div, infixLeft_ "%" Mod ] + , [ infixLeft_ "+" Add, infixLeft_ "-" Sub ] + , [ infixLeft_ "<<" LeftShift, infixLeft_ ">>" RightShift ] + , [ infixLeft_ "<" Lt + , infixLeft_ ">" Gt + , infixLeft "<=" Lte + , infixLeft ">=" Gte + ] + , [ infixLeft "==" Equ, infixLeft "!=" Neq ] + , [ infixLeft__ '&' BitAnd ] + , [ infixLeft_ "^" BitXor ] + , [ infixLeft__ '|' BitOr ] + , [ infixLeft "&&" And ] + , [ infixLeft "||" Or ] + ] + + +assignmentTable : List (List (Operator Char S Expr)) +assignmentTable = + [ [ infixRight "=" Equal ] + , [ infixRight "+=" AddAssign ] + , [ infixRight "-=" SubAssign ] + , [ infixRight "*=" MulAssign ] + , [ infixRight "/=" DivAssign ] + , [ infixRight "%=" ModAssign ] + , [ infixRight "<<=" LeftAssign ] + , [ infixRight ">>=" RightAssign ] + , [ infixRight "&=" AndAssign ] + , [ infixRight "^=" XorAssign ] + , [ infixRight "|=" OrAssign ] + ] + + +expressionTable : List (List (Operator Char S Expr)) +expressionTable = + [ [ infixLeft "," Sequence ] + ] + + + +---------------------------------------------------------------------- +-- Grammar +---------------------------------------------------------------------- + + +primaryExpression : P Expr +primaryExpression = + choice + [ fmap Variable (try identifier) + + -- int constant + , intConstant + + -- uint constant + -- float constant + , floatingConstant + + -- bool constant + , keyword "true" >> return (BoolConstant True) + , keyword "false" >> return (BoolConstant False) + + -- expression within parentheses + , between lparen rparen expression + ] + + +postfixExpression : P Expr +postfixExpression = + -- do + -- e <- try (functionCallGeneric >>= \(i,p) -> return (FunctionCall i p)) + -- <|> primaryExpression + -- p <- many <| choice + -- [ between lbracket rbracket integerExpression >>= return . flip Bracket + -- , dotFunctionCallGeneric + -- , dotFieldSelection + -- , operator "++" >> return PostInc + -- , operator "--" >> return PostDec + -- ] + -- return $ foldl (flip ($)) e p + Debug.todo "postfixExpression" + + +dotFunctionCallGeneric : P (Expr -> Expr) +dotFunctionCallGeneric = + -- lexeme (try $ string "." >> functionCallGeneric) >>= \(i,p) -> return (\e -> MethodCall e i p) + Debug.todo "dotFunctionCallGeneric" + + +dotFieldSelection : P (Expr -> Expr) +dotFieldSelection = + -- lexeme (try $ string "." >> identifier) >>= return . flip FieldSelection + Debug.todo "dotFieldSelection" + + +integerExpression : P Expr +integerExpression = + expression + + + +-- Those productions are pushed inside postfixExpression. +-- functionCall = functionCallOrMethod +-- functionCallOrMethod = functionCallGeneric <|> postfixExpression DOT functionCallGeneric + + +functionCallGeneric : P ( FunctionIdentifier, Parameters ) +functionCallGeneric = + -- do + -- i <- functionCallHeader + -- p <- choice + -- [ keyword "void" >> return ParamVoid + -- , sepBy assignmentExpression comma >>= return . Params + -- ] + -- rparen + -- return (i, p) + Debug.todo "functionCallGeneric" + + + +-- Those productions are pushed inside functionCallGeneric. +-- functionCallHeaderNoParameters = undefined +-- functionCallHeaderWithParameters = undefined + + +functionCallHeader : P FunctionIdentifier +functionCallHeader = + -- do + -- i <- functionIdentifier + -- lparen + -- return i + Debug.todo "functionCallHeader" + + +functionIdentifier : P FunctionIdentifier +functionIdentifier = + -- choice + -- [ try identifier >>= return . FuncId + -- , typeSpecifier >>= return . FuncIdTypeSpec -- TODO if the 'identifier' is declared as a type, should be this case + -- -- no need for fieldSelection + -- ] + Debug.todo "functionIdentifier" + + +unaryExpression : P Expr +unaryExpression = + -- do + -- p <- many $ choice + -- [ operator "++" >> return PreInc + -- , operator "--" >> return PreDec + -- , operator "+" >> return UnaryPlus + -- , operator "-" >> return UnaryNegate + -- , operator "!" >> return UnaryNot + -- , operator "~" >> return UnaryOneComplement + -- ] + -- e <- postfixExpression + -- return $ foldr ($) e p + Debug.todo "unaryExpression" + + + +-- inside unaryExpression +-- unaryOperator = choice +-- implemented throught buildExpressionParser +-- multiplicativeExpression = undefined +-- additiveExpression = undefined +-- shiftExpression = undefined +-- relationalExpression = undefined +-- equalityExpression = undefined +-- andExpression = undefined +-- exclusiveOrExpression = undefined +-- inclusiveOrExpression = undefined +-- logicalAndExpression = undefined +-- logicalXorExpression = undefined +-- logicalOrExpression = undefined + + +conditionalExpression : P Expr +conditionalExpression = + -- do + -- loe <- buildExpressionParser conditionalTable unaryExpression + -- ter <- optionMaybe $ do + -- _ <- lexeme (string "?") + -- e <- expression + -- _ <- lexeme (string ":") + -- a <- assignmentExpression + -- return (e, a) + -- case ter of + -- Nothing -> return loe + -- Just (e, a) -> return $ Selection loe e a + Debug.todo "conditionalExpression" + + +assignmentExpression : P Expr +assignmentExpression = + buildExpressionParser assignmentTable conditionalExpression + + +expression : P Expr +expression = + buildExpressionParser expressionTable assignmentExpression + + +constantExpression : P Expr +constantExpression = + conditionalExpression + + + +-- The GLSL grammar include here function definition but we don't +-- do this here because they should occur only at top level (page 28). +-- Function definitions are handled in externalDefinition instead. + + +declaration : P Declaration +declaration = + choice + -- [ try $ do + -- t <- fullySpecifiedType + -- l <- idecl `sepBy` comma + -- semicolon + -- return $ InitDeclaration (TypeDeclarator t) l + -- , do keyword "invariant" + -- i <- idecl `sepBy` comma + -- semicolon + -- return $ InitDeclaration InvariantDeclarator i + -- , do keyword "precision" + -- q <- precisionQualifier + -- s <- typeSpecifierNoPrecision + -- semicolon + -- return $ Precision q s + -- , do q <- typeQualifier + -- choice + -- [ semicolon >> return (TQ q) + -- , do i <- identifier + -- lbrace + -- s <- structDeclarationList + -- rbrace + -- m <- optionMaybe $ do + -- j <- identifier + -- n <- optionMaybe $ between lbracket rbracket $ optionMaybe constantExpression + -- return (j,n) + -- semicolon + -- return $ Block q i s m + -- ] + -- ] + -- where idecl = do + -- i <- identifier + -- m <- optionMaybe $ between lbracket rbracket $ + -- optionMaybe constantExpression + -- j <- optionMaybe $ lexeme (string "=") >> initializer + -- return $ InitDecl i m j + Debug.todo + "declaration" + + +functionPrototype : P FunctionPrototype +functionPrototype = + -- do + -- (t, i, p) <- functionDeclarator + -- rparen + -- return $ FuncProt t i p + Debug.todo "functionPrototype" + + +functionDeclarator : P ( FullType, String, List ParameterDeclaration ) +functionDeclarator = + -- do + -- (t, i) <- functionHeader + -- p <- parameterDeclaration `sepBy` comma + -- return (t, i, p) + Debug.todo "functionDeclarator" + + + +-- inside functionDeclarator +-- functionHeaderWithParameters = undefined + + +functionHeader : P ( FullType, String ) +functionHeader = + -- do + -- t <- fullySpecifiedType + -- i <- identifier + -- lparen + -- return (t, i) + Debug.todo "functionHeader" + + + +-- inside parameterDeclaration +-- parameterDeclarator = undefined +-- expanding parameterDeclarator and parameterTypeSpecifier, the rule is: +-- parameterDeclaration: +-- parameterTypeQualifier [parameterQualifier] typeSpecifier identifier[[e]] +-- [parameterQualifier] typeSpecifier identifier[[e]] +-- parameterTypeQualifier [parameterQualifier] typeSpecifier +-- [parameterQualifier] typeSpecifier +-- which is simply +-- [parameterTypeQualifier] [parameterQualifier] typeSpecifier [identifier[[e]]] + + +parameterDeclaration : P ParameterDeclaration +parameterDeclaration = + -- do + -- tq <- optionMaybe parameterTypeQualifier + -- q <- optionMaybe parameterQualifier + -- s <- typeSpecifier + -- m <- optionMaybe $ do + -- i <- identifier + -- b <- optionMaybe $ between lbracket rbracket constantExpression -- FIXME can't the bracket be empty, i.e. a[] ? + -- return (i,b) + -- return $ ParameterDeclaration tq q s m + Debug.todo "parameterDeclaration" + + +parameterQualifier : P ParameterQualifier +parameterQualifier = + -- choice + -- -- "empty" case handled in the caller + -- [ (try . lexeme . string) "inout" >> return InOutParameter + -- , (try . lexeme . string) "in" >> return InParameter + -- , (try . lexeme . string) "out" >> return OutParameter + -- ] + Debug.todo "parameterQualifier" + + + +-- inside parameterDeclaration +-- parameterTypeSpecifier = typeSpecifier +-- FIXME not correct w.r.t. the specs. +-- The specs allow +-- int +-- int, foo +-- invariant foo, bar[] +-- and disallow +-- invariant bar[] +-- It is not used, it is inside declaration. +-- initDeclaratorList = undefined +-- inside initDeclaratorList +-- singleDeclaration = undefined + + +fullySpecifiedType : P FullType +fullySpecifiedType = + -- choice + -- [ try typeSpecifier >>= return . FullType Nothing + -- , do q <- typeQualifier + -- s <- typeSpecifier + -- return $ FullType (Just q) s + -- ] + Debug.todo "fullySpecifiedType" + + +invariantQualifier : P InvariantQualifier +invariantQualifier = + -- keyword "invariant" >> return Invariant + Debug.todo "invariantQualifier" + + +interpolationQualifier : P InterpolationQualifier +interpolationQualifier = + -- choice + -- [ keyword "smooth" >> return Smooth + -- , keyword "flat" >> return Flat + -- , keyword "noperspective" >> return NoPerspective + -- ] + Debug.todo "interpolationQualifier" + + +layoutQualifier : P LayoutQualifier +layoutQualifier = + -- do + -- keyword "layout" + -- lparen + -- q <- layoutQualifierId `sepBy` comma + -- rparen + -- return $ Layout q + Debug.todo "layoutQualifier" + + + +-- implemented directly in layoutQualifier +-- layoutQualifierIdList = undefined + + +layoutQualifierId : P LayoutQualifierId +layoutQualifierId = + -- do + -- i <- identifier + -- c <- optionMaybe $ lexeme (string "=") >> intConstant + -- return $ LayoutQualId i c + Debug.todo "layoutQualifierId" + + +parameterTypeQualifier : P ParameterTypeQualifier +parameterTypeQualifier = + -- keyword "const" >> return ConstParameter + Debug.todo "parameterTypeQualifier" + + + +-- sto +-- lay [sto] +-- int [sto] +-- inv [sto] +-- inv int sto + + +typeQualifier : P TypeQualifier +typeQualifier = + -- choice + -- [ do s <- storageQualifier + -- return $ TypeQualSto s + -- , do l <- layoutQualifier + -- s <- optionMaybe storageQualifier + -- return $ TypeQualLay l s + -- , do i <- interpolationQualifier + -- s <- optionMaybe storageQualifier + -- return $ TypeQualInt i s + -- , do i <- invariantQualifier + -- choice + -- [ do j <- interpolationQualifier + -- s <- storageQualifier + -- return $ TypeQualInv3 i j s + -- , do s <- optionMaybe storageQualifier + -- return $ TypeQualInv i s + -- ] + -- ] + Debug.todo "typeQualifier" + + + +-- TODO see 4.3 for restrictions + + +storageQualifier : P StorageQualifier +storageQualifier = + -- choice + -- [ keyword "const" >> return Const + -- , keyword "attribute" >> return Attribute -- TODO vertex only, is deprecated + -- , keyword "varying" >> return Varying -- deprecated + -- , keyword "in" >> return In + -- , keyword "out" >> return Out + -- , keyword "centroid" >> (choice + -- [ keyword "varying" >> return CentroidVarying -- deprecated + -- , keyword "in" >> return CentroidIn + -- , keyword "out" >> return CentroidOut + -- ]) + -- , keyword "uniform" >> return Uniform + -- ] + Debug.todo "storageQualifier" + + +typeSpecifier : P TypeSpecifier +typeSpecifier = + -- choice + -- [ do q <- try precisionQualifier + -- s <- typeSpecifierNoPrecision + -- return $ TypeSpec (Just q) s + -- , typeSpecifierNoPrecision >>= return . TypeSpec Nothing + -- ] + Debug.todo "typeSpecifier" + + +typeSpecifierNoPrecision : P TypeSpecifierNoPrecision +typeSpecifierNoPrecision = + -- do + -- s <- typeSpecifierNonArray + -- choice + -- [ try (lbracket >> rbracket) >> return (TypeSpecNoPrecision s (Just Nothing)) + -- , lbracket >> constantExpression >>= \c -> rbracket >> return (TypeSpecNoPrecision s (Just $ Just c)) + -- , return $ TypeSpecNoPrecision s Nothing + -- ] + Debug.todo "typeSpecifierNoPrecision" + + + +-- Basic types, structs, and user-defined types. + + +typeSpecifierNonArray : P TypeSpecifierNonArray +typeSpecifierNonArray = + -- choice + -- [ keyword "void" >> return Void + -- , keyword "float" >> return Float + -- , keyword "int" >> return Int + -- , keyword "uint" >> return UInt + -- , keyword "bool" >> return Bool + -- , keyword "vec2" >> return Vec2 + -- , keyword "vec3" >> return Vec3 + -- , keyword "vec4" >> return Vec4 + -- , keyword "bvec2" >> return BVec2 + -- , keyword "bvec3" >> return BVec3 + -- , keyword "bvec4" >> return BVec4 + -- , keyword "ivec2" >> return IVec2 + -- , keyword "ivec3" >> return IVec3 + -- , keyword "ivec4" >> return IVec4 + -- , keyword "uvec2" >> return UVec2 + -- , keyword "uvec3" >> return UVec3 + -- , keyword "uvec4" >> return UVec4 + -- , keyword "mat2" >> return Mat2 + -- , keyword "mat3" >> return Mat3 + -- , keyword "mat4" >> return Mat4 + -- , keyword "mat2x2" >> return Mat2x2 + -- , keyword "mat2x3" >> return Mat2x3 + -- , keyword "mat2x4" >> return Mat2x4 + -- , keyword "mat3x2" >> return Mat3x2 + -- , keyword "mat3x3" >> return Mat3x3 + -- , keyword "mat3x4" >> return Mat3x4 + -- , keyword "mat4x2" >> return Mat4x2 + -- , keyword "mat4x3" >> return Mat4x3 + -- , keyword "mat4x4" >> return Mat4x4 + -- , keyword "sampler1D" >> return Sampler1D + -- , keyword "sampler2D" >> return Sampler2D + -- , keyword "sampler3D" >> return Sampler3D + -- , keyword "samplerCube" >> return SamplerCube + -- , keyword "sampler1DShadow" >> return Sampler1DShadow + -- , keyword "sampler2DShadow" >> return Sampler2DShadow + -- , keyword "samplerCubeShadow" >> return SamplerCubeShadow + -- , keyword "sampler1DArray" >> return Sampler1DArray + -- , keyword "sampler2DArray" >> return Sampler2DArray + -- , keyword "sampler1DArrayShadow" >> return Sampler1DArrayShadow + -- , keyword "sampler2DArrayShadow" >> return Sampler2DArrayShadow + -- , keyword "isampler1D" >> return ISampler1D + -- , keyword "isampler2D" >> return ISampler2D + -- , keyword "isampler3D" >> return ISampler3D + -- , keyword "isamplerCube" >> return ISamplerCube + -- , keyword "isampler1DArray" >> return ISampler1DArray + -- , keyword "isampler2DArray" >> return ISampler2DArray + -- , keyword "usampler1D" >> return USampler1D + -- , keyword "usampler2D" >> return USampler2D + -- , keyword "usampler3D" >> return USampler3D + -- , keyword "usamplerCube" >> return USamplerCube + -- , keyword "usampler1DArray" >> return USampler1DArray + -- , keyword "usampler2DArray" >> return USampler2DArray + -- , keyword "sampler2DRect" >> return Sampler2DRect + -- , keyword "sampler2DRectShadow" >> return Sampler2DRectShadow + -- , keyword "isampler2DRect" >> return ISampler2DRect + -- , keyword "usampler2DRect" >> return USampler2DRect + -- , keyword "samplerBuffer" >> return SamplerBuffer + -- , keyword "isamplerBuffer" >> return ISamplerBuffer + -- , keyword "usamplerBuffer" >> return USamplerBuffer + -- , keyword "sampler2DMS" >> return Sampler2DMS + -- , keyword "isampler2DMS" >> return ISampler2DMS + -- , keyword "usampler2DMS" >> return USampler2DMS + -- , keyword "sampler2DMSArray" >> return Sampler2DMSArray + -- , keyword "isampler2DMSArray" >> return ISampler2DMSArray + -- , keyword "usampler2DMSArray" >> return USampler2DMSArray + -- , structSpecifier + -- , identifier >>= return . TypeName -- verify if it is declared + -- ] + Debug.todo "typeSpecifierNonArray" + + +precisionQualifier : P PrecisionQualifier +precisionQualifier = + -- choice + -- [ keyword "highp" >> return HighP + -- , keyword "mediump" >> return MediumP + -- , keyword "lowp" >> return LowP + -- ] + Debug.todo "precisionQualifier" + + +structSpecifier : P TypeSpecifierNonArray +structSpecifier = + -- do + -- keyword "struct" + -- i <- optionMaybe identifier + -- lbrace + -- d <- structDeclarationList + -- rbrace + -- return $ StructSpecifier i d + Debug.todo "structSpecifier" + + +structDeclarationList : P (List Field) +structDeclarationList = + -- many1 structDeclaration + Debug.todo "structDeclarationList" + + +structDeclaration : P Field +structDeclaration = + -- do + -- q <- optionMaybe typeQualifier + -- s <- typeSpecifier + -- l <- structDeclaratorList + -- semicolon + -- return $ Field q s l + Debug.todo "structDeclaration" + + +structDeclaratorList : P (List StructDeclarator) +structDeclaratorList = + -- sepBy structDeclarator comma + Debug.todo "structDeclaratorList" + + +structDeclarator : P StructDeclarator +structDeclarator = + -- do + -- i <- identifier + -- choice + -- [ do lbracket + -- e <- optionMaybe constantExpression + -- rbracket + -- return $ StructDeclarator i (Just e) + -- , return $ StructDeclarator i Nothing + -- ] + Debug.todo "structDeclarator" + + +initializer : P Expr +initializer = + assignmentExpression + + +declarationStatement : P Declaration +declarationStatement = + declaration + + +statement : P Statement +statement = + -- CompoundStatement `fmap` compoundStatement + -- <|> simpleStatement + Debug.todo "statement" + + +simpleStatement : P Statement +simpleStatement = + -- choice + -- [ declarationStatement >>= return . DeclarationStatement + -- , expressionStatement >>= return . ExpressionStatement + -- , selectionStatement + -- , switchStatement + -- , caseLabel >>= return . CaseLabel + -- , iterationStatement + -- , jumpStatement + -- ] + Debug.todo "simpleStatement" + + +compoundStatement : P Compound +compoundStatement = + -- choice + -- [ try (lbrace >> rbrace) >> return (Compound []) + -- , between lbrace rbrace statementList >>= return . Compound + -- ] + Debug.todo "compoundStatement" + + +statementNoNewScope : P Statement +statementNoNewScope = + -- CompoundStatement `fmap` compoundStatementNoNewScope + -- <|> simpleStatement + Debug.todo "statementNoNewScope" + + +compoundStatementNoNewScope : P Compound +compoundStatementNoNewScope = + compoundStatement + + +statementList : P (List Statement) +statementList = + many1 statement + + +expressionStatement : P (Maybe Expr) +expressionStatement = + -- choice + -- [ semicolon >> return Nothing + -- , expression >>= \e -> semicolon >> return (Just e) + -- ] + Debug.todo "expressionStatement" + + +selectionStatement : P Statement +selectionStatement = + -- do + -- keyword "if" + -- lparen + -- c <- expression + -- rparen + -- t <- statement + -- f <- optionMaybe (keyword "else" >> statement) + -- return $ SelectionStatement c t f + Debug.todo "selectionStatement" + + + +-- inside selectionStatement +-- selectionRestStatement = undefined + + +condition : P Condition +condition = + -- choice + -- [ expression >>= return . Condition + -- , do t <- fullySpecifiedType + -- i <- identifier + -- _ <- lexeme (string "=") + -- j <- initializer + -- return $ InitializedCondition t i j + -- ] + Debug.todo "condition" + + +switchStatement : P Statement +switchStatement = + -- do + -- keyword "switch" + -- lparen + -- e <- expression + -- rparen + -- lbrace + -- l <- switchStatementList + -- rbrace + -- return $ SwitchStatement e l + Debug.todo "switchStatement" + + +switchStatementList : P (List Statement) +switchStatementList = + many statement + + +caseLabel : P CaseLabel +caseLabel = + -- choice + -- [ keyword "case" >> expression >>= \e -> colon >> return (Case e) + -- , keyword "default" >> colon >> return Default + -- ] + Debug.todo "caseLabel" + + +iterationStatement : P Statement +iterationStatement = + -- choice + -- [ do keyword "while" + -- lparen + -- c <- condition + -- rparen + -- s <- statementNoNewScope + -- return $ While c s + -- , do keyword "do" + -- s <- statement + -- keyword "while" + -- lparen + -- e <- expression + -- rparen + -- semicolon + -- return $ DoWhile s e + -- , do keyword "for" + -- lparen + -- i <- forInitStatement + -- c <- optionMaybe condition + -- semicolon + -- e <- optionMaybe expression + -- rparen + -- s <- statementNoNewScope + -- return $ For i c e s + -- ] + Debug.todo "iterationStatement" + + +forInitStatement : P (Result (Maybe Expr) Declaration) +forInitStatement = + -- (expressionStatement >>= return . Left) + -- <|> (declarationStatement >>= return . Right) + Debug.todo "forInitStatement" + + + +-- inside iterationStatement +-- conditionOp = undefined +-- inside iterationStatement +-- forRestStatement = undefined + + +jumpStatement : P Statement +jumpStatement = + -- choice + -- [ keyword "continue" >> semicolon >> return Continue + -- , keyword "break" >> semicolon >> return Break + -- , try (keyword "return" >> semicolon) >> return (Return Nothing) + -- , keyword "return" >> expression >>= \e -> semicolon >> return (Return $ Just e) + -- , keyword "discard" >> semicolon >> return Discard + -- ] + Debug.todo "jumpStatement" + + +translationUnit : P TranslationUnit +translationUnit = + fmap TranslationUnit (many1 externalDeclaration) + + +externalDeclaration : P ExternalDeclaration +externalDeclaration = + -- choice + -- [ do p <- try functionPrototype + -- choice + -- [ semicolon >> return (FunctionDeclaration p) + -- , compoundStatementNoNewScope >>= return . FunctionDefinition p + -- ] + -- , fmap Declaration declaration + -- ] + Debug.todo "externalDeclaration" + + + +-- inside externalDeclaration, used only in tests + + +functionDefinition : P ExternalDeclaration +functionDefinition = + -- do + -- fp <- functionPrototype + -- cs <- compoundStatementNoNewScope + -- return $ FunctionDefinition fp cs + Debug.todo "functionDefinition" diff --git a/src/Language/GLSL/Syntax.elm b/src/Language/GLSL/Syntax.elm new file mode 100644 index 000000000..061d6e39a --- /dev/null +++ b/src/Language/GLSL/Syntax.elm @@ -0,0 +1,358 @@ +module Language.GLSL.Syntax exposing (..) + +-- TODO: +-- - add support for 'array of strings' ? +-- - add support for macro preprocessing +-- - add support for optional macro #include +-- - applicative style (see http://github.com/markusle/husky)? +-- - type checking +-- - check for constant expression where expected +-- - error reporting +-- - pretty-printing +-- - basic queries (inputs and outputs of the shader) +-- - support GLSL 1.40? +-- - proper testing (HUnit and QuickCheck) +-- - use hpc with the tests +-- - scoping +-- - clean module import/export +-- - order of Syntax data types and Pretty instances should be the same +-- - build with no warning +-- - use hlint +-- - push to github +-- - push to hackage +-- - use parsec 3 +-- - handle all possible newlines (\n, \r, \r\n, \n\r) +-- - 80-columns clean +-- - lot of restriction of Samplers use (section 4.1.7), +-- well in fact, for plenty of things. +---------------------------------------------------------------------- +-- Abstract syntax tree +---------------------------------------------------------------------- + + +type TranslationUnit + = TranslationUnit (List ExternalDeclaration) + + + +-- at least one + + +type ExternalDeclaration + = -- function declarations should be at top level (page 28) + FunctionDeclaration FunctionPrototype + | FunctionDefinition FunctionPrototype Compound + | Declaration Declaration + + + +-- TODO clean + + +type Declaration + = -- e.g. layout (origin_upper_left) in vec4 gl_FragCoord; + -- struct name { ... }; + -- struct name { ... } name; + InitDeclaration InvariantOrType (List InitDeclarator) + | Precision PrecisionQualifier TypeSpecifierNoPrecision + | Block TypeQualifier String (List Field) (Maybe ( String, Maybe (Maybe Expr) )) -- constant expression + -- e.g. layout (origin_upper_left) in; TODO check if it is only used for default layout. + | TQ TypeQualifier + + + +-- TODO regroup String (Maybe (Maybe Expr)) as Declarator and use it for +-- StructDeclarator. + + +type InitDeclarator + = InitDecl String (Maybe (Maybe Expr)) (Maybe Expr) -- constant expression; assignment expression + + +type InvariantOrType + = InvariantDeclarator + | TypeDeclarator FullType + + +type FunctionPrototype + = FuncProt FullType String (List ParameterDeclaration) + + +type ParameterDeclaration + = ParameterDeclaration (Maybe ParameterTypeQualifier) (Maybe ParameterQualifier) TypeSpecifier (Maybe ( String, Maybe Expr )) + + + +-- constant expression + + +type FullType + = FullType (Maybe TypeQualifier) TypeSpecifier + + + +-- sto +-- lay [sto] +-- int [sto] +-- inv [sto] +-- inv int sto + + +type TypeQualifier + = TypeQualSto StorageQualifier + | TypeQualLay LayoutQualifier (Maybe StorageQualifier) + | TypeQualInt InterpolationQualifier (Maybe StorageQualifier) + | TypeQualInv InvariantQualifier (Maybe StorageQualifier) + | TypeQualInv3 InvariantQualifier InterpolationQualifier StorageQualifier + + +type TypeSpecifier + = TypeSpec (Maybe PrecisionQualifier) TypeSpecifierNoPrecision + + +type InvariantQualifier + = Invariant + + +type InterpolationQualifier + = Smooth + | Flat + | NoPerspective + + +type LayoutQualifier + = Layout (List LayoutQualifierId) + + +type LayoutQualifierId + = LayoutQualId String (Maybe Expr) -- TODO Expr should be IntConstant + + +type Statement + = -- declaration statement + DeclarationStatement Declaration + -- jump statement + | Continue + | Break + | Return (Maybe Expr) + | Discard -- fragment shader only + -- compound statement + | CompoundStatement Compound + -- expression statement + | ExpressionStatement (Maybe Expr) + -- selection statement + | SelectionStatement Expr Statement (Maybe Statement) + -- switch statement + | SwitchStatement Expr (List Statement) + | CaseLabel CaseLabel + -- iteration statement + | While Condition Statement -- no new scope + | DoWhile Statement Expr + | For (Result (Maybe Expr) Declaration) (Maybe Condition) (Maybe Expr) Statement + + + +-- 1st stmt: expression or declaration, 2nd: no new scope + + +type Compound + = Compound (List Statement) + + +type Condition + = Condition Expr + | InitializedCondition FullType String Expr -- assignment expression + + +type CaseLabel + = Case Expr + | Default + + +type StorageQualifier + = Const + | Attribute -- vertex only + | Varying + | CentroidVarying + | In + | Out + | CentroidIn + | CentroidOut + | Uniform + + +type TypeSpecifierNoPrecision + = TypeSpecNoPrecision TypeSpecifierNonArray (Maybe (Maybe Expr)) -- constant expression + + +type TypeSpecifierNonArray + = Void + | Float + | Int + | UInt + | Bool + | Vec2 + | Vec3 + | Vec4 + | BVec2 + | BVec3 + | BVec4 + | IVec2 + | IVec3 + | IVec4 + | UVec2 + | UVec3 + | UVec4 + | Mat2 + | Mat3 + | Mat4 + | Mat2x2 + | Mat2x3 + | Mat2x4 + | Mat3x2 + | Mat3x3 + | Mat3x4 + | Mat4x2 + | Mat4x3 + | Mat4x4 + | Sampler1D + | Sampler2D + | Sampler3D + | SamplerCube + | Sampler1DShadow + | Sampler2DShadow + | SamplerCubeShadow + | Sampler1DArray + | Sampler2DArray + | Sampler1DArrayShadow + | Sampler2DArrayShadow + | ISampler1D + | ISampler2D + | ISampler3D + | ISamplerCube + | ISampler1DArray + | ISampler2DArray + | USampler1D + | USampler2D + | USampler3D + | USamplerCube + | USampler1DArray + | USampler2DArray + | Sampler2DRect + | Sampler2DRectShadow + | ISampler2DRect + | USampler2DRect + | SamplerBuffer + | ISamplerBuffer + | USamplerBuffer + | Sampler2DMS + | ISampler2DMS + | USampler2DMS + | Sampler2DMSArray + | ISampler2DMSArray + | USampler2DMSArray + | StructSpecifier (Maybe String) (List Field) + | TypeName String -- TODO user-defined type, should verify if it is declared + + +type PrecisionQualifier + = HighP + | MediumP + | LowP + + + +-- TODO The type qualifier can be present only when there is one or more declarators. +-- There other restrictions, see 4.1.8. + + +type Field + = Field (Maybe TypeQualifier) TypeSpecifier (List StructDeclarator) + + +type StructDeclarator + = StructDeclarator String (Maybe (Maybe Expr)) -- constant expression + + +type Expr + = -- primaryExpression + Variable String + | IntConstant IntConstantKind Int + | FloatConstant Float + | BoolConstant Bool + -- postfixExpression + | Bracket Expr Expr + | FieldSelection Expr String + | MethodCall Expr FunctionIdentifier Parameters + | FunctionCall FunctionIdentifier Parameters + | PostInc Expr + | PostDec Expr + | PreInc Expr + | PreDec Expr + -- unary expression + | UnaryPlus Expr + | UnaryNegate Expr + | UnaryNot Expr + | UnaryOneComplement Expr + -- binary expression + | Mul Expr Expr + | Div Expr Expr + | Mod Expr Expr + | Add Expr Expr + | Sub Expr Expr + | LeftShift Expr Expr + | RightShift Expr Expr + | Lt Expr Expr + | Gt Expr Expr + | Lte Expr Expr + | Gte Expr Expr + | Equ Expr Expr + | Neq Expr Expr + | BitAnd Expr Expr + | BitXor Expr Expr + | BitOr Expr Expr + | And Expr Expr + | Or Expr Expr + | Selection Expr Expr Expr -- ternary _ ? _ : _ operator + -- assignment, the left Expr should be unary expression + | Equal Expr Expr + | MulAssign Expr Expr + | DivAssign Expr Expr + | ModAssign Expr Expr + | AddAssign Expr Expr + | SubAssign Expr Expr + | LeftAssign Expr Expr + | RightAssign Expr Expr + | AndAssign Expr Expr + | XorAssign Expr Expr + | OrAssign Expr Expr + -- sequence + | Sequence Expr Expr + + +type IntConstantKind + = Hexadecimal + | Octal + | Decimal + + +type Parameters + = ParamVoid + | Params (List Expr) + + +type ParameterQualifier + = InParameter + | OutParameter + | InOutParameter + + +type ParameterTypeQualifier + = ConstParameter + + +type FunctionIdentifier + = -- TODO could be refine (I think a precision qualifier is not permitted, + -- nor a complete struct definition) + FuncIdTypeSpec TypeSpecifier + | FuncId String diff --git a/terminal/src/Develop/Socket.elm b/terminal/src/Develop/Socket.elm index 6f4828bee..5214d2ae3 100644 --- a/terminal/src/Develop/Socket.elm +++ b/terminal/src/Develop/Socket.elm @@ -5,10 +5,14 @@ import Control.Exception exposing (SomeException, catch) import Data.ByteString.Char8 as BS import Data.IO exposing (IO) import Network.WebSockets as WS -import System.FSNotify.Devel as Notify import System.FSNotify as Notify +import System.FSNotify.Devel as Notify + + +a = + 0 + -a = 0 --watchFile : FilePath -> WS.PendingConnection -> IO () --watchFile watchedFile pendingConnection = diff --git a/tests/backwards-compatibility.test.js b/tests/backwards-compatibility.test.js index 3a2e24ef0..dc1804f6a 100644 --- a/tests/backwards-compatibility.test.js +++ b/tests/backwards-compatibility.test.js @@ -4,10 +4,47 @@ const childProcess = require("child_process"); const os = require("os"); const tmpDir = os.tmpdir(); -const examples = ["Hello", "Buttons", "Clock", "HttpQuotes", "Cards"]; -const flags = ["no-flags", "debug", "optimize"]; +const examples = [ + // HTML + "Hello", + "Groceries", + "Shapes", + // User Input + "Buttons", + "TextFields", + "Forms", + // Random + "Numbers", + "Cards", + "Positions", + // HTTP + "Book", + "Quotes", + // Time + "CurrentTime", + "Clock", + // Files + ["Upload", ["no-flags", "debug"]], + ["DragAndDrop", ["no-flags", "debug"]], + "ImagePreviews", + // WebGL + "Triangle", + "Cube", + "Crate", + "Thwomp", + "FirstPerson", + // Playground + "Picture", + "Animation", + "Mouse", + "Keyboard", + "Turtle", + "Mario", +]; -const generateFlags = function (flag) { +const defaultFlags = ["no-flags", "debug", "optimize"]; + +const generateCommandFlags = function (flag) { if (flag === "no-flags") { return ""; } else { @@ -18,15 +55,24 @@ const generateFlags = function (flag) { describe("backwards compatibility", () => { describe.each(examples)( "produces the same code as elm for the %s example", - (example) => { - test.each(flags)("%s", (flagOpt) => { - const elmOutput = `${tmpDir}/guida-test-elm-${example}-${flagOpt}-${process.pid}.js`; - const guidaOutput = `${tmpDir}/guida-test-guida-${example}-${flagOpt}-${process.pid}.js`; - const flag = generateFlags(flagOpt); + (examplePlusFlags) => { + let example, currentFlags; + + if (Array.isArray(examplePlusFlags)) { + [example, currentFlags] = examplePlusFlags; + } else { + example = examplePlusFlags; + currentFlags = defaultFlags; + } + + test.each(currentFlags)("%s", (flag) => { + const elmOutput = `${tmpDir}/guida-test-elm-${example}-${flag}-${process.pid}.js`; + const guidaOutput = `${tmpDir}/guida-test-guida-${example}-${flag}-${process.pid}.js`; + const commandFlag = generateCommandFlags(flag); try { childProcess.execSync( - `elm make ./src/${example}.elm ${flag} --output ${elmOutput}`, + `elm make ./src/${example}.elm ${commandFlag} --output ${elmOutput}`, { cwd: path.join(__dirname, "..", "examples") } ); } catch (e) { @@ -35,7 +81,7 @@ describe("backwards compatibility", () => { try { childProcess.execSync( - `../bin/index.js make ./src/${example}.elm ${flag} --output ${guidaOutput}`, + `../bin/index.js make ./src/${example}.elm ${commandFlag} --output ${guidaOutput}`, { cwd: path.join(__dirname, "..", "examples") } ); } catch (e) {