diff --git a/KiCS.cabal b/KiCS.cabal
--- a/KiCS.cabal
+++ b/KiCS.cabal
@@ -1,5 +1,5 @@
 Name:          KiCS
-Version:       0.8.3
+Version:       0.8.4
 Cabal-Version: >= 1.6
 Author:        Bernd Braßel
 Maintainer:    Bernd Braßel
@@ -26,6 +26,20 @@
     directory,
     containers,
     curry-base >= 0.2.4
+  Other-Modules: 
+    Config
+    CurryToHaskell
+    SafeCalls
+    Names
+    KicsSubdir
+    FunctionalProg
+    ShowFunctionalProg
+    ShowFlatCurry
+    PreTrans
+    Simplification
+    Brace
+    InstallDir
+    MyReadline
 
 Executable kicsi
   main-is:        kicsi.hs
@@ -40,4 +54,18 @@
     containers,
     readline,
     curry-base >= 0.2.4
+  Other-Modules: 
+    Config
+    CurryToHaskell
+    SafeCalls
+    Names
+    KicsSubdir
+    FunctionalProg
+    ShowFunctionalProg
+    ShowFlatCurry
+    PreTrans
+    Simplification
+    Brace
+    InstallDir
+    MyReadline
 
diff --git a/src/Brace.hs b/src/Brace.hs
new file mode 100644
--- /dev/null
+++ b/src/Brace.hs
@@ -0,0 +1,10 @@
+module Brace where
+
+import List
+
+separate :: [a] -> [[a]] -> [a] 
+separate s xs = concat (intersperse s (filter (not . null) xs))
+
+brace :: [a] -> [a] -> [a] -> [[a]] -> [a] 
+brace _ _ _ [] = []
+brace begin end sep xs = begin++separate sep xs++end
diff --git a/src/Config.hs b/src/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Config.hs
@@ -0,0 +1,476 @@
+module Config (module Config,module KicsSubdir) where
+
+import Data.Char
+
+import System.FilePath
+import System.Environment (getEnvironment,getArgs)
+import System.Directory hiding (executable)
+import System.Time
+import Control.Monad.Trans(liftIO)
+
+import Curry.ExtendedFlat.Type(Prog, readFlat)
+
+import InstallDir
+import SafeCalls
+import Names
+import KicsSubdir
+
+
+getOptions :: IO (Options,State)
+getOptions = do 
+  (opts,state) <- readConfig
+  args <- getArgs
+  cupath <- getEnv "CURRYPATH"
+  let parsed = parseOptions opts args
+  parsedOpts <- either usage return parsed
+  let addFiledir = case takeDirectory (filename opts) of "" -> id; dir -> (dir:)
+      newOpts    = parsedOpts{userlibpath=  addFiledir $
+                                         userlibpath parsedOpts
+                                      ++ splitSearchPath cupath}
+  return (newOpts,state)    
+
+
+
+parseOptions :: Options -> [String] -> Either String Options
+parseOptions opts ("-or":xs) = parseOptions (opts{cm=OrBased}) xs
+parseOptions opts ("-ctc":xs) = parseOptions (opts{cm=CTC}) xs
+parseOptions opts ("-main":x:xs) = parseOptions (opts{mainFunc=x}) xs
+parseOptions opts ("-frontend":x:xs) = parseOptions (opts{frontend=x}) xs
+parseOptions opts ("-kicspath":x:xs) = parseOptions (opts{kicspath=x}) xs
+parseOptions opts ("-userlibpath":x:xs) = 
+  parseOptions (opts{userlibpath=userlibpath opts ++ splitSearchPath x}) xs
+parseOptions opts ("-nouserlibpath":xs) = parseOptions (opts{userlibpath=[]}) xs
+parseOptions opts ("-ghc":x:xs) = parseOptions (opts{ghc=x}) xs
+parseOptions opts ("-make":xs) = parseOptions (opts{make=True}) xs
+parseOptions opts ("-nomake":xs) = parseOptions (opts{make=False}) xs
+parseOptions opts ("-executable":xs) = parseOptions (opts{executable=True}) xs
+parseOptions opts ("-noexecutable":xs) = parseOptions (opts{executable=False}) xs
+parseOptions opts ("-q":xs) = parseOptions (opts{verbosity=0}) xs
+parseOptions opts ("-v":i:xs) = parseOptions (opts{verbosity=read i}) xs
+parseOptions opts ("-noforce":xs) = parseOptions (opts{force=False}) xs
+parseOptions opts ("-force":xs) = parseOptions (opts{force=True}) xs
+parseOptions opts ("-all":"df":xs) = parseOptions (opts{pm=All DF}) xs
+parseOptions opts ("-all":"bf":xs) = parseOptions (opts{pm=All BF}) xs
+parseOptions opts ("-st":xs) = parseOptions (opts{pm=ST}) xs
+parseOptions opts ("-i":"df":xs) = parseOptions (opts{pm=Interactive DF}) xs
+parseOptions opts ("-i":"bf":xs) = parseOptions (opts{pm=Interactive BF}) xs
+parseOptions opts ("-o":x:xs) = parseOptions (opts{target=x}) xs
+parseOptions opts ("-d":xs) = parseOptions (opts{debug=True,doNotUseInterface=True}) xs
+parseOptions opts ("--debug":xs) = parseOptions opts ("-d":xs)
+parseOptions opts ("--debugger":d:xs) = parseOptions opts{debugger=Just d} xs
+parseOptions opts []    = Right opts
+parseOptions opts [x]   = Right (opts{filename=x,mainModule=takeBaseName x})
+parseOptions _    (x:_) = Left ("unrecognized option: "++x)
+
+
+usage :: String -> IO b
+usage problem = do
+  putStrLn problem
+  putStrLn "Usage: kics [options] filename"
+  putStrLn "option         | meaning"
+  putStrLn "-or            | or based"
+  putStrLn "-ctc           | switch to call time choice"
+  putStrLn "-main          | name of main function "
+  putStrLn "-frontend      | frontend binary"
+  putStrLn "-kicspath      | path to kics compiler"
+  putStrLn "-userlibpath   | path to curry libraries"
+  putStrLn "-nouserlibpath | only standard curry libraries"
+  putStrLn "-ghc           | path to ghc"
+  putStrLn "-make          | chase imported modules"
+  putStrLn "-nomake        | do not chase imported modules"
+  putStrLn "-executable    | create executable"
+  putStrLn "-noexecutable  | do not create executable"
+  putStrLn "-v <n>         | set verbosity level to n, e.g., -v 3"
+  putStrLn "-q             | scarce output"
+  putStrLn "-force         | force recompilation"
+  putStrLn "-noforce       | do not force recompilation"
+  putStrLn "-all df        | print all solutions depth first"
+  putStrLn "-all bf        | print all solutions breadth first"
+  putStrLn "-st            | print solutions as search tree"
+  putStrLn "-i df          | interactively show solutions depth first"
+  putStrLn "-i bf          | interactively show solutions breadth first"
+  putStrLn "-o             | name of output file"
+  putStrLn "-d             | turn on debug mode"
+  putStrLn "--debugger <n> | use debug tool <n>"
+  error "compilation aborted"
+
+
+data Options = Opts{ cm :: ChoiceMode,
+                     filename, mainFunc, mainModule, target,
+                     frontend, ghc, ghcOpts,
+                     kicspath  :: String,
+                     userlibpath, done :: [String],
+                     verbosity :: Int,
+                     make, executable, eval, 
+                     force, debug, doNotUseInterface :: Bool, 
+                     debugger :: Maybe String,
+                     consUse :: ConsUse,
+                     extCons,hasData :: Bool,
+                     pm :: PresentationMode,
+                     extData, extFuncs :: [String],
+                     extInsts :: [(String,[ProvidedInstance])]} deriving Show
+
+data ConsUse = DataDef | InstanceDef | FunctionDef deriving (Eq,Show)
+
+
+cymake_call :: String
+cymake_call = unpath [installDir,"bin","parsecurry"]
+
+
+libpath :: Options -> [String]
+libpath Opts{userlibpath=up,kicspath=kp} 
+  = --(case takeDirectory fn of "" -> id; dir -> ((dir++[pathSeparator]):))
+    up ++ [unpath [kp,"src","lib",""]]
+
+
+cmdLibpath :: Options -> String
+cmdLibpath opts = toPathList (libpath opts)
+
+currentModule :: Options -> String
+currentModule opts = strip (filename opts)
+  where
+   strip s = case break isPathSeparator s of
+               (s',[]) -> s'
+               (_,_:s')  -> strip s'
+
+hasExtData,hasExtInsts, hasExtFuncs :: Options -> Bool
+hasExtData opts = 
+  not (null (extData opts)) || any (elem Declaration . snd) (extInsts opts)
+hasExtInsts opts = 
+  not (null (filter (any (/=Declaration) . snd) (extInsts opts)))
+hasExtFuncs opts = not (null (extFuncs opts))
+
+
+defaultOpts :: t -> Options
+defaultOpts _ = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Main",
+      target = "request",
+      frontend=cymake_call,
+      kicspath=installDir,
+      userlibpath=[],
+      ghc=ghc_call,
+      ghcOpts=" -fglasgow-exts -fcontext-stack=50 ",
+      done=[], 
+      make=True, 
+      executable=False, 
+      verbosity=1,
+      eval=True,
+      force=False,
+      debug=False,
+      debugger = Nothing,
+      doNotUseInterface=False,
+      consUse=FunctionDef,
+      extCons=False,
+      hasData=False,
+      pm=Interactive DF,
+      extData=[],
+      extInsts=[],
+      extFuncs=[]}
+
+
+kicsrc :: String -> String
+kicsrc home = unpath [home,".kicsrc"]
+
+data ChoiceMode = OrBased | CTC deriving (Eq,Read,Show)
+
+data SearchMode = DF | BF 
+
+instance Show SearchMode where
+  show DF  = "depth first"
+  show BF  = "breadth first"
+
+data PresentationMode = First SearchMode
+                      | All SearchMode 
+                      | Interactive SearchMode
+                      | ST 
+
+instance Show PresentationMode where
+  show (All x) = "all solutions "++show x
+  show (Interactive x) = "interactive "++show x
+  show (First x) = "first solution "++show x
+  show ST  = "search tree"
+
+data State = State {home,rts,cmdLineArgs :: String,
+                    files :: [(Bool,String)],
+                    time :: Bool} deriving Show
+
+
+defaultState :: String -> State
+defaultState home = State {home=home,
+                           rts=" -H400M ",
+                           cmdLineArgs="",
+                           files=[],
+                           time=False}
+
+
+readPMode :: String -> PresentationMode
+readPMode s = readPM (words (map toLower s))
+    where
+      readPM ("interactive":ws) = Interactive (readSM ws)
+      readPM ("all":"solutions":ws) = All (readSM ws)
+      readPM ["search","tree"] = ST
+      
+      readSM ["depth","first"] = DF
+      readSM ["breadth","first"] = BF
+
+ghcCall :: Options -> String
+ghcCall opts@Opts{filename=fn} = 
+  callnorm (ghc opts
+             ++makeGhc (make opts)
+             ++" -i"++show (toPathList 
+                             (pathWithSubdirs 
+                                (unpath [installDir,"src"]:
+                                 unpath [installDir,"src","oracle"]:
+                                 libpath opts)))++" "
+             ++kicsSubdirPathToFile
+             ++linkOpts
+             ++ghcOpts opts
+             ++verboseGhc (verbosity opts >= 2) 
+             ++ghcTarget opts
+             ++" "++show fn)
+      
+  where
+    linkOpts | debug opts = linkLib++" -L"++installDir++"/src/lib/ "
+             | otherwise  = ""
+    linkLib  | eval opts  = " -ldyncoracle "
+             | otherwise  = " -lcoracle "
+
+    verboseGhc True  = ""
+    verboseGhc False = " -v0 "
+
+    ghcTarget Opts{target=""} = ""
+    ghcTarget Opts{target=t} = " -o "++show t
+
+    makeGhc True = " --make "
+    makeGhc False = ""
+
+    kicsSubdirPathToFile = case takeDirectory fn of
+                             "" -> ""
+                             path -> " -i"++show (addKicsSubdir path)++" "
+
+
+stricthsCall :: Options -> String
+stricthsCall opts = 
+  callnorm (installDir++"/bin/stricths --hs " 
+             ++ ("-s"++mainModule opts++" ")
+             ++ (if make  opts then "-m " else "")
+             ++ (if force opts then "-f " else "")
+             ++ (if verbosity opts < 2 then "-q " else "")
+             ++ filename opts)
+
+
+mkStrictCall :: Options -> String
+mkStrictCall opts = 
+  callnorm (installDir++"/bin/mkstrict " 
+             ++ (if verbosity opts < 2 then "--quiet " else "")
+             ++ filename opts++" "            
+          
+
+             {-++ (if make  opts then "-m " else "")
+             ++ (if force opts then "-f " else "")
+             ++ filename opts-})
+
+cyCall :: Options -> String
+cyCall opts = callnorm $ frontend opts++" --extended-flat -e " ++
+                         unwords (map (("-i"++) . show) (libpath opts))
+
+
+callnorm :: String -> String
+callnorm s = unwords (words s) ++ " "
+
+
+cymake :: Options -> SafeIO ()
+cymake opts = do
+  safeSystem (verbosity opts >= 3) 
+                         (cyCall opts ++ show (filename opts)
+                             ++ if verbosity opts >= 3 then "" else " 1>/dev/null ")
+
+
+prophecy :: Options -> SafeIO ()
+prophecy opts = safeSystem (verbosity opts >= 4) $
+   		      installDir++"/bin/prophecy " 
+   		      ++ (if make  opts then " -m " else "")
+   		      ++ (if force opts then " -f " else "")
+   		      ++ (if verbosity opts < 2 then " -q " else "")
+   		      ++ show (dropExtension $ filename opts)
+   		      ++ if verbosity opts >= 4 then "" else " 1>/dev/null "
+
+                
+readConfig :: IO (Options, State)
+readConfig = do
+   home <- getEnv "HOME"
+   curDir <- getCurrentDirectory
+   catch (readFile (kicsrc home) >>= getConfigs home) 
+         (\_->do
+                 let defaultsO = defaultOpts curDir
+                     defaultsS = defaultState home
+                 writeConfig defaultsO defaultsS
+                 putStrLn ("The file "++kicsrc home++" has been written.")
+                 putStrLn ("You might need to edit it.")
+                 error "Please verify .kicsrc")
+
+
+writeConfig :: Options -> State -> IO ()
+writeConfig opts state = do
+  home <- getEnv "HOME"
+  writeFile (kicsrc home)
+    (wLibPath++wPM++wEval++wTime ++wRTS)
+  where
+    wLibPath  = setting 1 (\o-> toPathList $ case userlibpath o of
+                            ".":path -> path
+                            path     -> path)
+    wPM       = setting 2 (show . pm)
+    wEval     = setting 3 (show . eval)
+    wTime     = inState 4 (show . time)
+    wRTS      = inState 5 rts
+
+    setting n f = entry n (f opts)
+    inState n f = entry n (f state)
+    entry n s   = (configs!!(n-1)) ++ "="++s++"\n\n"
+
+
+mkTags :: [Options -> String]
+mkTags = [kicspath,
+          (toPathList . userlibpath),
+          (show . pm)]
+
+
+getConfigs :: String -> String -> IO (Options, State)
+getConfigs home cfgs | cfgs == cfgs = do
+  punkt <- getCurrentDirectory
+
+  let readOpts = selOpts (entries cfgs)
+
+      defaultsO = defaultOpts punkt  
+      opts = defaultsO
+            {cm           = OrBased,
+             kicspath     = installDir,
+             userlibpath  = let up = readSetting userlibpath splitSearchPath 1
+                             in (punkt ++ [pathSeparator]) : up,
+             pm           = readSetting pm readPMode 2,
+             ghc          = ghc_call,                              
+             frontend     = cymake_call,
+             eval         = readSetting eval read 3,
+             force = False}
+      readSetting f r n = maybe (f defaultsO) r (readOpts!!(n-1))
+
+      defaultsS = defaultState home
+      state = defaultsS
+               {time = readSSet time read 4,
+                rts  = readSSet rts  id   5}
+      readSSet f r n = maybe (f defaultsS) r (readOpts!!(n-1))
+
+  return (opts,state)
+
+
+entries :: String -> [(String, String)]
+entries s = equations (lines s)
+  where
+    equations [] = []
+    equations (x:xs) = case break (=='=') x of
+      (l,_:r) -> (l,r):equations xs
+      _       -> equations xs
+
+
+selOpts :: [(String, a)] -> [Maybe a]
+selOpts cfgs = map (selTag cfgs) configs
+
+
+configs :: [String]
+configs = 
+ ["Libraries",
+  "PresentationMode",
+  "Eval",
+  "Time",
+  "RunTimeSettings"]
+
+
+selTag :: [(String, a)] -> String -> Maybe a
+selTag [] _ = Nothing
+selTag ((t,v):xs) s = 
+  if map toLower t==map toLower s 
+    then Just v
+    else selTag xs s
+
+-- FIXME use library functions for path manipulation (hsi)
+paths :: String -> [FilePath]
+paths s = case break (==':') s of
+           ("","") -> []
+           (w,"") -> [w]
+           ("",_:ws) -> paths ws
+           (w,_:ws) -> w : paths ws
+
+getModTime :: String -> SafeIO ClockTime
+getModTime fn = safeIO (do 
+                   ex<-doesModuleExist fn
+                   if ex then getModuleModTime fn else return (TOD 0 0))
+
+
+-- FIXME When readFlatCurry fails, no cause is reported (hsi)
+safeReadFlat :: Options -> String -> SafeIO (Curry.ExtendedFlat.Type.Prog)
+safeReadFlat opts s = do
+    fs <- safeIO (findFileInPath s (libpath opts))
+    fn <- warning s (cmdLibpath opts) fs
+    prog <- safeIOSeq (readFlat fn)
+    maybe (fail $ "readFlat "++ show s) return prog
+
+
+warning :: String -> FilePath -> [FilePath] -> SafeIO FilePath
+warning fn path [] = fail ("module "++fn++" not found in path "++path)
+warning _ _  (f:fs) = do
+  mapM_ (safeIO . putStrLn) 
+        (map (\f' -> "further file found (but ignored) "++f'
+                   ++" taking "++f++" instead") fs)
+  return f
+
+
+----------------------------------------------
+-- external definitions
+----------------------------------------------
+
+-- what is provided by external files
+
+data ProvidedInstance = 
+  Declaration | Show | Read | BaseCurry | Curry deriving (Eq,Ord,Read,Show)
+
+data Provided = ForType String (Maybe [ProvidedInstance])
+              | ForFunction String 
+              | SomeFunctions
+              deriving (Eq,Read,Show)
+
+-- external specifications have to look like this:
+-- fortype <typename> [definition|nodef] instances <instname>*
+-- extfunc <funcname>
+
+put :: Int -> Options -> String -> SafeIO ()
+put i Opts{verbosity=j} s 
+    | i > j     = return ()
+    | otherwise = safeIO (putStrLn s)
+
+readExternalSpec :: Options -> String -> SafeIO Options
+readExternalSpec opts p = do
+    specs <- safeIO $ findFileInPath 
+                        (externalSpecName (p `withoutSubdir` currySubdir)) 
+                        (libpath opts) 
+    if null specs
+      then return opts 
+      else do
+        spec <- warning "" "" specs >>= safeIO . readModule
+        put 5 opts "reading external specification"
+        let newOpts = foldr insertP opts (read spec)
+        safeIO (seq newOpts (return ()))
+        put 5 opts "external specification read"
+        return newOpts
+  where
+    insertP SomeFunctions         opts = opts{extFuncs = ""     : extFuncs  opts}
+    insertP (ForFunction f)       opts = opts{extFuncs = f      : extFuncs  opts}
+    insertP (ForType t Nothing)   opts = opts{extData  = t      : extData   opts}
+    insertP (ForType t (Just is)) opts = opts{extInsts = (t,is) : extInsts  opts}
+    
+baseName :: String -> String
+baseName f = case reverse f of
+  'y':'r':'r':'u':'c':'.':f'     -> reverse f'
+  'y':'r':'r':'u':'c':'l':'.':f' -> reverse f'
+  _ -> f
+
+getEnv :: String -> IO String
+getEnv s = getEnvironment >>= maybe (return "") return . lookup s
diff --git a/src/CurryToHaskell.hs b/src/CurryToHaskell.hs
new file mode 100644
--- /dev/null
+++ b/src/CurryToHaskell.hs
@@ -0,0 +1,1343 @@
+module CurryToHaskell where 
+
+import Control.Monad
+import Data.List
+import Data.Char
+import Data.Maybe
+import System
+import System.FilePath
+
+import Curry.ExtendedFlat.Type
+import Curry.ExtendedFlat.Goodies hiding (consName)
+
+import qualified FunctionalProg as C
+import ShowFunctionalProg
+import PreTrans hiding (nub,pre)
+import Simplification ( simplifyProg )
+
+import SafeCalls
+import Brace
+import Config
+import Names (dataHsName,instHsName,funcHsName,
+              extDataHsName,extInstHsName,extFuncHsName,
+              extDataModName,extInstModName,extFuncModName,
+              dataModName,instModName,modName,dbgModName,
+              elimInfix,funName,functionName,constructorName)
+import qualified Names as N
+
+
+--import Debug.Trace
+--trace' x = trace (show x) x
+
+-------------------------------
+-- main compilation routine
+-------------------------------
+
+-- call this function to start compilation
+-- arguments: record of Type Options as defined 
+-- in Config.hs 
+
+startCompilations :: Options -> [String] -> IO [String]
+startCompilations _ [] = return []
+startCompilations opts fs = 
+  compilations fs opts{done=[],mainModule=head fs}
+
+-- FIXME errors in retrieving options are silently ignored
+compilations ::  [String] -> Options -> IO [String]
+compilations [] opts = return (done opts)
+compilations (f:fs) opts = 
+  safe (startCompilation opts{filename=f}) >>=
+  compilations fs . either (const opts) id
+
+
+startCompilation :: Options -> SafeIO Options
+startCompilation opts = do 
+  put 2 opts "calling frontend"
+  newOpts <- callFrontend opts 
+  visited <- compile newOpts >>= return . done 
+  put 2 opts "calling ghc"
+  ghcProgram False newOpts (funcHsName (filename newOpts))
+  return newOpts{done=visited}
+
+-- compile not only returns the current Options 
+-- but also a flag whether no significant changes
+-- have been made. A significant change forces
+-- recompilation of dependent modules.
+compile :: Options -> SafeIO Options
+compile opts = do
+  newOpts <- getFlatCurryFileName opts
+  old <- notUptodate newOpts
+  if old || force opts || executable opts 
+   -- possible improvement: generate only Main.hs if up-to-date
+   then process newOpts >>= makeImports 
+   else skip    newOpts >>= makeImports 
+
+process :: Options -> SafeIO (String,[String],Options)
+process opts0@(Opts{filename=fn}) = do
+  prog <- safeReadFlat opts0 (replaceExtension fn ".efc")
+  unless (executable opts0)  
+         (put 1 opts0 ("processing: "++progName prog))
+  opts <- readExternalSpec opts0 fn
+  unless (null $ extData  opts) 
+         (put 5 opts "external data declarations found")
+  unless (null $ extInsts opts) 
+         (put 5 opts "external instance declarations found")
+  unless (null $ extFuncs opts) 
+         (put 5 opts "external function declarations found")
+  applyFlatTransformations opts prog >>= generateHaskellFiles opts
+  return (progName prog,progImports prog,opts0)
+
+-- only read beginning of interface file, return name and list of imports 
+skip :: Options -> SafeIO (String,[String],Options)
+skip opts = do
+    let fname = if doNotUseInterface opts 
+                then replaceExtension (filename opts) ".efc"
+                else replaceExtension (filename opts) ".fint"
+    fn <- safeIO (findFileInPath fname (libpath opts)) >>=
+          warning (filename opts) (cmdLibpath opts) 
+    cont <- safeIOSeq (readModule fn)
+    let [("Prog",rest)] = lex cont
+        [(name,rest')]  = reads rest
+        [(imps,_)]      = reads rest'
+    put 3 opts ("up-to-date: "++name)
+    return (name,imps,opts)
+
+makeImports :: (String,[String],Options) -> SafeIO Options
+makeImports (name,imps,opts@(Opts{filename=fn})) = do
+  impOpts <- foldCompile imps opts{executable=False}
+  return impOpts{done=name : done impOpts}
+
+---------------------------------------------------------------------------------
+-- sub routines of compilation
+---------------------------------------------------------------------------------
+
+callFrontend opts@(Opts{filename=givenFile}) = do
+  let lib = libpath opts
+  foundCurry <- safeIO (findFileInPath (replaceExtension givenFile ".curry") lib)
+  foundSources <- if null foundCurry 
+                   then safeIO (findFileInPath (replaceExtension givenFile ".lcurry") lib)
+                   else return foundCurry
+  unless (null foundSources) (if   debug opts 
+                              then prophecy opts 
+                              else cymake opts)
+  return (if debug opts then opts{filename=dbgModName givenFile} else opts)
+
+getFlatCurryFileName opts@(Opts{filename=basename}) = do
+  let lib = libpath opts
+  foundFiles <- safeIO (findFileInPath (replaceExtension basename ".efc") lib)
+  foundFile <- warning basename (toPathList lib) foundFiles
+  let foundBasename = dropExtensions foundFile
+  return (opts{filename=foundBasename})
+
+notUptodate opts@(Opts{filename=foundBasename}) = do
+  tSource      <- getModTime (replaceExtension foundBasename ".efc")
+  tDestination <- getModTime (funcHsName foundBasename)
+  return (tSource > tDestination)
+
+
+--applyFlatTransformations :: Options -> Prog -> ([FuncDecl], Prog, [Prog], ([Char], [Char]))
+applyFlatTransformations opts prog = do
+  let auxNames = generateAuxNames (progFuncs prog)
+      mexprog = if executable opts then addExec auxNames opts prog 
+                                   else Left prog
+  exprog <- either return fail mexprog 
+  let suffix = flip replaceExtension $ if doNotUseInterface opts
+               then ".efc"
+               else ".fint"
+  interfaces <- mapM (safeReadFlat opts . suffix) (progImports exprog) 
+  (globals,locProg) <- safeIOSeq (return (splitGlobals exprog))
+  let liftedProg = noCharCase (liftCases True (simplifyProg locProg))
+  --disAmb <- disambiguate interfaces ceprog
+  unless (null globals) 
+         (put 5 opts 
+            ("module contains "++show (length globals)
+                               ++" global declarations"))
+  return (globals,liftedProg,interfaces,auxNames)
+
+generateHaskellFiles opts (globals,prog,interfaces,auxNames) = do
+  let typeMapping = makeTypeMap (prog:interfaces)
+      modules = transform typeMapping auxNames opts prog
+  put 3 opts "generating Haskell"
+  mapM  (writeProgram opts) (addGlobalDefs opts globals modules)
+  return (haskellFiles opts (progName prog))
+
+writeProgram opts (fn,printOpts,prog) = do
+  put 3 opts ("writing "++inKicsSubdir fn)
+  safeIO (writeKicsFile fn (showProgOpt printOpts prog))
+  put 3 opts (fn++" written")
+  return fn
+
+
+ghcProgram skipping opts fn = 
+  unless (eval opts && executable opts)  $ do
+      found <- safeIO (findFileInPath fn (libpath opts))
+      let hsFile = head found
+          ghc    = safeSystem (verbosity opts >= 2) 
+                     (ghcCall opts{make=True,filename=hsFile,target=""})
+          shFile = drop 2 (reverse hsFile)
+          oFile  = reverse ('o':shFile)
+          hiFile = reverse ('i':'h':shFile)
+      unless (null found) $
+         if skipping 
+           then do
+                  ex <- safeIO (mapM doesModuleExist [oFile,hiFile])
+                  unless (and ex) ghc
+           else ghc
+
+foldCompile :: [String] -> Options -> SafeIO Options
+foldCompile [] opts     = return opts
+foldCompile (f:fs) opts 
+  | elem f (done opts) = foldCompile fs opts
+  | otherwise          = compile (opts{filename=f}) >>=
+                         foldCompile fs
+
+
+------------------------------------------------------
+-- auxiliary functions
+------------------------------------------------------
+
+-- names of all haskell files associated with program
+haskellFiles :: Options -> String -> [String]
+haskellFiles opts name =
+  ifAdd (extData opts)  (add [extDataHsName]) $
+  ifAdd (extInsts opts) (add [dataHsName,extInstHsName]) $
+  ifAdd (extFuncs opts) (add [instHsName,extFuncHsName]) $ 
+  add [funcHsName] []
+  where
+    ifAdd (_:_) f ds = f ds
+    ifAdd []    _ ds = ds
+    
+    add = foldr (\ f -> ((f name:) .)) id 
+ 
+
+------------------------------------------------------
+-- basic transformation
+------------------------------------------------------
+-- for a given module up to three haskell modules are generated:
+    -- one for the functions,
+    -- one for the data declarations (possibly empty)
+    -- one "Main"-module to generate executables, 
+    --   if the executable flag is set in the options
+-- introduce Modules CallTime/RunTimeChoice 
+transform typeMapping aux opts0 (Prog name imports types funcs _)
+  = (if executable opts then [(mainFileName,False,mainModule)] else [])
+     ++ modules
+
+  where
+    opts = opts0{hasData=hasInternalData}
+    hasExternalData      = hasExtData  opts
+    hasExternalInstances = hasExtInsts opts
+    hasExternalFuncs     = hasExtFuncs opts
+    hasInternalData      = not $ null $ filter (not . isExternalType) types
+
+    modules 
+      | not hasInternalData                      = [allinclusiveProg]
+      | hasExternalInstances && hasExternalFuncs = [dataProg,instProg,funcProg]
+      | hasExternalInstances                     = [dataProg,instFuncProg]
+      | hasExternalFuncs                         = [dataInstProg,funcProg]
+      | otherwise                                = [allinclusiveProg]
+
+    -- filename, flag and module definitions
+    dataProg 	     = (dataHsName (filename opts),False,dataModule)
+    instProg 	     = (instHsName (filename opts),False,instModule)
+    funcProg 	     = (funcHsName (filename opts),False,funcModule)
+    instFuncProg     = (funcHsName (filename opts),False,instFuncModule)
+    dataInstProg     = (instHsName (filename opts),False,dataInstModule)
+    allinclusiveProg = (funcHsName (filename opts),False,allinclusive)
+
+
+    modul mName mImports mExports mTypes mInsts mFuncs =  
+      C.Prog mName mImports mExports mTypes mInsts mFuncs []
+
+    dataModule     = modul dataName dataImports dataExports dataTypes []        []
+    instModule     = modul instName instImports instExports []        instances []
+    funcModule     = modul funcName funcImports funcExports []        []        functions
+    instFuncModule = modul funcName instImports funcExports []        instances functions
+    dataInstModule = modul instName dataImports dataExports dataTypes instances []
+    allinclusive   = modul funcName allIImports allIExports dataTypes instances functions
+
+    -- the module names are:
+    dataName = dataModName name
+    instName = instModName name
+    funcName = N.modName name
+
+    mainModuleName = "Main"
+
+    -- the file names of these modules are:
+    funcFileName = funcHsName (filename opts)
+    dataFileName = dataHsName (filename opts)
+    mainFileName = "Main.hs"
+
+    -- import lists
+    newImports = map N.modName imports
+    allIImports = 
+      ["Curry"] ++ (if hasExternalData  then [extDataModName name] else []) 
+                ++ (if hasExternalFuncs then [extFuncModName name] else [])
+                ++ newImports
+    dataImports 
+      | hasExternalData = "Curry" : (extDataModName name) : newImports
+      | otherwise       = "Curry" : newImports
+    instImports         = "Curry" : dataName : (extInstModName name) : newImports
+    funcImports         = "Curry" : instImportName : (extFuncModName name) : newImports
+    -- this is the only special prelude treatment:
+    instImportName 
+      | name=="Prelude" = instName ++ " hiding ("++opsUsedInInstances++")"
+      | otherwise       = instName
+    opsUsedInInstances = "op_38_38"
+    
+    -- export lists
+    allIExports = map ("module "++) $
+         (if hasExternalData  then [extDataModName name] else [])
+      ++ (if hasExternalFuncs then [extFuncModName name] else [])
+    dataExports 
+      | hasExternalData      = ["module "++extDataModName name]
+      | otherwise            = []
+    instExports = map ("module "++) [dataName,extInstModName name]
+    funcExports = map ("module "++) [instName,extFuncModName name]
+ 
+    -- the generated types, instances and functions
+    dataTypes = map (transTypeDecl opts{consUse=DataDef}) 
+                    (typeSyns++filter isToTransform typeDecls)
+    instances =  genInstances BaseCurry baseCurryInstance opts typeDecls
+              ++ genInstances Curry     curryInstance     opts typeDecls
+              ++ genInstances Show      showInstance      opts typeDecls
+              ++ genInstances Read      readInstance      opts typeDecls
+    functions = map (transFunc opts typeMapping) funcs
+
+    mainModule = mainMod aux funcName opts
+ 
+    -- information about original module 
+    (typeSyns,typeDecls) = partition isTypeSyn $ 
+                           filter (\t->  not (elem (localName $ typeName t) (extData opts))) types
+    isToTransform t = case lookup (localName $ typeName t) (extInsts opts) of
+      Nothing -> True
+      Just is -> not (elem Declaration is)
+
+
+--------------------------------------------------------
+-- adding main function for executables
+--------------------------------------------------------
+
+generateAuxNames fs = (genNewName "aux1" fns,genNewName "aux2" fns)
+  where 
+    fns = map (localName . funcName) fs
+
+    genNewName s ts = if elem s ts then genNewName ('a':s) ts else s
+    
+
+mainMod (_,aux2) m opts = let aux = mkQName (m,localName (mkQName $ funName ("",aux2))) in
+  C.Prog "Main" ["Curry",N.modName "Prelude",m]
+     [] [] [] 
+     [C.Func (mkQName (m,"main")) public untyped 
+        (Just  [C.Rule [] 
+          (noguard $ fapp (hasPresym ">>") 
+                       [app (setProg opts) (C.String (mainModule opts)),
+                        app (C.Symbol (mkQName (N.modName "Prelude","curryIOVoid")))
+                            (sym aux)]) []])]
+     []
+  where
+    setProg Opts{cm=OrBased} = cusym "setProgNameAndOrBased"
+    setProg _                = cusym "setProgName"
+
+addExec (aux1,aux2) opts (Prog m is ts funcs ops) = 
+  case lookup (mainFunc opts) lfs of
+    Just f@(Func n a vis t (Rule vs e)) 
+     | t == ioT unitT -> prog False
+       [Func a2 0 vis t (Rule [] (flatApp n []))]
+     | isIOType t -> prog True
+       [Func a1 0 vis (monomorph t) (Rule [] (flatApp n [])),
+        Func a2 0 vis (ioT unitT) (Rule [] (flatApp printIO [calla1 t True]))]
+     |  isFuncType t && not (debug opts) -- && not (isFuncType (range t)))
+          -> Right (mainFunc opts++" is no constant")
+     | debug opts -> prog False
+       [Func a1 1 vis (monomorph t) (Rule [0] (flatApp n [Var 0])),
+        Func a2 0 vis (ioT unitT) (Rule [] 
+          (calla1 t (isFuncType (range t) && 
+                     isFuncType (range (range t)) && 
+                     isIOType (range (range (range t))))))]
+     | otherwise -> prog True
+       [Func a1 0 vis (monomorph t) (Rule [] (flatApp n [])),
+        Func a2 0 vis (ioT unitT) (Rule [] 
+          (flatBind (flatGst (calla1 t True)) (startFunc opts)))]
+    _ -> Right (mainFunc opts++" undefined")
+  where
+    a1 = mkQName (m,aux1)
+    a2 = mkQName (m,aux2)
+    calla1 t orc = if debug opts 
+                   then Comb FuncCall (mkQName ("Oracle","oracle"++if orc then "IO" else "") )
+                             [Comb (FuncPartCall 1) a1 []]
+                   else Comb FuncCall a1 []
+    printIO = mkQName ("Interactive","printIO")
+    lfs = zip (map (localName . funcName) funcs) funcs
+  
+    startFunc Opts{pm=Interactive DF} = ask ... df 
+    startFunc Opts{pm=Interactive BF} = ask ... bf 
+    startFunc Opts{pm=All DF}         = pr  ... df
+    startFunc Opts{pm=All BF}         = pr  ... bf 
+    startFunc Opts{pm=First DF}       = ap_ pr $ hd ... df
+    startFunc Opts{pm=First BF}       = ap_ pr $ hd ... bf
+    startFunc Opts{pm=ST}             = Comb (FuncPartCall 1) pr []
+  
+    monomorph (TVar _) = unitT
+    monomorph (TCons n args) = TCons n (map monomorph args)
+    monomorph (FuncType t1 t2) = FuncType (monomorph t1) (monomorph t2)
+
+    prog addInt fs =  Left (Prog m (if addInt then "Interactive":is else is)
+                                 ts (fs++funcs) ops)
+
+ask = mkQName ("Interactive","interactiveSols")
+df  = mkQName ("Prelude","allValuesD")
+bf  = mkQName ("Prelude","allValuesB")
+pr  = mkQName ("Interactive","printTerm")
+hd  = mkQName ("Prelude","head")
+f ... g = Comb FuncCall  (flatPre ".") 
+            [Comb (FuncPartCall 1) f [],Comb (FuncPartCall 1) g []]
+ap_ f e = Comb FuncCall  (flatPre ".") [Comb (FuncPartCall 1) f [],e]
+
+------------------------------------------------------
+-- transformation of type declarations
+------------------------------------------------------
+
+-- each type declaration has to derive instances for Show and Read
+-- moreover, new constructors for logical variables, ors and fails 
+-- have to be added.
+
+transTypeDecl :: Options -> TypeDecl -> C.TypeDecl
+transTypeDecl opts (Type name vis vars consdecls) 
+  = C.Type (consName opts name) (transvis vis) (map (varName "t" . mkIdx) vars) 
+           (map (transConsdecls opts) consdecls ++
+            newConsDecls (consName opts name) vars)
+           []
+transTypeDecl opts (TypeSyn name vis vars t) 
+  = C.TypeSyn (consName opts name) (transvis vis) (map (varName "t" . mkIdx) vars) 
+              (transTypeExpr opts t)
+
+transConsdecls :: Options -> ConsDecl -> C.ConsDecl
+transConsdecls opts (Cons name arity vis ts) 
+  = C.Cons (consName opts name) arity (transvis vis) False 
+           (map (transTypeExprF opts) ts)
+
+transTypeExpr, transTypeExprF :: Options -> TypeExpr -> C.TypeExpr
+transTypeExpr _ (TVar n) = toTVar n
+transTypeExpr opts (FuncType t1 t2) = 
+  C.FuncType (transTypeExprF opts t1) (transTypeExpr opts t2)
+transTypeExpr opts (TCons name ts) 
+  = C.TCons (consName opts name) (map (transTypeExprF opts) ts)
+
+transTypeExprF _ (TVar n) = toTVar n
+transTypeExprF opts (FuncType t1 t2) = 
+      C.TCons (consName opts{extCons=True} (addPre "Prim"))
+        [addStateType (C.FuncType (transTypeExprF opts t1) (transTypeExprF opts t2))]
+transTypeExprF opts (TCons name ts) 
+ = C.TCons (consName opts name) (map (transTypeExprF opts) ts)
+
+newConsDecls qn vs 
+  = [C.Cons qn{ localName = localName qn ++ "Fail"}  0 private  False [tExceptions],
+     C.Cons qn{ localName = localName qn ++ "Or"}  2 private False 
+        [tOrRef, tBranches newT]] 
+  where
+    newT = C.TCons qn (map toTVar vs)
+
+
+-------------------------------------------
+-- generating instances
+-------------------------------------------
+
+inst newModName name vars classname =  
+  C.Instance (map (\v -> C.TypeClass (cu classname) [toTVar v]) vars) 
+             (C.TypeClass (cu classname) 
+                          [C.TCons (mkQName (newModName,name)) (map toTVar vars)])
+
+
+curryInstance opts t@(Type origName vis vars consdecls) 
+  = inst newModName name vars "Curry" 
+         [strEq,eq,propagate,foldCurry,typeName,showFunction True opts t] --toTerm,fromTerm
+  where
+    (newModName,name) = qnOf $ consName opts origName 
+
+    origMod = Curry.ExtendedFlat.Type.modName origName
+  
+    isPrelude = origMod=="Prelude"
+
+    strEq = C.Func (mkQName (newModName,"strEq")) (transvis vis) untyped 
+                  (Just  
+                    (map strEqRule consdecls++
+                    [C.Rule [_x,toPVar 0,_x]
+                           (noguard $ 
+                              fapp (extInstPresym isPrelude "strEqFail")
+                                   [fapp (extInstPresym isPrelude "typeName") [toVar 0]]) []]))
+
+    strEqRule (Cons cname arity _ _) =
+      rule  [C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]),
+             C.PComb (consName opts cname) (map (toPVar' "y" . mkIdx) [1..arity])]
+            (noguard $ if arity==0 then (extInstPresym isPrelude "strEqSuccess")
+                         else foldr1 (\ e es -> fapp (extInstPresym isPrelude "concAnd") 
+                                                     (addStateArg [e,es]))
+                                 (map sEq [1..arity])) []
+       where
+         sEq i = fapp (extInstPresym isPrelude "genStrEq") (addStateArg [toVar $ mkIdx i,toVar' "y" (mkIdx i)])
+
+    eq = C.Func (mkQName (newModName,"eq")) (transvis vis) untyped 
+               (Just  
+                       (map eqRule consdecls
+                         ++otherwiseExp 3 (baseTypesym isPrelude "C_False")))
+
+    eqRule (Cons cname arity _ _) =
+      rule  [C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]),
+             C.PComb (consName opts cname) (map (toPVar' "y" . mkIdx) [1..arity])]
+             (noguard $ if arity==0 then baseTypesym isPrelude "C_True"
+                         else foldr1 (\ e es -> fapp (fbasesym opts "&&") (addStateArg [e,es]))
+                                (map eqArgs [1..arity])) []
+       where
+         eqArgs i = fapp (extInstPresym isPrelude "genEq") (addStateArg [toVar $ mkIdx i,toVar' "y" (mkIdx i)])
+
+    propagate = C.Func (mkQName (newModName,"propagate")) (transvis vis) untyped 
+                       (Just  (map propRule consdecls))
+                       
+
+    propRule (Cons cname arity _ _) =
+      C.Rule (addStatePat [C.PVar "f",C.PComb (consName opts cname) 
+                                              (map (toPVar . mkIdx) [1..arity])])
+             (noguard $ fapp (sym (consName opts cname))
+                             (map propCall [1 .. arity])) []
+      where propCall i = fapp (C.Var "f") (addStateArg [toHInt (i-1),toVar $ mkIdx i])
+
+    foldCurry = C.Func (mkQName (newModName,"foldCurry")) (transvis vis) untyped 
+                       (Just  (map foldRule consdecls))
+                       
+    foldRule (Cons cname arity _ _) =
+      C.Rule (addStatePat [C.PVar "f",C.PVar "c",C.PComb (consName opts cname) 
+                                                         (map (toPVar . mkIdx) [1..arity])])
+             (noguard $ foldr appFold (C.Var "c") (map (toVar . mkIdx) [1 .. arity])) []
+       where
+         appFold v e = fapp (C.Var "f") (addStateArg [v,e])
+
+    typeName =  C.Func (mkQName (newModName,"typeName")) (transvis vis) untyped 
+                  (Just  [C.Rule [_x] 
+                                 (noguard $ C.String (localName origName)) []])
+
+    toTerm = C.Func (mkQName (newModName,"toC_Term")) (transvis vis) untyped 
+                  (Just  
+                    (map toTermRule (zip [1..] consdecls) ++
+                    [C.Rule [_x,_x,
+                             C.PComb (mkQName (newModName,name++"FreeVar")) [C.PVar "r"]] 
+                            (noguard $ app (baseTypesym isPrelude "C_Free") 
+                                        (app (c_int isPrelude)
+                                          (app (hasPresym "toInteger")
+                                               (C.Var "r")))) []]))
+
+    toTermRule (nr,(Cons cname arity _ _)) =
+      C.Rule [C.PVar "mode",C.PVar "store",
+              C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])]             
+             (noguard $ fapp (baseTypesym isPrelude "C_Data") 
+                             [toInt nr,c_string_ origMod (localName cname),
+                              dList isPrelude (map su [1..arity])]) []
+       where
+         su i = fapp (basesym "ctcStore") 
+                     [C.Var "mode",app (basesym "toC_Term") (C.Var "mode"),
+                      C.Var "store",toVar $ mkIdx i]
+
+    fromTerm = C.Func (mkQName (newModName,"fromC_Term")) (transvis vis) untyped 
+                  (Just  
+                    (concatMap fromTermRule (zip [1..] consdecls) ++
+                    [C.Rule [C.PComb (baseType isPrelude "C_Free") 
+                               [C.PComb (baseType isPrelude "C_Int") 
+                                    [C.PVar "r"]]] 
+                            (noguard $ app (sym (mkQName (newModName,name++"FreeVar")))
+                                           (app (hasPresym "fromInteger")
+                                               (C.Var "r"))) []]))
+
+    fromTermRule (nr,(Cons cname arity _ _)) =
+      [rule "C_Data"     [pnr,_x,pts],
+       rule "C_Data"     [pfree,pname,pts]]
+       where
+         pnr = toPInt opts nr
+         pfree = C.PComb (baseType isPrelude "C_IntFreeVar") [_x]
+         pname = dpList isPrelude (map (toPChar opts) (localName cname))
+         pts = dpList isPrelude (map (toPVar . mkIdx) [1..arity])
+         e = noguard $ fapp (sym (consName opts cname)) 
+                            (map (app (basesym "fromC_Term") . toVar . mkIdx) [1..arity])
+         rule c args = C.Rule [C.PComb (baseType isPrelude c) args] e []
+
+
+baseCurryInstance opts (Type origName vis vars consdecls) 
+  = inst newModName name vars "BaseCurry" 
+       [nf False, nf True, 
+      	free "generator" "generator",failed,branching,
+      	consKind,
+      	exceptions,orRef,branches]
+  where
+    (newModName,name) = qnOf $ consName opts origName 
+
+    origMod = Curry.ExtendedFlat.Type.modName origName
+  
+    isPrelude = origMod=="Prelude"
+
+    nf gr = C.Func (mkQName (newModName,if gr then "gnf" else "nf")) (transvis vis) untyped 
+                  (Just  
+            (concatMap (nfrule gr) (filter ((1<=) . consArity) consdecls) ++
+             [C.Rule (addStatePat [C.PVar "f",C.PVar "x"])
+                     (noguard (fapp (C.Var "f") (addStateArg [C.Var "x"]))) []]))
+
+    nfrule gr (Cons cname arity _ _)
+      =  [C.Rule [C.PVar "f",
+                  C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]),
+                  C.PVar "state0"]
+                 (noguard $ foldr (nflambda gr)
+                             (fapp (C.Var "f") 
+                                [fapp (sym $ consName opts cname) 
+                                        (map (toVar' "v" . mkIdx) [1..arity]),
+                                 toVar' "state" (mkIdx arity)])
+                             (map mkIdx [1..arity])) []]
+
+    nflambda gr i e = 
+      fapp (basesym (if gr then "gnfCTC" else "nfCTC")) 
+        [C.Lambda [toPVar' "v" i,toPVar' "state" i] e,toVar i,toVar' "state" (i-1)]
+
+    free s t = C.Func (mkQName (newModName,s)) (transvis vis) untyped 
+            (Just [C.Rule [C.PVar "i"] (noguard $ 
+             fapp (basesym "withRef") [
+             C.Lambda [C.PVar "r"] $
+             fapp (sym (orName opts origName)) 
+             [fapp (basesym "mkRef") [C.Var "r",maxAr,C.Var "i"],
+              list_ (map freeCons consdecls)],
+             maxAr]) []])
+      where
+        maxAr = C.Var (show (foldr max 0 (map consArity consdecls)))
+        freeCons (Cons cname arity _ _) = 
+          fapp (sym (consName opts cname)) 
+               (snd $ foldr addOne (0,[]) (replicate arity (app (basesym t))))
+        addOne e (n,es) = 
+          (n+1,e (fapp (hasPresym "+") [C.Var "r",toHInt n]):es)
+ 
+    failed = constructor "failed" failName 
+    freeVarFunc = constructor "freeVar" freeVarName 
+    branching = constructor "branching" orName 
+    suspend = constructor "suspend" suspName 
+
+
+    consKind = C.Func (mkQName (newModName,"consKind")) (transvis vis) untyped 
+                  (Just  
+                    (map tester [(orName, 2, "Branching"),
+                                 (failName, 1, "Failed")] ++
+                    [C.Rule [_x]
+                           (noguard $ (basesym "Val")) []]))
+
+    tester (namer,arity,nameTest)  = 
+       C.Rule [C.PComb (namer opts origName) (take arity (repeat (_x)))]
+              (noguard (basesym nameTest)) []
+
+    selector nameSel namer arity number =
+       C.Func (mkQName (newModName,nameSel)) (transvis vis) untyped 
+         (Just [C.Rule [C.PComb (namer opts origName) 
+                          (underscores (number-1)++[C.PVar "x"]++
+                           underscores (arity-number))]
+                       (noguard (C.Var "x")) []])
+
+    constructor nameConstr namer = 
+      C.Func (mkQName (newModName,nameConstr)) (transvis vis) untyped 
+         (Just  [C.Rule []
+                  (noguard $ sym (namer opts origName)) []])
+
+    exceptions = selector "exceptions" failName 1 1
+    freeVarRef = selector "freeVarRef" freeVarName 1 1
+                     
+    orRef    = selector "orRef" orName 2 1
+    branches = selector "branches" orName 2 2
+
+    suspRef  = selector "suspRef" suspName 2 1
+    suspCont = selector "suspCont" suspName 2 2
+
+
+    
+---------------------------------------------------------------------------
+
+
+   
+------------------------------------------------------
+-- transformation of functions and expressions
+------------------------------------------------------
+
+transFunc :: Options -> (QName -> QName) -> FuncDecl -> C.FuncDecl
+transFunc opts typeMapping (Func fname arity vis t (Rule lhs rhs))
+  = C.Func newFName (transvis vis) 
+           (transFType opts arity t) crules
+    where
+      newFName = mkQName $ funName $ qnOf fname
+      f = mkQName (N.modName (Curry.ExtendedFlat.Type.modName fname),auxName $ localName newFName) 
+      trhs = transExpr opts rhs
+
+      crules = case rhs of
+        Case _ ct (Var n) bs -> Just (transBranching ct (break (==n) lhs) 
+                                                     opts f typeMapping fname bs)
+        Case _ _  _       _  -> error "case not normalized"
+        _                    -> Just [rule (map toPVar lhs) (noguard trhs) []]
+
+      auxName name
+          | isInfixOpName name = elimInfix name
+          | otherwise          = name
+
+
+transFunc opts _ (Func qn arity vis t (External _))
+    = C.Func (mkQName $ funName $ qnOf qn) (transvis vis) (transFType opts arity t)
+      (Just  [rule (map (toPVar . mkIdx) [1..arity])  
+              (noguard (fapp (C.Symbol (mkQName (extFuncModName m,fname)))
+                        (addStateArg (map (toVar . mkIdx) [1..arity])))) []])
+    where (m, fname) = qnOf qn
+
+
+transFType :: Options -> Int -> TypeExpr -> Maybe C.TypeExpr
+-- the first line is for transformations too lazy to compute correct type
+transFType _ _ (TVar (-42)) = Nothing 
+transFType opts arity t = Just $
+  C.TConstr 
+    [C.TypeClass c [toTVar tv] | tv <- nub (allVarsInTypeExpr t),
+                                  c <- [mkQName ("Curry","Curry")]]
+    (addStateType (transFTypeExpr opts arity t))
+
+transFTypeExpr opts 0 t = transTypeExprF opts t
+transFTypeExpr opts (n+1) (FuncType t1 t2)
+  = C.FuncType (transTypeExprF opts t1) (transFTypeExpr opts n t2)
+
+transvis x | x==Private = C.Private
+           | x==Public  = C.Public
+
+transExpr :: Options -> Expr -> C.Expr
+transExpr opts (Var n) = toVar n
+transExpr opts (Lit l) = transLit opts l
+transExpr opts (Free [] e) = transExpr opts e
+transExpr opts (Free (v:vs) e) 
+  = app freeCall (C.Lambda [toPVar v] (transExpr opts (Free vs e)))
+transExpr opts (Or e1 e2) = fapp orSym (map (transExpr opts) [e1, e2])
+transExpr opts (Let vbs e) = 
+  C.LetDecl (map locdecl vbs) (transExpr opts e)
+  where
+    locdecl (v,b) = C.LocalPat (toPVar v) (transExpr opts b) []
+transExpr opts (Comb FuncCall fn args)
+    | qnOf fn == ("Global","global") 
+    = C.LetDecl [C.LocalPat (C.PVar "st") (hasPresym "Nothing") []] 
+      (fapp (C.Symbol (mkQName $ funName $ qnOf fn)) (map (transExpr opts) args))
+transExpr opts (Comb combType fname args) 
+  = newExpr
+  where
+    newArgs = map (transExpr opts) args
+
+    call = case combType of 
+              ConsCall       -> symApp (consName opts fname) newArgs
+              FuncCall       -> symApp (mkQName $ funName $ qnOf fname)       (addStateArg newArgs)
+              FuncPartCall i -> symApp (mkQName $ funName $ qnOf fname)       newArgs
+              ConsPartCall i -> symApp (consName opts fname) newArgs 
+
+    symApp s xs = fapp (C.Symbol s) xs
+
+    newExpr = case combType of 
+                ConsCall       -> call
+                FuncCall       -> call
+                FuncPartCall i -> pf opts i call
+                ConsPartCall i -> pc opts i call
+transExpr _ (Case _ _ _ _) = error "unlifted case"
+
+
+transLit :: Options -> Literal -> C.Expr
+transLit opts (Charc _ c)  = toChar opts c
+transLit opts (Floatc _ f) = toFloat opts f
+transLit opts (Intc _ i)   = toInt i
+
+
+transBranching :: CaseType -> ([VarIndex],[VarIndex]) -> Options -> QName -> 
+  (QName -> QName) -> QName -> [BranchExpr] -> [C.Rule]
+transBranching caseMode vs@(as,v:bs) opts f tm oName branches
+  = oldRules++newRules
+  where
+    oldRules = map (transRule vs opts) branches
+    typeName = case (\ (Branch p _) -> p) (head branches) of
+      Pattern c _ -> tm c
+      LPattern l  -> mkQName ("Prelude",case l of {Intc _ _->"Int";Charc _ _->"Char"})
+
+    freePat = C.AsPat "x" (C.PComb (freeVarName opts typeName) [C.PVar "ref"])
+    orPat   = C.PComb (orName opts typeName) [C.PVar "i",C.PVar "xs"]
+    suspPat = C.PComb (suspName opts typeName) [C.PVar "ref",C.PVar "susp"]
+
+    isOracleMod = debug opts && "CurryOracle" `isPrefixOf` mname && length mname > 11
+    mname = Curry.ExtendedFlat.Type.modName f
+
+    refVar = 1 --if null (as++bs) then error $ "where is the ref?" ++ show f
+               --               else last (as++bs)
+    applyf b = C.Lambda (addStatePat (if b then [toPVar refVar,C.PVar "x"]
+                                           else [C.PVar "x"]))
+                      (fapp (sym f) 
+                            (addStateArg (map toVar as ++ 
+                                          C.Var "x" : map toVar bs)))
+
+    newLhs p e = rule (map toPVar as ++ (p:map toPVar bs)) e []
+    newRules = 
+           [newLhs orPat
+             (noguard ((if isOracleMod
+                        then fapp (sym (mkQName (funName ("CEventOracle","onBranches")))) .
+                             (toVar refVar :)
+                        else fapp (cusym "mapOr"))
+                       (addStateArg [applyf isOracleMod,
+                                     C.Var "i",C.Var "xs"])))
+           ,newLhs (C.PVar "x")
+                   (noguard $ (if isOracleMod then closeRef refVar else id)
+                            $ fapp (cusym "patternFail") 
+                                  [qname_ $ qnOf oName,C.Var "x"])]
+
+
+    closeRef i e = fapp (sym $ mkQName  $ funName ("CEventOracle","closeRef")) $
+                        addStateArg [toVar i,e]
+
+transRule :: ([VarIndex],[VarIndex]) -> Options -> BranchExpr -> C.Rule 
+transRule (as,v:bs) opts (Branch (LPattern l@(Charc _ _)) e) 
+  = rule ps (C.GuardedExpr [(guard,transExpr opts e)]) []
+  where
+    guard = app (extInstPresym False "isC_True")
+                (fapp (fbasesym opts "===") [toVar v,toLit opts l])
+    ps    = map toPVar as ++ toPVar v : map toPVar bs
+transRule (as,v:bs) opts (Branch (LPattern l) e) 
+  = rule ps (noguard (transExpr opts e)) []
+  where
+    ps  = map toPVar as ++ C.AsPat (xvar v) (toPLit opts l) : map toPVar bs
+transRule (as,v:bs) opts (Branch (Pattern name args) e) 
+  = rule ps (noguard (transExpr opts e)) []
+  where
+    ps = map toPVar as ++ (if elem v args then id else C.AsPat (xvar v)) 
+                          (C.PComb (consName opts name) (map toPVar args)) 
+                        : map toPVar bs
+
+
+rule ps = C.Rule (addStatePat ps)
+
+transOp (Op name InfixOp p)  = C.Op (mkQName $ funName $ qnOf name) C.InfixOp  p
+transOp (Op name InfixlOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixlOp p
+transOp (Op name InfixrOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixrOp p
+
+
+----------------------------------------------------------------
+-- generating instances for read and show
+----------------------------------------------------------------
+
+genInstances _ _ _ [] = []
+genInstances cl genFunc opts (t:ts) 
+  | maybe False (elem cl) (lookup (localName $ typeName t) (extInsts opts)) 
+  = genInstances cl genFunc opts ts
+  | otherwise = genFunc opts{consUse=InstanceDef} t : 
+                genInstances cl genFunc opts ts
+
+showInstance opts t@(Type origName vis vars consdecls) =
+ C.Instance (map (\v -> C.TypeClass (has "Show") [toTVar v]) vars)
+   (C.TypeClass (has "Show") [C.TCons (mkQName (newModName,name)) (map toTVar vars)])
+   [showFunction False opts t]
+ where
+   (newModName,name) = qnOf $ consName opts origName
+
+
+
+showFunction showQ opts t@(Type origName vis vars consdecls) 
+  | maybe False (elem Show) (lookup (localName $ typeName t) (extInsts opts)) 
+  = showsPrec [C.Rule [] (C.SimpleExpr (hasPresym "showsPrec")) []]
+  | otherwise = showsPrec (map showsPrecRule consdecls
+              ++[showGenerator])
+ where
+   showParenArg qn 
+       = case localName qn of
+           '(':_           -> hasPresym "True"
+           _   | showQ     -> hasPresym "True"
+               | otherwise -> lt (C.Var "d") app_prec
+
+   showsPrecName = if showQ then "showQ" else "showsPrec"
+   showsPrecSym  = (if showQ then extInstPresym (Curry.ExtendedFlat.Type.modName origName=="Prelude") 
+                             else hasPresym) showsPrecName
+
+   identifier qn = case localName qn of
+                     "()" -> "()"
+                     _    -> let (cm,cn) = qnOf qn
+                             in if showQ then cm++"."++cn else cn
+
+   opening qn = case localName qn of
+                  '(':_ -> ""
+                  _     -> identifier qn ++ " "
+
+   separator qn = case localName qn of
+                    '(':_ -> ','
+                    _     -> ' '
+
+   showsPrec rs = C.Func (mkQName (newModName,showsPrecName))
+                         (transvis vis) untyped 
+                         (Just rs)
+
+   (newModName,name) = qnOf $ consName opts origName
+
+   showsPrecRule (Cons cname 0 _ []) = 
+      C.Rule [_x, C.PComb (consName opts cname) []]
+         (C.SimpleExpr 
+            (app (hasPresym "showString") (string_ (identifier cname)))) []
+   showsPrecRule (Cons cname arity _ args) = 
+     C.Rule [C.PVar "d", C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])]
+            (C.SimpleExpr (fapp (hasPresym "showParen") 
+                             [showParenArg cname,sym (mkQName ("","showStr"))]))
+            [C.LocalFunc (C.Func (mkQName ("","showStr")) (transvis vis) untyped 
+                  (Just [C.Rule [] (C.SimpleExpr showStr) []]))]
+      where
+        showStr = points (app (hasPresym "showString") (string_ (opening cname)):
+                          intersperse 
+                            (app (hasPresym "showChar") (char_ (separator cname)))
+                            (map (callShowsPrec . mkIdx) [1..arity]))
+                             
+
+        callShowsPrec i = fapp showsPrecSym [add_prec cname,toVar i]
+
+        points = foldr1 point 
+
+        point x y = fapp (hasPresym ".") [x,y]
+
+
+   showTuple = C.Func (mkQName (newModName,showsPrecName)) (transvis vis) untyped 
+                  (Just (map showTupleRule consdecls++[showGenerator]))
+
+   showTupleRule (Cons cname arity _ args) = 
+     C.Rule [C.PVar "d", C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])]
+            (C.SimpleExpr (app (hasPresym "showString") 
+                             (app (hasPresym "show") 
+                               (fapp (sym (mkQName ("",localName cname)))
+                                    (map (toVar . mkIdx) [1..arity]))))) []
+
+   showGenerator = C.Rule [_x, 
+                         C.PComb (mkQName (newModName,name++"Or")) [C.PVar "r",_x]]
+                   (C.SimpleExpr 
+                       (app (hasPresym "showString") 
+                            (cons_ (char_ '_') 
+                                   (app (hasPresym "show") 
+                                        (app (cusym "deref")
+                                             (C.Var "r")))))) []
+
+readInstance :: Config.Options -> TypeDecl -> C.InstanceDecl
+readInstance opts (Type origName vis vars consdecls) =
+ C.Instance (map (\v -> C.TypeClass (has "Read") [toTVar v]) $  vars)
+   (C.TypeClass (has "Read") [C.TCons c (map toTVar vars)])
+   [if isTuple (localName origName) then readTuple else readsPrec]
+ where
+   c          = consName opts origName
+   newModName = Curry.ExtendedFlat.Type.modName c
+
+   readsPrec = C.Func (mkQName (newModName,"readsPrec")) (transvis vis) untyped 
+                  (Just [C.Rule [C.PVar "d",C.PVar "r"] 
+                          (C.SimpleExpr (plusplus (map read consdecls))) []])
+
+   plusplus = foldr1 (\x y->fapp (hasPresym "++") [x,y])
+
+   read cons@(Cons _ 0 _ []) = 
+     fapp (hasPresym "readParen") [hasPresym "False",lamb cons,C.Var "r"]
+   read cons = 
+     fapp (hasPresym "readParen") [lt (C.Var "d") app_prec,lamb cons,C.Var "r"]
+
+   lamb (Cons cn arity _ args) = C.Lambda [C.PVar "r"] 
+     (C.ListComp (fapp (sym (mkQName ("","(,)")))
+                     [fapp (sym newC) 
+                           (map (toVar . mkIdx) [1..arity]),
+                      toVar' "r" (mkIdx arity) ])
+        (C.SPat (pair (C.PVar "_") (toPVar' "r" 0)) 
+              (fapp (cusym "readQualified") [string_ (Curry.ExtendedFlat.Type.modName cn),string_ (localName cn),C.Var "r"]):
+         map (readArg . mkIdx) [1..arity]))
+
+     where
+       newC = consName opts cn
+    
+   readArg i = C.SPat (pair  (toPVar' "x" i) (toPVar' "r" i))
+                      (fapp (hasPresym "readsPrec") 
+                           [add_prec $ mkQName ("",""),
+                            toVar' "r" (i-1)])
+
+   readTuple = C.Func (mkQName (newModName,"readsPrec")) (transvis vis) untyped 
+                  (Just (map readTupleRule consdecls))
+
+   readTupleRule (Cons t arity _ args) =
+     C.Rule [C.PVar "d",C.PVar "r"] 
+       (C.SimpleExpr 
+          (fapp (hasPresym "map") [sym (mkQName ("","readTup")),
+                                   fapp (hasPresym "readsPrec") 
+                                        [C.Var "d",C.Var "r"]])) 
+       [C.LocalFunc (C.Func (mkQName ("","readTup")) (transvis vis) untyped 
+          (Just [C.Rule [pair (C.PComb (mkQName ("",localName t)) (map (toPVar . mkIdx) [1..arity])) 
+                              (C.PVar "s")] 
+                   (C.SimpleExpr   
+                      (fapp (sym (mkQName ("","(,)")))
+                         [fapp (sym (consName opts t)) (map (toVar . mkIdx) [1..arity]),
+                          C.Var "s"])) []]))]
+        
+   pair x y = C.PComb (mkQName ("","(,)")) [x,y]
+
+
+add_prec qn = case localName qn of
+                '(':_ -> cusym "zero"
+                _     -> cusym "eleven"
+
+app_prec = cusym "ten"
+
+lt x y = fapp (hasPresym ">") [x,y]
+
+int i = app (hasPresym "fromInteger") (C.Lit (C.Intc i))
+
+
+--------------------------
+-- naming conventions
+--------------------------
+
+consName,freeVarName,failName,orName,suspName :: Options -> QName -> QName
+consName opts qn
+  | m/=currentModule opts       = mkQName (N.modName m,cn)
+  | dataDef && isExtDataName    = mkQName (extDataModName m,cn)
+  | dataDef && existsDataModule = mkQName (dataModName m,cn)
+  | dataDef && existsInstModule = mkQName (instModName m,cn)
+  | dataDef                     = mkQName (N.modName m,cn)
+  | instDef && existsDataModule = mkQName (dataModName m,cn)
+  | instDef && isExtDataName    = mkQName (extDataModName m,cn)
+  | instDef && existsInstModule = mkQName (instModName m,cn)
+  | instDef                     = mkQName (N.modName m,cn)
+  | funcDef && existsInstModule = mkQName (instModName m,cn)
+  | funcDef && isExtDataName    = mkQName (extDataModName m,cn)
+  | funcDef                     = mkQName (N.modName m,cn)
+  where
+    m = Curry.ExtendedFlat.Type.modName qn
+    n = localName qn
+    existsDataModule = hasExtInsts opts
+    existsInstModule = hasData opts && hasExtFuncs opts
+    isExtDataName    = elem n (extData opts)
+
+    cn | extCons opts = n
+       | otherwise    = constructorName n
+    
+    instDef = consUse opts==InstanceDef
+    funcDef = consUse opts==FunctionDef
+    dataDef = consUse opts==DataDef
+
+-- FIXME N.freeVarName, failName, orName, suspName :: QName -> QName
+freeVarName opts = mkQName . N.freeVarName . qnOf . consName opts
+failName    opts = mkQName . N.failName    . qnOf . consName opts
+orName      opts = mkQName . N.orName      . qnOf . consName opts
+suspName    opts = mkQName . N.suspName    . qnOf . consName opts
+
+curryName s = mkQName ("Curry",s)
+curryTCons = C.TCons . curryName
+
+----------------------------------------
+-- treating the additional state argument
+----------------------------------------
+
+stateTypeName :: String
+stateTypeName = "State"
+
+addStateType :: C.TypeExpr -> C.TypeExpr
+addStateType t@(C.TVar _) = C.FuncType (curryTCons stateTypeName []) t
+addStateType t@(C.TCons _ _) = C.FuncType (curryTCons stateTypeName []) t
+addStateType (C.FuncType t1 t2) = C.FuncType t1 (addStateType t2)
+
+addStatePat :: [C.Pattern] -> [C.Pattern]
+addStatePat = (++[C.PVar "st"])
+
+addStateArg :: [C.Expr] -> [C.Expr]
+addStateArg = (++[C.Var "st"])
+
+-- global definitions must not have a state argument
+addGlobalDefs :: Options -> [FuncDecl] -> [(String,Bool,C.Prog)] -> [(String,Bool,C.Prog)]
+addGlobalDefs opts gs (x:xs@(_:_)) = x : addGlobalDefs opts gs xs
+addGlobalDefs opts gs [(s,b,prog)] = [(s,b,prog{C.funcDecls=gs'++C.funcDecls prog})]
+  where 
+    gs' = map transformGlobal gs
+    transformGlobal (Func n 0 vis t (Rule [] e)) = 
+    -- FIXME funName :: QName -> QName
+      C.Func (mkQName $ funName $ qnOf n) (transvis vis) (transFType opts 0 t) 
+        (Just [C.Rule [] 
+                 (C.SimpleExpr (transExpr opts e)) []])
+
+----------------------------------------------------------------
+-- constants and abbreviations for flat, resp. abstract curry
+----------------------------------------------------------------
+
+part opts i e = 
+  if i<2
+   then primValue opts (C.Lambda (addStatePat [toPVar' "v" 1]) e)
+   else primValue opts (C.Lambda [toPVar' "v" i, _x] (part opts (i-1) e))
+
+isPrelude :: Options -> Bool
+isPrelude opts = currentModule opts=="Prelude" 
+
+-- partial function call, one argument missing
+pf :: Options -> Int -> C.Expr -> C.Expr
+pf opts = app . partial opts (fapp (extFuncPresym opts "pf"))
+
+-- partial constructor call, one argument missing
+pc :: Options -> Int -> C.Expr -> C.Expr
+pc opts = app . partial opts (fapp (extFuncPresym opts "pc"))
+
+-- partial application, more than one argument
+pa :: Options -> [C.Expr] -> C.Expr
+pa opts = fapp (extFuncPresym opts "pa")
+
+-- function compostition (.)
+cp :: Options -> [C.Expr] -> C.Expr
+cp opts = fapp (extFuncPresym opts "cp")
+
+partial :: Options -> ([C.Expr] -> C.Expr) -> Int -> C.Expr
+partial opts part n
+  = foldr1 (\f g -> cp opts [f,g])
+  . map (\ (k,p) -> dotted opts (k-1) (p [])) 
+  $ reverse (zip (reverse [1..n]) (part:repeat (pa opts)))
+
+-- add a lot of dots to compose part call functions
+dotted :: Options -> Int -> C.Expr -> C.Expr
+dotted opts n p
+  | n == 0    = p
+  | otherwise = dotted opts (n-1) (cp opts [p])
+
+prelPCons opts s = C.PComb (consName opts (mkQName ("Prelude",s)))
+
+pO opts x = prelPCons opts "O"   [x]
+pI opts x = prelPCons opts "I"   [x]
+pIHi opts = prelPCons opts "IHi" []
+
+p0 opts     = prelPCons opts "Zero" []
+pPos opts x = prelPCons opts "Pos" [x]
+pNeg opts x = prelPCons opts "Neg" [x]
+
+public = C.Public
+
+isMain (_,fname) = fname=="main"
+
+isFirst (_,fname) = fname=="first"
+
+cunit opts = sym (consName opts{extCons=True} $ addPre "T0")
+
+-- types
+
+tFreeVarRef t = curryTCons "FreeVarRef" [t]
+
+tOrRef = curryTCons "OrRef" []
+
+tExceptions = curryTCons "C_Exceptions" []
+
+tSuspRef = curryTCons "SuspRef" []
+
+tList a = C.TCons (mkQName ("Prelude","[]")) [a]
+c_tList a = curryTCons "List" [a]
+
+tPair a b = C.TCons (mkQName ("Prelude","(,)")) [a,b]
+
+tMaybe a = C.TCons (mkQName ("Prelude","Maybe")) [a]
+
+tBranches x = curryTCons "Branches" [x]
+
+tSusp x = curryTCons "SuspCont" [x]
+
+private = C.Private
+
+untyped = Nothing
+
+noguard e = C.SimpleExpr e
+
+freeCall = cusym "freeF"
+
+orSym = cusym "orF"
+
+app a b = C.Apply a b
+
+app2 a b c = app (app a b) c
+
+fapp x xs = foldl C.Apply x xs
+
+flatApp = Comb FuncCall 
+
+flatBind x y = Comb FuncCall (flatPre ">>=") [x,y]
+
+flatEq x y = Comb FuncCall (flatPre "===") [x,y]
+
+flatPre s = mkQName ("Prelude",s)
+
+flatGst x = Comb FuncCall (flatPre "getSearchTree") [x]
+
+mid = hasPresym "id"
+
+sym = C.Symbol 
+
+cusym s = sym (cu s)
+
+fcusym s = sym (mkQName (funName ("Prelude",s)))
+
+
+
+basesym s = sym (ba s)
+
+baseTypesym isP s = sym (baseType isP s)
+
+baseType True  s = mkQName (dataModName "Prelude",s)
+baseType False s = mkQName (N.modName "Prelude",s)
+
+
+
+fbasesym opts s 
+  | currentModule opts=="Prelude" = sym (mkQName (extInstModName "Prelude",functionName s))
+  | otherwise = sym (mkQName (N.modName "Prelude",functionName s))
+
+
+cu s = mkQName ("Curry",s)
+ba s = mkQName ("Curry",s)
+
+toVar i = C.Var (xvar i)
+
+toVar' s i = C.Var (varName s i)
+
+xvar = varName "x"
+
+mkVarName :: String -> Int -> String
+mkVarName s i = s++show i
+
+varName :: String -> VarIndex -> String
+varName s i = mkVarName s (idxOf i)
+
+toPVar i = C.PVar (varName "x" i)
+
+toPVar' s i = C.PVar (varName s i)
+
+toTVar i = C.TVar (mkVarName "t" i)
+
+primValue opts v = 
+  app (sym $ consName opts{extCons=True} (addPre "PrimValue")) v
+
+
+-- FIXME
+addPre s = mkQName ("Prelude",s)
+has s = mkQName ("Prelude",s)
+
+
+toList [] = C.Symbol (mkQName ("","[]"))
+toList (x:xs) = app2 (C.Symbol (mkQName ("",":"))) x (toList xs)
+
+toPList [] = C.PComb (mkQName ("","[]")) []
+toPList (x:xs) = C.PComb (mkQName ("",":")) [x,toPList xs] 
+
+hasPresym s = sym (has s)
+
+
+
+toPLit opts (Intc _ i) = toPInt opts i
+toPLit opts (Charc _ c) = toPChar opts c
+toPLit opts (Floatc _ f) = toPFloat opts f
+
+toPInt opts n 
+  | n>0  = pPos opts (toPNat opts n)
+  | n<0  = pNeg opts (toPNat opts (negate n))
+  | n==0 = p0 opts
+
+toPNat opts n 
+  | d==0 = pIHi opts
+  | m==1 = pI opts (toPNat opts d)
+  | m==0 = pO opts (toPNat opts d)
+  where
+    d = div n 2
+    m = mod n 2
+
+toPChar opts c 
+  | currentModule opts=="Prelude" = C.PComb (mkQName (dataModName "Prelude","C_Char")) [C.PLit (C.Charc c)]
+  | otherwise = C.PComb (mkQName (N.modName "Prelude","C_Char")) [C.PLit (C.Charc c)]
+
+toPFloat opts n = primPValue opts (C.PLit (C.Floatc n))
+
+primPValue opts p =  C.PComb (consName opts{extCons=True} (addPre "PrimValue")) [p]
+
+toLit opts (Intc _ i) = toInt i
+toLit opts (Charc _ c) = toChar opts c
+toLit opts (Floatc _ f) = toFloat opts f
+
+toInt n  = C.Lit (C.Intc (toInteger n))
+toHInt n = C.Lit (C.HasIntc (toInteger n))
+
+c_int isP =  baseTypesym isP "C_Int"
+
+toChar opts c = app (sym (consName opts (mkQName ("Prelude","Char")))) (C.Lit (C.Charc c))
+toFloat opts f = primValue opts (C.Lit (C.Floatc f))
+
+
+
+otherwiseExp n e = [C.Rule (map C.PVar (take n (repeat "_")))
+                           (noguard e) []]
+
+ioT x = TCons (mkQName ("Prelude","IO")) [x]
+unitT = TCons (mkQName ("Prelude","()")) []
+
+hasUnit = sym (mkQName ("","()"))
+
+hasBind x y = fapp (hasPresym ">>=") [x,y]
+hasReturn x = app (hasPresym "return") x
+
+char_ c = C.Lit (C.Charc c)
+
+list_ [] = nil 
+list_ (x:xs) = cons_ x (list_ xs)
+
+cons_ x xs = fapp (sym (mkQName ("",":"))) [x,xs]
+nil = sym (mkQName ("","[]"))
+
+string_ n = list_ (map char_ n)
+
+c_char_ c = fapp (basesym "C_Char") [C.Lit (C.Charc c)]
+
+c_list_ [] = c_nil
+c_list_ (x:xs) = c_cons_ x (c_list_ xs)
+
+c_cons_ x xs = fapp (sym (mkQName ("DataPrelude",":<"))) [x,xs]
+c_nil = sym (mkQName ("DataPrelude","List"))
+
+bc_list_ [] = bc_nil
+bc_list_ (x:xs) = bc_cons_ x (bc_list_ xs)
+
+dList True  = bc_list_
+dList False = c_list_
+
+dpList True  = bc_plist_
+dpList False = c_plist_
+
+bc_cons_ x xs = fapp (sym (mkQName ("DataPrelude",":<"))) [x,xs]
+bc_nil = sym (mkQName ("DataPrelude","List"))
+
+c_string_ "Prelude" n = bc_list_ (map c_char_ n)
+c_string_ _         n =  c_list_ (map c_char_ n)
+
+pchar_ c = C.PLit (C.Charc c)
+
+plist_ [] = pnil 
+plist_ (x:xs) = pcons_ x (plist_ xs)
+
+pcons_ x xs = C.PComb (mkQName ("",":")) [x,xs]
+pnil = C.PComb (mkQName ("","[]")) []
+
+c_plist_ [] = c_pnil 
+c_plist_ (x:xs) = c_pcons_ x (c_plist_ xs)
+
+c_pcons_ x xs = C.PComb (mkQName ("DataPrelude",":<")) [x,xs]
+c_pnil = C.PComb (mkQName ("DataPrelude","List")) []
+
+bc_plist_ [] = bc_pnil 
+bc_plist_ (x:xs) = bc_pcons_ x (bc_plist_ xs)
+
+bc_pcons_ x xs = C.PComb (mkQName ("DataPrelude",":<")) [x,xs]
+bc_pnil = C.PComb (mkQName ("DataPrelude","List")) []
+
+
+pstring_ n = plist_ (map pchar_ n)
+
+underscores i = replicate i (_x)
+
+qname_ (m,f) = string_ (m++'.':f)
+
+extInstPresym True  s = sym $ mkQName (extInstModName "Prelude",s)
+extInstPresym False s = sym $ mkQName (N.modName "Prelude",s)
+
+extFuncPresym opts s 
+  | isPrelude opts = sym $ mkQName (extFuncModName "Prelude",s)
+  | otherwise      = sym $ mkQName (N.modName "Prelude",s)
+
+
+_x = C.PVar "_"
+
+st = C.Var "st"
+
diff --git a/src/FunctionalProg.hs b/src/FunctionalProg.hs
new file mode 100644
--- /dev/null
+++ b/src/FunctionalProg.hs
@@ -0,0 +1,251 @@
+------------------------------------------------------------------------------
+--- Library to support meta-programming in Curry.
+---
+--- This library contains a definition for representing Haskell programs
+--- in Curry (type "CurryProg") and an I/O action to read Curry programs and
+--- transform them into this abstract representation (function "readCurry").
+---
+--- Note this defines a slightly new format for AbstractCurry
+--- in comparison to the first proposal of 2003.
+---
+--- The Difference to AbstractCurry for now is only the deriving construct.
+---
+--- Assumption: an abstract Curry program is stored in file prog.acy
+---             and translated with the parser by "parsecurry -acy prog".
+---
+--- @author Michael Hanus, Bernd Braßel
+--- @version August 2005
+------------------------------------------------------------------------------
+
+module FunctionalProg where
+
+import Curry.ExtendedFlat.Type(QName)
+
+
+------------------------------------------------------------------------------
+-- Definition of data types for representing abstract Curry programs:
+-- ==================================================================
+
+--- Data type for representing a Curry module in the intermediate form.
+--- A value of this data type has the form
+--- <CODE>
+---  (CProg modname imports typedecls functions opdecls)
+--- </CODE>
+--- where modname: name of this module,
+---       imports: list of modules names that are imported,
+---       typedecls, opdecls, functions: see below
+
+data Prog = Prog { progName :: String,
+                   imports,exports ::[String],
+                   typeDecls :: [TypeDecl],
+                   instanceDecls :: [InstanceDecl],
+                   funcDecls :: [FuncDecl],
+                   opDecls :: [OpDecl] } deriving (Show,Eq,Read)
+
+emptyProg = Prog "" [] [] [] [] [] []
+
+
+--- The data type for representing qualified names.
+--- In AbstractCurry all names are qualified to avoid name clashes.
+--- The first component is the module name and the second component the
+--- unqualified name as it occurs in the source program.
+-- type QName = (String,String)
+
+
+-- Data type to specify the visibility of various entities.
+
+data Visibility = Public    -- exported entity
+                | Private   -- private entity
+                  deriving (Show,Eq,Read)
+
+
+--- The data type for representing type variables.
+--- They are represented by (i,n) where i is a type variable index
+--- which is unique inside a function and n is a name (if possible,
+--- the name written in the source program).
+type VarName = String
+
+--- Data type for representing definitions of algebraic data types
+--- and type synonyms.
+--- <PRE>
+--- A data type definition of the form
+---
+--- data t x1...xn = ...| c t1....tkc |...
+---
+--- is represented by the Curry term
+---
+--- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])
+---
+--- where each ij is the index of the type variable xj
+---
+--- Note: the type variable indices are unique inside each type declaration
+---       and are usually numbered from 0
+---
+--- Thus, a data type declaration consists of the name of the data type,
+--- a list of type parameters and a list of constructor declarations.
+--- </PRE>
+
+data TypeDecl = Type { 
+                         typeName :: QName,
+                         typeVis  :: Visibility,
+                         typeVars :: [VarName],
+                         consDecls :: [ConsDecl],
+                         derive ::  [String]}
+              | TypeSyn 
+                       { typeName :: QName,
+                         typeVis  :: Visibility,
+                         typeVars :: [VarName],
+                         typeExpr :: TypeExpr}
+                 deriving (Show,Eq,Read)
+
+--- For a type declaration the membership to certain classes can be derived in 
+--- Haskell.
+
+data TypeClass = TypeClass { className :: QName, 
+                             classArgs :: [TypeExpr]} deriving (Show,Eq,Read)
+
+data InstanceDecl = Instance {
+                      constraint :: [TypeClass],
+                      instanciated :: TypeClass,
+                      instanceFunc :: [FuncDecl]} deriving (Show,Eq,Read)
+
+--- A constructor declaration consists of the name and arity of the
+--- constructor and a list of the argument types of the constructor.
+
+data ConsDecl = Cons { consName :: QName,
+                       consArity :: Int, 
+                       consVis :: Visibility,
+                       strictArgs :: Bool,
+                       consArgs :: [TypeExpr]} deriving (Show,Eq,Read)
+
+
+--- Data type for type expressions.
+--- A type expression is either a type variable, a function type,
+--- or a type constructor application.
+---
+--- Note: the names of the predefined type constructors are
+---       "Int", "Float", "Bool", "Char", "IO", "Success",
+---       "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+
+data TypeExpr =
+    TVar VarName               -- type variable
+  | FuncType TypeExpr TypeExpr  -- function type t1->t2
+  | TCons QName [TypeExpr]       -- type constructor application
+                                   -- (CTCons (module,name) arguments)
+  | TConstr [TypeClass] TypeExpr
+                   deriving (Show,Eq,Read)
+
+
+--- Data type for operator declarations.
+--- An operator declaration "fix p n" in Curry corresponds to the
+--- AbstractCurry term (COp n fix p).
+
+data OpDecl = Op QName Fixity Integer deriving (Show,Eq,Read)
+
+data Fixity = InfixOp   -- non-associative infix operator
+            | InfixlOp  -- left-associative infix operator
+            | InfixrOp  -- right-associative infix operator
+                   deriving (Show,Eq,Read)
+
+
+--- Data types for representing object variables.
+--- Object variables occurring in expressions are represented by (Var i)
+--- where i is a variable index.
+
+--- Data type for representing function declarations.
+--- <PRE>
+--- A function declaration in FlatCurry is a term of the form
+---
+---  (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))
+---
+--- and represents the function "name" with definition
+---
+---   name :: type
+---   rule1
+---   ...
+---   rulek
+---
+--- Note: the variable indices are unique inside each rule
+---
+--- External functions are represented as (CFunc name arity type (CExternal s))
+--- where s is the external name associated to this function.
+---
+--- Thus, a function declaration consists of the name, arity, type, and
+--- a list of rules.
+--- </PRE>
+
+data FuncDecl = Func { funcName :: QName,
+                       funcVis :: Visibility,
+                       funcType :: Maybe TypeExpr,
+                       funcBody ::  Maybe [Rule]} deriving (Show,Eq,Read)
+
+
+--- A rule is either a list of formal parameters together with an expression
+--- (i.e., a rule in flat form), a list of general program rules with
+--- an evaluation annotation, or it is externally defined
+
+--- The most general form of a rule. It consists of a list of patterns
+--- (left-hand side), a list of guards ("success" if not present in the
+--- source text) with their corresponding right-hand sides, and
+--- a list of local declarations.
+data Rule = Rule { patterns :: [Pattern],
+                   rhs :: Rhs,
+                   locDecls :: [LocalDecl]}
+                   deriving (Show,Eq,Read)
+
+data Rhs = SimpleExpr Expr | GuardedExpr [(Expr,Expr)] deriving (Show,Eq,Read)
+
+
+--- Data type for representing local (let/where) declarations
+data LocalDecl =
+     LocalFunc FuncDecl                 -- local function declaration
+   | LocalPat  Pattern Expr [LocalDecl] -- local pattern declaration
+                   deriving (Show,Eq,Read)
+
+--- Data type for representing Curry expressions.
+
+data Expr =
+   Var      VarName              -- variable (unique index / name)
+ | Lit      Literal               -- literal (Integer/Float/Char constant)
+ | Symbol   QName                  -- a defined symbol with module and name
+ | Apply    Expr Expr            -- application (e1 e2)
+ | Lambda   [Pattern] Expr       -- lambda abstraction
+ | LetDecl  [LocalDecl] Expr     -- local let declarations
+ | DoExpr   [Statement]           -- do expression
+ | ListComp Expr [Statement]     -- list comprehension
+ | Case     Expr [BranchExpr]    -- case expression
+ | String   String 
+ deriving (Show,Eq,Read)
+
+--- Data type for representing statements in do expressions and
+--- list comprehensions.
+
+data Statement = SExpr Expr         -- an expression (I/O action or boolean)
+               | SPat Pattern Expr -- a pattern definition
+               | SLet [LocalDecl]   -- a local let declaration
+               deriving (Show,Eq,Read)
+
+--- Data type for representing pattern expressions.
+
+data Pattern =
+   PVar VarName         -- pattern variable (unique index / name)
+ | PLit Literal          -- literal (Integer/Float/Char constant)
+ | PComb QName [Pattern] -- application (m.c e1 ... en) of n-ary
+                           -- constructor m.c (CPComb (m,c) [e1,...,en])
+ | AsPat VarName Pattern
+                   deriving (Show,Eq,Read)
+
+--- Data type for representing branches in case expressions.
+
+data BranchExpr = Branch Pattern Expr
+                   deriving (Show,Eq,Read)
+
+--- Data type for representing literals occurring in an expression.
+--- It is either an integer, a float, or a character constant.
+
+data Literal = Intc   Integer
+             | HasIntc Integer
+             | Floatc Double
+             | Charc  Char
+                   deriving (Show,Eq,Read)
+
diff --git a/src/InstallDir.hs b/src/InstallDir.hs
new file mode 100644
--- /dev/null
+++ b/src/InstallDir.hs
@@ -0,0 +1,3 @@
+module InstallDir where
+installDir = "/home/bbr/kics"
+ghc_call= "/home/ghc/bin/ghc"
diff --git a/src/KicsSubdir.hs b/src/KicsSubdir.hs
new file mode 100644
--- /dev/null
+++ b/src/KicsSubdir.hs
@@ -0,0 +1,132 @@
+module KicsSubdir where
+
+import System.Directory
+import System.FilePath
+import System.Time (ClockTime)
+import List (intersperse,nubBy)
+
+curDirPath :: FilePath
+curDirPath = "."
+
+path :: String -> [String]
+path = canonPath . separateBy isPathSeparator 
+  where
+    canonPath (c:cs) = c:filter (not . null) cs
+    canonPath [] = []
+
+-- separate a list by separator predicate
+
+separateBy :: (a -> Bool) -> [a] -> [[a]]
+separateBy p = sep id 
+  where
+    sep xs [] = [xs []]
+    sep xs (c:cs) = if p c then xs [] : sep id cs
+                           else sep (xs . (c:)) cs
+
+unpath :: [String] -> String
+unpath = concat . intersperse [pathSeparator]
+
+toPathList :: [String] -> String
+toPathList = concat . intersperse [searchPathSeparator]
+
+
+--When we split a path into its basename and directory we will make
+--sure that the basename does not contain any path separators.
+ 
+dirname, basename :: FilePath -> FilePath
+dirname  = unpath . init . path
+basename = last . path
+
+-- add a subdirectory to a given filename 
+-- if it is not already present
+
+inSubdir :: String -> String -> String
+inSubdir fn sub = unpath $ add (path fn) 
+  where
+    add ps@[_] = sub:ps
+    add ps@[p,_] | p==sub = ps
+    add (p:ps) = p:add ps
+    add [] = error "inSubdir: empty path"
+
+withoutSubdir :: String -> String -> String
+withoutSubdir fn sub = unpath $ rmv (path fn) 
+  where
+    rmv [] = []
+    rmv [p,n]  | p==sub = [n]
+    rmv (p:ps) = p:rmv ps
+
+
+--The sub directory to hide files in:
+
+currySubdir :: String 
+currySubdir = ".curry"
+
+inCurrySubdir :: String -> String
+inCurrySubdir = (`inSubdir` currySubdir)
+
+kicsSubdir :: String
+kicsSubdir = "kics"
+
+addKicsSubdir :: String -> String
+addKicsSubdir s = unpath [s,currySubdir,kicsSubdir]
+
+pathWithSubdirs :: [FilePath] -> [FilePath]
+pathWithSubdirs = concatMap dirWithSubdirs
+  where
+    dirWithSubdirs dir = [dir,unpath [dir,currySubdir,[pathSeparator]],
+                              unpath [dir,currySubdir,kicsSubdir,[pathSeparator]]] 
+
+inKicsSubdir :: String -> String
+inKicsSubdir s = inCurrySubdir s `inSubdir` kicsSubdir
+
+--write a file to curry subdirectory
+
+writeKicsFile :: String -> String -> IO String
+writeKicsFile filename contents = do
+  let filename' = inKicsSubdir filename 
+      subdir = dirname filename'
+  createDirectoryIfMissing True subdir
+  writeFile filename' contents
+  return filename'
+
+-- do things with file in subdir
+
+onExistingFileDo :: (String -> IO a) -> String -> IO a
+onExistingFileDo act fn = do
+  let filename = fn --(fn `withoutSubdir` kicsSubdir) 
+  ex <- doesFileExist filename
+  if ex then act filename 
+    else do
+      let filename' = inCurrySubdir filename
+      ex' <- doesFileExist filename'
+      if ex' then act filename' 
+        else do
+          let filename'' = inKicsSubdir filename
+          act filename''
+
+readModule :: String -> IO String
+readModule = onExistingFileDo readFile
+
+maybeReadModule :: String -> IO (Maybe String)
+maybeReadModule filename = 
+  catch (readModule filename >>= return . Just) (\_ -> return Nothing)
+
+doesModuleExist :: String -> IO Bool
+doesModuleExist = onExistingFileDo doesFileExist
+
+getModuleModTime :: String -> IO ClockTime
+getModuleModTime = onExistingFileDo getModificationTime
+
+findFileInPath :: String -> [String] -> IO [String]
+findFileInPath fn p = do
+   if any isPathSeparator fn 
+     then findFile fn
+     else do
+       let fs = nubBy equalFilePath $ map (++fn) p
+       founds <- mapM findFile fs
+       return (nubBy equalFilePath $ concat founds)
+
+  where
+    findFile = onExistingFileDo doesExist
+    doesExist fn' = do ex <- doesFileExist fn'
+                       return [ fn' | ex ]
diff --git a/src/MyReadline.hs b/src/MyReadline.hs
new file mode 100644
--- /dev/null
+++ b/src/MyReadline.hs
@@ -0,0 +1,6 @@
+module MyReadline (readline, addHistory,initializeReadline) where
+
+import System.Console.Readline
+
+initializeReadline :: IO ()
+initializeReadline = return ()
diff --git a/src/Names.hs b/src/Names.hs
new file mode 100644
--- /dev/null
+++ b/src/Names.hs
@@ -0,0 +1,110 @@
+module Names where
+
+import Char
+import List
+import System.FilePath
+
+import ShowFunctionalProg (isTuple,isInfixOpName)
+
+---------------------------------------------------------------------------
+-- generating names to avoid clashes with Haskell
+---------------------------------------------------------------------------
+-- constructor names
+
+preludeConstructorName "()" = "T0"
+preludeConstructorName "[]" = "List"
+preludeConstructorName ":"  = ":<"
+preludeConstructorName n 
+  | isTuple n = "T"++show (1+length (takeWhile (==',') (tail n)))
+  | otherwise = 'C':'_':n
+
+constructorName = preludeConstructorName
+
+consName extFuncs (m,n) = 
+  case m of
+   "Prelude" -> (dataDefMod extFuncs m,preludeConstructorName n)
+   ""        -> ("",preludeConstructorName n)
+   _         -> (dataDefMod extFuncs m,constructorName n)
+
+
+{-
+extConsName exts (m,n) = case m of
+   "Prelude" -> (datamod m,preludeConstructorName n)
+   ""        -> ("",preludeConstructorName n)
+   _         -> (datamod m,constructorName n)
+  where
+    datamod = if elem (m,n) exts then extDataModName else dataModName
+-}
+
+dataDefMod :: Bool -> String -> String
+dataDefMod False = modName
+dataDefMod True  = instModName
+
+-- function names
+preludeFunctionName s@"share" = s
+preludeFunctionName n = functionName n
+
+functionName n | isInfixOpName n = elimInfix n 
+               | otherwise = 'c':'_':n
+
+funName (p@"Prelude",n) = (modName p,preludeFunctionName n)
+funName (m,n) = (modName m,functionName n)
+
+elimInfix name = "op_"++concat (intersperse "_" (map (show . ord) name))
+
+-----------------------------------------
+-- naming conventions for new objects
+-----------------------------------------
+-- module names
+
+insertName :: String -> FilePath -> FilePath
+insertName s xs = replaceFileName xs (s++takeFileName xs)
+
+modName s = insertName "Curry" s
+
+dataMName = "Data"
+instMName = "Instances"
+funcMName = "Functions"
+dbgMName  = "Oracle"
+
+external = insertName "External"
+
+extDataMName = external dataMName
+extInstMName = external instMName
+extFuncMName = external funcMName
+
+dataModName = insertName dataMName 
+instModName = insertName instMName 
+funcModName = insertName funcMName 
+dbgModName  = insertName dbgMName
+
+extDataModName = insertName extDataMName 
+extInstModName = insertName extInstMName 
+extFuncModName = insertName extFuncMName 
+
+dataHsName s = replaceExtension (dataModName s) ".hs"
+instHsName s = replaceExtension (instModName s) ".hs"
+funcHsName s = replaceExtension (modName s)     ".hs"
+
+extDataHsName s = replaceExtension (extDataModName s) ".hs"
+extInstHsName s = replaceExtension (extInstModName s) ".hs"
+extFuncHsName s = replaceExtension (extFuncModName s) ".hs"
+
+externalSpecName s = replaceExtension (external s) ".spec"
+
+strictPrefix = "S"
+
+mkStrictName = insertName strictPrefix
+
+
+-- names for new constructors
+--addPrefix s _ (p@"Prelude","Int")   = (instModName p,"C_Int"++s)
+--addPrefix s _ (p@"Prelude","Float") = (instModName p,"Prim"++s)
+addPrefix s (m,n) = (m,n++s)
+
+freeVarName = addPrefix "FreeVar"
+failName    = addPrefix "Fail"
+orName      = addPrefix "Or"
+suspName    = addPrefix "Susp"
+
+
diff --git a/src/PreTrans.hs b/src/PreTrans.hs
new file mode 100644
--- /dev/null
+++ b/src/PreTrans.hs
@@ -0,0 +1,307 @@
+{-# OPTIONS -cpp #-} 
+--------------------------------
+-- preliminary transformations
+--------------------------------
+module PreTrans 
+  where
+
+import Maybe
+import List hiding (nub)
+
+import Curry.Base.Position(noRef)
+
+import Curry.ExtendedFlat.Type
+import Curry.ExtendedFlat.Goodies
+
+
+
+
+import qualified Data.Map as FM
+
+
+
+-------------------------------------------------------------------------------
+-- some auxiliary functions
+-------------------------------------------------------------------------------
+
+
+transFM :: Ord k => (a -> Bool) -> (FuncDecl -> (k, a)) -> [Prog] -> FM.Map k a
+transFM p f ps = FM.fromList (filter (p . snd) (map f (allFuncs ps)))
+
+
+allFuncs :: [Prog] -> [FuncDecl]
+allFuncs ps = concatMap progFuncs ps
+
+--- compute number of arguments by function type 
+typeArity :: TypeExpr -> Int
+typeArity (TVar _) = 0
+typeArity (TCons _ _) = 0
+typeArity (FuncType _ t2) = 1+typeArity t2
+
+
+-- FIXME stupid
+maxL :: (Num a, Ord a) => [a] -> a
+maxL = foldl max 0 
+
+
+--- is root type constructor IO?
+isIOType :: TypeExpr -> Bool
+isIOType = trTypeExpr (const False) (\ q _ -> q==(pre "IO")) (\ _ _ -> False)
+
+------------------------------------------------------------
+-- eliminate case on character
+------------------------------------------------------------
+
+noCharCase :: Prog -> Prog
+noCharCase = updProgFuncs (map (updFuncBody noCCase))
+
+noCCase :: Expr -> Expr
+noCCase = trExpr Var Lit Comb Let Free Or noCCaseExpr noCCaseBr
+
+noCCaseExpr :: SrcRef -> CaseType -> Expr -> [Expr -> Either (Expr,Expr) BranchExpr] -> Expr
+noCCaseExpr pos ct v bs = 
+  either (foldr ifte (Comb FuncCall (pre "failed") [])) (Case pos ct v) (lrs (map ($ v) bs))
+  where
+    lrs (Left  x:xs) = Left (x:map (either id (error "PreTrans.noCCaseExpr Right?")) xs)
+    lrs (Right x:xs) = Right (x:map (either (error "PreTrans.noCCaseExpr Left?") id) xs)
+    -- FIXME Patterns not matched: []
+
+    ifte (b,e1) e2 = Comb FuncCall (pre "if_then_else") [b,e1,e2]
+
+noCCaseBr :: Pattern -> Expr -> Expr -> Either (Expr,Expr) BranchExpr
+noCCaseBr (LPattern c@(Charc _ _)) e v = 
+  Left (Comb FuncCall (pre "===") [v,Lit c],e)
+noCCaseBr p e _ = Right (Branch p e)
+
+------------------------------------------------------------
+-- eliminate nested case expressions
+------------------------------------------------------------
+
+--- @param - the program to be transformed
+liftCases :: Bool -> Prog -> Prog
+liftCases nestedOnly p = 
+  let fs  = progFuncs p
+      aux = genAuxName (map (localName . funcName) fs)
+      (exts,ins) = partition isExternal fs
+      (newFsf,_,auxFf) = foldr (liftCasesFunc nestedOnly (progName p) aux) 
+                               (id,0,id) 
+                               ins
+   in updProgFuncs (const (newFsf (auxFf exts))) p
+
+type FuncList = [FuncDecl] -> [FuncDecl]
+type Result = (FuncList,Int,FuncList)
+
+liftCasesFunc :: Bool -> String -> String -> FuncDecl -> Result -> Result
+liftCasesFunc onlyNested mod aux f (es,i0,ff) = 
+  ((updFuncBody (const exp) f:) . es,i',ff . ffe)
+  where
+    body = funcBody f
+
+    (exp,i',ffe,_) = 
+     if onlyNested then (case body of
+      Case p cm e@(Var _) bs -> 
+         let (e',i',ffe,_)    = trans e i0
+             (bs',i'',ffbs,_) = 
+               fold i' (map (\ (Branch pat be) -> branch pat (trans be)) bs)
+          in (Case p cm e' bs', i'',ffe . ffbs,[])
+      _            -> trans body i0)
+     else trans body i0
+           
+    trans = trExpr var lit comb leT freE or casE branch
+
+    var v i = (Var v,i,id,[v])
+    lit l i = (Lit l,i,id,[])
+    comb ct n args i = let (args',i',ff,vs) = fold i args
+      in (Comb ct n args',i',ff,vs)
+    leT bs e i = 
+      let (vs,es)  = unzip bs 
+          (es',i',ffes,ves) = fold i es
+          (e',i'',ffe,ve) = e i'
+      in (Let (zip vs es') e',i'', ffes . ffe,
+          filter (not . elemOf vs) (ves ++ ve))
+    freE vs e i = 
+      let (e',i',ff,ve) = e i 
+       in (Free vs e',i',ff,filter (not . elemOf vs) ve)
+    or e1 e2 i = 
+      let ([e1',e2'],i',ff',vs) = fold i [e1,e2]
+       in (Or e1' e2',i',ff',vs)
+    casE _ ct e bs i = 
+      let (e',i',ffe',ve)     = e i
+          (bs',i'',ffbs,vbs) = fold i' bs
+          envRes = nub (ve ++ vbs)
+          env = case e' of
+                  Var v -> delete v envRes
+                  _     -> envRes
+       in (genFuncCall (localName $ funcName f) mod aux i'' env e',i''+1,
+           (genFunc (localName $ funcName f) mod aux i'' env e' ct bs':) . ffe' . ffbs,
+           envRes)
+    branch p e i = 
+      let (e',i'',ff',ve) = e i
+       in (Branch p e',i'',ff',removePVars ve p)
+
+
+fold :: a -> [a -> (c,a,d -> d,[e])] -> ([c],a,d -> d,[e])
+fold i = foldr once ([],i,id,[])
+  where
+    once f (es,j,ff1,vs1) = let (e,k,ff2,vs2) = f j
+                             in (e:es,k,ff1 . ff2,vs1++vs2)
+
+
+genFuncCall :: String -> String -> String -> Int -> [VarIndex] -> Expr -> Expr
+genFuncCall f m aux i env e = 
+  Comb FuncCall (mkQName (m, f++aux++show i)) (map Var env ++ [e])
+
+
+genFunc :: String -> String -> String -> Int -> [VarIndex] -> Expr ->
+           CaseType -> [BranchExpr] -> FuncDecl
+genFunc f m aux i env e ct bs = 
+  Func (mkQName (m, f++aux++show i)) (length env+1) Private (TVar (-42)) $
+       Rule (env++[v]) (Case noRef ct (Var v) bs)
+  where
+    v = case e of 
+         Var idx -> idx
+         _       -> foldr max 0 env + 1
+
+
+removePVars :: [VarIndex] -> Pattern -> [VarIndex]
+removePVars e = trPattern (\ _ vs -> filter (not . elemOf vs) e) (const e)
+
+genAuxName :: [String] -> String
+genAuxName = foldl addUnderscores "_case_"
+
+addUnderscores :: String -> String -> String
+addUnderscores n m = if isPrefixOf n m then addUnderscores (n++"_") m else n     
+
+elemOf :: Eq a => [a] -> a -> Bool
+elemOf = flip elem
+
+nub :: Ord k => [k] -> [k]
+nub xs = map fst $ FM.toList $ FM.fromList $ zip xs (repeat ())
+
+------------------------------------------------------------
+-- elimination of constants
+------------------------------------------------------------
+
+externalConstants :: [QName]
+externalConstants = map (curry mkQName "Prelude") ["success","failed"] ++
+                    map (curry mkQName "IO") ["stdin","stdout","stderr"]
+
+
+isToElim :: Rule -> TypeExpr -> Bool
+isToElim (Rule _ _) t = typeArity t==0 && t /= TVar (-42)
+isToElim (External _) _ = False
+
+
+mapExp :: (Expr -> Expr) -> Expr -> Expr
+mapExp f (Var i) = f (Var i)
+mapExp f (Lit l) = f (Lit l)
+mapExp f (Comb ct n es) = f (Comb ct n (map (mapExp f) es))
+mapExp f (Let vbs e) = let (vs,bs) = unzip vbs in 
+  Let (zip vs (map (mapExp f) bs)) (mapExp f e)
+mapExp f (Free vs e) = Free vs (mapExp f e)
+mapExp f (Or e1 e2) = Or (mapExp f e1) (mapExp f e2)
+mapExp f (Case pos ct e bs) = Case pos ct (mapExp f e) (map mbr bs)
+  where
+    mbr (Branch p be) = Branch p (mapExp f be)
+-- FIXME Patterns not matched: _ (TypedExpr _ _)
+
+
+elimConsts :: [Prog] -> Prog -> Prog
+elimConsts interfaces p@(Prog pn is ts fs os) = 
+  Prog pn is ts (map elimConstsF fs) os
+  where
+    constsfm = transFM id ftypeArity (p:interfaces)
+
+    ftypeArity (Func mn _ _ t r) = (mn,isToElim r t)
+
+    elimConstsF f@(Func _ _ _ _ (External _)) = f
+    elimConstsF (Func n a v t r@(Rule vs e)) 
+      | isToElim r t = 
+          Func n (a+1) v (FuncType unitType t) 
+                 (Rule [maxL (allVars e) + 1] (mapExp elimConstsE e))
+      | otherwise = Func n a v t (Rule vs (mapExp elimConstsE e)) 
+
+    elimConstsE e = case e of
+      Comb FuncCall fn [] -> if FM.member fn constsfm
+                               then Comb FuncCall fn [unit]
+                               else e
+      _ -> e
+
+
+unit :: Expr
+unit = Comb ConsCall (pre "()") []
+
+unitType :: TypeExpr
+unitType = TCons (pre "()") []
+
+pre :: String ->QName
+pre s = mkQName ("Prelude",s)
+
+------------------------------------------------------------
+-- typing ambiguous type variables
+------------------------------------------------------------
+
+makeTypeMap :: [Prog] -> QName -> QName
+makeTypeMap ps s = maybe (errorMsg s) id (FM.lookup s fm)
+  where
+    fm = FM.fromList (concatMap typeMapTypeDecl (concatMap typeDecls ps))
+    errorMsg qn = error ("PreTrans.makeTypeMap: cannot find type"++
+                            " of constructor "++modName qn++"."++localName qn)
+
+
+typeMapTypeDecl :: TypeDecl -> [(QName, QName)]
+typeMapTypeDecl (TypeSyn _ _ _ _) = []
+typeMapTypeDecl (Type tn _ _ consDecls) = 
+    zip (map (\ (Cons name _ _ _) -> name) consDecls) (repeat tn)
+
+
+typeDecls :: Prog -> [TypeDecl]
+typeDecls (Prog _ _ ts _ _) = ts
+
+------------------------------------------------------------
+-- global states 
+------------------------------------------------------------
+
+splitGlobals :: Prog -> ([FuncDecl],Prog)
+splitGlobals prog  
+  | progName prog == "Global" = ([],prog)
+  | all okDef toTest = (gs,updProgFuncs (const fs) prog) 
+  | otherwise    = error $ "function global not allowed in this context " 
+                           ++ show (map funcName (filter (not . okDef) gs))
+  where
+    (toTest,_) = partition (containsGlobal . resultType . funcType) 
+                                  (progFuncs prog) 
+
+    (gs,fs) = partition isGlobalDecl (progFuncs prog) 
+
+    isGlobal (TCons qn _)
+        | qnOf qn == ("Global","Global") = True
+    isGlobal _                           = False
+
+    isGlobalDecl f = isGlobal (funcType f) && isGlobalDef (funcBody f)
+
+    containsGlobal (TVar _) = False
+    containsGlobal t@(TCons _ args) = isGlobal t || any containsGlobal args
+    containsGlobal (FuncType _ _) = False
+
+    isGlobalDef (Comb FuncCall qn _)
+        | qnOf qn == ("Global","global") = True
+    isGlobalDef _                        = False
+
+    okDef f 
+      | isGlobal (funcType f) && isGlobalDef (funcBody f) = 
+        isMonomorph (funcType f)
+      | otherwise = noCallToGlobal (funcBody f)
+
+    noCallToGlobal = trExpr (\_->True) (\_->True)
+                            (\ _ n args -> qnOf n/=("Global","global") 
+                                           && and args)
+                            (\bs e->and (e:map snd bs)) 
+                            (\_ ->id) (&&)
+                            (\_ _ e bs -> and (e:bs)) (\_->id)
+
+isMonomorph :: TypeExpr -> Bool
+isMonomorph (TVar _)       = False
+isMonomorph (TCons _ xs)   = all isMonomorph xs
+isMonomorph (FuncType a b) = all isMonomorph [a,b]
+
diff --git a/src/SafeCalls.hs b/src/SafeCalls.hs
new file mode 100644
--- /dev/null
+++ b/src/SafeCalls.hs
@@ -0,0 +1,45 @@
+{-# OPTIONS -cpp  #-} 
+module SafeCalls(SafeIO, safeSystem, safeIO, safeIOSeq, safe) where
+
+import Control.Monad.Error
+
+
+#if __GLASGOW_HASKELL__ >= 610
+import Control.OldException 
+#else
+import Control.Exception 
+#endif
+
+import Prelude hiding (catch)
+import System
+
+--------------------
+-- safe calls
+--------------------
+
+type SafeIO = ErrorT String IO
+
+safeSystem :: Bool -> String -> SafeIO ()
+safeSystem _ "" = return ()
+safeSystem verbose sysCall = do
+  when verbose $ liftIO $ putStrLn sysCall
+  ec <- liftIO $ system sysCall
+  if ec==ExitSuccess then return () else fail ("safeSystem: "++show ec)
+
+safeIO :: IO a -> SafeIO a
+safeIO action = foo (liftM Right action)
+
+safeIOSeq :: IO a -> SafeIO a
+safeIOSeq action = foo (action >>= \x -> seq x (return (Right x)))
+
+foo :: IO (Either String a) -> SafeIO a
+foo x = liftIO (catch x putErr) >>= either fail return
+
+
+safe :: SafeIO a -> IO (Either String a)
+safe = runErrorT 
+
+putErr :: Show a => a -> IO (Either String b)
+putErr e = putStrLn ("IO action failed: "++show e) >> 
+           return (Left $ "SafeCalls.putErr: " ++ show e)
+
diff --git a/src/ShowFlatCurry.hs b/src/ShowFlatCurry.hs
new file mode 100644
--- /dev/null
+++ b/src/ShowFlatCurry.hs
@@ -0,0 +1,374 @@
+------------------------------------------------------------------------------
+--- Some tools to support meta-programming in Curry based on FlatCurry.
+---
+--- This library contains
+--- <UL>
+--- <LI> a show function for a string representation of FlatCurry programs
+---   (function "showFlatProg")
+---
+--- <LI> a function for showing FlatCurry expressions in (almost) Curry syntax
+---   (function "showCurryExpr")
+--- </UL>
+---
+--- Note that the previously contained function "writeFLC"
+--- is no longer supported. Use Flat2Fcy.writeFCY instead
+--- and change file suffix into ".efc"!
+---
+--- @author Michael Hanus
+--- @version August 2005
+-- modified to support new ExtendedFlat format in August 2009 (Holger Siegel)
+------------------------------------------------------------------------------
+
+
+module ShowFlatCurry(showFlatProg,showFlatType,showFlatFunc,
+                      showCurryType,showCurryExpr,showCurryId,showCurryVar)
+   where
+
+import List
+import Char
+import Brace
+
+import Curry.ExtendedFlat.Type
+
+
+--- Shows a FlatCurry program term as a string (with some pretty printing).
+showFlatProg :: Prog -> String
+showFlatProg (Prog modname imports types funcs ops) =
+     "module " ++show modname++" where"
+     ++ concatMap ("\nimport "++) imports 
+     ++ concatMap showFlatType types
+     ++ concatMap showFlatFunc funcs
+
+
+showFlatVisibility :: Visibility -> [Char]
+showFlatVisibility Public  = " Public "
+showFlatVisibility Private = " Private "
+
+showFlatFixity InfixOp = " InfixOp "
+showFlatFixity InfixlOp = " InfixlOp "
+showFlatFixity InfixrOp = " InfixrOp "
+
+showFlatOp :: OpDecl -> [Char]
+showFlatOp (Op name fix prec) =
+ "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")"
+
+showFlatType :: TypeDecl -> String
+showFlatType (Type qn _ tpars []) =  
+  "\ndata " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " external"
+showFlatType (Type qn _ tpars consdecls) =
+  "\ndata " ++ localName qn 
+              ++ brace " " "" " " (map showTypeVar tpars) ++ " = "
+              ++ separate " | " (map showCurryCons consdecls)
+showFlatType (TypeSyn qn _ tpars texp) =
+  "\ntype " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " = "
+                    ++ showCurryType localName False texp 
+
+
+showCurryCons :: ConsDecl -> [Char]
+showCurryCons (Cons qn _ _ types) =
+    localName qn ++ brace " " "" " " (map (showCurryType localName True) types)
+
+showFlatFunc :: FuncDecl -> String
+showFlatFunc (Func qn _ _ ftype _) =
+  '\n':localName qn++" :: "++showCurryType localName False ftype
+
+showFlatRule :: Rule -> [Char]
+showFlatRule (Rule params expr) =
+  " (Rule " ++ showFlatList show params
+            ++ showFlatExpr expr ++ ")"
+showFlatRule (External name) =
+  " (External " ++ show name ++ ")"
+
+
+showFlatTypeExpr :: TypeExpr -> String
+showFlatTypeExpr (FuncType t1 t2) =
+  "(FuncType " ++ showFlatTypeExpr t1 ++ " " ++ showFlatTypeExpr t2 ++ ")"
+showFlatTypeExpr (TCons tc ts) =
+  "(TCons " ++ show tc
+            ++ showFlatList showFlatTypeExpr ts ++ ")"
+showFlatTypeExpr (TVar n) = "(TVar " ++ show n ++ ")"
+
+
+showFlatCombType :: CombType -> String
+showFlatCombType FuncCall = "FuncCall"
+showFlatCombType ConsCall = "ConsCall"
+showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")"
+showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")"
+
+
+showFlatExpr :: Expr -> String
+showFlatExpr (Var n) = "(Var " ++ show n ++ ")"
+showFlatExpr (Lit l) = "(Lit " ++ showFlatLit l ++ ")"
+showFlatExpr (Comb ctype cf es) =
+  "(Comb " ++ showFlatCombType ctype ++ " "
+           ++ show cf ++ showFlatList showFlatExpr es ++ ")"
+showFlatExpr (Let bindings exp) =
+  "(Let " ++ showFlatList showFlatBinding bindings ++ showFlatExpr exp ++ ")"
+ where showFlatBinding (x,e) = "("++show x++","++showFlatExpr e++")"
+showFlatExpr (Free xs e) =
+  "(Free " ++ showFlatList show xs ++ showFlatExpr e ++ ")"
+showFlatExpr (Or e1 e2) =
+  "(Or " ++ showFlatExpr e1 ++ " " ++ showFlatExpr e2 ++ ")"
+showFlatExpr (Case _ Rigid e bs) =
+  "(Case Rigid " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")"
+showFlatExpr (Case _ Flex e bs) =
+  "(Case Flex " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")"
+
+
+showFlatLit :: Literal -> String
+showFlatLit (Intc   _ i) = "(Intc " ++ show i ++ ")"
+showFlatLit (Floatc _ f) = "(Floatc " ++ show f ++ ")"
+showFlatLit (Charc  _ c) =
+ if ord c >= 32  &&  ord c < 127
+ then "(Charc '" ++ [c] ++ "')"
+ else "(Charc (chr " ++ show (ord c) ++ "))"
+
+showFlatBranch :: BranchExpr -> String
+showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p
+                                         ++ showFlatExpr e ++ ")"
+
+
+showFlatPattern :: Pattern -> String
+showFlatPattern (Pattern qn xs) =
+      "(Pattern " ++ show qn
+                  ++ showFlatList show xs ++ ")"
+showFlatPattern (LPattern lit) = "(LPattern " ++ showFlatLit lit ++ ")"
+
+
+-- format a finite list of elements:
+showFlatList :: (a->String) -> [a] -> String
+showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] "
+
+showFlatListElems :: (a->String) -> [a] -> String
+showFlatListElems format elems = concat (intersperse "," (map format elems))
+
+
+------------------------------------------------------------------------------
+--- Shows a FlatCurry type in Curry syntax.
+---
+--- @param trans - a translation function from qualified type names
+---                to external type names
+--- @param nested - True iff brackets must be written around complex types
+--- @param texpr - the FlatCurry type expression to be formatted
+--- @return the String representation of the formatted type expression
+
+showTypeVar :: Int -> String
+showTypeVar i = if i<27 then [chr (97+i)] else 't':show i
+
+showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String
+
+showCurryType _ _ (TVar i) = showTypeVar i
+showCurryType tf nested (FuncType t1 t2) =
+  showBracketsIf nested
+    (showCurryType tf (isFuncType t1) t1 ++ " -> " ++
+     showCurryType tf False t2)
+showCurryType tf nested (TCons tc ts)
+    | ts==[]  = tf tc
+    | qnOf tc==("Prelude","[]")
+    = "[" ++ showCurryType tf False (head ts) ++ "]" -- list type
+    | "(," `isPrefixOf` localName tc      -- tuple type
+    = "(" ++ concat (intersperse "," (map (showCurryType tf False) ts)) ++ ")"
+    | otherwise
+    = showBracketsIf nested
+      (tf tc ++ concatMap (\t->' ':showCurryType tf True t) ts)
+
+
+isFuncType :: TypeExpr -> Bool
+isFuncType (TVar _)       = False
+isFuncType (FuncType _ _) = True
+isFuncType (TCons _ _)  = False
+
+
+------------------------------------------------------------------------------
+--- Shows a FlatCurry expressions in (almost) Curry syntax.
+---
+--- @param trans - a translation function from qualified functions names
+---                to external function names
+--- @param nested - True iff brackets must be written around complex terms
+--- @param indent - the indentation used in  case expressions and if-then-else
+--- @param expr - the FlatCurry expression to be formatted
+--- @return the String representation of the formatted expression
+
+showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String
+
+showCurryExpr _ _ _ (Var n) = showCurryVar n
+
+showCurryExpr _ _ _ (Lit l) = showCurryLit l
+
+showCurryExpr tf _ _ (Comb _ cf []) = showCurryId (tf cf)
+showCurryExpr tf nested b (Comb _ cf [e]) =
+  showBracketsIf nested (showCurryId (tf cf) ++ " "
+                            ++ showCurryExpr tf True b e)
+showCurryExpr tf nested b (Comb ct cf [e1,e2])
+ | qnOf cf==("Prelude","apply")
+  = showBracketsIf nested
+       (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2)
+ | isAlpha (head (localName cf))
+  = showBracketsIf nested
+    (tf cf ++" "++ showCurryElems (showCurryExpr tf True b) [e1,e2])
+ | isFiniteList (Comb ct cf [e1,e2])
+  = if isStringConstant (Comb ct cf [e1,e2])
+    then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\""
+    else "[" ++
+         concat (intersperse "," (showCurryFiniteList tf b (Comb ct cf [e1,e2])))
+         ++ "]"
+ | localName cf == "(,)" -- pair constructor?
+  = "(" ++ showCurryExpr tf False b e1 ++ "," ++
+           showCurryExpr tf False b e2 ++ ")"
+ | otherwise
+  = showBracketsIf nested
+              (showCurryExpr tf True b e1 ++ " " ++ tf cf ++ " " ++
+               showCurryExpr tf True b e2 )
+showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es))
+ | qnOf cf==("Prelude","if_then_else") && es==[]
+  = showBracketsIf nested
+        ("\n" ++
+         sceBlanks b ++ " if "   ++ showCurryExpr tf False (b+2) e1 ++ "\n" ++
+         sceBlanks b ++ " then " ++ showCurryExpr tf False (b+2) e2 ++ "\n" ++
+         sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3)
+ | "(," `isPrefixOf` localName cf -- tuple constructor?
+  = "(" ++
+    concat (intersperse "," (map (showCurryExpr tf False b) (e1:e2:e3:es)))
+        ++ ")"
+ | otherwise
+  = showBracketsIf nested
+       (showCurryId (tf cf) ++ " "
+        ++ showCurryElems (showCurryExpr tf True b) (e1:e2:e3:es))
+
+showCurryExpr tf nested b (Let bindings expr) =
+  showBracketsIf nested
+    ("\n"++sceBlanks b++"let " ++ concat (intersperse ("\n    "++sceBlanks b)
+     (map (\ (x,e)->showCurryVar x ++" = "++showCurryExpr tf False (b+4) e) bindings)) ++
+     ("\n"++sceBlanks b++" in ") ++ showCurryExpr tf False (b+4) expr)
+
+showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e
+
+showCurryExpr tf nested b (Free (x:xs) e) =
+  showBracketsIf nested
+    ("let " ++ concat (intersperse "," (map showCurryVar (x:xs))) ++
+     " free in " ++ showCurryExpr tf False b e)
+
+showCurryExpr tf nested b (Or e1 e2) =
+  showBracketsIf nested
+    (showCurryExpr tf True b e1 ++ " ? " ++ showCurryExpr tf True b e2)
+
+showCurryExpr tf nested b (Case _ ctype e cs) =
+  showBracketsIf nested
+    ((if ctype==Rigid then "case " else "fcase ") ++
+     showCurryExpr tf True b e ++ " of\n " ++
+     showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b)
+
+showCurryVar :: VarIndex -> String
+showCurryVar i = "v" ++ show (idxOf i)
+
+--- Shows an identifier in Curry form. Thus, operators are enclosed in brackets.
+showCurryId :: String -> String
+showCurryId name | isAlpha (head name) = name
+                 | name == "[]"        = name
+                 | otherwise           = ('(':name)++")"
+
+
+showCurryLit :: Literal -> String
+showCurryLit (Intc   _ i) = show i
+showCurryLit (Floatc _ f) = show f
+showCurryLit (Charc  _ c) = show c
+
+
+showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String
+showCurryCase tf b (Branch (Pattern l vs) e) =
+  sceBlanks b ++ showPattern (tf l) vs
+              ++ " -> " ++ showCurryExpr tf False b e ++ "\n"
+ where
+   showPattern c [] = c
+   showPattern c [x] = c ++ " " ++ showCurryVar x
+   showPattern c [x1,x2] =
+     if isAlpha (head c)
+     then c ++ " " ++ showCurryVar x1 ++ " " ++ showCurryVar x2
+     else if c=="(,)" -- pair constructor?
+          then "(" ++ showCurryVar x1 ++ "," ++ showCurryVar x2 ++ ")"
+          else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2
+   showPattern c (x1:x2:x3:xs) =
+     if take 2 c == "(,"  -- tuple constructor?
+     then "("++ concat (intersperse "," (map showCurryVar (x1:x2:x3:xs))) ++")"
+     else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs)
+
+showCurryCase tf b (Branch (LPattern l) e) =
+  sceBlanks b ++ showCurryLit l ++ " "
+              ++ " -> " ++ showCurryExpr tf False b e ++ "\n"
+
+
+showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String]
+showCurryFiniteList _ _ (Comb _ qn [])
+    | qnOf qn ==  ("Prelude","[]")
+    = []
+showCurryFiniteList tf b (Comb _ qn [e1,e2])
+    | qnOf qn ==  ("Prelude",":")
+    = showCurryExpr tf False b e1 : showCurryFiniteList tf b e2
+
+-- show a string constant
+showCurryStringConstant :: Expr -> String
+showCurryStringConstant (Comb _ qn [])
+    | qnOf qn == ("Prelude","[]")
+    = []
+showCurryStringConstant (Comb _ qn [e1,e2])
+    | qnOf qn == ("Prelude",":")
+    = showCharExpr e1 ++ showCurryStringConstant e2
+
+-- FIXME Pattern match(es) are non-exhaustive
+showCharExpr :: Expr -> String
+showCharExpr (Lit (Charc _ c))
+  | c=='"'  = "\\\""
+  | c=='\'' = "\\\'"
+  | c=='\n' = "\\n"
+  | o < 32 || o > 126 =
+    ['\\',chr(o `div` 100 + 48), chr(((o `mod` 100) `div` 10 + 48)),chr(o `mod` 10 + 48)]
+  | otherwise = [c]
+ where
+   o = ord c
+
+showCurryElems :: (a->String) -> [a] -> String
+showCurryElems format elems =
+   concat (intersperse " " (map format elems))
+
+
+showBracketsIf :: Bool -> String -> String
+showBracketsIf True  s ='(' : s ++ ")"
+showBracketsIf False s = s
+                        
+
+sceBlanks :: Int -> String
+sceBlanks b = take b (repeat ' ')
+
+-- Is the expression a finite list (with an empty list at the end)?
+isFiniteList :: Expr -> Bool
+isFiniteList (Var _) = False
+isFiniteList (Lit _) = False
+isFiniteList (Comb _ name args)
+    | qnOf name==("Prelude","[]") && args==[]
+    = True
+    | qnOf name==("Prelude",":")  && length args == 2
+    = isFiniteList (args!!1)
+    | otherwise
+    = False
+isFiniteList (Let _ _) = False
+isFiniteList (Free _ _) = False
+isFiniteList (Or _ _) = False
+isFiniteList (Case _ _ _ _) = False
+
+-- Is the expression a string constant?
+isStringConstant :: Expr -> Bool
+isStringConstant e = case e of
+  Comb _ name args -> (qnOf name==("Prelude","[]") && null args) ||
+                      (qnOf name==("Prelude",":") && length args == 2 &&
+                       isCharConstant (head args) && isStringConstant (args!!1))
+  _                -> False
+
+-- Is the expression a character constant?
+isCharConstant :: Expr -> Bool
+isCharConstant e = case e of
+  Lit (Charc _ _) -> True
+  _             -> False
+
+
+------------------------------------------------------------------------------
+
diff --git a/src/ShowFunctionalProg.hs b/src/ShowFunctionalProg.hs
new file mode 100644
--- /dev/null
+++ b/src/ShowFunctionalProg.hs
@@ -0,0 +1,404 @@
+{-# OPTIONS -fglasgow-exts #-}
+-- uses pattern guards to recognize strings and lists
+------------------------------------------------------------------------------
+--- A pretty printer for AbstractHaskell, adapted from AbstractCurryPrinter
+---
+--- This library defines a function "showProg" that shows
+--- an AbstractCurry program in standard Curry syntax.
+---
+--- @author Martin Engelke, Bernd Brassel, Michael Hanus, Sebastian Fischer
+--- @version May 2007
+-- in November 2004: 
+-- - added filter for type variables (to print <var0> as var0, like in Prelude)
+-- - prettyprint list patterns
+-- in July 2005:
+-- - added options to most functions
+-- - print qualified symbol when necessary (local functions missing)
+-- in May 2007:
+-- - prettier representation of Curry and Haskell Strings
+------------------------------------------------------------------------------
+module ShowFunctionalProg(showProg,showProgOpt,
+                            showTypeDecls,
+                            showTypeDecl,
+                            showTypeExpr,
+                            showFuncDecl,
+                            showExpr,showPattern,
+                            isInfixOpName,isTuple) where
+
+import Curry.ExtendedFlat.Type(QName(..), qnOf)
+import FunctionalProg
+import Data.List
+import Data.Char(ord)
+import Monad (ap)
+import Brace
+
+
+-------------------------------------------------------------------------------
+-- Functions to print an AbstractCurry program in standard Curry syntax
+-------------------------------------------------------------------------------
+
+data Options = PrintOpt { unqual :: Bool,
+                          sep :: String}
+
+defaultOptions :: Options
+defaultOptions = PrintOpt False ""
+
+--- Shows an AbstractCurry program in standard Curry syntax.
+showProg :: Prog -> String
+showProg = showProgOpt (unqual defaultOptions)
+
+showProgOpt :: Bool -> Prog -> String
+showProgOpt uq (Prog m imps exps typedecls insdecls funcdecls opdecls)
+   = "module "++m++showExports m exps ++" where\n\n"
+     ++ showImports imps
+     ++ showOpDecls opdecls
+     ++ showTypeDecls opts typedecls
+     ++ showInsDecls opts insdecls
+     ++ separate "\n\n" (map (showFuncDeclOpt opts) funcdecls)
+     ++ "\n"
+  where
+    opts = defaultOptions{unqual=uq}
+
+-----------------------------------------
+-- export declaration
+-----------------------------------------
+
+showExports :: String -> [String] -> String
+showExports m exps = brace " (" ")" ", " (("module "++m):exps)
+
+-----------------------------------------
+-- import declaration
+-----------------------------------------
+
+showImports :: [String] -> String
+showImports imps = brace "" "\n\n" "\n" (map ("import "++) imps)
+    
+-----------------------------------------
+-- infix operators
+-----------------------------------------
+
+showOpDecls :: [OpDecl] -> String
+showOpDecls opdecls = brace "" "\n\n" "\n" (map showOpDecl opdecls)
+
+showOpDecl :: OpDecl -> String
+showOpDecl (Op qn fixity precedence)
+   = separate " " [showFixity fixity,
+                   show precedence,
+                   '`':showIdentifier (localName qn) ++"`"]
+
+
+showFixity :: Fixity -> String
+showFixity InfixOp  = "infix"
+showFixity InfixlOp = "infixl"
+showFixity InfixrOp = "infixr"
+
+--------------------------------------------------
+-- type declarations, instances, type classes
+--------------------------------------------------
+
+--- Shows a list of AbstractCurry type declarations in standard Curry syntax.
+showTypeDecls :: Options -> [TypeDecl] -> String
+showTypeDecls opts typedecls =  
+  brace "" "\n\n" "\n\n" (map (showTypeDecl opts) typedecls)
+
+--- Shows an AbstractCurry type declaration in standard Curry syntax.
+showTypeDecl :: Options -> TypeDecl -> String
+showTypeDecl opts t = 
+  decl ++ showIdentifier (localName (typeName t)) ++ 
+  brace " " "" " " (map (showTypeExpr opts False . TVar) (typeVars t)) ++ " = "++
+  (case t of
+    TypeSyn{typeExpr=e} -> showTypeExpr opts False e
+    Type{consDecls=cs} -> separate "\n  | " (map (showConsDecl opts) cs) ++
+                          brace "\n  deriving (" ")" "," (derive t))
+  where
+    decl = case t of {TypeSyn{} -> "type "; Type{} -> "data "} 
+
+showConsDecl :: Options -> ConsDecl -> String
+showConsDecl opts c 
+   = separate (if strictArgs c then " !" else " ") 
+              (showIdentifier (localName (consName c)) : 
+               map (showTypeExpr opts True) (consArgs c))
+
+showInsDecls :: Options -> [InstanceDecl] -> String
+showInsDecls opts is = brace "" "\n\n" "\n\n" (map (showInsDecl opts) is)
+
+showInsDecl :: Options -> InstanceDecl -> String
+showInsDecl opts (Instance tcs tc fs) 
+  = "instance " 
+  ++ showTypeConstr opts tcs
+  ++ showTypeClass opts tc 
+  ++ brace " where\n  " "\n\n" "  " (map (showFuncDeclOpt (opts{sep="  "})) fs)
+
+
+showTypeConstr :: Options -> [TypeClass] -> String
+showTypeConstr opts tcs = brace "(" ") => " "," (map (showTypeClass opts) tcs)
+
+
+showTypeClass :: Options -> TypeClass -> String
+showTypeClass opts (TypeClass qn ts) 
+  = localName qn ++ brace " " "" " " (map (showTypeExpr opts True) ts)
+
+--- Shows an AbstractCurry type expression in standard Curry syntax.
+--- If the first argument is True, the type expression is enclosed
+--- in brackets.
+showTypeExpr :: Options -> Bool -> TypeExpr -> String
+showTypeExpr _ _ (TVar name) = showIdentifier name
+showTypeExpr opts nested (FuncType domain range) =
+   (if nested then brace "(" ")" else separate) " -> "
+   [showTypeExpr opts (case domain of {FuncType _ _ -> False; _ -> True}) domain,
+    showTypeExpr opts False range]
+showTypeExpr opts nested (TCons qn typelist) = 
+   (if nested && not (null typelist) then brace "(" ")" else separate) ""
+   [showTypeCons opts qn typelist]
+showTypeExpr opts nested (TConstr tcs t) = 
+   (if nested then brace "(" ")" else separate) ""
+   [showTypeConstr opts tcs ++ showTypeExpr opts False t]
+
+showTypeCons :: Options -> QName -> [TypeExpr] -> String
+showTypeCons opts qn ts = 
+  showSymbol opts qn ++ 
+  brace " " "" " " (map (showTypeExpr opts True) ts)
+
+
+
+------------------------------------------
+-- function declarations
+------------------------------------------
+
+--- Shows an AbstractCurry function declaration in standard Curry syntax.
+showFuncDecl :: FuncDecl -> String
+showFuncDecl = showFuncDeclOpt defaultOptions
+
+showFuncDeclOpt :: Options -> FuncDecl -> String
+showFuncDeclOpt opts f = 
+  maybe "" (\t->fname ++" :: "++ (showTypeExpr opts False t) ++ "\n") 
+           (funcType f) ++
+  maybe (fname ++ " external") 
+        (brace (fname++" ") "\n\n" ("\n"++sep opts++fname++" ") . 
+        map (showRule opts)) (funcBody f)
+  where
+    fname = showIdentifier (localName (funcName f))
+
+showRule :: Options -> Rule -> String
+showRule opts (Rule ps r ls) 
+  = separate " " (map (showPatternOpt opts) ps) ++
+    showRhs opts r ++
+    brace "\n   where\n    " "" "\n    " (map (showLocalDecl opts) ls)
+
+showRhs :: Options -> Rhs -> String
+showRhs opts (SimpleExpr e) = " = "++showExprOpt opts e
+showRhs opts (GuardedExpr gs) = brace "\n  " "" "\n  " (map (showGuard opts) gs)
+
+showGuard :: Options -> (Expr,Expr) -> String
+showGuard opts (g,r) = "  | " ++ showExprOpt opts g ++ " = " ++ showExprOpt opts r
+
+showLocalDecl :: Options -> LocalDecl -> String
+showLocalDecl opts (LocalFunc funcdecl) = showFuncDeclOpt (opts{sep="    "}) funcdecl
+showLocalDecl opts (LocalPat pattern expr ls) =
+   showPatternOpt opts pattern ++ " = " ++ showExprOpt opts expr ++
+   brace "\n   where\n    " "" "\n    " (map (showLocalDecl opts) ls)
+
+---------------------------------------
+-- symbols, expresssions, identifiers
+---------------------------------------
+
+-- Remove characters '<' and '>' from identifiers sind these characters
+-- are sometimes introduced in new identifiers generated by the front end (for sections)
+-- also eliminate non standard characters.
+
+showIdentifier :: String -> String
+showIdentifier "[]" = "[]"
+showIdentifier "_" = "_"
+showIdentifier name 
+  | isInfixOpName name = "("++name++")"
+  | isTuple name = name
+  | otherwise = let newName = normChars name in
+     if head newName=='\'' then "c_"++newName else newName
+  where
+   normChars :: String -> String
+   normChars [] = []
+   normChars (c@'_':cs) = c:normChars cs
+   normChars (c:cs) 
+     | (co >= na && co <= nz) = c:normChars cs
+     | (co >= nA && co <= nZ) = c:normChars cs
+     | (co >= n0 && co <= n9) = c:normChars cs
+     | otherwise = '\'':show co++normChars cs
+     where
+       co = ord c
+       na = 97
+       nz = 122
+       nA = 65
+       nZ = 90
+       n0 = 48
+       n9 = 57
+
+--- Shows an AbstractCurry expression in standard Curry syntax.
+
+showExpr :: Expr -> String
+showExpr = showExprOpt defaultOptions
+
+showExprOpt :: Options -> Expr -> String
+showExprOpt _ (Var name) = showIdentifier name
+showExprOpt _ (Lit lit) = showLiteral lit
+showExprOpt opts (Symbol name) = showSymbol opts name
+showExprOpt opts e@(Apply func arg)
+  | Just cs <- expAsCurryString   e = fromCurryString cs
+  | Just cl <- expAsCurryList     e = fromCurryList cl
+  | Just hs <- expAsHaskellString e = fromHaskellString hs
+  | Just hl <- expAsHaskellList   e = fromHaskellList hl
+  | otherwise = showExprOpt opts func ++ brace "(" ")" "" [showExprOpt opts arg]
+ where
+  -- string or list is non-empty (the empty string is parsed as empty list)
+  fromCurryString s = "(fromHaskellString " ++ show s++ ")"
+
+  fromCurryList es
+    = "(fromHaskellList ["
+   ++ concat (intersperse "," (map (showExprOpt opts) es)) ++ "])"
+
+  fromHaskellString :: String -> String
+  fromHaskellString s = show s -- quotation marks and quoted special chars
+
+  fromHaskellList es
+    = "[" ++ concat (intersperse "," (map (showExprOpt opts) es)) ++ "]"
+
+showExprOpt opts (Lambda patts expr) = showLambda opts patts expr
+showExprOpt opts (LetDecl localdecls expr)
+   = brace "let {" "} in " "; " (map (showLocalDecl opts) localdecls) ++
+     showExprOpt opts expr
+showExprOpt opts (DoExpr stmts)
+   = brace "do\n    " "\n  " "\n    " (map (showStatement opts) stmts)
+showExprOpt opts (ListComp expr stmts)
+   =    brace "[" "]" " | " 
+          [showExprOpt opts expr,separate ", " (map (showStatement opts) stmts)]
+showExprOpt opts (Case expr branches)
+   = brace ("case " ++ showExprOpt opts expr ++ " of\n") "\n" "\n  "
+       (map (showBranchExpr opts) branches)
+showExprOpt _ (String s) = '"':s++"\"" --"
+
+showSymbol :: Options -> QName -> String
+showSymbol _ qn
+    | modName qn == ""
+    = showIdentifier (localName qn)
+showSymbol opts qn
+    | isInfixOpName (localName qn)
+    = brace "(" ")" "" [modName qn ++ "." ++ localName qn]
+    | not (unqual opts) || "External" `isPrefixOf` modName qn
+    = modName qn++"."++showIdentifier (localName qn)
+    | otherwise
+    = showIdentifier (localName qn)
+
+
+showLambda :: Options -> [Pattern] -> Expr -> String
+showLambda opts patts expr = 
+  brace "\\ " " -> " " " (map (showPatternOpt opts) patts) ++
+  showExprOpt opts expr
+
+
+showStatement :: Options -> Statement -> String
+showStatement opts (SExpr expr) = showExprOpt opts expr
+showStatement opts (SPat pattern expr)
+   = showPatternOpt opts pattern ++ " <- " ++ showExprOpt opts expr
+showStatement opts (SLet localdecls)
+   =  brace "let " " in \n  " "\n    " (map (showLocalDecl opts) localdecls)
+
+-- try to transform expression into a non-empty Curry string
+expAsCurryString :: Expr -> Maybe String
+expAsCurryString (Symbol qn) 
+    | qnOf qn == ("CurryPrelude","List")
+    = Just ""
+expAsCurryString (Apply (Apply (Symbol qn1)
+                          (Apply (Symbol qn2)
+                                 (Lit (Charc c))))
+                   cs)
+    | qnOf qn1 == ("CurryPrelude",":<") && qnOf qn2 == ("CurryPrelude","C_Char")
+    = Just (c:) `ap` expAsCurryString cs
+expAsCurryString _ = Nothing
+
+-- try to transform expression into a Curry list
+expAsCurryList :: Expr -> Maybe [Expr]
+expAsCurryList (Symbol qn) 
+    | qnOf qn == ("CurryPrelude","List")
+        = Just []
+expAsCurryList (Apply (Apply (Symbol qn) x) xs)
+    | qnOf qn == ("CurryPrelude",":<")
+    = Just (x:) `ap` expAsCurryList xs
+expAsCurryList _ = Nothing
+
+-- try to transform expression into a non-empty Haskell string
+expAsHaskellString :: Expr -> Maybe String
+expAsHaskellString (Symbol qn)
+    | qnOf qn == ("","[]")
+    = Just ""
+expAsHaskellString (Apply (Apply (Symbol qn) (Lit (Charc c))) cs)
+    | qnOf qn == ("",":")
+    = Just (c:) `ap` expAsHaskellString cs
+expAsHaskellString _ = Nothing
+
+-- try to transform expression into a Haskell list
+expAsHaskellList :: Expr -> Maybe [Expr]
+expAsHaskellList (Symbol qn)
+    | qnOf qn ==  ("","[]") = Just []
+expAsHaskellList (Apply (Apply (Symbol qn) x) xs)
+    | qnOf qn == ("",":")
+    = Just (x:) `ap` expAsHaskellList xs
+expAsHaskellList _ = Nothing
+
+-------------------------------------------------------
+-- patterns
+-------------------------------------------------------
+
+showPattern :: Pattern -> String
+showPattern = showPatternOpt defaultOptions
+
+showPatternOpt :: Options -> Pattern -> String
+showPatternOpt _ (PVar name) = showIdentifier name
+showPatternOpt _ (PLit lit) = showLiteral lit
+showPatternOpt opts (PComb name []) = showSymbol opts name 
+showPatternOpt opts (PComb sym ps)
+   = brace "(" ")" " " (showSymbol opts sym:map (showPatternOpt opts) ps)
+showPatternOpt opts (AsPat v p) = 
+  showPatternOpt opts (PVar v)++"@"++showPatternOpt opts p
+
+showBranchExpr :: Options -> BranchExpr -> String
+showBranchExpr opts (Branch pattern expr)
+   = showPatternOpt opts pattern ++ " -> " ++ showExprOpt opts expr
+
+showLiteral :: Literal -> String
+showLiteral (HasIntc i) = '(':show i++"::Int)"
+showLiteral (Intc i) = '(':show i++"::C_Int)"
+showLiteral (Floatc f) = '(':show f++"::Float)"
+showLiteral (Charc c) = "'"++showCharc c++"'"
+
+showCharc :: Char -> String
+showCharc c = case c of 
+   '\n' -> "\\n"
+   '\t' -> "\\t"
+   '\r' -> "\\r"
+   '\\' -> "\\\\"
+   '\"' -> "\\\""
+   '\'' -> "\\'"
+   _ -> [c]
+
+-------------------------------------------------------------------------------
+--- tests for various properties of AbstractCurry constructs
+-------------------------------------------------------------------------------
+
+isInfixOpName :: String -> Bool
+isInfixOpName = all (`elem` infixIDs)
+
+isTuple :: String -> Bool
+isTuple "" = False
+isTuple (c:cs) = c=='(' && dropWhile (==',') cs == ")"
+
+------------------------------------------------------------------------------
+--- constants used by AbstractCurryPrinter
+------------------------------------------------------------------------------
+
+infixIDs :: String
+infixIDs =  "~!@#$%^&*+-=<>?./|\\:"
+
+
+
+
+
+
diff --git a/src/Simplification.hs b/src/Simplification.hs
new file mode 100644
--- /dev/null
+++ b/src/Simplification.hs
@@ -0,0 +1,519 @@
+module Simplification (simplifyProg) where
+
+
+import Prelude hiding ( or,fail,catch )
+
+import Data.Ord(comparing)
+import Data.List ( sortBy, groupBy, partition )
+
+import Curry.Base.Position(noRef)
+import Curry.ExtendedFlat.Type
+import Curry.ExtendedFlat.Goodies hiding ( freeVars )
+import qualified Curry.ExtendedFlat.Goodies as FCG
+
+
+
+data Int' = Neg Nat | Zero | Pos Nat
+data Nat = IHi | O Nat | I Nat
+
+simplifyProg :: Prog -> Prog
+simplifyProg = simplified []
+
+simplified :: [FuncDecl] -> Prog -> Prog
+simplified preludeFuncs prog =
+  updProgExps (runSimp next rs . evalFamilySimp tExpr opt) prog
+ where
+  opt = elimSimpleLet `or`
+        elimIntLit `or`
+        elimFailBranch `or`
+        elimCase `or`
+        propagate
+
+  next = mkIdx (1 + maxVarIndex (0:allVarsInProg prog))
+
+  rs = map rule (filter isInlined (preludeFuncs ++ progFuncs prog))
+  rule func = (funcName func, funcRule func)
+
+  -- inline only flat constants and if_then_else
+  isInlined func =
+    not (isExternal func) &&
+    (qnOf(funcName func) == (preludeName,if_then_elseName) ||
+     isConstant (funcBody func) ||
+     isVar (funcBody func))
+
+isConstant :: Expr -> Bool
+isConstant exp = isLit exp || (isConsCall exp && null (combArgs exp))
+
+
+-- elimination of let bindings that occur only once in right-hand side
+
+elimSimpleLet :: Expr -> Simp Expr
+elimSimpleLet exp
+  | isLet exp && (null keptBs || not (null simpBs))
+    = ret (let_ keptBs (replace simpBs e))
+  | otherwise = fail
+ where
+  Let bs e = exp
+  (simpBs,keptBs') = partition isSimpleBind bs
+
+  keptBs = map (\ (v,e) -> (v,replace simpBs e)) keptBs'
+
+  freeVarsInBinds = concatMap (freeVars . snd) bs
+
+  isSimpleBind (x,e) =
+    isVar e || not (x `elem` freeVarsInBinds) && x `isUniqueIn` exp
+
+isUniqueIn :: VarIndex -> Expr -> Bool
+x `isUniqueIn` exp = null xs || null (tail xs)
+ where xs = filter (x==) (freeVars exp)
+
+
+-- elimination of integer literals and patterns
+
+elimIntLit :: Expr -> Simp Expr
+elimIntLit exp
+  | isLit exp && isIntLit lit = ret (intLitToCons lit)
+  | isCase exp && any (isIntPattern . branchPattern) (caseBranches exp)
+    = flatCase ct [e] (map nestedBranch bs) fail
+  | otherwise = fail
+ where
+  lit = literal exp
+  Case _ ct e bs = exp
+
+isIntLit :: Literal -> Bool
+isIntLit exp = case exp of Intc _ _ -> True; _ -> False
+
+intLitToCons :: Literal -> Expr
+intLitToCons (Intc _ n) = int_ (intToInt' n)
+
+isIntPattern :: Pattern -> Bool
+isIntPattern pat = not (isConsPattern pat) && isIntLit (patLiteral pat)
+
+nestedBranch :: BranchExpr -> ([Expr],Expr)
+nestedBranch (Branch pat exp) =
+  case patExpr pat of
+    Lit (Intc _ n) -> ([int_ (intToInt' n)], exp)
+    pexp -> ([pexp], exp)
+
+-- flattens a case expression.
+-- the branches are given as pairs of possibly nested constructor terms
+-- and arbitrary right hand sides.
+-- multiple arguments of patterns are matched from left to right!
+flatCase :: CaseType -> [Expr] -> [([Expr],Expr)] -> Simp Expr -> Simp Expr
+flatCase _ [] [] err = err
+flatCase _ [] bs@(_:_) _ = ret (foldr1 (?~) (map snd bs))
+flatCase ct (e:es) bs err
+  | all isVar pats
+    = flatCase ct es (map replaceVar bs) err
+  | not (null bs) && all isConsCall pats
+    = liftSimp (Case noRef ct e) (mapSimp branch groupedBs)
+  | otherwise
+    = foldr (flatCase ct (e:es)) err (groupBy (lift2 sameKind (head . fst)) bs)
+ where
+  pats = map (head . fst) bs
+  groupedBs = reorderBy (lift2 compare (combName . head . fst)) bs
+  sameKind p1 p2 = all isVar [p1,p2] || all isConsCall [p1,p2]
+
+  replaceVar (Var x:ps,rhs) = (ps,Let [(x,e)] rhs)
+
+  branch gbs@((Comb _ name args : _, _) : _) =
+    nextVars (length args) .>>= \xs ->
+    liftSimp (Branch (Pattern name xs))
+      (flatCase ct (map Var xs ++ es) (map extend gbs) err)
+
+  extend (Comb _ _ args : ps, rhs) = (args ++ ps, rhs)
+
+-- elimination of failing branches in case expressions
+
+elimFailBranch :: Expr -> Simp Expr
+elimFailBranch exp
+  | isCase exp && (null bs || any isFailBranch bs)
+    = ret (replaceBranches exp (filter (not . isFailBranch) bs))
+  | otherwise = fail
+ where
+  bs = caseBranches exp
+
+isFailBranch :: BranchExpr -> Bool
+isFailBranch = isFailed . branchExpr
+
+isFailed :: Expr -> Bool
+isFailed exp = isFuncCall exp && qnOf (combName exp) == (preludeName,failedName)
+
+replaceBranches :: Expr -> [BranchExpr] -> Expr
+replaceBranches (Case p ct e _) bs
+  | null bs   = failed_
+  | otherwise = Case p ct e bs
+
+
+-- elimination of case applied to constructor terms
+
+elimCase :: Expr -> Simp Expr
+elimCase exp
+  | isCase exp && isConsCall scr = match scr (caseBranches exp)
+  | otherwise = fail
+ where
+  scr = caseExpr exp
+
+match :: Expr -> [BranchExpr] -> Simp Expr
+match (Comb _ name args) bs
+  | null xs = ret failed_
+  | otherwise
+    = nextVars (length ys) .>>= \zs ->
+      ret $ Let (zip zs args) (replace (zip ys (map Var zs)) exp)
+ where
+  xs = filter ((name==) . patCons . branchPattern) bs
+  Branch pat exp : _ = xs
+  ys = patArgs pat
+
+
+-- inlining of functions whose rule is provided
+
+propagate :: Expr -> Simp Expr
+propagate exp
+  | isFuncCall exp = fetchRule (combName exp) .>>= ret . inline exp
+  | otherwise      = fail
+
+inline :: Expr -> Rule -> Expr
+inline (Comb _ _ args) (Rule params body) = Let (zip params args) body
+
+-- traversables
+
+tInt :: Traversable Int' Nat
+tInt Zero    = noChildren Zero
+tInt (Pos n) = ([n], \ [n] -> Pos n)
+tInt (Neg n) = ([n], \ [n] -> Neg n)
+
+tNat :: Traversable Nat Nat
+tNat IHi   = noChildren IHi
+tNat (O n) = ([n], \ [n] -> O n)
+tNat (I n) = ([n], \ [n] -> I n)
+
+tExpr :: Traversable Expr Expr
+tExpr exp =
+  case exp of
+    Comb ct name args -> (args, Comb ct name)
+    Let bs e -> let (xs,es) = unzip bs in (e:es, \ (e:es) -> Let (zip xs es) e)
+    Free xs e -> ([e], \ [e] -> Free xs e)
+    Or e1 e2 -> ([e1,e2], \ [e1,e2] -> Or e1 e2)
+    Case p ct e bs -> let (ps,es) = unzip (map branch bs)
+                      in (e:es, \ (e:es) -> Case p ct e (zipWith Branch ps es))
+    _ -> noChildren exp
+ where
+  branch (Branch p e) = (p,e)
+
+tBranchExpr :: Traversable BranchExpr Expr
+tBranchExpr (Branch pat exp) = ([exp], \ [exp] -> Branch pat exp)
+
+tTypeExpr :: Traversable TypeExpr TypeExpr
+tTypeExpr typ =
+  case typ of
+    FuncType dom ran -> ([dom,ran], \ [dom,ran] -> FuncType dom ran)
+    TCons name args -> (args, TCons name)
+    _ -> noChildren typ
+
+
+-- comparison
+
+type Ord' a = a -> a -> Ordering
+
+reorderBy :: Ord' a -> [a] -> [[a]]
+reorderBy cmp = groupBy eq . sortBy cmp
+ where
+  eq x y = cmp x y == EQ
+
+
+-- creating FlatCurry expressions
+
+let_ bs e = if null bs then e else Let bs e
+
+preludeName = "Prelude"
+if_then_elseName = "if_then_else"
+failedName = "failed"
+
+failed_ :: Expr
+failed_ = Comb FuncCall (mkQName (preludeName,failedName)) []
+
+zero_ = Comb ConsCall (mkQName (preludeName, "Zero")) []
+pos_ n = Comb ConsCall (mkQName (preludeName, "Pos")) [n]
+neg_ n = Comb ConsCall (mkQName (preludeName, "Neg")) [n]
+
+iHi_ = Comb ConsCall (mkQName (preludeName, "IHi")) []
+o_ n = Comb ConsCall (mkQName (preludeName, "O")) [n]
+i_ n = Comb ConsCall (mkQName (preludeName, "I")) [n]
+
+x ?~ y = Comb FuncCall (mkQName (preludeName, "?")) [x,y]
+
+int_ :: Int' -> Expr
+int_ = foldChildren tInt tNat intExp natExp
+ where
+  intExp Zero    _   = zero_
+  intExp (Pos _) [n] = pos_ n
+  intExp (Neg _) [n] = neg_ n
+
+  natExp IHi     _   = iHi_
+  natExp (O _)   [n] = o_ n
+  natExp (I _)   [n] = i_ n
+
+
+-- auxiliary functions
+
+lift2 :: (a -> a -> c) -> (b -> a) -> (b -> b -> c)
+lift2 op f x y = op (f x) (f y)
+
+stripSuffix :: String -> String -> String
+stripSuffix suf str
+  | suf `isSuffixOf` str = take (length str - length suf) str
+  | otherwise = str
+
+isSuffixOf, isPrefixOf :: Eq a => [a] -> [a] -> Bool
+suf `isSuffixOf` l = reverse suf `isPrefixOf` reverse l
+
+[] `isPrefixOf` _ = True
+(x:xs) `isPrefixOf` (y:ys) = x==y && xs `isPrefixOf` ys
+
+
+-- compute free variables of expression
+
+freeVars :: Expr -> [VarIndex]
+freeVars = outOfScopeVars []
+
+outOfScopeVars :: [VarIndex] -> Expr -> [VarIndex]
+outOfScopeVars scope exp = fold tExpr vars exp scope
+ where
+  vars exp cs scope =
+    case (exp,cs) of
+      (Var n,_) -> if n `elem` scope then [] else [n]
+      (Let bs _,_) ->
+        concatMap ( $ filter (not . (`elem` map fst bs)) scope) cs
+      (Free vs _,[e]) -> e (filter (not . (`elem` vs)) scope)
+      (Case _ _ _ bs,e:es) ->
+        e scope ++ concat (zipWith (scopeBranch scope) bs es)
+      _ -> concatMap ( $ scope) cs
+
+  scopeBranch scope (Branch pat _) e
+    | isConsPattern pat = e (filter (not . (`elem` patArgs pat)) scope)
+    | otherwise = e scope
+
+
+-- replace free variables in expression according to environment
+
+type Env   = [(VarIndex,Expr)]
+
+replace :: Env -> Expr -> Expr
+replace env exp
+  | isVar  exp = fromEnv [] (varNr exp) env 
+  | isLet  exp = mapChildren tExpr (replace (removeLetBinds exp env)) exp
+  | isFree exp = mapChildren tExpr (replace (remove (FCG.freeVars exp) env)) exp
+  | isCase exp = let Case p ct e bs = exp
+                  in Case p ct (replace env e) (map (replaceBranch env) bs)
+  | otherwise  = mapChildren tExpr (replace env) exp
+
+fromEnv :: [VarIndex] -> VarIndex -> Env -> Expr
+fromEnv is i env = case lookup i env of
+  Nothing -> Var i
+  Just (Var j) -> if elem j is then Comb FuncCall (mkQName ("Prelude","failed")) [] 
+                               else fromEnv (j:is) j env
+  Just e  -> replace env e
+
+remove :: [VarIndex] -> Env -> Env
+remove xs env = filter (not . (`elem`xs) . fst) env
+
+removeLetBinds :: Expr -> Env -> Env
+removeLetBinds = remove . map fst . letBinds
+
+replaceBranch :: Env -> BranchExpr -> BranchExpr
+replaceBranch env b =
+  mapChildren tBranchExpr (replace (remove (patArgs (branchPattern b)) env)) b
+
+maxVarIndex :: [VarIndex] -> Int
+maxVarIndex vis = maximum (0 : map idxOf vis)
+
+
+--- A datatype is <code>Traversable</code> if it defines a function
+--- that can decompose a value into a list of children of the same type
+--- and recombine new children to a new value of the original type. 
+---
+type Traversable a b = a -> ([b], [b] -> a)
+
+--- Traversal function for constructors without children.
+---
+noChildren :: Traversable a b
+noChildren x = ([], const x)
+
+--- Yields the children of a value.
+---
+children :: Traversable a b -> a -> [b]
+children tr = fst . tr
+
+--- Replaces the children of a value.
+--- 
+replaceChildren :: Traversable a b -> a -> [b] -> a
+replaceChildren tr = snd . tr
+
+--- Applies the given function to each child of a value.
+---
+mapChildren :: Traversable a b -> (b -> b) -> a -> a
+mapChildren tr f x = replaceChildren tr x (map f (children tr x))
+
+--- Computes a list of the given value, its children, those children, etc.
+---
+family :: Traversable a a -> a -> [a]
+family tr x = familyFL tr x []
+
+--- Computes a list of family members of the children of a value.
+--- The value and its children can have different types.
+---
+childFamilies :: Traversable a b -> Traversable b b -> a -> [b]
+childFamilies tra trb x = childFamiliesFL tra trb x [] 
+
+-- implementation of 'family' with functional lists for efficiency reasons
+
+type FunList a = [a] -> [a]
+
+familyFL :: Traversable a a -> a -> FunList a
+familyFL tr x xs = x : childFamiliesFL tr tr x xs
+
+childFamiliesFL :: Traversable a b -> Traversable b b -> a -> FunList b
+childFamiliesFL tra trb x xs = concatFL (map (familyFL trb) (children tra x)) xs
+
+--- Concatenates a list of functional lists.
+---
+concatFL :: [FunList a] -> FunList a
+concatFL [] ys = ys
+concatFL (x:xs) ys = x (concatFL xs ys)
+
+--- Applies the given function to each member of the family of a value.
+--- Proceeds bottom-up.
+---
+mapFamily :: Traversable a a -> (a -> a) -> a -> a
+mapFamily tr f = f . mapChildFamilies tr tr f
+
+--- Applies the given function to each member of the families of the children
+--- of a value. The value and its children can have different types.
+--- Proceeds bottom-up.
+---
+mapChildFamilies :: Traversable a b -> Traversable b b -> (b -> b) -> a -> a
+mapChildFamilies tra trb = mapChildren tra . mapFamily trb
+
+--- Applies the given function to each member of the family of a value 
+--- as long as possible. On each member of the family of the result the given
+--- function will yield <code>Nothing</code>.
+--- Proceeds bottom-up.
+---
+evalFamily :: Traversable a a -> (a -> Maybe a) -> a -> a
+evalFamily tr f = mapFamily tr g
+ where g x = maybe x (mapFamily tr g) (f x)
+
+--- Applies the given function to each member of the families of the children
+--- of a value as long as possible.
+--- Similar to 'evalFamily'.
+---
+evalChildFamilies :: Traversable a b -> Traversable b b
+                  -> (b -> Maybe b) -> a -> a
+evalChildFamilies tra trb = mapChildren tra . evalFamily trb
+
+--- Implements a traversal similar to a fold with possible default cases.
+---
+fold :: Traversable a a -> (a -> [r] -> r) -> a -> r
+fold tr f = foldChildren tr tr f f
+
+--- Fold the children and combine the results.
+---
+foldChildren :: Traversable a b -> Traversable b b
+             -> (a -> [rb] -> ra) -> (b -> [rb] -> rb) -> a -> ra
+foldChildren tra trb f g a = f a (map (fold trb g) (children tra a))
+
+infixl 1 .>>=, .>>
+
+
+type Rules = [(QName,Rule)]
+type Simp a = VarIndex -> Rules -> Maybe (a,VarIndex)
+
+runSimp :: VarIndex -> Rules -> Simp a -> a
+runSimp n rs o =
+  maybe (error "Simplification.runSimp: simplification fails") fst (o n rs)
+
+ret :: a -> Simp a
+ret x n _ = Just (x,n)
+
+(.>>=) :: Simp a -> (a -> Simp b) -> Simp b
+(oa .>>= f) n rs = 
+  case oa n rs of
+    Nothing -> Nothing
+    Just (a,n) -> f a n rs
+
+(.>>) :: Simp b -> Simp a -> Simp a
+o .>> oa = o .>>= const oa
+
+liftSimp :: (a -> b) -> Simp a -> Simp b
+liftSimp f oa = oa .>>= ret . f
+
+fail :: Simp a
+fail _ _ = Nothing
+
+catch :: Simp a -> Simp a -> Simp a
+catch o1 o2 n rs = maybe (o2 n rs) Just (o1 n rs) 
+
+or :: (a -> Simp b) -> (a -> Simp b) -> a -> Simp b
+or f g a = catch (f a) (g a)
+
+nextVar :: Simp VarIndex
+nextVar n _ = Just (n,n+1)
+
+nextVars :: Int -> Simp [VarIndex]
+nextVars n = sequenceSimp (replicate n nextVar)
+
+fetchRule :: QName -> Simp Rule
+fetchRule name n rs = maybe Nothing defRule (lookup name rs)
+ where
+  defRule (Rule args body) = 
+    let arity = length args
+        args' = map mkIdx (take arity [idxOf n ..])
+     in Just (Rule args' (replace (zip args (map Var args')) body)
+             ,incVarIndex n arity)
+  defRule (External _) = Nothing
+
+sequenceSimp :: [Simp a] -> Simp [a]
+sequenceSimp [] = ret []
+sequenceSimp (ox:oxs) = ox .>>= \x -> sequenceSimp oxs .>>= \xs -> ret (x:xs)
+
+mapSimp :: (a -> Simp b) -> [a] -> Simp [b]
+mapSimp f = sequenceSimp . map f
+
+
+replaceChildrenSimp :: Traversable a b -> a -> Simp [b] -> Simp a
+replaceChildrenSimp tr = liftSimp . replaceChildren tr
+
+mapChildrenSimp :: Traversable a b -> (b -> Simp b) -> a -> Simp a
+mapChildrenSimp tr f a = replaceChildrenSimp tr a (mapSimp f (children tr a))
+
+mapFamilySimp :: Traversable a a -> (a -> Simp a) -> a -> Simp a
+mapFamilySimp tr f a = mapChildFamiliesSimp tr tr f a .>>= f
+
+mapChildFamiliesSimp :: Traversable a b -> Traversable b b
+                    -> (b -> Simp b) -> a -> Simp a
+mapChildFamiliesSimp tra trb = mapChildrenSimp tra . mapFamilySimp trb
+
+evalFamilySimp :: Traversable a a -> (a -> Simp a) -> a -> Simp a
+evalFamilySimp tr f = mapFamilySimp tr g
+ where g a = catch (f a .>>= mapFamilySimp tr g) (ret a)
+
+evalChildFamiliesSimp :: Traversable a b -> Traversable b b
+                     -> (b -> Simp b) -> a -> Simp a
+evalChildFamiliesSimp tra trb = mapChildrenSimp tra . evalFamilySimp trb
+
+cmpString :: String -> String -> Ordering
+cmpString = compare
+
+intToInt' :: Prelude.Integral a => a -> Int'
+intToInt' n = case Prelude.compare n 0 of
+ LT -> Neg (intToNat (Prelude.abs n))
+ EQ -> Zero
+ GT -> Pos (intToNat (Prelude.abs n))
+
+intToNat :: Prelude.Integral a => a -> Nat
+intToNat n = case Prelude.mod n 2 of
+              1 -> if m Prelude.== 0 then IHi else I (intToNat m)
+              0 -> O (intToNat m)
+  where m = Prelude.div n 2
+