Prelude.hs.include 6.76 KB
Newer Older
1
2
import qualified Char

3
instance DI.GenTerm Float where
Bernd Brassel's avatar
Bernd Brassel committed
4
5
  genTerm FloatUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" 2)
  genTerm (Float f) = DI.TermFloat f
6
 
7
instance DI.GenTerm Char where
Bernd Brassel's avatar
Bernd Brassel committed
8
9
  genTerm CharUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" 0)
  genTerm (Char c) = DI.TermChar c
10

Bernd Brassel's avatar
Bernd Brassel committed
11
12
instance DI.GenTerm (IO dm a) where
  genTerm IOUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" Prelude.undefined)
13
14
  genTerm x0 = Prelude.error "not implemented"

15
natToHInt :: Nat -> Prelude.Integer
16
17
18
19
natToHInt IHi = 1
natToHInt (O x) = 2 Prelude.* natToHInt x
natToHInt (I x) = 2 Prelude.* natToHInt x Prelude.+ 1

20
intToHInt :: Int -> Prelude.Integer
21
22
23
24
intToHInt (Neg n) = Prelude.negate (natToHInt n)
intToHInt (Pos n) = natToHInt n
intToHInt Zero = 0

25
hIntToNat :: Prelude.Integral n => n -> Nat 
26
27
28
29
30
hIntToNat 1 = IHi
hIntToNat i = case Prelude.divMod i 2 of
  (d,0) -> O (hIntToNat d)
  (d,1) -> I (hIntToNat d)

31
hIntToInt :: (Prelude.Integral n) => n -> Int 
32
33
34
35
hIntToInt i | i Prelude.<  0 = Neg (hIntToNat (Prelude.negate i))
            | i Prelude.== 0 = Zero
            | Prelude.otherwise = Pos (hIntToNat i)

36
listToHList :: List a -> [a]
37
38
39
listToHList Nil = []
listToHList (Cons x xs) = x:listToHList xs

40
charToHChar :: Char  -> Prelude.Char
41
42
43
charToHChar (Char c) = c


44
data Float = Float Prelude.Float | FloatUnderscore deriving (Data.Generics.Typeable, Data.Generics.Data)
45
 
46
data Char = Char Prelude.Char | CharUnderscore deriving (Data.Generics.Typeable, Data.Generics.Data)
47
 
48
49
50
51
-- data (DM.DM dm) => IO a = IO (Prelude.IO a) | IOUnderscore
-- data (DM.DM dm) => IO a = IO a | IOUnderscore
-- data IO a = IO (World -> (a,World))
-- data IO a = IO (DM.Func dm (Unit) (a,Unit))
Bernd Brassel's avatar
Bernd Brassel committed
52
data World = World
53

54
55
56
57
data (DM.DM dm) => IO dm a = IO (World -> dm (a,World)) | IOUnderscore -- (dm :: * -> *)

instance Data.Generics.Typeable (IO dm a)
instance Data.Generics.Data (IO dm a)
Bernd Brassel's avatar
Bernd Brassel committed
58
59

return :: DM.DM dm => a -> dm a
60
61
return = Prelude.return

62
63
64
curryReturn :: DM.DM dm => a -> dm (IO dm a)
curryReturn x = return (IO (\w -> return (x,w)))

Bernd Brassel's avatar
Bernd Brassel committed
65
66
(?) :: (DM.DM dm, DI.GenTerm a) => a -> a -> dm a
x ? y = x DM.? y
67
68
69

-- implementation just returns () representation
strict_prim_putChar ::
70
                    (DM.DM dm) => Char -> dm (IO dm (Unit))
71
strict_prim_putChar x0 = hook_strict_prim_putChar x0 (curryReturn Unit)
72

73
strict_getChar :: (DM.DM dm) => dm (IO dm Char)
74
strict_getChar =
75
     hook_strict_getChar (do c <- DM.getNextExtVal; curryReturn (Char c))
76
77

