ExternalInstancesPrelude.hs 25.3 KB
Newer Older
1
2
3
4
5
{-# LANGUAGE RankNTypes, 
             ScopedTypeVariables, 
             MultiParamTypeClasses, 
             FlexibleInstances #-}

bbr's avatar
bbr committed
6
7
8
9
10
11
12
13
14
15
16
17
module ExternalInstancesPrelude (
  module AutoGenerated2, 
  module ExternalInstancesPrelude) where

import Curry
import DataPrelude
import Char
import List
import System.IO.Unsafe
import Data.IORef
import AutoGenerated2

bbr's avatar
bbr committed
18
trace s x = unsafePerformIO (putStrLn s >> return x) 
bbr's avatar
bbr committed
19
20
21
22
23
24
25
26
-----------------------------------------------------------------
-- type classes to extend BaseCurry to full Curry
-----------------------------------------------------------------

type StrEqResult = C_Bool

class (BaseCurry a,Show a,Read a) => Curry a where
  -- basic equalities 
bbr's avatar
bbr committed
27
28
  strEq :: a -> a -> Result StrEqResult
  eq    :: a -> a -> Result C_Bool
bbr's avatar
bbr committed
29
30

  -- some generics
31
  propagate :: (forall b. Curry b => Int -> b -> Result b) -> a -> Result a
bbr's avatar
bbr committed
32
  foldCurry :: (forall c. Curry c => c -> b -> Result b) -> b -> a -> Result b
bbr's avatar
bbr committed
33
34
35
36

  -- name of the type
  typeName :: a -> String

bbr's avatar
bbr committed
37
38
39
40
  -- show qualified terms
  showQ :: Int -> a -> String -> String 
  showQ = showsPrec

bbr's avatar
bbr committed
41
42
43
  showQList :: [a] -> String -> String
  showQList = showQStandardList

bbr's avatar
bbr committed
44
45
46
47
48
  -- generic programming
  --toC_Term   :: HNFMode -> State  -> a -> C_Data
  --fromC_Term :: C_Data -> a

class Generate a where
bbr's avatar
bbr committed
49
50
  genFree    :: Int -> [a]
  maxArity   :: a -> Int
bbr's avatar
bbr committed
51
52
53
54
55
56
57
58
59
60

-----------------------------------------------------------------
-- external Show instances
-----------------------------------------------------------------


instance (Show t0) => Show (IOVal t0) where
  showsPrec d (IOVal x1) = showParen (d>10) showStr
   where
    showStr  = showString "IOVal" . showsPrec 11 x1
61
  showsPrec _ (IOValOr i _) = showString ('_':show (deref i))
bbr's avatar
bbr committed
62
63
64
65
66
67
68
69
70

instance Show (IO (IOVal a)) where
  show _  = "IO"

instance Show (C_IO a) where
  show _  = "IO"

instance Show C_Success where
  showsPrec _ C_Success = showString "success"
71
  showsPrec _ (C_SuccessOr ref _) = showString ('_':show (deref ref))
bbr's avatar
bbr committed
72
73
74
75
76
77

instance Show (a->b) where
  show _ = "FUNCTION"

instance Show a => Show (Prim a) where
  show (PrimValue x) = show x
78
  show (PrimOr r _) = "_"++show (deref r)
bbr's avatar
bbr committed
79
80

instance Show a => Show (List a) where
bbr's avatar
bbr committed
81
82
83
    showsPrec = showsPrecList (showsPrec 0) (showsPrec 0)

showsPrecList :: (a -> ShowS) -> ([a] -> ShowS) -> Int -> List a -> ShowS
bbr's avatar
bbr committed
84
85
showsPrecList recursiveCall listCall _ (ListOr r _) = 
  showString ('_':show (deref r))
bbr's avatar
bbr committed
86
87
88
showsPrecList recursiveCall listCall _ xs 
  | isFreeList xs = showChar '(' . showFreel xs
  | otherwise     = listCall (toHaskellList xs)
bbr's avatar
bbr committed
89
90
      where
        isFreeList List = False
91
        isFreeList (ListOr _ _) = True
bbr's avatar
bbr committed
92
93
94
        isFreeList (_ :< xs) = isFreeList xs
        isFreeList _ = True

bbr's avatar
bbr committed
95
        showFreel (x:<xs)         = recursiveCall x . showChar ':' . showFreel xs
bbr's avatar
bbr committed
96
	showFreel (ListOr r _)    = showString ('_':show (deref r)++")")
bbr's avatar
bbr committed
97
98
99
100
101

showQStandardList :: Curry a => [a] -> ShowS
showQStandardList xs = showChar '[' . 
                       foldr (.) (showChar ']') 
                             (intersperse (showChar ',') (map (showQ 0) xs))
bbr's avatar
bbr committed
102

bbr's avatar
bbr committed
103
104
105
106
107
108
fourToInt :: C_Four -> Either String Int
fourToInt  C_F0 = Right 0
fourToInt  C_F1 = Right 1
fourToInt  C_F2 = Right 2
fourToInt  C_F3 = Right 3
fourToInt  x@(C_FourOr _ _) = Left (show x)
bbr's avatar
bbr committed
109
110
111
112
113
114
115

intToFour :: Int -> C_Four
intToFour  0 = C_F0
intToFour  1 = C_F1
intToFour  2 = C_F2
intToFour  3 = C_F3

bbr's avatar
bbr committed
116
117
118
119
120
121
122
123
124
125
126
127
scToChar ::  C_Four ->  C_Four ->  C_Four ->  C_Four -> Either String Char
scToChar f1 f2 f3 f4 
  = chr' ((fourToInt f1**64)+++(fourToInt f2**16)+++(fourToInt f3**4)+++fourToInt f4)
  where 
    Left s  ** _  = Left s
    Right i ** j  = Right (i*j)
    
    Left s  +++ _  = Left s
    Right i +++ Left s  = Left s
    Right i +++ Right j = Right (i+j)
    chr' (Right i) = Right (chr i)
    chr' (Left s)  = Left s
bbr's avatar
bbr committed
128
129
130
131
132
133
134
135
136
137

charToSc ::  Char -> C_Char
charToSc c = SearchChar (intToFour d64) (intToFour d16) (intToFour d4) (intToFour m4)
  where
    o = ord c
    (d64,m64) = divMod o 64
    (d16,m16) = divMod m64 16
    (d4,m4)   = divMod m16 4
    
instance Show C_Four where
bbr's avatar
bbr committed
138
139
140
  showsPrec d (C_FourOr r _) = showChar '_' . showsPrec d (deref r)
  showsPrec _ _ = error "probably due to usage of ($#) instead of ($##) \
                        \for an external function with argument type string or character"
bbr's avatar
bbr committed
141
142
143

instance Show C_Char where
  show (C_Char c) = show c
bbr's avatar
bbr committed
144
145
  show (SearchChar f1 f2 f3 f4) 
    = either id show (scToChar f1 f2 f3 f4)
bbr's avatar
bbr committed
146
  show (C_CharOr r _) = '_':show (deref r)
bbr's avatar
bbr committed
147
148
149

  showList cs = if any isFreeChar cs
                  then showChar '[' . showFreel cs
bbr's avatar
bbr committed
150
                  else showChar '"' . showl cs   -- "
bbr's avatar
bbr committed
151
152
153
    where 
      showl []       = showChar '"'
      showl (C_Char '"':cs) = showString "\\\"" . showl cs
154
155
156
157
158
159
160
161
162
      showl (C_Char c:cs)
       | oc <= 7   = showString "\\00" . shows oc . showl cs
       | oc <= 10  = showLitChar c . showl cs
       | oc <= 12  = showString "\\0" . shows oc . showl cs
       | oc <= 13  = showLitChar c . showl cs
       | oc <= 31  = showString "\\0" . shows oc . showl cs
       | oc <= 126 = showLitChar c . showl cs
       | otherwise = showString "\\" . shows oc . showl cs
       where oc = ord c
bbr's avatar
bbr committed
163
164
      showl (SearchChar f1 f2 f3 f4:cs) = 
        either showString showLitChar (scToChar f1 f2 f3 f4) . showl cs
bbr's avatar
bbr committed
165
166
  
      showFreel [] = showString "]"
bbr's avatar
bbr committed
167
168
169
170
171
172
      showFreel [c] = showString (show c) . showString "]"
      showFreel (c:cs)   = showString (show c++",") . showFreel cs
      
      isFreeChar (SearchChar f1 f2 f3 f4) = 
        any ((==Branching) . consKind) [f1,f2,f3,f4] 
      isFreeChar _              = False
bbr's avatar
bbr committed
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

protectEsc p f             = f . cont
 where cont s@(c:_) | p c  = "\\&" ++ s
       cont s              = s

asciiTab = zip ['\NUL'..' ']
	   ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
	    "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
	    "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
	    "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
	    "SP"]

