Commit 6714e1e2 authored by bbr's avatar bbr
Browse files

external functions of prelude compile

- several changes in the according file
- change to have generate instance for functions
parent 6785e77e
......@@ -188,17 +188,17 @@ instance (ConvertCH a b) => ConvertCH (C_Maybe a) (Maybe b) where
-- external functions for Prelude
---------------------------------------------------------------------------------
($#) :: (Curry a, Curry b) => State -> Prim (State -> a -> b) -> a -> b
($#) st cont x = prepApply st ghnfCTC x cont
($#) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b
($#) cont x = prepApply ghnfCTC x cont
($!) :: (Curry a,Curry b) => State -> Prim (State -> a -> b) -> a -> b
($!) st cont x = prepApply st hnfCTC x cont
($!) :: (Curry a,Curry b) => Prim (a -> Result b) -> a -> Result b
($!) cont x = prepApply hnfCTC x cont
($!!) :: (Curry a, Curry b) => State -> Prim (State -> a -> b) -> a -> b
($!!) st cont x = prepApply st nfCTC x cont
($!!) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b
($!!) cont x = prepApply nfCTC x cont
($##) :: (Curry a, Curry b) => State -> Prim (State -> a -> b) -> a -> b
($##) st cont x = prepApply st gnfCTC x cont
($##) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b
($##) cont x = prepApply gnfCTC x cont
prim_error :: Curry a => State -> C_String -> a
prim_error _ s = failed (ErrorCall (fromCurry s))
......@@ -206,23 +206,23 @@ prim_error _ s = failed (ErrorCall (fromCurry s))
prim_failed :: Curry a => State -> a
prim_failed st = prim_error st (toCurry "Prelude.failed")
(==) :: Curry a => State -> a -> a -> C_Bool
(==) :: Curry a => a -> a -> Result C_Bool
(==) = genEq
prim_ord :: State -> C_Char -> C_Int
prim_ord _ cc = toCurry (ord (fromCurry cc))
prim_ord :: C_Char -> Result C_Int
prim_ord cc _ = toCurry (ord (fromCurry cc))
prim_chr :: State -> C_Int -> C_Char
prim_chr _ ci = toCurry (chr (fromCurry ci))
prim_chr :: C_Int -> Result C_Char
prim_chr ci _ = toCurry (chr (fromCurry ci))
(===) :: Curry a => State -> a -> a -> C_Bool --C_Success
(===) :: Curry a => a -> a -> Result C_Bool --C_Success
(===) = genStrEq
success :: C_Success
success = C_Success
(&) :: State -> C_Success -> C_Success -> C_Success
(&) st x y = boolToSuccess (concAnd st (successToBool x) (successToBool y))
(&) :: C_Success -> C_Success -> Result C_Success
(&) x y st = boolToSuccess (concAnd (successToBool x) (successToBool y) st)
boolToSuccess C_True = C_Success
boolToSuccess C_False = C_SuccessFail (ErrorCall "&")
......@@ -237,11 +237,11 @@ andBreadth :: State -> List C_Bool -> C_Bool
andBreadth st xs = startBreadth st (toHaskellList xs)
-- TODO: C_IO without State??? also other io-functions.
prim_bind :: (Curry a,Curry b) => State -> C_IO a -> Prim (State -> a -> C_IO b) -> C_IO b
prim_bind _ m f = C_IO (\st -> hnfCTC (exec f) st m)
prim_bind :: (Curry a,Curry b) => C_IO a -> Prim (a -> Result (C_IO b)) -> Result (C_IO b)
prim_bind m f _ = C_IO (hnfCTC (exec f) m)
exec :: (Curry a,Curry b) => Prim (State -> a -> C_IO b) -> State -> C_IO a -> IO (IOVal b)
exec f st (C_IO m) = m st >>= prim_do f st
exec :: (Curry a,Curry b) => Prim (a -> Result (C_IO b)) -> C_IO a -> Result (IO (IOVal b))
exec f (C_IO m) st = m st >>= \ x -> prim_do f x st
-- if it wasn't io, we could just write
--exec f st (C_IO m) = m st >>= hnfCTC (fromIOVal f) st
......@@ -254,63 +254,63 @@ exec f st (C_IO m) = m st >>= prim_do f st
-- IMPORTANT: This code should correspond to BaseCurry.ctcStore
prim_do :: (Curry a,Curry b) =>
Prim (State -> a -> C_IO b) -> State -> IOVal a -> IO (IOVal b)
prim_do f state x = case x of
IOVal res -> hnfCTC exec2 state (apply state f res)
Prim (a -> Result (C_IO b)) -> IOVal a -> Result (IO (IOVal b))
prim_do f x state = case x of
IOVal res -> hnfCTC exec2 (apply f res state) state
IOValFail es -> return (IOValFail es)
IOValOr ref bs ->
case state of
Nothing -> mapOr state (\ st -> (>>= prim_do f st)) ref bs
Nothing -> mapOr (\ x st -> x >>= \ x' -> prim_do f x' st) ref bs state
Just store ->
case fromStore store ref of
Nothing ->
return (IOValOr ref
(zipWith (ctcBranch (\ st x -> x >>= cont st) store ref) [0..] bs))
Just i -> trace "prim_do" (bs!!i) >>= prim_do f state
(zipWith (ctcBranch (\ x st -> x >>= \ x' -> cont x' st) ref store) [0..] bs))
Just i -> (bs!!i) >>= \ x' -> prim_do f x' state
IOValFreeVar ref -> case binding x of
--Left i -> IOValSusp True (findBindIO cont i)
Right v -> prim_do f state v --hnfCTC exec2 state (apply f v)
Right v -> prim_do f v state --hnfCTC exec2 state (apply f v)
--IOValSusp _ susp -> case state of
-- Nothing -> fetchState (\st -> prim_do f st x)
-- --Just store -> wakeUpIO f susp state
where
cont st = prim_do f (Just st)
cont x st = prim_do f x (Just st)
exec2 :: State -> C_IO b -> IO (IOVal b)
exec2 st (C_IO f) = f st
exec2 :: C_IO b -> Result (IO (IOVal b))
exec2 (C_IO f) = f
prim_return :: Curry a => State -> a -> C_IO a
prim_return _ a = C_IO (\ st -> hnfCTC (const (return . IOVal)) st a)
prim_return :: Curry a => a -> Result (C_IO a)
prim_return a _ = C_IO (hnfCTC (\ x _ -> return (IOVal x)) a)
prim_putChar :: State -> C_Char -> C_IO T0
prim_putChar :: C_Char -> Result (C_IO T0)
prim_putChar = ioFunc1 putChar
prim_getChar :: State -> C_IO C_Char
prim_getChar :: Result (C_IO C_Char)
prim_getChar = ioFunc0 getChar
prim_readFile :: State -> C_String -> C_IO C_String
prim_readFile :: C_String -> Result (C_IO C_String)
prim_readFile = ioFunc1 readFile
prim_writeFile :: State -> C_String -> C_String -> C_IO T0
prim_writeFile :: C_String -> C_String -> Result (C_IO T0)
prim_writeFile = ioFunc2 writeFile
prim_appendFile :: State -> C_String -> C_String -> C_IO T0
prim_appendFile :: C_String -> C_String -> Result (C_IO T0)
prim_appendFile = ioFunc2 appendFile
catchFail :: State -> C_IO a -> C_IO a -> C_IO a
catchFail _ act err = error "catchFail not supported yet" --catch act (const err)
catchFail :: State -> C_IO a -> C_IO a -> Result (C_IO a)
catchFail act err _ = error "catchFail not supported yet" --catch act (const err)
prim_show :: (Show a,Curry a) => State -> a -> C_String
prim_show _ = trace "show" $ toCurry . show
getSearchTree :: Curry a => State -> a -> C_IO (C_SearchTree a)
getSearchTree _ x = C_IO (\ state -> return (IOVal (searchTr state x)))
getSearchTree :: Curry a => a -> Result (C_IO (C_SearchTree a))
getSearchTree x _ = C_IO (\ state -> return (IOVal (searchTr x state)))
searchTr :: Curry a => State -> a -> (C_SearchTree a)
searchTr state x = transVal (nfCTC (nfCTC (const id)) state x)
searchTr :: Curry a => a -> Result (C_SearchTree a)
searchTr x state = transVal (nfCTC (nfCTC (\ x _ -> x)) x state)
where
transVal x = case consKind x of
Val -> C_Value x
......@@ -341,26 +341,26 @@ fromData :: Curry a => State -> C_Data -> a
fromData st _ = prim_error st (toCurry "fromData not implemented") --fromC_Term
prepApply :: (BaseCurry a,BaseCurry b) =>
State -> ((State -> b -> a) -> State -> b -> a) -> b -> (Prim (State -> b -> a)) -> a
prepApply st prep x (PrimValue f) = prep f st x
prepApply st prep x (PrimFreeVar r) = suspCTC st r (\st -> prepApply st prep x)
prepApply st prep x (PrimOr r bs) = mapOr st (\st -> prepApply st prep x) r bs
prepApply st prep x (PrimSusp r susp) = treatSusp st (\st -> prepApply st prep x) r susp
prepApply _ _ _ cont = patternFail "Prelude.prepApply" cont
((b -> Result a) -> b -> Result a) -> b -> (Prim (b -> Result a)) -> Result a
prepApply prep x (PrimValue f) st = prep f x st
prepApply prep x (PrimFreeVar r) st = suspCTC r (prepApply prep x) st
prepApply prep x (PrimOr r bs) st = mapOr (prepApply prep x) r bs st
prepApply prep x (PrimSusp r susp) st = treatSusp (prepApply prep x) r susp st
prepApply _ _ cont _ = patternFail "Prelude.prepApply" cont
--apply :: (Curry b, Curry (Prim (a -> b))) => Prim (a -> b) -> a -> b
apply st (PrimValue f) x = f st x
apply st (PrimFreeVar r) x = suspCTC st r (\ st f -> apply st f x)
apply st (PrimOr r bs) x = mapOr st (\ st f -> apply st f x) r bs
apply st (PrimSusp r susp) x = treatSusp st (\ st f -> apply st f x) r susp
apply st cont _ = patternFail "Prelude.apply" cont
apply (PrimValue f) x st = f x st
apply (PrimFreeVar r) x st = suspCTC r (\ f -> apply f x) st
apply (PrimOr r bs) x st = mapOr (\ f -> apply f x) r bs st
apply (PrimSusp r susp) x st = treatSusp (\ f -> apply f x) r susp st
apply cont _ st = patternFail "Prelude.apply" cont
cond :: Curry a => State -> C_Success -> a -> a
cond _ C_Success x = x
cond st s@(C_SuccessFreeVar _) x = narrowCTC st s (\_ _ -> x)
cond st (C_SuccessOr r bs) x = mapOr st (\ st c -> cond st c x) r bs
cond st (C_SuccessSusp r susp) x = treatSusp st (\ st c -> cond st c x) r susp
cond _ x _ = patternFail "Prelude.cond" x
cond :: Curry a => C_Success -> a -> Result a
cond C_Success x _ = x
cond s@(C_SuccessFreeVar _) x st = narrowCTC s (\_ _ -> x) st
cond (C_SuccessOr r bs) x st = mapOr (\ c -> cond c x) r bs st
cond (C_SuccessSusp r susp) x st = treatSusp (\ c -> cond c x) r susp st
cond x _ _ = patternFail "Prelude.cond" x
commit :: Curry a => State -> a -> a
......@@ -373,57 +373,57 @@ ifVar = error "ifVar not implemented"
-- to ease connecting external functions
---------------------------------------------
extFunc1 :: (Curry a,Curry d,ConvertCH a b,ConvertCH d c) => (b->c) -> a -> d
extFunc1 f x = gnf0 (\ x' -> toCurry (f (fromCurry x'))) x
extFunc1 :: (Curry a,Curry d,ConvertCH a b,ConvertCH d c) => (b->c) -> a -> Result d
extFunc1 f = gnfCTC (\ x' _ -> toCurry (f (fromCurry x')))
extFunc2 :: (Curry a, Curry c,Curry f,ConvertCH a b,ConvertCH c d,ConvertCH f e) =>
(b->d->e) -> a -> c -> f
(b->d->e) -> a -> c -> Result f
extFunc2 f x y =
gnf0 (\x'->gnf0 (\ y' -> toCurry (f (fromCurry x') (fromCurry y'))) y) x
gnfCTC (\x'->gnfCTC (\ y' _ -> toCurry (f (fromCurry x') (fromCurry y'))) y) x
extFunc3 :: (Curry c1, Curry c2, Curry c3, Curry cv,
ConvertCH c1 h1,ConvertCH c2 h2,ConvertCH c3 h3,ConvertCH cv hv) =>
(h1->h2->h3->hv) -> c1 -> c2 -> c3 -> cv
(h1->h2->h3->hv) -> c1 -> c2 -> c3 -> Result cv
extFunc3 f x y z =
gnf0 (\x'->
gnf0 (\y' ->
gnf0 (\z' -> toCurry (f (fromCurry x') (fromCurry y') (fromCurry z'))) z ) y) x
gnfCTC (\x' ->
gnfCTC (\y' ->
gnfCTC (\z' _ -> toCurry (f (fromCurry x') (fromCurry y') (fromCurry z'))) z ) y) x
extFunc4 :: (Curry c1, Curry c2, Curry c3, Curry c4, Curry cv,
ConvertCH c1 h1,ConvertCH c2 h2,ConvertCH c3 h3,ConvertCH c4 h4,ConvertCH cv hv) =>
(h1->h2->h3->h4->hv) -> c1 -> c2 -> c3 -> c4 -> cv
(h1->h2->h3->h4->hv) -> c1 -> c2 -> c3 -> c4 -> Result cv
extFunc4 f x1 x2 x3 x4 =
gnf0 (\x1'->
gnf0 (\x2' ->
gnf0 (\x3' ->
gnf0 (\x4' -> toCurry (f (fromCurry x1') (fromCurry x2') (fromCurry x3') (fromCurry x4')))
gnfCTC (\x1' ->
gnfCTC (\x2' ->
gnfCTC (\x3' ->
gnfCTC (\x4' _ -> toCurry (f (fromCurry x1') (fromCurry x2') (fromCurry x3') (fromCurry x4')))
x4) x3) x2) x1
hnf2 :: (Curry a, Curry b,Curry c) => (a->b->c) -> a -> b -> c
hnf2 f x y = hnf0 (\x'->hnf0 (\ y' -> f x' y') y) x
hnf2 :: (Curry a, Curry b,Curry c) => (a->b->c) -> a -> b -> Result c
hnf2 f x y = hnfCTC (\ x' -> hnfCTC (\ y' _ -> f x' y') y) x
ioFunc0 :: (Curry b,ConvertCH b a) => IO a -> State -> C_IO b
ioFunc0 :: (Curry b,ConvertCH b a) => IO a -> Result (C_IO b)
ioFunc0 iof _ = C_IO (\ _ -> iof >>= \hv -> return (IOVal (toCurry hv)))
ioFunc1 :: (Curry a,Curry d,ConvertCH a b,ConvertCH d c) => (b->IO c) -> Fun a (C_IO d)
ioFunc1 iof _ x = C_IO (\ _ ->
ioFunc1 :: (Curry a,Curry d,ConvertCH a b,ConvertCH d c) => (b->IO c) -> a -> Result (C_IO d)
ioFunc1 iof x _ = C_IO (\ _ ->
iof (fromCurry x) >>= \hv ->
return (IOVal (toCurry hv)))
ioFunc2 :: (Curry a, Curry c,Curry f,ConvertCH a b,ConvertCH c d,ConvertCH f e) =>
(b->d->IO e) -> State -> a -> c -> C_IO f
ioFunc2 iof _ x y = C_IO (\ _ ->
(b->d->IO e) -> a -> c -> Result (C_IO f)
ioFunc2 iof x y _ = C_IO (\ _ ->
iof (fromCurry x) (fromCurry y) >>= \hv ->
return (IOVal (toCurry hv)))
ioFunc3 iof _ x y z = C_IO (\ _ ->
ioFunc3 iof x y z _ = C_IO (\ _ ->
iof (fromCurry x) (fromCurry y) (fromCurry z) >>= \hv ->
return (IOVal (toCurry hv)))
ghnf02 :: (Curry a, Curry b,Curry c) => (a->b->c) -> a -> b -> c
ghnf02 f x y = ghnf0 (\x'-> ghnf0 (\ y' -> f x' y') y) x
ghnfCTC2 :: (Curry a, Curry b,Curry c) => (a->b->c) -> a -> b -> Result c
ghnfCTC2 f x y = ghnfCTC (\x'-> ghnfCTC (\ y' _ -> f x' y') y) x
......
......@@ -626,11 +626,11 @@ strEqSuccess = C_True
-- genFree _ = mkBranches (free ())
-- genPattern _ = mkBranches (pattern ())
instance BaseCurry b => Generate (State -> a -> b) where
instance BaseCurry b => Generate (a -> Result b) where
genFree _ = mkBranches (free ())
genPattern _ = mkBranches (pattern ())
mkBranches :: BaseCurry b => b -> [State -> a -> b]
mkBranches :: BaseCurry b => b -> [a -> Result b]
mkBranches x = case consKind x of
Val -> [const (const x)]
Branching -> map (const . const) (branches x)
......
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