[ForType "IO" Nothing ,ForType "Float" Nothing ,ForType "Char" Nothing ,ForType "[]" (Just [Show,Read,BaseCurry,Curry]) ,ForType "Nat" (Just [Show,Read]) ,ForType "Int" (Just [Show,Read]) ,ForType "Success" (Just [Show,Read,BaseCurry]) ,ForType "Bool" (Just [Declaration,BaseCurry]) ,SomeFunctions ] import Char import List import System.IO.Unsafe import Data.IORef import Prelude hiding ((==),(>>=),return,catch) import qualified Prelude ((==),(>>=),return) import System.IO #if __GLASGOW_HASKELL__ >= 610 import Control.OldException (catch) #else import Control.Exception (catch) #endif ----------------------------------------------------------------- -- curry number types ----------------------------------------------------------------- type C_Float = Prim Float ----------------------------------------------------------------- -- The curry IO monad ----------------------------------------------------------------- data C_IO t0 = C_IO (State -> IO (IOVal t0)) | C_IOFail C_Exceptions | C_IOOr OrRef (Branches (C_IO t0)) data IOVal t0 = IOVal t0 | IOValFail C_Exceptions | IOValOr OrRef (Branches (IO (IOVal t0))) data C_Bool = C_False | C_True | C_BoolFail Curry.RunTimeSystem.C_Exceptions | C_BoolOr Curry.RunTimeSystem.OrRef (Curry.RunTimeSystem.Branches C_Bool) | C_BoolAnd [C_Bool] data C_Char = C_Char !Char | SearchChar C_Four C_Four C_Four C_Four | C_CharFail C_Exceptions | C_CharOr OrRef (Branches C_Char) trace s x = unsafePerformIO (putStrLn s >> preturn x) ----------------------------------------------------------------- -- type classes to extend BaseCurry to full Curry ----------------------------------------------------------------- type StrEqResult = C_Bool class (BaseCurry a,Show a,Read a) => Curry a where -- basic equalities strEq :: a -> a -> Result StrEqResult eq :: a -> a -> Result C_Bool -- some generics propagate :: (forall b. Curry b => Int -> b -> Result b) -> a -> Result a foldCurry :: (forall c. Curry c => c -> b -> Result b) -> b -> a -> Result b -- name of the type typeName :: a -> String -- show qualified terms showQ :: Int -> a -> String -> String showQ = showsPrec showQList :: [a] -> String -> String showQList = showQStandardList -- generic programming --toC_Term :: HNFMode -> State -> a -> C_Data --fromC_Term :: C_Data -> a class Generate a where genFree :: Int -> [a] maxArity :: a -> Int ----------------------------------------------------------------- -- external Show instances ----------------------------------------------------------------- instance (Show t0) => Show (IOVal t0) where showsPrec d (IOVal x1) = showParen (d>10) showStr where showStr = showString "IOVal" . showsPrec 11 x1 showsPrec _ (IOValOr i _) = showString ('_':show (deref i)) instance Show (IO (IOVal a)) where show _ = "IO" instance Show (C_IO a) where show _ = "IO" instance Show C_Success where showsPrec _ C_Success = showString "success" showsPrec _ (C_SuccessOr ref _) = showString ('_':show (deref ref)) instance Show (a->b) where show _ = "FUNCTION" instance Show a => Show (Prim a) where show (PrimValue x) = show x show (PrimOr r _) = "_"++show (deref r) instance Show a => Show (List a) where showsPrec = showsPrecList (showsPrec 0) (showsPrec 0) showsPrecList :: (a -> ShowS) -> ([a] -> ShowS) -> Int -> List a -> ShowS showsPrecList recursiveCall listCall _ (ListOr r _) = showString ('_':show (deref r)) showsPrecList recursiveCall listCall _ xs | isFreeList xs = showChar '(' . showFreel xs | otherwise = listCall (toHaskellList xs) where isFreeList List = False isFreeList (ListOr _ _) = True isFreeList (_ :< xs) = isFreeList xs isFreeList _ = True showFreel (x: [a] -> ShowS showQStandardList xs = showChar '[' . foldr (.) (showChar ']') (intersperse (showChar ',') (map (showQ 0) xs)) fourToInt :: C_Four -> Either String Int fourToInt C_F0 = Right 0 fourToInt C_F1 = Right 1 fourToInt C_F2 = Right 2 fourToInt C_F3 = Right 3 fourToInt x@(C_FourOr _ _) = Left (show x) intToFour :: Int -> C_Four intToFour 0 = C_F0 intToFour 1 = C_F1 intToFour 2 = C_F2 intToFour 3 = C_F3 scToChar :: C_Four -> C_Four -> C_Four -> C_Four -> Either String Char scToChar f1 f2 f3 f4 = chr' ((fourToInt f1**64)+++(fourToInt f2**16)+++(fourToInt f3**4)+++fourToInt f4) where Left s ** _ = Left s Right i ** j = Right (i*j) Left s +++ _ = Left s Right i +++ Left s = Left s Right i +++ Right j = Right (i+j) chr' (Right i) = Right (chr i) chr' (Left s) = Left s charToSc :: Char -> C_Char charToSc c = SearchChar (intToFour d64) (intToFour d16) (intToFour d4) (intToFour m4) where o = ord c (d64,m64) = divMod o 64 (d16,m16) = divMod m64 16 (d4,m4) = divMod m16 4 instance Show C_Four where showsPrec d (C_FourOr r _) = showChar '_' . showsPrec d (deref r) showsPrec _ _ = error "probably due to usage of ($#) instead of ($##) \ \for an external function with argument type string or character" instance Show C_Char where show (C_Char c) = show c show (SearchChar f1 f2 f3 f4) = either id show (scToChar f1 f2 f3 f4) show (C_CharOr r _) = '_':show (deref r) showList cs = if any isFreeChar cs then showChar '[' . showFreel cs else showChar '"' . showl cs -- " where showl [] = showChar '"' showl (C_Char '"':cs) = showString "\\\"" . showl cs showl (C_Char c:cs) | oc <= 7 = showString "\\00" . shows oc . showl cs | oc <= 10 = showLitChar c . showl cs | oc <= 12 = showString "\\0" . shows oc . showl cs | oc <= 13 = showLitChar c . showl cs | oc <= 31 = showString "\\0" . shows oc . showl cs | oc <= 126 = showLitChar c . showl cs | otherwise = showString "\\" . shows oc . showl cs where oc = ord c showl (SearchChar f1 f2 f3 f4:cs) = either showString showLitChar (scToChar f1 f2 f3 f4) . showl cs showFreel [] = showString "]" showFreel [c] = showString (show c) . showString "]" showFreel (c:cs) = showString (show c++",") . showFreel cs isFreeChar (SearchChar f1 f2 f3 f4) = Prelude.any ((Prelude.== Branching) . consKind) [f1,f2,f3,f4] isFreeChar _ = False protectEsc p f = f . cont where cont s@(c:_) | p c = "\\&" ++ s cont s = s asciiTab = zip ['\NUL'..' '] ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", "SP"] instance Show C_Nat where showsPrec d x | isFreeNat x = showsPrecNat d x | otherwise = showsPrec d (fromCurry x::Integer) isFreeNat :: C_Nat -> Bool isFreeNat (C_NatOr _ _) = True isFreeNat C_IHi = False isFreeNat (C_I n) = isFreeNat n isFreeNat (C_O n) = isFreeNat n showsPrecNat :: Int -> C_Nat -> ShowS showsPrecNat _ C_IHi = Prelude.showString((:)('I')((:)('H')((:)('i')([])))) showsPrecNat d (C_O x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr) where showStr = (Prelude..)(Prelude.showString((:)('O')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1)) showsPrecNat d (C_I x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr) where showStr = (Prelude..)(Prelude.showString((:)('I')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1)) showsPrecNat _ (C_NatOr i _) = Prelude.showString((:)('_')(Prelude.show(deref i))) instance Show C_Int where showsPrec _ C_Zero = showChar '0' showsPrec d x@(C_Pos n) | isFreeNat n = showParen (d>10) (showString "Pos " . showsPrecNat 11 n) | otherwise = showsPrec d (fromCurry x::Integer) showsPrec d x@(C_Neg n) | isFreeNat n = showParen (d>10) (showString "Neg " . showsPrecNat 11 n) | otherwise = showsPrec d (fromCurry x::Integer) showsPrec _ (C_IntOr i _) = showChar '_' . shows (deref i) ----------------------------------------------------------------- -- external Read instances ----------------------------------------------------------------- instance Read C_Four where readsPrec _ _ = error "I won't read four" instance (Read t0) => Read (IOVal t0) where readsPrec d r = readParen (d>10) (\ r -> [ (IOVal x1,r1) | (_,r0) <- readQualified "Prelude" "IOVal" r, (x1,r1) <- readsPrec 11 r0]) r instance Read (IO (IOVal a)) where readsPrec = error "no reading IO" instance Read (C_IO a) where readsPrec = error "no reading IO" instance Read C_Success where readsPrec d r = Prelude.readParen(Prelude.False) (\ r -> [(,)(C_Success)(r0) | (_,r0) <- readQualified "Prelude" "Success" r])(r) instance Read a => Read (Prim a) where readsPrec p s = map (\(x,y) -> (PrimValue x,y)) (readsPrec p s) instance Read a => Read (List a) where readsPrec p = map (\ (x,y) -> (fromHaskellList x,y)) . readsPrec p instance Read C_Char where readsPrec p s = map (\ (x,y) -> (toCurry x,y)) (((readsPrec p)::ReadS Char) s) readList s = map (\ (x,y) -> (map toCurry x,y)) ((readList::ReadS String) s) instance Read (a->b) where readsPrec = error "reading FUNCTION" instance Read C_Nat where readsPrec d r = readParen False (\ r -> [(C_IHi,r0) | (_ ,r0) <- readQualified "Prelude" "IHi" r]) r ++ readParen (d>10) (\ r -> [(C_O x1,r1) | (_ ,r0) <- readQualified "Prelude" "O" r, (x1,r1) <- readsPrec 11 r0]) r ++ readParen (d>10) (\ r -> [(C_I x1,r1) | (_ ,r0) <- readQualified "Prelude" "I" r, (x1,r1) <- readsPrec 11 r0]) r ++ [(toCurry i,r0) | (i::Integer,r0) <- reads r] instance Read C_Int where readsPrec d r = readParen (d>10) (\ r -> [(C_Neg x1,r1) | (_ ,r0) <- readQualified "Prelude" "Neg" r, (x1,r1) <- readsPrec 11 r0]) r ++ readParen False (\ r -> [(C_Zero,r0) | (_ ,r0) <- readQualified "Prelude" "Zero" r]) r ++ readParen (d>10) (\ r -> [(C_Pos x1,r1) | (_ ,r0) <- readQualified "Prelude" "Pos" r, (x1,r1) <- readsPrec 11 r0]) r ++ [(toCurry i,r0) | (i::Integer,r0) <- reads r] ----------------------------------------------------------------- -- external BaseCurry instances ----------------------------------------------------------------- instance (BaseCurry t0) => BaseCurry (IOVal t0) where nf f (IOVal x1) state0 = nfCTC(\ v1 state1 -> f(IOVal(v1)) (state1))(x1) (state0) nf f x state = f(x) (state) gnf f (IOVal x1) state0 = gnfCTC(\ v1 state1 -> f(IOVal(v1)) (state1))(x1) (state0) gnf f x state = f(x) (state) generator i = IOVal (generator i) failed = IOValFail branching r bs = IOValOr r (map preturn bs) consKind (IOValOr _ _) = Branching consKind (IOValFail _) = Failed consKind _ = Val exceptions (IOValFail x) = x orRef (IOValOr x _) = x branches (IOValOr _ bs) = map unsafePerformIO bs instance (BaseCurry t0) => BaseCurry (IO (IOVal t0)) where nf f x state = f(x) (state) gnf f x state = f(x)(state) failed x = preturn (IOValFail x) generator u = preturn (generator u) branching r bs = preturn (IOValOr r bs) consKind x = consKind (unsafePerformIO x) exceptions x = exceptions (unsafePerformIO x) orRef x = orRef (unsafePerformIO x) branches x = unsafePerformIO (x Prelude.>>= \ (IOValOr _ bs) -> preturn bs) instance (BaseCurry t0) => BaseCurry (C_IO t0) where nf f x state = f(x)(state) gnf f x state = f(x)(state) generator i = C_IO (\ _ -> generator i) failed = C_IOFail branching = C_IOOr consKind (C_IOOr _ _) = Branching consKind (C_IOFail _) = Failed consKind _ = Val exceptions (C_IOFail x) = x orRef (C_IOOr x _) = x branches (C_IOOr _ x) = x instance BaseCurry C_Char where nf f (SearchChar x1 x2 x3 x4) state0 = Curry.RunTimeSystem.nfCTC(\ v1 state1 -> Curry.RunTimeSystem.nfCTC(\ v2 state2 -> Curry.RunTimeSystem.nfCTC(\ v3 state3 -> Curry.RunTimeSystem.nfCTC(\ v4 state4 -> f(SearchChar(v1)(v2)(v3)(v4))(state4))(x4)(state3))(x3)(state2))(x2)(state1))(x1)(state0) nf f x store = f(x)(store) gnf f (SearchChar x1 x2 x3 x4) state0 = Curry.RunTimeSystem.gnfCTC(\ v1 state1 -> Curry.RunTimeSystem.gnfCTC(\ v2 state2 -> Curry.RunTimeSystem.gnfCTC(\ v3 state3 -> Curry.RunTimeSystem.gnfCTC(\ v4 state4 -> f(SearchChar(v1)(v2)(v3)(v4))(state4))(x4)(state3))(x3)(state2))(x2)(state1))(x1)(state0) gnf f x store = f(x)(store) consKind (C_CharOr _ _) = Branching consKind (C_CharFail _) = Failed consKind _ = Val generator i = withRef ( \r -> SearchChar (generator r) (generator (r+1)) (generator (r+2)) (generator (r+3))) 3 orRef (C_CharOr x _) = x branches (C_CharOr _ x) = x failed = C_CharFail exceptions (C_CharFail x) = x branching = C_CharOr instance Generate a => BaseCurry (Prim a) where nf f x store = f(x)(store) gnf f x store = f(x)(store) generator i = gen genFree where gen f = let max = maxArity (head (f 0)) in withRef (\r -> PrimOr (mkRef r max i) (map PrimValue (f r))) max failed = PrimFail branching = PrimOr consKind (PrimOr _ _) = Branching consKind (PrimFail _) = Failed consKind _ = Val exceptions (PrimFail x) = x orRef (PrimOr x _) = x branches (PrimOr _ x) = x instance (BaseCurry t0) => BaseCurry (List t0) where nf f ((:<) x1 x2) state0 = Curry.RunTimeSystem.nfCTC(\ v1 state1 -> Curry.RunTimeSystem.nfCTC(\ v2 state2 -> f((:<)(v1)(v2))(state2))(x2)(state1))(x1)(state0) nf f x st = f(x)(st) gnf f ((:<) x1 x2) state0 = Curry.RunTimeSystem.gnfCTC(\ v1 state1 -> Curry.RunTimeSystem.gnfCTC(\ v2 state2 -> f((:<)(v1)(v2))(state2))(x2)(state1))(x1)(state0) gnf f x st = f(x)(st) generator i = withRef (\ r -> ListOr (mkRef r 2 i) ([List,(:<)(generator(r+1))(generator(r+2))])) 2 failed = ListFail branching = ListOr consKind (ListOr _ _) = Curry.RunTimeSystem.Branching consKind (ListFail _) = Curry.RunTimeSystem.Failed consKind _ = Curry.RunTimeSystem.Val exceptions (ListFail x) = x orRef (ListOr x _) = x branches (ListOr _ x) = x ----------------------------------------------------------------- -- converting between curry and haskell ----------------------------------------------------------------- -- In Order to integrate Haskell functions we sometimes -- need to convert values. -- (Do we really need both directions? Or rather convert a b for both?) class ConvertCH a b where fromCurry :: a -> b fromCurry = error "fromCurry" toCurry :: b -> a toCurry = error "toCurry" instance ConvertCH C_Bool Bool where fromCurry C_True = True fromCurry C_False = False toCurry True = C_True toCurry False = C_False isC_True C_True = True isC_True _ = False instance ConvertCH C_Char Char where fromCurry (C_Char c) = c fromCurry (SearchChar f0 f1 f2 f3) = either (error "convert to char") id (scToChar f0 f1 f2 f3) toCurry c = C_Char c instance (ConvertCH a b) => ConvertCH (List a) [b] where fromCurry List = [] fromCurry (x :< xs) = fromCurry x : fromCurry xs fromCurry (ListOr _ _) = error "or list" toCurry [] = List toCurry (x:xs) = toCurry x :< toCurry xs -- sometimes you need conversion of lists without converting the elements -- eg Searchtree, Show instance toHaskellList :: List a -> [a] toHaskellList List = [] toHaskellList (x :< xs) = x : toHaskellList xs fromHaskellList :: [a] -> List a fromHaskellList [] = List fromHaskellList (x : xs) = x :< fromHaskellList xs -- specify result type of toCurry "..." for code generation fromHaskellString :: String -> List C_Char fromHaskellString = toCurry instance ConvertCH C_Int Integer where fromCurry C_Zero = 0 fromCurry (C_Pos i) = fromCurry i fromCurry (C_Neg i) = negate (fromCurry i) toCurry n = case compare n 0 of LT -> C_Neg (toCurry (abs n)) EQ -> C_Zero GT -> C_Pos (toCurry (abs n)) instance ConvertCH C_Nat Integer where fromCurry (C_I bs) = 2 Prelude.* fromCurry bs Prelude.+ 1 fromCurry (C_O bs) = 2 Prelude.* fromCurry bs fromCurry C_IHi = 1 toCurry n = case mod n 2 of 1 -> if m Prelude.== 0 then C_IHi else C_I (toCurry m) 0 -> C_O (toCurry m) where m = Prelude.div n 2 instance ConvertCH C_Int Int where fromCurry c = fromInteger (fromCurry c) toCurry i = toCurry (toInteger i) instance ConvertCH (Prim a) a where toCurry = PrimValue fromCurry (PrimValue x) = x ------------------------------------------------------------- -- basic functions used in instances of class GenericCurry ------------------------------------------------------------- -- obscure names come from the standard operator -- renaming scheme of the compiler. -- implementation of concurrent (&) -- no other implementation -- basic concept: if one value suspends evaluate the other -- TODO: include state information! concAnd :: StrEqResult -> StrEqResult -> Result StrEqResult concAnd C_True y _ = y concAnd x@(C_BoolOr _ _) y st = maySwitch y x st --concAnd (C_BoolOr r xs) y = C_BoolOr r (map (flip concAnd y) xs) concAnd x@(C_BoolFail _) _ _ = x concAnd x@C_False _ _ = x maySwitch :: StrEqResult -> StrEqResult -> Result StrEqResult maySwitch C_True x _ = x maySwitch y@(C_BoolOr _ _) (C_BoolOr r xs) st = C_BoolOr r (map (\ x -> concAnd y x st) xs) maySwitch x@(C_BoolFail _) _ _ = x maySwitch x@C_False _ _ = x {- startBreadth :: [StrEqResult] -> Result StrEqResult startBreadth cs st = onLists st [] cs instance Eq C_Bool where C_True == C_True = True C_False == C_False = True _ == _ = False allSame :: Eq a => [a] -> Bool allSame [] = True allSame (x:xs) = all (x==) xs onLists :: Store -> [StrEqResult] -> [StrEqResult] -> StrEqResult onLists _ [] [] = strEqSuccess onLists _ _ (x@(C_BoolFail _):_) = x onLists _ _ (C_False:_) = C_False onLists st ors (C_True:xs) = onLists st ors xs onLists st ors (C_BoolAnd xs:ys) = onLists st ors (xs++ys) onLists st ors (C_BoolOr ref xs:ys) | isChain ref = chain (\ x st -> onLists st ors (x:ys)) ref xs st | otherwise = case fromStore ref st of Nothing -> onLists st (insertOr ref xs ors) ys Just i -> onLists st ors (xs!!i : ys) onLists st (C_BoolOr ref xs:ors) [] = let inBranch i x = maybe (failed $ curryError "onLists") (\st -> onLists st ors [x]) (addToStore ref i st) in C_BoolOr ref (zipWith inBranch [0..] xs) insertOr ref xs [] = [C_BoolOr ref xs] insertOr ref xs (o@(C_BoolOr ref2 xs2):ys) | ref==ref2 = C_BoolOr ref (zipWith insertAnd xs xs2) : ys | otherwise = o : insertOr ref xs ys insertAnd C_True y = y insertAnd C_False _ = C_False insertAnd x@(C_BoolFail _) _ = x insertAnd x C_True = x insertAnd _ C_False = C_False insertAnd _ x@(C_BoolFail _) = x insertAnd o1@(C_BoolOr ref1 xs1) o2@(C_BoolOr ref2 xs2) | ref1 == ref2 = C_BoolOr ref1 (zipWith insertAnd xs1 xs2) | otherwise = C_BoolAnd [o1,o2] insertAnd o@(C_BoolOr _ _) (C_BoolAnd ys) = C_BoolAnd (o:ys) insertAnd (C_BoolAnd ys) o@(C_BoolOr _ _) = C_BoolAnd (o:ys) insertAnd (C_BoolAnd xs) (C_BoolAnd ys) = C_BoolAnd (xs++ys) -} --- implementation of (==) --- no other implementation genEq :: Curry t0 => t0 -> t0 -> Result C_Bool genEq x y = ghnfCTC (\x'-> ghnfCTC (eq x') y) x --- implementation of (=:=) --- no other implementation --- TODO: use state information genStrEq :: Curry t0 => t0 -> t0 -> Result StrEqResult genStrEq a b = (\ a' -> (onceMore a') `hnfCTC` b) `hnfCTC` a where onceMore a' b' = (\ a'' -> unify a'' b') `hnfCTC` a' unify x y st = checkFree (consKind x) (consKind y) where checkFree Val Val = strEq x y st checkFree Branching Branching | drx Prelude.== dry = C_True | otherwise = branching (equalFromTo ax bx drx ay by dry) [C_True] where (ax,bx,drx)=genInfo (orRef x) (ay,by,dry)=genInfo (orRef y) checkFree Branching _ = hnfCTC (\ x' -> unify x' y) (branching (narrowOrRef (orRef x)) (branches x)) st checkFree _ Branching = hnfCTC (unify x) (branching (narrowOrRef (orRef y)) (branches y)) st checkFree x y = error $ "checkFree " ++ show (x,y) strEqFail :: String -> StrEqResult strEqFail s = C_False --C_SuccessFail (ErrorCall ("(=:=) for type "++s)) strEqSuccess :: StrEqResult strEqSuccess = C_True --hcAppend [] ys = ys --hcAppend (x:xs) ys = x:< hcAppend xs ys ----------------------------------------------------------------- -- external Generate instances ----------------------------------------------------------------- instance BaseCurry b => Generate (a -> Result b) where genFree i = mkBranches (generator i) maxArity _ = 1 mkBranches :: BaseCurry b => b -> [a -> Result b] mkBranches x = case consKind x of Val -> [const (const x)] Branching -> map (const . const) (branches x) instance Generate Float where genFree = error "free variable of type Float" maxArity _ = error "free variable of type Float" ----------------------------------------------------------------- -- external Curry instances ----------------------------------------------------------------- instance (Curry t0) => Curry (List t0) where strEq List List st = strEqSuccess strEq ((:<) x1 x2) ((:<) y1 y2) st = concAnd(genStrEq(x1)(y1)(st))(genStrEq(x2)(y2)(st))(st) strEq _ x0 _ = strEqFail(typeName(x0)) eq List List st = C_True eq ((:<) x1 x2) ((:<) y1 y2) st = op_38_38(genEq(x1)(y1)(st))(genEq(x2)(y2)(st))(st) eq _ _ _ = C_False propagate f List st = List propagate f ((:<) x1 x2) st = (:<)(f 0 (x1)(st))(f 1 (x2)(st)) foldCurry f c List st = c foldCurry f c ((:<) x1 x2) st = f(x1)(f(x2)(c)(st))(st) typeName _ = "[]" showQ = showsPrecList (showQ 0) showQList instance Curry C_Four where strEq C_F0 C_F0 _ = strEqSuccess strEq C_F1 C_F1 _ = strEqSuccess strEq C_F2 C_F2 _ = strEqSuccess strEq C_F3 C_F3 _ = strEqSuccess strEq x0 _ _ = strEqFail(typeName(x0)) eq C_F0 C_F0 _ = C_True eq C_F1 C_F1 _ = C_True eq C_F2 C_F2 _ = C_True eq C_F3 C_F3 _ = C_True eq _ _ _ = C_False propagate _ C_F0 _ = C_F0 propagate _ C_F1 _ = C_F1 propagate _ C_F2 _ = C_F2 propagate _ C_F3 _ = C_F3 foldCurry _ c C_F0 _ = c foldCurry _ c C_F1 _ = c foldCurry _ c C_F2 _ = c foldCurry _ c C_F3 _ = c typeName _ = "Four" instance BaseCurry a => Curry (IO (IOVal a)) where strEq x y = error "IO.strEq" eq _ _ = error "IO.eq" propagate _ _ = error "propagate IOVal" foldCurry _ _ _ = error "foldCurry IOVal" typeName _ = "IOVal" --toC_Term _ _ _ = error "IO.toC_Term" --fromC_Term _ = error "IO.fromC_Term" instance BaseCurry a => Curry (C_IO a) where strEq _ _ = error "strEq IO" eq _ _ = error "eq IO" --subst store x = x propagate _ _ = error "propagate IO" foldCurry _ _ _ = error "foldCurry IO" typeName _ = "IO" --toC_Term _ _ (C_IOFreeVar r) = C_Free(C_Int(Prelude.toInteger(r))) --toC_Term _ _ _ = C_Data (C_Int 1) (toCurry "IO") List --fromC_Term (C_Free (C_Int r)) = C_IOFreeVar(Prelude.fromInteger(r)) --fromC_Term _ = error "no converting IO" instance Curry C_Char where strEq x@(C_Char c1) (C_Char c2) _ | c1 Prelude.== c2 = C_True strEq c1@(SearchChar _ _ _ _) (C_Char c2) st = strEq c1 (charToSc c2) st strEq (C_Char c1) c2@(SearchChar _ _ _ _) st = strEq (charToSc c1) c2 st strEq (SearchChar x1 x2 x3 x4) (SearchChar y1 y2 y3 y4) st = concAnd (genEq(x1)(y1)st)(concAnd(genStrEq(x2)(y2)st)(concAnd(genStrEq(x3)(y3)st)(genStrEq(x4)(y4)st)st)st)st strEq _ x _ = strEqFail (typeName x) eq (C_Char x1) (C_Char y1) _ = toCurry (x1 Prelude.== y1) eq c1@(SearchChar _ _ _ _) (C_Char c2) st = eq c1 (charToSc c2) st eq (C_Char c1) c2@(SearchChar _ _ _ _) st = eq (charToSc c1) c2 st eq (SearchChar x1 x2 x3 x4) (SearchChar y1 y2 y3 y4) st = op_38_38 (genEq (x1)(y1)st) (op_38_38 (genEq(x2)(y2)st) (op_38_38(genEq(x3)(y3)st)(genEq(x4)(y4)st)st)st)st eq _ _ _ = C_False propagate _ c@(C_Char _) _ = c propagate f (SearchChar f0 f1 f2 f3) st = SearchChar (f 0 f0 st) (f 1 f1 st) (f 2 f2 st) (f 3 f3 st) foldCurry _ c (C_Char _) _ = c foldCurry f c (SearchChar f0 f1 f2 f3) st = f f0 (f f1 (f f2 (f f3 c st)st)st)st typeName _ = "Char" showQList = showList --toC_Term _ _ (C_Char c) = C_Data (C_Int (toInteger (ord c))) (toCurry (show c)) List --toC_Term _ _ (C_CharFreeVar r) = C_Free(C_Int(Prelude.toInteger(r))) --fromC_Term (C_Data (C_Int (i::Integer)) _ List) = C_Char (chr (fromInteger i)) --fromC_Term (C_Data (C_IntFreeVar _) name List) = C_Char (read (fromCurry name)) --fromC_Term (C_Free (C_Int r)) = C_CharFreeVar(Prelude.fromInteger(r)) instance (Generate a,Show a,Read a,Eq a) => Curry (Prim a) where strEq x@(PrimValue v1) (PrimValue v2) _ | v1 Prelude.== v2 = C_True --C_Success | otherwise = strEqFail (typeName x) eq (PrimValue v1) (PrimValue v2) _ = toCurry (v1 Prelude.== v2) propagate _ (PrimValue v1) _ = PrimValue v1 foldCurry _ c (PrimValue _) _ = c --toC_Term _ _ (PrimValue x1) = let sx = show x1 in -- C_Data (C_Int (string2int sx)) (toCurry sx) List --toC_Term _ _ (PrimFreeVar r) = C_Free(C_Int(Prelude.toInteger(r))) --fromC_Term (C_Data _ name List) = PrimValue (read (fromCurry name)) --fromC_Term (C_Free (C_Int r)) = PrimFreeVar(Prelude.fromInteger(r)) typeName _ = "Prim" ----------------------------------------------------------------- -- external Curry instances ----------------------------------------------------------------- instance Eq (a->b) where (==) = error "comparing FUNCTION" infix 4 === infixr 0 & ----------------------------------------------------------------------- -- IO starter ----------------------------------------------------------------------- preturn = Prelude.return optChangeStore :: a -> (b -> Store -> a) -> ((Int -> Store) -> a) -> OrRef -> Branches b -> Store -> a optChangeStore err det br = manipulateStore err det (\ _ -> br) (\ _ -> det) curryIO :: Curry a => (Result (C_IO a)) -> IO a curryIO x = let st = emptyStore in ioStart st (x st) curryIOVoid :: Curry a => (Result (C_IO a)) -> IO () curryIOVoid x = curryIO x >> Prelude.return () ioStart :: Curry a => Store -> C_IO a -> IO a ioStart st (C_IO act) = act st Prelude.>>= curryDo st ioStart _ (C_IOFail es) = printExceptions es ioStart st (C_IOOr ref bs) = optChangeStore (printExceptions (curryError "ioStart")) (flip ioStart) (\st -> searchValC_IO [] (zipWith (mkChoice st) [0..] bs)) ref bs st curryDo :: Curry a => Store -> IOVal a -> IO a curryDo _ (IOVal x) = Prelude.return x curryDo _ (IOValFail es) = printExceptions es curryDo st (IOValOr ref bs) = optChangeStore (printExceptions (curryError "curryDo")) (\ x st -> x Prelude.>>= curryDo st) (\st -> searchIOVal [] (zipWith (mkChoice st) [0..] bs)) ref bs st mkChoice :: BaseCurry a => (Int -> Store) -> Int -> a -> (Store,a) mkChoice st i x = (st i,x) searchValC_IO :: Curry a => [C_Exceptions] -> [(Store,C_IO a)] -> IO a searchValC_IO es [] = mapM_ printException es >> error "no solution in branching io value" searchValC_IO _ ((st,C_IO act) : _) = act st Prelude.>>= curryDo st searchValC_IO es ((_ ,C_IOFail e@(ErrorCall _)) : xs) = searchValC_IO (e:es) xs searchValC_IO es ((_ ,C_IOFail e) : xs) = searchValC_IO es xs searchValC_IO es ((st,C_IOOr ref bs) : xs) = optChangeStore (searchValC_IO es xs) (\ x st -> case x of C_IO act -> act st Prelude.>>= curryDo st C_IOOr _ _ -> searchValC_IO es ((st,x):xs) C_IOFail _ -> searchValC_IO es xs) -- switch arguments of (++) for breadth first (bad.), cf. also below (\ st -> searchValC_IO es (zipWith (mkChoice st) [0..] bs ++ xs)) ref bs st searchIOVal :: Curry a => [C_Exceptions] -> [(Store,IO (IOVal a))] -> IO a searchIOVal es [] = mapM_ printException es >> error "no solution in branching io value" searchIOVal es ((st,act) : stacts) = do x <- act case x of IOVal a -> Prelude.return a IOValFail e@(ErrorCall _) -> searchIOVal (e:es) stacts IOValFail _ -> searchIOVal es stacts -- switch arguments of (++) for breadth first (bad.) IOValOr ref bs -> optChangeStore (searchIOVal (curryError "inconsistent Store":es) stacts) (\ x st -> searchIOVal es ((st,x):stacts)) (\st -> searchIOVal es (zipWith (mkChoice st) [0..] bs ++ stacts)) ref bs st -- this is the place to change for implicit breadth first search searchVal :: (Store -> a -> b) -> Store -> OrRef -> Branches a -> b searchVal cont store ref [] = error "top io failed" searchVal cont store ref (x:bs) = cont store x printException :: C_Exceptions -> IO () printException (PatternMatchFail s) = hPutStrLn stderr ("non-exhaustive patterns in function "++s) printException (AssertionFailed s) = hPutStrLn stderr ("assertion failed with label "++s) printException (IOException s) = hPutStrLn stderr ("io exception: " ++ s) printException (ErrorCall s) = hPutStrLn stderr ("error : " ++s) printException PreludeFailed = hPutStrLn stderr "Prelude.failed" printExceptions :: C_Exceptions -> IO a printExceptions e = printException e >> error "program error" ----------------------------------------------------------------------- -- Int and Float ----------------------------------------------------------------------- instance Eq C_Int where x == y = (fromCurry x::Integer) Prelude.== fromCurry y instance Num C_Int where fromInteger x = toCurry x x + y = toCurry ((fromCurry x::Integer) + fromCurry y) x * y = toCurry ((fromCurry x::Integer) * fromCurry y) abs (C_Neg x) = C_Pos x abs x = x signum (C_Pos _) = C_Pos C_IHi signum (C_Neg _) = C_Neg C_IHi signum x = x instance Eq a => Eq (Prim a) where (PrimValue x) == (PrimValue y) = x Prelude.== y instance (Num a) => Num (Prim a) where (PrimValue x) + (PrimValue y) = PrimValue (x+y) (PrimValue x) - (PrimValue y) = PrimValue (x-y) (PrimValue x) * (PrimValue y) = PrimValue (x*y) negate (PrimValue x) = PrimValue (negate x) abs (PrimValue x) = PrimValue (abs x) signum (PrimValue x) = PrimValue (signum x) fromInteger x = PrimValue (fromInteger x) instance Enum a => Enum (Prim a) where toEnum i = PrimValue (toEnum i) fromEnum (PrimValue x) = fromEnum x instance Real a => Real (Prim a) where toRational (PrimValue x) = toRational x instance Integral a => Integral (Prim a) where quotRem (PrimValue x) (PrimValue y) = let (x',y') = quotRem x y in (PrimValue x', PrimValue y') toInteger (PrimValue x) = toInteger x instance Ord a => Ord (Prim a) where (PrimValue x) <= (PrimValue y) = x<=y ----------------------------------------------------------------------- -- T0 is unit (), needed for IO primitives ----------------------------------------------------------------------- instance ConvertCH T0 () where toCurry () = T0 fromCurry T0 = () instance (ConvertCH a ha, ConvertCH b hb) => ConvertCH (T2 a b) (ha,hb) where toCurry (x,y) = T2 (toCurry x) (toCurry y) fromCurry (T2 x y) = (fromCurry x, fromCurry y) instance (ConvertCH a ha, ConvertCH b hb, ConvertCH c hc) => ConvertCH (T3 a b c) (ha,hb,hc) where toCurry (x,y,z) = T3 (toCurry x) (toCurry y) (toCurry z) fromCurry (T3 x y z) = (fromCurry x, fromCurry y, fromCurry z) ----------------------------------------------------------------------- -- Maybe ----------------------------------------------------------------------- instance (ConvertCH a b) => ConvertCH (C_Maybe a) (Maybe b) where fromCurry C_Nothing = Nothing fromCurry (C_Just x) = Just (fromCurry x) toCurry Nothing = C_Nothing toCurry (Just x) = C_Just (toCurry x) --------------------------------------------------------------------------------- -- external functions for Prelude --------------------------------------------------------------------------------- ($#) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b ($#) cont x = prepApply ghnfCTC x cont ($!) :: (Curry a,Curry b) => Prim (a -> Result b) -> a -> Result b ($!) cont x = prepApply hnfCTC x cont ($!!) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b ($!!) cont x = prepApply nfCTC x cont ($##) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b ($##) cont x = prepApply gnfCTC x cont prim_error :: Curry a => C_String -> Result a prim_error s _ = Curry.RunTimeSystem.failed (ErrorCall (fromCurry s)) failed :: Curry a => Result a failed _ = Curry.RunTimeSystem.failed PreludeFailed (==) :: Curry a => a -> a -> Result C_Bool (==) = genEq prim_ord :: C_Char -> Result C_Int prim_ord cc _ = toCurry (ord (fromCurry cc)) prim_chr :: C_Int -> Result C_Char prim_chr ci _ = toCurry (chr (fromCurry ci)) (===) :: Curry a => a -> a -> Result C_Bool --C_Success (===) = genStrEq success :: C_Success success = C_Success --concAnd' x y st = startBreadth [x,y] st (&) :: C_Success -> C_Success -> Result C_Success -- (&) x y st = boolToSuccess (concAnd' (successToBool x) (successToBool y) st) (&) x y st = boolToSuccess (concAnd (successToBool x st) (successToBool y st) st) st boolToSuccess C_True _ = C_Success boolToSuccess C_False _ = C_SuccessFail (ErrorCall "&") boolToSuccess (C_BoolFail e) _ = C_SuccessFail e boolToSuccess (C_BoolOr r xs) st = mapOr boolToSuccess r xs st successToBool :: C_Success -> Result C_Bool successToBool C_Success _ = C_True successToBool (C_SuccessFail e) _ = C_BoolFail e successToBool (C_SuccessOr r xs) st = mapOr successToBool r xs st --andBreadth :: List C_Bool -> Result C_Bool --andBreadth xs st = startBreadth (toHaskellList xs) st -- TODO: C_IO without State??? also other io-functions. (>>=) :: (Curry a,Curry b) => C_IO a -> Prim (a -> Result (C_IO b)) -> Result (C_IO b) (>>=) m f _ = C_IO (hnfCTC (exec f) m) 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 Prelude.>>= \ x -> prim_do f x st -- if it wasn't io, we could just write --exec f st (C_IO m) = m st Prelude.>>= hnfCTC (fromIOVal f) st -- with fromIOVal simply being --fromIOVal::(Curry a,Curry b)=>Prim(a->C_IO b)->State->IOVal a->IO(IOVal b) --fromIOVal f st (IOVal res) = hnfCTC exec2 st (apply f res) -- and everything would work fine. But then for the susp and or cases -- we would use unsafe io... -- Thus, prim_do has to copy the code of ctcStore False -- IMPORTANT: This code should correspond to BaseCurry.RunTimeSystem.ctcStore prim_do :: (Curry a,Curry b) => 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 -> Prelude.return (IOValFail es) IOValOr ref bs -> optChangeStore (Curry.RunTimeSystem.failed $ curryError "prim_do") (\ x st -> x Prelude.>>= \ x' -> prim_do f x' st) (\ st -> Prelude.return (IOValOr ref (zipWith (\ i x -> x Prelude.>>= \ x' -> cont x' (st i)) [0..] bs))) ref bs state where cont x st = prim_do f x st exec2 :: C_IO b -> Result (IO (IOVal b)) exec2 (C_IO f) = f return :: a -> Result (C_IO a) return a _ = C_IO (\ _ -> Prelude.return (IOVal a)) prim_putChar :: C_Char -> Result (C_IO T0) prim_putChar = ioFunc1 putChar getChar :: Result (C_IO C_Char) getChar = ioFunc0 Prelude.getChar prim_readFile :: C_String -> Result (C_IO C_String) prim_readFile = ioFunc1 readFile prim_writeFile :: C_String -> C_String -> Result (C_IO T0) prim_writeFile = ioFunc2 writeFile prim_appendFile :: C_String -> C_String -> Result (C_IO T0) prim_appendFile = ioFunc2 appendFile catchFail :: Curry a => C_IO a -> C_IO a -> Result (C_IO a) catchFail (C_IO act) err _ = C_IO (\ st -> catch (act st) (const (hnfCTC exec2 err st))) catchFail (C_IOFail _) err _ = err catchFail (C_IOOr ref bs) err st = optChangeStore err (flip catchFail err) (\st -> searchValCatch (zipWith (mkChoice st) [0..] bs) err) ref bs st searchValCatch :: Curry a => [(Store,C_IO a)] -> C_IO a -> C_IO a searchValCatch [] err = err searchValCatch ((st,C_IO act) : _) err = catchFail (C_IO act) err st searchValCatch ((_ ,C_IOFail _) : xs) err = searchValCatch xs err searchValCatch ((st,C_IOOr ref bs) : xs) err = optChangeStore (searchValCatch xs err) (\ x st -> catchFail x err st) (\ st -> searchValCatch (zipWith (mkChoice st) [0..] bs ++ xs) err) ref bs st prim_show :: (Show a,Curry a) => a -> Result C_String prim_show x _ = toCurry (show x) getSearchTree :: Curry a => a -> Result (C_IO (C_SearchTree a)) getSearchTree x _ = C_IO (\ state -> Prelude.return (IOVal (searchTr x state))) searchTr :: Curry a => a -> Result (C_SearchTree a) searchTr x state = transVal (nfCTC (nfCTC const) x state) where transVal x = case consKind x of Val -> C_Value x Failed -> C_Fail Branching | isGenerator (orRef x) -> C_Value x | otherwise -> transBranching (branches x) transBranching [] = C_Fail transBranching [x] = transVal x transBranching xs@(_:_:_) = C_Choice (fromHaskellList (map transVal xs)) {- toData :: Curry a => a -> Result C_Data toData _ st = prim_error (toCurry "toData not implemented") st --ctcStore True (toC_Term True) Nothing toNumData :: Curry a => a -> Result C_NumData toNumData _ st = prim_error (toCurry "toNumData not implemented") st --ctcStore True (\ store x -> (conv2num (toC_Term True store x))) Nothing cmap _ List = List cmap f (x :< xs) = f x :< cmap f xs fromData :: Curry a => C_Data -> Result a fromData _ st = prim_error (toCurry "fromData not implemented") st --fromC_Term -} prepApply :: (BaseCurry a,BaseCurry b) => ((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 (PrimOr r bs) st = mapOr (prepApply prep x) r bs st prepApply _ _ cont _ = patternFail "Prelude.prepApply" cont --apply :: (Curry b, Curry (Prim (a -> b))) => Prim (a -> b) -> a -> b apply (PrimValue f) x st = f x st apply (PrimOr r bs) x st = mapOr (\ f -> apply f x) r bs st apply cont _ st = patternFail "Prelude.apply" cont -- these functions are employed for higher order pf :: Curry b => (a -> Result b) -> Prim (a -> Result b) pf = PrimValue pc :: Curry b => (a -> b) -> (Prim (a -> Result b)) pc f = PrimValue (\ x _ -> f x) pa :: Curry c => (a -> Prim (b -> Result c)) -> Prim (a -> Result (Prim (b -> Result c))) pa f = PrimValue (\ x _ -> f x) cp :: (b -> c) -> (a -> b) -> a -> c cp f g x = f (g x) cond :: Curry a => C_Success -> a -> Result a cond C_Success x _ = x cond (C_SuccessOr r bs) x st = mapOr (\ c -> cond c x) r bs st cond x _ _ = patternFail "Prelude.cond" x ifVar :: (Curry a,Curry b) => b -> a -> a -> a ifVar = error "ifVar not implemented" --------------------------------------------- -- to ease connecting external functions --------------------------------------------- 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 -> Result f extFunc2 f x y = 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 -> Result cv extFunc3 f x y z = 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 -> Result cv extFunc4 f x1 x2 x3 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 -> Result c hnf2 f x y = hnfCTC (\ x' -> hnfCTC (\ y' _ -> f x' y') y) x ioFunc0 :: (Curry b,ConvertCH b a) => IO a -> Result (C_IO b) ioFunc0 iof _ = C_IO (\ _ -> iof Prelude.>>= \hv -> Prelude.return (IOVal (toCurry hv))) 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) Prelude.>>= \hv -> Prelude.return (IOVal (toCurry hv))) ioFunc2 :: (Curry a, Curry c,Curry f,ConvertCH a b,ConvertCH c d,ConvertCH f e) => (b->d->IO e) -> a -> c -> Result (C_IO f) ioFunc2 iof x y _ = C_IO (\ _ -> iof (fromCurry x) (fromCurry y) Prelude.>>= \hv -> Prelude.return (IOVal (toCurry hv))) ioFunc3 iof x y z _ = C_IO (\ _ -> iof (fromCurry x) (fromCurry y) (fromCurry z) Prelude.>>= \hv -> Prelude.return (IOVal (toCurry hv))) 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 (=:<=) = error "function patterns not implemented" -- from old autogenerated data Prim t0 = PrimValue t0 | PrimFail C_Exceptions | PrimOr OrRef (Branches (Prim t0)) data C_Four = C_F0 | C_F1 | C_F2 | C_F3 | C_FourFail C_Exceptions | C_FourOr OrRef (Branches C_Four) deriving (Eq) instance BaseCurry C_Success where nf f x st = f(x)(st) gnf f x st = f(x)(st) generator i = withRef(\ r -> C_SuccessOr(mkRef(r)(0)(i))([C_Success]))(0) failed = C_SuccessFail branching = C_SuccessOr consKind (C_SuccessOr _ _) = Branching consKind (C_SuccessFail _) = Failed consKind _ = Val exceptions (C_SuccessFail x) = x orRef (C_SuccessOr x _) = x branches (C_SuccessOr _ x) = x instance BaseCurry C_Bool where nf f x st = f(x)(st) gnf f x st = f(x)(st) generator i = withRef(\ r -> C_BoolOr(mkRef(r)(0)(i))([C_False,C_True]))(0) failed = C_BoolFail branching = C_BoolOr consKind (C_BoolOr _ _) = Branching consKind (C_BoolFail _) = Failed consKind _ = Val exceptions (C_BoolFail x) = x orRef (C_BoolOr x _) = x branches (C_BoolOr _ x) = x instance BaseCurry C_Four where nf f x st = f(x)(st) gnf f x st = f(x)(st) generator i = withRef(\ r -> C_FourOr(mkRef(r)(0)(i))([C_F0,C_F1,C_F2,C_F3]))(0) failed = C_FourFail branching = C_FourOr consKind (C_FourOr _ _) = Branching consKind (C_FourFail _) = Failed consKind _ = Val exceptions (C_FourFail x) = x orRef (C_FourOr x _) = x branches (C_FourOr _ x) = x