instance Show C_Nat where
  showsPrec d x | isFreeNat x = showsPrecNat d x
                | otherwise   = showsPrec d (fromCurry x::Integer)


isFreeNat :: C_Nat -> Bool
bbr's avatar
bbr committed
191
isFreeNat (C_NatOr _ _)    = True
bbr's avatar
bbr committed
192
193
194
195
196
197
198
199
200
201
202
203
204
205
isFreeNat C_IHi            = False
isFreeNat (C_I n)          = isFreeNat n
isFreeNat (C_O n)          = isFreeNat n

showsPrecNat :: Int -> C_Nat -> ShowS
showsPrecNat _ DataPrelude.C_IHi = Prelude.showString((:)('I')((:)('H')((:)('i')([]))))
showsPrecNat d (DataPrelude.C_O x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr)
 where
  showStr  = (Prelude..)(Prelude.showString((:)('O')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1))

showsPrecNat d (DataPrelude.C_I x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr)
 where
  showStr  = (Prelude..)(Prelude.showString((:)('I')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1))

bbr's avatar
bbr committed
206
207
showsPrecNat _ (DataPrelude.C_NatOr i _) = Prelude.showString((:)('_')(Prelude.show(deref i)))

bbr's avatar
bbr committed
208
209
210
211
212
213
214
215
instance Show C_Int where
  showsPrec _ C_Zero = showChar '0'
  showsPrec d x@(C_Pos n) 
    | isFreeNat n = showParen (d>10) (showString "Pos " . showsPrecNat 11 n)
    | otherwise   = showsPrec d (fromCurry x::Integer)
  showsPrec d x@(C_Neg n) 
    | isFreeNat n = showParen (d>10) (showString "Neg " . showsPrecNat 11 n)
    | otherwise   = showsPrec d (fromCurry x::Integer)
