Commit 523c583c authored by Bernd Brassel's avatar Bernd Brassel
Browse files

MPrelude compiles

parent 6d41c180
......@@ -366,7 +366,7 @@ debugModuleName = "debug.hs"
genDebugModule Opts{debugger=Just tool,mainModule=mod} fs line = do
let modName = debugModuleName
modImports = imports $ "Debugger.DebugMonad":
("Debugger.Tools."++tool++"."++tool++"Monad"):
("Debugger.Tools."++tool++"."++"Monad"):
map mkStrictName ((reqModuleName++" as S"):fs)
modCont = modImports ++
"\n\nmain = do\n\
......
import qualified Char
instance DebugInfo.GenTerm (Float dm) where
instance DI.GenTerm (Float dm) where
underscore = FloatUnderscore
genTerm FloatUnderscore = DebugInfo.TermUnderscore (DebugInfo.SrcID "Prelude" 2)
genTerm (Float f) = DebugInfo.TermFloat f
genTerm FloatUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" 2)
genTerm (Float f) = DI.TermFloat f
instance DebugInfo.GenTerm (Char dm) where
instance DI.GenTerm (Char dm) where
underscore = CharUnderscore
genTerm CharUnderscore = DebugInfo.TermUnderscore (DebugInfo.SrcID "Prelude" 0)
genTerm (Char c) = DebugInfo.TermChar c
genTerm CharUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" 0)
genTerm (Char c) = DI.TermChar c
instance DebugInfo.GenTerm (IO dm a) where
instance DI.GenTerm (IO dm a) where
underscore = IOUnderscore
genTerm IOUnderscore = DebugInfo.TermUnderscore (DebugInfo.SrcID "Prelude" Prelude.undefined)
genTerm IOUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" Prelude.undefined)
genTerm x0 = Prelude.error "not implemented"
natToHInt :: DebugMonad.DM dm => Nat dm -> Prelude.Integer
natToHInt :: DM.DM dm => Nat dm -> Prelude.Integer
natToHInt IHi = 1
natToHInt (O x) = 2 Prelude.* natToHInt x
natToHInt (I x) = 2 Prelude.* natToHInt x Prelude.+ 1
intToHInt :: DebugMonad.DM dm => Int dm -> Prelude.Integer
intToHInt :: DM.DM dm => Int dm -> Prelude.Integer
intToHInt (Neg n) = Prelude.negate (natToHInt n)
intToHInt (Pos n) = natToHInt n
intToHInt Zero = 0
hIntToNat :: (DebugMonad.DM dm,Prelude.Integral n) => n -> Nat dm
hIntToNat :: (DM.DM dm,Prelude.Integral n) => n -> Nat dm
hIntToNat 1 = IHi
hIntToNat i = case Prelude.divMod i 2 of
(d,0) -> O (hIntToNat d)
(d,1) -> I (hIntToNat d)
hIntToInt :: (DebugMonad.DM dm,Prelude.Integral n) => n -> Int dm
hIntToInt :: (DM.DM dm,Prelude.Integral n) => n -> Int dm
hIntToInt i | i Prelude.< 0 = Neg (hIntToNat (Prelude.negate i))
| i Prelude.== 0 = Zero
| Prelude.otherwise = Pos (hIntToNat i)
listToHList :: DebugMonad.DM dm => List dm a -> [a]
listToHList :: DM.DM dm => List dm a -> [a]
listToHList Nil = []
listToHList (Cons x xs) = x:listToHList xs
charToHChar :: DebugMonad.DM dm => Char dm -> Prelude.Char
charToHChar :: DM.DM dm => Char dm -> Prelude.Char
charToHChar (Char c) = c
data (DebugMonad.DM dm) => Float dm = Float Prelude.Float | FloatUnderscore
data (DM.DM dm) => Float dm = Float Prelude.Float | FloatUnderscore
data (DebugMonad.DM dm) => Char dm = Char Prelude.Char | CharUnderscore
data (DM.DM dm) => Char dm = Char Prelude.Char | CharUnderscore
-- data (DebugMonad.DM dm) => IO dm a = IO (Prelude.IO a) | IOUnderscore
-- data (DebugMonad.DM dm) => IO dm a = IO a | IOUnderscore
-- data (DM.DM dm) => IO dm a = IO (Prelude.IO a) | IOUnderscore
-- data (DM.DM dm) => IO dm a = IO a | IOUnderscore
-- data IO dm a = IO (World -> (a,World))
-- data IO dm a = IO (DebugMonad.Func dm (Unit dm) (a,Unit dm))
data IO dm a = IO ((Unit dm) -> (a,(Unit dm))) | IOUnderscore
-- data IO dm a = IO (DM.Func dm (Unit dm) (a,Unit dm))
data World = World
return :: DebugMonad.DM dm => a -> dm a
data IO dm a = IO (World -> dm (a,World)) | IOUnderscore
return :: DM.DM dm => a -> dm a
return = Prelude.return
(?) :: DebugMonad.DM dm => a -> a -> dm a
(?) :: DM.DM dm => a -> a -> dm a
x ? _ = return x
--_ ? y = Prelude.return y
-- implementation just returns () representation
strict_prim_putChar ::
(DebugMonad.DM dm) => Char dm -> dm (IO dm (Unit dm))
strict_prim_putChar x0 = hook_strict_prim_putChar x0 (return (IO Unit))
(DM.DM dm) => Char dm -> dm (IO dm (Unit dm))
strict_prim_putChar x0 = hook_strict_prim_putChar x0 (strict_return Unit)
-- extracts a regular Char from the Virtual I/O information of the oracle
extractChar :: (DebugMonad.DM dm) => dm Prelude.Char
extractChar = DebugMonad.getNextExtVal
extractChar :: (DM.DM dm) => dm Prelude.Char
extractChar = DM.getNextExtVal
strict_getChar :: (DebugMonad.DM dm) => dm (IO dm (Char dm))
strict_getChar :: (DM.DM dm) => dm (IO dm (Char dm))
strict_getChar =
do c <- extractChar
hook_strict_getChar (return (IO (Char c)))
hook_strict_getChar (strict_return (Char c))
op_DollarEMark ::
(DebugMonad.DM dm, DebugInfo.GenTerm a, DebugInfo.GenTerm b) =>
DebugMonad.Func dm a b -> a -> dm b
(DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
DM.Func dm a b -> a -> dm b
op_DollarEMark x0 x1
= hook_op_DollarEMark x0 x1 (strict_apply x0 x1)
op_DollarEMarkEMark ::
(DebugMonad.DM dm, DebugInfo.GenTerm a, DebugInfo.GenTerm b) =>
DebugMonad.Func dm a b -> a -> dm b
(DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
DM.Func dm a b -> a -> dm b
op_DollarEMarkEMark x0 x1
= hook_op_DollarEMarkEMark x0 x1 (strict_apply x0 x1)
op_DollarRhomb ::
(DebugMonad.DM dm, DebugInfo.GenTerm a, DebugInfo.GenTerm b) =>
DebugMonad.Func dm a b -> a -> dm b
(DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
DM.Func dm a b -> a -> dm b
op_DollarRhomb x0 x1
= hook_op_DollarRhomb x0 x1 (strict_apply x0 x1)
op_DollarRhombRhomb ::
(DebugMonad.DM dm, DebugInfo.GenTerm a, DebugInfo.GenTerm b) =>
DebugMonad.Func dm a b -> a -> dm b
(DM.DM dm, DI.GenTerm a, DI.GenTerm b) =>
DM.Func dm a b -> a -> dm b
op_DollarRhombRhomb x0 x1
= hook_op_DollarRhombRhomb x0 x1 (strict_apply x0 x1)
strict_prim_error ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) =>
(DM.DM dm, DI.GenTerm a) =>
List dm (Char dm) -> dm a
strict_prim_error x0
= hook_strict_prim_error x0
(DebugMonad.errorHook (Prelude.map charToHChar (listToHList x0)))
(DM.errorHook (Prelude.map charToHChar (listToHList x0)))
strict_failed :: (DebugMonad.DM dm, DebugInfo.GenTerm a) => dm a
strict_failed
= DebugMonad.failedHook
strict_failed :: (DM.DM dm, DI.GenTerm a) => dm a
strict_failed = return DM.failed
--DM.failedHook
op_EqEq ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) => a -> a -> dm (Bool dm)
(DM.DM dm, DI.GenTerm a) => a -> a -> dm (Bool dm)
op_EqEq x0 x1
= hook_op_EqEq x0 x1 (x0 `eqeq` x1)
eqeq :: (DebugMonad.DM dm, DebugInfo.GenTerm a) => a -> a -> dm (Bool dm)
eqeq :: (DM.DM dm, DI.GenTerm a) => a -> a -> dm (Bool dm)
eqeq x0 x1
| DebugInfo.genTerm x0 Prelude.== DebugInfo.genTerm x1 = Prelude.return True
| DI.genTerm x0 Prelude.== DI.genTerm x1 = Prelude.return True
| Prelude.otherwise = Prelude.return False
strict_prim_ord :: (DebugMonad.DM dm) => Char dm -> dm (Int dm)
strict_prim_ord :: (DM.DM dm) => Char dm -> dm (Int dm)
strict_prim_ord x0@(Char c)
= hook_strict_prim_ord x0 (Prelude.return (hIntToInt (Char.ord c)))
strict_prim_chr :: (DebugMonad.DM dm) => Int dm -> dm (Char dm)
strict_prim_chr :: (DM.DM dm) => Int dm -> dm (Char dm)
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 ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) => a -> a -> dm (Bool dm)
(DM.DM dm, DI.GenTerm a) => a -> a -> dm (Bool dm)
op_EqEqEq x0 x1
= hook_op_EqEqEq x0 x1 (x0 `eqeq` x1)
op_And ::
(DebugMonad.DM dm) => Success dm -> Success dm -> dm (Success dm)
(DM.DM dm) => Success dm -> Success dm -> dm (Success dm)
op_And x0 x1 = hook_op_And x0 x1 (Prelude.error "not implemented")
-- data IO dm a = IO ((Unit dm) -> (a,(Unit dm)))
op_GtGtEq ::
(DebugMonad.DM dm, DebugInfo.GenTerm a, DebugInfo.GenTerm b) =>
IO dm a -> DebugMonad.Func dm a (IO dm b) -> dm (IO dm b)
op_GtGtEq a k
(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 x0 x1 (Prelude.error "not implemented")
= hook_op_GtGtEq a k (IO (\w -> case a w of
(r,w') -> let IO f = k r
in
f w'))
= hook_op_GtGtEq a1 k (return (IO (\w -> do
(r, w') <- a w
IO f <- strict_apply k r
f w')))
strict_return ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) => a -> dm (IO dm a)
(DM.DM dm, DI.GenTerm a) => a -> dm (IO dm a)
strict_return x
-- = hook_strict_return x (IO dm (FuncRep (\w -> (x,w))))
= hook_strict_return x (IO (\w -> (x,w)))
= hook_strict_return x (return (IO (\w -> return (x,w))))
strict_prim_readFile ::
(DebugMonad.DM dm) =>
(DM.DM dm) =>
List dm (Char dm) -> dm (IO dm (List dm (Char dm)))
strict_prim_readFile x0
= hook_strict_prim_readFile x0 (Prelude.error "not implemented")
-- implementation just returns () representation
strict_prim_writeFile ::
(DebugMonad.DM dm) =>
(DM.DM dm) =>
List dm (Char dm) -> List dm (Char dm) -> dm (IO dm (Unit dm))
strict_prim_writeFile x0 x1
= hook_strict_prim_writeFile x0 x1 (return (IO Unit))
= hook_strict_prim_writeFile x0 x1 (strict_return Unit)
-- implementation just returns () representation
strict_prim_appendFile ::
(DebugMonad.DM dm) =>
(DM.DM dm) =>
List dm (Char dm) -> List dm (Char dm) -> dm (IO dm (Unit dm))
strict_prim_appendFile x0 x1
= hook_strict_prim_appendFile x0 x1 (return (IO Unit))
= hook_strict_prim_appendFile x0 x1 (strict_return Unit)
strict_catchFail ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) =>
(DM.DM dm, DI.GenTerm a) =>
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 ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) =>
(DM.DM dm, DI.GenTerm a) =>
a -> dm (List dm (Char dm))
strict_prim_show x0
= hook_strict_prim_show x0 (Prelude.error "not implemented")
strict_getSearchTree ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) =>
(DM.DM dm, DI.GenTerm a) =>
a -> dm (IO dm (SearchTree dm a))
strict_getSearchTree x0
= hook_strict_getSearchTree x0 (Prelude.error "not implemented")
strict_apply :: DebugMonad.DM dm => DebugMonad.Func dm a b -> a -> dm b
strict_apply (DebugMonad.FuncRep _ f) x = f x
strict_apply :: DM.DM dm => DM.Func dm a b -> a -> dm b
strict_apply (DM.FuncRep _ f) x = f x
strict_cond ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) => Success dm -> a -> dm a
(DM.DM dm, DI.GenTerm a) => Success dm -> a -> dm a
strict_cond x0 x1
= hook_strict_cond x0 x1 (Prelude.error "not implemented")
strict_commit ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) => a -> dm a
(DM.DM dm, DI.GenTerm a) => a -> dm a
strict_commit x0
= hook_strict_commit x0 (Prelude.error "not implemented")
op_EqColonLtEq ::
(DebugMonad.DM dm, DebugInfo.GenTerm a) =>
(DM.DM dm, DI.GenTerm a) =>
a -> a -> dm (Success dm)
op_EqColonLtEq x0 x1
= hook_op_EqColonLtEq x0 x1 (Prelude.error "not implemented")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment