add Bits instance for Word

.appveyor.yml

@@ -1,4 +1,4 @@
-# ~*~ auto-generated by haskell-ci with config : 0487c3b5a1be273dd65c5cb36e42c12c0ff9c8ac3098315950725cdf228762e4 ~*~
+# ~*~ auto-generated by haskell-ci with config : ff1b963a6044945c37f27bf014779c728f2acd4d5706d068ce3c706ef124a613 ~*~
 
 version: "{build}"
 clone_folder: C:\project
@@ -10,8 +10,8 @@ environment:
   global:
     STACK_ROOT: "C:\\SR"
   matrix:
-    - { BUILD: "ghc-8.4", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-12.9, packages: [ foundation/, basement/ ], extra-deps: [], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" }
-    - { BUILD: "ghc-8.4", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-12.9, packages: [ foundation/, basement/ ], extra-deps: [], flags: { foundation: { bounds-check: true, linktest: true } } }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" }
+    - { BUILD: "ghc-8.6", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-13.5, packages: [ foundation/, basement/ ], extra-deps: [], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" }
+    - { BUILD: "ghc-8.6", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-13.5, packages: [ foundation/, basement/ ], extra-deps: [], flags: { foundation: { bounds-check: true, linktest: true } } }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" }
 
 matrix:
   fast_finish: true

.haskell-ci

@@ -2,8 +2,9 @@
 compiler: ghc-8.0 lts-9.21
 compiler: ghc-8.2 lts-11.22
 compiler: ghc-8.4 lts-12.9
-compiler: ghc-8.4-edge lts-12.9
-compiler: ghc-8.4-experimental lts-12.9
+compiler: ghc-8.4-edge lts-12.26
+compiler: ghc-8.4-experimental lts-12.26
+compiler: ghc-8.6 lts-13.5
 
 # options
 option: gaugedep extradep=gauge-0.2.1
@@ -15,8 +16,8 @@ build: ghc-8.2 checkbounds gaugedep
 build: ghc-8.0 checkbounds gaugedep
 build: ghc-8.4-edge checkbounds package=edge/
 build: ghc-8.4-experimental checkbounds experimental allowed-failure gaugedep
-build: ghc-8.4 os=osx,linux,windows
-build: ghc-8.4 checkbounds os=osx,linux,windows
+build: ghc-8.6 os=osx,linux,windows
+build: ghc-8.6 checkbounds os=osx,linux,windows
 
 # packages
 package: foundation/

.travis.yml

@@ -1,4 +1,4 @@
-# ~*~ auto-generated by haskell-ci with config : 0487c3b5a1be273dd65c5cb36e42c12c0ff9c8ac3098315950725cdf228762e4 ~*~
+# ~*~ auto-generated by haskell-ci with config : ff1b963a6044945c37f27bf014779c728f2acd4d5706d068ce3c706ef124a613 ~*~
 
 # Use new container infrastructure to enable caching
 sudo: false
@@ -16,10 +16,10 @@ matrix:
   - { env: BUILD=stack RESOLVER=ghc-8.0, compiler: ghc-8.0, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
   - { env: BUILD=stack RESOLVER=ghc-8.4-edge, compiler: ghc-8.4-edge, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
   - { env: BUILD=stack RESOLVER=ghc-8.4-experimental, compiler: ghc-8.4-experimental, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
-  - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
-  - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
-  - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
-  - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
   - { env: BUILD=hlint, compiler: hlint, language: generic }
   - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
   allow_failures:
@@ -61,19 +61,19 @@ script:
         stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
         ;;
       ghc-8.4-edge)
-        echo "{ resolver: lts-12.9, packages: [ foundation/, basement/, edge/ ], extra-deps: [], flags: { foundation: { bounds-check: true, linktest: true } } }" > stack.yaml
+        echo "{ resolver: lts-12.26, packages: [ foundation/, basement/, edge/ ], extra-deps: [], flags: { foundation: { bounds-check: true, linktest: true } } }" > stack.yaml
         stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
         ;;
       ghc-8.4-experimental)
-        echo "{ resolver: lts-12.9, packages: [ foundation/, basement/ ], extra-deps: [ gauge-0.2.1 ], flags: { foundation: { bounds-check: true, linktest: true, experimental: true } } }" > stack.yaml
+        echo "{ resolver: lts-12.26, packages: [ foundation/, basement/ ], extra-deps: [ gauge-0.2.1 ], flags: { foundation: { bounds-check: true, linktest: true, experimental: true } } }" > stack.yaml
         stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
         ;;
-      ghc-8.4)
-        echo "{ resolver: lts-12.9, packages: [ foundation/, basement/ ], extra-deps: [], flags: {} }" > stack.yaml
+      ghc-8.6)
+        echo "{ resolver: lts-13.5, packages: [ foundation/, basement/ ], extra-deps: [], flags: {} }" > stack.yaml
         stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
         ;;
-      ghc-8.4)
-        echo "{ resolver: lts-12.9, packages: [ foundation/, basement/ ], extra-deps: [], flags: { foundation: { bounds-check: true, linktest: true } } }" > stack.yaml
+      ghc-8.6)
+        echo "{ resolver: lts-13.5, packages: [ foundation/, basement/ ], extra-deps: [], flags: { foundation: { bounds-check: true, linktest: true } } }" > stack.yaml
         stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
         ;;
       esac

