git.iko.soy/Idris-dev
on bc8da8d help sign in
Idris-dev/src/Idris/Primitives.hs
490 lines 22 kB history raw
1{-|
2Module : Idris.Primitives
3Description : Provision of primitive data types.
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE PatternGuards, RankNTypes, ScopedTypeVariables #-}
10module Idris.Primitives(primitives, Prim(..)) where
12import Idris.Core.Evaluate
13import Idris.Core.TT
14import IRTS.Lang
16import Data.Bits
17import Data.Char
18import Data.Function (on)
19import Data.Int
21data Prim = Prim { p_name :: Name,
22 p_type :: Type,
23 p_arity :: Int,
24 p_def :: [Const] -> Maybe Const,
25 p_lexp :: (Int, PrimFn),
26 p_total :: Totality
27 }
29ty :: [Const] -> Const -> Type
30ty [] x = Constant x
31ty (t:ts) x = Bind (sMN 0 "T") (Pi RigW Nothing (Constant t) (TType (UVar [] (-3)))) (ty ts x)
33total, partial :: Totality
34total = Total []
35partial = Partial NotCovering
37primitives :: [Prim]
38primitives =
39 -- operators
40 [iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt,
41 iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt,
42 iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt,
43 iCoerce (ITFixed IT8) ITBig "zext" zext LZExt,
44 iCoerce (ITFixed IT8) ITNative "zext" zext LZExt,
45 iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt,
46 iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt,
47 iCoerce (ITFixed IT16) ITBig "zext" zext LZExt,
48 iCoerce (ITFixed IT16) ITNative "zext" zext LZExt,
49 iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt,
50 iCoerce (ITFixed IT32) ITBig "zext" zext LZExt,
51 iCoerce (ITFixed IT32) ITNative "zext" zext LZExt,
52 iCoerce (ITFixed IT64) ITBig "zext" zext LZExt,
53 iCoerce ITNative ITBig "zext" zext LZExt,
54 iCoerce ITNative (ITFixed IT64) "zext" zext LZExt,
55 iCoerce ITNative (ITFixed IT32) "zext" zext LZExt,
56 iCoerce ITNative (ITFixed IT16) "zext" zext LZExt,
57 iCoerce ITChar ITBig "zext" zext LZExt,
59 iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt,
60 iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt,
61 iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt,
62 iCoerce (ITFixed IT8) ITBig "sext" sext LSExt,
63 iCoerce (ITFixed IT8) ITNative "sext" sext LSExt,
64 iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt,
65 iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt,
66 iCoerce (ITFixed IT16) ITBig "sext" sext LSExt,
67 iCoerce (ITFixed IT16) ITNative "sext" sext LSExt,
68 iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt,
69 iCoerce (ITFixed IT32) ITBig "sext" sext LSExt,
70 iCoerce (ITFixed IT32) ITNative "sext" sext LSExt,
71 iCoerce (ITFixed IT64) ITBig "sext" sext LSExt,
72 iCoerce ITNative ITBig "sext" sext LSExt,
73 iCoerce ITNative ITBig "sext" sext LSExt,
74 iCoerce ITNative (ITFixed IT64) "sext" sext LSExt,
75 iCoerce ITNative (ITFixed IT32) "sext" sext LSExt,
76 iCoerce ITNative (ITFixed IT16) "sext" sext LSExt,
77 iCoerce ITChar ITBig "sext" sext LSExt,
79 iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc,
80 iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc,
81 iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc,
82 iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc,
83 iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc,
84 iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc,
85 iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc,
86 iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc,
87 iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc,
88 iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc,
89 iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc,
90 iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc,
91 iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc,
92 iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc,
93 iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc,
94 iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc,
95 iCoerce ITBig ITNative "trunc" trunc LTrunc,
96 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,
97 iCoerce ITBig ITChar "trunc" trunc LTrunc,
99 Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))
100 (2, LPlus ATFloat) total,
101 Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))
102 (2, LMinus ATFloat) total,
103 Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))
104 (2, LTimes ATFloat) total,
105 Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))
106 (2, LSDiv ATFloat) total,
107 Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))
108 (2, LEq ATFloat) total,
109 Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))
110 (2, LSLt ATFloat) total,
111 Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))
112 (2, LSLe ATFloat) total,
113 Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))
114 (2, LSGt ATFloat) total,
115 Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))
116 (2, LSGe ATFloat) total,
117 Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))
118 (2, LStrConcat) total,
119 Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))
120 (2, LStrEq) total,
121 Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
122 (2, LStrLt) total,
123 Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
124 (1, LStrLen) total,
125 -- Conversions
126 Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)
127 (1, LChInt ITNative) total,
128 Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)
129 (1, LIntCh ITNative) partial,
130 Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)
131 (1, LStrFloat) total,
132 Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)
133 (1, LFloatStr) total,
135 Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)
136 (1, LFExp) total,
137 Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
138 (1, LFLog) total,
139 Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
140 (1, LFSin) total,
141 Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
142 (1, LFCos) total,
143 Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
144 (1, LFTan) total,
145 Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
146 (1, LFASin) total,
147 Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
148 (1, LFACos) total,
149 Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
150 (1, LFATan) total,
151 Prim (sUN "prim__floatATan2") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (p_floatATan2)
152 (2, LFATan2) total,
153 Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
154 (1, LFSqrt) total,
155 Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
156 (1, LFFloor) total,
157 Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
158 (1, LFCeil) total,
159 Prim (sUN "prim__negFloat") (ty [(AType ATFloat)] (AType ATFloat)) 1 (c_negFloat)
160 (1, LFNegate) total,
162 Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
163 (1, LStrHead) partial,
164 Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
165 (1, LStrTail) partial,
166 Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
167 (2, LStrCons) total,
168 Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
169 (2, LStrIndex) partial,
170 Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
171 (1, LStrRev) total,
172 Prim (sUN "prim__strSubstr") (ty [AType (ATInt ITNative), AType (ATInt ITNative), StrType] StrType) 3 (p_strSubstr)
173 (3, LStrSubstr) total,
175 Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce)
176 (1, LReadStr) total, -- total is okay, because we have 'WorldType'
177 Prim (sUN "prim__writeString") (ty [WorldType,StrType] (AType (ATInt ITNative))) 2 (p_cantreduce)
178 (2, LWriteStr) total,
179 Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)
180 (1, LSystemInfo) total
181 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
183intOps :: IntTy -> [Prim]
184intOps ity = intCmps ity ++ intArith ity ++ intConv ity
186intSCmps :: IntTy -> [Prim]
187intSCmps ity =
188 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
189 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
190 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
191 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
192 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
193 ]
195intCmps :: IntTy -> [Prim]
196intCmps ITNative = intSCmps ITNative
197intCmps ity =
198 intSCmps ity ++
199 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
200 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
201 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
202 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
203 ]
205intArith :: IntTy -> [Prim]
206intArith ity =
207 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
208 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
209 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
210 , iBinOp ity "udiv" (bitBin ity quot) LUDiv partial
211 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
212 , iBinOp ity "urem" (bitBin ity rem) LURem partial
213 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
214 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
215 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
216 , iBinOp ity "ashr" (bashr ity) LASHR total
217 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
218 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
219 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
220 , iUnOp ity "compl" (bUn ity complement) LCompl total
221 ]
223intConv :: IntTy -> [Prim]
224intConv ity =
225 [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
226 (1, LIntStr ity) total
227 , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
228 (1, LStrInt ity) total
229 , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
230 (1, LIntFloat ity) total
231 , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
232 (1, LFloatInt ity) total
233 ]
235iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
236iCmp ity op self impl irop totality
237 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
238 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
239 2 impl (2, irop ity) totality
241iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
242iBinOp ity op impl irop totality
243 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
244 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
245 2 impl (2, irop ity) totality
246iUnOp ity op impl irop totality
247 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
248 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
249 1 impl (1, irop ity) totality
251iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
252iCoerce from to op impl irop =
253 Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
254 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
256fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
257fBin op [Fl x, Fl y] = Just $ Fl (op x y)
258fBin _ _ = Nothing
260bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
261bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
262 Just $ I i
263bfBin _ _ = Nothing
265bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
266bsBin op [Str x, Str y]
267 = let i = (if op x y then 1 else 0) in
268 Just $ I i
269bsBin _ _ = Nothing
271sBin :: (String -> String -> String) -> [Const] -> Maybe Const
272sBin op [Str x, Str y] = Just $ Str (op x y)
273sBin _ _ = Nothing
275bsrem :: IntTy -> [Const] -> Maybe Const
276bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
277bsrem (ITFixed IT8) [B8 x, B8 y]
278 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
279bsrem (ITFixed IT16) [B16 x, B16 y]
280 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
281bsrem (ITFixed IT32) [B32 x, B32 y]
282 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
283bsrem (ITFixed IT64) [B64 x, B64 y]
284 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
285bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
286bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
287bsrem _ _ = Nothing
289bsdiv :: IntTy -> [Const] -> Maybe Const
290bsdiv ITBig [BI x, BI y] = Just . BI $ x `quot` y
291bsdiv (ITFixed IT8) [B8 x, B8 y]
292 = Just $ B8 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int8))
293bsdiv (ITFixed IT16) [B16 x, B16 y]
294 = Just $ B16 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int16))
295bsdiv (ITFixed IT32) [B32 x, B32 y]
296 = Just $ B32 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int32))
297bsdiv (ITFixed IT64) [B64 x, B64 y]
298 = Just $ B64 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int64))
299bsdiv ITNative [I x, I y] = Just $ I (x `quot` y)
300bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `quot` (ord y))
301bsdiv _ _ = Nothing
303bashr :: IntTy -> [Const] -> Maybe Const
304bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
305bashr (ITFixed IT8) [B8 x, B8 y]
306 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
307bashr (ITFixed IT16) [B16 x, B16 y]
308 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
309bashr (ITFixed IT32) [B32 x, B32 y]
310 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
311bashr (ITFixed IT64) [B64 x, B64 y]
312 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
313bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
314bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
315bashr _ _ = Nothing
317bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
318bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
319bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
320bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
321bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
322bUn ITBig op [BI x] = Just $ BI (op x)
323bUn ITNative op [I x] = Just $ I (op x)
324bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
325bUn _ _ _ = Nothing
327bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
328bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
329bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
330bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
331bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
332bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
333bitBin ITNative op [I x, I y] = Just $ I (op x y)
334bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
335bitBin _ _ _ = Nothing
337bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
338bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
339bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
340bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
341bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
342bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
343bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
344bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
345bCmp _ _ _ = Nothing
348cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
349cmpOp (ITFixed _) f = f
350cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
351cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
352cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
354sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
355sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
356sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
357sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
358sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
359sCmpOp _ f = f
361toInt :: Integral a => IntTy -> a -> Const
362toInt (ITFixed IT8) x = B8 (fromIntegral x)
363toInt (ITFixed IT16) x = B16 (fromIntegral x)
364toInt (ITFixed IT32) x = B32 (fromIntegral x)
365toInt (ITFixed IT64) x = B64 (fromIntegral x)
366toInt ITBig x = BI (fromIntegral x)
367toInt ITNative x = I (fromIntegral x)
368toInt ITChar x = Ch (chr $ fromIntegral x)
370intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
371intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
372intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
373intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
374intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
375intToInt ITBig out [BI x] = Just $ toInt out x
376intToInt ITNative out [I x] = Just $ toInt out x
377intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
378intToInt _ _ _ = Nothing
380zext :: IntTy -> IntTy -> [Const] -> Maybe Const
381zext from ITBig val = intToInt from ITBig val
382zext ITBig _ _ = Nothing
383zext f@(ITFixed from) t@(ITFixed to) val
384 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
385zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
386zext from ITNative val = intToInt from ITNative val
387zext _ _ _ = Nothing
389sext :: IntTy -> IntTy -> [Const] -> Maybe Const
390sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
391sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
392sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
393sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
394sext ITBig _ _ = Nothing
395sext from to val = intToInt from to val
397trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
398trunc ITBig to val = intToInt ITBig to val
399trunc _ ITBig _ = Nothing
400trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
401trunc ITNative to [I x] = Just $ toInt to x
402trunc from ITNative val = intToInt from ITNative val
403trunc _ _ _ = Nothing
405intToStr :: [Const] -> Maybe Const
406intToStr val | [i] <- getInt val = Just $ Str (show i)
407intToStr _ = Nothing
409getInt :: [Const] -> [Integer]
410getInt (B8 x : xs) = toInteger x : getInt xs
411getInt (B16 x : xs) = toInteger x : getInt xs
412getInt (B32 x : xs) = toInteger x : getInt xs
413getInt (B64 x : xs) = toInteger x : getInt xs
414getInt (I x : xs) = toInteger x : getInt xs
415getInt (BI x : xs) = x : getInt xs
416getInt _ = []
418strToInt :: IntTy -> [Const] -> Maybe Const
419strToInt ity [Str x] = case reads x of
420 [(n,s)] -> Just $ if all isSpace s then toInt ity (n :: Integer) else I 0
421 _ -> Just $ I 0
422strToInt _ _ = Nothing
424intToFloat :: [Const] -> Maybe Const
425intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
426intToFloat _ = Nothing
428floatToInt :: IntTy -> [Const] -> Maybe Const
429floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
430floatToInt _ _ = Nothing
432c_intToChar, c_charToInt :: [Const] -> Maybe Const
433c_intToChar [(I x)] = Just . Ch . toEnum $ x
434c_intToChar _ = Nothing
435c_charToInt [(Ch x)] = Just . I . fromEnum $ x
436c_charToInt _ = Nothing
438c_negFloat :: [Const] -> Maybe Const
439c_negFloat [Fl x] = Just $ Fl (negate x)
440c_negFloat _ = Nothing
442c_floatToStr :: [Const] -> Maybe Const
443c_floatToStr [Fl x] = Just $ Str (show x)
444c_floatToStr _ = Nothing
445c_strToFloat [Str x] = case reads x of
446 [(n,s)] -> Just $ Fl (if all isSpace s then n else 0)
447 _ -> Just $ Fl 0
448c_strToFloat _ = Nothing
450p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
451p_fPrim f [Fl x] = Just $ Fl (f x)
452p_fPrim f _ = Nothing
454p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
455p_floatExp = p_fPrim exp
456p_floatLog = p_fPrim log
457p_floatSin = p_fPrim sin
458p_floatCos = p_fPrim cos
459p_floatTan = p_fPrim tan
460p_floatASin = p_fPrim asin
461p_floatACos = p_fPrim acos
462p_floatATan = p_fPrim atan
463p_floatSqrt = p_fPrim sqrt
464p_floatFloor = p_fPrim (fromInteger . floor)
465p_floatCeil = p_fPrim (fromInteger . ceiling)
467p_floatATan2 :: [Const] -> Maybe Const
468p_floatATan2 [Fl y, Fl x] = Just $ Fl (atan2 y x)
469p_floatATan2 _ = Nothing
471p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev, p_strSubstr :: [Const] -> Maybe Const
472p_strLen [Str xs] = Just $ I (length xs)
473p_strLen _ = Nothing
474p_strHead [Str (x:xs)] = Just $ Ch x
475p_strHead _ = Nothing
476p_strTail [Str (x:xs)] = Just $ Str xs
477p_strTail _ = Nothing
478p_strIndex [Str xs, I i]
479 | i < length xs = Just $ Ch (xs!!i)
480p_strIndex _ = Nothing
481p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
482p_strCons _ = Nothing
483p_strRev [Str xs] = Just $ Str (reverse xs)
484p_strRev _ = Nothing
485p_strSubstr [I offset, I length, Str input] = Just $ Str (take length (drop offset input))
486p_strSubstr _ = Nothing
489p_cantreduce :: a -> Maybe b
490p_cantreduce _ = Nothing