216
  showsPrec _ (C_IntOr i _) = showChar '_' . shows (deref i)
bbr's avatar
bbr committed
217
218
219
220
221
222
223
224
225
226

-----------------------------------------------------------------
-- external Read instances
-----------------------------------------------------------------

instance Read C_Four where
  readsPrec _ _ = error "I won't read four"

instance (Read t0) => Read (IOVal t0) where
  readsPrec d r = readParen (d>10) 
227
    (\ r -> [ (IOVal x1,r1) | (_,r0) <- readQualified "Prelude" "IOVal" r, 
bbr's avatar
bbr committed
228
229
230
231
232
233
234
235
236
                              (x1,r1) <- readsPrec 11 r0]) r

instance Read (IO (IOVal a)) where
  readsPrec = error "no reading IO"

instance Read (C_IO a) where
  readsPrec = error "no reading IO"

instance Read C_Success where
237
238
239
  readsPrec d r = Prelude.readParen(Prelude.False)
                  (\ r -> [(,)(C_Success)(r0) | 
                           (_,r0) <- readQualified "Prelude" "Success" r])(r)
bbr's avatar
bbr committed
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258

instance Read a => Read (Prim a) where
  readsPrec p s = map (\(x,y) -> (PrimValue x,y)) (readsPrec p s)

instance Read a => Read (List a) where
    readsPrec p = map (\ (x,y) -> (fromHaskellList x,y)) . readsPrec p

instance Read C_Char where
  readsPrec p s = map (\ (x,y) -> (toCurry x,y))
                      (((readsPrec p)::ReadS Char) s)

  readList s = map (\ (x,y) -> (map toCurry x,y))
                      ((readList::ReadS String) s)

instance Read (a->b) where
  readsPrec = error "reading FUNCTION"

instance Read DataPrelude.C_Nat where
  readsPrec d r =  
259
260
261
262
263
       readParen False  (\ r -> [(C_IHi,r0)  | (_ ,r0) <- readQualified "Prelude" "IHi" r]) r
    ++ readParen (d>10) (\ r -> [(C_O x1,r1) | (_ ,r0) <- readQualified "Prelude" "O"   r, 
                                               (x1,r1) <- readsPrec 11 r0]) r
    ++ readParen (d>10) (\ r -> [(C_I x1,r1) | (_ ,r0) <- readQualified "Prelude" "I"   r, 
                                               (x1,r1) <- readsPrec 11 r0]) r
bbr's avatar
bbr committed
264
265
266
267
    ++ [(toCurry i,r0) | (i::Integer,r0) <- reads r]

instance Read DataPrelude.C_Int where
  readsPrec d r = 
268
269
270
271
272
       readParen (d>10) (\ r -> [(C_Neg x1,r1)  | (_ ,r0) <- readQualified "Prelude" "Neg" r, 
                                                  (x1,r1) <- readsPrec 11 r0]) r
    ++ readParen False  (\ r -> [(C_Zero,r0)    | (_ ,r0) <- readQualified "Prelude" "Zero" r]) r 
    ++ readParen (d>10) (\ r -> [(C_Pos x1,r1)  | (_ ,r0) <- readQualified "Prelude" "Pos" r,
                                                  (x1,r1) <- readsPrec 11 r0]) r
bbr's avatar
bbr committed
273
274
275
276
277
278
279
280
    ++ [(toCurry i,r0) | (i::Integer,r0) <- reads r]


-----------------------------------------------------------------
-- external BaseCurry instances
-----------------------------------------------------------------

instance (BaseCurry t0) => BaseCurry (IOVal t0) where
bbr's avatar
bbr committed
281
282
  nf f (IOVal x1) state0 = nfCTC(\ v1 state1 -> f(IOVal(v1)) (state1))(x1) (state0)
  nf f x state = f(x) (state)
bbr's avatar
bbr committed
283

bbr's avatar
bbr committed
284
285
  gnf f (IOVal x1) state0 = gnfCTC(\ v1 state1 -> f(IOVal(v1)) (state1))(x1) (state0)
  gnf f x state = f(x) (state)
bbr's avatar
bbr committed
286

bbr's avatar
bbr committed
287
  generator i    = IOVal (generator i)
bbr's avatar
bbr committed
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302

  failed  = IOValFail

  branching r bs = IOValOr r (map return bs)

  consKind (IOValOr _ _) = Branching
  consKind (IOValFail _) = Failed
  consKind _ = Val

  exceptions (IOValFail x) = x

  orRef (IOValOr x _) = x

  branches (IOValOr _ bs) = map unsafePerformIO bs

