module ExternalInstancesPrelude (
  module AutoGenerated2, 
  module ExternalInstancesPrelude) where

import Curry
import DataPrelude
import Char
import List
import System.IO.Unsafe
import Data.IORef
import AutoGenerated2
--import qualified Debug.Trace as H

strace s x = unsafePerformIO (putStrLn s >> return 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 => 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

  -- generic programming
  --toC_Term   :: HNFMode -> State  -> a -> C_Data
  --fromC_Term :: C_Data -> a

class Generate a where
  genFree    :: () -> [a]
  genPattern :: () -> [a]

-----------------------------------------------------------------
-- 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 _ (IOValFreeVar i) = showString ('_':show 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_SuccessFreeVar ref) = showString ('_':show ref)

instance Show (FreeVarRef a) where
  show (FreeVarRef i _) = show i

instance Show (a->b) where
  show _ = "FUNCTION"

instance Show a => Show (Prim a) where
  show (PrimValue x) = show x
  show (PrimFreeVar r) = "_"++show r

instance Show a => Show (List a) where
    show xs = if isFreeList xs 
                then '(':showFreel xs
                else show (toHaskellList xs)
      where
        isFreeList List = False
        isFreeList (ListFreeVar _) = True
        isFreeList (_ :< xs) = isFreeList xs
        isFreeList _ = True

        showFreel (ListFreeVar r) = '_':show r++")"
        showFreel (x:<xs)   = show x ++ ":" ++ showFreel xs
	showFreel _ = "showFreel _"

fourToInt :: C_Four -> Int
fourToInt  C_F0 = 0
fourToInt  C_F1 = 1
fourToInt  C_F2 = 2
fourToInt  C_F3 = 3
fourToInt  x    = error $ "fourToInt "++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 -> Char
scToChar f1 f2 f3 f4 = chr ((fourToInt f1)*64+(fourToInt f2)*16+(fourToInt f3)*4+(fourToInt f4))

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
  show _ = error "probably someone used $# instead of $## for an external character function"

instance Show C_Char where
  show (C_Char c) = show c
  show (SearchChar f1 f2 f3 f4) = show (scToChar f1 f2 f3 f4)
  show (C_CharFreeVar r) = '_':show 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)   = showLitChar c . showl cs
      showl (SearchChar f1 f2 f3 f4:cs) = showLitChar (scToChar f1 f2 f3 f4) . showl cs
      showl (C_CharFreeVar r:cs) = showString ('_':show r) . showl cs
  
      showFreel [] = showString "]"
      showFreel [C_Char c] = showString (show c) . showString "]"
      showFreel [C_CharFreeVar r] = showString ('_':show r) . showString "]"
      showFreel (C_Char c:cs)   = showString (show c++",") . showFreel cs
      showFreel (c@(SearchChar _ _ _ _):cs) = showString (show c++",") . showFreel cs
      showFreel (C_CharFreeVar r:cs) = showString ('_':show r++",") . showFreel cs

      isFreeChar c = case c of 
                   C_CharFreeVar _ -> True
                   _ -> 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_NatFreeVar _) = True
isFreeNat C_IHi            = False
isFreeNat (C_I n)          = isFreeNat n
isFreeNat (C_O n)          = isFreeNat n

showsPrecNat :: Int -> C_Nat -> ShowS
showsPrecNat _ DataPrelude.C_IHi = Prelude.showString((:)('I')((:)('H')((:)('i')([]))))
showsPrecNat d (DataPrelude.C_O x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr)
 where
  showStr  = (Prelude..)(Prelude.showString((:)('O')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1))

showsPrecNat d (DataPrelude.C_I x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr)
 where
  showStr  = (Prelude..)(Prelude.showString((:)('I')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1))

