Commit 3c55f61c authored by bbr's avatar bbr
Browse files

module meta compiling

- in addition: no () put out in new ghc
parent 0809f040
......@@ -316,7 +316,7 @@ mainMod (_,aux2) m opts = let aux = (m,snd (funName ("",aux2))) in
(Just [C.Rule []
(noguard $ fapp (hasPresym ">>")
[app (setProg opts) (C.String (mainModule opts)),
app (C.Symbol (modName "Prelude","curryIO"))
app (C.Symbol (modName "Prelude","curryIOVoid"))
(sym aux)]) []])]
[]
where
......
......@@ -3,6 +3,6 @@ module ExternalFunctionsInteractive where
import Curry
import CurryPrelude
printTerm :: (Show t0,Curry t0) => State -> t0 -> C_IO T0
printTerm _ x = C_IO (\ _ -> print x >> return (IOVal T0))
printTerm :: (Show t0,Curry t0) => t0 -> Result (C_IO T0)
printTerm x _ = C_IO (\ _ -> print x >> return (IOVal T0))
......@@ -16,8 +16,8 @@ import Data.List
-- test for free variable
---------------------------------------------------------------------------------
prim_isFree :: (Curry t0) => Fun t0 (C_IO (C_Either t0 t0))
prim_isFree _ x = C_IO (\ _ -> case consKind x of
prim_isFree :: (Curry t0) => t0 -> Result (C_IO (C_Either t0 t0))
prim_isFree x _ = C_IO (\ _ -> case consKind x of
Free -> return (IOVal (C_Left x))
_ -> return (IOVal (C_Right x)))
......@@ -30,34 +30,34 @@ prim_isFree _ x = C_IO (\ _ -> case consKind x of
-- then apply continuation on it and make sure that you got a value
-- of type io before finally executing that action.
headNormalFormIO :: (Curry a,Curry b) => Fun (Prim (Fun a (C_IO b))) (a -> C_IO b)
headNormalFormIO _ cont x =
C_IO (\state -> hnfCTC (\st x' -> hnfCTC exec2 st (apply st cont x')) state x)
headNormalFormIO :: (Curry a,Curry b) => Prim (a -> Result (C_IO b)) -> a -> Result (C_IO b)
headNormalFormIO cont x _ =
C_IO (hnfCTC (\ x' st -> hnfCTC exec2 (apply cont x' st) st) x)
searchTree :: Curry a => Fun a (C_SearchTree a)
searchTree st x = searchTr st x
searchTree :: Curry a => a -> Result (C_SearchTree a)
searchTree = searchTr
hnfIO _ x = C_IO (\ state -> hnfCTC (const (return . IOVal)) state x)
nfIO _ x = C_IO (\ state -> nfCTC (const (return . IOVal)) state x)
gnfIO _ x = C_IO (\ state -> ghnfCTC (const (return . IOVal)) state x)
ghnfIO _ x = C_IO (\ state -> ghnfCTC (const (return . IOVal)) state x)
hnfIO x _ = C_IO (hnfCTC (const (return . IOVal)) x)
nfIO x _ = C_IO (nfCTC (const (return . IOVal)) x)
gnfIO x _ = C_IO (ghnfCTC (const (return . IOVal)) x)
ghnfIO x _ = C_IO (ghnfCTC (const (return . IOVal)) x)
---------------------------------------------------------------------------------
-- rich search trees
---------------------------------------------------------------------------------
getRichSearchTree :: Curry a => Fun a (C_IO (C_RichSearchTree a))
getRichSearchTree _ x = C_IO (\ state -> return (IOVal (richSearchTr state x)))
getRichSearchTree :: Curry a => a -> Result (C_IO (C_RichSearchTree a))
getRichSearchTree x _ = C_IO (\ state -> return (IOVal (richSearchTr x state)))
richSearchTree :: Curry a => Fun a (C_RichSearchTree a)
richSearchTree :: Curry a => a -> Result (C_RichSearchTree a)
richSearchTree = richSearchTr
--inject :: Curry a => C_Context -> a -> C_RichSearchTree a
--inject (Context c) = richSearchTr c
richSearchTr :: Curry a => Fun a (C_RichSearchTree a)
richSearchTr state x =
transVal (nfCTC (nfCTC (const id)) state x)
richSearchTr :: Curry a => a -> Result (C_RichSearchTree a)
richSearchTr x state =
transVal (nfCTC (nfCTC (\ x _ -> x)) x state)
where
transVal x = case consKind x of
Val -> C_RichValue x
......@@ -86,13 +86,13 @@ instance ConvertCH C_Exception Exception where
-- parallel search
---------------------------------------------------------------------------------
parallelSearch :: Curry a => Fun a (C_IO (List a))
parallelSearch _ v = C_IO (\state -> do
parallelSearch :: Curry a => a -> Result (C_IO (List a))
parallelSearch v _ = C_IO (\state -> do
chan <- newChan
mvar <- newEmptyMVar
qsem <- newMyQSem 0
tid <- forkIO (searchThread qsem mvar chan
(nfCTC (nfCTC (const id)) state v))
(nfCTC (nfCTC (\ x _ -> x)) v state))
putMVar mvar [tid]
--addFinalizer res (stopSearch mvar2)
res <- myGetChanContents qsem chan
......@@ -191,33 +191,33 @@ testMyQSem (MyQSem sem) = do
-- covering non-determinism
-------------------------------
cover :: Curry a => Fun a a
cover st x = case consKind x of
cover :: Curry a => a -> Result a
cover x st = case consKind x of
Branching -> branching (Curry.cover (orRef x))
(map (ExternalFunctionsMeta.cover st) (branches x))
(map (flip ExternalFunctionsMeta.cover st) (branches x))
_ -> x
-----------------------------------
-- encapsulate to head normal form
-----------------------------------
st :: Curry a => Fun a (C_SearchTree a)
st s x = transVal (hnfCTC (const id) s x)
st :: Curry a => a -> Result (C_SearchTree a)
st x s = transVal (hnfCTC (\ x _ -> x) x s)
where
transVal x = case consKind x of
Val -> C_Value x
Failed -> C_Fail
Branching -> let ref = orRef x in
if isCovered ref
then C_SearchTreeOr (uncover ref) (map (st s) (branches x))
then C_SearchTreeOr (uncover ref) (map (flip st s) (branches x))
else C_Or (fromHaskellList (map transVal (branches x)))
-----------------------------
-- the general question mark
-----------------------------
ors :: Curry a => Fun (List a) a
ors _ xs = orsCTC (toHaskellList xs)
ors :: Curry a => List a -> Result a
ors xs _ = orsCTC (toHaskellList xs)
......
......@@ -24,6 +24,9 @@ infixr 0 &
curryIO :: Curry a => (Result (C_IO a)) -> IO a
curryIO x = let st = emptyStore in ioStart st (x (Just st))
curryIOVoid :: Curry a => (Result (C_IO a)) -> IO ()
curryIOVoid x = curryIO x >> return ()
ioStart :: Curry a => Store -> C_IO a -> IO a
ioStart st (C_IO act) = act (Just st) >>= curryDo st
ioStart _ (C_IOFail es) = printExceptions es
......
Supports Markdown
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