KiCS 0.8.3 → 0.8.4
raw patch · 14 files changed
+4009/−1 lines, 14 files
Files
- KiCS.cabal +29/−1
- src/Brace.hs +10/−0
- src/Config.hs +476/−0
- src/CurryToHaskell.hs +1343/−0
- src/FunctionalProg.hs +251/−0
- src/InstallDir.hs +3/−0
- src/KicsSubdir.hs +132/−0
- src/MyReadline.hs +6/−0
- src/Names.hs +110/−0
- src/PreTrans.hs +307/−0
- src/SafeCalls.hs +45/−0
- src/ShowFlatCurry.hs +374/−0
- src/ShowFunctionalProg.hs +404/−0
- src/Simplification.hs +519/−0
KiCS.cabal view
@@ -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
+ src/Brace.hs view
@@ -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
+ src/Config.hs view
@@ -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
+ src/CurryToHaskell.hs view
@@ -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"+
+ src/FunctionalProg.hs view
@@ -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)+
+ src/InstallDir.hs view
@@ -0,0 +1,3 @@+module InstallDir where+installDir = "/home/bbr/kics"+ghc_call= "/home/ghc/bin/ghc"
+ src/KicsSubdir.hs view
@@ -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 ]
+ src/MyReadline.hs view
@@ -0,0 +1,6 @@+module MyReadline (readline, addHistory,initializeReadline) where++import System.Console.Readline++initializeReadline :: IO ()+initializeReadline = return ()
+ src/Names.hs view
@@ -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"++
+ src/PreTrans.hs view
@@ -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]+
+ src/SafeCalls.hs view
@@ -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)+
+ src/ShowFlatCurry.hs view
@@ -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+++------------------------------------------------------------------------------+
+ src/ShowFunctionalProg.hs view
@@ -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 = "~!@#$%^&*+-=<>?./|\\:"++++++
+ src/Simplification.hs view
@@ -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+