showsPrecNat _ (DataPrelude.C_NatFreeVar i) = Prelude.showString((:)('_')(Prelude.show(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_IntFreeVar i) = showChar '_' . shows 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 DataPrelude.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 DataPrelude.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)

  free _    = IOVal (free ())
  pattern x = IOVal (freeIORef ())

  failed  = IOValFail

  freeVar  = IOValFreeVar

  branching r bs = IOValOr r (map return bs)

  suspend ref cont = error "IOValSusp" --IOValSusp ref (\state -> maybeFetchStore (return . cont) state)

  consKind (IOValFreeVar _) = Free
  consKind (IOValOr _ _) = Branching
  consKind (IOValFail _) = Failed
  consKind (IOValSusp _ _) = Suspended
  consKind _ = Val

  exceptions (IOValFail x) = x

  freeVarRef (IOValFreeVar x) = x

  orRef (IOValOr x _) = x

  branches (IOValOr _ bs) = map unsafePerformIO bs

  suspRef (IOValSusp x _) = x

  suspCont (IOValSusp _ cont) =  error "IOValSusp2" -- \store -> unsafePerformIO (cont (Just store))

instance BaseCurry (IO (IOVal t0)) where
  nf f x state = f(x) (state)
  gnf f x state = f(x)(state)

  failed x = return (IOValFail x)

  free = error "IO.free"
  pattern = error "IO.pattern"
  freeVar    = error "IO.freeVar"
  freeVarRef = error "IO.freeVarRef"

  branching r bs = return (IOValOr r bs)

  suspend r cont = error "IO IOValSusp" --return (IOValSusp r (maybeFetchStore cont))

  consKind _ = error "IO (IOVal _).consKind"  

  exceptions _ = error "IO (IOVal _).exceptions"

  orRef _ = error "IO (IOVal _).orRef"

  branches _ = error "IO (IOVal _).branches"

  suspRef _ = error "IO (IOVal _).suspRef"

  suspCont _ = error "IO (IOVal _).suspCont"


instance (BaseCurry t0) => BaseCurry (C_IO t0) where
  nf f x state = f(x)(state)
  gnf f x state = f(x)(state)

  free _    = C_IO (\ _ -> free ())
  pattern _ = C_IO (\ _ -> freeIORef ())

  failed  = C_IOFail

  freeVar  = C_IOFreeVar

  branching  = C_IOOr

  suspend  = C_IOSusp

  consKind (C_IOFreeVar _) = Free
  consKind (C_IOOr _ _) = Branching
  consKind (C_IOFail _) = Failed
  consKind (C_IOSusp _ _) = Suspended
  consKind _ = Val

  exceptions (C_IOFail x) = x

  freeVarRef (C_IOFreeVar x) = x

  orRef (C_IOOr x _) = x

  branches (C_IOOr _ x) = x

  suspRef (C_IOSusp x _) = x

  suspCont (C_IOSusp _ x) = x


instance BaseCurry C_Char where
  nf f (SearchChar x1 x2 x3 x4) state0 = Curry.nfCTC(\ v1 state1 -> Curry.nfCTC(\ v2 state2 -> Curry.nfCTC(\ v3 state3 -> Curry.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.gnfCTC(\ v1 state1 -> Curry.gnfCTC(\ v2 state2 -> Curry.gnfCTC(\ v3 state3 -> Curry.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_CharFreeVar _) = Free
  consKind (C_CharOr _ _) = Branching
  consKind (C_CharFail _) = Failed
  consKind (C_CharSusp _ _) = Suspended
  consKind _ = Val

  free _    = SearchChar (free ()) (free ()) (free ()) (free ())
  pattern _ = SearchChar (pattern ()) (pattern ()) (pattern ()) (pattern ()) 

  freeVarRef (C_CharFreeVar r) = r
  orRef      (C_CharOr x _) = x
  branches   (C_CharOr _ x) = x
  suspRef    (C_CharSusp x _) = x
  suspCont   (C_CharSusp _ x) = x

  failed = C_CharFail

  exceptions (C_CharFail x) = x

  freeVar = C_CharFreeVar

  branching  = C_CharOr

  suspend = C_CharSusp

instance Generate a => BaseCurry (Prim a) where
  nf f x store = f(x)(store)

  gnf f x store = f(x)(store)

  free _    = orsCTC (map PrimValue (genFree ()))
  pattern _ = orsCTC (map PrimValue (genPattern ()))

  suspend = PrimSusp
  failed = PrimFail
  branching = PrimOr
  freeVar = PrimFreeVar

  consKind (PrimFreeVar _) = Free
  consKind (PrimOr _ _) = Branching
  consKind (PrimFail _) = Failed
  consKind (PrimSusp _ _) = Suspended
  consKind _ = Val

  exceptions (PrimFail x) = x

  freeVarRef (PrimFreeVar r) = r

  orRef (PrimOr x _) = x

  branches (PrimOr _ x) = x

  suspRef (PrimSusp x _) = x

  suspCont (PrimSusp _ 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) = 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"
  fromCurry (ListFreeVar _) = error "free list"
  fromCurry (ListSusp _ _) = error "susp 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.

-- this is a specialized version of RunTimeCurry.narrowCTC
-- could again be replaced by standard definition.
narrowSuccess :: FreeVarRef StrEqResult -> StrEqResult -> StrEqResult
narrowSuccess v@(FreeVarRef _ ref) res = case unsafePerformIO (readIORef ref) of
  C_BoolFail _    -> bind v C_True res
  C_True          -> res
  C_False         -> strEqFail ""
  C_BoolFreeVar v -> narrowSuccess v res

-- 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
concAnd (C_BoolFreeVar v) x st = narrowSuccess v x
concAnd s@(C_BoolSusp _ wake) x st = 
  case unsafePerformIO (readIORef wake) () of
    Nothing -> susp x s
    Just v  -> concAnd v x st

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 x y st) xs)
maySwitch x@(C_BoolFail _) _ _ = x
maySwitch x@C_False _ _ = x
maySwitch (C_BoolFreeVar v) x st = narrowSuccess v x
maySwitch s@(C_BoolSusp _ wake) x st = 
  case unsafePerformIO (readIORef wake) () of
    Nothing -> susp x s
    Just v  -> maySwitch v x st

startBreadth :: [StrEqResult] -> Result StrEqResult
startBreadth cs st = onLists (maybe emptyStore id 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) = case fromStore st ref 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 res = map (\ (i,x) -> onLists (addToStore st ref i) ors [x]) (zip [0..] xs)
  in  C_BoolOr ref res 

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)

susp :: StrEqResult -> StrEqResult -> StrEqResult 
susp C_True x = x
susp x@C_False _ = x
susp (C_BoolOr ref xs) x = C_BoolOr ref (map (flip susp x) xs)
susp (C_BoolSusp ref wake) s = -- @(C_SuccessSusp ref' cont') 
  treatSusp (\ x _ -> susp x s) ref wake Nothing
{-
case wake () of
     Just v  -> susp v s'
     Nothing -> 
   (C_SuccessSusp (ref||ref') (\ store -> cont' store `concAnd` cont store))-}
susp x@(C_BoolFail _) _ = x
susp (C_BoolFreeVar v) x = narrowSuccess v x

--- 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 Free Free 
         | freeVarRef x Prelude.== freeVarRef y
         = C_True --C_Success
         | otherwise = bind (freeVarRef x) y C_True --C_Success 
            -- maybe create new var to be symmetric?
      checkFree Free _ = let p=pattern () in 
        bind (freeVarRef x) p (hnfCTC (\ x' -> unify x' y) p st)
      checkFree _ Free = let p=pattern () in 
        bind (freeVarRef y) p (hnfCTC (unify x) p st)
      checkFree Val Val = strEq x y st

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->b) where
--  genFree _    = mkBranches (free ())
--  genPattern _ = mkBranches (pattern ())

instance BaseCurry b => Generate (a -> Result b) where
  genFree _    = mkBranches (free ())
  genPattern _ = mkBranches (pattern ())

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"
  genPattern _ = error "free variable of type Float"


-----------------------------------------------------------------
-- external Curry instances
-----------------------------------------------------------------
{-
instance (Curry a) => Curry (IOVal a) where
  strEq (IOVal x1) (IOVal y1) = op_61_58_61(x1)(y1)
  strEq x0 _ = strEqFail(typeName(x0))

  eq (IOVal x1) (IOVal y1) = op_61_61(x1)(y1)
  eq _ _ = C_False

  --subst store (IOVal x1) = IOVal(subst(store)(x1))
  --subst store (IOValFreeVar r) = fetch(store)(r)

  typeName _ = "IOVal"

  --toC_Term mode store (IOVal x1) = C_Data(C_Int((1::Integer)))((:<)(C_Char('I'))((:<)(C_Char('O'))((:<)(C_Char('V'))((:<)(C_Char('a'))((:<)(C_Char('l'))(List))))))((:<)(ctcStore(mode)(toC_Term(mode))(store)(x1))(List))
  --toC_Term _ _ (IOValFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))

  --fromC_Term (C_Data (C_Int (1::Integer)) _ ((:<) x1 List)) = IOVal(fromC_Term(x1))
  --fromC_Term (C_Data (C_IntFreeVar _) ((:<) (C_Char 'I') ((:<) (C_Char 'O') ((:<) (C_Char 'V') ((:<) (C_Char 'a') ((:<) (C_Char 'l') List))))) ((:<) x1 List)) = IOVal(fromC_Term(x1))
  --fromC_Term (C_Free (C_Int r)) = IOValFreeVar(Prelude.fromInteger(r))
-}

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 Curry (IO (IOVal a)) where 
  strEq _ _ = 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 f0 st) (f f1 st) (f f2 st) (f 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


  --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))

  typeName _ = "Char"