bbr's avatar
bbr committed
303
instance (BaseCurry t0) => BaseCurry (IO (IOVal t0)) where
bbr's avatar
bbr committed
304
305
  nf f x state = f(x) (state)
  gnf f x state = f(x)(state)
bbr's avatar
bbr committed
306
307
308

  failed x = return (IOValFail x)

bbr's avatar
bbr committed
309
  generator u       = return (generator u)
bbr's avatar
bbr committed
310
311
312

  branching r bs = return (IOValOr r bs)

bbr's avatar
bbr committed
313
  consKind x = consKind (unsafePerformIO x)
bbr's avatar
bbr committed
314

bbr's avatar
bbr committed
315
  exceptions x = exceptions (unsafePerformIO x)
bbr's avatar
bbr committed
316

bbr's avatar
bbr committed
317
  orRef x = orRef (unsafePerformIO x)
bbr's avatar
bbr committed
318

bbr's avatar
bbr committed
319
  branches x = unsafePerformIO (x >>= \ (IOValOr _ bs) -> return bs)
bbr's avatar
bbr committed
320
321

instance (BaseCurry t0) => BaseCurry (C_IO t0) where
bbr's avatar
bbr committed
322
323
  nf f x state = f(x)(state)
  gnf f x state = f(x)(state)
bbr's avatar
bbr committed
324

bbr's avatar
bbr committed
325
  generator i    = C_IO (\ _ -> generator i)
bbr's avatar
bbr committed
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342

  failed  = C_IOFail

  branching  = C_IOOr

  consKind (C_IOOr _ _) = Branching
  consKind (C_IOFail _) = Failed
  consKind _ = Val

  exceptions (C_IOFail x) = x

  orRef (C_IOOr x _) = x

  branches (C_IOOr _ x) = x


instance BaseCurry C_Char where
bbr's avatar
bbr committed
343
344
  nf f (SearchChar x1 x2 x3 x4) state0 = Curry.nfCTC(\ v1 state1 -> Curry.nfCTC(\ v2 state2 -> Curry.nfCTC(\ v3 state3 -> Curry.nfCTC(\ v4 state4 -> f(SearchChar(v1)(v2)(v3)(v4))(state4))(x4)(state3))(x3)(state2))(x2)(state1))(x1)(state0)
  nf f x store = f(x)(store)
bbr's avatar
bbr committed
345

bbr's avatar
bbr committed
346
347
  gnf f (SearchChar x1 x2 x3 x4) state0 = Curry.gnfCTC(\ v1 state1 -> Curry.gnfCTC(\ v2 state2 -> Curry.gnfCTC(\ v3 state3 -> Curry.gnfCTC(\ v4 state4 -> f(SearchChar(v1)(v2)(v3)(v4))(state4))(x4)(state3))(x3)(state2))(x2)(state1))(x1)(state0)
  gnf f x store = f(x)(store)
bbr's avatar
bbr committed
348
349
350
351
352
353
  

  consKind (C_CharOr _ _) = Branching
  consKind (C_CharFail _) = Failed
  consKind _ = Val

bbr's avatar
bbr committed
354
355
356
357
  generator i = withRef ( \r -> SearchChar (generator r) 
                                           (generator (r+1)) 
                                           (generator (r+2)) 
                                           (generator (r+3))) 3
bbr's avatar
bbr committed
358
359
360
361
362
363
364
365
366
367
368
369

  orRef      (C_CharOr x _) = x
  branches   (C_CharOr _ x) = x

  failed = C_CharFail

  exceptions (C_CharFail x) = x

  branching  = C_CharOr


instance Generate a => BaseCurry (Prim a) where
bbr's avatar
bbr committed
370
  nf f x store = f(x)(store)
bbr's avatar
bbr committed
371

bbr's avatar
bbr committed
372
  gnf f x store = f(x)(store)
bbr's avatar
bbr committed
373

bbr's avatar
bbr committed
374
375
376
377
378
379
  generator i    = gen genFree 
    where
      gen f = let max = maxArity (head (f 0)) in
        withRef (\r -> PrimOr (mkRef r max i)
                              (map PrimValue (f r)))
                max
bbr's avatar
bbr committed
380
381
382
383
384
385
386
387
388
389
390
391
392
393

  failed = PrimFail
  branching = PrimOr

  consKind (PrimOr _ _) = Branching
  consKind (PrimFail _) = Failed
  consKind _ = Val

  exceptions (PrimFail x) = x

  orRef (PrimOr x _) = x

  branches (PrimOr _ x) = x

bbr's avatar
bbr committed
394
395
396
397
398
399
400
401

instance (BaseCurry t0) => BaseCurry (DataPrelude.List t0) where
  nf f ((DataPrelude.:<) x1 x2) state0 = Curry.nfCTC(\ v1 state1 -> Curry.nfCTC(\ v2 state2 -> f((DataPrelude.:<)(v1)(v2))(state2))(x2)(state1))(x1)(state0)
  nf f x st = f(x)(st)

  gnf f ((DataPrelude.:<) x1 x2) state0 = Curry.gnfCTC(\ v1 state1 -> Curry.gnfCTC(\ v2 state2 -> f((DataPrelude.:<)(v1)(v2))(state2))(x2)(state1))(x1)(state0)
  gnf f x st = f(x)(st)

