module Data.ShortWord.TH
( mkShortWord
) where
import GHC.Arr (Ix(..))
import GHC.Enum (succError, predError, toEnumError)
import Data.Data
import Data.Proxy (Proxy(..))
import Data.Ratio ((%))
import Data.Bits (Bits(..))
import Data.Bits (FiniteBits(..))
#if MIN_VERSION_hashable(1,2,0)
import Data.Hashable (Hashable(..), hashWithSalt)
#else
import Data.Hashable (Hashable(..), combine)
#endif
import Data.Char (toLower)
import Data.List (union)
import Control.Applicative ((<$>), (<*>))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Module(..), ModName(..))
import Data.BinaryWord (BinaryWord(..))
mkShortWord ∷ String
→ String
→ String
→ String
→ String
→ String
→ Name
→ Int
→ [Name]
→ Q [Dec]
mkShortWord un uc upn sn sc spn utp bl ad =
(++) <$> mkShortWord' False un' uc' upn' sn' sc' utp bl ad
<*> mkShortWord' True sn' sc' spn' un' uc' utp bl ad
where un' = mkName un
uc' = mkName uc
upn' = mkName upn
sn' = mkName sn
sc' = mkName sc
spn' = mkName spn
mkShortWord' ∷ Bool
→ Name → Name
→ Name
→ Name → Name
→ Name
→ Int
→ [Name]
→ Q [Dec]
mkShortWord' signed tp cn pn otp ocn utp bl ad = returnDecls $
[ NewtypeD [] tp []
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
(NormalC cn [(Bang NoSourceUnpackedness
NoSourceStrictness,
uT)])
# if MIN_VERSION_template_haskell(2,12,0)
[DerivClause Nothing (ConT <$> union [''Typeable] ad)]
# else
(ConT <$> union [''Typeable] ad)
# endif
#else
(NormalC cn [(NotStrict, uT)])
(union [''Typeable] ad)
#endif
, SigD pn (AppT (ConT ''Proxy) tpT)
, fun pn $ ConE 'Proxy
, inst ''Eq [tp] $
[ funUn2 '(==) $ appVN '(==) [x, y]
, inline '(==) ]
, inst ''Ord [tp]
[ funUn2 'compare $ appVN 'compare [x, y]
, inline 'compare ]
, inst ''Bounded [tp]
[ fun 'minBound $ appW $ appV '(.&.) [VarE 'minBound, maskE]
, inline 'minBound
, fun 'maxBound $ appW $ appV '(.&.) [VarE 'maxBound, maskE]
, inline 'maxBound ]
, inst ''Enum [tp]
[ funUnAsX 'succ $
CondE (appVN '(==) [x, 'maxBound])
(appV 'succError [litS (show tp)])
(appW (appV '(+) [VarE y, appV 'shiftL [litI 1, shiftE]]))
, inlinable 'succ
, funUnAsX 'pred $
CondE (appVN '(==) [x, 'minBound])
(appV 'predError [litS (show tp)])
(appW (appV '() [VarE y, appV 'shiftL [litI 1, shiftE]]))
, inlinable 'pred
, funX' 'toEnum
(CondE (appV '(||) [ appV '(<) [ VarE y
, appV 'shiftR
[VarE 'minBound, shiftE]
]
, appV '(>) [ VarE y
, appV 'shiftR
[VarE 'maxBound, shiftE]
]
])
(appV 'toEnumError [ litS (show tp)
, VarE x
, TupE [ SigE (VarE 'minBound) tpT
, SigE (VarE 'maxBound) tpT
]
])
(appW $ appV 'shiftL [VarE y, shiftE]))
[val y $ appVN 'toEnum [x]]
, funUn 'fromEnum $ appV 'fromEnum [appV 'shiftR [VarE x, shiftE]]
, inline 'fromEnum
, funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound]
, inline 'enumFrom
, funXY 'enumFromThen $
appV 'enumFromThenTo
[ VarE x
, VarE y
, CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound)
]
, inlinable 'enumFromThen
, 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]) []]
]
, 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]
[ funUn 'negate $ appW $ appVN 'negate [x]
, inline 'negate
, if signed
then funUnAsX 'abs $
CondE (appVN '(<) [y, 'allZeroes])
(appW $ appVN 'negate [y]) (VarE x)
else funX 'abs $ VarE x
, if signed then inlinable 'abs else inline 'abs
, funUn 'signum $ appW $ appV 'shiftL [appVN 'signum [x], shiftE]
, inline 'signum
, funUn2 '(+) $ appW $ appVN '(+) [x, y]
, inline '(+)
, funUn2 '(*) $
appW $ appV '(*) [appV 'shiftR [VarE x, shiftE], VarE y]
, inline '(*)
, funX 'fromInteger $
appW $ appV 'shiftL [appVN 'fromInteger [x], shiftE]
, inline 'fromInteger
]
, inst ''Real [tp]
[ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1]
, inline 'toRational ]
, inst ''Integral [tp] $
[ funUn 'toInteger $ appV 'toInteger [appV 'shiftR [VarE x, shiftE]]
, inline 'toInteger
, funUn2' 'quotRem
(TupE [appW (appV 'shiftL [VarE q, shiftE]), appWN r])
[vals [q, r] $ appVN 'quotRem [x, y]]
, inline 'quotRem
, funUn2' 'divMod
(TupE [appW (appV 'shiftL [VarE q, shiftE]), appWN r])
[vals [q, r] $ appVN 'divMod [x, y]]
, inline 'divMod
]
, inst ''Show [tp]
[
funUn 'show $ appV 'show [appV 'shiftR [VarE x, shiftE]]
, inline 'show ]
, inst ''Read [tp]
[ funXY 'readsPrec $
appV 'fmap [ LamE [TupP [VarP q, VarP r]]
(TupE [appVN 'fromInteger [q], VarE r])
, appVN 'readsPrec [x, y] ]
]
, inst ''Hashable [tp]
#if MIN_VERSION_hashable(1,2,0)
[ funXUn 'hashWithSalt $ appVN 'hashWithSalt [x, y]
#else
[ funUn 'hash $ appVN 'hash [x]
, inline 'hash
#endif
, inline 'hashWithSalt ]
, inst ''Ix [tp]
[ funTup 'range $ appVN 'enumFromTo [x, y]
, inline 'range
, funTupLZ 'unsafeIndex $
appV '() [appVN 'fromIntegral [z], appVN 'fromIntegral [x]]
, inline 'unsafeIndex
, funTupZ 'inRange $
appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]]
, inline 'inRange ]
, inst ''Bits [tp] $
[ fun_ 'bitSize $ sizeE
, inline 'bitSize
, fun_ 'bitSizeMaybe $ app (ConE 'Just) [sizeE]
, inline 'bitSizeMaybe
, fun_ 'isSigned $ ConE $ if signed then 'True else 'False
, inline 'isSigned
, funUn 'complement $
appW $ appV '(.&.) [appVN 'complement [x], maskE]
, inline 'complement
, funUn2 'xor $ appW $ appVN 'xor [x, y]
, inline 'xor
, funUn2 '(.&.) $ appW $ appVN '(.&.) [x, y]
, inline '(.&.)
, funUn2 '(.|.) $ appW $ appVN '(.|.) [x, y]
, inline '(.|.)
, funUnY 'shiftL $ appW $ appVN 'shiftL [x, y]
, inline 'shiftL
, funUnY 'shiftR $ appW $ appV '(.&.) [appVN 'shiftR [x, y], maskE]
, inline 'shiftR
, funUnY 'rotateL $ appW $ appV '(.|.) $ (appVN 'shiftL [x, y] :) $
return $ appV '(.&.) $
[ if signed
then appV 'signedWord [ appV 'shiftR
[ appVN 'unsignedWord [x]
, appV '() [sizeE, VarE y]
]
]
else appV 'shiftR [VarE x, appV '() [sizeE, VarE y]]
, maskE
]
, inline 'rotateL
, funXY 'rotateR $ appV 'rotateL [VarE x, appV '() [sizeE, VarE y]]
, inline 'rotateR
, funX 'bit $ appW $ appV 'bit [appV '(+) [VarE x, shiftE]]
, inline 'bit
, funUnY 'setBit $
appW $ appV 'setBit [VarE x, appV '(+) [VarE y, shiftE]]
, inline 'setBit
, funUnY 'clearBit $
appW $ appV 'clearBit [VarE x, appV '(+) [VarE y, shiftE]]
, inline 'clearBit
, funUnY 'complementBit $
appW $ appV 'complementBit [VarE x, appV '(+) [VarE y, shiftE]]
, inline 'complementBit
, funUnY 'testBit $ appV 'testBit [VarE x, appV '(+) [VarE y, shiftE]]
, inline 'testBit
, funUn 'popCount $ appVN 'popCount [x]
, inline 'popCount
]
, inst ''FiniteBits [tp]
[ fun_ 'finiteBitSize $ sizeE
, inline 'finiteBitSize
# if MIN_VERSION_base(4,8,0)
, fun 'countLeadingZeros $ VarE 'leadingZeroes
, inline 'countLeadingZeros
, fun 'countTrailingZeros $ VarE 'trailingZeroes
, inline 'countTrailingZeros
# endif
]
, inst ''BinaryWord [tp]
[ tySynInst ''UnsignedWord [tpT] $
ConT $ if signed then otp else tp
, tySynInst ''SignedWord [tpT] $
ConT $ if signed then tp else otp
, if signed
then funUn 'unsignedWord $ appC ocn [appVN 'unsignedWord [x]]
else fun 'unsignedWord $ VarE 'id
, inline 'unsignedWord
, if signed
then fun 'signedWord $ VarE 'id
else funUn 'signedWord $ appC ocn [appVN 'signedWord [x]]
, inline 'signedWord
, funUn2' 'unwrappedAdd
(TupE [ appW (appV 'shiftL [VarE t1, shiftE])
, appC (if signed then ocn else cn)
[appVN 'unsignedWord [t2]]
])
[vals [t1, t2] $ appVN 'unwrappedAdd [x, y]]
, inline 'unwrappedAdd
, funUn2' 'unwrappedMul
(TupE [ appW (appV 'shiftL [VarE t1, shiftE])
, appC (if signed then ocn else cn)
[appVN 'unsignedWord [t2]]
])
[vals [t1, t2] $
appV 'unwrappedMul [appV 'shiftR [VarE x, shiftE], VarE y]]
, inline 'unwrappedMul
, funUn 'leadingZeroes $
appV 'leadingZeroes [appV '(.|.)
[VarE x, appV 'complement [maskE]]]
, inline 'leadingZeroes
, funUn 'trailingZeroes $
appV '() [appVN 'trailingZeroes [x], shiftE]
, inline 'trailingZeroes
, fun 'allZeroes $ appWN 'allZeroes
, inline 'allZeroes
, fun 'allOnes $ appW $ appV '(.&.) [VarE 'allOnes, maskE]
, inline 'allOnes
, fun 'msb $ appWN 'msb
, inline 'msb
, fun 'lsb $ appW $ appV 'shiftL [VarE 'lsb, shiftE]
, inline 'lsb
, funUn 'testMsb $ appVN 'testMsb [x]
, inline 'testMsb
, funUn 'testLsb $ appV 'testBit [VarE x, shiftE]
, inline 'testLsb
, funUn 'setMsb $ appW $ appVN 'setMsb [x]
, inline 'setMsb
, funUn 'setLsb $ appW $ appV 'setBit [VarE x, shiftE]
, inline 'setLsb
, funUn 'clearMsb $ appW $ appVN 'clearMsb [x]
, inline 'clearMsb
, funUn 'clearLsb $ appW $ appV 'clearBit [VarE x, shiftE]
, inline 'clearLsb
]
, rule ("fromIntegral/" ++ show tp ++ "->" ++ show tp)
(VarE 'fromIntegral)
(SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT))
, rule ("fromIntegral/" ++ show tp ++ "->" ++ show otp)
(VarE 'fromIntegral)
(SigE (VarE $ if signed then 'unsignedWord else 'signedWord)
(AppT (AppT ArrowT tpT) (ConT otp)))
, rule ("fromIntegral/" ++ show tp ++ "->a")
(VarE 'fromIntegral)
(LetE [funUn fn $ appV 'fromIntegral
[appV 'shiftR [VarE x, shiftE]]]
(VarE fn))
, rule ("fromIntegral/a->" ++ show tp)
(VarE 'fromIntegral)
(appV '(.) [ appV '(.) [ ConE tp
, appV 'flip [VarE 'shiftL, shiftE] ]
, VarE 'fromIntegral ])
]
where
x = mkName "x"
y = mkName "y"
z = mkName "z"
q = mkName "q"
r = mkName "r"
t1 = mkName "t1"
t2 = mkName "t2"
c = mkName "c"
next = mkName "next_"
step = mkName "step_"
to = mkName "to_"
down = mkName "down_"
up = mkName "up_"
fn = mkName "fn_"
uT | signed = AppT (ConT ''SignedWord) (ConT utp)
| otherwise = AppT (ConT ''UnsignedWord) (ConT utp)
tpT = ConT tp
tySynInst n ps t =
#if MIN_VERSION_template_haskell(2,9,0)
TySynInstD n (TySynEqn ps t)
#else
TySynInstD n ps t
#endif
inst cls params = InstanceD
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
#endif
[] (foldl AppT (ConT cls) (ConT <$> params))
fun n e = FunD n [Clause [] (NormalB e) []]
fun_ n e = FunD n [Clause [WildP] (NormalB e) []]
funUn' n e ds =
FunD n [Clause [ConP cn [VarP x]] (NormalB e) ds]
funUn n e = funUn' n e []
funUnAsX' n e ds = FunD n [Clause [AsP x (ConP cn [VarP y])]
(NormalB e) ds]
funUnAsX n e = funUnAsX' n e []
funUn2' n e ds =
FunD n [Clause [ConP cn [VarP x], ConP cn [VarP y]] (NormalB e) ds]
funUn2 n e = funUn2' n e []
funXUn' n e ds =
FunD n [Clause [VarP x, ConP cn [VarP y]] (NormalB e) ds]
funXUn n e = funXUn' n e []
funUnY' n e ds =
FunD n [Clause [ConP cn [VarP x], VarP y] (NormalB e) ds]
funUnY n e = funUnY' n 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) []]
fun_ZC n e = FunD n [Clause [WildP, VarP z, VarP c] (NormalB e) []]
inline n = PragmaD $ InlineP n Inline FunLike AllPhases
inlinable n = PragmaD $ InlineP n Inlinable FunLike AllPhases
rule n m e = PragmaD $ RuleP n [] m e 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 e = appC cn [e]
appVN f = appN (VarE f)
appCN f = appN (ConE f)
appWN e = appCN cn [e]
litI = LitE . IntegerL
litS = LitE . StringL
sizeE = litI $ toInteger bl
shiftE = appV '()
[ appV 'finiteBitSize [SigE (VarE 'undefined) uT]
, sizeE ]
maskE = appV 'shiftL [VarE 'allOnes, shiftE]
returnDecls ds = do
Module _ (ModName modName) ← thisModule
let typeVar = mkName $ uncapitalize (show tp) ++ "Type"
where uncapitalize (h : t) = toLower h : t
uncapitalize [] = []
fullName = modName ++ "." ++ show tp
return $ (ds ++) $
[ SigD typeVar (ConT ''DataType)
, fun typeVar $ appV 'mkIntType [litS fullName]
, inst ''Data [tp] $
[ fun 'toConstr $ appVN 'mkIntegralConstr [typeVar]
, fun_ZC 'gunfold $ CaseE (appVN 'constrRep [c]) $
[ Match (ConP 'IntConstr [VarP x])
(NormalB $ appV z [appVN 'fromIntegral [x]])
[]
, Match WildP
(NormalB $
appV 'error
[appV '(++)
[ litS "Data.Data.gunfold: Constructor"
, appV '(++)
[ appVN 'show [c]
, appV '(++)
[ litS " is not of type "
, litS fullName ]
]
]
])
[]
]
, fun_ 'dataTypeOf $ VarE typeVar
]
]