instance (Generate a,Show a,Read a,Eq a) => Curry (Prim a) where
  strEq x@(PrimValue v1) (PrimValue v2) _
    | v1==v2 = C_True --C_Success
    | otherwise = strEqFail (typeName x)

  eq (PrimValue v1) (PrimValue v2) _ = toCurry (v1==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"

{-




-----------------------------------------------------------------------
-- Strings and other Lists
-----------------------------------------------------------------------


  strEq C_Success C_Success = C_Success
  strEq x _ = strEqFail (typeName x)

  eq C_Success C_Success = C_True
  eq _ _ = C_False

  typeName _ = (:<)(C_Char('S'))((:<)(C_Char('u'))((:<)(C_Char('c'))((:<)(C_Char('c'))((:<)(C_Char('e'))((:<)(C_Char('s'))((:<)(C_Char('s'))(List)))))))

  --toC_Term mode store C_Success = C_Data(C_Int((1::Integer)))((:<)(C_Char('S'))((:<)(C_Char('u'))((:<)(C_Char('c'))((:<)(C_Char('c'))((:<)(C_Char('e'))((:<)(C_Char('s'))((:<)(C_Char('s'))(List))))))))(List)
  --toC_Term _ _ (C_SuccessFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))

  --fromC_Term (C_Data (C_Int (1::Integer)) _ List) = C_Success
  --fromC_Term (C_Data (C_IntFreeVar _) ((:<) (C_Char 'S') ((:<) (C_Char 'u') ((:<) (C_Char 'c') ((:<) (C_Char 'c') ((:<) (C_Char 'e') ((:<) (C_Char 's') ((:<) (C_Char 's') List))))))) List) = C_Success
  --fromC_Term (C_Free (C_Int r)) = C_SuccessFreeVar(Prelude.fromInteger(r))




  strEq C_True C_True = C_Success
  strEq C_False C_False = C_Success
  strEq x _ = strEqFail (typeName x)

  eq C_True C_True = C_True
  eq C_False C_False = C_True
  eq _ _ = C_False

  typeName _ = (:<)(C_Char('B'))((:<)(C_Char('o'))((:<)(C_Char('o'))((:<)(C_Char('l'))(List))))

  --toC_Term mode store C_True = C_Data(C_Int((2::Integer)))((:<)(C_Char('T'))((:<)(C_Char('r'))((:<)(C_Char('u'))((:<)(C_Char('e'))(List)))))(List)
  --toC_Term mode store C_False = C_Data(C_Int((1::Integer)))((:<)(C_Char('F'))((:<)(C_Char('a'))((:<)(C_Char('l'))((:<)(C_Char('s'))((:<)(C_Char('e'))(List))))))(List)
  --toC_Term _ _ (C_BoolFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))

  --fromC_Term (C_Data (C_Int (2::Integer)) _ List) = C_True
  --fromC_Term (C_Data (C_Int (1::Integer)) _ List) = C_False
  --fromC_Term (C_Data (C_IntFreeVar _) ((:<) (C_Char 'T') ((:<) (C_Char 'r') ((:<) (C_Char 'u') ((:<) (C_Char 'e') List)))) List) = C_True
  --fromC_Term (C_Data (C_IntFreeVar _) ((:<) (C_Char 'F') ((:<) (C_Char 'a') ((:<) (C_Char 'l') ((:<) (C_Char 's') ((:<) (C_Char 'e') List))))) List) = C_False
  --fromC_Term (C_Free (C_Int r)) = C_BoolFreeVar(Prelude.fromInteger(r))





