git.iko.soy/Idris-dev
on aeb032a help sign in
Idris-dev/src/Idris/Primitives.hs
484 lines 22 kB history raw
1{-|
2Module : Idris.Primitives
3Description : Provision of primitive data types.
4Copyright :
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__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
152 (1, LFSqrt) total,
153 Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
154 (1, LFFloor) total,
155 Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
156 (1, LFCeil) total,
157 Prim (sUN "prim__negFloat") (ty [(AType ATFloat)] (AType ATFloat)) 1 (c_negFloat)
158 (1, LFNegate) total,
160 Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
161 (1, LStrHead) partial,
162 Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
163 (1, LStrTail) partial,
164 Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
165 (2, LStrCons) total,
166 Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
167 (2, LStrIndex) partial,
168 Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
169 (1, LStrRev) total,
170 Prim (sUN "prim__strSubstr") (ty [AType (ATInt ITNative), AType (ATInt ITNative), StrType] StrType) 3 (p_strSubstr)
171 (3, LStrSubstr) total,
173 Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce)
174 (1, LReadStr) total, -- total is okay, because we have 'WorldType'
175 Prim (sUN "prim__writeString") (ty [WorldType,StrType] (AType (ATInt ITNative))) 2 (p_cantreduce)
176 (2, LWriteStr) total,
177 Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)
178 (1, LSystemInfo) total
179 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
181intOps :: IntTy -> [Prim]
182intOps ity = intCmps ity ++ intArith ity ++ intConv ity
184intSCmps :: IntTy -> [Prim]
185intSCmps ity =
186 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
187 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
188 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
189 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
190 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
191 ]
193intCmps :: IntTy -> [Prim]
194intCmps ITNative = intSCmps ITNative
195intCmps ity =
196 intSCmps ity ++
197 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
198 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
199 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
200 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
201 ]
203intArith :: IntTy -> [Prim]
204intArith ity =
205 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
206 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
207 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
208 , iBinOp ity "udiv" (bitBin ity quot) LUDiv partial
209 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
210 , iBinOp ity "urem" (bitBin ity rem) LURem partial
211 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
212 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
213 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
214 , iBinOp ity "ashr" (bashr ity) LASHR total
215 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
216 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
217 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
218 , iUnOp ity "compl" (bUn ity complement) LCompl total
219 ]
221intConv :: IntTy -> [Prim]
222intConv ity =
223 [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
224 (1, LIntStr ity) total
225 , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
226 (1, LStrInt ity) total
227 , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
228 (1, LIntFloat ity) total
229 , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
230 (1, LFloatInt ity) total
231 ]
233iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
234iCmp ity op self impl irop totality
235 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
236 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
237 2 impl (2, irop ity) totality
239iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
240iBinOp ity op impl irop totality
241 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
242 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
243 2 impl (2, irop ity) totality
244iUnOp ity op impl irop totality
245 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
246 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
247 1 impl (1, irop ity) totality
249iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
250iCoerce from to op impl irop =
251 Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
252 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
254fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
255fBin op [Fl x, Fl y] = Just $ Fl (op x y)
256fBin _ _ = Nothing
258bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
259bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
260 Just $ I i
261bfBin _ _ = Nothing
263bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
264bsBin op [Str x, Str y]
265 = let i = (if op x y then 1 else 0) in
266 Just $ I i
267bsBin _ _ = Nothing
269sBin :: (String -> String -> String) -> [Const] -> Maybe Const
270sBin op [Str x, Str y] = Just $ Str (op x y)
271sBin _ _ = Nothing
273bsrem :: IntTy -> [Const] -> Maybe Const
274bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
275bsrem (ITFixed IT8) [B8 x, B8 y]
276 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
277bsrem (ITFixed IT16) [B16 x, B16 y]
278 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
279bsrem (ITFixed IT32) [B32 x, B32 y]
280 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
281bsrem (ITFixed IT64) [B64 x, B64 y]
282 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
283bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
284bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
285bsrem _ _ = Nothing
287bsdiv :: IntTy -> [Const] -> Maybe Const
288bsdiv ITBig [BI x, BI y] = Just . BI $ x `quot` y
289bsdiv (ITFixed IT8) [B8 x, B8 y]
290 = Just $ B8 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int8))
291bsdiv (ITFixed IT16) [B16 x, B16 y]
292 = Just $ B16 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int16))
293bsdiv (ITFixed IT32) [B32 x, B32 y]
294 = Just $ B32 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int32))
295bsdiv (ITFixed IT64) [B64 x, B64 y]
296 = Just $ B64 (fromIntegral (fromIntegral x `quot` fromIntegral y :: Int64))
297bsdiv ITNative [I x, I y] = Just $ I (x `quot` y)
298bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `quot` (ord y))
299bsdiv _ _ = Nothing
301bashr :: IntTy -> [Const] -> Maybe Const
302bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
303bashr (ITFixed IT8) [B8 x, B8 y]
304 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
305bashr (ITFixed IT16) [B16 x, B16 y]
306 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
307bashr (ITFixed IT32) [B32 x, B32 y]
308 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
309bashr (ITFixed IT64) [B64 x, B64 y]
310 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
311bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
312bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
313bashr _ _ = Nothing
315bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
316bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
317bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
318bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
319bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
320bUn ITBig op [BI x] = Just $ BI (op x)
321bUn ITNative op [I x] = Just $ I (op x)
322bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
323bUn _ _ _ = Nothing
325bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
326bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
327bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
328bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
329bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
330bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
331bitBin ITNative op [I x, I y] = Just $ I (op x y)
332bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
333bitBin _ _ _ = Nothing
335bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
336bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
337bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
338bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
339bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
340bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
341bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
342bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
343bCmp _ _ _ = Nothing
346cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
347cmpOp (ITFixed _) f = f
348cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
349cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
350cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
352sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
353sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
354sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
355sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
356sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
357sCmpOp _ f = f
359toInt :: Integral a => IntTy -> a -> Const
360toInt (ITFixed IT8) x = B8 (fromIntegral x)
361toInt (ITFixed IT16) x = B16 (fromIntegral x)
362toInt (ITFixed IT32) x = B32 (fromIntegral x)
363toInt (ITFixed IT64) x = B64 (fromIntegral x)
364toInt ITBig x = BI (fromIntegral x)
365toInt ITNative x = I (fromIntegral x)
366toInt ITChar x = Ch (chr $ fromIntegral x)
368intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
369intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
370intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
371intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
372intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
373intToInt ITBig out [BI x] = Just $ toInt out x
374intToInt ITNative out [I x] = Just $ toInt out x
375intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
376intToInt _ _ _ = Nothing
378zext :: IntTy -> IntTy -> [Const] -> Maybe Const
379zext from ITBig val = intToInt from ITBig val
380zext ITBig _ _ = Nothing
381zext f@(ITFixed from) t@(ITFixed to) val
382 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
383zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
384zext from ITNative val = intToInt from ITNative val
385zext _ _ _ = Nothing
387sext :: IntTy -> IntTy -> [Const] -> Maybe Const
388sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
389sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
390sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
391sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
392sext ITBig _ _ = Nothing
393sext from to val = intToInt from to val
395trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
396trunc ITBig to val = intToInt ITBig to val
397trunc _ ITBig _ = Nothing
398trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
399trunc ITNative to [I x] = Just $ toInt to x
400trunc from ITNative val = intToInt from ITNative val
401trunc _ _ _ = Nothing
403intToStr :: [Const] -> Maybe Const
404intToStr val | [i] <- getInt val = Just $ Str (show i)
405intToStr _ = Nothing
407getInt :: [Const] -> [Integer]
408getInt (B8 x : xs) = toInteger x : getInt xs
409getInt (B16 x : xs) = toInteger x : getInt xs
410getInt (B32 x : xs) = toInteger x : getInt xs
411getInt (B64 x : xs) = toInteger x : getInt xs
412getInt (I x : xs) = toInteger x : getInt xs
413getInt (BI x : xs) = x : getInt xs
414getInt _ = []
416strToInt :: IntTy -> [Const] -> Maybe Const
417strToInt ity [Str x] = case reads x of
418 [(n,s)] -> Just $ if all isSpace s then toInt ity (n :: Integer) else I 0
419 _ -> Just $ I 0
420strToInt _ _ = Nothing
422intToFloat :: [Const] -> Maybe Const
423intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
424intToFloat _ = Nothing
426floatToInt :: IntTy -> [Const] -> Maybe Const
427floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
428floatToInt _ _ = Nothing
430c_intToChar, c_charToInt :: [Const] -> Maybe Const
431c_intToChar [(I x)] = Just . Ch . toEnum $ x
432c_intToChar _ = Nothing
433c_charToInt [(Ch x)] = Just . I . fromEnum $ x
434c_charToInt _ = Nothing
436c_negFloat :: [Const] -> Maybe Const
437c_negFloat [Fl x] = Just $ Fl (negate x)
438c_negFloat _ = Nothing
440c_floatToStr :: [Const] -> Maybe Const
441c_floatToStr [Fl x] = Just $ Str (show x)
442c_floatToStr _ = Nothing
443c_strToFloat [Str x] = case reads x of
444 [(n,s)] -> Just $ Fl (if all isSpace s then n else 0)
445 _ -> Just $ Fl 0
446c_strToFloat _ = Nothing
448p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
449p_fPrim f [Fl x] = Just $ Fl (f x)
450p_fPrim f _ = Nothing
452p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
453p_floatExp = p_fPrim exp
454p_floatLog = p_fPrim log
455p_floatSin = p_fPrim sin
456p_floatCos = p_fPrim cos
457p_floatTan = p_fPrim tan
458p_floatASin = p_fPrim asin
459p_floatACos = p_fPrim acos
460p_floatATan = p_fPrim atan
461p_floatSqrt = p_fPrim sqrt
462p_floatFloor = p_fPrim (fromInteger . floor)
463p_floatCeil = p_fPrim (fromInteger . ceiling)
465p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev, p_strSubstr :: [Const] -> Maybe Const
466p_strLen [Str xs] = Just $ I (length xs)
467p_strLen _ = Nothing
468p_strHead [Str (x:xs)] = Just $ Ch x
469p_strHead _ = Nothing
470p_strTail [Str (x:xs)] = Just $ Str xs
471p_strTail _ = Nothing
472p_strIndex [Str xs, I i]
473 | i < length xs = Just $ Ch (xs!!i)
474p_strIndex _ = Nothing
475p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
476p_strCons _ = Nothing
477p_strRev [Str xs] = Just $ Str (reverse xs)
478p_strRev _ = Nothing
479p_strSubstr [I offset, I length, Str input] = Just $ Str (take length (drop offset input))
480p_strSubstr _ = Nothing
483p_cantreduce :: a -> Maybe b
484p_cantreduce _ = Nothing