bbr's avatar
bbr committed
402
403
  generator i = withRef (\ r -> ListOr (mkRef r 2 i) 
                        ([List,(:<)(generator(r+1))(generator(r+2))])) 2
bbr's avatar
bbr committed
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

  failed  = DataPrelude.ListFail

  branching  = DataPrelude.ListOr

  consKind (DataPrelude.ListOr _ _) = Curry.Branching
  consKind (DataPrelude.ListFail _) = Curry.Failed
  consKind _ = Curry.Val

  exceptions (DataPrelude.ListFail x) = x

  orRef (DataPrelude.ListOr x _) = x

  branches (DataPrelude.ListOr _ x) = x


bbr's avatar
bbr committed
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
-----------------------------------------------------------------
-- converting between curry and haskell
-----------------------------------------------------------------

-- In Order to integrate Haskell functions we sometimes 
-- need to convert values.
-- (Do we really need both directions? Or rather convert a b for both?)
class ConvertCH a b where
  fromCurry :: a -> b
  fromCurry = error "fromCurry"
  toCurry :: b -> a
  toCurry = error "toCurry"

instance ConvertCH C_Bool Bool where
  fromCurry C_True  = True
  fromCurry C_False = False

  toCurry True  = C_True
  toCurry False = C_False

isC_True C_True = True
isC_True _      = False

instance ConvertCH C_Char Char where
  fromCurry (C_Char c) = c
bbr's avatar
bbr committed
445
446
  fromCurry (SearchChar f0 f1 f2 f3) = 
    either (error "convert to char") id (scToChar f0 f1 f2 f3)
bbr's avatar
bbr committed
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
  toCurry c = C_Char c

instance (ConvertCH a b) => ConvertCH (List a) [b] where
  fromCurry List = []
  fromCurry (x :< xs) = fromCurry x : fromCurry xs
  fromCurry (ListOr _ _) = error "or list"

  toCurry [] = List
  toCurry (x:xs) = toCurry x :< toCurry xs

-- sometimes you need conversion of lists without converting the elements
-- eg Searchtree, Show instance

toHaskellList :: List a -> [a]
toHaskellList List = []
toHaskellList (x :< xs) = x : toHaskellList xs

fromHaskellList :: [a] -> List a
fromHaskellList [] = List
fromHaskellList (x : xs) = x :< fromHaskellList xs

-- specify result type of toCurry "..." for code generation
fromHaskellString :: String -> List C_Char
fromHaskellString = toCurry

instance ConvertCH C_Int Integer where
  fromCurry C_Zero    = 0
  fromCurry (C_Pos i) = fromCurry i
  fromCurry (C_Neg i) = negate (fromCurry i)

  toCurry n = case compare n 0 of
   LT -> C_Neg (toCurry (abs n))
   EQ -> C_Zero
   GT -> C_Pos (toCurry (abs n))

instance ConvertCH C_Nat Integer where
  fromCurry (C_I bs) = 2 Prelude.* fromCurry bs Prelude.+ 1
  fromCurry (C_O bs) = 2 Prelude.* fromCurry bs
  fromCurry C_IHi    = 1

  toCurry n = case mod n 2 of
                1 -> if m Prelude.== 0 then C_IHi else C_I (toCurry m)
                0 -> C_O (toCurry m)
    where m = Prelude.div n 2


instance ConvertCH C_Int Int where
  fromCurry c = fromInteger (fromCurry c)
  toCurry i   = toCurry (toInteger i)

instance ConvertCH (Prim a) a where
  toCurry = PrimValue 
  fromCurry (PrimValue x) = x

-------------------------------------------------------------
-- basic functions used in instances of class GenericCurry
-------------------------------------------------------------
-- obscure names come from the standard operator 
-- renaming scheme of the compiler.

-- implementation of concurrent (&)
-- no other implementation
-- basic concept: if one value suspends evaluate the other 
-- TODO: include state information!
bbr's avatar
bbr committed
511
512
513
concAnd :: StrEqResult -> StrEqResult -> Result StrEqResult
concAnd C_True y _ = y
concAnd x@(C_BoolOr _ _) y st = maySwitch y x st
bbr's avatar
bbr committed
514
--concAnd (C_BoolOr r xs) y = C_BoolOr r (map (flip concAnd y) xs)
bbr's avatar
bbr committed
515
516
517
518
519
520
concAnd x@(C_BoolFail _) _ _ = x
concAnd x@C_False _ _ = x

maySwitch :: StrEqResult -> StrEqResult -> Result StrEqResult
maySwitch C_True x _ = x
maySwitch y@(C_BoolOr _ _) (C_BoolOr r xs) st = 
521
             C_BoolOr r (map (\ x -> concAnd y x st) xs)