--instance Enum (IORef a) where
--instance Real (IORef a) where
--instance Num (IORef a) where
--instance Ord (IORef a) where
--instance Integral (IORef a) where
--  toInteger _ = undefined

-------------------------------------------------------------------------
-- expanding type definitions
-------------------------------------------------------------------------

-- the following is needed to give functions a curry class 
-- by data type (Prim (a->b)) (see below.)
-- The alternative would be an own Wrapper class for functions.
-- (Maybe done some day if there would be some serious advantage.)


-----------------------------------------------------------------------
-- some special instances for functions in order to derive class Curry
-- for Prim (a->b)
-----------------------------------------------------------------------

-----------------------------------------------------------------
-- wrapper for primitive datatypes
-----------------------------------------------------------------

int2string :: Integer -> String
int2string i = if i < 256 then [ch i] else int2string (div i 256) ++ [ch (mod i 256)]
  where
    ch i = chr (fromInteger i)

string2int :: String -> Integer
string2int = foldl (\ i c -> 256*i+toInteger(ord c)) 0
              
		      

-----------------------------------------------------------------------
-- Lists
-----------------------------------------------------------------------







freeVarify cs = case break isSpace cs of
                  (consName,_:nStr)
                    | isSuffixOf "FreeVar" consName && isDigit (head nStr) ->
                        '_':nStr
                  _ -> cs