op_DollarEMark ::
Bernd Brassel's avatar
Bernd Brassel committed
78
79
               (DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
                 DM.Func dm a b -> a -> dm b
80
op_DollarEMark x0 x1
81
  = hook_op_DollarEMark x0 x1 (curryApply x0 x1)
82
83
 
op_DollarEMarkEMark ::
Bernd Brassel's avatar
Bernd Brassel committed
84
85
                    (DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
                      DM.Func dm a b -> a -> dm b
86
op_DollarEMarkEMark x0 x1
87
  = hook_op_DollarEMarkEMark x0 x1 (curryApply x0 x1)
88
89
 
op_DollarRhomb ::
Bernd Brassel's avatar
Bernd Brassel committed
90
91
               (DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
                 DM.Func dm a b -> a -> dm b
92
op_DollarRhomb x0 x1
93
  = hook_op_DollarRhomb x0 x1 (curryApply x0 x1)
94
95
 
op_DollarRhombRhomb ::
Bernd Brassel's avatar
Bernd Brassel committed
96
97
                    (DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
                      DM.Func dm a b -> a -> dm b
98
op_DollarRhombRhomb x0 x1
99
  = hook_op_DollarRhombRhomb x0 x1 (curryApply x0 x1)
100
101
 
strict_prim_error ::
Bernd Brassel's avatar
Bernd Brassel committed
102
                  (DM.DM dm, DI.GenTerm a) =>
103
                    List Char -> dm a
104
105
strict_prim_error x0
  = hook_strict_prim_error x0 
Bernd Brassel's avatar
Bernd Brassel committed
106
      (DM.errorHook (Prelude.map charToHChar (listToHList x0)))
107
 
Bernd Brassel's avatar
Bernd Brassel committed
108
strict_failed :: (DM.DM dm, DI.GenTerm a) => dm a
109
strict_failed = hook_strict_failed DM.failedHook 
Bernd Brassel's avatar
Bernd Brassel committed
110

111
112

op_EqEq ::
113
        (DM.DM dm, DI.GenTerm a) => a -> a -> dm Bool
114
115
116
op_EqEq x0 x1
  = hook_op_EqEq x0 x1 (x0 `eqeq` x1)
      
117
eqeq :: (DM.DM dm, DI.GenTerm a) => a -> a -> dm Bool
118
eqeq x0 x1 
Bernd Brassel's avatar
Bernd Brassel committed
119
  | DI.genTerm x0 Prelude.== DI.genTerm x1 = Prelude.return True 
120
121
  | Prelude.otherwise                                    = Prelude.return False
 
122
strict_prim_ord :: (DM.DM dm) => Char -> dm (Int)
123
124
125
strict_prim_ord x0@(Char c)
  = hook_strict_prim_ord x0 (Prelude.return (hIntToInt (Char.ord c)))
 
126
strict_prim_chr :: (DM.DM dm) => Int -> dm Char
127
128
129
130
131
strict_prim_chr x0
  = hook_strict_prim_chr x0 (Prelude.error "not implemented") -- TODO: natToInt
-- = hook_strict_prim_chr x0 (Char $ prim_chr $ natToInt x0)
 
op_EqEqEq ::
132
          (DM.DM dm, DI.GenTerm a) => a -> a -> dm Bool
133
134
135
136
op_EqEqEq x0 x1
  = hook_op_EqEqEq x0 x1 (x0 `eqeq` x1)
 
op_And ::
137
       (DM.DM dm) => Success -> Success -> dm Success
138
139
op_And x0 x1 = hook_op_And x0 x1 (Prelude.error "not implemented")

140
-- data IO a = IO ((Unit) -> (a,(Unit)))
141
op_GtGtEq ::
Bernd Brassel's avatar
Bernd Brassel committed
142
143
144
145
146
          (DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
            IO dm a -> DM.Func dm a (IO dm b) -> dm (IO dm b)
op_GtGtEq a1@(IO a) k
  = hook_op_GtGtEq a1 k (return (IO (\w -> do
       (r, w') <- a w 
147
       IO f <- curryApply k r
Bernd Brassel's avatar
Bernd Brassel committed
148
       f w')))
149
 
150

151
strict_return ::
Bernd Brassel's avatar
Bernd Brassel committed
152
              (DM.DM dm, DI.GenTerm a) => a -> dm (IO dm a)
153
strict_return x
154
  = hook_strict_return x (curryReturn x)
155
156
 
strict_prim_readFile ::
Bernd Brassel's avatar
Bernd Brassel committed
157
                     (DM.DM dm) =>
158
                       List Char -> dm (IO dm (List Char))
159
160
161
162
163
strict_prim_readFile x0
  = hook_strict_prim_readFile x0 (Prelude.error "not implemented")
 
-- implementation just returns () representation
strict_prim_writeFile ::
Bernd Brassel's avatar
Bernd Brassel committed
164
                      (DM.DM dm) =>
165
                        List Char -> List Char -> dm (IO dm (Unit))
166
strict_prim_writeFile x0 x1
167
  = hook_strict_prim_writeFile x0 x1 (curryReturn Unit)
168
169
170
 
-- implementation just returns () representation
strict_prim_appendFile ::
Bernd Brassel's avatar
Bernd Brassel committed
171
                       (DM.DM dm) =>
172
                         List Char -> List Char -> dm (IO dm (Unit))
173
strict_prim_appendFile x0 x1
174
  = hook_strict_prim_appendFile x0 x1 (curryReturn Unit)
175
176
 
strict_catchFail ::
Bernd Brassel's avatar
Bernd Brassel committed
177
                 (DM.DM dm, DI.GenTerm a) =>
178
179
180
181
182
                   IO dm a -> IO dm a -> dm (IO dm a)
strict_catchFail x0 x1
  = hook_strict_catchFail x0 x1 (Prelude.error "not implemented")
 
strict_prim_show ::
Bernd Brassel's avatar
Bernd Brassel committed
183
                 (DM.DM dm, DI.GenTerm a) =>
184
                   a -> dm (List Char)
185
186
187
188
strict_prim_show x0
  = hook_strict_prim_show x0 (Prelude.error "not implemented")
 
strict_getSearchTree ::
Bernd Brassel's avatar
Bernd Brassel committed
189
                     (DM.DM dm, DI.GenTerm a) =>
190
                       a -> dm (IO dm (SearchTree a))
191
192
193
strict_getSearchTree x0
  = hook_strict_getSearchTree x0 (Prelude.error "not implemented")
 
194
195
196
197
198
199

curryApply :: DM.DM dm => DM.Func dm a b -> a -> dm b
curryApply (DM.FuncRep _ f) x = f x

strict_apply :: (DM.DM dm, DI.GenTerm a,DI.GenTerm b) => DM.Func dm a b -> a -> dm b
strict_apply f x = hook_strict_apply f x (curryApply f x)
200
201
 
strict_cond ::
202
            (DM.DM dm, DI.GenTerm a) => Success -> a -> dm a
203
204
205
206
strict_cond x0 x1
  = hook_strict_cond x0 x1 (Prelude.error "not implemented")
 
op_EqColonLtEq ::
Bernd Brassel's avatar
Bernd Brassel committed
207
               (DM.DM dm, DI.GenTerm a) =>
208
                 a -> a -> dm Success
209
210
211
op_EqColonLtEq x0 x1
  = hook_op_EqColonLtEq x0 x1 (Prelude.error "not implemented")