Commit fee96506 authored by Bernd Brassel's avatar Bernd Brassel
Browse files

Merge branch 'master' into cabal

* master:
  some more steps for io
  verbesserungen in external debugger functions
parents 27dd3ddf 578744ba
import qualified Char
import qualified Debugger.ShowTerm as ST
instance DI.GenTerm Float where
genTerm FloatUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" 2)
......@@ -12,12 +13,12 @@ instance DI.GenTerm (IO dm a) where
genTerm IOUnderscore = DI.TermUnderscore (DI.SrcID "Prelude" Prelude.undefined)
genTerm x0 = Prelude.error "not implemented"
natToHInt :: Nat -> Prelude.Integer
natToHInt :: Nat -> Prelude.Int
natToHInt IHi = 1
natToHInt (O x) = 2 Prelude.* natToHInt x
natToHInt (I x) = 2 Prelude.* natToHInt x Prelude.+ 1
intToHInt :: Int -> Prelude.Integer
intToHInt :: Int -> Prelude.Int
intToHInt (Neg n) = Prelude.negate (natToHInt n)
intToHInt (Pos n) = natToHInt n
intToHInt Zero = 0
......@@ -37,9 +38,22 @@ listToHList :: List a -> [a]
listToHList Nil = []
listToHList (Cons x xs) = x:listToHList xs
hListToList :: [a] -> List a
hListToList [] = Nil
hListToList (x:xs) = (Cons x (hListToList xs))
charToHChar :: Char -> Prelude.Char
charToHChar (Char c) = c
hCharToChar :: Prelude.Char -> Char
hCharToChar c = Char c
hStrToStr :: Prelude.String -> List Char
hStrToStr str = hListToList (Prelude.map hCharToChar str)
strToHStr :: List Char -> Prelude.String
strToHStr listChar = Prelude.map charToHChar (listToHList listChar)
data Float = Float Prelude.Float | FloatUnderscore deriving (Data.Generics.Typeable, Data.Generics.Data)
......@@ -56,48 +70,63 @@ 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)
-- simple not qualified short cuts to Prelude
return :: DM.DM dm => a -> dm a
return = Prelude.return
(.) = (Prelude..)
($) = (Prelude.$)
-- IO return for the DebugMonad
curryReturn :: DM.DM dm => a -> dm (IO dm a)
curryReturn x = return (IO (\w -> return (x,w)))
-- local declaration for ? of the DebugMonad module
(?) :: (DM.DM dm, DI.GenTerm a) => a -> a -> dm a
x ? y = x DM.? y
-- putChar :: IO ()
-- implementation just returns () representation
strict_prim_putChar ::
(DM.DM dm) => Char -> dm (IO dm (Unit))
strict_prim_putChar x0 = hook_strict_prim_putChar x0 (curryReturn Unit)
-- getChar :: IO Char
strict_getChar :: (DM.DM dm) => dm (IO dm Char)
strict_getChar =
hook_strict_getChar (do c <- DM.getNextExtVal; curryReturn (Char c))
-- $! :: (a -> b) -> a -> b
op_DollarEMark ::
(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 (curryApply x0 x1)
-- $!! :: (a -> b) -> a -> b
op_DollarEMarkEMark ::
(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 (curryApply x0 x1)
-- $# :: (a -> b) -> a -> b
op_DollarRhomb ::
(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 (curryApply x0 x1)
-- $## :: (a -> b) -> a -> b
op_DollarRhombRhomb ::
(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 (curryApply x0 x1)
-- prim_error :: String -> a
strict_prim_error ::
(DM.DM dm, DI.GenTerm a) =>
List Char -> dm a
......@@ -105,60 +134,72 @@ strict_prim_error x0
= hook_strict_prim_error x0
(DM.errorHook (Prelude.map charToHChar (listToHList x0)))
-- failed :: a
strict_failed :: (DM.DM dm, DI.GenTerm a) => dm a
strict_failed = hook_strict_failed DM.failedHook
strict_failed = hook_strict_failed (return DM.failed)
-- == :: a -> a -> Bool
op_EqEq ::
(DM.DM dm, DI.GenTerm a) => a -> a -> dm Bool
op_EqEq x0 x1
= hook_op_EqEq x0 x1 (x0 `eqeq` x1)
-- performs an equality check on given elements
eqeq :: (DM.DM dm, DI.GenTerm a) => a -> a -> dm Bool
eqeq x0 x1
| DI.genTerm x0 Prelude.== DI.genTerm x1 = Prelude.return True
| Prelude.otherwise = Prelude.return False
eqeq x0 x1 = DM.treatCase' Prelude.False (eqeqx x0) x1 where
eqeqx x y | DI.genTerm x Prelude.== DI.genTerm y = return True
| Prelude.otherwise = return False
-- prim_ord :: Char -> Int
strict_prim_ord :: (DM.DM dm) => Char -> dm (Int)
strict_prim_ord x0@(Char c)
= hook_strict_prim_ord x0 (Prelude.return (hIntToInt (Char.ord c)))
= hook_strict_prim_ord x0 (return (hIntToInt (Char.ord c)))
-- prim_chr :: Int -> Char
strict_prim_chr :: (DM.DM dm) => Int -> dm Char
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)
= hook_strict_prim_chr x0 (return (Char (Char.chr (intToHInt x0))))
-- === :: a -> a -> Bool (???)
op_EqEqEq ::
(DM.DM dm, DI.GenTerm a) => a -> a -> dm Bool
op_EqEqEq x0 x1
= hook_op_EqEqEq x0 x1 (x0 `eqeq` x1)
-- & :: Success -> Success -> Success (TODO)
op_And ::
(DM.DM dm) => Success -> Success -> dm Success
op_And x0 x1 = hook_op_And x0 x1 (Prelude.error "not implemented")
-- data IO a = IO ((Unit) -> (a,(Unit)))
-- >>= :: IO a -> (a -> IO b) -> IO b
op_GtGtEq ::
(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
DM.popOracle
(r, w') <- a w
DM.popOracle
IO f <- curryApply k r
DM.popOracle
f w')))
-- return :: a -> IO a
strict_return ::
(DM.DM dm, DI.GenTerm a) => a -> dm (IO dm a)
strict_return x
= hook_strict_return x (curryReturn x)
= hook_strict_return x (curryReturn x)
-- prim_readFile :: String -> IO String (TODO???)
strict_prim_readFile ::
(DM.DM dm) =>
List Char -> dm (IO dm (List Char))
strict_prim_readFile x0
= hook_strict_prim_readFile x0 (Prelude.error "not implemented")
= hook_strict_prim_readFile x0 (do f <- DM.getNextExtVal; curryReturn (hStrToStr f))
-- prim_writeFile :: String -> String -> IO ()
-- implementation just returns () representation
strict_prim_writeFile ::
(DM.DM dm) =>
......@@ -166,6 +207,7 @@ strict_prim_writeFile ::
strict_prim_writeFile x0 x1
= hook_strict_prim_writeFile x0 x1 (curryReturn Unit)
-- prim_appendFile :: String -> String -> IO ()
-- implementation just returns () representation
strict_prim_appendFile ::
(DM.DM dm) =>
......@@ -173,36 +215,46 @@ strict_prim_appendFile ::
strict_prim_appendFile x0 x1
= hook_strict_prim_appendFile x0 x1 (curryReturn Unit)
-- catchFail :: IO a -> IO a -> IO a (TODO)
strict_catchFail ::
(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")
-- prim_show :: a -> String
strict_prim_show ::
(DM.DM dm, DI.GenTerm a) =>
a -> dm (List Char)
strict_prim_show x0
= hook_strict_prim_show x0 (Prelude.error "not implemented")
= hook_strict_prim_show x0 (show x0)
show x0 = DM.treatCase' Prelude.False (return . show') x0 where
show' x = hStrToStr hStr where
hStr = ST.showGenTerm x
-- getSearchTree :: a -> IO (SearchTree a) (TODO)
strict_getSearchTree ::
(DM.DM dm, DI.GenTerm a) =>
a -> dm (IO dm (SearchTree a))
strict_getSearchTree x0
= hook_strict_getSearchTree x0 (Prelude.error "not implemented")
-- apply for the DebugMonad
curryApply :: DM.DM dm => DM.Func dm a b -> a -> dm b
curryApply (DM.FuncRep _ f) x = f x
-- apply :: (a -> b) -> a -> b
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)
-- cond :: Success -> a -> a (TODO)
strict_cond ::
(DM.DM dm, DI.GenTerm a) => Success -> a -> dm a
strict_cond x0 x1
= hook_strict_cond x0 x1 (Prelude.error "not implemented")
-- =:<= :: a -> a -> Success (TODO)
op_EqColonLtEq ::
(DM.DM dm, DI.GenTerm a) =>
a -> a -> dm Success
......
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