-----------------------------------------------------------------------
-- Char is not implemented with Prim because of String representation
-----------------------------------------------------------------------






---------------------------------------------------
-- only as long as AutoGenerated2 is not complete
---------------------------------------------------



instance Curry C_Int where
  nf f store x = f(store)(x)
  gnf f store x = f(store)(x)

  consKind (C_IntFreeVar _) = Free
  consKind (C_IntOr _ _) = Branching
  consKind (C_IntFail _) = Failed
  consKind (C_IntSusp _ _) = Suspended
  consKind _ = Val

  exceptions (C_IntFail x) = x

  freeVarRef (C_IntFreeVar r) = r

  orRef (C_IntOr x _) = x

  branches (C_IntOr _ x) = x

  suspRef (C_IntSusp x _) = x

  suspCont (C_IntSusp _ x) = x


  failed = C_IntFail
  freeVar = C_IntFreeVar

  branching  = C_IntOr

  suspend = C_IntSusp

  strEq x@(C_Int c1) (C_Int c2) 
    | c1 Prelude.== c2 = C_Success
    | otherwise = strEqFail (typeName x)

  eq (C_Int x1) (C_Int y1) = toCurry (x1 Prelude.== y1)
  eq _ _ = C_False

  --toC_Term _ _ ci@(C_Int i) = C_Data ci (toCurry (show i)) List
  --toC_Term _ _ (C_IntFreeVar r) = C_Free(C_Int(Prelude.toInteger(r)))

  --fromC_Term (C_Data i@(C_Int _) _ _)  = i
  --fromC_Term (C_Data (C_IntFreeVar _) name List) = C_Int (read (fromCurry name))
  --fromC_Term (C_Free (C_Int r)) = C_IntFreeVar(Prelude.fromInteger(r))

  typeName _ = (:<)(C_Char('I'))((:<)(C_Char('n'))((:<)(C_Char('t'))(List)))


-}