bbr's avatar
bbr committed
522
523
maySwitch x@(C_BoolFail _) _ _ = x
maySwitch x@C_False _ _ = x
bbr's avatar
bbr committed
524
{-
bbr's avatar
bbr committed
525
startBreadth :: [StrEqResult] -> Result StrEqResult
bbr's avatar
bbr committed
526
startBreadth cs st = onLists st [] cs
bbr's avatar
bbr committed
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542

instance Eq C_Bool where
  C_True == C_True = True
  C_False == C_False = True
  _ == _ = False

allSame :: Eq a => [a] -> Bool
allSame []     = True
allSame (x:xs) = all (x==) xs

onLists :: Store -> [StrEqResult] -> [StrEqResult] -> StrEqResult
onLists _ []  []      = strEqSuccess
onLists _ _   (x@(C_BoolFail _):_) = x
onLists _ _   (C_False:_)   = C_False
onLists st ors (C_True:xs) = onLists st ors xs
onLists st ors (C_BoolAnd xs:ys) = onLists st ors (xs++ys)
bbr's avatar
bbr committed
543
544
545
546
547
onLists st ors (C_BoolOr ref xs:ys) 
  | isChain ref = chain (\ x st -> onLists st ors (x:ys)) ref xs st
  | otherwise   = case fromStore ref st of
  Nothing -> onLists st (insertOr ref xs ors) ys
  Just i  -> onLists st ors (xs!!i : ys)
bbr's avatar
bbr committed
548
onLists st (C_BoolOr ref xs:ors) [] = 
bbr's avatar
bbr committed
549
550
  let inBranch i x = maybe (failed $ curryError "onLists")
                           (\st -> onLists st ors [x])
bbr's avatar
bbr committed
551
                           (addToStore ref i st)
bbr's avatar
bbr committed
552
  in  C_BoolOr ref (zipWith inBranch [0..] xs)
bbr's avatar
bbr committed
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

insertOr ref xs [] = [C_BoolOr ref xs]
insertOr ref xs (o@(C_BoolOr ref2 xs2):ys) 
  | ref==ref2 = C_BoolOr ref (zipWith insertAnd xs xs2) : ys
  | otherwise = o : insertOr ref xs ys

insertAnd C_True           y       	    = y
insertAnd C_False          _       	    = C_False
insertAnd x@(C_BoolFail _) _       	    = x
insertAnd x                C_True  	    = x
insertAnd _                C_False 	    = C_False
insertAnd _                x@(C_BoolFail _) = x
insertAnd o1@(C_BoolOr ref1 xs1) o2@(C_BoolOr ref2 xs2) 
  | ref1 == ref2 = C_BoolOr ref1 (zipWith insertAnd xs1 xs2)
  | otherwise    = C_BoolAnd [o1,o2]
insertAnd o@(C_BoolOr _ _) (C_BoolAnd ys)   = C_BoolAnd (o:ys)
insertAnd (C_BoolAnd ys)   o@(C_BoolOr _ _) = C_BoolAnd (o:ys)
insertAnd (C_BoolAnd xs)   (C_BoolAnd ys)   = C_BoolAnd (xs++ys)
bbr's avatar
bbr committed
571
-}
bbr's avatar
bbr committed
572
573
--- implementation of (==)
--- no other implementation
bbr's avatar
bbr committed
574
575
genEq :: Curry t0 => t0 -> t0 -> Result C_Bool
genEq x y = ghnfCTC (\x'-> ghnfCTC (eq x') y) x
bbr's avatar
bbr committed
576
577
578
579

--- implementation of (=:=)
--- no other implementation
--- TODO: use state information
bbr's avatar
bbr committed
580
581
genStrEq :: Curry t0 => t0 -> t0 -> Result StrEqResult
genStrEq a b = (\ a' -> (onceMore a') `hnfCTC` b)  `hnfCTC` a
bbr's avatar
bbr committed
582
  where
