fixed-generic (empty) → 0.1.0.0

raw patch · 7 files changed

+215/−0 lines, 7 filesdep +basedep +fixed-genericdep +ghc-internalsetup-changed

Dependencies added: base, fixed-generic, ghc-internal

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +1/−0
Setup.hs +2/−0
fixed-generic.cabal +57/−0
src/Data/Fixed/Generic.hs +116/−0
test/Spec.hs +2/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `fixed-generic`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2024 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# fixed-generic

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ fixed-generic.cabal view

@@ -0,0 +1,57 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           fixed-generic+version:        0.1.0.0+synopsis:       Fixed-point number build on generic integral number+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/fixed-generic#readme>+category:       Numeric+homepage:       https://github.com/YoshikuniJujo/fixed-generic#readme+bug-reports:    https://github.com/YoshikuniJujo/fixed-generic/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      Copyright (c) 2023 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/fixed-generic++library+  exposed-modules:+      Data.Fixed.Generic+  other-modules:+      Paths_fixed_generic+  autogen-modules:+      Paths_fixed_generic+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , ghc-internal <10+  default-language: Haskell2010++test-suite fixed-generic-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_fixed_generic+  autogen-modules:+      Paths_fixed_generic+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , fixed-generic+    , ghc-internal <10+  default-language: Haskell2010

+ src/Data/Fixed/Generic.hs view

@@ -0,0 +1,116 @@+{-# LANGUAGE BlockArguments, ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.Fixed.Generic (F(..), showF) where++import GHC.Internal.Read+import GHC.Internal.Text.ParserCombinators.ReadPrec+import GHC.Internal.Text.Read.Lex+import Data.Data+import Data.Fixed++newtype F (a :: k) n = MkF n deriving (Eq, Ord)++tyF :: DataType+tyF = mkDataType "Data.Fixed.Generic.F" [conMkF]++conMkF :: Constr+conMkF = mkConstr tyF "MkF" [] Prefix++instance (Typeable k, Typeable a, Data n) => Data (F (a :: k) n) where+	gfoldl k z (MkF a) = k (z MkF) a+	gunfold k z _ = k (z MkF)+	dataTypeOf _ = tyF+	toConstr _ = conMkF++withResolution :: forall k (a :: k) f . HasResolution a => (Integer -> f) -> f+withResolution foo = foo . resolution $ Proxy @a++resl :: forall a n . (HasResolution a, Num n) => n+resl = fromInteger $ resolution (Proxy @a)++withResl :: forall k (a :: k) n f . (Num n, HasResolution a) => (n -> f) -> f+withResl foo = foo $ resl @a++instance Enum n => Enum (F a n) where+	succ (MkF a) = MkF (succ a)+	pred (MkF a) = MkF (succ a)+	toEnum = MkF . toEnum+	fromEnum (MkF a) = fromEnum a+	enumFrom (MkF a) = fmap MkF $ enumFrom a+	enumFromThen (MkF a) (MkF b) = fmap MkF (enumFromThen a b)+	enumFromTo (MkF a) (MkF b) = fmap MkF (enumFromTo a b)+	enumFromThenTo (MkF a) (MkF b) (MkF c) = fmap MkF (enumFromThenTo a b c)++instance (HasResolution a, Integral n) => Num (F a n) where+	MkF a + MkF b = MkF $ a + b+	MkF a - MkF b = MkF $ a - b+	MkF a * MkF b = MkF $ (a * b) `div` resl @a+	negate (MkF a) = MkF $ negate a+	abs (MkF a) = MkF $ abs a+	signum (MkF a) = fromIntegral $ signum a+	fromInteger i = withResl @_ @a \res -> MkF $ fromInteger i * res++instance (HasResolution a, Integral n) => Real (F a n) where+	toRational (MkF a) = toRational a / toRational (resolution (Proxy @a))++instance (HasResolution a, Integral n) => Fractional (F a n) where+	MkF a / MkF b = MkF $ (a * resl @a) `div` b+	recip (MkF a) = MkF $ (res * res) `div` a where res = resl @a+	fromRational r =+		withResolution @_ @a \res -> MkF (floor (r * (toRational res)))++instance (HasResolution a, Integral n) => RealFrac (F a n) where+	properFraction a = (i, a - fromIntegral i)+		where i = truncate a+	truncate f = truncate (toRational f)+	round f = round (toRational f)+	ceiling f = ceiling (toRational f)+	floor f = floor (toRational f)++chopZeros :: (Show n, Integral n) => n -> String+chopZeros 0 = ""+chopZeros a | a `mod` 10 == 0 = chopZeros (a `div` 10)+chopZeros a = show a++showIntegerZeros :: (Show n, Integral n) => Bool -> Int -> n -> String+showIntegerZeros True _ 0 = ""+showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where+	s = show a+	s' = if chopTrailingZeros then chopZeros a else s++withDot :: String -> String+withDot "" = ""+withDot s = '.' : s++showF :: forall a n . (HasResolution a, Show n, Integral n) => Bool -> F a n -> String+showF chopTrailingZeros (MkF a) | a < 0 =+	"-" ++ showF chopTrailingZeros (MkF (negate a) :: F a n)+showF chopTrailingZeros (MkF a) =+	show i ++ withDot (showIntegerZeros chopTrailingZeros digits fracNum)+	where+	res = resl @a+	(i, d) = a `divMod` res+	digits = ceiling (logBase 10 (fromIntegral res) :: Double)+	maxnum = 10 ^ digits+	fracNum = divCeil (d * maxnum) res+	divCeil x y = (x + y - 1) `div` y++instance (HasResolution a, Show n, Integral n) => Show (F a n) where+	showsPrec p n = showParen (p > 6 && n < 0) $ showString $ showF False n++convertF :: forall a n . (HasResolution a, Integral n) => Lexeme -> ReadPrec (F a n)+convertF (Number n)+	| Just (i, f) <- numberToFixed e n =+		pure (fromInteger i + (fromInteger f / (10 ^ e)))+		where+		r = resl @a+		e = ceiling (logBase 10 (fromInteger r) :: Double)+convertF _ = pfail++instance (HasResolution a, Integral n) => Read (F a n) where+	readPrec = readNumber convertF+	readListPrec = readListPrecDefault+	readList = readListDefault

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"