{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TemplateHaskell #-} -- | Template Haskell utilities for generating double words declarations module Data.DoubleWord.TH ( mkDoubleWord , mkUnpackedDoubleWord ) where import GHC.Arr (Ix(..)) import Data.Ratio ((%)) import Data.Bits (Bits(..)) import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int8, Int16, Int32, Int64) import Data.Hashable (Hashable(..), combine) import Control.Applicative ((<$>), (<*>)) import Language.Haskell.TH hiding (match) import Data.DoubleWord.Base -- | Declare signed and unsigned binary word types built from -- the specified low and high halves. The high halves /must/ have -- less or equal bit-length than the lover half. For each data type -- the following instances are declared: 'DoubleWord', 'Eq', 'Ord', -- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Read', -- 'Hashable', 'Ix', 'Bits', 'BinaryWord'. mkDoubleWord ∷ String -- ^ Unsigned variant type name → String -- ^ Unsigned variant constructor name → Strict -- ^ Unsigned variant higher half strictness → Name -- ^ Unsigned variant higher half type → String -- ^ Signed variant type name → String -- ^ Signed variant constructor name → Strict -- ^ Signed variant higher half strictness → Name -- ^ Signed variant higher half type → Strict -- ^ Lower half strictness → Name -- ^ Lower half type → [Name] -- ^ List of instances for automatic derivation → Q [Dec] mkDoubleWord un uc uhs uhn sn sc shs shn ls ln ad = (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls lt ad <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls lt ad where un' = mkName un uc' = mkName uc sn' = mkName sn sc' = mkName sc lt = ConT ln -- | @'mkUnpackedDoubleWord' u uh s sh l@ is an alias for -- @'mkDoubleWord' u u 'Unpacked' uh s s 'Unpacked' sh 'Unpacked' l@ mkUnpackedDoubleWord ∷ String -- ^ Unsigned variant type name → Name -- ^ Unsigned variant higher half type → String -- ^ Signed variant type name → Name -- ^ Signed variant higher half type → Name -- ^ Lower half type → [Name] -- ^ List of instances for automatic derivation → Q [Dec] mkUnpackedDoubleWord un uhn sn shn ln ad = mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln ad mkDoubleWord' ∷ Bool → Name → Name → Name → Name → Strict → Type → Strict → Type → [Name] → Q [Dec] mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT ad = (<$> mkRules) $ (++) $ [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] ad , inst ''DoubleWord [tp] [ TySynInstD ''LoWord [tpT] loT , TySynInstD ''HiWord [tpT] hiT , funLo 'loWord (VarE lo) , inline 'loWord , funHi 'hiWord (VarE hi) , inline 'hiWord , fun 'fromHiAndLo (ConE cn) , inline 'fromHiAndLo {- extendLo x = W allZeroes x -} , funX 'extendLo $ appWN ['allZeroes, x] , inline 'extendLo {- signExtendLo x = W (if x < 0 then allOnes else allZeroes) (unsignedWord x) -} , funX 'signExtendLo $ appW [ CondE (appVN 'testMsb [x]) (VarE 'allOnes) (VarE 'allZeroes) , appVN 'unsignedWord [x] ] , inlinable 'signExtendLo ] , inst ''Eq [tp] $ {- (W hi lo) == (W hi' lo') = hi == hi' && lo == lo' -} [ funHiLo2 '(==) $ appV '(&&) [appVN '(==) [hi, hi'], appVN '(==) [lo, lo']] , inline '(==) ] , inst ''Ord [tp] {- compare (W hi lo) (W hi' lo') = case hi `compare` hi' of EQ → lo `compare` lo' x → x -} [ funHiLo2 'compare $ CaseE (appVN 'compare [hi, hi']) [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) [] , Match (VarP x) (NormalB (VarE x)) [] ] , inlinable 'compare ] , inst ''Bounded [tp] {- minBound = W minBound minBound -} [ fun 'minBound $ appWN ['minBound, 'minBound] , inline 'minBound {- maxBound = W maxBound maxBound -} , fun 'maxBound $ appWN ['maxBound, 'maxBound] , inline 'maxBound ] , inst ''Enum [tp] {- succ (W hi lo) = if lo == maxBound then W (succ hi) minBound else W hi (succ lo) -} [ funHiLo 'succ $ CondE (appVN '(==) [lo, 'maxBound]) (appW [appVN 'succ [hi], VarE 'minBound]) (appW [VarE hi, appVN 'succ [lo]]) , inlinable 'succ {- pred (W hi lo) = if lo == minBound then W (pred hi) maxBound else W hi (pred lo) -} , funHiLo 'pred $ CondE (appVN '(==) [lo, 'minBound]) (appW [appVN 'pred [hi], VarE 'maxBound]) (appW [VarE hi, appVN 'pred [lo]]) , inlinable 'pred {- toEnum x | x < 0 = if signed then W (-1) (negate $ 1 + toEnum (negate (x + 1))) else ERROR | otherwise = W 0 (toEnum x) -} , funX 'toEnum $ CondE (appV '(<) [VarE x, litI 0]) (if signed then appW [ VarE 'allOnes , appV 'negate [ appV '(+) [ oneE , appV 'toEnum [ appV 'negate [appV '(+) [VarE x, litI 1]] ] ] ] ] else appV 'error [litS "toEnum: nagative value"]) (appW [VarE 'allZeroes, appVN 'toEnum [x]]) {- fromEnum (W 0 lo) = fromEnum lo fromEnum (W (-1) lo) = if signed then negate $ fromEnum $ negate lo else ERROR fromEnum _ = ERROR -} , FunD 'fromEnum $ Clause [ConP cn [LitP $ IntegerL 0, VarP lo]] (NormalB $ appVN 'fromEnum [lo]) [] : if signed then [ Clause [ConP cn [LitP $ IntegerL (-1), VarP lo]] (NormalB $ appV 'negate [appV 'fromEnum [appV 'negate [VarE lo]]]) [] , Clause [WildP] (NormalB $ appV 'error [litS "fromEnum: out of bounds"]) [] ] else [ Clause [WildP] (NormalB $ appV 'error [litS "fromEnum: out of bounds"]) [] ] {- enumFrom x = enumFromTo x maxBound -} , funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound] , inline 'enumFrom {- enumFromThen x y = enumFromThenTo x y $ if y >= x then maxBound else minBound -} , funXY 'enumFromThen $ appV 'enumFromThenTo [ VarE x , VarE y , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound) ] , inlinable 'enumFromThen {- enumFromTo x y = case y `compare` x of LT → x : down y x EQ → [x] GT → x : up y x where down to c = next : if next == to then [] else down to next where next = c - 1 up to c = next : if next == to then [] else up to next where next = c + 1 -} , FunD 'enumFromTo $ return $ Clause [VarP x, VarP y] (NormalB $ CaseE (appVN 'compare [y, x]) [ Match (ConP 'LT []) (NormalB $ appC '(:) [VarE x, appVN down [y, x]]) [] , Match (ConP 'EQ []) (NormalB $ appC '(:) [VarE x, ConE '[]]) [] , Match (ConP 'GT []) (NormalB $ appC '(:) [VarE x, appVN up [y, x]]) [] ]) [ FunD down $ return $ Clause [VarP to, VarP c] (NormalB $ appC '(:) [ VarE next , CondE (appVN '(==) [next, to]) (ConE '[]) (appVN down [to, next]) ]) [ValD (VarP next) (NormalB $ appVN '(-) [c, 'lsb]) []] , FunD up $ return $ Clause [VarP to, VarP c] (NormalB $ appC '(:) [ VarE next , CondE (appVN '(==) [next, to]) (ConE '[]) (appVN up [to, next]) ]) [ValD (VarP next) (NormalB $ appVN '(+) [c, 'lsb]) []] ] {- enumFromThenTo x y z = case y `compare` x of LT → if z > x then [] else down (x - y) z x EQ → repeat x GT → if z < x then [] else up (y - x) z x where down s to c = c : if next < to then [] else down s to next where next = c - s up s to c = c : if next > to then [] else up s to next where next = c + s -} , FunD 'enumFromThenTo $ return $ Clause [VarP x, VarP y, VarP z] (NormalB $ CaseE (appVN 'compare [y, x]) [ Match (ConP 'LT []) (NormalB $ CondE (appVN '(>) [z, x]) (ConE '[]) (appV down [appVN '(-) [x, y], VarE z, VarE x])) [] , Match (ConP 'EQ []) (NormalB $ appVN 'repeat [x]) [] , Match (ConP 'GT []) (NormalB $ CondE (appVN '(<) [z, x]) (ConE '[]) (appV up [appVN '(-) [y, x], VarE z, VarE x])) [] ]) [ FunD down $ return $ Clause [VarP step, VarP to, VarP c] (NormalB $ appC '(:) [ VarE c , CondE (appVN '(<) [next, to]) (ConE '[]) (appVN down [step, to, next]) ]) [ValD (VarP next) (NormalB $ appVN '(-) [c, step]) []] , FunD up $ return $ Clause [VarP step, VarP to, VarP c] (NormalB $ appC '(:) [ VarE c , CondE (appVN '(==) [next, to]) (ConE '[]) (appVN up [step, to, next]) ]) [ValD (VarP next) (NormalB $ appVN '(+) [c, step]) []]] ] , inst ''Num [tp] {- negate (W hi lo) = if lo == 0 then W (negate hi) 0 else W (negate $ hi + 1) (negate lo) -} [ funHiLo 'negate $ CondE (appVN '(==) [lo, 'allZeroes]) (appW [appVN 'negate [hi], zeroE]) (appW [ appV 'negate [appVN '(+) ['lsb, hi]] , appVN 'negate [lo] ]) , inlinable 'negate {- abs x = if SIGNED then if x < 0 then negate x else x else x -} , funX 'abs $ if signed then CondE (appVN '(<) [x, 'allZeroes]) (appVN 'negate [x]) (VarE x) else VarE x , if signed then inlinable 'abs else inline 'abs {- signum (W hi lo) = if SIGNED then case hi `compare` 0 of LT → W (-1) maxBound EQ → if lo == 0 then 0 else 1 GT → W 0 1 else if hi == 0 && lo == 0 then 0 else 1 -} , funHiLo 'signum $ if signed then CaseE (appVN 'compare [hi, 'allZeroes]) [ Match (ConP 'LT []) (NormalB $ appWN ['allOnes, 'maxBound]) [] , Match (ConP 'EQ []) (NormalB $ CondE (appVN '(==) [lo, 'allZeroes]) zeroE oneE) [] , Match (ConP 'GT []) (NormalB oneE) [] ] else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes] , appVN '(==) [lo, 'allZeroes] ]) zeroE oneE , inlinable 'signum {- (W hi lo) + (W hi' lo') = W y x where x = lo + lo' y = hi + hi' + if x < lo then 1 else 0 -} , funHiLo2' '(+) (appWN [y, x]) [ val x $ appVN '(+) [lo, lo'] , val y $ appV '(+) [ appVN '(+) [hi, hi'] , CondE (appVN '(<) [x, lo]) oneE zeroE ] ] , inlinable '(+) {- UNSIGNED: (W hi lo) * (W hi' lo') = W (hi * fromIntegral lo' + hi' * fromIntegral lo + fromIntegral x) y where (x, y) = unwrappedMul lo lo' SIGNED: x * y = signedWord $ unsignedWord x * unsignedWord y -} , if signed then funXY '(*) $ appV 'signedWord [appV '(*) [ appVN 'unsignedWord [x] , appVN 'unsignedWord [y] ]] else funHiLo2' '(*) (appW [ appV '(+) [ appV '(+) [ appV '(*) [VarE hi, appVN 'fromIntegral [lo']] , appV '(*) [VarE hi', appVN 'fromIntegral [lo]] ] , appVN 'fromIntegral [x] ] , VarE y ]) [vals [x, y] (appVN 'unwrappedMul [lo, lo'])] , inlinable '(*) {- fromInteger x = W (fromInteger y) (fromInteger z) where (y, z) = x `divMod` (toInteger (maxBound ∷ L) + 1) -} , funX' 'fromInteger (appW [appVN 'fromInteger [y], appVN 'fromInteger [z]]) [vals [y, z] (appV 'divMod [ VarE x , appV '(+) [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ])] ] , inst ''Real [tp] {- toRational x = toInteger x % 1 -} [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1] , inline 'toRational ] , inst ''Integral [tp] $ {- toInteger (W hi lo) = toInteger hi * (toInteger (maxBound ∷ L) + 1) + toInteger lo -} [ funHiLo 'toInteger $ appV '(+) [ appV '(*) [ appVN 'toInteger [hi] , appV '(+) [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ] , appVN 'toInteger [lo] ] {- UNSIGNED: quotRem x@(W hi lo) y@(W hi' lo') = if hi' == 0 && lo' == 0 then error "divide by zero" else case compare hi hi' of LT → (0, x) EQ → compare lo lo' of LT → (0, x) EQ → (1, 0) GT | hi' == 0 → (W 0 t2, W 0 t1) where (t2, t1) = quotRem lo lo' GT → (1, lo - lo') GT | lo' == 0 → (W 0 (fromIntegral t2), W (fromIntegral t1) lo) where (t2, t1) = quotRem hi hi' GT | hi' == 0 && lo' == maxBound → if t2 == 0 then if t1 == maxBound then (W 0 z + 1, 0) else (W 0 z, t1) else if t1 == maxBound then (W 0 z + 2, 1) else if t1 == xor maxBound 1 then (W 0 z + 2, 0) else (W 0 z + 1, W 0 (t1 + 1)) where z = fromIntegral hi (t2, t1) = unwrappedAdd z lo GT | hi' == 0 → (t2, W 0 t1) where (t2, t1) = div1 hi lo lo' GT → if t1 == t2 then (1, x - y) else (W 0 (fromIntegral q2), shiftR r2 t2) where t1 = leadingZeroes hi t2 = leadingZeroes hi' z = shiftR hi (bitSize (undefined ∷ H) - t2) W hhh hll = shiftL x t2 v@(W lhh lll) = shiftL y t2 -- z hhh hll / lhh lll ((0, q1), r1) = div2 z hhh lhh (t4, t3) = unwrappedMul (fromIntegral q1) lll t5 = W (fromIntegral t4) t3 t6 = W r1 hll (t8, t7) = unwrappedAdd t6 v (t10, t9) = unwrappedAdd t7 v (q2, r2) = if t5 > t6 then if loWord t8 == 0 then if t7 >= t5 then (q1 - 1, t7 - t5) else if loWord t10 == 0 then (q1 - 2, t9 - t5) else (q1 - 2, (maxBound - t5) + t9 + 1) else (q1 - 1, (maxBound - t5) + t7 + 1) else (q1, t6 - t5) where div1 hhh hll by = go hhh hll 0 where (t2, t1) = quotRem maxBound by go h l c = if z == 0 then (c + W (fromIntegral t8) t7 + W 0 t10, t9) else go (fromIntegral z) t5 (c + (W (fromIntegral t8) t7)) where h1 = fromIntegral h (t4, t3) = unwrappedMul h1 (t1 + 1) (t6, t5) = unwrappedAdd t3 l z = t4 + t6 (t8, t7) = unwrappedMul h1 t2 (t10, t9) = quotRem t5 by div2 hhh hll by = go hhh hll (0, 0) where (t2, t1) = quotRem maxBound by go h l c = if z == 0 then (addT (addT c (t8, t7)) (0, t10), t9) else go z t5 (addT c (t8, t7)) where (t4, t3) = unwrappedMul h (t1 + 1) (t6, t5) = unwrappedAdd t3 l z = t4 + t6 (t8, t7) = unwrappedMul h t2 (t10, t9) = quotRem t5 by addT (lhh, lhl) (llh, lll) = (lhh + llh + t4, t3) where (t4, t3) = unwrappedAdd lhl lll SIGNED: quotRem x y = if x < 0 then if y < 0 then let (q, r) = quotRem (negate $ unsignedWord x) (negate $ unsignedWord y) in (signedWord q, signedWord $ negate r) else let (q, r) = quotRem (negate $ unsignedWord x) (unsignedWord y) in (signedWord $ negate q, signedWord $ negate r) else if y < 0 then let (q, r) = quotRem (unsignedWord x) (negate $ unsignedWord y) in (signedWord $ negate q, signedWord r) else let (q, r) = quotRem (unsignedWord x) (unsignedWord y) in (signedWord q, signedWord r) -} , if signed then funXY 'quotRem $ CondE (appVN 'testMsb [x]) (CondE (appVN 'testMsb [y]) (LetE [vals [q, r] $ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appV 'unsignedWord [appVN 'negate [y]] ]] (TupE [ appVN 'signedWord [q] , appV 'signedWord [appVN 'negate [r]] ])) (LetE [vals [q, r] $ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appVN 'unsignedWord [y] ]] (TupE [ appV 'signedWord [appVN 'negate [q]] , appV 'signedWord [appVN 'negate [r]] ]))) (CondE (appVN 'testMsb [y]) (LetE [vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appV 'unsignedWord [appVN 'negate [y]] ]] (TupE [ appV 'signedWord [appVN 'negate [q]] , appVN 'signedWord [r] ])) (LetE [vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appVN 'unsignedWord [y] ]] (TupE [ appVN 'signedWord [q] , appVN 'signedWord [r] ]))) else funHiLo2XY' 'quotRem (CondE (appV '(&&) [ appVN '(==) [hi', 'allZeroes] , appVN '(==) [lo', 'allZeroes] ]) (appV 'error [litS "divide by zero"]) (CaseE (appVN 'compare [hi, hi']) [ match (ConP 'LT []) (TupE [zeroE, VarE x]) , match (ConP 'EQ []) (CaseE (appVN 'compare [lo, lo']) [ match (ConP 'LT []) (TupE [zeroE, VarE x]) , match (ConP 'EQ []) (TupE [oneE, zeroE]) , Match (ConP 'GT []) (GuardedB $ return ( NormalG (appVN '(==) [hi', 'allZeroes]) , TupE [ appWN ['allZeroes, t2] , appWN ['allZeroes, t1] ])) [vals [t2, t1] $ appVN 'quotRem [lo, lo']] , match (ConP 'GT []) $ TupE [ oneE , appW [zeroE, appVN '(-) [lo, lo']] ] ]) , Match (ConP 'GT []) (GuardedB $ return ( NormalG (appVN '(==) [lo', 'allZeroes]) , TupE [ appW [zeroE, appVN 'fromIntegral [t2]] , appW [appVN 'fromIntegral [t1], VarE lo] ] )) [vals [t2, t1] $ appVN 'quotRem [hi, hi']] , Match (ConP 'GT []) (GuardedB $ return ( NormalG (appV '(&&) [ appVN '(==) [hi', 'allZeroes] , appVN '(==) [lo', 'maxBound] ]) , CondE (appVN '(==) [t2, 'allZeroes]) (CondE (appVN '(==) [t1, 'maxBound]) (TupE [ appV '(+) [ appWN ['allZeroes, z] , oneE ] , zeroE ]) (TupE [ appWN ['allZeroes, z] , appWN ['allZeroes, t1] ])) (CondE (appVN '(==) [t1, 'maxBound]) (TupE [ appV '(+) [appWN ['allZeroes, z], litI 2] , oneE ]) (CondE (appV '(==) [ VarE t1 , appVN 'xor ['maxBound, 'lsb] ]) (TupE [ appV '(+) [appWN ['allZeroes, z], litI 2] , zeroE ]) (TupE [ appV '(+) [appWN ['allZeroes, z], oneE] , appW [ zeroE , appVN '(+) [t1, 'lsb] ] ]))) )) [ val z $ appVN 'fromIntegral [hi] , vals [t2, t1] $ appVN 'unwrappedAdd [z, lo] ] , Match (ConP 'GT []) (GuardedB $ return ( NormalG (appVN '(==) [hi', 'allZeroes]) , TupE [VarE t2, appWN ['allZeroes, t1]] )) [vals [t2, t1] $ appVN div1 [hi, lo, lo']] , match' (ConP 'GT []) (CondE (appVN '(==) [t1, t2]) (TupE [oneE, appVN '(-) [x, y]]) (TupE [ appW [zeroE, appVN 'fromIntegral [q2]] , appVN 'shiftR [r2, t2] ])) [ val t1 $ appVN 'leadingZeroes [hi] , val t2 $ appVN 'leadingZeroes [hi'] , val z $ appV 'shiftR [ VarE hi , appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) hiT] , VarE t2 ] ] , ValD (ConP cn [VarP hhh, VarP hll]) (NormalB $ appVN 'shiftL [x, t2]) [] , ValD (AsP v $ ConP cn [VarP lhh, VarP lll]) (NormalB $ appVN 'shiftL [y, t2]) [] , ValD (TupP [ TupP [LitP (IntegerL 0), VarP q1] , VarP r1 ]) (NormalB $ appVN div2 [z, hhh, lhh]) [] , vals [t4, t3] $ appV 'unwrappedMul [appVN 'fromIntegral [q1], VarE lll] , val t5 $ appW [appVN 'fromIntegral [t4], VarE t3] , val t6 $ appWN [r1, hll] , vals [t8, t7] $ appVN 'unwrappedAdd [t6, v] , vals [t10, t9] $ appVN 'unwrappedAdd [t7, v] , vals [q2, r2] $ CondE (appVN '(>) [t5, t6]) (CondE (appV '(==) [appVN 'loWord [t8], zeroE]) (CondE (appVN '(>=) [t7, t5]) (TupE [ appVN '(-) [q1, 'lsb] , appVN '(-) [t7, t5] ]) (CondE (appV '(==) [ appVN 'loWord [t10] , zeroE ]) (TupE [ appV '(-) [VarE q1, litI 2] , appVN '(-) [t9, t5] ]) (TupE [ appV '(-) [VarE q1, litI 2] , appV '(+) [ appVN '(-) ['maxBound, t5] , appVN '(+) [t9, 'lsb] ] ]))) (TupE [ appVN '(-) [q1, 'lsb] , appV '(+) [ appVN '(-) ['maxBound, t5] , appVN '(+) [t7, 'lsb] ] ])) (TupE [VarE q1, appVN '(-) [t6, t5]]) ] ])) [ FunD div1 $ return $ Clause [VarP hhh, VarP hll, VarP by] (NormalB (appVN go [hhh, hll, 'allZeroes])) [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] , FunD go $ return $ Clause [VarP h, VarP l, VarP c] (NormalB (CondE (appVN '(==) [z, 'allZeroes]) (TupE [ appV '(+) [ VarE c , appV '(+) [ appW [ appVN 'fromIntegral [t8] , VarE t7 ] , appWN ['allZeroes, t10] ] ] , VarE t9 ]) (appV go [ appVN 'fromIntegral [z] , VarE t5 , appV '(+) [ VarE c , appW [ appVN 'fromIntegral [t8] , VarE t7 ] ] ]))) [ val h1 $ appVN 'fromIntegral [h] , vals [t4, t3] $ appV 'unwrappedMul [VarE h1, appVN '(+) [t1, 'lsb]] , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l] , val z $ appVN '(+) [t4, t6] , vals [t8, t7] $ appVN 'unwrappedMul [h1, t2] , vals [t10, t9] $ appVN 'quotRem [t5, by] ] ] , FunD div2 $ return $ Clause [VarP hhh, VarP hll, VarP by] (NormalB (appV go [ VarE hhh , VarE hll , TupE [zeroE, zeroE]])) [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] , FunD go $ return $ Clause [VarP h, VarP l, VarP c] (NormalB (CondE (appVN '(==) [z, 'allZeroes]) (TupE [ appV addT [ VarE c , appV addT [ TupE [VarE t8 , VarE t7] , TupE [zeroE, VarE t10] ] ] , VarE t9 ]) (appV go [ VarE z , VarE t5 , appV addT [ VarE c , TupE [VarE t8, VarE t7] ] ]))) [ vals [t4, t3] $ appV 'unwrappedMul [VarE h, appVN '(+) [t1, 'lsb]] , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l] , val z $ appVN '(+) [t4, t6] , vals [t8, t7] $ appVN 'unwrappedMul [h, t2] , vals [t10, t9] $ appVN 'quotRem [t5, by] ] , FunD addT $ return $ Clause [ TupP [VarP lhh, VarP lhl] , TupP [VarP llh, VarP lll] ] (NormalB (TupE [ appV '(+) [ VarE t4 , appVN '(+) [lhh, llh] ] , VarE t3 ])) [vals [t4, t3] $ appVN 'unwrappedAdd [lhl, lll]] ] ] {- UNSIGNED: divMod = quotRem SIGNED: divMod x y = if x < 0 then if y < 0 then let (q, r) = quotRem (negate $ unsignedWord x) (negate $ unsignedWord y) in (signedWord q, signedWord $ negate r) else let (q, r) = quotRem (negate $ unsignedWord x) (unsignedWord y) q1 = signedWord (negate q) r1 = signedWord (negate r) in if r == 0 then (q1, r1) else (q1 - 1, r1 + y) else if y < 0 then let (q, r) = quotRem (unsignedWord x) (negate $ unsignedWord y) q1 = signedWord (negate q) r1 = signedWord r in if r == 0 then (q1, r1) else (q1 - 1, r1 + y) else let (q, r) = quotRem (unsignedWord x) (unsignedWord y) in (signedWord q, signedWord r) -} , if signed then funXY 'divMod $ CondE (appVN 'testMsb [x]) (CondE (appVN 'testMsb [y]) (LetE [vals [q, r] $ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appV 'unsignedWord [appVN 'negate [y]] ]] (TupE [ appVN 'signedWord [q] , appV 'signedWord [appVN 'negate [r]] ])) (LetE [ vals [q, r] $ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appVN 'unsignedWord [y] ] , val q1 $ appV 'signedWord [appVN 'negate [q]] , val r1 $ appV 'signedWord [appVN 'negate [r]] ] (CondE (appVN '(==) [r, 'allZeroes]) (TupE [VarE q1, VarE r1]) (TupE [ appVN '(-) [q1, 'lsb] , appVN '(+) [r1, y] ])))) (CondE (appVN 'testMsb [y]) (LetE [ vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appV 'unsignedWord [appVN 'negate [y]] ] , val q1 $ appV 'signedWord [appVN 'negate [q]] , val r1 $ appVN 'signedWord [r] ] (CondE (appVN '(==) [r, 'allZeroes]) (TupE [VarE q1, VarE r1]) (TupE [ appVN '(-) [q1, 'lsb] , appVN '(+) [r1, y] ]))) (LetE [vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appVN 'unsignedWord [y] ]] (TupE [ appVN 'signedWord [q] , appVN 'signedWord [r] ]))) else fun 'divMod $ VarE 'quotRem ] ++ if signed then [] else [inline 'divMod] , inst ''Show [tp] [ fun 'show $ appVN '(.) ['show, 'toInteger] , inline 'show ] , inst ''Read [tp] {- readsPrec x y = fmap (\(q, r) → (fromInteger q, r)) $ readsPrec x y -} [ funXY 'readsPrec $ appV 'fmap [ LamE [TupP [VarP q, VarP r]] (TupE [appVN 'fromInteger [q], VarE r]) , appVN 'readsPrec [x, y] ] ] , inst ''Hashable [tp] {- hash (W hi lo) = hash hi `combine` hash lo -} [ funHiLo 'hash $ appV 'combine [appVN 'hash [hi], appVN 'hash [lo]] , inline 'hash , inline 'hashWithSalt ] , inst ''Ix [tp] {- range (x, y) = enumFromTo x y -} [ funTup 'range $ appVN 'enumFromTo [x, y] , inline 'range {- unsafeIndex (x, _) z = fromIntegral z - fromIntegral x -} , funTupLZ 'unsafeIndex $ appV '(-) [appVN 'fromIntegral [z], appVN 'fromIntegral [x]] , inline 'unsafeIndex {- inRange (x, y) z = z >= x && z <= y -} , funTupZ 'inRange $ appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]] , inline 'inRange ] , inst ''Bits [tp] $ {- bitSize _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -} [ fun_ 'bitSize $ appV '(+) [ appV 'bitSize [SigE (VarE 'undefined) hiT] , appV 'bitSize [SigE (VarE 'undefined) loT] ] , inline 'bitSize {- isSigned _ = SIGNED -} , fun_ 'isSigned $ ConE $ if signed then 'True else 'False , inline 'isSigned {- complement (W hi lo) = W (complement hi) (complement lo) -} , funHiLo 'complement $ appW [appVN 'complement [hi], appVN 'complement [lo]] , inline 'complement {- xor (W hi lo) (W hi' lo') = W (xor hi hi') (xor lo lo') -} , funHiLo2 'xor $ appW [appVN 'xor [hi, hi'], appVN 'xor [lo, lo']] , inline 'xor {- (W hi lo) .&. (W hi' lo') = W (hi .&. hi') (lo .&. lo') -} , funHiLo2 '(.&.) $ appW [appVN '(.&.) [hi, hi'], appVN '(.&.) [lo, lo']] , inline '(.&.) {- (W hi lo) .|. (W hi' lo') = W (hi .|. hi') (lo .|. lo') -} , funHiLo2 '(.|.) $ appW [appVN '(.|.) [hi, hi'], appVN '(.|.) [lo, lo']] , inline '(.|.) {- shiftL (W hi lo) x = if y > 0 then W (shiftL hi x .|. fromIntegral (shiftR lo y)) (shiftL lo x) else W (fromIntegral $ shiftL lo $ negate y) 0 where y = bitSize (undefined ∷ L) - x -} , funHiLoX' 'shiftL (CondE (appV '(>) [VarE y, litI 0]) (appW [ appV '(.|.) [ appVN 'shiftL [hi, x] , appV 'fromIntegral [appVN 'shiftR [lo, y]] ] , appVN 'shiftL [lo, x] ]) (appW [ appV 'fromIntegral [appV 'shiftL [VarE lo, appVN 'negate [y]]] , zeroE ])) [val y $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] , VarE x ]] {- shiftR (W hi lo) x = W (shiftR hi x) (if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x else z) where y = bitSize (undefined ∷ L) - x z = if SIGNED then fromIntegral $ shiftR (fromIntegral hi ∷ SignedWord L) $ negate y else shiftR (fromIntegral hi) $ negate y -} , funHiLoX' 'shiftR (appW [ appVN 'shiftR [hi, x] , CondE (appV '(>=) [VarE y, litI 0]) (appV '(.|.) [ appV 'shiftL [appVN 'fromIntegral [hi], VarE y] , appVN 'shiftR [lo, x] ]) (VarE z) ]) [ val y $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] , VarE x ] , val z $ if signed then appV 'fromIntegral [appV 'shiftR [ SigE (appVN 'fromIntegral [hi]) (AppT (ConT ''SignedWord) loT) , appVN 'negate [y] ]] else appV 'shiftR [ appVN 'fromIntegral [hi] , appVN 'negate [y] ] ] {- UNSIGNED: rotateL (W hi lo) x = if y >= 0 then W (fromIntegral (shiftL lo y) .|. shiftR hi z) W (shiftL (fromIntegral hi) (bitSize (undefined ∷ L) - z) .|. shiftR lo z) else W (fromIntegral (shiftR lo $ negate y) .|. shiftL hi x) (shift (fromIntegral hi) (bitSize (undefined ∷ L) - z) .|. shiftL lo x .|. shiftR lo z) where y = x - bitSize (undefined ∷ L) z = bitSize (undefined ∷ W) - x SIGNED: rotateL x y = signedWord $ rotateL (unsignedWord x) y -} , if signed then funXY 'rotateL $ appV 'signedWord [appV 'rotateL [appVN 'unsignedWord [x], VarE y]] else funHiLoX' 'rotateL (CondE (appV '(>=) [VarE y, litI 0]) (appW [ appV '(.|.) [ appV 'fromIntegral [appVN 'shiftL [lo, y]] , appVN 'shiftR [hi, z] ] , appV '(.|.) [ appV 'shiftL [ appVN 'fromIntegral [hi] , appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] , VarE z ] ] , appVN 'shiftR [lo, z] ] ]) (appW [ appV '(.|.) [ appV 'fromIntegral [appV 'shiftR [VarE lo, appVN 'negate [y]]] , appVN 'shiftL [hi, x] ] , appV '(.|.) [ appV 'shift [ appVN 'fromIntegral [hi] , appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] , VarE z] ] , appV '(.|.) [appVN 'shiftL [lo, x], appVN 'shiftR [lo, z]] ] ])) [ val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ] , val z $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) tpT] , VarE x ] ] {- rotateR x y = rotateL x $ bitSize (undefined ∷ W) - y -} , funXY 'rotateR $ appV 'rotateL [ VarE x , appV '(-) [appV 'bitSize [SigE (VarE 'undefined) tpT], VarE y] ] , inline 'rotateR {- bit x = if y >= 0 then W (bit y) 0 else W 0 (bit x) where y = x - bitSize (undefined ∷ LoWord W) -} , funX' 'bit (CondE (appV '(>=) [VarE y, litI 0]) (appW [appVN 'bit [y], zeroE]) (appW [zeroE, appVN 'bit [x]])) [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] , inlinable 'bit {- setBit (W hi lo) x = if y >= 0 then W (setBit hi y) lo else W hi (setBit lo x) where y = x - bitSize (undefined ∷ L) -} , funHiLoX' 'setBit (CondE (appV '(>=) [VarE y, litI 0]) (appW [appVN 'setBit [hi, y], VarE lo]) (appW [VarE hi, appVN 'setBit [lo, x]])) [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] , inlinable 'setBit {- clearBit (W hi lo) x = if y >= 0 then W (clearBit hi y) lo else W hi (clearBit lo x) where y = x - bitSize (undefined ∷ L) -} , funHiLoX' 'clearBit (CondE (appV '(>=) [VarE y, litI 0]) (appW [appVN 'clearBit [hi, y], VarE lo]) (appW [VarE hi, appVN 'clearBit [lo, x]])) [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] , inlinable 'clearBit {- complementBit (W hi lo) x = if y >= 0 then W (complementBit hi y) lo else W hi (complementBit lo x) where y = x - bitSize (undefined ∷ L) -} , funHiLoX' 'complementBit (CondE (appV '(>=) [VarE y, litI 0]) (appW [appVN 'complementBit [hi, y], VarE lo]) (appW [VarE hi, appVN 'complementBit [lo, x]])) [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] , inlinable 'complementBit {- testBit (W hi lo) x = if y >= 0 then testBit hi y else testBit lo x where y = x - bitSize (undefined ∷ L) -} , funHiLoX' 'testBit (CondE (appV '(>=) [VarE y, litI 0]) (appVN 'testBit [hi, y]) (appVN 'testBit [lo, x])) [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] , inlinable 'testBit {- popCount (W hi lo) = popCount hi + popCount lo -} , funHiLo 'popCount (appV '(+) [appVN 'popCount [hi], appVN 'popCount [lo]]) , inline 'popCount ] ++ if signed then [inline 'rotateL] else [] , inst ''BinaryWord [tp] [ TySynInstD ''UnsignedWord [tpT] $ ConT $ if signed then otp else tp , TySynInstD ''SignedWord [tpT] $ ConT $ if signed then tp else otp {- UNSIGNED: unsignedWord = id SIGNED: unsignedWord (W hi lo) = U (unsignedWord hi) lo -} , if signed then funHiLo 'unsignedWord $ appC ocn [appVN 'unsignedWord [hi], VarE lo] else fun 'unsignedWord $ VarE 'id , inline 'unsignedWord {- UNSIGNED: signedWord (W hi lo) = S (signedWord hi) lo SIGNED: signedWord = id -} , if signed then fun 'signedWord $ VarE 'id else funHiLo 'signedWord $ appC ocn [appVN 'signedWord [hi], VarE lo] , inline 'signedWord {- UNSIGNED: unwrappedAdd (W hi lo) (W hi' lo') = (W 0 z, W y x) where (t1, x) = unwrappedAdd lo lo' (t3, t2) = unwrappedAdd hi (fromIntegral t1) (t4, y) = unwrappedAdd t2 hi' z = fromIntegral $ t3 + t4 SIGNED: unwrappedAdd x y = (z, t4) where t1 = if x < 0 then maxBound else minBound t2 = if y < 0 then maxBound else minBound (t3, t4) = unwrappedAdd (unsignedWord x) (unsignedWord y) z = signedWord $ t1 + t2 + t3 -} , if signed then funXY' 'unwrappedAdd (TupE [VarE z, VarE t4]) [ val t1 $ CondE (appVN 'testMsb [x]) (VarE 'maxBound) (VarE 'minBound) , val t2 $ CondE (appVN 'testMsb [y]) (VarE 'maxBound) (VarE 'minBound) , vals [t3, t4] $ appV 'unwrappedAdd [ appVN 'unsignedWord [x] , appVN 'unsignedWord [y] ] , val z $ appV 'signedWord [appV '(+) [VarE t1, appVN '(+) [t2, t3]]] ] else funHiLo2' 'unwrappedAdd (TupE [appWN ['allZeroes, z], appWN [y, x]]) [ vals [t1, x] $ appVN 'unwrappedAdd [lo, lo'] , vals [t3, t2] $ appV 'unwrappedAdd [VarE hi, appVN 'fromIntegral [t1]] , vals [t4, y] $ appVN 'unwrappedAdd [t2, hi'] , val z $ appV 'fromIntegral [appVN '(+) [t3, t4]] ] {- UNSIGNED: unwrappedMul (W hi lo) (W hi' lo') = (W (hhh + fromIntegral (shiftR t9 y) + shiftL x z) (shiftL t9 z .|. shiftR t3 y), W (fromIntegral t3) lll) where (llh, lll) = unwrappedMul lo lo' (hlh, hll) = unwrappedMul (fromIntegral hi) lo' (lhh, lhl) = unwrappedMul lo (fromIntegral hi') (hhh, hhl) = unwrappedMul hi hi' (t2, t1) = unwrappedAdd llh hll (t4, t3) = unwrappedAdd t1 lhl (t6, t5) = unwrappedAdd (fromIntegral hhl) (t2 + t4) (t8, t7) = unwrappedAdd t5 lhh (t10, t9) = unwrappedAdd t7 hlh x = fromIntegral $ t6 + t8 + t10 y = bitSize (undefined ∷ H) z = bitSize (undefined ∷ L) - y SIGNED: unwrappedMul (W hi lo) (W hi' lo') = (x, y) where t1 = W (complement hi') (complement lo') + 1 t2 = W (complement hi) (complement lo) + 1 (t3, y) = unwrappedMul (U (unsignedWord hi) lo) (U (unsignedWord hi') lo') z = signedWord t3 x = if hi < 0 then if hi' < 0 then z + t1 + t2 else z + t1 else if hi' < 0 then z + t2 else z -} , if signed then funHiLo2' 'unwrappedMul (TupE [VarE x, VarE y]) [ val t1 $ appV '(+) [ appW [ appVN 'complement [hi'] , appVN 'complement [lo'] ] , oneE ] , val t2 $ appV '(+) [ appW [ appVN 'complement [hi] , appVN 'complement [lo] ] , oneE ] , vals [t3, y] $ appV 'unwrappedMul [ appC ocn [appVN 'unsignedWord [hi], VarE lo] , appC ocn [appVN 'unsignedWord [hi'], VarE lo'] ] , val z $ appVN 'signedWord [t3] , val x $ CondE (appVN 'testMsb [hi]) (CondE (appVN 'testMsb [hi']) (appV '(+) [VarE z, appVN '(+) [t1, t2]]) (appVN '(+) [z, t1])) (CondE (appVN 'testMsb [hi']) (appVN '(+) [z, t2]) (VarE z)) ] else funHiLo2' 'unwrappedMul (TupE [ appW [ appV '(+) [ VarE hhh , appV '(+) [ appV 'fromIntegral [appVN 'shiftR [t9, y]] , appVN 'shiftL [x, z] ] ] , appV '(.|.) [ appVN 'shiftL [t9, z] , appVN 'shiftR [t3, y] ] ] , appW [appVN 'fromIntegral [t3], VarE lll] ]) [ vals [llh, lll] $ appVN 'unwrappedMul [lo, lo'] , vals [hlh, hll] $ appV 'unwrappedMul [appVN 'fromIntegral [hi], VarE lo'] , vals [lhh, lhl] $ appV 'unwrappedMul [VarE lo, appVN 'fromIntegral [hi']] , vals [hhh, hhl] $ appVN 'unwrappedMul [hi, hi'] , vals [t2, t1] $ appVN 'unwrappedAdd [llh, hll] , vals [t4, t3] $ appVN 'unwrappedAdd [t1, lhl] , vals [t6, t5] $ appV 'unwrappedAdd [ appVN 'fromIntegral [hhl] , appVN '(+) [t2, t4] ] , vals [t8, t7] $ appVN 'unwrappedAdd [t5, lhh] , vals [t10, t9] $ appVN 'unwrappedAdd [t7, hlh] , val x $ appV 'fromIntegral [appV '(+) [VarE t6, appVN '(+) [t8, t10]]] , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT] , val z $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] , VarE y ] ] {- UNSIGNED: leadingZeroes (W hi lo) = if x == y then y + leadingZeroes lo else x where x = leadingZeroes hi y = bitSize (undefined ∷ H) SIGNED: leadingZeroes = leadingZeroes . unsignedWord -} , if signed then fun 'leadingZeroes $ appVN '(.) ['leadingZeroes, 'unsignedWord] else funHiLo' 'leadingZeroes (CondE (appVN '(==) [x, y]) (appV '(+) [VarE y, appVN 'leadingZeroes [lo]]) (VarE x)) [ val x $ appVN 'leadingZeroes [hi] , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT] ] , if signed then inlinable 'leadingZeroes else inline 'leadingZeroes {- UNSIGNED: trailingZeroes (W hi lo) = if x == y then y + trailingZeroes hi else x where x = trailingZeroes lo y = bitSize (undefined ∷ L) SIGNED: trailingZeroes = trailingZeroes . unsignedWord -} , if signed then fun 'trailingZeroes $ appVN '(.) ['trailingZeroes, 'unsignedWord] else funHiLo' 'trailingZeroes (CondE (appVN '(==) [x, y]) (appV '(+) [VarE y, appVN 'trailingZeroes [hi]]) (VarE x)) [ val x $ appVN 'trailingZeroes [lo] , val y $ appV 'bitSize [SigE (VarE 'undefined) loT] ] , if signed then inlinable 'trailingZeroes else inline 'trailingZeroes {- allZeroes = W allZeroes allZeroes -} , fun 'allZeroes $ appWN ['allZeroes, 'allZeroes] , inline 'allZeroes {- allOnes = W allOnes allOnes -} , fun 'allOnes $ appWN ['allOnes, 'allOnes] , inline 'allOnes {- msb = W msb allZeroes -} , fun 'msb $ appWN ['msb, 'allZeroes] , inline 'msb {- lsb = W allZeroes lsb -} , fun 'lsb $ appWN ['allZeroes, 'lsb] , inline 'lsb {- testMsb (W hi _) = testMsb hi -} , funHi 'testMsb $ appVN 'testMsb [hi] , inline 'testMsb {- testLsb (W _ lo) = testLsb lo -} , funLo 'testLsb $ appVN 'testLsb [lo] , inline 'testLsb ] ] where x = mkName "x" y = mkName "y" z = mkName "z" t1 = mkName "t1" t2 = mkName "t2" t3 = mkName "t3" t4 = mkName "t4" t5 = mkName "t5" t6 = mkName "t6" t7 = mkName "t7" t8 = mkName "t8" t9 = mkName "t9" t10 = mkName "t10" v = mkName "v" q = mkName "q" q1 = mkName "q1" q2 = mkName "q2" r = mkName "r" r1 = mkName "r1" r2 = mkName "r2" lll = mkName "lll" llh = mkName "llh" lhl = mkName "lhl" lhh = mkName "lhh" hll = mkName "hll" hlh = mkName "hlh" hhl = mkName "hhl" hhh = mkName "hhh" h = mkName "h" h1 = mkName "h1" l = mkName "l" div1 = mkName "div1" div2 = mkName "div2" addT = mkName "addT" by = mkName "by_" go = mkName "go_" c = mkName "c" next = mkName "next_" step = mkName "step_" to = mkName "to_" down = mkName "down_" up = mkName "up_" hi = mkName "hi_" lo = mkName "lo_" hi' = mkName "hi'" lo' = mkName "lo'" tpT = ConT tp inst cls params = InstanceD [] (foldl AppT (ConT cls) (ConT <$> params)) fun n e = FunD n [Clause [] (NormalB e) []] fun_ n e = FunD n [Clause [WildP] (NormalB e) []] funX' n e ds = FunD n [Clause [VarP x] (NormalB e) ds] funX n e = funX' n e [] funXY' n e ds = FunD n [Clause [VarP x, VarP y] (NormalB e) ds] funXY n e = funXY' n e [] funTup n e = FunD n [Clause [TupP [VarP x, VarP y]] (NormalB e) []] funTupZ n e = FunD n [Clause [TupP [VarP x, VarP y], VarP z] (NormalB e) []] funTupLZ n e = FunD n [Clause [TupP [VarP x, WildP], VarP z] (NormalB e) []] funLo n e = FunD n [Clause [ConP cn [WildP, VarP lo]] (NormalB e) []] funHi n e = FunD n [Clause [ConP cn [VarP hi, WildP]] (NormalB e) []] funHiLo n e = funHiLo' n e [] funHiLo' n e ds = FunD n [Clause [ConP cn [VarP hi, VarP lo]] (NormalB e) ds] funHiLoX' n e ds = FunD n [Clause [ConP cn [VarP hi, VarP lo], VarP x] (NormalB e) ds] funHiLo2 n e = funHiLo2' n e [] funHiLo2' n e ds = FunD n [Clause [ ConP cn [VarP hi, VarP lo] , ConP cn [VarP hi', VarP lo'] ] (NormalB e) ds] funHiLo2XY' n e ds = FunD n [Clause [ AsP x (ConP cn [VarP hi, VarP lo]) , AsP y (ConP cn [VarP hi', VarP lo']) ] (NormalB e) ds] match' p e ds = Match p (NormalB e) ds match p e = match' p e [] inline n = PragmaD $ InlineP n Inline FunLike AllPhases inlinable n = PragmaD $ InlineP n Inlinable FunLike AllPhases val n e = ValD (VarP n) (NormalB e) [] vals ns e = ValD (TupP (VarP <$> ns)) (NormalB e) [] app f = foldl AppE f appN f = app f . fmap VarE appV f = app (VarE f) appC f = app (ConE f) appW = appC cn appVN f = appN (VarE f) appCN f = appN (ConE f) appWN = appCN cn litI = LitE . IntegerL litS = LitE . StringL zeroE = VarE 'allZeroes oneE = VarE 'lsb mkRules = do let idRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) [] (VarE 'fromIntegral) (SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT)) AllPhases mkRules' [idRule] loT (VarE 'loWord) (VarE 'extendLo) (VarE 'signExtendLo) mkRules' rules t narrowE extE signExtE = do let narrowRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT t) [] (VarE 'fromIntegral) (SigE narrowE (AppT (AppT ArrowT tpT) t)) AllPhases extRule = RuleP ("fromIntegral/" ++ showT t ++ "->" ++ show tp) [] (VarE 'fromIntegral) (SigE extE (AppT (AppT ArrowT t) tpT)) AllPhases signedRules ← do insts ← reifyInstances ''SignedWord [t] case insts of [TySynInstD _ _ signT] → return $ [ RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT signT) [] (VarE 'fromIntegral) (SigE (AppE (appVN '(.) ['signedWord]) narrowE) (AppT (AppT ArrowT tpT) signT)) AllPhases , RuleP ("fromIntegral/" ++ showT signT ++ "->" ++ show tp) [] (VarE 'fromIntegral) (SigE signExtE (AppT (AppT ArrowT signT) tpT)) AllPhases ] _ → return [] let rules' = narrowRule : extRule : signedRules ++ rules case smallerStdTypes t of Just ts → do let smallRules = ts >>= \(uSmallName, sSmallName) → let uSmallT = ConT uSmallName sSmallT = ConT sSmallName in [ RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show uSmallName) [] (VarE 'fromIntegral) (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) (AppT (AppT ArrowT tpT) uSmallT)) AllPhases , RuleP ("fromIntegral/" ++ show uSmallName ++ "->" ++ show tp) [] (VarE 'fromIntegral) (SigE (appV '(.) [extE, VarE 'fromIntegral]) (AppT (AppT ArrowT uSmallT) tpT)) AllPhases , RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show sSmallName) [] (VarE 'fromIntegral) (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) (AppT (AppT ArrowT tpT) sSmallT)) AllPhases , RuleP ("fromIntegral/" ++ show sSmallName ++ "->" ++ show tp) [] (VarE 'fromIntegral) (SigE (appV '(.) [signExtE, VarE 'fromIntegral]) (AppT (AppT ArrowT sSmallT) tpT)) AllPhases ] return $ PragmaD <$> rules' ++ smallRules _ → do insts ← reifyInstances ''LoWord [t] case insts of [TySynInstD _ _ t'] → mkRules' rules' t' (appV '(.) [VarE 'loWord, narrowE]) (appV '(.) [VarE 'extendLo, extE]) (appV '(.) [VarE 'signExtendLo, signExtE]) _ → return $ PragmaD <$> rules' showT (ConT n) = show n showT t = show t stdTypes = [(''Word64, ''Int64), (''Word32, ''Int32), (''Word16, ''Int16), (''Word8, ''Int8)] smallerStdTypes t = smallerStdTypes' t stdTypes smallerStdTypes' _ [] = Nothing smallerStdTypes' t ((ut, _) : ts) | ConT ut == t = Just ts | otherwise = smallerStdTypes' t ts