initial commit
[wavedrum/sharc-disassembler.git] / SHARC / Word48.hs
1 {-
2 This file is part of shark-disassembler.
3
4 Copyright (C) 2014 Ricardo Wurmus
5
6 This program is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program. If not, see <http://www.gnu.org/licenses/>.
18 -}
19
20 module SHARC.Word48 where
21
22 import Text.Printf (printf)
23 import Data.Word (Word8, Word64)
24 import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit)
25 import Data.Binary.Get
26 import Control.Monad (replicateM)
27
28 data Word48 = Word48 (Word8, Word8, Word8, Word8, Word8, Word8)
29 instance Show Word48 where
30 show (Word48 (a,b,c,d,e,f)) =
31 unwords $ map (printf "0x%02X") [a,b,c,d,e,f]
32
33 unpackWord8Word48 :: [Word8] -> Word48
34 unpackWord8Word48 [a,b,c,d,e,f] = Word48 (f,e,d,c,b,a)
35
36 getWord48 :: ([Word8] -> Word48) -> Get Word48
37 getWord48 p = fmap p $ replicateM 6 getWord8
38
39 getPackedWord48 :: Get Word48
40 getPackedWord48 = getWord48 unpackWord8Word48
41
42 word48ToWord64 :: Word48 -> Word64
43 word48ToWord64 (Word48 (a,b,c,d,e,f)) = fromIntegral a `shiftL` 40 .|.
44 fromIntegral b `shiftL` 32 .|.
45 fromIntegral c `shiftL` 24 .|.
46 fromIntegral d `shiftL` 16 .|.
47 fromIntegral e `shiftL` 8 .|.
48 fromIntegral f
49
50 -- apply mask and shift result to the very right
51 -- TODO: find a laxer type signature
52 cutMask :: Integral n => Word64 -> Word64 -> n
53 cutMask w mask = fromIntegral . fst $ until p shifter (w .&. mask, mask)
54 where
55 -- shift word by as much as we need to shift the mask to the very right
56 p (x, mask') = mask' `testBit` 0
57 shifter (x, m) = (x `shiftR` 1, m `shiftR` 1)
58