basement/Basement/Bits.hs

@@ -56,7 +56,7 @@ import GHC.Int
 import GHC.IntWord64
 #endif
 
--- | operation over finit bits
+-- | operation over finite bits
 class FiniteBitsOps bits where
     -- | get the number of bits in the given object
     --
@@ -122,6 +122,11 @@ class BitOps bits where
     default clearBit :: FiniteBitsOps bits => bits -> Offset Bool -> bits
     clearBit x n = x .&. (bitFlip (bit n))
 
+infixl 8 .<<., .>>., `rotateL`, `rotateR`
+infixl 7 .&.
+infixl 6 .^.
+infixl 5 .|.
+
 -- | Bool set of 'n' bits.
 --
 newtype Bits (n :: Nat) = Bits { bitsToNatural :: Natural }
@@ -310,6 +315,56 @@ instance BitOps Word32 where
     (W32# x#) .<<. (CountOf (I# i#)) = W32# (narrow32Word# (x# `shiftL#` i#))
     (W32# x#) .>>. (CountOf (I# i#)) = W32# (narrow32Word# (x# `shiftRL#` i#))
 
+-- Word ---------------------------------------------------------------------
+
+#if WORD_SIZE_IN_BITS == 64
+instance FiniteBitsOps Word where
+    numberOfBits _ = 64
+    rotateL (W# x#) (CountOf (I# i#))
+        | isTrue# (i'# ==# 0#) = W# x#
+        | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#`
+                           (x# `uncheckedShiftRL#` (64# -# i'#)))
+      where
+        !i'# = word2Int# (int2Word# i# `and#` 63##)
+    rotateR (W# x#) (CountOf (I# i#))
+        | isTrue# (i'# ==# 0#) = W# x#
+        | otherwise  = W# ((x# `uncheckedShiftRL#` i'#) `or#`
+                           (x# `uncheckedShiftL#` (64# -# i'#)))
+      where
+        !i'# = word2Int# (int2Word# i# `and#` 63##)
+    bitFlip (W# x#) = W# (x# `xor#` mb#)
+        where !(W# mb#) = maxBound
+    popCount (W# x#) = CountOf $ wordToInt (W# (popCnt64# x#))
+    countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz64# w#))
+    countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz64# w#))
+#else
+    numberOfBits _ = 32
+    rotateL (W# x#) (CountOf (I# i#))
+        | isTrue# (i'# ==# 0#) = W# x#
+        | otherwise  = W# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`
+                                          (x# `uncheckedShiftRL#` (32# -# i'#))))
+      where
+        !i'# = word2Int# (int2Word# i# `and#` 31##)
+    rotateR (W# x#) (CountOf (I# i#))
+        | isTrue# (i'# ==# 0#) = W# x#
+        | otherwise  = W# ((x# `uncheckedShiftRL#` i'#) `or#`
+                           (x# `uncheckedShiftL#` (32# -# i'#)))
+      where
+        !i'# = word2Int# (int2Word# i# `and#` 31##)
+    bitFlip (W# x#) = W# (x# `xor#` mb#)
+        where !(W# mb#) = maxBound
+    popCount (W# x#) = CountOf $ wordToInt (W# (popCnt32# x#))
+    countLeadingZeros (W# w#) = CountOf $ wordToInt (W# (clz32# w#))
+    countTrailingZeros (W# w#) = CountOf $ wordToInt (W# (ctz32# w#))
+#endif
+
+instance BitOps Word where
+    (W# x#) .&. (W# y#)   = W# (x# `and#` y#)
+    (W# x#) .|. (W# y#)   = W# (x# `or#`  y#)
+    (W# x#) .^. (W# y#)   = W# (x# `xor#` y#)
+    (W# x#) .<<. (CountOf (I# i#)) = W# ((x# `shiftL#` i#))
+    (W# x#) .>>. (CountOf (I# i#)) = W# ((x# `shiftRL#` i#))
+
 -- Word64 ---------------------------------------------------------------------
 
 #if WORD_SIZE_IN_BITS == 64

basement/Basement/From.hs

@@ -213,6 +213,9 @@ instance From (Either a b) (These a b) where
     from (Left a) = This a
     from (Right b) = That b
 
+instance From Word128 Word256 where
+    from (Word128 a b) = Word256 0 0 a b
+
 -- basement instances
 
 -- uarrays

foundation/Foundation/Network/IPv4.hs

@@ -28,7 +28,7 @@ import Basement.Compat.Base
 import Data.Proxy
 import Foundation.String (String)
 import Foundation.Primitive
-import Foundation.Bits
+import Basement.Bits
 import Foundation.Parser hiding (peek)
 import Foundation.Collection (Sequential, Element, elem)
 

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-10.7
+resolver: lts-13.5
 packages:
 - location: foundation/
 - location: basement/