diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile new file mode 100644 index 0000000000000000000000000000000000000000..4f495f174717f7b7ec37d1f28161b6f951e440fa --- /dev/null +++ b/.devcontainer/Dockerfile @@ -0,0 +1,73 @@ +FROM mcr.microsoft.com/devcontainers/base:bookworm + +# update Debian +ENV DEBIAN_FRONTEND=noninteractive +RUN apt-get update && apt-get -y dist-upgrade + +# user +USER vscode +WORKDIR /home/vscode +ENV LC_ALL=en_US.utf-8 + +# ghcup +ARG BOOTSTRAP_HASKELL_NONINTERACTIVE=1 +ARG BOOTSTRAP_HASKELL_MINIMAL=1 +RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh +ENV PATH=/home/vscode/.ghcup/bin:$PATH + +# cabal +RUN ghcup install cabal --set latest +RUN cabal update +ENV PATH=/home/vscode/.cabal/bin:$PATH + +# native back-end +ENV GHC_NATIVE_VERSIONS="9.8.4 9.10.1 9.12.2" +ENV GHC_NATIVE_EXPIRED_VERSIONS="9.4.8 9.6.7" +WORKDIR /home/vscode +RUN for V in $GHC_NATIVE_VERSIONS $GHC_NATIVE_EXPIRED_VERSIONS; do ghcup install ghc $V; done +RUN sudo apt-get install -y libgmp-dev + +# formatter +WORKDIR /home/vscode +RUN ghcup set ghc 9.12.2 +RUN cabal install fourmolu-0.18.0.0 + +# WebAssembly back-end +ENV GHC_WASM32_VERSIONS="wasm32-wasi-9.8.4.20250206 wasm32-wasi-9.10.1.20250327 wasm32-wasi-9.12.2.20250327" +WORKDIR /home/vscode +RUN sudo apt-get install -y zstd +RUN curl https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/bootstrap.sh | SKIP_GHC=1 sh +RUN ghcup config add-release-channel https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/ghcup-wasm-0.0.9.yaml +RUN . /home/vscode/.ghc-wasm/env && for V in $GHC_WASM32_VERSIONS; do ghcup install ghc $V -- $CONFIGURE_ARGS; done +RUN curl -LO https://github.com/bytecodealliance/wasmtime/releases/download/dev/wasmtime-dev-x86_64-linux.tar.xz +RUN xz -d wasmtime-dev-x86_64-linux.tar.xz +RUN tar xvf wasmtime-dev-x86_64-linux.tar +ENV PATH=/home/vscode/wasmtime-dev-x86_64-linux:$PATH + +# JavaScript back-end +ENV GHC_JS_VERSIONS="javascript-unknown-ghcjs-9.10.0.20240413 javascript-unknown-ghcjs-9.12.1" +WORKDIR /home/vscode +RUN sudo apt-get install -y nodejs +RUN ghcup config add-release-channel cross +RUN git clone https://github.com/emscripten-core/emsdk.git +WORKDIR /home/vscode/emsdk +RUN sudo apt-get install -y python3 +RUN ./emsdk install 3.1.57 +RUN ./emsdk activate 3.1.57 +RUN . ./emsdk_env.sh && emconfigure ghcup install ghc javascript-unknown-ghcjs-9.10.0.20240413 +RUN ./emsdk install 3.1.74 +RUN ./emsdk activate 3.1.74 +RUN . ./emsdk_env.sh && emconfigure ghcup install ghc javascript-unknown-ghcjs-9.12.1 + +# MicroHs back-end +WORKDIR /home/vscode +RUN git clone https://github.com/augustss/MicroHs.git --branch stable-7 mhs +WORKDIR /home/vscode/mhs +RUN make minstall +ENV PATH=/home/vscode/.mcabal/bin:$PATH + +# build commands +WORKDIR /home/vscode +RUN sudo apt-get install -y autoconf +ENV PATH=/workspaces/time/bin:$PATH +ENV TZ="America/Los_Angeles" diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json new file mode 100644 index 0000000000000000000000000000000000000000..97835dcec2160d688d4a509fdf99a1b70660e510 --- /dev/null +++ b/.devcontainer/devcontainer.json @@ -0,0 +1,9 @@ +// For format details, see https://aka.ms/devcontainer.json. For config options, see the +// README at: https://github.com/devcontainers/templates/tree/main/src/debian +{ + "name": "Builder", + "build": + { + "dockerfile": "Dockerfile" + } +} diff --git a/.envrc b/.envrc new file mode 100644 index 0000000000000000000000000000000000000000..4062153171b36d529bd096cc2e63913266bbff20 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use nix -p devcontainer just act docker diff --git a/.github/workflows/ci.mhs.yml b/.github/workflows/ci.mhs.yml deleted file mode 100644 index 91f1ef5ed6a93c1d9d2f64d3f6bf9eb1a9a9b8d4..0000000000000000000000000000000000000000 --- a/.github/workflows/ci.mhs.yml +++ /dev/null @@ -1,43 +0,0 @@ -name: ci-mhs - -on: - push: - branches: [ "master" ] - pull_request: - branches: [ "master" ] - -jobs: - build-mhs-time: - runs-on: ubuntu-latest - steps: - - name: checkout time repo - uses: actions/checkout@v4 - with: - path: time - - name: checkout mhs repo - # workaround for `act`: https://github.com/nektos/act/issues/678#issuecomment-1693751996 - run: git clone https://github.com/augustss/MicroHs.git --branch stable-2 mhs - - name: make and install mhs - run: | - cd mhs - make minstall - - name: compile and install time package - run: | - PATH="$HOME/.mcabal/bin:$PATH" - cd time - mcabal install - - name: run ShowDefaultTZAbbreviations test - run: | - PATH="$HOME/.mcabal/bin:$PATH" - cd time - mhs test/ShowDefaultTZAbbreviations.hs -oShowDefaultTZAbbreviations - ./ShowDefaultTZAbbreviations - - name: run ShowTime test - run: | - PATH="$HOME/.mcabal/bin:$PATH" - cd time - mhs test/ShowTime.hs -oShowTime - ./ShowTime - - name: cleanup - run: | - rm -rf $HOME/.mcabal diff --git a/.github/workflows/ci.wasm32.yml b/.github/workflows/ci.wasm32.yml deleted file mode 100644 index 4556d44c36ea45b118f2c55ba143294e0df2dce0..0000000000000000000000000000000000000000 --- a/.github/workflows/ci.wasm32.yml +++ /dev/null @@ -1,39 +0,0 @@ -name: ci-wasm32 - -on: - push: {} - pull_request: {} - workflow_dispatch: {} - -jobs: - - ci-wasm32: - name: ci-wasm32 - runs-on: ubuntu-latest - steps: - - - name: setup-wasm32-wasi-ghc - run: | - pushd $(mktemp -d) - curl -f -L --retry 5 https://gitlab.haskell.org/ghc/ghc-wasm-meta/-/archive/master/ghc-wasm-meta-master.tar.gz | tar xz --strip-components=1 - FLAVOUR=9.6 PREFIX=/tmp/.ghc-wasm ./setup.sh - /tmp/.ghc-wasm/add_to_github_path.sh - popd - - - name: checkout - uses: actions/checkout@v4 - - - name: build - run: | - sed -i '/tasty/d' time.cabal - - echo "package QuickCheck" >> cabal.project.local - echo " flags: -templatehaskell" >> cabal.project.local - - autoreconf -i - - wasm32-wasi-cabal build test:ShowDefaultTZAbbreviations - wasmtime run $(wasm32-wasi-cabal list-bin test:ShowDefaultTZAbbreviations) - - wasm32-wasi-cabal build test:ShowTime - wasmtime run $(wasm32-wasi-cabal list-bin test:ShowTime) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml new file mode 100644 index 0000000000000000000000000000000000000000..dea5f5ea92957a327cc9197c8f924385a632b8df --- /dev/null +++ b/.github/workflows/ci.yaml @@ -0,0 +1,307 @@ +name: ci +on: + push: {} + pull_request: {} + workflow_dispatch: {} + +jobs: + # Steps are intended to parallel the Dockerfile + + build-native: + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + ghc: + - "9.12" + - "9.10" + - "9.8" + steps: + - name: "Install ghcup & cabal" + run: | + cd $HOME + export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 + export BOOTSTRAP_HASKELL_MINIMAL=1 + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install cabal --set latest + cabal update + + - name: "Install GHC native" + run: | + cd $HOME + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install ghc ${{matrix.ghc}} + sudo apt-get install -y libgmp-dev + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build native" + run: | + export PATH=$HOME/.ghcup/bin:$PATH + export PATH=`pwd`/bin:$PATH + build-native ${{matrix.ghc}} + + build-native-expired: + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + ghc: + - "9.6" + - "9.4" + steps: + - name: "Install ghcup & cabal" + run: | + cd $HOME + export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 + export BOOTSTRAP_HASKELL_MINIMAL=1 + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install cabal --set latest + cabal update + + - name: "Install GHC native" + run: | + cd $HOME + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install ghc ${{matrix.ghc}} + sudo apt-get install -y libgmp-dev + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build native expired" + run: | + export PATH=$HOME/.ghcup/bin:$PATH + export PATH=`pwd`/bin:$PATH + build-native-expired ${{matrix.ghc}} + + build-js: + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + ghc: + - "9.12" + - "9.10" + steps: + - name: "Install ghcup & cabal" + run: | + cd $HOME + export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 + export BOOTSTRAP_HASKELL_MINIMAL=1 + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install cabal --set latest + cabal update + + - name: "Install GHC js" + run: | + cd $HOME + export PATH=$HOME/.ghcup/bin:$PATH + sudo apt-get update + sudo apt-get install -y nodejs + ghcup config add-release-channel cross + git clone https://github.com/emscripten-core/emsdk.git + cd emsdk + sudo apt-get install -y python3 + case ${{matrix.ghc}} in + 9.12) + export EMSDK_VERSION=3.1.74 + ;; + 9.10) + export EMSDK_VERSION=3.1.57 + ;; + esac + ./emsdk install $EMSDK_VERSION + ./emsdk activate $EMSDK_VERSION + . ./emsdk_env.sh + emconfigure ghcup install ghc javascript-unknown-ghcjs-${{matrix.ghc}} + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build js" + run: | + export PATH=$HOME/.ghcup/bin:$PATH + export PATH=`pwd`/bin:$PATH + build-js javascript-unknown-ghcjs-${{matrix.ghc}} + + build-wasm32: + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + ghc: + - "9.12" + - "9.10" + - "9.8" + steps: + - name: "Install ghcup & cabal" + run: | + cd $HOME + export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 + export BOOTSTRAP_HASKELL_MINIMAL=1 + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install cabal --set latest + cabal update + + - name: "Install GHC wasm32" + run: | + cd $HOME + export PATH=$HOME/.ghcup/bin:$PATH + sudo apt-get install -y zstd + curl https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/bootstrap.sh | SKIP_GHC=1 sh + ghcup config add-release-channel https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/ghcup-wasm-0.0.9.yaml + . $HOME/.ghc-wasm/env && ghcup install ghc wasm32-wasi-${{matrix.ghc}} -- $CONFIGURE_ARGS + curl -LO https://github.com/bytecodealliance/wasmtime/releases/download/dev/wasmtime-dev-x86_64-linux.tar.xz + xz -d wasmtime-dev-x86_64-linux.tar.xz + tar xvf wasmtime-dev-x86_64-linux.tar + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build wasm32" + run: | + export PATH=$HOME/.ghcup/bin:$PATH + export PATH=$HOME/wasmtime-dev-x86_64-linux:$PATH + export PATH=`pwd`/bin:$PATH + build-wasm32 wasm32-wasi-${{matrix.ghc}} + + build-mhs: + runs-on: ubuntu-latest + steps: + - name: "Install MicroHs" + run: | + cd $HOME + git clone https://github.com/augustss/MicroHs.git --branch stable-7 mhs + cd mhs + make minstall + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build MicroHs" + run: | + export PATH=$HOME/.mcabal/bin:$PATH + export PATH=`pwd`/bin:$PATH + build-mhs + + build-windows: + runs-on: windows-latest + defaults: + run: + shell: msys2 {0} + strategy: + fail-fast: false + matrix: + ghc: + - "9.12" + - "9.10" + - "9.8" + steps: + - name: "Install GHC & cabal" + uses: haskell-actions/setup@v2 + id: setup-haskell-cabal + with: + ghc-version: ${{matrix.ghc}} + + - name: "Cache cabal stuff" + uses: actions/cache@v4 + with: + path: | + ${{steps.setup-haskell-cabal.outputs.cabal-store}} + dist-newstyle + key: ${{runner.os}}-${{matrix.ghc}} + + - name: "MSYS2" + uses: msys2/setup-msys2@v2 + with: + msystem: MINGW64 + update: true + path-type: inherit + install: autoconf + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build" + run: | + cabal update + autoreconf -i + cabal test --ghc-options='-Werror' + + - name: "Haddock" + run: cabal v1-haddock + + build-macos: + runs-on: macOS-latest + strategy: + fail-fast: false + matrix: + ghc: + - "9.12" + - "9.10" + - "9.8" + steps: + - name: "Install autoconf" + run: | + brew install autoconf + + - name: "Install GHC & cabal" + uses: haskell-actions/setup@v2 + id: setup-haskell-cabal + with: + ghc-version: ${{matrix.ghc}} + + - name: "Cache cabal stuff" + uses: actions/cache@v4 + with: + path: | + ${{steps.setup-haskell-cabal.outputs.cabal-store}} + dist-newstyle + key: ${{runner.os}}-${{matrix.ghc}} + + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build" + run: | + cabal update + autoreconf -i + cabal test --ghc-options='-Werror' + + build-freebsd: + # See https://github.com/marketplace/actions/freebsd-vm. + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + ghc: + - "9.12" + steps: + - name: "Checkout" + uses: actions/checkout@v4 + + - name: "Build" + id: build-freebsd + uses: vmactions/freebsd-vm@v1 + with: + usesh: true + mem: 4096 + prepare: | + pkg install -y bash curl gcc gmp gmake ncurses perl5 libffi libiconv git autoconf + export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 + export BOOTSTRAP_HASKELL_MINIMAL=1 + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + export PATH=$HOME/.ghcup/bin:$PATH + ghcup install cabal --set latest + cabal update + ghcup install ghc ${{matrix.ghc}} + run: | + export PATH=$HOME/.ghcup/bin:$PATH + export PATH=`pwd`/bin:$PATH + build-native ${{matrix.ghc}} diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml deleted file mode 100644 index df178c552735307c532affb2a98f0bd396384e75..0000000000000000000000000000000000000000 --- a/.github/workflows/ci.yml +++ /dev/null @@ -1,97 +0,0 @@ -name: ci -on: - push: {} - pull_request: {} - workflow_dispatch: {} - -jobs: - build: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - os: [ubuntu-latest, macOS-latest] - ghc: ['9.8.2', '9.6.4', '9.4.8'] - steps: - - uses: actions/checkout@v4 - - name: "MacOS: install autoconf" - if: runner.os == 'macOS' - run: | - brew install autoconf - - uses: haskell-actions/setup@v2 - id: setup-haskell-cabal - with: - ghc-version: ${{ matrix.ghc }} - - uses: actions/cache@v4 - name: Cache cabal stuff - with: - path: | - ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - dist-newstyle - key: ${{ runner.os }}-${{ matrix.ghc }} - - name: Build - run: | - autoreconf -i - cabal update - cabal v1-install --only-dependencies --enable-tests - cabal v1-configure --enable-tests - cabal v1-test - - name: Haddock - run: cabal v1-haddock - - build-win: - runs-on: windows-latest - defaults: - run: - shell: msys2 {0} - strategy: - fail-fast: false - matrix: - ghc: ['9.8.2', '9.6.4', '9.4.8'] - steps: - - uses: actions/checkout@v4 - - uses: haskell-actions/setup@v2 - id: setup-haskell-cabal - with: - ghc-version: ${{ matrix.ghc }} - - uses: actions/cache@v4 - name: Cache cabal stuff - with: - path: | - ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - dist-newstyle - key: ${{ runner.os }}-${{ matrix.ghc }} - - uses: msys2/setup-msys2@v2 - with: - msystem: MINGW64 - update: true - path-type: inherit - install: autoconf - - name: Build - run: | - autoreconf -i - cabal update - cabal v1-install --only-dependencies --enable-tests - cabal v1-configure --enable-tests - cabal v1-test - - name: Haddock - run: cabal v1-haddock - - build-freebsd: - # See https://github.com/marketplace/actions/freebsd-vm. - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v4 - - name: Build - id: build-freebsd - uses: vmactions/freebsd-vm@v1 - with: - usesh: true - mem: 4096 - prepare: pkg install -y ghc hs-cabal-install git autoconf - run: | - autoreconf -i - cabal update - cabal v1-install --only-dependencies --enable-tests - cabal v1-configure --enable-tests - cabal v1-test diff --git a/.gitignore b/.gitignore index a881fa95f915b85f9ed8e5bbbf9f7799e116ac3a..2cf211ce3d9e1d13b9af5d62262ceaf55a5c4b06 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,8 @@ configure dist/ dist-newstyle/ dist-install +dist-mcabal +*.pkg ghc.mk lib/include/HsTimeConfig.h lib/include/HsTimeConfig.h.in diff --git a/Checklist b/Checklist index 6b128a77fb85b77f01d8d997c3b25e1b573de097..95024e271de3af1d52ff489ef6395e688845dcfd 100644 --- a/Checklist +++ b/Checklist @@ -42,11 +42,11 @@ Before release: 8. Format source - ./format-all -b + just format 9. Build & test - ./fullcheck + just fullbuild 10. Run benchmarks @@ -70,12 +70,12 @@ Before release: 13b. Build and test on 32-bit Linux machine git switch master - ./fullcheck + just fullbuild 13c. Build and test on FreeBSD machine git switch master - ./fullcheck + just fullbuild 13d. Build and test on Windows diff --git a/bin/build-all b/bin/build-all new file mode 100755 index 0000000000000000000000000000000000000000..b4c5bc7127df69f5ba1660c803f2ad636a136e1b --- /dev/null +++ b/bin/build-all @@ -0,0 +1,25 @@ +#!/usr/bin/env -S bash -e +git clean -dXf +cabal update + +for V in $GHC_NATIVE_VERSIONS +do +build-native $V +done + +for V in $GHC_NATIVE_EXPIRED_VERSIONS +do +build-native-expired $V +done + +for V in $GHC_WASM32_VERSIONS +do +build-wasm32 $V +done + +for V in $GHC_JS_VERSIONS +do +build-js $V +done + +build-mhs diff --git a/bin/build-js b/bin/build-js new file mode 100755 index 0000000000000000000000000000000000000000..a70e89c9c94d6f1edc6b86150cbecfc0f5888898 --- /dev/null +++ b/bin/build-js @@ -0,0 +1,9 @@ +#!/usr/bin/env -S bash -e +ghcup set ghc $1 +autoreconf -i +cabal \ + --with-compiler=javascript-unknown-ghcjs-ghc \ + --with-hc-pkg=javascript-unknown-ghcjs-ghc-pkg \ + --with-hsc2hs=javascript-unknown-ghcjs-hsc2hs \ + test \ + --ghc-options='-Werror' diff --git a/bin/build-mhs b/bin/build-mhs new file mode 100755 index 0000000000000000000000000000000000000000..41cea752520c900981b550cdb973a56a7c24be3e --- /dev/null +++ b/bin/build-mhs @@ -0,0 +1,10 @@ +#!/usr/bin/env -S bash -e +autoreconf -i +mcabal install +mkdir -p dist-mcabal/bin +mhs test/ForeignCalls.hs -odist-mcabal/bin/ForeignCalls +dist-mcabal/bin/ForeignCalls +mhs test/ShowDefaultTZAbbreviations.hs -odist-mcabal/bin/ShowDefaultTZAbbreviations +dist-mcabal/bin/ShowDefaultTZAbbreviations +mhs test/ShowTime.hs -odist-mcabal/bin/ShowTime +dist-mcabal/bin/ShowTime diff --git a/bin/build-native b/bin/build-native new file mode 100755 index 0000000000000000000000000000000000000000..1516f203d2eabad49108784f56b1e1bc81722ae0 --- /dev/null +++ b/bin/build-native @@ -0,0 +1,4 @@ +#!/usr/bin/env -S bash -e +ghcup set ghc $1 +autoreconf -i +cabal test --ghc-options='-Werror' diff --git a/bin/build-native-expired b/bin/build-native-expired new file mode 100755 index 0000000000000000000000000000000000000000..ea5f023be271d8e7bbc750e2676623002a9bde45 --- /dev/null +++ b/bin/build-native-expired @@ -0,0 +1,10 @@ +#!/usr/bin/env -S bash -e +ghcup set ghc $1 +autoreconf -i +if cabal v1-configure --enable-tests; +then + echo "time incorrectly selected with unsupported GHC version $1" + exit 1 +else + echo "time correctly deselected with unsupported GHC version $1" +fi diff --git a/bin/build-wasm32 b/bin/build-wasm32 new file mode 100755 index 0000000000000000000000000000000000000000..b2632b33cc75f0a6bf7275a20ba6a077bd021044 --- /dev/null +++ b/bin/build-wasm32 @@ -0,0 +1,11 @@ +#!/usr/bin/env -S bash -e +ghcup set ghc $1 +autoreconf -i +source $HOME/.ghc-wasm/env +cabal \ + --with-compiler=wasm32-wasi-ghc \ + --with-hc-pkg=wasm32-wasi-ghc-pkg \ + --with-hsc2hs=wasm32-wasi-hsc2hs \ + --test-wrapper=wasmtime \ + test \ + --ghc-options='-Werror' diff --git a/bin/format b/bin/format new file mode 100755 index 0000000000000000000000000000000000000000..8bc8a8ac25ba8c1cf8a3119fc0bcd36e73157b18 --- /dev/null +++ b/bin/format @@ -0,0 +1,3 @@ +#!/usr/bin/env -S bash -e +fourmolu -i -o -XPatternSynonyms \ + `find -name '*.hs' -not -path '*.stack-work/*' -not -path '*/dist/*' -not -path '*/dist-newstyle/*' | grep -xvf .format.ignore` diff --git a/build b/build deleted file mode 100755 index 1b30580bf5bd66aa67f4f76be2c35c6fab056f79..0000000000000000000000000000000000000000 --- a/build +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash -e -autoreconf -i -PATH=$HOME/.ghcup/bin:$PATH -ghcup upgrade -ghcup install cabal latest -ghcup set cabal latest -ghcup install ghc latest -ghcup set ghc latest -cabal update -cabal v1-install --only-dependencies --enable-tests -cabal v1-configure --enable-tests -cabal v1-test -cabal v1-haddock diff --git a/changelog.md b/changelog.md index 7ea431bb8a5a772c085d518901254ac6ff8d019f..ed7fb809718f1051c27cda2dad1e9bec0a8ac922 100644 --- a/changelog.md +++ b/changelog.md @@ -2,9 +2,13 @@ ## Unreleased -- support MicroHs +- support GHC backends (with CI): + - JavaScript + - WebAssembly + - MicroHs - add instance ParseTime DayOfWeek - make use of %s specifiers in parsing various types +- add Lift instances to all types (really this time) ## [1.14] - 2024-03-10 - add Lift instances to all types diff --git a/format-all b/format-all deleted file mode 100755 index 6cc52772967dee9e4353c97916b310cffc2b8298..0000000000000000000000000000000000000000 --- a/format-all +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/bash -e -if [ "$1" == "-b" ] -then stack --stack-yaml stack.tools.yaml install --no-test --no-bench --no-haddock fourmolu -fi - -INSTALL=`stack --stack-yaml stack.tools.yaml path --local-bin` -for f in `find -name '*.hs' -not -path '*.stack-work/*' -not -path '*/dist/*' | grep -xvf .format.ignore` -do $INSTALL/fourmolu -i -o -XPatternSynonyms $f || exit -done diff --git a/fullcheck b/fullcheck deleted file mode 100755 index 855fe43152ecfbbae100c7c8c72efcf7c1d5fa0e..0000000000000000000000000000000000000000 --- a/fullcheck +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/bash -e -git clean -dXf -git pull -autoreconf -i -PATH=$HOME/.ghcup/bin:$PATH -ghcup upgrade -ghcup install cabal latest -ghcup set cabal latest - -# check unsupported versions do not select this version of time -for c in 8.10.7 9.2.8 -do -ghcup install ghc $c -ghcup set ghc $c -cabal update -if cabal v1-configure --enable-tests; -then - echo "time incorrectly selected with unsupported GHC version $c" - exit 1 -else - echo "time correctly deselected with unsupported GHC version $c" -fi -done - -# check supported versions -for c in 9.4.8 9.6.4 9.8.2 -do -ghcup install ghc $c -ghcup set ghc $c -cabal update -cabal v1-install --only-dependencies --enable-tests -cabal v1-configure --enable-tests -cabal v1-test -cabal v1-haddock -done -echo OK diff --git a/fullcheck.ps1 b/fullcheck.ps1 index 4dfe76810fee83af1aabb5f9f920238b36909d29..723017cf635f802ea82023c7613c61566d80d157 100644 --- a/fullcheck.ps1 +++ b/fullcheck.ps1 @@ -11,7 +11,7 @@ if (!$?) {Exit 1} if (!$?) {Exit 1} & "ghcup" "set" "cabal" "latest" if (!$?) {Exit 1} -ForEach ($c in "9.4.8","9.6.4","9.8.2") +ForEach ($c in "9.8.4","9.10.1","9.12.2") { & "ghcup" "install" "ghc" "$c" if (!$?) {Exit 1} diff --git a/justfile b/justfile new file mode 100644 index 0000000000000000000000000000000000000000..0fae4c07db2512e5f1dc04ae5ddfcb991dbb4340 --- /dev/null +++ b/justfile @@ -0,0 +1,23 @@ +default: build + +container-build: + devcontainer build --workspace-folder . + +container-up: + devcontainer up --workspace-folder . + +shell: container-up + devcontainer exec --workspace-folder . bash + +format: container-up + devcontainer exec --workspace-folder . format + +build: container-up + devcontainer exec --workspace-folder . build-all + +fullbuild: container-build format build + +# to run this, your (classic) token must have "repo" and "read:packages" +# to upload the container, it must have "write:packages" and you should be a member of the Haskell org. +act: + act -s GITHUB_TOKEN="$(gh auth token)" -j build-new diff --git a/lib/Data/Time/Calendar/CalendarDiffDays.hs b/lib/Data/Time/Calendar/CalendarDiffDays.hs index 3740be03cf481ae3370fd9d730ddab388c4f0481..f03159ef5838a42db67d9dbf486013e447bc3769 100644 --- a/lib/Data/Time/Calendar/CalendarDiffDays.hs +++ b/lib/Data/Time/Calendar/CalendarDiffDays.hs @@ -14,17 +14,7 @@ data CalendarDiffDays = CalendarDiffDays { cdMonths :: Integer , cdDays :: Integer } - deriving - ( Eq - , -- | @since 1.9.2 - Data - , -- | @since 1.9.2 - Typeable - , -- | @since 1.14 - TH.Lift - , -- | @since 1.14 - Generic - ) + deriving (Eq, Typeable, Data, Generic, TH.Lift) instance NFData CalendarDiffDays where rnf (CalendarDiffDays m d) = rnf m `seq` rnf d `seq` () diff --git a/lib/Data/Time/Calendar/Days.hs b/lib/Data/Time/Calendar/Days.hs index 8a2c1511e3a142cf3257aeb6f6d8bd7582f638d2..8f0965871845c29621290167cfdac5429d2971b4 100644 --- a/lib/Data/Time/Calendar/Days.hs +++ b/lib/Data/Time/Calendar/Days.hs @@ -25,7 +25,7 @@ import qualified Language.Haskell.TH.Syntax as TH newtype Day = ModifiedJulianDay { toModifiedJulianDay :: Integer } - deriving (Eq, Ord, Data, Typeable, TH.Lift, Generic) + deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData Day where rnf (ModifiedJulianDay a) = rnf a diff --git a/lib/Data/Time/Calendar/Gregorian.hs b/lib/Data/Time/Calendar/Gregorian.hs index fd10f5c77d2af5f38440523afdc6c9542606ce59..be5a8481047c5d84bf784187038c2fb9fa2e3363 100644 --- a/lib/Data/Time/Calendar/Gregorian.hs +++ b/lib/Data/Time/Calendar/Gregorian.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -7,12 +6,9 @@ module Data.Time.Calendar.Gregorian ( -- * Year, month and day Year, -#ifdef __GLASGOW_HASKELL__ pattern CommonEra, pattern BeforeCommonEra, -#endif MonthOfYear, -#ifdef __GLASGOW_HASKELL__ pattern January, pattern February, pattern March, @@ -25,15 +21,12 @@ module Data.Time.Calendar.Gregorian ( pattern October, pattern November, pattern December, -#endif DayOfMonth, -- * Gregorian calendar toGregorian, fromGregorian, -#ifdef __GLASGOW_HASKELL__ pattern YearMonthDay, -#endif fromGregorianValid, showGregorian, gregorianMonthLength, @@ -70,7 +63,6 @@ toGregorian date = (year, month, day) fromGregorian :: Year -> MonthOfYear -> DayOfMonth -> Day fromGregorian year month day = fromOrdinalDate year (monthAndDayToDayOfYear (isLeapYear year) month day) -#if __GLASGOW_HASKELL__ -- | Bidirectional abstract constructor for the proleptic Gregorian calendar. -- Invalid values will be clipped to the correct range, month first, then day. pattern YearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day @@ -78,7 +70,6 @@ pattern YearMonthDay y m d <- (toGregorian -> (y, m, d)) where YearMonthDay y m d = fromGregorian y m d -#endif {-# COMPLETE YearMonthDay #-} @@ -193,10 +184,8 @@ diffGregorianDurationRollOver day2 day1 = instance Show Day where show = showGregorian -#ifdef __GLASGOW_HASKELL__ -- orphan instance instance DayPeriod Year where periodFirstDay y = YearMonthDay y January 1 periodLastDay y = YearMonthDay y December 31 dayPeriod (YearMonthDay y _ _) = y -#endif diff --git a/lib/Data/Time/Calendar/Julian.hs b/lib/Data/Time/Calendar/Julian.hs index b60a63e8708cbb4b7ce66e83b40594bc002b911c..861c4b9e210ade9764082d8c3c3f84709d13f4aa 100644 --- a/lib/Data/Time/Calendar/Julian.hs +++ b/lib/Data/Time/Calendar/Julian.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.Time.Calendar.Julian ( Year, MonthOfYear, -#ifdef __GLASGOW_HASKELL__ pattern January, pattern February, pattern March, @@ -17,15 +15,12 @@ module Data.Time.Calendar.Julian ( pattern October, pattern November, pattern December, -#endif DayOfMonth, DayOfYear, module Data.Time.Calendar.JulianYearDay, toJulian, fromJulian, -#ifdef __GLASGOW_HASKELL__ pattern JulianYearMonthDay, -#endif fromJulianValid, showJulian, julianMonthLength, @@ -60,7 +55,6 @@ toJulian date = (year, month, day) fromJulian :: Year -> MonthOfYear -> DayOfMonth -> Day fromJulian year month day = fromJulianYearAndDay year (monthAndDayToDayOfYear (isJulianLeapYear year) month day) -#ifdef __GLASGOW_HASKELL__ -- | Bidirectional abstract constructor for the proleptic Julian calendar. -- Invalid values will be clipped to the correct range, month first, then day. pattern JulianYearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day @@ -70,7 +64,6 @@ pattern JulianYearMonthDay y m d <- JulianYearMonthDay y m d = fromJulian y m d {-# COMPLETE JulianYearMonthDay #-} -#endif -- | Convert from proleptic Julian calendar. -- Invalid values will return Nothing. diff --git a/lib/Data/Time/Calendar/Month.hs b/lib/Data/Time/Calendar/Month.hs index 6fa3563ca5b389a407d6a69fc34d165c7e5ab4c7..8b3559916f22c82894fed7745ab8c7f441781c1a 100644 --- a/lib/Data/Time/Calendar/Month.hs +++ b/lib/Data/Time/Calendar/Month.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | An absolute count of common calendar months. @@ -6,12 +5,10 @@ module Data.Time.Calendar.Month ( Month (..), addMonths, diffMonths, -#if __GLASGOW_HASKELL__ pattern YearMonth, fromYearMonthValid, pattern MonthDay, fromMonthDayValid, -#endif ) where import Control.DeepSeq @@ -28,7 +25,7 @@ import Text.Read -- | An absolute count of common calendar months. -- Number is equal to @(year * 12) + (monthOfYear - 1)@. -newtype Month = MkMonth Integer deriving (Eq, Ord, Data, Typeable, TH.Lift, Generic) +newtype Month = MkMonth Integer deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData Month where rnf (MkMonth m) = rnf m @@ -50,7 +47,6 @@ instance Ix Month where inRange (MkMonth a, MkMonth b) (MkMonth c) = inRange (a, b) c rangeSize (MkMonth a, MkMonth b) = rangeSize (a, b) -#ifdef __GLASGOW_HASKELL__ -- | Show as @yyyy-mm@. instance Show Month where show (YearMonth y m) = show4 y ++ "-" ++ show2 m @@ -67,7 +63,6 @@ instance DayPeriod Month where periodFirstDay (YearMonth y m) = YearMonthDay y m 1 periodLastDay (YearMonth y m) = YearMonthDay y m 31 -- clips to correct day dayPeriod (YearMonthDay y my _) = YearMonth y my -#endif addMonths :: Integer -> Month -> Month addMonths n (MkMonth a) = MkMonth $ a + n @@ -75,12 +70,11 @@ addMonths n (MkMonth a) = MkMonth $ a + n diffMonths :: Month -> Month -> Integer diffMonths (MkMonth a) (MkMonth b) = a - b -#ifdef __GLASGOW_HASKELL__ -- | Bidirectional abstract constructor. -- Invalid months of year will be clipped to the correct range. pattern YearMonth :: Year -> MonthOfYear -> Month pattern YearMonth y my <- - MkMonth ((\m -> divMod' m 12) -> (y, succ . fromInteger -> my)) + MkMonth ((\m -> divMod' m 12) -> (y, (succ . fromInteger -> my))) where YearMonth y my = MkMonth $ (y * 12) + toInteger (pred $ clip 1 12 my) @@ -103,4 +97,3 @@ fromMonthDayValid :: Month -> DayOfMonth -> Maybe Day fromMonthDayValid = periodToDayValid {-# COMPLETE MonthDay #-} -#endif diff --git a/lib/Data/Time/Calendar/MonthDay.hs b/lib/Data/Time/Calendar/MonthDay.hs index 02ba0d34fa19142ad0f23d18b4f763042d99516a..8bd23c6b9d1e13d0bcc062bd43bcb8298f47be73 100644 --- a/lib/Data/Time/Calendar/MonthDay.hs +++ b/lib/Data/Time/Calendar/MonthDay.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.Time.Calendar.MonthDay ( MonthOfYear, -#ifdef __GLASGOW_HASKELL__ pattern January, pattern February, pattern March, @@ -16,7 +14,6 @@ module Data.Time.Calendar.MonthDay ( pattern October, pattern November, pattern December, -#endif DayOfMonth, DayOfYear, monthAndDayToDayOfYear, diff --git a/lib/Data/Time/Calendar/OrdinalDate.hs b/lib/Data/Time/Calendar/OrdinalDate.hs index c4743253e283c6b087a17bda49ac2da23ffae97c..31cb9ad65d3c76b4432cd77100ef4e4758d23717 100644 --- a/lib/Data/Time/Calendar/OrdinalDate.hs +++ b/lib/Data/Time/Calendar/OrdinalDate.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | ISO 8601 Ordinal Date format @@ -46,7 +45,6 @@ fromOrdinalDate year day = ModifiedJulianDay mjd + (div y 400) - 678576 -#ifdef __GLASGOW_HASKELL__ -- | Bidirectional abstract constructor for ISO 8601 Ordinal Date format. -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). pattern YearDay :: Year -> DayOfYear -> Day @@ -56,7 +54,6 @@ pattern YearDay y d <- YearDay y d = fromOrdinalDate y d {-# COMPLETE YearDay #-} -#endif -- | Convert from ISO 8601 Ordinal Date format. -- Invalid day numbers return 'Nothing' diff --git a/lib/Data/Time/Calendar/Quarter.hs b/lib/Data/Time/Calendar/Quarter.hs index 52d835197fa1e0605f664f73e9d121b1ad06dfb3..c25217abd42192995462f1e39cb064ca98a3e9b6 100644 --- a/lib/Data/Time/Calendar/Quarter.hs +++ b/lib/Data/Time/Calendar/Quarter.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | Year quarters. @@ -7,18 +6,12 @@ module Data.Time.Calendar.Quarter ( addQuarters, diffQuarters, Quarter (..), -#ifdef __GLASGOW_HASKELL__ pattern YearQuarter, -#endif monthOfYearQuarter, -#ifdef __GLASGOW_HASKELL__ monthQuarter, dayQuarter, -#endif DayOfQuarter, -#ifdef __GLASGOW_HASKELL__ pattern QuarterDay, -#endif ) where import Control.DeepSeq @@ -35,7 +28,7 @@ import Text.ParserCombinators.ReadP import Text.Read -- | Quarters of each year. Each quarter corresponds to three months. -data QuarterOfYear = Q1 | Q2 | Q3 | Q4 deriving (Eq, Ord, Data, Typeable, Read, Show, Ix, TH.Lift, Generic) +data QuarterOfYear = Q1 | Q2 | Q3 | Q4 deriving (Eq, Ord, Read, Show, Ix, Typeable, Data, Generic, TH.Lift) -- | maps Q1..Q4 to 1..4 instance Enum QuarterOfYear where @@ -62,7 +55,7 @@ instance NFData QuarterOfYear where -- | An absolute count of year quarters. -- Number is equal to @(year * 4) + (quarterOfYear - 1)@. -newtype Quarter = MkQuarter Integer deriving (Eq, Ord, Data, Typeable, Generic) +newtype Quarter = MkQuarter Integer deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData Quarter where rnf (MkQuarter m) = rnf m @@ -84,7 +77,6 @@ instance Ix Quarter where inRange (MkQuarter a, MkQuarter b) (MkQuarter c) = inRange (a, b) c rangeSize (MkQuarter a, MkQuarter b) = rangeSize (a, b) -#ifdef __GLASGOW_HASKELL__ -- | Show as @yyyy-Qn@. instance Show Quarter where show (YearQuarter y qy) = show4 y ++ "-" ++ show qy @@ -111,7 +103,6 @@ instance DayPeriod Quarter where Q3 -> periodLastDay $ YearMonth y September Q4 -> periodLastDay $ YearMonth y December dayPeriod (MonthDay m _) = monthQuarter m -#endif addQuarters :: Integer -> Quarter -> Quarter addQuarters n (MkQuarter a) = MkQuarter $ a + n @@ -119,16 +110,14 @@ addQuarters n (MkQuarter a) = MkQuarter $ a + n diffQuarters :: Quarter -> Quarter -> Integer diffQuarters (MkQuarter a) (MkQuarter b) = a - b -#ifdef __GLASGOW_HASKELL__ -- | Bidirectional abstract constructor. pattern YearQuarter :: Year -> QuarterOfYear -> Quarter pattern YearQuarter y qy <- - MkQuarter ((\q -> divMod' q 4) -> (y, toEnum . succ . fromInteger -> qy)) + MkQuarter ((\q -> divMod' q 4) -> (y, (toEnum . succ . fromInteger -> qy))) where YearQuarter y qy = MkQuarter $ (y * 4) + toInteger (pred $ fromEnum qy) {-# COMPLETE YearQuarter #-} -#endif -- | The 'QuarterOfYear' this 'MonthOfYear' is in. monthOfYearQuarter :: MonthOfYear -> QuarterOfYear @@ -137,7 +126,6 @@ monthOfYearQuarter my | my <= 6 = Q2 monthOfYearQuarter my | my <= 9 = Q3 monthOfYearQuarter _ = Q4 -#ifdef __GLASGOW_HASKELL__ -- | The 'Quarter' this 'Month' is in. monthQuarter :: Month -> Quarter monthQuarter (YearMonth y my) = YearQuarter y $ monthOfYearQuarter my @@ -157,4 +145,3 @@ pattern QuarterDay q dq <- QuarterDay = periodToDay {-# COMPLETE QuarterDay #-} -#endif diff --git a/lib/Data/Time/Calendar/Types.hs b/lib/Data/Time/Calendar/Types.hs index c5de90d7eafbd0c13a39cf262cf7dabdea50cad3..515e437ecde6949f4d730c8040d5d7e8ac014928 100644 --- a/lib/Data/Time/Calendar/Types.hs +++ b/lib/Data/Time/Calendar/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.Time.Calendar.Types where @@ -6,7 +5,6 @@ module Data.Time.Calendar.Types where -- | Year of Common Era (when positive). type Year = Integer -#ifdef __GLASGOW_HASKELL__ -- | Also known as Anno Domini. pattern CommonEra :: Integer -> Year pattern CommonEra n <- @@ -24,12 +22,10 @@ pattern BeforeCommonEra n <- BeforeCommonEra n = 1 - n {-# COMPLETE CommonEra, BeforeCommonEra #-} -#endif -- | Month of year, in range 1 (January) to 12 (December). type MonthOfYear = Int -#ifdef __GLASGOW_HASKELL__ pattern January :: MonthOfYear pattern January = 1 @@ -68,7 +64,6 @@ pattern December :: MonthOfYear pattern December = 12 {-# COMPLETE January, February, March, April, May, June, July, August, September, October, November, December #-} -#endif -- | Day of month, in range 1 to 31. type DayOfMonth = Int diff --git a/lib/Data/Time/Calendar/Week.hs b/lib/Data/Time/Calendar/Week.hs index 4a1743049a821a9ad0e8bd930ca7fec4bddc2701..ef3b4f549855dc9525f59e427f669af85ce3d4f5 100644 --- a/lib/Data/Time/Calendar/Week.hs +++ b/lib/Data/Time/Calendar/Week.hs @@ -27,7 +27,7 @@ data DayOfWeek | Friday | Saturday | Sunday - deriving (Eq, Show, Read, Data, Typeable, Ord, Ix, TH.Lift, Generic) + deriving (Eq, Ord, Ix, Show, Read, Typeable, Data, Generic, TH.Lift) instance NFData DayOfWeek where rnf Monday = () diff --git a/lib/Data/Time/Calendar/WeekDate.hs b/lib/Data/Time/Calendar/WeekDate.hs index d464e4270010837dfaa420c44dc03f834c168fea..f69d27b258e50f76696e1631844e069f9b44685e 100644 --- a/lib/Data/Time/Calendar/WeekDate.hs +++ b/lib/Data/Time/Calendar/WeekDate.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | Week-based calendars @@ -15,9 +14,7 @@ module Data.Time.Calendar.WeekDate ( -- * ISO 8601 Week Date format toWeekDate, fromWeekDate, -#ifdef __GLASGOW_HASKELL__ pattern YearWeekDay, -#endif fromWeekDateValid, showWeekDate, ) where @@ -26,20 +23,14 @@ import Data.Time.Calendar.Days import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Private import Data.Time.Calendar.Week -#ifdef __GLASGOW_HASKELL__ import qualified Language.Haskell.TH.Syntax as TH -#endif data FirstWeekType = -- | first week is the first whole week of the year FirstWholeWeek | -- | first week is the first week with four days in the year FirstMostWeek - deriving (Eq -#ifdef __GLASGOW_HASKELL__ - , TH.Lift -#endif - ) + deriving (Eq, TH.Lift) firstDayOfWeekCalendar :: FirstWeekType -> DayOfWeek -> Year -> Day firstDayOfWeekCalendar wt dow year = @@ -129,17 +120,15 @@ toWeekDate d = fromWeekDate :: Year -> WeekOfYear -> Int -> Day fromWeekDate y wy dw = fromWeekCalendar FirstMostWeek Monday y wy (toEnum $ clip 1 7 dw) -#ifdef __GLASGOW_HASKELL__ -- | Bidirectional abstract constructor for ISO 8601 Week Date format. -- Invalid week values will be clipped to the correct range. pattern YearWeekDay :: Year -> WeekOfYear -> DayOfWeek -> Day pattern YearWeekDay y wy dw <- - (toWeekDate -> (y, wy, toEnum -> dw)) + (toWeekDate -> (y, wy, (toEnum -> dw))) where YearWeekDay y wy dw = fromWeekDate y wy (fromEnum dw) {-# COMPLETE YearWeekDay #-} -#endif -- | Convert from ISO 8601 Week Date format. First argument is year, second week number (1-52 or 53), third day of week (1 for Monday to 7 for Sunday). -- Invalid week and day values will return Nothing. diff --git a/lib/Data/Time/Clock/Internal/AbsoluteTime.hs b/lib/Data/Time/Clock/Internal/AbsoluteTime.hs index 4d1158d6d10a1901e2ce43470c72526d334ea221..040cf12467df184a179b06ec8c6056ef65c2efe2 100644 --- a/lib/Data/Time/Clock/Internal/AbsoluteTime.hs +++ b/lib/Data/Time/Clock/Internal/AbsoluteTime.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | TAI and leap-second maps for converting to UTC: most people won't need this module. @@ -15,18 +14,12 @@ import Control.DeepSeq import Data.Data import Data.Time.Calendar.Days import Data.Time.Clock.Internal.DiffTime -#ifdef __GLASGOW_HASKELL__ import qualified Language.Haskell.TH.Syntax as TH -#endif -- | AbsoluteTime is TAI, time as measured by a clock. newtype AbsoluteTime = MkAbsoluteTime DiffTime - deriving (Eq, Ord, Data, Typeable -#ifdef __GLASGOW_HASKELL__ - , TH.Lift -#endif - ) + deriving (Eq, Ord, Typeable, Data, TH.Lift) instance NFData AbsoluteTime where rnf (MkAbsoluteTime a) = rnf a diff --git a/lib/Data/Time/Clock/Internal/CTimespec.hsc b/lib/Data/Time/Clock/Internal/CTimespec.hsc index 27054f31013dfac5c99ddf1f3ecceee759ba1c80..feaca786a108194075045166b8f21ce13bbc970e 100644 --- a/lib/Data/Time/Clock/Internal/CTimespec.hsc +++ b/lib/Data/Time/Clock/Internal/CTimespec.hsc @@ -34,18 +34,31 @@ instance Storable CTimespec where foreign import ccall unsafe "time.h clock_gettime" clock_gettime :: ClockID -> Ptr CTimespec -> IO CInt -foreign import ccall unsafe "time.h clock_getres" - clock_getres :: ClockID -> Ptr CTimespec -> IO CInt #else /* defined(javascript_HOST_ARCH) */ foreign import capi unsafe "time.h clock_gettime" clock_gettime :: ClockID -> Ptr CTimespec -> IO CInt -foreign import capi unsafe "time.h clock_getres" - clock_getres :: ClockID -> Ptr CTimespec -> IO CInt #endif /* defined(javascript_HOST_ARCH) */ +-- | Get the current time from the given clock. +clockGetTime :: ClockID -> IO CTimespec +clockGetTime clockid = alloca (\ptspec -> do + throwErrnoIfMinus1_ "clock_gettime" $ clock_gettime clockid ptspec + peek ptspec + ) + +#if defined(javascript_HOST_ARCH) + +clockGetRes :: ClockID -> IO (Either Errno CTimespec) +clockGetRes _ = return $ Right $ MkCTimespec 0 0 + +#else /* defined(javascript_HOST_ARCH) */ + +foreign import capi unsafe "time.h clock_getres" + clock_getres :: ClockID -> Ptr CTimespec -> IO CInt + -- | Get the resolution of the given clock. clockGetRes :: ClockID -> IO (Either Errno CTimespec) clockGetRes clockid = alloca $ \ptspec -> do @@ -58,12 +71,7 @@ clockGetRes clockid = alloca $ \ptspec -> do errno <- getErrno return $ Left errno --- | Get the current time from the given clock. -clockGetTime :: ClockID -> IO CTimespec -clockGetTime clockid = alloca (\ptspec -> do - throwErrnoIfMinus1_ "clock_gettime" $ clock_gettime clockid ptspec - peek ptspec - ) +#endif /* defined(javascript_HOST_ARCH) */ #if defined(javascript_HOST_ARCH) -- JS backend doesn't support foreign imports with capi convention diff --git a/lib/Data/Time/Clock/Internal/DiffTime.hs b/lib/Data/Time/Clock/Internal/DiffTime.hs index 0798760110d8907d7f3a84c878921cd0e78aa785..e29b9f428430cffdbe1a0cd3e411e17dd845ebe7 100644 --- a/lib/Data/Time/Clock/Internal/DiffTime.hs +++ b/lib/Data/Time/Clock/Internal/DiffTime.hs @@ -17,10 +17,10 @@ import Data.Data import Data.Fixed #ifdef __GLASGOW_HASKELL__ import GHC.Read -import qualified Language.Haskell.TH.Syntax as TH #endif -import Text.Read +import qualified Language.Haskell.TH.Syntax as TH import Text.ParserCombinators.ReadP +import Text.Read -- | This is a length of time, as measured by a clock. -- Conversion functions such as 'fromInteger' and 'realToFrac' will treat it as seconds. @@ -29,7 +29,7 @@ import Text.ParserCombinators.ReadP -- It has a precision of one picosecond (= 10^-12 s). Enumeration functions will treat it as picoseconds. newtype DiffTime = MkDiffTime Pico - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord, Typeable, Data, TH.Lift) instance NFData DiffTime where rnf (MkDiffTime t) = rnf t @@ -81,13 +81,6 @@ instance RealFrac DiffTime where ceiling (MkDiffTime a) = ceiling a floor (MkDiffTime a) = floor a -#ifdef __GLASGOW_HASKELL__ --- Let GHC derive the instances when 'Fixed' has 'TH.Lift' instance. -instance TH.Lift DiffTime where - liftTyped :: TH.Quote m => DiffTime -> TH.Code m DiffTime - liftTyped (MkDiffTime (MkFixed a)) = [||MkDiffTime (MkFixed $$(TH.liftTyped a))||] -#endif - -- | Create a 'DiffTime' which represents an integral number of seconds. secondsToDiffTime :: Integer -> DiffTime secondsToDiffTime = fromInteger diff --git a/lib/Data/Time/Clock/Internal/NominalDiffTime.hs b/lib/Data/Time/Clock/Internal/NominalDiffTime.hs index ff27eea5ae9c83604a404e7574a7e82e8dbdd5d3..1648248492c36801213e5933ee81d52f420e2805 100644 --- a/lib/Data/Time/Clock/Internal/NominalDiffTime.hs +++ b/lib/Data/Time/Clock/Internal/NominalDiffTime.hs @@ -16,25 +16,25 @@ import Data.Data import Data.Fixed #ifdef __GLASGOW_HASKELL__ import GHC.Read -import qualified Language.Haskell.TH.Syntax as TH #endif +import qualified Language.Haskell.TH.Syntax as TH import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadPrec -- | This is a length of time, as measured by UTC. --- It has a precision of 10^-12 s. +-- It has a precision of one picosecond (10^-12 s). -- -- Conversion functions such as 'fromInteger' and 'realToFrac' will treat it as seconds. -- For example, @(0.010 :: NominalDiffTime)@ corresponds to 10 milliseconds. -- --- It has a precision of one picosecond (= 10^-12 s). Enumeration functions will treat it as picoseconds. +-- Enumeration functions will treat it as picoseconds. -- -- It ignores leap-seconds, so it's not necessarily a fixed amount of clock time. -- For instance, 23:00 UTC + 2 hours of NominalDiffTime = 01:00 UTC (+ 1 day), -- regardless of whether a leap-second intervened. newtype NominalDiffTime = MkNominalDiffTime Pico - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord, Typeable, Data, TH.Lift) -- | Create a 'NominalDiffTime' from a number of seconds. -- @@ -48,13 +48,6 @@ secondsToNominalDiffTime = MkNominalDiffTime nominalDiffTimeToSeconds :: NominalDiffTime -> Pico nominalDiffTimeToSeconds (MkNominalDiffTime t) = t -#ifdef __GLASGOW_HASKELL__ --- Let GHC derive the instances when 'Fixed' has 'TH.Lift' instance. -instance TH.Lift NominalDiffTime where - liftTyped :: TH.Quote m => NominalDiffTime -> TH.Code m NominalDiffTime - liftTyped (MkNominalDiffTime (MkFixed a)) = [||MkNominalDiffTime (MkFixed $$(TH.liftTyped a))||] -#endif - instance NFData NominalDiffTime where rnf (MkNominalDiffTime t) = rnf t diff --git a/lib/Data/Time/Clock/Internal/SystemTime.hs b/lib/Data/Time/Clock/Internal/SystemTime.hs index 15b330d9566e5cc145411f00f4717558ea443da6..6de4688a793aeb6e02134ddb2e3760e45c4eeb8d 100644 --- a/lib/Data/Time/Clock/Internal/SystemTime.hs +++ b/lib/Data/Time/Clock/Internal/SystemTime.hs @@ -43,7 +43,7 @@ data SystemTime = MkSystemTime { systemSeconds :: {-# UNPACK #-} !Int64 , systemNanoseconds :: {-# UNPACK #-} !Word32 } - deriving (Eq, Ord, Show, Data, Typeable, TH.Lift, Generic) + deriving (Eq, Ord, Show, Typeable, Data, Generic, TH.Lift) instance NFData SystemTime where rnf a = a `seq` () diff --git a/lib/Data/Time/Clock/Internal/UTCTime.hs b/lib/Data/Time/Clock/Internal/UTCTime.hs index 6228796875ee5d1b8c872397c53826078b3c4077..9a9cd2a92e9368723fd6418dcd85291c0f068b09 100644 --- a/lib/Data/Time/Clock/Internal/UTCTime.hs +++ b/lib/Data/Time/Clock/Internal/UTCTime.hs @@ -30,16 +30,7 @@ data UTCTime = UTCTime , utctDayTime :: DiffTime -- ^ the time from midnight, 0 <= t < 86401s (because of leap-seconds) } - deriving (Data, Typeable, TH.Lift, Generic) + deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData UTCTime where rnf (UTCTime d t) = rnf d `seq` rnf t `seq` () - -instance Eq UTCTime where - (UTCTime da ta) == (UTCTime db tb) = (da == db) && (ta == tb) - -instance Ord UTCTime where - compare (UTCTime da ta) (UTCTime db tb) = - case (compare da db) of - EQ -> compare ta tb - cmp -> cmp diff --git a/lib/Data/Time/Clock/Internal/UniversalTime.hs b/lib/Data/Time/Clock/Internal/UniversalTime.hs index 0af975e7431ed2ff5b4d34fbd05bd09301e23cd5..d954603edc5288e1599bb858ac1a5f14292d462c 100644 --- a/lib/Data/Time/Clock/Internal/UniversalTime.hs +++ b/lib/Data/Time/Clock/Internal/UniversalTime.hs @@ -17,7 +17,7 @@ import qualified Language.Haskell.TH.Syntax as TH newtype UniversalTime = ModJulianDate { getModJulianDate :: Rational } - deriving (Eq, Ord, Data, Typeable, TH.Lift, Generic) + deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData UniversalTime where rnf (ModJulianDate a) = rnf a diff --git a/lib/Data/Time/Clock/System.hs b/lib/Data/Time/Clock/System.hs index de569f7ac56a41162d7e826cd8a475fcd12eef94..c6a47f8659a37a07c744c1b44976e46e867cbe4f 100644 --- a/lib/Data/Time/Clock/System.hs +++ b/lib/Data/Time/Clock/System.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | Fast access to the system clock. @@ -30,10 +29,8 @@ truncateSystemTimeLeapSecond t = t systemToUTCTime :: SystemTime -> UTCTime systemToUTCTime (MkSystemTime seconds nanoseconds) = let -#ifdef __GLASGOW_HASKELL__ days :: Int64 timeSeconds :: Int64 -#endif (days, timeSeconds) = seconds `divMod` 86400 day :: Day day = addDays (fromIntegral days) systemEpochDay @@ -56,10 +53,8 @@ utcToSystemTime (UTCTime day time) = timePicoseconds = fromIntegral $ diffTimeToPicoseconds time timeNanoseconds :: Int64 timeNanoseconds = timePicoseconds `div` 1000 -#ifdef __GLASGOW_HASKELL__ timeSeconds :: Int64 nanoseconds :: Int64 -#endif (timeSeconds, nanoseconds) = if timeNanoseconds >= 86400000000000 then (86399, timeNanoseconds - 86399000000000) diff --git a/lib/Data/Time/Format/Format/Instances.hs b/lib/Data/Time/Format/Format/Instances.hs index 53893a2449f9af66d15dfd6b8562cacba248d37d..9e8cb6629427f709c021464e1811201549d972c3 100644 --- a/lib/Data/Time/Format/Format/Instances.hs +++ b/lib/Data/Time/Format/Format/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS -fno-warn-orphans #-} @@ -112,7 +111,6 @@ instance FormatTime DayOfWeek where formatCharacter _ _ = Nothing instance FormatTime Month where -#ifdef __GLASGOW_HASKELL__ -- Year Count formatCharacter _ 'Y' = Just $ formatNumber False 4 '0' $ \(YearMonth y _) -> y formatCharacter _ 'y' = Just $ formatNumber True 2 '0' $ \(YearMonth y _) -> mod100 y @@ -125,7 +123,6 @@ instance FormatTime Month where formatCharacter _ 'h' = Just $ formatString $ \locale (YearMonth _ my) -> snd $ (months locale) !! (my - 1) formatCharacter _ 'm' = Just $ formatNumber True 2 '0' $ \(YearMonth _ m) -> m -#endif -- Default formatCharacter _ _ = Nothing @@ -135,7 +132,6 @@ instance FormatTime Day where formatCharacter _ 'F' = Just $ formatString $ \locale -> formatTime locale "%Y-%m-%d" formatCharacter _ 'x' = Just $ formatString $ \locale -> formatTime locale (dateFmt locale) -- Day of Month -#ifdef __GLASGOW_HASKELL__ formatCharacter _ 'd' = Just $ formatNumber True 2 '0' $ \(YearMonthDay _ _ dm) -> dm formatCharacter _ 'e' = Just $ formatNumber True 2 ' ' $ \(YearMonthDay _ _ dm) -> dm -- Day of Year @@ -146,7 +142,6 @@ instance FormatTime Day where formatCharacter _ 'f' = Just $ formatNumber False 2 '0' $ \(YearWeekDay y _ _) -> div100 y formatCharacter _ 'V' = Just $ formatNumber True 2 '0' $ \(YearWeekDay _ wy _) -> wy formatCharacter _ 'u' = Just $ formatNumber True 1 '0' $ \(YearWeekDay _ _ dw) -> fromEnum dw -#endif -- Day of week formatCharacter _ 'a' = Just $ formatString $ \locale -> snd . ((wDays locale) !!) . snd . sundayStartWeek formatCharacter _ 'A' = Just $ formatString $ \locale -> fst . ((wDays locale) !!) . snd . sundayStartWeek @@ -154,9 +149,7 @@ instance FormatTime Day where formatCharacter _ 'w' = Just $ formatNumber True 1 '0' $ snd . sundayStartWeek formatCharacter _ 'W' = Just $ formatNumber True 2 '0' $ fst . mondayStartWeek -- Default -#ifdef __GLASGOW_HASKELL__ formatCharacter alt c = mapFormatCharacter (\(MonthDay m _) -> m) $ formatCharacter alt c -#endif instance FormatTime UTCTime where formatCharacter alt c = mapFormatCharacter (utcToZonedTime utc) $ formatCharacter alt c diff --git a/lib/Data/Time/Format/Parse/Instances.hs b/lib/Data/Time/Format/Parse/Instances.hs index 4ae55bd0471a9340085bd47c7b05f6b1b9b9e648..9c2b9bdfeb85244ca8478fffebcb2916372991f2 100644 --- a/lib/Data/Time/Format/Parse/Instances.hs +++ b/lib/Data/Time/Format/Parse/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS -fno-warn-orphans #-} @@ -278,7 +277,6 @@ instance ParseTime DayOfWeek where in rest cs -#ifdef __GLASGOW_HASKELL__ dayMonth :: Day -> Month dayMonth (MonthDay m _) = m @@ -296,7 +294,6 @@ instance ParseTime Month where rest (_ : xs) = rest xs rest [] = fromYearMonthValid y 1 rest cs -#endif mfoldl :: Monad m => (a -> b -> m a) -> m a -> [b] -> m a mfoldl f = diff --git a/lib/Data/Time/LocalTime.hs b/lib/Data/Time/LocalTime.hs index 9ce2b1c6588e985eeb11155d56bd0886aa61792e..76757d634f1a52177d6af9e6ba2e1824d9a1a201 100644 --- a/lib/Data/Time/LocalTime.hs +++ b/lib/Data/Time/LocalTime.hs @@ -19,6 +19,7 @@ module Data.Time.LocalTime ( import Data.Time.Format () import Data.Time.LocalTime.Internal.CalendarDiffTime +import Data.Time.LocalTime.Internal.Foreign import Data.Time.LocalTime.Internal.LocalTime import Data.Time.LocalTime.Internal.TimeOfDay import Data.Time.LocalTime.Internal.TimeZone hiding (timeZoneOffsetString'') diff --git a/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs b/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs index ad1c0cdaf939890de006af4343a9426d7c8636e8..2fc62b0f724804f448167c749bcea1281a252cfe 100644 --- a/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs +++ b/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs @@ -10,19 +10,13 @@ import Data.Data import Data.Time.Calendar.CalendarDiffDays import Data.Time.Clock.Internal.NominalDiffTime import GHC.Generics +import qualified Language.Haskell.TH.Syntax as TH data CalendarDiffTime = CalendarDiffTime { ctMonths :: Integer , ctTime :: NominalDiffTime } - deriving - ( Eq - , -- | @since 1.9.2 - Data - , -- | @since 1.9.2 - Typeable - , Generic - ) + deriving (Eq, Typeable, Data, Generic, TH.Lift) instance NFData CalendarDiffTime where rnf (CalendarDiffTime m t) = rnf m `seq` rnf t `seq` () diff --git a/lib/Data/Time/LocalTime/Internal/Foreign.hs b/lib/Data/Time/LocalTime/Internal/Foreign.hs new file mode 100644 index 0000000000000000000000000000000000000000..21317e9c3b00de665865bd124db148503582a2e0 --- /dev/null +++ b/lib/Data/Time/LocalTime/Internal/Foreign.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE Safe #-} + +module Data.Time.LocalTime.Internal.Foreign ( + getTimeZone, + getCurrentTimeZone, +) where + +import Data.Time.Clock.Internal.UTCTime +import Data.Time.Clock.POSIX +import Data.Time.Clock.System +import Data.Time.LocalTime.Internal.TimeZone +import Foreign +import Foreign.C +#if defined(javascript_HOST_ARCH) +import Data.Time.Calendar.Gregorian +import Data.Time.Clock.Internal.NominalDiffTime +import Data.Time.LocalTime.Internal.LocalTime +import Data.Time.LocalTime.Internal.TimeOfDay +#endif + +#if defined(javascript_HOST_ARCH) + +foreign import javascript "((dy,dm,dd,th,tm,ts) => { new Date(dy,dm,dd,th,tm,ts).getTimezoneOffset(); })" + js_get_timezone_minutes :: Int -> Int -> Int -> Int -> Int -> Int -> IO Int + +get_timezone_minutes :: UTCTime -> IO Int +get_timezone_minutes ut = let + lt :: LocalTime + lt = utcToLocalTime utc ut + in case lt of + LocalTime (YearMonthDay dy dm dd) (TimeOfDay th tm ts) -> + js_get_timezone_minutes (fromInteger dy) (pred dm) dd th tm (floor ts) + +getTimeZoneCTime :: CTime -> IO TimeZone +getTimeZoneCTime ct = do + let + ut :: UTCTime + ut = posixSecondsToUTCTime $ secondsToNominalDiffTime $ fromIntegral $ fromCTime ct + mins <- get_timezone_minutes ut + return $ TimeZone mins False "" + +fromCTime :: CTime -> Int64 +fromCTime (CTime tt) = fromIntegral tt + +#else +{-# CFILES cbits/HsTime.c #-} +foreign import ccall unsafe "HsTime.h get_current_timezone_seconds" + get_current_timezone_seconds :: + CTime -> Ptr CInt -> Ptr CString -> IO CLong + +getTimeZoneCTime :: CTime -> IO TimeZone +getTimeZoneCTime ctime = + with 0 $ \pdst -> + with nullPtr $ \pcname -> do + secs <- get_current_timezone_seconds ctime pdst pcname + case secs of + 0x80000000 -> fail "localtime_r failed" + _ -> do + dst <- peek pdst + cname <- peek pcname + name <- peekCString cname + return (TimeZone (div (fromIntegral secs) 60) (dst == 1) name) +#endif + +-- there's no instance Bounded CTime, so this is the easiest way to check for overflow +toCTime :: Int64 -> IO CTime +toCTime t = + let + tt = fromIntegral t + t' = fromIntegral tt + in + if t' == t + then return $ CTime tt + else fail "Data.Time.LocalTime.Internal.TimeZone.toCTime: Overflow" + +-- | Get the configured time-zone for a given time (varying as per summertime adjustments). +getTimeZoneSystem :: SystemTime -> IO TimeZone +getTimeZoneSystem t = do + ctime <- toCTime $ systemSeconds t + getTimeZoneCTime ctime + +-- | Get the configured time-zone for a given time (varying as per summertime adjustments). +-- +-- On Unix systems the output of this function depends on: +-- +-- 1. The value of @TZ@ environment variable (if set) +-- +-- 2. The system time zone (usually configured by @\/etc\/localtime@ symlink) +-- +-- For details see tzset(3) and localtime(3). +-- +-- Example: +-- +-- @ +-- > let t = `UTCTime` (`Data.Time.Calendar.fromGregorian` 2021 7 1) 0 +-- > `getTimeZone` t +-- CEST +-- > `System.Environment.setEnv` \"TZ\" \"America/New_York\" >> `getTimeZone` t +-- EDT +-- > `System.Environment.setEnv` \"TZ\" \"Europe/Berlin\" >> `getTimeZone` t +-- CEST +-- @ +-- +-- On Windows systems the output of this function depends on: +-- +-- 1. The value of @TZ@ environment variable (if set). +-- See [here](https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/tzset) for how Windows interprets this variable. +-- +-- 2. The system time zone, configured in Settings +getTimeZone :: UTCTime -> IO TimeZone +getTimeZone t = do + ctime <- toCTime $ floor $ utcTimeToPOSIXSeconds t + getTimeZoneCTime ctime + +-- | Get the configured time-zone for the current time. +getCurrentTimeZone :: IO TimeZone +getCurrentTimeZone = getSystemTime >>= getTimeZoneSystem diff --git a/lib/Data/Time/LocalTime/Internal/LocalTime.hs b/lib/Data/Time/LocalTime/Internal/LocalTime.hs index 88412cba354df2a93ffc6eab15be691c32f18826..564a7f571c6593b1fe156b81fba81b64f6c68cae 100644 --- a/lib/Data/Time/LocalTime/Internal/LocalTime.hs +++ b/lib/Data/Time/LocalTime/Internal/LocalTime.hs @@ -25,6 +25,7 @@ import Data.Time.Clock.Internal.UniversalTime import Data.Time.LocalTime.Internal.TimeOfDay import Data.Time.LocalTime.Internal.TimeZone import GHC.Generics +import qualified Language.Haskell.TH.Syntax as TH -- | A simple day and time aggregate, where the day is of the specified parameter, -- and the time is a TimeOfDay. @@ -34,7 +35,7 @@ data LocalTime = LocalTime { localDay :: Day , localTimeOfDay :: TimeOfDay } - deriving (Eq, Ord, Data, Typeable, Generic) + deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData LocalTime where rnf (LocalTime d t) = rnf d `seq` rnf t `seq` () diff --git a/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs b/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs index 6bcf170609822f4da28d724a93a016fdf35b6482..524fbc358a7310f7984c23a126aa84fde11e05a4 100644 --- a/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs +++ b/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs @@ -26,6 +26,7 @@ import Data.Time.Clock.Internal.DiffTime import Data.Time.Clock.Internal.NominalDiffTime import Data.Time.LocalTime.Internal.TimeZone import GHC.Generics +import qualified Language.Haskell.TH.Syntax as TH -- | Time of day as represented in hour, minute and second (with picoseconds), typically used to express local time of day. -- @@ -40,7 +41,7 @@ data TimeOfDay = TimeOfDay -- ^ Note that 0 <= 'todSec' < 61, accomodating leap seconds. -- Any local minute may have a leap second, since leap seconds happen in all zones simultaneously } - deriving (Eq, Ord, Data, Typeable, Generic) + deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData TimeOfDay where rnf (TimeOfDay h m s) = rnf h `seq` rnf m `seq` rnf s `seq` () diff --git a/lib/Data/Time/LocalTime/Internal/TimeZone.hs b/lib/Data/Time/LocalTime/Internal/TimeZone.hs index c6d75d0ae2e44c0823b4fbd239c10e24a5073bab..84af4b9285e805a93b14bb63a09f22824b6fe9d0 100644 --- a/lib/Data/Time/LocalTime/Internal/TimeZone.hs +++ b/lib/Data/Time/LocalTime/Internal/TimeZone.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE Safe #-} module Data.Time.LocalTime.Internal.TimeZone ( @@ -10,20 +9,13 @@ module Data.Time.LocalTime.Internal.TimeZone ( minutesToTimeZone, hoursToTimeZone, utc, - -- getting the locale time zone - getTimeZone, - getCurrentTimeZone, ) where import Control.DeepSeq import Data.Data import Data.Time.Calendar.Private -import Data.Time.Clock.Internal.UTCTime -import Data.Time.Clock.POSIX -import Data.Time.Clock.System -import Foreign -import Foreign.C import GHC.Generics +import qualified Language.Haskell.TH.Syntax as TH -- | A TimeZone is a whole number of minutes offset from UTC, together with a name and a \"just for summer\" flag. data TimeZone = TimeZone @@ -34,7 +26,7 @@ data TimeZone = TimeZone , timeZoneName :: String -- ^ The name of the zone, typically a three- or four-letter acronym. } - deriving (Eq, Ord, Data, Typeable, Generic) + deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) instance NFData TimeZone where rnf (TimeZone m so n) = rnf m `seq` rnf so `seq` rnf n `seq` () @@ -79,81 +71,3 @@ instance Show TimeZone where -- | The UTC time zone. utc :: TimeZone utc = TimeZone 0 False "UTC" - -{-# CFILES cbits/HsTime.c #-} -foreign import ccall unsafe "HsTime.h get_current_timezone_seconds" - get_current_timezone_seconds :: - CTime -> Ptr CInt -> Ptr CString -> IO CLong - -getTimeZoneCTime :: CTime -> IO TimeZone -getTimeZoneCTime ctime = - with - 0 - ( \pdst -> - with - nullPtr - ( \pcname -> do - secs <- get_current_timezone_seconds ctime pdst pcname - case secs of - 0x80000000 -> fail "localtime_r failed" - _ -> do - dst <- peek pdst - cname <- peek pcname - name <- peekCString cname - return (TimeZone (div (fromIntegral secs) 60) (dst == 1) name) - ) - ) - --- there's no instance Bounded CTime, so this is the easiest way to check for overflow -toCTime :: Int64 -> IO CTime -toCTime t = - let - tt = fromIntegral t - t' = fromIntegral tt - in - if t' == t - then return $ CTime tt - else fail "Data.Time.LocalTime.Internal.TimeZone.toCTime: Overflow" - --- | Get the configured time-zone for a given time (varying as per summertime adjustments). -getTimeZoneSystem :: SystemTime -> IO TimeZone -getTimeZoneSystem t = do - ctime <- toCTime $ systemSeconds t - getTimeZoneCTime ctime - --- | Get the configured time-zone for a given time (varying as per summertime adjustments). --- --- On Unix systems the output of this function depends on: --- --- 1. The value of @TZ@ environment variable (if set) --- --- 2. The system time zone (usually configured by @\/etc\/localtime@ symlink) --- --- For details see tzset(3) and localtime(3). --- --- Example: --- --- @ --- > let t = `UTCTime` (`Data.Time.Calendar.fromGregorian` 2021 7 1) 0 --- > `getTimeZone` t --- CEST --- > `System.Environment.setEnv` \"TZ\" \"America/New_York\" >> `getTimeZone` t --- EDT --- > `System.Environment.setEnv` \"TZ\" \"Europe/Berlin\" >> `getTimeZone` t --- CEST --- @ --- --- On Windows systems the output of this function depends on: --- --- 1. The value of @TZ@ environment variable (if set). --- See [here](https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/tzset) for how Windows interprets this variable. --- --- 2. The system time zone, configured in Settings -getTimeZone :: UTCTime -> IO TimeZone -getTimeZone t = do - ctime <- toCTime $ floor $ utcTimeToPOSIXSeconds t - getTimeZoneCTime ctime - --- | Get the configured time-zone for the current time. -getCurrentTimeZone :: IO TimeZone -getCurrentTimeZone = getSystemTime >>= getTimeZoneSystem diff --git a/lib/Data/Time/LocalTime/Internal/ZonedTime.hs b/lib/Data/Time/LocalTime/Internal/ZonedTime.hs index a64f343f63139fb64b6302bef51848ae64c868f0..a4c0b57d6fe78d3e6599bfada8f385c82bcf1032 100644 --- a/lib/Data/Time/LocalTime/Internal/ZonedTime.hs +++ b/lib/Data/Time/LocalTime/Internal/ZonedTime.hs @@ -14,9 +14,11 @@ import Control.DeepSeq import Data.Data import Data.Time.Clock.Internal.UTCTime import Data.Time.Clock.POSIX +import Data.Time.LocalTime.Internal.Foreign import Data.Time.LocalTime.Internal.LocalTime import Data.Time.LocalTime.Internal.TimeZone import GHC.Generics +import qualified Language.Haskell.TH.Syntax as TH -- | A local time together with a time zone. -- @@ -27,7 +29,7 @@ data ZonedTime = ZonedTime { zonedTimeToLocalTime :: LocalTime , zonedTimeZone :: TimeZone } - deriving (Data, Typeable, Generic) + deriving (Typeable, Data, Generic, TH.Lift) instance NFData ZonedTime where rnf (ZonedTime lt z) = rnf lt `seq` rnf z `seq` () diff --git a/stack.tools.yaml b/stack.tools.yaml deleted file mode 100644 index 7849b5e79b2fbc88689d516c8482a445a0db3e9d..0000000000000000000000000000000000000000 --- a/stack.tools.yaml +++ /dev/null @@ -1,2 +0,0 @@ -resolver: lts-22.12 -packages: [] diff --git a/stack.tools.yaml.lock b/stack.tools.yaml.lock deleted file mode 100644 index 7fb5a123b73ab711dc094e92aaf712c0e362a87a..0000000000000000000000000000000000000000 --- a/stack.tools.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - sha256: e2c529ccfb21501f98f639e056cbde50470b86256d9849d7a82d414ca23e4276 - size: 712898 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/12.yaml - original: lts-22.12 diff --git a/stack.yaml b/stack.yaml index ced78db8c9f4a757eefed6912f363160c7cae4f5..38f6f84ba910a1c6a71060376651a36eedf9d7d0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-22.13 +resolver: lts-23.19 packages: - '.' allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index ca9a5de24b23920822bf0f50d93f264ce73ae58c..7471450182c217c794958d28ff414b7ad1175c65 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -27,7 +27,7 @@ packages: hackage: directory-1.3.8.3 snapshots: - completed: - sha256: 6f0bea3ba5b07360f25bc886e8cff8d847767557a492a6f7f6dcb06e3cc79ee9 - size: 712905 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/13.yaml - original: lts-22.13 + sha256: 296a7960c37efa382432ab497161a092684191815eb92a608c5d6ea5f894ace3 + size: 683835 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/19.yaml + original: lts-23.19 diff --git a/test/ForeignCalls.hs b/test/ForeignCalls.hs new file mode 100644 index 0000000000000000000000000000000000000000..dbb565810131714e983d4bd8877c3a7f82cb8afb --- /dev/null +++ b/test/ForeignCalls.hs @@ -0,0 +1,50 @@ +module Main (main) where + +import Control.Exception +import Control.Monad +import Data.Foldable +import Data.Monoid +import Data.Time +import Data.Time.Clock.POSIX +import Data.Time.Clock.System +import Data.Time.Clock.TAI +import Data.Traversable +import System.Exit +import System.IO + +data Test = MkTest String (IO ()) + +tests :: [Test] +tests = + [ MkTest "getCurrentTime" $ void $ getCurrentTime + , MkTest "getZonedTime" $ void $ getZonedTime + , MkTest "getCurrentTimeZone" $ void $ getCurrentTimeZone + , MkTest "getTimeZone" $ void $ getCurrentTime >>= getTimeZone + , MkTest "getPOSIXTime" $ void $ getPOSIXTime + , MkTest "getSystemTime" $ void $ getSystemTime + , MkTest "getTime_resolution" $ void $ evaluate getTime_resolution + , MkTest "taiClock time" $ for_ taiClock $ \(_, getTime) -> void $ getTime + , MkTest "taiClock resolution" $ for_ taiClock $ \(res, _) -> void $ evaluate res + ] + +runTest :: Test -> IO Bool +runTest (MkTest name action) = do + hPutStr stderr $ name <> ": " + result <- try action + case result of + Left err -> do + hPutStrLn stderr $ "FAILED: " <> show (err :: SomeException) + return False + Right () -> do + hPutStrLn stderr "PASSED" + return True + +main :: IO () +main = do + results <- for tests $ \test -> do + passed <- runTest test + return (Sum $ if passed then 1 else 0 :: Int, Sum 1) + let + (Sum i, Sum n) = mconcat results + hPutStrLn stderr $ show i <> " out of " <> show n <> " tests passed" + exitWith $ if i == n then ExitSuccess else ExitFailure 1 diff --git a/test/main/Test/Format/ISO8601.hs b/test/main/Test/Format/ISO8601.hs index 1a84ab7b530c8572830d75267fd5cddd591234e9..e24ddbe314a6ef3f4e0d65349ed1eca8515740fd 100644 --- a/test/main/Test/Format/ISO8601.hs +++ b/test/main/Test/Format/ISO8601.hs @@ -58,7 +58,7 @@ readShowTests :: (Eq a, Show a, Arbitrary a, SpecialTestValues a) => (FormatExte readShowTests = readShowTestsCheck $ \_ -> False newtype Durational t = MkDurational t - deriving (Eq) + deriving Eq instance Show t => Show (Durational t) where show (MkDurational t) = show t diff --git a/time.cabal b/time.cabal index 2d6a50eab9a08d0ff951d1ce87af57fc884bf419..482f748d5ec87111620e6891cf7141fc93965811 100644 --- a/time.cabal +++ b/time.cabal @@ -13,9 +13,9 @@ description: Time, clocks and calendars category: Time build-type: Configure tested-with: - GHC == 9.4.8, - GHC == 9.6.4, - GHC == 9.8.2 + GHC == 9.8.4, + GHC == 9.10.1, + GHC == 9.12.2 x-follows-version-policy: extra-source-files: @@ -49,10 +49,13 @@ library StandaloneDeriving PatternSynonyms ViewPatterns - ghc-options: -Wall -fwarn-tabs + ghc-options: + -Wall + -fwarn-tabs + -Wno-deriving-typeable c-sources: lib/cbits/HsTime.c build-depends: - base >= 4.15 && < 5, + base >= 4.18 && < 5, deepseq >= 1.1, if impl(ghc) build-depends: template-haskell >= 2.17, @@ -94,6 +97,7 @@ library Data.Time.Clock.Internal.UTCTime, Data.Time.Clock.Internal.CTimeval, Data.Time.Clock.Internal.UTCDiff, + Data.Time.LocalTime.Internal.Foreign, Data.Time.LocalTime.Internal.TimeZone, Data.Time.LocalTime.Internal.TimeOfDay, Data.Time.LocalTime.Internal.CalendarDiffTime, @@ -139,7 +143,22 @@ test-suite ShowTime time main-is: ShowTime.hs +test-suite ForeignCalls + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs + build-depends: + base, + time + main-is: ForeignCalls.hs + test-suite test-main + if arch (javascript) || arch (wasm32) + -- blocked by splitmix + -- https://github.com/haskellari/splitmix/issues/92 + -- https://github.com/haskellari/splitmix/issues/93 + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test/main default-language: Haskell2010 @@ -207,7 +226,7 @@ test-suite test-main Test.LocalTime.TimeRef test-suite test-unix - if os(windows) + if os(windows) || arch (javascript) || arch (wasm32) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test/unix