diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,6 +1,7 @@ Copyright (C) 2010-2016 NICTA Limited -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation +Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. +Copyright (c) 2019-2020, System F (System F Aerial Operations) ABN 19 363 313 255 All rights reserved. @@ -15,7 +16,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of QFPL nor the names of other + * Neither the name of System F nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) -import System.FilePath ( () ) - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - -\end{code} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,75 @@ +0.15 + +* Widen version bounds. + +0.14 + +* Fix export for `DecDigitNoZero`. + +0.13 + +* Make `DecDigitNoZero` data type. + +0.12 + +* Fix bug in functions that produce Integral values. + +0.11 + +* Update `lens` to support `< 5.2` + +0.9 + +* Update base version. + +0.8 + +* Add decimal arithmetic + +0.6 + +* Removed the `Digit` datatype +* Added new datatypes with appropriate `D*` instances + * `BinDigit` + * `OctDigit` + * `DecDigit` + * `HexDigit` + * `HeXDigit` + * `HEXDigit` +* Culled most of the doctests, and leaving one or two per function to illustrate + usage +* Juggled re-exports to make the library easier to use and to improve documentation +* Added `Data.Digit.Enum`, which contains ascending-order enumerations of the new datatypes +* Added integral conversion functions for the new datatypes + +0.5.3 + +* Bump version of [tasty-hedgehog, hedgehog, papa] +* Updated default.nix + +0.5.2 + +* Add `Data.Digit.Natural (_NaturalDigits, naturalToDigits, digitsToNatural)` + +0.5.1 + +* Replace doctest with hunit and hedgehog via tasty + +0.5.0 + +* Data types for other bases (binary, octal, hexadecimal). +* Remove the `Digit…` data types. +* Introduce the `Digit` data type. + +0.4.0 + +* Refactor to classy prisms for each digit. + +0.3.0 + +* Refactor decimal type. +* `Digits` and `Digits1` data types for list of digits. + 0.2.9 * Remove redundant type-class constraints. diff --git a/digit.cabal b/digit.cabal --- a/digit.cabal +++ b/digit.cabal @@ -1,75 +1,114 @@ name: digit -version: 0.3.0 +version: 0.15 license: BSD3 license-file: LICENCE -author: Queensland Functional Programming Lab -maintainer: Queensland Functional Programming Lab -copyright: Copyright (C) 2010-2016 NICTA Limited -copyright: Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. +author: System F +maintainer: System F +copyright: Copyright (c) 2010-2016 NICTA Limited + Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. + Copyright (c) System F (System F Aerial Operations) 2019-2020 synopsis: A data-type representing digits 0-9 and other combinations category: Data -homepage: https://github.com/qfpl/digit -bug-reports: https://github.com/qfpl/digit/issues +homepage: https://github.com/system-f/digit +bug-reports: https://github.com/system-f/digit/issues cabal-version: >= 1.10 -build-type: Custom +build-type: Simple extra-source-files: CONTRIBUTORS, changelog.md +tested-with: GHC == 9.8.1, GHC == 9.6.3, GHC == 9.4.7, GHC == 9.0.2, GHC == 8.6.1, GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 description: - <> + <> . @Digit@ is a data-type that represents the digits 0-9 and other combinations. source-repository head type: git - location: git@github.com:qfpl/digit.git - -flag small_base - description: Choose the new, split-up base package. + location: git@github.com:system-f/digit.git library default-language: Haskell2010 build-depends: - base >= 4.7 && < 5 - , lens >= 4.0 && < 5 - , parsers >= 0.12.3 && < 0.13 + base >= 4.8 && < 6 + , lens >= 4.0 && < 6 + , parsers >= 0.12.3 && < 1 , semigroups >= 0.12 && < 1.0 , template-haskell >= 2.8 && < 3 - , papa >= 0.3 && < 0.4 - + , semigroupoids >= 5 && < 7 + , scientific >= 0.3 && < 1 + ghc-options: -Wall + default-extensions: + NoImplicitPrelude + hs-source-dirs: src exposed-modules: Data.Digit - Data.Digits - Data.Digits1 + Data.Digit.Binary + Data.Digit.Natural + Data.Digit.Decimal + Data.Digit.Octal -test-suite doctests + Data.Digit.Hexadecimal.LowerCase + Data.Digit.Hexadecimal.UpperCase + Data.Digit.Hexadecimal.MixedCase + + Data.Digit.Class.D0 + Data.Digit.Class.D1 + Data.Digit.Class.D2 + Data.Digit.Class.D3 + Data.Digit.Class.D4 + Data.Digit.Class.D5 + Data.Digit.Class.D6 + Data.Digit.Class.D7 + Data.Digit.Class.D8 + Data.Digit.Class.D9 + + Data.Digit.Class.LowerCase + Data.Digit.Class.MixedCase + Data.Digit.Class.UpperCase + + Data.Digit.Char + Data.Digit.Enum + Data.Digit.Integral + + +test-suite tests type: exitcode-stdio-1.0 main-is: - doctests.hs + Main.hs default-language: Haskell2010 build-depends: - base < 5 && >= 4.8 - , doctest >= 0.9.7 - , filepath >= 1.3 - , directory >= 1.1 - , QuickCheck >= 2.0 - , template-haskell >= 2.8 - , parsec >= 3.1 - + base >=4.8 && <4.13 + , lens >=4.0 && <5.2 + , ansi-wl-pprint >=0.6 && <0.7 + , hedgehog >=0.5 && <1.1 + , tasty >=0.11 && <1.3 + , tasty-hspec >=1.1 && <1.2 + , parsec >=3.1 && <3.2 + , parsers >=0.12.3 && <0.13 + , pretty >=1.1 && <1.2 + , text >=1.2 && <1.3 + , tasty-hedgehog >=0.1 && <1.1 + , tasty-hunit >=0.9 && <0.11 + , semigroups >= 0.12 && < 1.0 + , digit + ghc-options: -Wall -threaded + + default-extensions: + NoImplicitPrelude hs-source-dirs: test diff --git a/src/Data/Digit.hs b/src/Data/Digit.hs --- a/src/Data/Digit.hs +++ b/src/Data/Digit.hs @@ -1,858 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | A data type with ten nullary constructors [0-9] and combinators. -module Data.Digit -( - Digit -, foldDigit -, HasDigit(..) -, AsDigit(..) -, ManyDigit(..) -, D0(..) -, D1(..) -, D2(..) -, D3(..) -, D4(..) -, D5(..) -, D6(..) -, D7(..) -, D8(..) -, D9(..) -, mod10 -, absrem10 -, divMod10 -, parsedigit -, digitQ -, (/+/) +module Data.Digit ( + module Data.Digit.Binary +, module Data.Digit.Decimal +, module Data.Digit.Octal +, module Data.Digit.Hexadecimal.LowerCase +, module Data.Digit.Hexadecimal.UpperCase +, module Data.Digit.Hexadecimal.MixedCase +-- * Utilities +, module Data.Digit.Char +, module Data.Digit.Enum +, module Data.Digit.Integral +, module Data.Digit.Natural ) where -import Data.Data (Data) -import Data.Maybe(fromMaybe) -import Data.Typeable (Typeable) -import Language.Haskell.TH(ExpQ, PatQ, varE, varP, mkName) -import Language.Haskell.TH.Quote(QuasiQuoter(QuasiQuoter), quotePat, quoteExp, quoteDec, dataToExpQ, dataToPatQ, quoteType) -import Prelude(fromEnum, Bounded, error) -- livin on the edge -import Text.Parser.Char(CharParsing, char) -import Text.Parser.Combinators(()) -import Papa - --- $setup --- >>> import Prelude - --- | A data type with ten nullary constructors. -data Digit = - D0 - | D1 - | D2 - | D3 - | D4 - | D5 - | D6 - | D7 - | D8 - | D9 - deriving (Eq, Ord, Enum, Bounded, Data, Typeable) - -instance Show Digit where - show = - show . fromEnum - --- | Catamorphism for @Digit@. --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D0 == q0 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D1 == q1 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D2 == q2 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D3 == q3 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D4 == q4 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D5 == q5 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D6 == q6 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D7 == q7 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D8 == q8 --- --- prop> foldDigit q0 q1 q2 q3 q4 q5 q6 q7 q8 q9 D9 == q9 -foldDigit :: - a -- ^ Zero. - -> a -- ^ One. - -> a -- ^ Two. - -> a -- ^ Three. - -> a -- ^ Four. - -> a -- ^ Five. - -> a -- ^ Six. - -> a -- ^ Seven. - -> a -- ^ Eight. - -> a -- ^ Nine. - -> Digit -- ^ The digit to fold. - -> a -foldDigit q0 _ _ _ _ _ _ _ _ _ D0 = - q0 -foldDigit _ q1 _ _ _ _ _ _ _ _ D1 = - q1 -foldDigit _ _ q2 _ _ _ _ _ _ _ D2 = - q2 -foldDigit _ _ _ q3 _ _ _ _ _ _ D3 = - q3 -foldDigit _ _ _ _ q4 _ _ _ _ _ D4 = - q4 -foldDigit _ _ _ _ _ q5 _ _ _ _ D5 = - q5 -foldDigit _ _ _ _ _ _ q6 _ _ _ D6 = - q6 -foldDigit _ _ _ _ _ _ _ q7 _ _ D7 = - q7 -foldDigit _ _ _ _ _ _ _ _ q8 _ D8 = - q8 -foldDigit _ _ _ _ _ _ _ _ _ q9 D9 = - q9 - -class HasDigit a where - hasdigit :: - Lens' a Digit - -instance HasDigit Digit where - hasdigit = - id - -class D0 d where - d0 :: - Prism' - d - () - x0 :: - D0 d => - d - x0 = - d0 # () - -instance D0 Digit where - d0 = - prism' - (\() -> D0) - (\d -> case d of - D0 -> Just () - _ -> Nothing) - -class D1 d where - d1 :: - Prism' - d - () - x1 :: - D1 d => - d - x1 = - d1 # () - -instance D1 Digit where - d1 = - prism' - (\() -> D1) - (\d -> case d of - D1 -> Just () - _ -> Nothing) - -class D2 d where - d2 :: - Prism' - d - () - x2 :: - D2 d => - d - x2 = - d2 # () - -instance D2 Digit where - d2 = - prism' - (\() -> D2) - (\d -> case d of - D2 -> Just () - _ -> Nothing) - -class D3 d where - d3 :: - Prism' - d - () - x3 :: - D3 d => - d - x3 = - d3 # () - -instance D3 Digit where - d3 = - prism' - (\() -> D3) - (\d -> case d of - D3 -> Just () - _ -> Nothing) - -class D4 d where - d4 :: - Prism' - d - () - x4 :: - D4 d => - d - x4 = - d4 # () - -instance D4 Digit where - d4 = - prism' - (\() -> D4) - (\d -> case d of - D4 -> Just () - _ -> Nothing) - -class D5 d where - d5 :: - Prism' - d - () - x5 :: - D5 d => - d - x5 = - d5 # () - -instance D5 Digit where - d5 = - prism' - (\() -> D5) - (\d -> case d of - D5 -> Just () - _ -> Nothing) - -class D6 d where - d6 :: - Prism' - d - () - x6 :: - D6 d => - d - x6 = - d6 # () - -instance D6 Digit where - d6 = - prism' - (\() -> D6) - (\d -> case d of - D6 -> Just () - _ -> Nothing) - -class D7 d where - d7 :: - Prism' - d - () - x7 :: - D7 d => - d - x7 = - d7 # () - -instance D7 Digit where - d7 = - prism' - (\() -> D7) - (\d -> case d of - D7 -> Just () - _ -> Nothing) - -class D8 d where - d8 :: - Prism' - d - () - x8 :: - D8 d => - d - x8 = - d8 # () - -instance D8 Digit where - d8 = - prism' - (\() -> D8) - (\d -> case d of - D8 -> Just () - _ -> Nothing) - -class D9 d where - d9 :: - Prism' - d - () - x9 :: - D9 d => - d - x9 = - d9 # () - -instance D9 Digit where - d9 = - prism' - (\() -> D9) - (\d -> case d of - D9 -> Just () - _ -> Nothing) - -class AsDigit a where - digit :: - Prism' - a - Digit - -instance AsDigit Digit where - digit = - id - --- | --- --- >>> (5 :: Int) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Int) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Int) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Int) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Int) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Int --- 5 --- --- >>> digitIntegral # D9 :: Int --- 9 --- --- >>> digitIntegral # D0 :: Int --- 0 -instance AsDigit Int where - digit = - digitIntegral - --- | --- --- >>> (5 :: Int8) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Int8) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Int8) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Int8) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Int8) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Int8 --- 5 --- --- >>> digitIntegral # D9 :: Int8 --- 9 --- --- >>> digitIntegral # D0 :: Int8 --- 0 -instance AsDigit Int8 where - digit = - digitIntegral - --- | --- --- >>> (5 :: Int16) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Int16) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Int16) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Int16) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Int16) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Int16 --- 5 --- --- >>> digitIntegral # D9 :: Int16 --- 9 --- --- >>> digitIntegral # D0 :: Int16 --- 0 -instance AsDigit Int16 where - digit = - digitIntegral - --- | --- --- >>> (5 :: Int32) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Int32) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Int32) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Int32) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Int32) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Int32 --- 5 --- --- >>> digitIntegral # D9 :: Int32 --- 9 --- --- >>> digitIntegral # D0 :: Int32 --- 0 -instance AsDigit Int32 where - digit = - digitIntegral - --- | --- --- >>> (5 :: Int64) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Int64) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Int64) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Int64) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Int64) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Int64 --- 5 --- --- >>> digitIntegral # D9 :: Int64 --- 9 --- --- >>> digitIntegral # D0 :: Int64 --- 0 -instance AsDigit Int64 where - digit = - digitIntegral - --- | --- --- >>> (5 :: Integer) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Integer) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Integer) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Integer) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Integer) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Integer --- 5 --- --- >>> digitIntegral # D9 :: Integer --- 9 --- --- >>> digitIntegral # D0 :: Integer --- 0 -instance AsDigit Integer where - digit = - digitIntegral - --- | --- --- >>> (5 :: Identity Int) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Identity Int) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Identity Int) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Identity Int) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Identity Int) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Identity Int --- Identity 5 --- --- >>> digitIntegral # D9 :: Identity Int --- Identity 9 --- --- >>> digitIntegral # D0 :: Identity Int --- Identity 0 -instance Integral a => AsDigit (Identity a) where - digit = - digitIntegral - --- | --- --- >>> (5 :: Const Int String) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Const Int String) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Const Int String) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Const Int String) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Const Int String) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Const Int String --- Const 5 --- --- >>> digitIntegral # D9 :: Const Int String --- Const 9 --- --- >>> digitIntegral # D0 :: Const Int String --- Const 0 -instance Integral a => AsDigit (Const a b) where - digit = - digitIntegral - --- | --- --- >>> (5 :: Word) ^? digitIntegral --- Just 5 --- --- >>> (0 :: Word) ^? digitIntegral --- Just 0 --- --- >>> (9 :: Word) ^? digitIntegral --- Just 9 --- --- >>> (10 :: Word) ^? digitIntegral --- Nothing --- --- >>> ((-5) :: Word) ^? digitIntegral --- Nothing --- --- >>> digitIntegral # D5 :: Word --- 5 --- --- >>> digitIntegral # D9 :: Word --- 9 --- --- >>> digitIntegral # D0 :: Word --- 0 -instance AsDigit Word where - digit = - digitIntegral - --- | --- --- >>> '5' ^? digit --- Just 5 --- --- >>> '0' ^? digit --- Just 0 --- --- >>> '9' ^? digit --- Just 9 --- --- >>> 'a' ^? digit --- Nothing --- --- >>> '@' ^? digit --- Nothing --- --- >>> digit # D5 :: Char --- '5' --- --- >>> digit # D9 :: Char --- '9' --- --- >>> digit # D0 :: Char --- '0' -instance AsDigit Char where - digit = - prism' - (\d -> case d of D0 -> '0' - D1 -> '1' - D2 -> '2' - D3 -> '3' - D4 -> '4' - D5 -> '5' - D6 -> '6' - D7 -> '7' - D8 -> '8' - D9 -> '9') - (\n -> case n of '0' -> Just D0 - '1' -> Just D1 - '2' -> Just D2 - '3' -> Just D3 - '4' -> Just D4 - '5' -> Just D5 - '6' -> Just D6 - '7' -> Just D7 - '8' -> Just D8 - '9' -> Just D9 - _ -> Nothing) - -class ManyDigit a where - digitT :: - Traversal' - a - Digit - -instance ManyDigit Digit where - digitT = - id - --- | Modulus with 10. --- --- >>> mod10 0 --- 0 --- --- >>> mod10 1 --- 1 --- --- >>> mod10 8 --- 8 --- --- >>> mod10 9 --- 9 --- --- >>> mod10 10 --- 0 --- --- >>> mod10 90 --- 0 --- --- >>> mod10 91 --- 1 --- --- >>> mod10 (-1) --- 9 --- --- >>> mod10 (-12) --- 8 -mod10 :: - Integral a => - a - -> Digit -mod10 n = - let r = n `mod` 10 - in fromMaybe (mod10 r) (r ^? digitIntegral) - --- | Absolute value of remainder 10. --- --- >>> absrem10 0 --- 0 --- --- >>> absrem10 1 --- 1 --- --- >>> absrem10 8 --- 8 --- --- >>> absrem10 9 --- 9 --- --- >>> absrem10 10 --- 0 --- --- >>> absrem10 90 --- 0 --- --- >>> absrem10 91 --- 1 --- --- >>> absrem10 (-1) --- 1 --- --- >>> absrem10 (-12) --- 2 -absrem10 :: - Integral a => - a - -> Digit -absrem10 n = - let r = abs n `rem` 10 - in fromMaybe (absrem10 r) (r ^? digitIntegral) - --- | Division/modulus with 10. --- --- >>> divMod10 0 --- (0,0) --- --- >>> divMod10 1 --- (0,1) --- --- >>> divMod10 8 --- (0,8) --- --- >>> divMod10 9 --- (0,9) --- --- >>> divMod10 10 --- (1,0) --- --- >>> divMod10 90 --- (9,0) --- --- >>> divMod10 91 --- (9,1) --- --- >>> divMod10 (-1) --- (-1,9) -divMod10 :: - Integral a => - a - -> (a, Digit) -divMod10 n = - let (x, r) = n `divMod` 10 - in (x, mod10 r) - -parsedigit :: - CharParsing p => - p Digit -parsedigit = - let p = asum ((\d -> d <$ char (digit # d)) <$> [D0 .. D9]) - in p "Digit" - --- | A QuasiQuoter for any range of @Digit@. --- --- [digitQ|4|] :: Digit --- 4 --- --- named [digitQ|4|] = "four" --- named [digitQ|$x|] = "not four, " ++ show x ++ " instead" --- --- mod10D x = let y = mod x 10 in [digitQ|$y|] -digitQ :: QuasiQuoter -digitQ = QuasiQuoter { - quoteExp = let dexp :: - [Char] - -> ExpQ - dexp ('$':vn) = - varE (mkName vn) - dexp (d:[]) = - maybe (error "not a digit") (dataToExpQ (const Nothing)) (d ^? digit) - dexp _ = - error "not a digit" - in dexp - , quotePat = let dpat :: - [Char] - -> PatQ - dpat ('$':vn) = - varP (mkName vn) - dpat (d:[]) = - maybe (error "not a digit") (dataToPatQ (const Nothing)) (d ^? digit) - dpat _ = - error "not a digit" - in dpat - , quoteType = - error "not quotable" - , quoteDec = - error "not quotable" - } - --- | --- --- >>> D0 /+/ D0 --- (0,0) --- --- >>> D0 /+/ D1 --- (0,1) --- --- >>> D1 /+/ D0 --- (0,1) --- --- >>> D4 /+/ D5 --- (0,9) --- --- >>> D5 /+/ D5 --- (1,0) --- --- >>> D5 /+/ D6 --- (1,1) --- --- >>> D8 /+/ D7 --- (1,5) --- --- >>> D9 /+/ D9 --- (1,8) -(/+/) :: - Digit - -> Digit - -> (Digit, Digit) -a /+/ b = - let (x, r) = divMod10 (digitIntegral # a + digitIntegral # b) - in (mod10 (x :: Integer), r) - ----- not exported -digitIntegral :: - Integral a => - Prism' a Digit -digitIntegral = - prism' - (\n -> case n of D0 -> 0 - D1 -> 1 - D2 -> 2 - D3 -> 3 - D4 -> 4 - D5 -> 5 - D6 -> 6 - D7 -> 7 - D8 -> 8 - D9 -> 9) - (\n -> case n of 0 -> Just D0 - 1 -> Just D1 - 2 -> Just D2 - 3 -> Just D3 - 4 -> Just D4 - 5 -> Just D5 - 6 -> Just D6 - 7 -> Just D7 - 8 -> Just D8 - 9 -> Just D9 - _ -> Nothing) +import Data.Digit.Binary +import Data.Digit.Decimal +import Data.Digit.Octal +import Data.Digit.Hexadecimal.LowerCase +import Data.Digit.Hexadecimal.UpperCase +import Data.Digit.Hexadecimal.MixedCase +import Data.Digit.Char +import Data.Digit.Enum +import Data.Digit.Integral +import Data.Digit.Natural diff --git a/src/Data/Digit/Binary.hs b/src/Data/Digit/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Binary.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Digit.Binary( + BinDigit(..) +, BinaryNoZero +, Binary +, parseBinaryNoZero +, parseBinary +-- * Prisms +, _BinDigit0 +, _BinDigit1 +-- * Re-exports +, module Data.Digit.Class.D0 +, module Data.Digit.Class.D1 +) where + +import Prelude (Eq, Show, Ord) +import Control.Lens.TH (makePrisms) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), choice) + +import Data.Digit.Class.D0 +import Data.Digit.Class.D1 + +data BinDigit + = BinDigit0 + | BinDigit1 + deriving (Show, Eq, Ord) + +makePrisms ''BinDigit + +instance D0 BinDigit where; d0 = _BinDigit0 +instance D1 BinDigit where; d1 = _BinDigit1 + +type BinaryNoZero d = + D1 d + +parseBinaryNoZero :: + (BinaryNoZero d, CharParsing p) => + p d +parseBinaryNoZero = + parse1 "BinaryNoZero" + +type Binary d = + (D0 d, BinaryNoZero d) + +parseBinary :: + (Binary d, CharParsing p) => + p d +parseBinary = + choice + [ + parse0 + , parseBinaryNoZero + ] "Binary" diff --git a/src/Data/Digit/Char.hs b/src/Data/Digit/Char.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Char.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Char( +-- * Binary + charBinaryNoZero +, charBinary +-- * Octal +, charOctalNoZero +, charOctal +-- * Decimal +, charDecimalNoZero +, charDecimal +-- * Hexadecimal +, charHexadecimalNoZero +, charHexadecimal +-- * HEXADECIMAL +, charHEXADECIMALNoZero +, charHEXADECIMAL +-- * HeXaDeCiMaL +, charHeXaDeCiMaLNoZero +, charHeXaDeCiMaL +) where + +import Prelude (Char, Eq, fst, lookup) + +import Control.Applicative (Applicative) +import Control.Lens (APrism, Choice, Prism', clonePrism, + prism', ( # )) +import Control.Lens.Extras (is) + +import Data.Foldable (find) +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) + +import Data.Digit.Binary as D +import Data.Digit.Decimal as D +import Data.Digit.Hexadecimal.LowerCase as D +import Data.Digit.Hexadecimal.UpperCase as D +import Data.Digit.Hexadecimal.MixedCase as D +import Data.Digit.Octal as D + +-- $setup +-- >>> import Data.Digit + +-- | +-- +-- >>> '1' ^? charBinaryNoZero :: Maybe BinDigit +-- Just BinDigit1 +-- +-- >>> charBinaryNoZero # BinDigit1 +-- '1' +charBinaryNoZero :: + BinaryNoZero d => + Prism' + Char + d +charBinaryNoZero = + associatePrism ('1', d1) [] + +-- | +-- +-- >>> '0' ^? charBinary :: Maybe BinDigit +-- Just BinDigit0 +-- +-- >>> charBinary # BinDigit0 :: Char +-- '0' +charBinary :: + Binary d => + Prism' + Char + d +charBinary = + associatePrism ('0', d0) [('1', d1)] + +-- | +-- +-- >>> '6' ^? charOctalNoZero :: Maybe OctDigit +-- Just OctDigit6 +-- +-- >>> charOctalNoZero # OctDigit5 :: Char +-- '5' +charOctalNoZero :: + OctalNoZero d => + Prism' + Char + d +charOctalNoZero = + associatePrism ('1', d1) [('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7)] + +-- | +-- >>> '7' ^? charOctal :: Maybe OctDigit +-- Just OctDigit7 +-- +-- >>> charOctal # OctDigit7 :: Char +-- '7' +charOctal :: + Octal d => + Prism' + Char + d +charOctal = + associatePrism ('0', d0) [('1', d1), ('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7)] + +-- | +-- >>> '9' ^? charDecimalNoZero :: Maybe DecDigit +-- Just DecDigit9 +-- +-- >>> charDecimalNoZero # DecDigit9 :: Char +-- '9' +charDecimalNoZero :: + DecimalNoZero d => + Prism' + Char + d +charDecimalNoZero = + associatePrism ('1', d1) [('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9)] + +-- | +-- >>> '9' ^? charDecimal :: Maybe DecDigit +-- Just DecDigit9 +-- +-- >>> charDecimal # DecDigit9 :: Char +-- '9' +charDecimal :: + Decimal d => + Prism' + Char + d +charDecimal = + associatePrism ('0', d0) [('1', d1), ('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9)] + +-- | +-- >>> 'f' ^? charHexadecimalNoZero :: Maybe HexDigit +-- Just HexDigitf +-- +-- >>> charHexadecimalNoZero # HexDigitf :: Char +-- 'f' +charHexadecimalNoZero :: + HexadecimalNoZero d => + Prism' + Char + d +charHexadecimalNoZero = + associatePrism ('1', d1) [('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9), ('a', da), ('b', db), ('c', dc), ('d', dd), ('e', de), ('f', df)] + +-- | +-- >>> 'f' ^? charHexadecimal :: Maybe HexDigit +-- Just HexDigitf +-- +-- >>> charHexadecimal # HexDigitf :: Char +-- 'f' +charHexadecimal :: + Hexadecimal d => + Prism' + Char + d +charHexadecimal = + associatePrism ('0', d0) [('1', d1), ('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9), ('a', da), ('b', db), ('c', dc), ('d', dd), ('e', de), ('f', df)] + +-- | +-- >>> 'F' ^? charHEXADECIMALNoZero :: Maybe HEXDigit +-- Just HEXDigitF +-- +-- >>> charHEXADECIMALNoZero # HEXDigitF :: Char +-- 'F' +charHEXADECIMALNoZero :: + HEXADECIMALNoZero d => + Prism' + Char + d +charHEXADECIMALNoZero = + associatePrism ('1', d1) [('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9), ('A', dA), ('B', dB), ('C', dC), ('D', dD), ('E', dE), ('F', dF)] + +-- | +-- >>> 'F' ^? charHEXADECIMAL :: Maybe HEXDigit +-- Just HEXDigitF +-- +-- >>> charHEXADECIMAL # HEXDigitF :: Char +-- 'F' +charHEXADECIMAL :: + HEXADECIMAL d => + Prism' + Char + d +charHEXADECIMAL = + associatePrism ('0', d0) [('1', d1), ('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9), ('A', dA), ('B', dB), ('C', dC), ('D', dD), ('E', dE), ('F', dF)] + +-- | +-- >>> 'f' ^? charHeXaDeCiMaLNoZero :: Maybe HeXDigit +-- Just HeXDigitf +-- +-- >>> 'F' ^? charHeXaDeCiMaLNoZero :: Maybe HeXDigit +-- Just HeXDigitF +-- +-- >>> charHeXaDeCiMaLNoZero # HeXDigitf :: Char +-- 'f' +-- +-- >>> charHeXaDeCiMaLNoZero # HeXDigitF :: Char +-- 'F' +charHeXaDeCiMaLNoZero :: + HeXaDeCiMaLNoZero d => + Prism' + Char + d +charHeXaDeCiMaLNoZero = + associatePrism ('1', d1) [('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9), ('a', da), ('b', db), ('c', dc), ('d', dd), ('e', de), ('f', df), ('A', dA), ('B', dB), ('C', dC), ('D', dD), ('E', dE), ('F', dF)] + + +-- | +-- >>> 'f' ^? charHeXaDeCiMaL :: Maybe HeXDigit +-- Just HeXDigitf +-- +-- >>> 'F' ^? charHeXaDeCiMaL :: Maybe HeXDigit +-- Just HeXDigitF +-- +-- >>> charHeXaDeCiMaL # HeXDigitf :: Char +-- 'f' +-- +-- >>> charHeXaDeCiMaL # HeXDigitF :: Char +-- 'F' +charHeXaDeCiMaL :: + HeXaDeCiMaL d => + Prism' + Char + d +charHeXaDeCiMaL = + associatePrism ('0', d0) [('1', d1), ('2', d2), ('3', d3), ('4', d4), ('5', d5), ('6', d6), ('7', d7), ('8', d8), ('9', d9), ('a', da), ('b', db), ('c', dc), ('d', dd), ('e', de), ('f', df), ('A', dA), ('B', dB), ('C', dC), ('D', dD), ('E', dE), ('F', dF)] + +---- not exported +associatePrism :: + (Eq b, Choice p, Applicative f) => + (b, APrism a a () ()) + -> [(b, APrism a a () ())] + -> p a (f a) + -> p b (f b) +associatePrism def z = + prism' + (\d -> fst (fromMaybe def (find (\(_, w) -> is w d) z))) + (\i -> (\p -> clonePrism p # ()) <$> lookup i (def:z)) diff --git a/src/Data/Digit/Class/D0.hs b/src/Data/Digit/Class/D0.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D0.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Digit.Class.D0( + D0(..) +, parse0 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D0 d where + d0 :: + Prism' + d + () + x0 :: + d + x0 = + d0 # () + +instance D0 () where + d0 = + id + +-- | +-- +-- >>> parse (parse0 <* eof) "test" "0" :: Either ParseError BinDigit +-- Right BinDigit0 +-- +-- >>> parse parse0 "test" "0xyz" :: Either ParseError BinDigit +-- Right BinDigit0 +-- +-- >>> isn't _Right (parse parse0 "test" "xyz" :: Either ParseError BinDigit) +-- True +parse0 :: + (D0 d, CharParsing p) => + p d +parse0 = + x0 <$ char '0' "0" diff --git a/src/Data/Digit/Class/D1.hs b/src/Data/Digit/Class/D1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D1.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D1( + D1(..) +, parse1 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D1 d where + d1 :: + Prism' + d + () + x1 :: + d + x1 = + d1 # () + +instance D1 () where + d1 = + id + +-- | +-- +-- >>> parse (parse1 <* eof) "test" "1" :: Either ParseError BinDigit +-- Right BinDigit1 +-- +-- >>> parse parse1 "test" "1xyz" :: Either ParseError BinDigit +-- Right BinDigit1 +-- +-- >>> isn't _Right (parse parse1 "test" "xyz" :: Either ParseError BinDigit) +-- True +parse1 :: + (D1 d, CharParsing p) => + p d +parse1 = + x1 <$ char '1' "1" diff --git a/src/Data/Digit/Class/D2.hs b/src/Data/Digit/Class/D2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D2.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D2( + D2(..) +, parse2 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D2 d where + d2 :: + Prism' + d + () + x2 :: + d + x2 = + d2 # () + +instance D2 () where + d2 = + id + +-- | +-- +-- >>> parse (parse2 <* eof) "test" "2" :: Either ParseError DecDigit +-- Right DecDigit2 +-- +-- >>> parse parse2 "test" "2xyz" :: Either ParseError DecDigit +-- Right DecDigit2 +-- +-- >>> isn't _Right (parse parse2 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse2 :: + (D2 d, CharParsing p) => + p d +parse2 = + x2 <$ char '2' "2" diff --git a/src/Data/Digit/Class/D3.hs b/src/Data/Digit/Class/D3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D3.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D3( + D3(..) +, parse3 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D3 d where + d3 :: + Prism' + d + () + x3 :: + d + x3 = + d3 # () + +instance D3 () where + d3 = + id + +-- | +-- +-- >>> parse (parse3 <* eof) "test" "3" :: Either ParseError DecDigit +-- Right DecDigit3 +-- +-- >>> parse parse3 "test" "3xyz" :: Either ParseError DecDigit +-- Right DecDigit3 +-- +-- >>> isn't _Right (parse parse3 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse3 :: + (D3 d, CharParsing p) => + p d +parse3 = + x3 <$ char '3' "3" diff --git a/src/Data/Digit/Class/D4.hs b/src/Data/Digit/Class/D4.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D4.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D4( + D4(..) +, parse4 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D4 d where + d4 :: + Prism' + d + () + x4 :: + d + x4 = + d4 # () + +instance D4 () where + d4 = + id + +-- | +-- +-- >>> parse (parse4 <* eof) "test" "4" :: Either ParseError DecDigit +-- Right DecDigit4 +-- +-- >>> parse parse4 "test" "4xyz" :: Either ParseError DecDigit +-- Right DecDigit4 +-- +-- >>> isn't _Right (parse parse4 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse4 :: + (D4 d, CharParsing p) => + p d +parse4 = + x4 <$ char '4' "4" diff --git a/src/Data/Digit/Class/D5.hs b/src/Data/Digit/Class/D5.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D5.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D5( + D5(..) +, parse5 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D5 d where + d5 :: + Prism' + d + () + x5 :: + d + x5 = + d5 # () + +instance D5 () where + d5 = + id + +-- | +-- +-- >>> parse (parse5 <* eof) "test" "5" :: Either ParseError DecDigit +-- Right DecDigit5 +-- +-- >>> parse parse5 "test" "5xyz" :: Either ParseError DecDigit +-- Right DecDigit5 +-- +-- >>> isn't _Right (parse parse5 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse5 :: + (D5 d, CharParsing p) => + p d +parse5 = + x5 <$ char '5' "5" diff --git a/src/Data/Digit/Class/D6.hs b/src/Data/Digit/Class/D6.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D6.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D6( + D6(..) +, parse6 +) where + + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D6 d where + d6 :: + Prism' + d + () + x6 :: + d + x6 = + d6 # () + +instance D6 () where + d6 = + id + +-- | +-- +-- >>> parse (parse6 <* eof) "test" "6" :: Either ParseError DecDigit +-- Right DecDigit6 +-- +-- >>> parse parse6 "test" "6xyz" :: Either ParseError DecDigit +-- Right DecDigit6 +-- +-- >>> isn't _Right (parse parse6 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse6 :: + (D6 d, CharParsing p) => + p d +parse6 = + x6 <$ char '6' "6" diff --git a/src/Data/Digit/Class/D7.hs b/src/Data/Digit/Class/D7.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D7.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D7( + D7(..) +, parse7 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D7 d where + d7 :: + Prism' + d + () + x7 :: + d + x7 = + d7 # () + +instance D7 () where + d7 = + id + +-- | +-- +-- >>> parse (parse7 <* eof) "test" "7" :: Either ParseError DecDigit +-- Right DecDigit7 +-- +-- >>> parse parse7 "test" "7xyz" :: Either ParseError DecDigit +-- Right DecDigit7 +-- +-- >>> isn't _Right (parse parse7 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse7 :: + (D7 d, CharParsing p) => + p d +parse7 = + x7 <$ char '7' "7" diff --git a/src/Data/Digit/Class/D8.hs b/src/Data/Digit/Class/D8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D8.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D8( + D8(..) +, parse8 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D8 d where + d8 :: + Prism' + d + () + x8 :: + d + x8 = + d8 # () + +instance D8 () where + d8 = + id + +-- | +-- +-- >>> parse (parse8 <* eof) "test" "8" :: Either ParseError DecDigit +-- Right DecDigit8 +-- +-- >>> parse parse8 "test" "8xyz" :: Either ParseError DecDigit +-- Right DecDigit8 +-- +-- >>> isn't _Right (parse parse8 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse8 :: + (D8 d, CharParsing p) => + p d +parse8 = + x8 <$ char '8' "8" diff --git a/src/Data/Digit/Class/D9.hs b/src/Data/Digit/Class/D9.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/D9.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.D9( + D9(..) +, parse9 +) where + +import Control.Category (id) +import Control.Lens (Prism', (#)) + +import Data.Functor ((<$)) + +import Text.Parser.Char(CharParsing, char) +import Text.Parser.Combinators(()) + +-- $setup +-- >>> import Data.Digit.Class +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class D9 d where + d9 :: + Prism' + d + () + x9 :: + d + x9 = + d9 # () + +instance D9 () where + d9 = + id + +-- | +-- +-- >>> parse (parse9 <* eof) "test" "9" :: Either ParseError DecDigit +-- Right DecDigit9 +-- +-- >>> parse parse9 "test" "9xyz" :: Either ParseError DecDigit +-- Right DecDigit9 +-- +-- >>> isn't _Right (parse parse9 "test" "xyz" :: Either ParseError DecDigit) +-- True +parse9 :: + (D9 d, CharParsing p) => + p d +parse9 = + x9 <$ char '9' "9" diff --git a/src/Data/Digit/Class/LowerCase.hs b/src/Data/Digit/Class/LowerCase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/LowerCase.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.LowerCase ( + + -- * Classes + Da(..) + , Db(..) + , Dc(..) + , Dd(..) + , De(..) + , Df(..) + + -- * Parsers + , parsea + , parseb + , parsec + , parsed + , parsee + , parsef + +) where + +import Control.Category (id) +import Control.Lens (Prism', ( # )) + +import Data.Functor ((<$)) + +import Text.Parser.Char (CharParsing, char) +import Text.Parser.Combinators (()) + +-- $setup +-- >>> import Data.Digit +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class Da d where + da :: + Prism' + d + () + xa :: + d + xa = + da # () + +instance Da () where + da = + id + +class Db d where + db :: + Prism' + d + () + xb :: + d + xb = + db # () + +instance Db () where + db = + id + +class Dc d where + dc :: + Prism' + d + () + xc :: + d + xc = + dc # () + +instance Dc () where + dc = + id + +class Dd d where + dd :: + Prism' + d + () + xd :: + d + xd = + dd # () + +instance Dd () where + dd = + id + +class De d where + de :: + Prism' + d + () + xe :: + d + xe = + de # () + +instance De () where + de = + id + +class Df d where + df :: + Prism' + d + () + xf :: + d + xf = + df # () + +instance Df () where + df = + id + +-- | +-- +-- >>> parse (parsea <* eof) "test" "a" :: Either ParseError HexDigit +-- Right HexDigita +-- +-- >>> parse parsea "test" "axyz" :: Either ParseError HexDigit +-- Right HexDigita +-- +-- >>> isn't _Right (parse parsea "test" "xyz" :: Either ParseError HexDigit) +-- True +parsea :: + (Da d, CharParsing p) => + p d +parsea = + xa <$ char 'a' "a" + +-- | +-- +-- >>> parse (parseb <* eof) "test" "b" :: Either ParseError HexDigit +-- Right HexDigitb +-- +-- >>> parse parseb "test" "bxyz" :: Either ParseError HexDigit +-- Right HexDigitb +-- +-- >>> isn't _Right (parse parseb "test" "xyz" :: Either ParseError HexDigit) +-- True +parseb :: + (Db d, CharParsing p) => + p d +parseb = + xb <$ char 'b' "b" + +-- | +-- +-- >>> parse (parsec <* eof) "test" "c" :: Either ParseError HexDigit +-- Right HexDigitc +-- +-- >>> parse parsec "test" "cxyz" :: Either ParseError HexDigit +-- Right HexDigitc +-- +-- >>> isn't _Right (parse parsec "test" "xyz" :: Either ParseError HexDigit) +-- True +parsec :: + (Dc d, CharParsing p) => + p d +parsec = + xc <$ char 'c' "c" + +-- | +-- +-- >>> parse (parsed <* eof) "test" "d" :: Either ParseError HexDigit +-- Right HexDigitd +-- +-- >>> parse parsed "test" "dxyz" :: Either ParseError HexDigit +-- Right HexDigitd +-- +-- >>> isn't _Right (parse parsed "test" "xyz" :: Either ParseError HexDigit) +-- True +parsed :: + (Dd d, CharParsing p) => + p d +parsed = + xd <$ char 'd' "d" + +-- | +-- +-- >>> parse (parsee <* eof) "test" "e" :: Either ParseError HexDigit +-- Right HexDigite +-- +-- >>> parse parsee "test" "exyz" :: Either ParseError HexDigit +-- Right HexDigite +-- +-- >>> isn't _Right (parse parsee "test" "xyz" :: Either ParseError HexDigit) +-- True +parsee :: + (De d, CharParsing p) => + p d +parsee = + xe <$ char 'e' "e" + +-- | +-- +-- >>> parse (parsef <* eof) "test" "f" :: Either ParseError HexDigit +-- Right HexDigitf +-- +-- >>> parse parsef "test" "fxyz" :: Either ParseError HexDigit +-- Right HexDigitf +-- +-- >>> isn't _Right (parse parsef "test" "xyz" :: Either ParseError HexDigit) +-- True +parsef :: + (Df d, CharParsing p) => + p d +parsef = + xf <$ char 'f' "f" diff --git a/src/Data/Digit/Class/MixedCase.hs b/src/Data/Digit/Class/MixedCase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/MixedCase.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Digit.Class.MixedCase + ( + -- * Types + DAa + , DBb + , DCc + , DDd + , DEe + , DFf + + -- * Parsers + , parseAa + , parseBb + , parseCc + , parseDd + , parseEe + , parseFf + + -- * Re-exports + , module Data.Digit.Class.UpperCase + , module Data.Digit.Class.LowerCase + + ) where + +import Text.Parser.Char (CharParsing) +import Text.Parser.Combinators (choice, ()) + +import Data.Digit.Class.LowerCase +import Data.Digit.Class.UpperCase + +-- $setup +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) +-- >>> import Data.Digit +-- >>> import Papa + +type DAa a = + (DA a, Da a) + +type DBb a = + (DB a, Db a) + +type DCc a = + (DC a, Dc a) + +type DDd a = + (DD a, Dd a) + +type DEe a = + (DE a, De a) + +type DFf a = + (DF a, Df a) + +-- | +-- +-- >>> parse (parseAa <* eof) "test" "A" :: Either ParseError HeXDigit +-- Right HeXDigitA +-- +-- >>> parse parseAa "test" "Axyz" :: Either ParseError HeXDigit +-- Right HeXDigitA +-- +-- >>> parse (parseAa <* eof) "test" "a" :: Either ParseError HeXDigit +-- Right HeXDigita +-- +-- >>> parse parseAa "test" "axyz" :: Either ParseError HeXDigit +-- Right HeXDigita +-- +-- >>> isn't _Right (parse parseAa "test" "xyz" :: Either ParseError HeXDigit) +-- True +parseAa :: + (DAa d, CharParsing p) => + p d +parseAa = + choice [parseA, parsea] "Aa" + +-- | +-- +-- >>> parse (parseBb <* eof) "test" "B" :: Either ParseError HeXDigit +-- Right HeXDigitB +-- +-- >>> parse parseBb "test" "Bxyz" :: Either ParseError HeXDigit +-- Right HeXDigitB +-- +-- >>> parse (parseBb <* eof) "test" "b" :: Either ParseError HeXDigit +-- Right HeXDigitb +-- +-- >>> parse parseBb "test" "bxyz" :: Either ParseError HeXDigit +-- Right HeXDigitb +-- +-- >>> isn't _Right (parse parseBb "test" "xyz" :: Either ParseError HeXDigit) +-- True +parseBb :: + (DBb d, CharParsing p) => + p d +parseBb = + choice [parseB, parseb] "Bb" + +-- | +-- +-- >>> parse (parseCc <* eof) "test" "C" :: Either ParseError HeXDigit +-- Right HeXDigitC +-- +-- >>> parse parseCc "test" "Cxyz" :: Either ParseError HeXDigit +-- Right HeXDigitC +-- +-- >>> parse (parseCc <* eof) "test" "c" :: Either ParseError HeXDigit +-- Right HeXDigitc +-- +-- >>> parse parseCc "test" "cxyz" :: Either ParseError HeXDigit +-- Right HeXDigitc +-- +-- >>> isn't _Right (parse parseCc "test" "xyz" :: Either ParseError HeXDigit) +-- True +parseCc :: + (DCc d, CharParsing p) => + p d +parseCc = + choice [parseC, parsec] "Cc" + + +-- | +-- +-- >>> parse (parseDd <* eof) "test" "D" :: Either ParseError HeXDigit +-- Right HeXDigitD +-- +-- >>> parse parseDd "test" "Dxyz" :: Either ParseError HeXDigit +-- Right HeXDigitD +-- +-- >>> parse (parseDd <* eof) "test" "d" :: Either ParseError HeXDigit +-- Right HeXDigitd +-- +-- >>> parse parseDd "test" "dxyz" :: Either ParseError HeXDigit +-- Right HeXDigitd +-- +-- >>> isn't _Right (parse parseDd "test" "xyz" :: Either ParseError HeXDigit) +-- True +parseDd :: + (DDd d, CharParsing p) => + p d +parseDd = + choice [parseD, parsed] "Dd" + +-- | +-- +-- >>> parse (parseEe <* eof) "test" "E" :: Either ParseError HeXDigit +-- Right HeXDigitE +-- +-- >>> parse parseEe "test" "Exyz" :: Either ParseError HeXDigit +-- Right HeXDigitE +-- +-- >>> parse (parseEe <* eof) "test" "e" :: Either ParseError HeXDigit +-- Right HeXDigite +-- +-- >>> parse parseEe "test" "exyz" :: Either ParseError HeXDigit +-- Right HeXDigite +-- +-- >>> isn't _Right (parse parseEe "test" "xyz" :: Either ParseError HeXDigit) +-- True +parseEe :: + (DEe d, CharParsing p) => + p d +parseEe = + choice [parseE, parsee] "Ee" + +-- | +-- +-- >>> parse (parseFf <* eof) "test" "F" :: Either ParseError HeXDigit +-- Right HeXDigitF +-- +-- >>> parse parseFf "test" "Fxyz" :: Either ParseError HeXDigit +-- Right HeXDigitF +-- +-- >>> parse (parseFf <* eof) "test" "f" :: Either ParseError HeXDigit +-- Right HeXDigitf +-- +-- >>> parse parseFf "test" "fxyz" :: Either ParseError HeXDigit +-- Right HeXDigitf +-- +-- >>> isn't _Right (parse parseFf "test" "xyz" :: Either ParseError HeXDigit) +-- True +parseFf :: + (DFf d, CharParsing p) => + p d +parseFf = + choice [parseF, parsef] "Ff" diff --git a/src/Data/Digit/Class/UpperCase.hs b/src/Data/Digit/Class/UpperCase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Class/UpperCase.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Class.UpperCase + ( + -- * Classes + DA(..) + , DB(..) + , DC(..) + , DD(..) + , DE(..) + , DF(..) + + -- * Parsers + , parseA + , parseB + , parseC + , parseD + , parseE + , parseF + ) where + +import Control.Category (id) +import Control.Lens (Prism', ( # )) + +import Data.Functor ((<$)) + +import Text.Parser.Char (CharParsing, char) +import Text.Parser.Combinators (()) + +-- $setup +-- >>> import Data.Digit +-- >>> import Text.Parsec(parse, ParseError, eof) +-- >>> import Data.Void(Void) + +class DA d where + dA :: + Prism' + d + () + xA :: + d + xA = + dA # () + +instance DA () where + dA = + id + +class DB d where + dB :: + Prism' + d + () + xB :: + d + xB = + dB # () + +instance DB () where + dB = + id + +class DC d where + dC :: + Prism' + d + () + xC :: + d + xC = + dC # () + +instance DC () where + dC = + id + +class DD d where + dD :: + Prism' + d + () + xD :: + d + xD = + dD # () + +instance DD () where + dD = + id + +class DE d where + dE :: + Prism' + d + () + xE :: + d + xE = + dE # () + +instance DE () where + dE = + id + +class DF d where + dF :: + Prism' + d + () + xF :: + d + xF = + dF # () + +instance DF () where + dF = + id + +-- | +-- +-- >>> parse (parseA <* eof) "test" "A" :: Either ParseError HEXDigit +-- Right HEXDigitA +-- +-- >>> parse parseA "test" "Axyz" :: Either ParseError HEXDigit +-- Right HEXDigitA +-- +-- >>> isn't _Right (parse parseA "test" "xyz" :: Either ParseError HEXDigit) +-- True +parseA :: + (DA d, CharParsing p) => + p d +parseA = + xA <$ char 'A' "A" + +-- | +-- +-- >>> parse (parseB <* eof) "test" "B" :: Either ParseError HEXDigit +-- Right HEXDigitB +-- +-- >>> parse parseB "test" "Bxyz" :: Either ParseError HEXDigit +-- Right HEXDigitB +-- +-- >>> isn't _Right (parse parseB "test" "xyz" :: Either ParseError HEXDigit) +-- True +parseB :: + (DB d, CharParsing p) => + p d +parseB = + xB <$ char 'B' "B" + +-- | +-- +-- >>> parse (parseC <* eof) "test" "C" :: Either ParseError HEXDigit +-- Right HEXDigitC +-- +-- >>> parse parseC "test" "Cxyz" :: Either ParseError HEXDigit +-- Right HEXDigitC +-- +-- >>> isn't _Right (parse parseC "test" "xyz" :: Either ParseError HEXDigit) +-- True +parseC :: + (DC d, CharParsing p) => + p d +parseC = + xC <$ char 'C' "C" + +-- | +-- +-- >>> parse (parseD <* eof) "test" "D" :: Either ParseError HEXDigit +-- Right HEXDigitD +-- +-- >>> parse parseD "test" "Dxyz" :: Either ParseError HEXDigit +-- Right HEXDigitD +-- +-- >>> isn't _Right (parse parseD "test" "xyz" :: Either ParseError HEXDigit) +-- True +parseD :: + (DD d, CharParsing p) => + p d +parseD = + xD <$ char 'D' "D" + +-- | +-- +-- >>> parse (parseE <* eof) "test" "E" :: Either ParseError HEXDigit +-- Right HEXDigitE +-- +-- >>> parse parseE "test" "Exyz" :: Either ParseError HEXDigit +-- Right HEXDigitE +-- +-- >>> isn't _Right (parse parseE "test" "xyz" :: Either ParseError HEXDigit) +-- True +parseE :: + (DE d, CharParsing p) => + p d +parseE = + xE <$ char 'E' "E" + +-- | +-- +-- >>> parse (parseF <* eof) "test" "F" :: Either ParseError HEXDigit +-- Right HEXDigitF +-- +-- >>> parse parseF "test" "Fxyz" :: Either ParseError HEXDigit +-- Right HEXDigitF +-- +-- >>> isn't _Right (parse parseF "test" "xyz" :: Either ParseError HEXDigit) +-- True +parseF :: + (DF d, CharParsing p) => + p d +parseF = + xF <$ char 'F' "F" diff --git a/src/Data/Digit/Decimal.hs b/src/Data/Digit/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Decimal.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Digit.Decimal( + DecDigit(..) +, DecDigitNoZero(..) +, DecimalNoZero +, Decimal +, parseDecimalNoZero +, parseDecimal +-- * Prisms +, _DecDigit0 +, _DecDigit1 +, _DecDigit2 +, _DecDigit3 +, _DecDigit4 +, _DecDigit5 +, _DecDigit6 +, _DecDigit7 +, _DecDigit8 +, _DecDigit9 +-- * Re-exports +, module Data.Digit.Class.D0 +, module Data.Digit.Class.D1 +, module Data.Digit.Class.D2 +, module Data.Digit.Class.D3 +, module Data.Digit.Class.D4 +, module Data.Digit.Class.D5 +, module Data.Digit.Class.D6 +, module Data.Digit.Class.D7 +, module Data.Digit.Class.D8 +, module Data.Digit.Class.D9 +) where + +import Prelude (Eq, Show, Ord, Enum, Bounded) +import Control.Lens.TH (makePrisms) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), choice) + +import Data.Digit.Class.D0 +import Data.Digit.Class.D1 +import Data.Digit.Class.D2 +import Data.Digit.Class.D3 +import Data.Digit.Class.D4 +import Data.Digit.Class.D5 +import Data.Digit.Class.D6 +import Data.Digit.Class.D7 +import Data.Digit.Class.D8 +import Data.Digit.Class.D9 + +data DecDigit + = DecDigit0 + | DecDigit1 + | DecDigit2 + | DecDigit3 + | DecDigit4 + | DecDigit5 + | DecDigit6 + | DecDigit7 + | DecDigit8 + | DecDigit9 + deriving (Show, Eq, Ord, Enum, Bounded) + +makePrisms ''DecDigit + +instance D0 DecDigit where; d0 = _DecDigit0 +instance D1 DecDigit where; d1 = _DecDigit1 +instance D2 DecDigit where; d2 = _DecDigit2 +instance D3 DecDigit where; d3 = _DecDigit3 +instance D4 DecDigit where; d4 = _DecDigit4 +instance D5 DecDigit where; d5 = _DecDigit5 +instance D6 DecDigit where; d6 = _DecDigit6 +instance D7 DecDigit where; d7 = _DecDigit7 +instance D8 DecDigit where; d8 = _DecDigit8 +instance D9 DecDigit where; d9 = _DecDigit9 + +data DecDigitNoZero = + DecDigitNoZero1 + | DecDigitNoZero2 + | DecDigitNoZero3 + | DecDigitNoZero4 + | DecDigitNoZero5 + | DecDigitNoZero6 + | DecDigitNoZero7 + | DecDigitNoZero8 + | DecDigitNoZero9 + deriving (Show, Eq, Ord, Enum, Bounded) + +makePrisms ''DecDigitNoZero + +instance D1 DecDigitNoZero where; d1 = _DecDigitNoZero1 +instance D2 DecDigitNoZero where; d2 = _DecDigitNoZero2 +instance D3 DecDigitNoZero where; d3 = _DecDigitNoZero3 +instance D4 DecDigitNoZero where; d4 = _DecDigitNoZero4 +instance D5 DecDigitNoZero where; d5 = _DecDigitNoZero5 +instance D6 DecDigitNoZero where; d6 = _DecDigitNoZero6 +instance D7 DecDigitNoZero where; d7 = _DecDigitNoZero7 +instance D8 DecDigitNoZero where; d8 = _DecDigitNoZero8 +instance D9 DecDigitNoZero where; d9 = _DecDigitNoZero9 + +type DecimalNoZero d = + (D1 d, D2 d, D3 d, D4 d, D5 d, D6 d, D7 d, D8 d, D9 d) + +parseDecimalNoZero :: + (DecimalNoZero d, CharParsing p) => + p d +parseDecimalNoZero = + choice + [ + parse1 + , parse2 + , parse3 + , parse4 + , parse5 + , parse6 + , parse7 + , parse8 + , parse9 + ] "DecimalNoZero" + +type Decimal d = + (D0 d, DecimalNoZero d) + +parseDecimal :: + (Decimal d, CharParsing p) => + p d +parseDecimal = + choice + [ + parse0 + , parseDecimalNoZero + ] "Decimal" diff --git a/src/Data/Digit/Enum.hs b/src/Data/Digit/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Enum.hs @@ -0,0 +1,169 @@ +module Data.Digit.Enum + ( -- * Binary + enumBinaryNoZero + , enumBinary + -- * Octal + , enumOctalNoZero + , enumOctal + -- * Decimal + , enumDecimalNoZero + , enumDecimal + -- * Hexadecimal + , enumHexadecimalNoZero + , enumHexadecimal + -- * HEXADECIMAL + , enumHEXADECIMALNoZero + , enumHEXADECIMAL + ) +where + +import Control.Lens.Review ((#)) +import Data.Digit.Binary +import Data.Digit.Decimal +import Data.Digit.Hexadecimal.LowerCase +import Data.Digit.Hexadecimal.UpperCase +import Data.Digit.Octal + +-- | @[1]@ +enumBinaryNoZero :: BinaryNoZero d => [d] +enumBinaryNoZero = [d1 # ()] + +-- | @[0, 1]@ +enumBinary :: Binary d => [d] +enumBinary = [d0 # (), d1 # ()] + +-- | @[1..7]@ +enumOctalNoZero :: OctalNoZero d => [d] +enumOctalNoZero = + [ d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + ] + +-- | @[0..7]@ +enumOctal :: Octal d => [d] +enumOctal = + [ d0 # () + , d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + ] + +-- | @[1..9]@ +enumDecimalNoZero :: DecimalNoZero d => [d] +enumDecimalNoZero = + [ d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + , d8 # () + , d9 # () + ] + +-- | @[0..9]@ +enumDecimal :: Decimal d => [d] +enumDecimal = + [ d0 # () + , d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + , d8 # () + , d9 # () + ] + +-- | @[1..9] ++ [a..f]@ +enumHexadecimalNoZero :: HexadecimalNoZero d => [d] +enumHexadecimalNoZero = + [ d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + , d8 # () + , d9 # () + , da # () + , db # () + , dc # () + , dd # () + , de # () + , df # () + ] + +-- | @[0..9] ++ [a..f]@ +enumHexadecimal :: Hexadecimal d => [d] +enumHexadecimal = + [ d0 # () + , d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + , d8 # () + , d9 # () + , da # () + , db # () + , dc # () + , dd # () + , de # () + , df # () + ] + +-- | @[1..9] ++ [A..F]@ +enumHEXADECIMALNoZero :: HEXADECIMALNoZero d => [d] +enumHEXADECIMALNoZero = + [ d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + , d8 # () + , d9 # () + , dA # () + , dB # () + , dC # () + , dD # () + , dE # () + , dF # () + ] + +-- | @[0..9] ++ [A..F]@ +enumHEXADECIMAL :: HEXADECIMAL d => [d] +enumHEXADECIMAL = + [ d0 # () + , d1 # () + , d2 # () + , d3 # () + , d4 # () + , d5 # () + , d6 # () + , d7 # () + , d8 # () + , d9 # () + , dA # () + , dB # () + , dC # () + , dD # () + , dE # () + , dF # () + ] diff --git a/src/Data/Digit/Hexadecimal/LowerCase.hs b/src/Data/Digit/Hexadecimal/LowerCase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Hexadecimal/LowerCase.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Digit.Hexadecimal.LowerCase( + HexDigit(..) +, HexadecimalNoZero +, Hexadecimal +, parseHexadecimalNoZero +, parseHexadecimal +-- * Prisms +, _HexDigit0 +, _HexDigit1 +, _HexDigit2 +, _HexDigit3 +, _HexDigit4 +, _HexDigit5 +, _HexDigit6 +, _HexDigit7 +, _HexDigit8 +, _HexDigit9 +, _HexDigita +, _HexDigitb +, _HexDigitc +, _HexDigitd +, _HexDigite +, _HexDigitf +-- * Re-exports +, module Data.Digit.Class.D0 +, module Data.Digit.Class.D1 +, module Data.Digit.Class.D2 +, module Data.Digit.Class.D3 +, module Data.Digit.Class.D4 +, module Data.Digit.Class.D5 +, module Data.Digit.Class.D6 +, module Data.Digit.Class.D7 +, module Data.Digit.Class.D8 +, module Data.Digit.Class.D9 + +, module Data.Digit.Class.LowerCase +) where + +import Prelude (Eq, Show, Ord) +import Control.Lens.TH (makePrisms) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), choice) + +import Data.Digit.Class.D0 +import Data.Digit.Class.D1 +import Data.Digit.Class.D2 +import Data.Digit.Class.D3 +import Data.Digit.Class.D4 +import Data.Digit.Class.D5 +import Data.Digit.Class.D6 +import Data.Digit.Class.D7 +import Data.Digit.Class.D8 +import Data.Digit.Class.D9 +import Data.Digit.Class.LowerCase + +import Data.Digit.Decimal(parseDecimalNoZero) + +data HexDigit + = HexDigit0 + | HexDigit1 + | HexDigit2 + | HexDigit3 + | HexDigit4 + | HexDigit5 + | HexDigit6 + | HexDigit7 + | HexDigit8 + | HexDigit9 + | HexDigita + | HexDigitb + | HexDigitc + | HexDigitd + | HexDigite + | HexDigitf + deriving (Show, Eq, Ord) + +makePrisms ''HexDigit + +instance D0 HexDigit where; d0 = _HexDigit0 +instance D1 HexDigit where; d1 = _HexDigit1 +instance D2 HexDigit where; d2 = _HexDigit2 +instance D3 HexDigit where; d3 = _HexDigit3 +instance D4 HexDigit where; d4 = _HexDigit4 +instance D5 HexDigit where; d5 = _HexDigit5 +instance D6 HexDigit where; d6 = _HexDigit6 +instance D7 HexDigit where; d7 = _HexDigit7 +instance D8 HexDigit where; d8 = _HexDigit8 +instance D9 HexDigit where; d9 = _HexDigit9 +instance Da HexDigit where; da = _HexDigita +instance Db HexDigit where; db = _HexDigitb +instance Dc HexDigit where; dc = _HexDigitc +instance Dd HexDigit where; dd = _HexDigitd +instance De HexDigit where; de = _HexDigite +instance Df HexDigit where; df = _HexDigitf + +type HexadecimalNoZero d = + (D1 d, D2 d, D3 d, D4 d, D5 d, D6 d, D7 d, D8 d, D9 d, Da d, Db d, Dc d, Dd d, De d, De d, Df d) + +parseHexadecimalNoZero :: + (HexadecimalNoZero d, CharParsing p) => + p d +parseHexadecimalNoZero = + choice + [ + parseDecimalNoZero + , parsea + , parseb + , parsec + , parsed + , parsee + , parsef + ] "HexadecimalNoZero" + +type Hexadecimal d = + (D0 d, HexadecimalNoZero d) + +parseHexadecimal :: + (Hexadecimal d, CharParsing p) => + p d +parseHexadecimal = + choice + [ + parse0 + , parseHexadecimalNoZero + ] "Hexadecimal" diff --git a/src/Data/Digit/Hexadecimal/MixedCase.hs b/src/Data/Digit/Hexadecimal/MixedCase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Hexadecimal/MixedCase.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Digit.Hexadecimal.MixedCase( + HeXDigit(..) +, HeXaDeCiMaLNoZero +, HeXaDeCiMaL +, parseHeXaDeCiMaLNoZero +, parseHeXaDeCiMaL +-- * Prisms +, _HeXDigit0 +, _HeXDigit1 +, _HeXDigit2 +, _HeXDigit3 +, _HeXDigit4 +, _HeXDigit5 +, _HeXDigit6 +, _HeXDigit7 +, _HeXDigit8 +, _HeXDigit9 +, _HeXDigita +, _HeXDigitb +, _HeXDigitc +, _HeXDigitd +, _HeXDigite +, _HeXDigitf +, _HeXDigitA +, _HeXDigitB +, _HeXDigitC +, _HeXDigitD +, _HeXDigitE +, _HeXDigitF +-- * Re-exports +, module Data.Digit.Class.D0 +, module Data.Digit.Class.D1 +, module Data.Digit.Class.D2 +, module Data.Digit.Class.D3 +, module Data.Digit.Class.D4 +, module Data.Digit.Class.D5 +, module Data.Digit.Class.D6 +, module Data.Digit.Class.D7 +, module Data.Digit.Class.D8 +, module Data.Digit.Class.D9 +, module Data.Digit.Class.MixedCase +) where + +import Prelude (Eq, Show, Ord) +import Control.Lens.TH (makePrisms) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), choice) +import Data.Digit.Class.D0 +import Data.Digit.Class.D1 +import Data.Digit.Class.D2 +import Data.Digit.Class.D3 +import Data.Digit.Class.D4 +import Data.Digit.Class.D5 +import Data.Digit.Class.D6 +import Data.Digit.Class.D7 +import Data.Digit.Class.D8 +import Data.Digit.Class.D9 +import Data.Digit.Class.MixedCase +import Data.Digit.Decimal(parseDecimalNoZero) + +data HeXDigit + = HeXDigit0 + | HeXDigit1 + | HeXDigit2 + | HeXDigit3 + | HeXDigit4 + | HeXDigit5 + | HeXDigit6 + | HeXDigit7 + | HeXDigit8 + | HeXDigit9 + | HeXDigita + | HeXDigitb + | HeXDigitc + | HeXDigitd + | HeXDigite + | HeXDigitf + | HeXDigitA + | HeXDigitB + | HeXDigitC + | HeXDigitD + | HeXDigitE + | HeXDigitF + deriving (Show, Eq, Ord) + +makePrisms ''HeXDigit + +instance D0 HeXDigit where; d0 = _HeXDigit0 +instance D1 HeXDigit where; d1 = _HeXDigit1 +instance D2 HeXDigit where; d2 = _HeXDigit2 +instance D3 HeXDigit where; d3 = _HeXDigit3 +instance D4 HeXDigit where; d4 = _HeXDigit4 +instance D5 HeXDigit where; d5 = _HeXDigit5 +instance D6 HeXDigit where; d6 = _HeXDigit6 +instance D7 HeXDigit where; d7 = _HeXDigit7 +instance D8 HeXDigit where; d8 = _HeXDigit8 +instance D9 HeXDigit where; d9 = _HeXDigit9 +instance DA HeXDigit where; dA = _HeXDigitA +instance Da HeXDigit where; da = _HeXDigita +instance DB HeXDigit where; dB = _HeXDigitB +instance Db HeXDigit where; db = _HeXDigitb +instance DC HeXDigit where; dC = _HeXDigitC +instance Dc HeXDigit where; dc = _HeXDigitc +instance DD HeXDigit where; dD = _HeXDigitD +instance Dd HeXDigit where; dd = _HeXDigitd +instance DE HeXDigit where; dE = _HeXDigitE +instance De HeXDigit where; de = _HeXDigite +instance DF HeXDigit where; dF = _HeXDigitF +instance Df HeXDigit where; df = _HeXDigitf + +type HeXaDeCiMaLNoZero d = + (D1 d, D2 d, D3 d, D4 d, D5 d, D6 d, D7 d, D8 d, D9 d, DA d, DB d, DC d, DD d, DE d, DF d, Da d, Db d, Dc d, Dd d, De d, De d, Df d) + +parseHeXaDeCiMaLNoZero :: + (HeXaDeCiMaLNoZero d, CharParsing p) => + p d +parseHeXaDeCiMaLNoZero = + choice + [ + parseDecimalNoZero + , parseAa + , parseBb + , parseCc + , parseDd + , parseEe + , parseFf + ] "HeXaDeCiMaLNoZero" + +type HeXaDeCiMaL d = + (D0 d, HeXaDeCiMaLNoZero d) + +parseHeXaDeCiMaL :: + (HeXaDeCiMaL d, CharParsing p) => + p d +parseHeXaDeCiMaL = + choice + [ + parse0 + , parseHeXaDeCiMaLNoZero + ] "HeXaDeCiMaL" diff --git a/src/Data/Digit/Hexadecimal/UpperCase.hs b/src/Data/Digit/Hexadecimal/UpperCase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Hexadecimal/UpperCase.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Digit.Hexadecimal.UpperCase( + HEXDigit(..) +, HEXADECIMALNoZero +, HEXADECIMAL +, parseHEXADECIMALNoZero +, parseHEXADECIMAL +-- * Prisms +, _HEXDigit0 +, _HEXDigit1 +, _HEXDigit2 +, _HEXDigit3 +, _HEXDigit4 +, _HEXDigit5 +, _HEXDigit6 +, _HEXDigit7 +, _HEXDigit8 +, _HEXDigit9 +, _HEXDigitA +, _HEXDigitB +, _HEXDigitC +, _HEXDigitD +, _HEXDigitE +, _HEXDigitF +-- * Re-exports +, module Data.Digit.Class.D0 +, module Data.Digit.Class.D1 +, module Data.Digit.Class.D2 +, module Data.Digit.Class.D3 +, module Data.Digit.Class.D4 +, module Data.Digit.Class.D5 +, module Data.Digit.Class.D6 +, module Data.Digit.Class.D7 +, module Data.Digit.Class.D8 +, module Data.Digit.Class.D9 +, module Data.Digit.Class.UpperCase +) where + +import Prelude (Eq, Show, Ord) +import Control.Lens.TH (makePrisms) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), choice) +import Data.Digit.Class.D0 +import Data.Digit.Class.D1 +import Data.Digit.Class.D2 +import Data.Digit.Class.D3 +import Data.Digit.Class.D4 +import Data.Digit.Class.D5 +import Data.Digit.Class.D6 +import Data.Digit.Class.D7 +import Data.Digit.Class.D8 +import Data.Digit.Class.D9 +import Data.Digit.Class.UpperCase +import Data.Digit.Decimal(parseDecimalNoZero) + +data HEXDigit + = HEXDigit0 + | HEXDigit1 + | HEXDigit2 + | HEXDigit3 + | HEXDigit4 + | HEXDigit5 + | HEXDigit6 + | HEXDigit7 + | HEXDigit8 + | HEXDigit9 + | HEXDigitA + | HEXDigitB + | HEXDigitC + | HEXDigitD + | HEXDigitE + | HEXDigitF + deriving (Show, Eq, Ord) + +makePrisms ''HEXDigit + +instance D0 HEXDigit where; d0 = _HEXDigit0 +instance D1 HEXDigit where; d1 = _HEXDigit1 +instance D2 HEXDigit where; d2 = _HEXDigit2 +instance D3 HEXDigit where; d3 = _HEXDigit3 +instance D4 HEXDigit where; d4 = _HEXDigit4 +instance D5 HEXDigit where; d5 = _HEXDigit5 +instance D6 HEXDigit where; d6 = _HEXDigit6 +instance D7 HEXDigit where; d7 = _HEXDigit7 +instance D8 HEXDigit where; d8 = _HEXDigit8 +instance D9 HEXDigit where; d9 = _HEXDigit9 +instance DA HEXDigit where; dA = _HEXDigitA +instance DB HEXDigit where; dB = _HEXDigitB +instance DC HEXDigit where; dC = _HEXDigitC +instance DD HEXDigit where; dD = _HEXDigitD +instance DE HEXDigit where; dE = _HEXDigitE +instance DF HEXDigit where; dF = _HEXDigitF + +type HEXADECIMALNoZero d = + (D1 d, D2 d, D3 d, D4 d, D5 d, D6 d, D7 d, D8 d, D9 d, DA d, DB d, DC d, DD d, DE d, DF d) + +parseHEXADECIMALNoZero :: + (HEXADECIMALNoZero d, CharParsing p) => + p d +parseHEXADECIMALNoZero = + choice + [ + parseDecimalNoZero + , parseA + , parseB + , parseC + , parseD + , parseE + , parseF + ] "HEXADECIMALNoZero" + +type HEXADECIMAL d = + (D0 d, HEXADECIMALNoZero d) + +parseHEXADECIMAL :: + (HEXADECIMAL d, CharParsing p) => + p d +parseHEXADECIMAL = + choice + [ + parse0 + , parseHEXADECIMALNoZero + ] "HEXADECIMAL" diff --git a/src/Data/Digit/Integral.hs b/src/Data/Digit/Integral.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Integral.hs @@ -0,0 +1,549 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Digit.Integral( +-- * Binary + integralBinaryNoZero +, integralBinary +, integralBinDigits +, binDigitsIntegral +-- * Octal +, integralOctalNoZero +, integralOctal +, integralOctDigits +, octDigitsIntegral +-- * Decimal +, integralDecimal +, integralDecimalNoZero +, integralDecDigits +, decDigitsIntegral +-- * Hexadecimal +, integralHexadecimalNoZero +, integralHexadecimal +, integralHexDigits +, hexDigitsIntegral +-- * HEXADECIMAL +, integralHEXADECIMALNoZero +, integralHEXADECIMAL +, integralHEXDigits +, _HEXDigitsIntegral +-- * HeXaDeCiMaL +, integralHeXaDeCiMaLNoZero +, integralHeXaDeCiMaL +, _HeXDigitsIntegral +, mod10 +, addDecDigit +, addDecDigit' +) where + +import Prelude (Eq, Integral, error, fst, lookup, + quotRem, (*), (+), (-), (==), (>=), mod, divMod) + +import Control.Applicative (Applicative) +import Control.Category (id, (.)) +import Control.Lens (APrism, Choice, Prism', Review, + clonePrism, outside, prism', unto, over, _1, + ( # ), (.~), (^?!), (^?)) +import Control.Lens.Extras (is) + +import Data.Bool (Bool, bool) +import Data.Either (Either (..), either) +import Data.Foldable (find, foldl') +import Data.Function (($),const) +import Data.Functor ((<$>)) +import Data.Int (Int) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromMaybe) +import Data.Ord ((>)) + +import Data.Digit.Binary +import Data.Digit.Decimal +import Data.Digit.Hexadecimal.LowerCase +import Data.Digit.Hexadecimal.UpperCase +import Data.Digit.Hexadecimal.MixedCase +import Data.Digit.Octal +import qualified Data.List.NonEmpty as NonEmpty + +-- $setup +-- >>> import Data.Digit + +-- | +-- +-- >>> 1 ^? integralBinaryNoZero +-- Just BinDigit1 +-- +-- >>> integralBinaryNoZero # BinDigit1 :: Integer +-- 1 +integralBinaryNoZero :: + (Integral a, BinaryNoZero d) => + Prism' + a + d +integralBinaryNoZero = + associatePrism (1, d1) [] + +-- | +-- +-- >>> 0 ^? integralBinary :: Maybe BinDigit +-- Just BinDigit0 +-- +-- >>> integralBinary # BinDigit0 :: Integer +-- 0 +integralBinary :: + (Integral a, Binary d) => + Prism' + a + d +integralBinary = + associatePrism (0, d0) [(1, d1)] + +-- | +-- >>> integralBinDigits (4 :: Int) +-- Right (BinDigit1 :| [BinDigit0, BinDigit0]) +-- +-- >>> integralBinDigits (0 :: Int) +-- Right (BinDigit0 :| []) +-- +-- >>> integralBinDigits (-1 :: Int) +-- Left (BinDigit0 :| []) +-- +-- >>> integralBinDigits (-4 :: Int) +-- Left (BinDigit1 :| [BinDigit1]) +integralBinDigits :: Integral a => a -> Either (NonEmpty BinDigit) (NonEmpty BinDigit) +integralBinDigits n = + if n >= 0 + then Right . NonEmpty.fromList $ go n [] + else Left . NonEmpty.fromList $ go (-n - 1) [] + where + go k = + let + (q, r) = quotRem k 2 + in + (if q == 0 then id else go q) . ((r ^?! integralBinary) :) + +-- | +-- >>> binDigitsIntegral (Right (BinDigit1 :| [BinDigit0, BinDigit0])) :: Int +-- 4 +-- +-- >>> binDigitsIntegral (Right (BinDigit0 :| [])) :: Int +-- 0 +-- +-- >>> binDigitsIntegral (Left (BinDigit0 :| [])) :: Int +-- 0 +-- +-- >>> binDigitsIntegral (Left (BinDigit1 :| [BinDigit1])) :: Int +-- -3 +binDigitsIntegral :: Integral a => Either (NonEmpty BinDigit) (NonEmpty BinDigit) -> a +binDigitsIntegral = either (\n -> -(go n)) go + where + go = foldl' (\b a -> (integralBinary # a) + 2 * b) 0 + +-- | +-- +-- >>> 7 ^? integralOctalNoZero :: Maybe OctDigit +-- Just OctDigit7 +-- +-- >>> integralOctalNoZero # OctDigit7 :: Integer +-- 7 +integralOctalNoZero :: + (Integral a, OctalNoZero d) => + Prism' + a + d +integralOctalNoZero = + associatePrism (1, d1) [(2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7)] + +-- | +-- +-- >>> 7 ^? integralOctal :: Maybe OctDigit +-- Just OctDigit7 +-- +-- >>> integralOctal # OctDigit7 :: Integer +-- 7 +integralOctal :: + (Integral a, Octal d) => + Prism' + a + d +integralOctal = + associatePrism (0, d0) [(1, d1), (2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7)] + +-- | +-- >>> integralOctDigits (64 :: Int) +-- Right (OctDigit1 :| [OctDigit0, OctDigit0]) +-- +-- >>> integralOctDigits (0 :: Int) +-- Right (OctDigit0 :| []) +-- +-- >>> integralOctDigits (-1 :: Int) +-- Left (OctDigit0 :| []) +-- +-- >>> integralOctDigits (-64 :: Int) +-- Left (OctDigit7 :| [OctDigit7]) +integralOctDigits :: Integral a => a -> Either (NonEmpty OctDigit) (NonEmpty OctDigit) +integralOctDigits n = + if n >= 0 + then Right . NonEmpty.fromList $ go n [] + else Left . NonEmpty.fromList $ go (-n - 1) [] + where + go k = + let + (q, r) = quotRem k 8 + in + (if q == 0 then id else go q) . ((r ^?! integralOctal) :) + +-- | +-- >>> octDigitsIntegral (Right (OctDigit1 :| [OctDigit0, OctDigit0])) :: Int +-- 64 +-- +-- >>> octDigitsIntegral (Right (OctDigit0 :| [])) :: Int +-- 0 +-- +-- >>> octDigitsIntegral (Left (OctDigit0 :| [])) :: Int +-- 0 +-- +-- >>> octDigitsIntegral (Left (OctDigit7 :| [OctDigit7])) :: Int +-- -63 +octDigitsIntegral :: Integral a => Either (NonEmpty OctDigit) (NonEmpty OctDigit) -> a +octDigitsIntegral = either (\n -> -(go n)) go + where + go = foldl' (\b a -> (integralOctal # a) + 8 * b) 0 + +-- | +-- >>> 9 ^? integralDecimalNoZero :: Maybe DecDigit +-- Just DecDigit9 +-- +-- >>> integralDecimalNoZero # DecDigit9 :: Integer +-- 9 +integralDecimalNoZero :: + (Integral a, DecimalNoZero d) => + Prism' + a + d +integralDecimalNoZero = + associatePrism (1, d1) [(2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7), (8, d8), (9, d9)] + +-- | +-- >>> 9 ^? integralDecimal :: Maybe DecDigit +-- Just DecDigit9 +-- +-- >>> integralDecimal # DecDigit9 :: Integer +-- 9 +integralDecimal :: + (Integral a, Decimal d) => + Prism' + a + d +integralDecimal = + associatePrism (0, d0) [(1, d1), (2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7), (8, d8), (9, d9)] + +-- | +-- >>> integralDecDigits (100 :: Int) +-- Right (DecDigit1 :| [DecDigit0, DecDigit0]) +-- +-- >>> integralDecDigits (0 :: Int) +-- Right (DecDigit0 :| []) +-- +-- >>> integralDecDigits (-1 :: Int) +-- Left (DecDigit0 :| []) +-- +-- >>> integralDecDigits (-100 :: Int) +-- Left (DecDigit9 :| [DecDigit9]) +integralDecDigits :: Integral a => a -> Either (NonEmpty DecDigit) (NonEmpty DecDigit) +integralDecDigits n = + if n >= 0 + then Right . NonEmpty.fromList $ go n [] + else Left . NonEmpty.fromList $ go (-n - 1) [] + where + go k = + let + (q, r) = quotRem k 10 + in + (if q == 0 then id else go q) . ((r ^?! integralDecimal) :) + +-- | +-- >>> decDigitsIntegral (Right (DecDigit1 :| [DecDigit0, DecDigit0])) :: Int +-- 100 +-- +-- >>> decDigitsIntegral (Right (DecDigit0 :| [])) :: Int +-- 0 +-- +-- >>> decDigitsIntegral (Left (DecDigit0 :| [])) :: Int +-- 0 +-- +-- >>> decDigitsIntegral (Left (DecDigit9 :| [DecDigit9])) :: Int +-- -9 +decDigitsIntegral :: Integral a => Either (NonEmpty DecDigit) (NonEmpty DecDigit) -> a +decDigitsIntegral = either (\n -> -(go n)) go + where + go = foldl' (\b a -> (integralDecimal # a) + 10 * b) 0 + +-- | +-- +-- >>> 15 ^? integralHexadecimalNoZero :: Maybe HexDigit +-- Just HexDigitf +-- +-- >>> integralHexadecimalNoZero # HexDigitf :: Integer +-- 15 +integralHexadecimalNoZero :: + (Integral a, HexadecimalNoZero d) => + Prism' + a + d +integralHexadecimalNoZero = + associatePrism (1, d1) [(2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7), (8, d8), (9, d9), (10, da), (11, db), (12, dc), (13, dd), (14, de), (15, df)] + +-- | +-- +-- >>> 15 ^? integralHexadecimal :: Maybe HexDigit +-- Just HexDigitf +-- +-- >>> integralHexadecimal # HexDigitf :: Integer +-- 15 +integralHexadecimal :: + (Integral a, Hexadecimal d) => + Prism' + a + d +integralHexadecimal = + associatePrism (0, d0) [(1, d1), (2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7), (8, d8), (9, d9), (10, da), (11, db), (12, dc), (13, dd), (14, de), (15, df)] + +-- | +-- >>> integralHexDigits (256 :: Int) +-- Right (HexDigit1 :| [HexDigit0, HexDigit0]) +-- +-- >>> integralHexDigits (0 :: Int) +-- Right (HexDigit0 :| []) +-- +-- >>> integralHexDigits (-1 :: Int) +-- Left (HexDigit0 :| []) +-- +-- >>> integralHexDigits (-256 :: Int) +-- Left (HexDigitf :| [HexDigitf]) +integralHexDigits :: Integral a => a -> Either (NonEmpty HexDigit) (NonEmpty HexDigit) +integralHexDigits n = + if n >= 0 + then Right . NonEmpty.fromList $ go n [] + else Left . NonEmpty.fromList $ go (-n - 1) [] + where + go k = + let + (q, r) = quotRem k 16 + in + (if q == 0 then id else go q) . ((r ^?! integralHexadecimal) :) + +-- | +-- >>> hexDigitsIntegral (Right (HexDigit1 :| [HexDigit0, HexDigit0])) :: Int +-- 256 +-- +-- >>> hexDigitsIntegral (Right (HexDigit0 :| [])) :: Int +-- 0 +-- +-- >>> hexDigitsIntegral (Left (HexDigit0 :| [])) :: Int +-- 0 +-- +-- >>> hexDigitsIntegral (Left (HexDigitf :| [HexDigitf])) :: Int +-- -255 +hexDigitsIntegral :: Integral a => Either (NonEmpty HexDigit) (NonEmpty HexDigit) -> a +hexDigitsIntegral = either (\n -> -(go n)) go + where + go = foldl' (\b a -> (integralHexadecimal # a) + 16 * b) 0 + +-- | +-- +-- >>> 15 ^? integralHEXADECIMALNoZero :: Maybe HEXDigit +-- Just HEXDigitF +-- +-- >>> integralHEXADECIMALNoZero # HEXDigitF :: Integer +-- 15 +integralHEXADECIMALNoZero :: + (Integral a, HEXADECIMALNoZero d) => + Prism' + a + d +integralHEXADECIMALNoZero = + associatePrism (1, d1) [(2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7), (8, d8), (9, d9), (10, dA), (11, dB), (12, dC), (13, dD), (14, dE), (15, dF)] + + +-- | +-- +-- >>> 15 ^? integralHEXADECIMAL :: Maybe HEXDigit +-- Just HEXDigitF +-- +-- >>> integralHEXADECIMAL # HEXDigitF :: Integer +-- 15 +integralHEXADECIMAL :: + (Integral a, HEXADECIMAL d) => + Prism' + a + d +integralHEXADECIMAL = + associatePrism (0, d0) [(1, d1), (2, d2), (3, d3), (4, d4), (5, d5), (6, d6), (7, d7), (8, d8), (9, d9), (10, dA), (11, dB), (12, dC), (13, dD), (14, dE), (15, dF)] + +-- | +-- >>> integralHEXDigits (256 :: Int) +-- Right (HEXDigit1 :| [HEXDigit0, HEXDigit0]) +-- +-- >>> integralHEXDigits (0 :: Int) +-- Right (HEXDigit0 :| []) +-- +-- >>> integralHEXDigits (-1 :: Int) +-- Left (HEXDigit0 :| []) +-- +-- >>> integralHEXDigits (-256 :: Int) +-- Left (HEXDigitF :| [HEXDigitF]) +integralHEXDigits :: Integral a => a -> Either (NonEmpty HEXDigit) (NonEmpty HEXDigit) +integralHEXDigits n = + if n >= 0 + then Right . NonEmpty.fromList $ go n [] + else Left . NonEmpty.fromList $ go (-n - 1) [] + where + go k = + let + (q, r) = quotRem k 16 + in + (if q == 0 then id else go q) . ((r ^?! integralHEXADECIMAL) :) + +-- | +-- >>> _HEXDigitsIntegral (Right (HEXDigit1 :| [HEXDigit0, HEXDigit0])) :: Int +-- 256 +-- +-- >>> _HEXDigitsIntegral (Right (HEXDigit0 :| [])) :: Int +-- 0 +-- +-- >>> _HEXDigitsIntegral (Left (HEXDigit0 :| [])) :: Int +-- 0 +-- +-- >>> _HEXDigitsIntegral (Left (HEXDigitF :| [HEXDigitF])) :: Int +-- -255 +_HEXDigitsIntegral :: Integral a => Either (NonEmpty HEXDigit) (NonEmpty HEXDigit) -> a +_HEXDigitsIntegral = either (\n -> -(go n)) go + where + go = foldl' (\b a -> (integralHEXADECIMAL # a) + 16 * b) 0 + +-- | +-- +-- >>> 15 ^? integralHeXaDeCiMaLNoZero :: Maybe HeXDigit +-- Just HeXDigitF +-- +-- >>> integralHeXaDeCiMaLNoZero # HeXDigitF :: Integer +-- 15 +integralHeXaDeCiMaLNoZero :: + (Integral a, HeXaDeCiMaLNoZero d) => + Review + a + d +integralHeXaDeCiMaLNoZero = + unto + (outside d1 .~ const 1 $ + outside d2 .~ const 2 $ + outside d3 .~ const 3 $ + outside d4 .~ const 4 $ + outside d5 .~ const 5 $ + outside d6 .~ const 6 $ + outside d7 .~ const 7 $ + outside d8 .~ const 8 $ + outside d9 .~ const 9 $ + outside da .~ const 10 $ + outside dA .~ const 10 $ + outside db .~ const 11 $ + outside dB .~ const 11 $ + outside dc .~ const 12 $ + outside dC .~ const 12 $ + outside dd .~ const 13 $ + outside dD .~ const 13 $ + outside de .~ const 14 $ + outside dE .~ const 14 $ + outside df .~ const 15 $ + outside dF .~ const 15 $ + error "incomplete pattern") + +-- | +-- +-- >>> 15 ^? integralHeXaDeCiMaL :: Maybe HeXDigit +-- Just HeXDigitF +-- +-- >>> integralHeXaDeCiMaL # HeXDigitF :: Integer +-- 15 +integralHeXaDeCiMaL :: + (Integral a, HeXaDeCiMaL d) => + Review + a + d +integralHeXaDeCiMaL = + unto + (outside d0 .~ const 0 $ + outside d1 .~ const 1 $ + outside d2 .~ const 2 $ + outside d3 .~ const 3 $ + outside d4 .~ const 4 $ + outside d5 .~ const 5 $ + outside d6 .~ const 6 $ + outside d7 .~ const 7 $ + outside d8 .~ const 8 $ + outside d9 .~ const 9 $ + outside da .~ const 10 $ + outside dA .~ const 10 $ + outside db .~ const 11 $ + outside dB .~ const 11 $ + outside dc .~ const 12 $ + outside dC .~ const 12 $ + outside dd .~ const 13 $ + outside dD .~ const 13 $ + outside de .~ const 14 $ + outside dE .~ const 14 $ + outside df .~ const 15 $ + outside dF .~ const 15 $ + error "incomplete pattern") + +-- | +-- >>> _HeXDigitsIntegral (Right (HeXDigit1 :| [HeXDigit0, HeXDigit0])) :: Int +-- 256 +-- +-- >>> _HeXDigitsIntegral (Right (HeXDigit0 :| [])) :: Int +-- 0 +-- +-- >>> _HeXDigitsIntegral (Left (HeXDigit0 :| [])) :: Int +-- 0 +-- +-- >>> _HeXDigitsIntegral (Left (HeXDigitF :| [HeXDigitF])) :: Int +-- -255 +_HeXDigitsIntegral :: Integral a => Either (NonEmpty HeXDigit) (NonEmpty HeXDigit) -> a +_HeXDigitsIntegral = either (\n -> -(go n)) go + where + go = foldl' (\b a -> (integralHeXaDeCiMaL # a) + 16 * b) 0 + +mod10 :: + Integral a => + a + -> DecDigit +mod10 n = + let r = n `mod` 10 + in fromMaybe (mod10 r) (r ^? integralDecimal) + +addDecDigit :: + DecDigit + -> DecDigit + -> (Bool, DecDigit) +addDecDigit a b = + let (x, r) = + (integralDecimal # a + integralDecimal # b) `divMod` 10 + in (x > 0, mod10 (r :: Int)) + +addDecDigit' :: + DecDigit + -> DecDigit + -> (DecDigit, DecDigit) +addDecDigit' a b = + over _1 (bool x0 x1) (addDecDigit a b) + +---- not exported +associatePrism :: + (Eq b, Choice p, Applicative f) => + (b, APrism a a () ()) + -> [(b, APrism a a () ())] + -> p a (f a) + -> p b (f b) +associatePrism def z = + prism' + (\d -> fst (fromMaybe def (find (\(_, w) -> is w d) z))) + (\i -> (\p -> clonePrism p # ()) <$> lookup i (def:z)) diff --git a/src/Data/Digit/Natural.hs b/src/Data/Digit/Natural.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Natural.hs @@ -0,0 +1,116 @@ +module Data.Digit.Natural + ( _NaturalDigits + , naturalToDigits + , digitsToNatural + ) where + +import Prelude (Int, error, fromIntegral, maxBound, (*), + (+), (-), (>), (^)) + +import Control.Category ((.)) +import Control.Lens (Prism', ifoldrM, prism', ( # )) + +import Data.Foldable (length) +import Data.Function (($)) +import Data.Functor (fmap, (<$>)) +import Data.Semigroup ((<>)) + +import Data.List (replicate) + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE + +import Data.Maybe (Maybe (..)) + +import Data.Digit.Decimal +import Data.Digit.Integral (integralDecimal) + +import Numeric.Natural (Natural) + +import Data.Scientific (toDecimalDigits) + +-- | +-- +-- >>> _NaturalDigits # 0 +-- DecDigit0 :| [] +-- +-- >>> _NaturalDigits # 1 +-- DecDigit1 :| [] +-- +-- >>> _NaturalDigits # 922 +-- DecDigit9 :| [DecDigit2,DecDigit2] +-- +-- >>> (DecDigit9 :| [DecDigit2,DecDigit2]) ^? _NaturalDigits +-- Just 922 +-- +-- >>> (DecDigit1 :| []) ^? _NaturalDigits +-- Just 1 +-- +-- prop> \x -> digitsToNatural ( naturalToDigits x ) == Just x +-- +_NaturalDigits :: Prism' (NonEmpty DecDigit) Natural +_NaturalDigits = prism' naturalToDigits digitsToNatural + +-- | +-- +-- >>> naturalDigits 0 +-- DecDigit0 :| [] +-- +-- >>> naturalDigits 9 +-- DecDigit9 :| [] +-- +-- >>> naturalDigits 393 +-- DecDigit3 :| [DecDigit9,DecDigit3] +-- +naturalToDigits :: Natural -> NonEmpty DecDigit +naturalToDigits n = + case toDecimalDigits $ fromIntegral n of + -- toDecimalDigits :: n -> ([n],n) + -- toDecimalDigits 0 = ([0],0) + -- toDecimalDigits (-0) = ([0],0) + -- toDecimalDigits (-1) = ([-1],1) + ([], _ ) -> error "Data.Scientific.toDecimalDigits is no longer correct!" + (x:xs, eXP) -> g x :| (g <$> xs) <> t (x:xs) eXP + + where + t allDigs eXP = + replicate (eXP - length allDigs) (d0 # ()) + + -- EWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW! + -- But you can't reach this point unless you have a non-zero absolute integral value. So... I dunno. + g 0 = d0 # () + g 1 = d1 # () + g 2 = d2 # () + g 3 = d3 # () + g 4 = d4 # () + g 5 = d5 # () + g 6 = d6 # () + g 7 = d7 # () + g 8 = d8 # () + g 9 = d9 # () + g _ = error "The universe now has more than ten digits." + +-- | Create a number from a list of digits with the integer bounds of the machine. +-- +-- >>> digitsToNatural (DecDigit3 :| [DecDigit4]) +-- Just 34 +-- +-- >>> digitsToNatural (DecDigit0 :| []) +-- Just 0 +-- +-- >>> digitsToNatural (naturalToDigits (maxBound :: Natural)) +-- Just 9223372036854775807 +-- +-- >>> digitsToNatural (naturalToDigits $ (maxBound :: Natural) + 1) +-- Nothing +digitsToNatural :: NonEmpty DecDigit -> Maybe Natural +digitsToNatural = fmap fromIntegral . ifoldrM f 0 . NE.reverse + where + f :: Int -> DecDigit -> Int -> Maybe Int + f i d curr = + let + next = (integralDecimal # d) * (10 ^ i) + in + if curr > maxBound - next + then Nothing + else Just (curr + next) diff --git a/src/Data/Digit/Octal.hs b/src/Data/Digit/Octal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Digit/Octal.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Digit.Octal( + OctDigit(..) +, OctalNoZero +, Octal +, parseOctalNoZero +, parseOctal +-- * Prisms +, _OctDigit0 +, _OctDigit1 +, _OctDigit2 +, _OctDigit3 +, _OctDigit4 +, _OctDigit5 +, _OctDigit6 +, _OctDigit7 +-- * Re-exports +, module Data.Digit.Class.D0 +, module Data.Digit.Class.D1 +, module Data.Digit.Class.D2 +, module Data.Digit.Class.D3 +, module Data.Digit.Class.D4 +, module Data.Digit.Class.D5 +, module Data.Digit.Class.D6 +, module Data.Digit.Class.D7 +) where + +import Prelude (Eq, Show, Ord, Enum, Bounded) +import Control.Lens.TH (makePrisms) +import Text.Parser.Char(CharParsing) +import Text.Parser.Combinators((), choice) +import Data.Digit.Class.D0 +import Data.Digit.Class.D1 +import Data.Digit.Class.D2 +import Data.Digit.Class.D3 +import Data.Digit.Class.D4 +import Data.Digit.Class.D5 +import Data.Digit.Class.D6 +import Data.Digit.Class.D7 + +data OctDigit + = OctDigit0 + | OctDigit1 + | OctDigit2 + | OctDigit3 + | OctDigit4 + | OctDigit5 + | OctDigit6 + | OctDigit7 + deriving (Show, Eq, Ord, Enum, Bounded) + +makePrisms ''OctDigit + +instance D0 OctDigit where; d0 = _OctDigit0 +instance D1 OctDigit where; d1 = _OctDigit1 +instance D2 OctDigit where; d2 = _OctDigit2 +instance D3 OctDigit where; d3 = _OctDigit3 +instance D4 OctDigit where; d4 = _OctDigit4 +instance D5 OctDigit where; d5 = _OctDigit5 +instance D6 OctDigit where; d6 = _OctDigit6 +instance D7 OctDigit where; d7 = _OctDigit7 + +type OctalNoZero d = + (D1 d, D2 d, D3 d, D4 d, D5 d, D6 d, D7 d) + +parseOctalNoZero :: + (OctalNoZero d, CharParsing p) => + p d +parseOctalNoZero = + choice + [ + parse1 + , parse2 + , parse3 + , parse4 + , parse5 + , parse6 + , parse7 + ] "OctalNoZero" + +type Octal d = + (D0 d, OctalNoZero d) + +parseOctal :: + (Octal d, CharParsing p) => + p d +parseOctal = + choice + [ + parse0 + , parseOctalNoZero + ] "Octal" diff --git a/src/Data/Digits.hs b/src/Data/Digits.hs deleted file mode 100644 --- a/src/Data/Digits.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Digits( - Digits(..) -, AsDigits(..) -, HasDigits(..) -, ManyDigits(..) -, parsedigits -) where - -import Control.Applicative(many) -import Data.Data (Data) -import Data.Digit(Digit, AsDigit(..), ManyDigit(..), parsedigit) -import Data.Digits1(Digits1(..), AsDigits1(..)) -import Data.Monoid(mappend) -import Data.Semigroup((<>)) -import Data.Typeable (Typeable) -import Text.Parser.Char(CharParsing) -import Text.Parser.Combinators(()) -import Papa - -newtype Digits = - Digits - [Digit] - deriving (Eq, Ord, Show, Data, Typeable) - -makeWrapped ''Digits - -class AsDigits a where - _Digits :: - Prism' - a - Digits - -instance AsDigits Digits where - _Digits = - id - -instance AsDigit a => AsDigits [a] where - _Digits = - prism' - (\(Digits d) -> (digit #) <$> d) - (\s -> Digits <$> traverse (^? digit) s) - -class HasDigits a where - digitsL :: - Lens' - a - Digits - -instance HasDigits Digits where - digitsL = - id - -class ManyDigits a where - digitsT :: - Traversal' - a - Digits - -instance ManyDigits Digits where - digitsT = - id - -instance Cons Digits Digits Digit Digit where - _Cons = - prism' - (\(h, Digits t) -> Digits (h:t)) - (\(Digits d) -> (_2 %~ Digits) <$> d ^? _Cons) - -instance Snoc Digits Digits Digit Digit where - _Snoc = - prism' - (\(Digits t, z) -> Digits (t ++ [z])) - (\(Digits d) -> (_1 %~ Digits) <$> d ^? _Snoc) - -instance AsEmpty Digits where - _Empty = - _Wrapped . _Empty - -instance Each Digits Digits Digit Digit where - each f (Digits d) = - Digits <$> each f d - -type instance IxValue Digits = Digit -type instance Index Digits = Int -instance Ixed Digits where - ix i f (Digits d) = - Digits <$> ix i f d - -instance Plated Digits where - plate f (Digits d) = - Digits <$> plate (\x -> (\(Digits e) -> e) <$> f (Digits x)) d - -instance Reversing Digits where - reversing (Digits d) = - Digits (reversing d) - -instance Semigroup Digits where - Digits d <> Digits e = - Digits (d <> e) - -instance Monoid Digits where - mempty = - Digits mempty - mappend = - (<>) - -parsedigits :: - CharParsing p => - p Digits -parsedigits = - Digits <$> many parsedigit "Digits" - -instance AsDigits1 Digits where - _Digits1 = - prism' - (\(Digits1 x) -> Digits (toList x)) - (\(Digits x) -> case x of - [] -> - Nothing - h:t -> - Just (Digits1 (h :| t))) - -instance ManyDigit Digits where - digitT f (Digits d) = - Digits <$> traverse f d diff --git a/src/Data/Digits1.hs b/src/Data/Digits1.hs deleted file mode 100644 --- a/src/Data/Digits1.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Digits1( - Digits1(..) -, AsDigits1(..) -, HasDigits1(..) -, ManyDigits1(..) -, parsedigitlist1 -) where - -import Data.Data(Data) -import Data.Digit(Digit, AsDigit(..), ManyDigit(..), parsedigit) -import Data.List.NonEmpty(some1) -import qualified Data.List.NonEmpty as NonEmpty(cons) -import Data.Semigroup((<>)) -import Data.Typeable (Typeable) -import Text.Parser.Char(CharParsing) -import Text.Parser.Combinators(()) -import Papa - -newtype Digits1 = - Digits1 - (NonEmpty Digit) - deriving (Eq, Ord, Show, Data, Typeable) - -makeWrapped ''Digits1 - -class AsDigits1 a where - _Digits1 :: - Prism' - a - Digits1 - -instance AsDigits1 Digits1 where - _Digits1 = - id - - -instance AsDigit a => AsDigits1 (NonEmpty a) where - _Digits1 = - prism' - (\(Digits1 d) -> (digit #) <$> d) - (\s -> Digits1 <$> traverse (^? digit) s) - -instance AsDigit a => AsDigits1 [a] where - _Digits1 = - -- where does this live? - let nonemptyP :: - Prism [a] [a] (NonEmpty a) (NonEmpty a) - nonemptyP = - prism' - toList - (\x -> case x of - [] -> - Nothing - h:t -> - Just (h :| t)) - in nonemptyP . _Digits1 - -class HasDigits1 a where - digits1L :: - Lens' - a - Digits1 - -instance HasDigits1 Digits1 where - digits1L = - id - -class ManyDigits1 a where - digits1T :: - Traversal' - a - Digits1 - -instance ManyDigits1 Digits1 where - digits1T = - id - -instance Semigroup Digits1 where - Digits1 x <> Digits1 y = - Digits1 (x <> y) - -instance Plated Digits1 where - plate f (Digits1 d) = - let platedNonEmpty :: - Traversal' (NonEmpty a) (NonEmpty a) - platedNonEmpty k l@(_ :| []) = - k l - platedNonEmpty k (h :| i : t) = - (h `NonEmpty.cons`) <$> k (i :| t) - in Digits1 <$> platedNonEmpty (\n -> (\(Digits1 x) -> x) <$> f (Digits1 n)) d - -instance Reversing Digits1 where - reversing (Digits1 d) = - Digits1 (reversing d) - -instance Each Digits1 Digits1 Digit Digit where - each f (Digits1 d) = - Digits1 <$> each f d - -instance Snoc Digits1 Digits1 Digit Digit where - _Snoc = - prism' - (\(Digits1 ds, d) -> Digits1 (ds <> (d :| []))) - (\(Digits1 (h :| t)) -> (_1 %~ (\ds -> Digits1 (h :| ds))) <$> t ^? _Snoc) - -instance Cons Digits1 Digits1 Digit Digit where - _Cons = - prism' - (\(d, Digits1 ds) -> Digits1 (d `NonEmpty.cons` ds)) - (\(Digits1 (h :| t)) -> (_2 %~ (\ds -> Digits1 (h :| ds))) <$> t ^? _Cons) - -type instance IxValue Digits1 = Digit -type instance Index Digits1 = Int -instance Ixed Digits1 where - ix i f (Digits1 d) = - Digits1 <$> ix i f d - -parsedigitlist1 :: - CharParsing p => - p Digits1 -parsedigitlist1 = - Digits1 <$> some1 parsedigit "Digits1" - -instance ManyDigit Digits1 where - digitT f (Digits1 d) = - Digits1 <$> traverse f d diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Main( + main +) where + +import Data.Digit +import Numeric.Natural (Natural) +import Prelude (Char, Integral, Int, String, Eq, Show, IO, Integer, minBound, maxBound, fromIntegral,fst,notElem) + +import Control.Category ((.)) +import Control.Monad ((>>=)) +import Control.Applicative ((<*)) +import Control.Lens (Prism', (^?), (#)) + +import Data.Semigroup ((<>)) +import Data.Monoid (mconcat) +import Data.Functor ((<$>),fmap) +import Data.Function (($)) +import Data.Maybe (Maybe (..)) +import Data.Either (Either (..),isLeft) +import Data.List.NonEmpty (NonEmpty) + +import Hedgehog(Property, Gen, forAll, property, assert, (===)) + +import Test.Tasty(TestTree, defaultMain, testGroup) +import Test.Tasty.Hedgehog(testProperty) +import Test.Tasty.HUnit(testCase, (@?=)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Text.Parsec(parse, ParseError, Parsec, eof) + +testPrism :: + (Show x, Eq x) => + Gen x + -> String + -> Prism' x HeXDigit + -> [(x, HeXDigit)] + -> [TestTree] +testPrism g n p x = + testProperty + (n <> " prism invalid values") + ( + property $ + do c <- forAll . Gen.filter (`notElem` (fmap fst x)) $ g + (c ^? p :: Maybe HeXDigit) === Nothing + ) : + ( + x >>= \(c, d) -> + [ + testCase + (n <> " prism ->") + ((c ^? p :: Maybe HeXDigit) @?= Just d) + , testCase + (n <> " prism <-") + (p # d @?= c) + ] + ) + +testParser :: + String + -> Parsec String () HeXDigit + -> [(Char, HeXDigit)] + -> [TestTree] +testParser n p x = + ( + let n' = n <> " parser invalid values" + in testProperty + n' + ( + property $ + do c <- forAll . Gen.filter (`notElem` (fmap fst x)) . Gen.choice $ [Gen.hexit, Gen.unicode] + assert (isLeft (parse p (n' <> " test") [c] :: Either ParseError HeXDigit)) + ) + ) : + ( + x >>= \(c, d) -> + [ + let n' = n <> " parses exactly one character" + in testCase + n' + ((parse (p <* eof) (n' <> " test") [c] :: Either ParseError HeXDigit) @?= Right d) + , let n' = n <> " parses the correct digit" + in testCase + n' + ((parse p (n' <> "test") (c:"xyz") :: Either ParseError HeXDigit) @?= Right d) + ] + ) + +integralPrism :: + (Show n, Integral n) => + String + -> Prism' n HeXDigit + -> [(n, HeXDigit)] + -> [TestTree] +integralPrism = + testPrism (Gen.choice [Gen.integral (Range.linear 0 9), Gen.integral (Range.linear 10 99999), Gen.integral (Range.linear (-1) (-99999))]) + +charPrism :: + String + -> Prism' Char HeXDigit + -> [(Char, HeXDigit)] + -> [TestTree] +charPrism = + testPrism (Gen.choice [Gen.hexit, Gen.unicode]) + +genNatural :: Gen Natural +genNatural = fromIntegral <$> Gen.integral (Range.linear 0 (maxBound :: Int)) + +prop_natural_digits_roundtrip :: Property +prop_natural_digits_roundtrip = property $ do + n <- forAll genNatural + digitsToNatural (naturalToDigits n) === Just n + +digitNaturalTests :: TestTree +digitNaturalTests = testGroup "digit Natural tests" + [ testProperty "Natural <-> NonEmpty Digit" prop_natural_digits_roundtrip + ] + +prop_integer_X :: (Integer -> a) -> (a -> Integer) -> Property +prop_integer_X iToX xToI = + property $ do + n <- forAll . + Gen.integral $ + Range.constant + (fromIntegral (minBound :: Int)) + (fromIntegral (maxBound :: Int)) + xToI (iToX n) === n + +prop_X_integer + :: (Eq a, Show a) + => Gen a + -> (Integer -> Either (NonEmpty a) (NonEmpty a)) + -> (Either (NonEmpty a) (NonEmpty a) -> Integer) + -> Property +prop_X_integer genX iToX xToI = + property $ do + let digits = Gen.nonEmpty (Range.constant 1 50) genX + ds <- forAll $ Gen.choice [Left <$> digits, Right <$> digits] + xToI (iToX (xToI ds)) === xToI ds + +toFromIntegralTests :: TestTree +toFromIntegralTests = + testGroup "To and from integers" + [ testProperty "Integer <-> BinDigit" $ + prop_integer_X integralBinDigits binDigitsIntegral + , testProperty "BinDigit <-> Integer" $ + prop_X_integer (Gen.element enumBinary) integralBinDigits binDigitsIntegral + , testProperty "Integer <-> OctDigit" $ + prop_integer_X integralOctDigits octDigitsIntegral + , testProperty "OctDigit <-> Integer" $ + prop_X_integer (Gen.element enumOctal) integralOctDigits octDigitsIntegral + , testProperty "Integer <-> DecDigit" $ + prop_integer_X integralDecDigits decDigitsIntegral + , testProperty "DecDigit <-> Integer" $ + prop_X_integer (Gen.element enumDecimal) integralDecDigits decDigitsIntegral + , testProperty "Integer <-> HexDigit" $ + prop_integer_X integralHexDigits hexDigitsIntegral + , testProperty "HexDigit <-> Integer" $ + prop_X_integer (Gen.element enumHexadecimal) integralHexDigits hexDigitsIntegral + , testProperty "Integer <-> HEXDigit" $ + prop_integer_X integralHEXDigits _HEXDigitsIntegral + , testProperty "HEXDigit <-> Integer" $ + prop_X_integer (Gen.element enumHEXADECIMAL) integralHEXDigits _HEXDigitsIntegral + ] + +main :: + IO () +main = defaultMain $ + testGroup "All Digit Tests" + [ digitBaseTests + , digitNaturalTests + , toFromIntegralTests + ] + +digitBaseTests :: TestTree +digitBaseTests = + testGroup "digit parser/prism tests" $ + let q0 = ('0', HeXDigit0) + q1 = ('1', HeXDigit1) + q2 = ('2', HeXDigit2) + q3 = ('3', HeXDigit3) + q4 = ('4', HeXDigit4) + q5 = ('5', HeXDigit5) + q6 = ('6', HeXDigit6) + q7 = ('7', HeXDigit7) + q8 = ('8', HeXDigit8) + q9 = ('9', HeXDigit9) + qa = ('a', HeXDigita) + qb = ('b', HeXDigitb) + qc = ('c', HeXDigitc) + qd = ('d', HeXDigitd) + qe = ('e', HeXDigite) + qf = ('f', HeXDigitf) + qA = ('A', HeXDigitA) + qB = ('B', HeXDigitB) + qC = ('C', HeXDigitC) + qD = ('D', HeXDigitD) + qE = ('E', HeXDigitE) + qF = ('F', HeXDigitF) + r0 :: (Integer, HeXDigit) + r0 = (0 , HeXDigit0) + r1 :: (Integer, HeXDigit) + r1 = (1 , HeXDigit1) + r2 :: (Integer, HeXDigit) + r2 = (2 , HeXDigit2) + r3 :: (Integer, HeXDigit) + r3 = (3 , HeXDigit3) + r4 :: (Integer, HeXDigit) + r4 = (4 , HeXDigit4) + r5 :: (Integer, HeXDigit) + r5 = (5 , HeXDigit5) + r6 :: (Integer, HeXDigit) + r6 = (6 , HeXDigit6) + r7 :: (Integer, HeXDigit) + r7 = (7 , HeXDigit7) + r8 :: (Integer, HeXDigit) + r8 = (8 , HeXDigit8) + r9 :: (Integer, HeXDigit) + r9 = (9 , HeXDigit9) + ra :: (Integer, HeXDigit) + ra = (10 , HeXDigita) + rb :: (Integer, HeXDigit) + rb = (11 , HeXDigitb) + rc :: (Integer, HeXDigit) + rc = (12 , HeXDigitc) + rd :: (Integer, HeXDigit) + rd = (13 , HeXDigitd) + re :: (Integer, HeXDigit) + re = (14 , HeXDigite) + rf :: (Integer, HeXDigit) + rf = (15 , HeXDigitf) + rA :: (Integer, HeXDigit) + rA = (10 , HeXDigitA) + rB :: (Integer, HeXDigit) + rB = (11 , HeXDigitB) + rC :: (Integer, HeXDigit) + rC = (12 , HeXDigitC) + rD :: (Integer, HeXDigit) + rD = (13 , HeXDigitD) + rE :: (Integer, HeXDigit) + rE = (14 , HeXDigitE) + rF :: (Integer, HeXDigit) + rF = (15 , HeXDigitF) + in mconcat [ + charPrism "charBinaryNoZero" charBinaryNoZero [q1] + , charPrism "charBinary" charBinary [q0, q1] + , charPrism "charOctalNoZero" charOctalNoZero [q1, q2, q3, q4, q5, q6, q7] + , charPrism "charOctal" charOctal [q0, q1, q2, q3, q4, q5, q6, q7] + , charPrism "charDecimalNoZero" charDecimalNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9] + , charPrism "charDecimal" charDecimal [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9] + , charPrism "charHexadecimalNoZero" charHexadecimalNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf] + , charPrism "charHexadecimal" charHexadecimal [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf] + , charPrism "charHEXADECIMALNoZero" charHEXADECIMALNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9, qA, qB, qC, qD, qE, qF] + , charPrism "charHEXADECIMAL" charHEXADECIMAL [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, qA, qB, qC, qD, qE, qF] + , charPrism "charHeXaDeCiMaLNoZero" charHeXaDeCiMaLNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf, qA, qB, qC, qD, qE, qF] + , charPrism "charHeXaDeCiMaL" charHeXaDeCiMaL [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf, qA, qB, qC, qD, qE, qF] + , integralPrism "integralBinaryNoZero" integralBinaryNoZero [r1] + , integralPrism "integralBinary" integralBinary [r0, r1] + , integralPrism "integralOctalNoZero" integralOctalNoZero [r1, r2, r3, r4, r5, r6, r7] + , integralPrism "integralOctal" integralOctal [r0, r1, r2, r3, r4, r5, r6, r7] + , integralPrism "integralDecimalNoZero" integralDecimalNoZero [r1, r2, r3, r4, r5, r6, r7, r8, r9] + , integralPrism "integralDecimal" integralDecimal [r0, r1, r2, r3, r4, r5, r6, r7, r8, r9] + , integralPrism "integralHexadecimalNoZero" integralHexadecimalNoZero [r1, r2, r3, r4, r5, r6, r7, r8, r9, ra, rb, rc, rd, re, rf] + , integralPrism "integralHexadecimal" integralHexadecimal [r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, ra, rb, rc, rd, re, rf] + , integralPrism "integralHEXADECIMALNoZero" integralHEXADECIMALNoZero [r1, r2, r3, r4, r5, r6, r7, r8, r9, rA, rB, rC, rD, rE, rF] + , integralPrism "integralHEXADECIMAL" integralHEXADECIMAL [r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, rA, rB, rC, rD, rE, rF] , testParser "parseBinaryNoZero" parseBinaryNoZero [q1] + , testParser "parseBinary" parseBinary [q0, q1] + , testParser "parseOctalNoZero" parseOctalNoZero [q1, q2, q3, q4, q5, q6, q7] + , testParser "parseOctal" parseOctal [q0, q1, q2, q3, q4, q5, q6, q7] + , testParser "parseDecimalNoZero" parseDecimalNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9] + , testParser "parseDecimal" parseDecimal [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9] + , testParser "parseHexadecimalNoZero" parseHexadecimalNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf] + , testParser "parseHexadecimal" parseHexadecimal [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf] + , testParser "parseHEXADECIMALNoZero" parseHEXADECIMALNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9, qA, qB, qC, qD, qE, qF] + , testParser "parseHEXADECIMALDecimal" parseHEXADECIMAL [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, qA, qB, qC, qD, qE, qF] + , testParser "parseHeXaDeCiMaLNoZero" parseHeXaDeCiMaLNoZero [q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf, qA, qB, qC, qD, qE, qF] + , testParser "parseHeXaDeCiMaLDecimal" parseHeXaDeCiMaL [q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, qa, qb, qc, qd, qe, qf, qA, qB, qC, qD, qE, qF] + , testParser "parse0" parse0 [q0] + , testParser "parse1" parse1 [q1] + , testParser "parse2" parse2 [q2] + , testParser "parse3" parse3 [q3] + , testParser "parse4" parse4 [q4] + , testParser "parse5" parse5 [q5] + , testParser "parse6" parse6 [q6] + , testParser "parse7" parse7 [q7] + , testParser "parse8" parse8 [q8] + , testParser "parse9" parse9 [q9] + , testParser "parsea" parsea [qa] + , testParser "parseb" parseb [qb] + , testParser "parsec" parsec [qc] + , testParser "parsed" parsed [qd] + , testParser "parsee" parsee [qe] + , testParser "parsef" parsef [qf] + , testParser "parseA" parseA [qA] + , testParser "parseB" parseB [qB] + , testParser "parseC" parseC [qC] + , testParser "parseD" parseD [qD] + , testParser "parseE" parseE [qE] + , testParser "parseF" parseF [qF] + , testParser "parseAa" parseAa [qA, qa] + , testParser "parseBb" parseBb [qB, qb] + , testParser "parseCc" parseCc [qC, qc] + , testParser "parseDd" parseDd [qD, qd] + , testParser "parseEe" parseEe [qE, qe] + , testParser "parseFf" parseFf [qF, qf] + ] diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Main where - -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -main :: - IO () -main = - getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c