bbr's avatar
bbr committed
583
    onceMore a' b' = (\ a'' -> unify a'' b') `hnfCTC` a'
bbr's avatar
bbr committed
584
    unify x y st = checkFree (consKind x) (consKind y)
bbr's avatar
bbr committed
585
      where
bbr's avatar
bbr committed
586
      checkFree Val Val = strEq x y st
Bernd Brassel's avatar
Bernd Brassel committed
587
588

      checkFree Branching Branching  
bbr's avatar
bbr committed
589
         | drx Prelude.== dry
bbr's avatar
bbr committed
590
591
         = C_True
         | otherwise = branching (equalFromTo ax bx drx ay by dry) [C_True]
bbr's avatar
bbr committed
592
593
         where (ax,bx,drx)=genInfo (orRef x)
               (ay,by,dry)=genInfo (orRef y)
Bernd Brassel's avatar
Bernd Brassel committed
594

bbr's avatar
bbr committed
595
      checkFree Branching _ = 
Bernd Brassel's avatar
Bernd Brassel committed
596
597
598
        hnfCTC (\ x' -> unify x' y) 
               (branching (narrowOrRef (orRef x)) (branches x)) st

bbr's avatar
bbr committed
599
      checkFree _ Branching = 
Bernd Brassel's avatar
Bernd Brassel committed
600
601
602
        hnfCTC (unify x)
               (branching (narrowOrRef (orRef y)) (branches y)) st

bbr's avatar
bbr committed
603
      checkFree x   y   = error $ "checkFree " ++ show (x,y)
bbr's avatar
bbr committed
604
605
606
607
608
609
610
611
612
613
614
615
616
617

strEqFail :: String -> StrEqResult
strEqFail s = C_False --C_SuccessFail (ErrorCall ("(=:=) for type "++s))

strEqSuccess :: StrEqResult
strEqSuccess = C_True

--hcAppend [] ys = ys
--hcAppend (x:xs) ys = x:< hcAppend xs ys

-----------------------------------------------------------------
-- external Generate instances
-----------------------------------------------------------------

bbr's avatar
bbr committed
618
instance BaseCurry b => Generate (a -> Result b) where
619
620
  genFree i  = mkBranches (generator i)
  maxArity _ = 1
bbr's avatar
bbr committed
621

bbr's avatar
bbr committed
622
mkBranches :: BaseCurry b => b -> [a -> Result b]
bbr's avatar
bbr committed
623
mkBranches x = case consKind x of
624
       Val       -> [const (const x)]
bbr's avatar
bbr committed
625
626
627
       Branching -> map (const . const) (branches x)

instance Generate Float where
628
629
  genFree    = error "free variable of type Float"
  maxArity _ = error "free variable of type Float"
bbr's avatar
bbr committed
630
631
632
633

-----------------------------------------------------------------
-- external Curry instances
-----------------------------------------------------------------
bbr's avatar
bbr committed
634
635
636
637
638
639
640
641
642
643
644

instance (Curry t0) => Curry (DataPrelude.List t0) where
  strEq DataPrelude.List DataPrelude.List st = ExternalInstancesPrelude.strEqSuccess
  strEq ((DataPrelude.:<) x1 x2) ((DataPrelude.:<) y1 y2) st = ExternalInstancesPrelude.concAnd(ExternalInstancesPrelude.genStrEq(x1)(y1)(st))(ExternalInstancesPrelude.genStrEq(x2)(y2)(st))(st)
  strEq _ x0 _ = ExternalInstancesPrelude.strEqFail(ExternalInstancesPrelude.typeName(x0))

  eq DataPrelude.List DataPrelude.List st = DataPrelude.C_True
  eq ((DataPrelude.:<) x1 x2) ((DataPrelude.:<) y1 y2) st = op_38_38(ExternalInstancesPrelude.genEq(x1)(y1)(st))(ExternalInstancesPrelude.genEq(x2)(y2)(st))(st)
  eq _ _ _ = DataPrelude.C_False

  propagate f DataPrelude.List st = DataPrelude.List
645
  propagate f ((DataPrelude.:<) x1 x2) st = (DataPrelude.:<)(f 0 (x1)(st))(f 1 (x2)(st))
bbr's avatar
bbr committed
646
647
648
649
650
651

  foldCurry f c DataPrelude.List st = c
  foldCurry f c ((DataPrelude.:<) x1 x2) st = f(x1)(f(x2)(c)(st))(st)

  typeName _ = "[]"

bbr's avatar
bbr committed
652
  showQ  = showsPrecList (showQ 0) showQList 
bbr's avatar
bbr committed
653
654

instance Curry C_Four where
bbr's avatar
bbr committed
655
656
657
658
  strEq C_F0 C_F0 _ = strEqSuccess
  strEq C_F1 C_F1 _ = strEqSuccess
  strEq C_F2 C_F2 _ = strEqSuccess
  strEq C_F3 C_F3 _ = strEqSuccess
659
  strEq x0   _    _ = strEqFail(typeName(x0))
bbr's avatar
bbr committed
660
661
662
663
664

  eq C_F0 C_F0 _ = C_True
  eq C_F1 C_F1 _ = C_True
  eq C_F2 C_F2 _ = C_True
  eq C_F3 C_F3 _ = C_True
665
  eq _    _    _ = C_False
bbr's avatar
bbr committed
666

bbr's avatar
bbr committed
667
668
669
670
  propagate _ C_F0 _ = C_F0
  propagate _ C_F1 _ = C_F1
  propagate _ C_F2 _ = C_F2
  propagate _ C_F3 _ = C_F3
bbr's avatar
bbr committed
671

bbr's avatar
bbr committed
672
673
674
675
  foldCurry _ c C_F0 _ = c
  foldCurry _ c C_F1 _ = c
  foldCurry _ c C_F2 _ = c
  foldCurry _ c C_F3 _ = c
bbr's avatar
bbr committed
676
677
678
679

  typeName _ = "Four"


bbr's avatar
bbr committed
680
681
instance BaseCurry a => Curry (IO (IOVal a)) where 
  strEq x y = error "IO.strEq"
bbr's avatar
bbr committed
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714

  eq _ _ = error "IO.eq"

  propagate _ _ = error "propagate IOVal"

  foldCurry _ _ _ = error "foldCurry IOVal"

  typeName _ = "IOVal"

  --toC_Term _ _ _ = error "IO.toC_Term"
  --fromC_Term _   = error "IO.fromC_Term"


instance BaseCurry a => Curry (C_IO a) where
  strEq _ _ = error "strEq IO"

  eq _ _ = error "eq IO"

  --subst store x = x

  propagate _ _ = error "propagate IO"

  foldCurry _ _ _ = error "foldCurry IO"

  typeName _ = "IO"

  --toC_Term _ _ (C_IOFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))
  --toC_Term _ _ _ = C_Data (C_Int 1) (toCurry "IO") List

  --fromC_Term (C_Free (C_Int r)) = C_IOFreeVar(Prelude.fromInteger(r))
  --fromC_Term _ = error "no converting IO"

