diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index b554b25..80241bf 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -1,47 +1,55 @@ +# Code generated by dhall-to-yaml. DO NOT EDIT. jobs: build: - runs-on: ubuntu-latest + name: "GHC ${{ matrix.ghc }}, Cabal ${{ matrix.cabal }}, OS ${{ matrix.os }}" + "runs-on": "${{ matrix.os }}" steps: - - name: Native dependencies - run: sudo apt install libgmp-dev libgl1-mesa-dev libxcursor-dev libxi-dev libxinerama-dev libxrandr-dev libxxf86vm-dev - - uses: "actions/checkout@v3" - - id: setup-haskell-cabal - uses: "haskell/actions/setup@v2" - with: - cabal-version: "${{ matrix.cabal }}" - enable-stack: false - ghc-version: "${{ matrix.ghc }}" - - name: Update Hackage repository - run: cabal update - - name: cabal.project.local.ci - run: | - if [ -e cabal.project.local.ci ]; then - cp cabal.project.local.ci cabal.project.local - fi - - name: freeze - run: cabal freeze - - uses: "actions/cache@v3" - with: - key: "${{ runner.os }}-${{ matrix.ghc }}-cabal-${{ hashFiles('cabal.project.freeze') }}" - path: | - ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - dist-newstyle - - name: Install dependencies - run: cabal build all --enable-tests --enable-benchmarks --only-dependencies - - name: build all - run: cabal build all --enable-tests --enable-benchmarks - - name: test all - run: cabal test all --enable-tests - - name: haddock all - run: cabal haddock all + - name: Native dependencies + run: "sudo apt install libgmp-dev libgl1-mesa-dev libxcursor-dev libxi-dev libxinerama-dev libxrandr-dev libxxf86vm-dev" + - uses: "actions/checkout@v4" + with: + submodules: recursive + - id: "setup-haskell-cabal" + uses: "haskell-actions/setup@v2" + with: + "cabal-version": "${{ matrix.cabal }}" + "ghc-version": "${{ matrix.ghc }}" + - name: Update Hackage repository + run: cabal update + - name: cabal.project.local.ci + run: | + if [ -e cabal.project.local.ci ]; then + cp cabal.project.local.ci cabal.project.local + fi + - name: freeze + run: "cabal freeze --enable-tests --enable-benchmarks" + - uses: "actions/cache@v3" + with: + key: "${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal}}-${{ hashFiles('cabal.project.freeze') }}" + path: | + ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + dist-newstyle + - name: Install dependencies + run: "cabal build all --enable-tests --enable-benchmarks --only-dependencies" + - name: build all + run: "cabal build all --enable-tests --enable-benchmarks" + - name: test all + run: "cabal test all --enable-tests" + - name: haddock all + run: cabal haddock all strategy: matrix: cabal: - - '3.4' + - '3.10' ghc: - - '9.0.2' - - '8.10.7' + - '9.6.3' + - '9.4.7' + - '9.2.8' + os: + - "ubuntu-latest" name: Haskell CI -on: - - push - - pull_request +'on': + pull_request: {} + push: {} + schedule: + - cron: "4 20 10 * *" diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..05dbef7 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,357 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + # - records: + # # How to format equals sign between type constructor and data constructor. + # # Possible values: + # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + # equals: "indent 2" + # + # # How to format first field of each record constructor. + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # first_field: "indent 2" + # + # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + # field_comment: 2 + # + # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + # via: "indent 2" + # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # + # # Wheter or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: none + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Enabling this argument will use the new GHC lib parse to format imports. + # + # This currently assumes a few things, it will assume that you want post + # qualified imports. It is also not as feature complete as the old + # imports formatting. + # + # It does not remove redundant lines or merge lines. As such, the full + # feature scope is still pending. + # + # It _is_ however, a fine alternative if you are using features that are + # not parseable by haskell src extensions and you're comfortable with the + # presets. + # + # Default: false + ghc_lib_parser: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: false + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true diff --git a/cabal.project b/cabal.project index 6613271..c3b035c 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,34 @@ packages: ./. + +allow-newer: + GPipe:containers + , GPipe:linear + , GPipe:transformers + , GPipe:hashtables + , GPipe-GLFW:linear + +-- fork due to resizeBuffer PR https://github.com/tobbebex/GPipe-Core/pull/76 +source-repository-package + type: git + location: https://github.com/sorki/GPipe-Core + tag: 86a7b29014e7ebfb24ac17d5afcd877a38a1fbd5 + subdir: + GPipe-Core + +-- until next release +source-repository-package + type: git + location: https://github.com/plredmond/GPipe-GLFW + tag: 3d7e91a20a80fe31e910884b151ebe4d26e8274e + subdir: + GPipe-GLFW + +-- NOTE: having implicit listed here breaks hint +-- see https://github.com/Haskell-Things/implicitpipe/issues/2 +-- +-- source-repository-package +-- type: git +-- location: https://github.com/Haskell-Things/ImplicitCAD +-- tag: ae794b901e9677593815fad741d87ff56846562d + + diff --git a/cabal.project.local.ci b/cabal.project.local.ci index 45739e5..e69de29 100644 --- a/cabal.project.local.ci +++ b/cabal.project.local.ci @@ -1,23 +0,0 @@ --- NOTE: having implicit listed here breaks hint --- see https://github.com/Haskell-Things/implicitpipe/issues/2 --- --- source-repository-package --- type: git --- location: https://github.com/Haskell-Things/ImplicitCAD --- tag: ae794b901e9677593815fad741d87ff56846562d - --- fork due to resizeBuffer PR https://github.com/tobbebex/GPipe-Core/pull/76 -source-repository-package - type: git - location: https://github.com/sorki/GPipe-Core - tag: 86a7b29014e7ebfb24ac17d5afcd877a38a1fbd5 - subdir: - GPipe-Core - --- until next release -source-repository-package - type: git - location: https://github.com/plredmond/GPipe-GLFW - tag: 3d7e91a20a80fe31e910884b151ebe4d26e8274e - subdir: - GPipe-GLFW diff --git a/ci.dhall b/ci.dhall index 3593ec0..ca814c1 100644 --- a/ci.dhall +++ b/ci.dhall @@ -1,18 +1,19 @@ let haskellCi = - https://raw.githubusercontent.com/sorki/github-actions-dhall/pending/haskell-ci.dhall + https://raw.githubusercontent.com/sorki/github-actions-dhall/main/haskell-ci.dhall + +let steps = haskellCi.defaultCabalSteps in haskellCi.generalCi - ( [ haskellCi.BuildStep.Name - { name = "Native dependencies" - , run = - "sudo apt install libgmp-dev libgl1-mesa-dev libxcursor-dev libxi-dev libxinerama-dev libxrandr-dev libxxf86vm-dev" - } - ] - # haskellCi.matrixSteps - ) - ( Some - { ghc = [ haskellCi.GHC.GHC902, haskellCi.GHC.GHC8107 ] - , cabal = [ haskellCi.Cabal.Cabal34 ] - } + ( steps + with extraSteps.pre + = + steps.extraSteps.pre + # [ haskellCi.BuildStep.Name + { name = "Native dependencies" + , run = + "sudo apt install libgmp-dev libgl1-mesa-dev libxcursor-dev libxi-dev libxinerama-dev libxrandr-dev libxxf86vm-dev" + } + ] ) + (haskellCi.DhallMatrix::{=} with ghc = haskellCi.defaultGHC3) : haskellCi.CI.Type diff --git a/ci.sh b/ci.sh index 7d7cc86..6839ab0 100755 --- a/ci.sh +++ b/ci.sh @@ -2,12 +2,11 @@ # Script by @fisx set -eo pipefail -cd "$( dirname "${BASH_SOURCE[0]}" )" -echo "regenerating .github/workflows/ci.yaml..." +# cd into the dir where this script is placed +cd "$( dirname "${BASH_SOURCE[0]}" )" -mkdir -p .github/workflows +echo "regenerating .github/workflows/ci.yaml" -# based on https://github.com/vmchale/github-actions-dhall -which dhall-to-yaml || cabal install dhall-yaml -dhall-to-yaml --file ci.dhall > .github/workflows/ci.yaml +which dhall-to-yaml-ng || cabal install dhall-yaml +dhall-to-yaml-ng --generated-comment --file ci.dhall > .github/workflows/ci.yaml diff --git a/default.nix b/default.nix index d796be9..25c64e6 100644 --- a/default.nix +++ b/default.nix @@ -1,10 +1,5 @@ -{ rev ? "7c6985653708c5fade76d2014824ff333b0a07b2" -, overlays ? [ (import ./overlay.nix) ] -, pkgs ? - if ((rev == "") || (rev == "default") || (rev == "local")) - then import { inherit overlays; } - # Do not guard with hash, so the project is able to use current channels (rolling `rev`) of Nixpkgs - else import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz") { inherit overlays; } +{ overlays ? [ (import ./overlay.nix) ] +, pkgs ? import { inherit overlays; } }: let diff --git a/implicitpipe.cabal b/implicitpipe.cabal index 9f78271..1fde21a 100644 --- a/implicitpipe.cabal +++ b/implicitpipe.cabal @@ -19,7 +19,7 @@ library , data-default , directory , filepath - , fsnotify + , fsnotify >= 0.4 , GPipe >= 2.2 , GPipe-GLFW >= 1.4 , GLFW-b diff --git a/overlay.nix b/overlay.nix index 40409c0..8a933f1 100644 --- a/overlay.nix +++ b/overlay.nix @@ -22,8 +22,8 @@ in overrides = super.lib.composeExtensions (old.overrides or (_: _: {})) (hself: hsuper: { #GPipe = super.haskell.lib.doJailbreak hsuper.GPipe; - GPipe = hsuper.callCabal2nix "GPipe" "${gpipeSrc}/GPipe-Core" {}; - GPipe-GLFW = hsuper.callCabal2nix "GPipe-GLFW" ("${gpipeGlfwSrc}/GPipe-GLFW") {}; + GPipe = super.haskell.lib.doJailbreak (hsuper.callCabal2nix "GPipe" "${gpipeSrc}/GPipe-Core" {}); + GPipe-GLFW = super.haskell.lib.doJailbreak (hsuper.callCabal2nix "GPipe-GLFW" ("${gpipeGlfwSrc}/GPipe-GLFW") {}); # for development # implicit = hsuper.callCabal2nix "implicit" (super.fetchFromGitHub { diff --git a/src/Graphics/Implicit/Viewer.hs b/src/Graphics/Implicit/Viewer.hs index 7bdd3ba..6b90dd2 100644 --- a/src/Graphics/Implicit/Viewer.hs +++ b/src/Graphics/Implicit/Viewer.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Graphics.Implicit.Viewer ( animate @@ -24,16 +23,16 @@ import Control.Monad.IO.Class import Data.Default import qualified Data.Map -import Graphics.GPipe hiding ((^-^), rotate, mod') +import Graphics.GPipe hiding (mod', rotate, (^-^)) +import qualified Graphics.GPipe.Context.GLFW as GLFW import Graphics.UI.GLFW (WindowHint(..)) -import qualified "GPipe-GLFW" Graphics.GPipe.Context.GLFW as GLFW import Graphics.Implicit +import Graphics.Implicit.Viewer.Demos import Graphics.Implicit.Viewer.Loaders import Graphics.Implicit.Viewer.Shaders import Graphics.Implicit.Viewer.Types import Graphics.Implicit.Viewer.Util -import Graphics.Implicit.Viewer.Demos -- | View `SymbolicObj3` object using OpenGL viewer view :: SymbolicObj3 -> IO () @@ -117,7 +116,7 @@ viewer config@ViewerConf{..} = do fragmentStream <- do - guard' (shaderEnvFlatNormals) + guard' shaderEnvFlatNormals rasterize shaderEnvRasterOptions (proj Flat <$> primitiveStream) @@ -197,8 +196,8 @@ loop win shader triangles unionBuffers@Uniforms{..} aTime eventChan renderChan v projMat = perspective (pi/2) (fromIntegral windowWidth / fromIntegral windowHeight) 0.1 100 - eye = (V3 0 (-1) 1) - lookAtPoint = (V3 0 0 0) + eye = V3 0 (-1) 1 + lookAtPoint = V3 0 0 0 cameraMatrix :: M44 Float cameraMatrix = @@ -276,8 +275,8 @@ updateViewerState win chan oldState = do V2 cursorX cursorY = lastCursorPos in s { lastCursorPos = x - , camPitch = ((realToFrac $ cursorY - oldCursorY) / 100 + camPitch) `mod''` (2*pi) - , camYaw = ((realToFrac $ cursorX - oldCursorX) / 100 + camYaw) `mod''` (2*pi) + , camPitch = (realToFrac (cursorY - oldCursorY) / 100 + camPitch) `mod''` (2*pi) + , camYaw = (realToFrac (cursorX - oldCursorX) / 100 + camYaw) `mod''` (2*pi) } LeftMouse x -> s { camRotating = x } @@ -303,13 +302,13 @@ updateViewerState win chan oldState = do spaceKey <- GLFW.getKey win GLFW.Key'Space let faster = case spaceKey of Just GLFW.KeyState'Pressed -> (*10) - _ -> id + _ -> id animDirection = if animationForward then 1 else -1 animTime = if animationRunning - then animationTime + (faster $ animDirection * animationStep) + then animationTime + faster (animDirection * animationStep) else animationTime nextOutOfBounds = @@ -376,4 +375,4 @@ setupCallbacks win chan = do when (keyState == GLFW.KeyState'Pressed) $ do case Data.Map.lookup key keyMap of Just message -> atomically $ writeTChan chan message - _ -> return () + _ -> return () diff --git a/src/Graphics/Implicit/Viewer/Config.hs b/src/Graphics/Implicit/Viewer/Config.hs index 9884f0c..dd19f59 100644 --- a/src/Graphics/Implicit/Viewer/Config.hs +++ b/src/Graphics/Implicit/Viewer/Config.hs @@ -20,7 +20,7 @@ data Resolution = -- | Scale resolution by function apResolution :: (Double -> Double) -> Resolution -> Resolution -apResolution f (Fixed n) = Fixed (f n) +apResolution f (Fixed n) = Fixed (f n) apResolution f (Varied f') = Varied $ f' . f meshFunFromResolution @@ -28,7 +28,7 @@ meshFunFromResolution -> Double -> SymbolicObj3 -> NormedTriangleMesh -meshFunFromResolution (Fixed n) = const $ discreteAprox n +meshFunFromResolution (Fixed n) = const $ discreteAprox n meshFunFromResolution (Varied f) = f data ViewerConf = ViewerConf diff --git a/src/Graphics/Implicit/Viewer/Demos.hs b/src/Graphics/Implicit/Viewer/Demos.hs index e1d8515..ddf42f9 100644 --- a/src/Graphics/Implicit/Viewer/Demos.hs +++ b/src/Graphics/Implicit/Viewer/Demos.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} module Graphics.Implicit.Viewer.Demos where -import Linear import Graphics.Implicit import Graphics.Implicit.Primitives @@ -23,8 +22,8 @@ demoRotatingAnim t = ontop :: SymbolicObj3 -> SymbolicObj3 -> SymbolicObj3 ontop a b = union [ translate (V3 0 0 z) a, b ] where z = let - ((V3 _ _ aBottom), _) = getBox a - (_, (V3 _ _ bTop)) = getBox b + (V3 _ _ aBottom, _) = getBox a + (_, V3 _ _ bTop) = getBox b in bTop - aBottom demoTranslatedSymbolic :: SymbolicObj3 diff --git a/src/Graphics/Implicit/Viewer/Loaders.hs b/src/Graphics/Implicit/Viewer/Loaders.hs index 7cf5721..eb26911 100644 --- a/src/Graphics/Implicit/Viewer/Loaders.hs +++ b/src/Graphics/Implicit/Viewer/Loaders.hs @@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Graphics.Implicit.Viewer.Loaders where @@ -10,22 +10,22 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad -import Control.Monad.Trans.Maybe (runMaybeT, MaybeT(..)) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Foldable (asum) import Data.List (isSuffixOf) -import Data.Time (getCurrentTime, diffUTCTime) +import Data.Time (diffUTCTime, getCurrentTime) import Data.Typeable (Typeable) import Graphics.Implicit -import Graphics.Implicit.Primitives (getBox) +import Graphics.Implicit.Export.GL import Graphics.Implicit.ExtOpenScad.Definitions +import Graphics.Implicit.Primitives (getBox) import Graphics.Implicit.Viewer.Types -import Graphics.Implicit.Export.GL import qualified Language.Haskell.Interpreter as Hint +import qualified System.Directory import qualified System.FSNotify as FSNotify import qualified System.FilePath -import qualified System.Directory -- | Run fsnotify based directory watcher for .hs and .escad files -- and run appropriate loader based on the file extension. @@ -52,7 +52,7 @@ runUpdater modFileRel initialResolution renderChan = void $ do eventHandler (FSNotify.Modified fp _ _) = atomically $ writeTChan watchEvent fp eventHandler _ = return () - void $ async $ FSNotify.withManagerConf (FSNotify.defaultConfig { FSNotify.confDebounce = FSNotify.Debounce 1 }) $ \mgr -> do + void $ async $ FSNotify.withManagerConf FSNotify.defaultConfig $ \mgr -> do void $ FSNotify.watchDir mgr (System.FilePath.takeDirectory modFile) @@ -102,7 +102,7 @@ loadViaHint modFile initialResolution renderChan = do mo <- eval @SymbolicObj3 modFile "obj" case mo of - Right o -> renderObjToChan o resolution renderChan + Right o -> renderObjToChan o resolution renderChan Left (Hint.WontCompile ghcErrs) -> forM_ ghcErrs $ putStrLn . Hint.errMsg Left (Hint.UnknownError str) -> putStrLn $ "Unknown error: " ++ str Left (Hint.NotAllowed str) -> putStrLn $ "Not allowed: " ++ str @@ -127,7 +127,7 @@ evalMay :: forall t. Typeable t evalMay modFile s = toMaybe $ eval modFile s where toMaybe a = a >>= return . \case Right x -> Just x - _ -> Nothing + _ -> Nothing loadViaEscad :: FilePath @@ -154,7 +154,7 @@ loadViaEscad modFile initialResolution renderChan = do let res = case lookupVarIn "$res" varLookup of Just (ONum n) -> Fixed n - _ -> initialResolution + _ -> initialResolution renderObjToChan (unionR 0 ((extrude (unionR 0 objs2) 1):objs3)) @@ -185,7 +185,7 @@ renderObjToChan o resolution renderChan = do unless (l == 0) $ do atomically $ writeTChan renderChan (l, objScale, mesh) after <- getCurrentTime - putStrLn $ "Done in " ++ (show $ diffUTCTime after now) + putStrLn $ "Done in " ++ show (diffUTCTime after now) when (l == 0) $ putStrLn "Mesh empty" @@ -200,6 +200,6 @@ runAnimation f initialResolution renderChan aTime = void $ async $ forever $ do isE <- atomically $ isEmptyTChan renderChan case isE of True -> do - t <- atomically $ readTVar aTime + t <- readTVarIO aTime renderObjToChan (f t) initialResolution renderChan False -> threadDelay 100000 diff --git a/src/Graphics/Implicit/Viewer/Shaders.hs b/src/Graphics/Implicit/Viewer/Shaders.hs index 9e183af..e3fb394 100644 --- a/src/Graphics/Implicit/Viewer/Shaders.hs +++ b/src/Graphics/Implicit/Viewer/Shaders.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Implicit.Viewer.Shaders where -import Data.Map (Map) -import qualified Data.Map import Data.Default import Data.Foldable +import Data.Map (Map) +import qualified Data.Map import Graphics.GPipe import Graphics.Implicit.Viewer.Types @@ -32,7 +32,7 @@ allShaders = Data.Map.fromList $ zip [0..] asumShaderByID :: forall os - . ((ShaderEnvironment os) -> Int) + . (ShaderEnvironment os -> Int) -> Window os RGBAFloat Depth -> FragStream -> Shader os (ShaderEnvironment os) () @@ -62,16 +62,16 @@ computeLight specularIntensity eye VertexInfo{..} = halfVector = signorm viewDir specular = maxB (viNormal `dot` halfVector) 0 in - specularIntensity *^ (V4 1 1 1 1) ^* (specular ** 32) + specularIntensity *^ V4 1 1 1 1 ^* (specular ** 32) + (1 *^ opaque $ 0.1 -- global illumination + ( -- red light from front right - (V3 0.8 0 0 ^* (maxB (normal `dot` dirR) 0)) + (V3 0.8 0 0 ^* maxB (normal `dot` dirR) 0) -- green from front left - + (V3 0 0.8 0 ^* (maxB (normal `dot` dirG) 0)) + + (V3 0 0.8 0 ^* maxB (normal `dot` dirG) 0) -- blue from bottom - + (V3 0 0 0.8 ^* (maxB (normal `dot` dirB) 0)) + + (V3 0 0 0.8 ^* maxB (normal `dot` dirB) 0) )) lightShaded @@ -82,7 +82,7 @@ lightShaded lightShaded i win fragStream = do eye <- getUni bEye let - litFrags = (computeLight i eye) <$> fragStream + litFrags = computeLight i eye <$> fragStream drawWindowColorDepth (const (win, def, def)) @@ -100,7 +100,7 @@ alphaWireframe win fragStream = do (V3 i j k) = w edgeFactor = minB (minB i j) k in - (V4 1 0 0 ((1.0 - edgeFactor) * 0.95)) + V4 1 0 0 ((1.0 - edgeFactor) * 0.95) drawWindowColor (const (win, blendAlpha)) @@ -125,7 +125,7 @@ edgy win fragStream = do drawWindowColor (const (win, blendAlpha)) - (wireFrags) + wireFrags edges :: forall os . Window os RGBAFloat Depth diff --git a/src/Graphics/Implicit/Viewer/Types.hs b/src/Graphics/Implicit/Viewer/Types.hs index 543b352..ed1292e 100644 --- a/src/Graphics/Implicit/Viewer/Types.hs +++ b/src/Graphics/Implicit/Viewer/Types.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Arrows #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} -- due to getUni which explodes when given signature {-# OPTIONS_GHC -fno-warn-missing-signatures #-} diff --git a/src/Graphics/Implicit/Viewer/Util.hs b/src/Graphics/Implicit/Viewer/Util.hs index fa02539..cb5532c 100644 --- a/src/Graphics/Implicit/Viewer/Util.hs +++ b/src/Graphics/Implicit/Viewer/Util.hs @@ -1,9 +1,9 @@ module Graphics.Implicit.Viewer.Util where -import Linear import Data.Map (Map) import qualified Data.Map +import Linear mkScaleTransform :: Float -> M44 Float mkScaleTransform s =