instance Curry C_Char where
bbr's avatar
bbr committed
715
  strEq x@(C_Char c1) (C_Char c2) _
bbr's avatar
bbr committed
716
    | c1 Prelude.== c2 = C_True
bbr's avatar
bbr committed
717
718
719
  strEq c1@(SearchChar _ _ _ _) (C_Char c2) st = strEq c1 (charToSc c2) st 
  strEq (C_Char c1) c2@(SearchChar _ _ _ _) st = strEq (charToSc c1) c2 st 
  strEq (SearchChar x1 x2 x3 x4) (SearchChar y1 y2 y3 y4) st = concAnd (genEq(x1)(y1)st)(concAnd(genStrEq(x2)(y2)st)(concAnd(genStrEq(x3)(y3)st)(genStrEq(x4)(y4)st)st)st)st
bbr's avatar
bbr committed
720
721
722
  strEq _ x _ = strEqFail (typeName x)


bbr's avatar
bbr committed
723
724
725
726
  eq (C_Char x1) (C_Char y1)             _  = toCurry (x1 Prelude.== y1)
  eq c1@(SearchChar _ _ _ _) (C_Char c2) st = eq c1 (charToSc c2) st
  eq (C_Char c1) c2@(SearchChar _ _ _ _) st = eq (charToSc c1) c2 st
  eq (SearchChar x1 x2 x3 x4) (SearchChar y1 y2 y3 y4) st = op_38_38 (genEq (x1)(y1)st) (op_38_38 (genEq(x2)(y2)st) (op_38_38(genEq(x3)(y3)st)(genEq(x4)(y4)st)st)st)st
bbr's avatar
bbr committed
727
728
  eq _ _ _ = C_False

bbr's avatar
bbr committed
729
  propagate _ c@(C_Char _) _ = c
730
731
  propagate f (SearchChar f0 f1 f2 f3) st = 
    SearchChar (f 0 f0 st) (f 1 f1 st) (f 2 f2 st) (f 3 f3 st)
bbr's avatar
bbr committed
732

bbr's avatar
bbr committed
733
734
  foldCurry _ c (C_Char _) _ = c
  foldCurry f c (SearchChar f0 f1 f2 f3) st = f f0 (f f1 (f f2 (f f3 c st)st)st)st
bbr's avatar
bbr committed
735

bbr's avatar
bbr committed
736
737
738
  typeName _ = "Char"

  showQList = showList  
bbr's avatar
bbr committed
739
740
741
742
743
744
745
746
747
748

  --toC_Term _ _ (C_Char c) = C_Data (C_Int (toInteger (ord c))) (toCurry (show c)) List
  --toC_Term _ _ (C_CharFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))

  --fromC_Term (C_Data (C_Int (i::Integer)) _ List) = C_Char (chr (fromInteger i))
  --fromC_Term (C_Data (C_IntFreeVar _) name List) = C_Char (read (fromCurry name))
  --fromC_Term (C_Free (C_Int r)) = C_CharFreeVar(Prelude.fromInteger(r))


instance (Generate a,Show a,Read a,Eq a) => Curry (Prim a) where
bbr's avatar
bbr committed
749
  strEq x@(PrimValue v1) (PrimValue v2) _
bbr's avatar
bbr committed
750
751
752
    | v1==v2 = C_True --C_Success
    | otherwise = strEqFail (typeName x)

bbr's avatar
bbr committed
753
  eq (PrimValue v1) (PrimValue v2) _ = toCurry (v1==v2)
bbr's avatar
bbr committed
754

bbr's avatar
bbr committed
755
  propagate _ (PrimValue v1) _ = PrimValue v1
bbr's avatar
bbr committed
756

bbr's avatar
bbr committed
757
  foldCurry _ c (PrimValue _) _ = c
bbr's avatar
bbr committed
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776

  --toC_Term _ _ (PrimValue x1) = let sx = show x1 in
  --    C_Data (C_Int (string2int sx)) (toCurry sx) List
  --toC_Term _ _ (PrimFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))

  --fromC_Term (C_Data _ name List) = PrimValue (read (fromCurry name))
  --fromC_Term (C_Free (C_Int r)) = PrimFreeVar(Prelude.fromInteger(r))
 
  typeName _ = "Prim"



-----------------------------------------------------------------
-- external Curry instances
-----------------------------------------------------------------

instance Eq (a->b) where
  (==) = error "comparing FUNCTION"