diff --git a/KiCS.cabal b/KiCS.cabal --- a/KiCS.cabal +++ b/KiCS.cabal @@ -1,5 +1,5 @@ Name: KiCS -Version: 0.8.5 +Version: 0.8.6 Cabal-Version: >= 1.6 Author: Bernd Braßel Maintainer: Bernd Braßel @@ -9,11 +9,13 @@ Category: Compiler build-type: Simple Synopsis: A compiler from Curry to Haskell -Description: This package builds two binaries, kics and kicsi, respectively. - The first is the Curry to Haskell compiler, the latter a text - based interactive environment. -Stability: *INCOMPLETE* do not download yet! (sorry...) - +Description: This package builds the Curry to Haskell compiler. + Note, that you need a functional curry module + "Prelude.curry" to get started. + The standard version of that file is contained + in the package KiCS-libraries. +Stability: experimental + Executable kics main-is: kics.hs hs-source-dirs: src @@ -26,45 +28,27 @@ 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 +Library hs-source-dirs: src Build-Depends: - base >= 4.1.0.0, - haskell98, - old-time, - filepath, - mtl, - directory, - containers, - readline, - curry-base >= 0.2.4 - Other-Modules: - Config - CurryToHaskell - SafeCalls - Names - KicsSubdir - FunctionalProg - ShowFunctionalProg - ShowFlatCurry - PreTrans - Simplification - Brace - InstallDir - MyReadline + syb + Exposed-Modules: + Curry.RunTimeSystem.Store, + Curry.RunTimeSystem.BaseCurry, + Curry.RunTimeSystem + Curry.Compiler.Config + Curry.Compiler.CurryToHaskell + Curry.Compiler.SafeCalls + Curry.Compiler.Names + Curry.Compiler.ShowFlatCurry + Other-Modules: + Curry.Compiler.KicsSubdir + Curry.Compiler.FunctionalProg + Curry.Compiler.ShowFunctionalProg + Curry.Compiler.PreTrans + Curry.Compiler.Simplification + Curry.Compiler.Brace + + + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,15 +1,2 @@ import Distribution.Simple - -main = defaultMainWithHooks - simpleUserHooks{hookedPreProcessors= - ("curry",\_ _ -> mkCurryLibrary): - hookedPreProcessors simpleUserHooks} - -mkCurryLibrary :: PreProcessor -mkCurryLibrary = PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - do info verbosity (inFile++" has been preprocessed to "++outFile) - stuff <- readFile inFile - writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) - return ExitSuccess +main = defaultMain diff --git a/src/Brace.hs b/src/Brace.hs deleted file mode 100644 --- a/src/Brace.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Brace where - -import List - -separate :: [a] -> [[a]] -> [a] -separate s xs = concat (intersperse s (filter (not . null) xs)) - -brace :: [a] -> [a] -> [a] -> [[a]] -> [a] -brace _ _ _ [] = [] -brace begin end sep xs = begin++separate sep xs++end diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,437 +0,0 @@ -module Config (module Config,module KicsSubdir) where - -import System.FilePath - -import InstallDir -import SafeCalls -import Char -import System.Environment (getEnvironment,getArgs) -import System.Directory hiding (executable) -import System.Time -import MetaProgramming.FlatCurry(readFlatCurry) -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 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 | 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 | use debug tool " - 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])], - toInclude :: String} deriving Show - -data ConsUse = DataDef | InstanceDef | FunctionDef deriving (Eq,Show) - - -cymake_call :: String -cymake_call = unpath [installDir,"bin","parsecurry"] - - -libpath :: Options -> [String] -libpath opts@Opts{userlibpath=up,kicspath=kp,filename=fn} - = --(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 curDir = 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=[], - toInclude=""} - -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 home = State {home=home, - rts=" -H400M ", - cmdLineArgs="", - files=[], - time=False} - -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 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 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 opts = callnorm $ frontend opts++" -e " ++ - unwords (map (("-i"++) . show) (libpath opts)) - -callnorm s = unwords (words s) ++ " " - -cymake opts = do - safeSystem (verbosity opts >= 3) - (cyCall opts ++ show (filename opts) - ++ if verbosity opts >= 3 then "" else " 1>/dev/null ") - -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 = 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 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 = [kicspath, - (toPathList . userlibpath), - (show . pm)] - -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 s = equations (lines s) - where - equations [] = [] - equations (x:xs) = case break (=='=') x of - (l,_:r) -> (l,r):equations xs - _ -> equations xs - -selOpts cfgs = map (selTag cfgs) configs - -configs = - ["Libraries", - "PresentationMode", - "Eval", - "Time", - "RunTimeSettings"] - -selTag [] _ = Nothing -selTag ((t,v):xs) s = - if map toLower t==map toLower s - then Just v - else selTag xs s - - -paths s = case break (==':') s of - ("","") -> [] - (w,"") -> [w] - ("",_:ws) -> paths ws - (w,_:ws) -> w : paths ws - -getModTime fn = safeIO (do - ex<-doesModuleExist fn - if ex then getModuleModTime fn else return (TOD 0 0)) - - - -safeReadFlat opts s = do - fs <- safeIO (findFileInPath s (libpath opts)) - fn <- warning s (cmdLibpath opts) fs - safeIOSeq (readFlatCurry fn) - - - -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 [definition|nodef] instances * --- extfunc - -put :: Int -> Options -> String -> Safe IO () -put i Opts{verbosity=j} s | i>j = return () - | i<=j = safeIO (putStrLn s) - -readExternalSpec :: Options -> String -> Safe IO 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 [(specs,stringToInclude)] = reads spec - newOpts = foldr insertP opts{toInclude=stringToInclude} specs - 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 f = case reverse f of - 'y':'r':'r':'u':'c':'.':f' -> reverse f' - 'y':'r':'r':'u':'c':'l':'.':f' -> reverse f' - _ -> f - -getEnv :: String -> IO String -getEnv s = getEnvironment >>= maybe (return "") return . lookup s diff --git a/src/Curry/Compiler/Brace.hs b/src/Curry/Compiler/Brace.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/Brace.hs @@ -0,0 +1,10 @@ +module Curry.Compiler.Brace where + +import List + +separate :: [a] -> [[a]] -> [a] +separate s xs = concat (intersperse s (filter (not . null) xs)) + +brace :: [a] -> [a] -> [a] -> [[a]] -> [a] +brace _ _ _ [] = [] +brace begin end sep xs = begin++separate sep xs++end diff --git a/src/Curry/Compiler/Config.hs b/src/Curry/Compiler/Config.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/Config.hs @@ -0,0 +1,456 @@ +module Curry.Compiler.Config ( + module Curry.Compiler.Config, + module Curry.Compiler.KicsSubdir) where + +import System.FilePath +import System.Time (ClockTime) +import Char +import System.Environment (getEnvironment,getArgs) +import System.Directory hiding (executable) +import System.Time + +import Curry.Compiler.SafeCalls +import Curry.FlatCurry.Type (readFlat) +import Curry.Compiler.Names +import Curry.Compiler.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 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 | 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 | use debug tool " + error "compilation aborted" + + +data Options = Opts{ cm :: ChoiceMode, + filename, mainFunc, mainModule, target, + frontend, ghcOpts + --, ghc, 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])], + toInclude :: String} deriving Show + +data ConsUse = DataDef | InstanceDef | FunctionDef deriving (Eq,Show) + + +cymake_call :: String +cymake_call = unpath ["cymake"] + + +libpath :: Options -> [String] +libpath opts@Opts{userlibpath=up,{-kicspath=kp,-}filename=fn} + = --(case takeDirectory fn of "" -> id; dir -> ((dir++[pathSeparator]):)) + up ++ [unpath ["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 curDir = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Main", + target = "request", + frontend=cymake_call, + --kicspath=installDir, + userlibpath=[], + --ghc="ghc", + 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=[], + toInclude=""} + +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 home = State {home=home, + rts=" -H400M ", + cmdLineArgs="", + files=[], + time=False} + +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 " + ++makeGhc (make opts) + ++" -i"++show (toPathList + (pathWithSubdirs $ 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 opts = + callnorm ("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 opts = + callnorm ("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 opts = callnorm $ frontend opts++" -e " ++ + unwords (map (("-i"++) . show) (libpath opts)) + +callnorm s = unwords (words s) ++ " " + +cymake opts = do + safeSystem (verbosity opts >= 3) + (cyCall opts ++ show (filename opts) + ++ if verbosity opts >= 3 then "" else " 1>/dev/null ") + +prophecy opts = safeSystem (verbosity opts >= 4) $ + "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 = 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 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 = [-- kicspath, + (toPathList . userlibpath), + (show . pm)] + +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 s = equations (lines s) + where + equations [] = [] + equations (x:xs) = case break (=='=') x of + (l,_:r) -> (l,r):equations xs + _ -> equations xs + +selOpts cfgs = map (selTag cfgs) configs + +configs = + ["Libraries", + "PresentationMode", + "Eval", + "Time", + "RunTimeSettings"] + +selTag [] _ = Nothing +selTag ((t,v):xs) s = + if map toLower t==map toLower s + then Just v + else selTag xs s + + +paths s = case break (==':') s of + ("","") -> [] + (w,"") -> [w] + ("",_:ws) -> paths ws + (w,_:ws) -> w : paths ws + +getModTime fn = safeIO (do + ex<-doesModuleExist fn + if ex then getModuleModTime fn else return (TOD 0 0)) + + + +safeReadFlat opts s = do + fs <- safeIO (findFileInPath s (libpath opts)) + fn <- warning s (cmdLibpath opts) fs + mprog <- safeIO $ readFlat fn + maybe (fail $ "file not found: "++fn) return mprog + + + + +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 [definition|nodef] instances * +-- extfunc + +put :: Int -> Options -> String -> Safe IO () +put i Opts{verbosity=j} s | i>j = return () + | i<=j = safeIO (putStrLn s) + +getExternalSpecFileName :: Options -> String -> Safe IO (Maybe FilePath) +getExternalSpecFileName opts p = do + specs <- safeIO $ findFileInPath + (externalSpecName (p `withoutSubdir` currySubdir)) + (libpath opts) + if null specs + then return Nothing + else warning "" "" specs >>= return . Just + + +readExternalSpec :: Options -> String -> Safe IO Options +readExternalSpec opts p = do + mspecFile <- getExternalSpecFileName opts p + case mspecFile of + Nothing -> return opts + Just specFile -> do + spec <- safeIO (readModule specFile) + put 5 opts "reading external specification" + let [(specs,stringToInclude)] = reads spec + newOpts = foldr insertP + opts{toInclude=stringToInclude} + specs + 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} + +getExternalSpecModTime :: Options -> String -> Safe IO ClockTime +getExternalSpecModTime opts p = do + mspecFile <- getExternalSpecFileName opts p + case mspecFile of + Nothing -> return (TOD 0 0) + Just specFile -> safeIO $ getModuleModTime specFile + + +baseName f = case reverse f of + 'y':'r':'r':'u':'c':'.':f' -> reverse f' + 'y':'r':'r':'u':'c':'l':'.':f' -> reverse f' + _ -> f + +getEnv :: String -> IO String +getEnv s = getEnvironment >>= maybe (return "") return . lookup s diff --git a/src/Curry/Compiler/CurryToHaskell.hs b/src/Curry/Compiler/CurryToHaskell.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/CurryToHaskell.hs @@ -0,0 +1,1232 @@ +module Curry.Compiler.CurryToHaskell where + +import List +import Char +import Maybe +import Monad +import System +import System.FilePath + +import Curry.FlatCurry.Type +import Curry.FlatCurry.Goodies hiding (consName) +import qualified Curry.Compiler.FunctionalProg as C +import Curry.Compiler.ShowFunctionalProg +import Curry.Compiler.PreTrans hiding (nub,pre) +import Curry.Compiler.Simplification ( simplifyProg ) +import Curry.Compiler.SafeCalls +import Curry.Compiler.Brace +import Curry.Compiler.Config as Config +import Curry.Compiler.Names + (modName,dbgModName,funcHsName,externalSpecName, + elimInfix,funName,functionName,constructorName) +import qualified Curry.Compiler.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} + +compilations :: [String] -> Options -> IO [String] +compilations [] opts = return (done opts) +compilations (f:fs) opts = + safe (startCompilation opts{filename=f}) >>= + compilations fs . maybe opts id + +startCompilation :: Options -> Safe IO 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 -> Safe IO 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 -> Safe IO (String,[String],Options) +process opts0@(Opts{filename=fn}) = do + prog <- safeReadFlat opts0 (replaceExtension fn ".fcy") + 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 -> Safe IO (String,[String],Options) +skip opts = do + let fname = if doNotUseInterface opts + then replaceExtension (filename opts) ".fcy" + 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) -> Safe IO 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 ".fcy") lib) + foundFile <- warning basename (toPathList lib) foundFiles + let foundBasename = dropExtensions foundFile + return (opts{filename=foundBasename}) + +notUptodate opts@(Opts{filename=foundBasename}) = do + tSource1 <- getModTime (replaceExtension foundBasename ".fcy") + tSource2 <- getExternalSpecModTime opts foundBasename + let destination = inModuleSubdir (inKicsSubdir (funcHsName foundBasename)) + tDestination <- getModTime destination + return (tSource1 > tDestination || tSource2 > tDestination) + +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 ".fcy" + 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 declaration(s)")) + 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,unqualified,prog) = do + let fn' = inModuleSubdir (inKicsSubdir fn) + put 3 opts ("writing "++ fn') + let printOpts = defaultPrintOptions{unqual=unqualified,include=toInclude opts} + safeIO (writeKicsFile (fn/="Main.hs") 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 -> Safe IO 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 = [funcHsName name] + +------------------------------------------------------ +-- 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} + hasInternalData = not $ null $ filter (not . isExternalType) types + + modules = [allinclusiveProg] + + -- filename, flag and module definitions + allinclusiveProg = (funcHsName (filename opts),False,allinclusive) + + + modul mName mImports mExports mTypes mInsts mFuncs = + C.Prog mName mImports mExports mTypes mInsts mFuncs [] + + allinclusive = modul funcName allIImports allIExports dataTypes instances functions + + -- the module names are: + funcName = modName name + + mainModuleName = "Main" + + -- the file names of these modules are: + funcFileName = funcHsName (filename opts) + mainFileName = "Main.hs" + + -- import lists + newImports = map modName imports + allIImports = [curryModule] ++ newImports + + {- + -- this is the only special prelude treatment: + instImportName + | name=="Prelude" = instName ++ " hiding ("++opsUsedInInstances++")" + | otherwise = instName + opsUsedInInstances = "op_38_38" + -} + + -- export lists + allIExports = [] + + -- 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 (snd $ typeName t) (extData opts))) types + isToTransform t = case lookup (snd $ 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 (snd . funcName) fs + + genNewName s ts = if elem s ts then genNewName ('a':s) ts else s + + +mainMod (_,aux2) m opts = let aux = (m,snd (funName ("",aux2))) in + C.Prog "Main" [curryModule,modName "Prelude",m] + [] [] [] + [C.Func (m,"main") public untyped + (Just [C.Rule [] + (noguard $ fapp (hasPresym ">>") + [app (setProg opts) (C.String (mainModule opts)), + app (C.Symbol (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 = (m,aux1) + a2 = (m,aux2) + calla1 t orc = if debug opts + then Comb FuncCall ("Oracle","oracle"++if orc then "IO" else "") + [Comb (FuncPartCall 1) a1 []] + else Comb FuncCall a1 [] + printIO = ("Interactive","printIO") + lfs = zip (map (snd . 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 = ("Interactive","interactiveSols") +df = ("Prelude","allValuesD") +bf = ("Prelude","allValuesB") +pr = ("Interactive","printTerm") +hd = ("Prelude","head") +f ... g = Comb FuncCall (addPre ".") + [Comb (FuncPartCall 1) f [],Comb (FuncPartCall 1) g []] +ap_ f e = Comb FuncCall (addPre ".") [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") 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") 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 (m,n) vs + = [C.Cons (m,n++"Fail") 0 private False [tExceptions], + C.Cons (m,n++"Or") 2 private False + [tOrRef, tBranches newT]] + where + newT = C.TCons (m,n) (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 (newModName,name) (map toTVar vars)]) + + +curryInstance opts t@(Type origName vis vars consdecls) + = inst newModName name vars curryClass + [strEq,eq,propagate,foldCurry,typeName,showFunction True opts t] --toTerm,fromTerm + where + (newModName,name) = consName opts origName + + origMod = fst origName + + isPrelude = origMod=="Prelude" + + strEq = C.Func (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 [1..arity]), + C.PComb (consName opts cname) (map (toPVar' "y") [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 i,toVar' "y" i]) + + eq = C.Func (newModName,"eq") (transvis vis) untyped + (Just + (map eqRule consdecls + ++otherwiseExp 3 (concupresym opts "False"))) + + eqRule (Cons cname arity _ _) = + rule [C.PComb (consName opts cname) (map toPVar [1..arity]), + C.PComb (consName opts cname) (map (toPVar' "y") [1..arity])] + (noguard $ if arity==0 then concupresym opts "True" + else foldr1 (\ e es -> fapp (funcupresym "&&") (addStateArg [e,es])) + (map eqArgs [1..arity])) [] + where + eqArgs i = fapp (extInstPresym isPrelude "genEq") (addStateArg [toVar i,toVar' "y" i]) + + propagate = C.Func (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 [1..arity])]) + (noguard $ fapp (sym (consName opts cname)) + (map propCall [1 .. arity])) [] + where propCall i = fapp (C.Var "f") (addStateArg [toHInt (i-1),toVar i]) + + foldCurry = C.Func (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 [1..arity])]) + (noguard $ foldr appFold (C.Var "c") (map toVar [1 .. arity])) [] + where + appFold v e = fapp (C.Var "f") (addStateArg [v,e]) + + typeName = C.Func (newModName,"typeName") (transvis vis) untyped + (Just [C.Rule [_x] + (noguard $ C.String (snd origName)) []]) + + toTerm = C.Func (newModName,"toC_Term") (transvis vis) untyped + (Just + (map toTermRule (zip [1..] consdecls) ++ + [C.Rule [_x,_x, + C.PComb (newModName,name++"FreeVar") [C.PVar "r"]] + (noguard $ app (cupresym "C_Free") + (app c_int + (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 [1..arity])] + (noguard $ fapp (cupresym "C_Data") + [toInt nr,c_string_ origMod (snd cname), + dList isPrelude (map su [1..arity])]) [] + where + su i = fapp (cusym "ctcStore") + [C.Var "mode",app (cusym "toC_Term") (C.Var "mode"), + C.Var "store",toVar i] + + fromTerm = C.Func (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 (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) (snd cname)) + pts = dpList isPrelude (map toPVar [1..arity]) + e = noguard $ fapp (sym (consName opts cname)) + (map (app (cusym "fromC_Term") . toVar) [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) = consName opts origName + + origMod = fst origName + + isPrelude = origMod=="Prelude" + + nf gr = C.Func (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 [1..arity]), + C.PVar "state0"] + (noguard $ foldr (nflambda gr) + (fapp (C.Var "f") + [fapp (sym $ consName opts cname) + (map (toVar' "v") [1..arity]), + toVar' "state" arity]) + [1..arity]) []] + + nflambda gr i e = + fapp (cusym (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 (newModName,s) (transvis vis) untyped + (Just [C.Rule [C.PVar "i"] (noguard $ + fapp (cusym "withRef") [ + C.Lambda [C.PVar "r"] $ + fapp (sym (orName opts origName)) + [fapp (cusym "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 (cusym 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 (newModName,"consKind") (transvis vis) untyped + (Just + (map tester [(orName, 2, "Branching"), + (failName, 1, "Failed")] ++ + [C.Rule [_x] + (noguard $ (cusym "Val")) []])) + + tester (namer,arity,nameTest) = + C.Rule [C.PComb (namer opts origName) (take arity (repeat (_x)))] + (noguard (cusym nameTest)) [] + + selector nameSel namer arity number = + C.Func (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 (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 = funName fname + f = (modName (fst fname),auxName 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 ct _ bs -> error "case not normalized" + _ -> Just [rule (map toPVar lhs) (noguard trhs) []] + + auxName (_,name) = + if isInfixOpName name + then elimInfix name + else name + +transFunc opts _ (Func (m,fname) arity vis t (External _)) = + C.Func (funName (m,fname)) (transvis vis) (transFType opts arity t) + (Just [rule (map toPVar [1..arity]) + (noguard (fapp (C.Symbol (modName m,fname)) + (addStateArg (map toVar [1..arity])))) []]) + + +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 <- [(curryModule,"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@("Global","global") args) = + C.LetDecl [C.LocalPat (C.PVar "st") (hasPresym "Nothing") []] + (fapp (C.Symbol (funName 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 (funName fname) (addStateArg newArgs) + FuncPartCall i -> symApp (funName 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 -> ("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 && take 11 (fst f)=="CurryOracle" && length (fst f) > 11 + + 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 (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_ oName,C.Var "x"])] + + + closeRef i e = fapp (sym $ 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 (funcupresym "===") [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 (funName name) C.InfixOp p +transOp (Op name InfixlOp p) = C.Op (funName name) C.InfixlOp p +transOp (Op name InfixrOp p) = C.Op (funName name) C.InfixrOp p + + +---------------------------------------------------------------- +-- generating instances for read and show +---------------------------------------------------------------- + +genInstances _ _ _ [] = [] +genInstances cl genFunc opts (t:ts) + | maybe False (elem cl) (lookup (snd $ 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 (addPre "Show") [toTVar v]) vars) + (C.TypeClass (addPre "Show") [C.TCons (newModName,name) (map toTVar vars)]) + [showFunction False opts t] + where + (newModName,name) = consName opts origName + + + +showFunction showQ opts t@(Type origName vis vars consdecls) + | maybe False (elem Show) (lookup (snd $ typeName t) (extInsts opts)) + = showsPrec [C.Rule [] (C.SimpleExpr (hasPresym "showsPrec")) []] + | otherwise = showsPrec (map showsPrecRule consdecls + ++[showGenerator]) + where + showParenArg (_,'(':_) = hasPresym "True" + showParenArg _ = if showQ then hasPresym "True" else lt (C.Var "d") app_prec + showsPrecName = if showQ then "showQ" else "showsPrec" + showsPrecSym = (if showQ then extInstPresym (fst origName=="Prelude") + else hasPresym) showsPrecName + + identifier (_,"()") = "()" + identifier (cm,cn) = if showQ then cm++"."++cn else cn + + opening (_,'(':_) = "" + opening cmn = identifier cmn ++ " " + + separator (_,'(':_) = ',' + separator _ = ' ' + + showsPrec rs = C.Func (newModName,showsPrecName) + (transvis vis) untyped + (Just rs) + + (newModName,name) = 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 [1..arity])] + (C.SimpleExpr (fapp (hasPresym "showParen") + [showParenArg cname,sym ("","showStr")])) + [C.LocalFunc (C.Func ("","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 [1..arity])) + + + callShowsPrec i = fapp showsPrecSym [add_prec cname,toVar i] + + points = foldr1 point + + point x y = fapp (hasPresym ".") [x,y] + + + showTuple = C.Func (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 [1..arity])] + (C.SimpleExpr (app (hasPresym "showString") + (app (hasPresym "show") + (fapp (sym ("",snd cname)) + (map toVar [1..arity]))))) [] + + showGenerator = C.Rule [_x, + C.PComb (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@(modName,name) vis vars consdecls) = + C.Instance (map (\v -> C.TypeClass (addPre "Read") [toTVar v]) vars) + (C.TypeClass (addPre "Read") [C.TCons (newModName,newName) (map toTVar vars)]) + [if isTuple (snd origName) then readTuple else readsPrec] + where + c@(newModName,newName) = consName opts origName + + readsPrec = C.Func (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@(cmodName,cname) arity _ args) = C.Lambda [C.PVar "r"] + (C.ListComp (fapp (sym ("","(,)")) + [fapp (sym newC) + (map toVar [1..arity]), + toVar' "r" arity ]) + (C.SPat (pair (C.PVar "_") (toPVar' "r" 0)) + (fapp (cusym "readQualified") [string_ cmodName,string_ cname,C.Var "r"]): + map readArg [1..arity])) + + where + newC@(newMod,newCName) = consName opts cn + + readArg i = C.SPat (pair (toPVar' "x" i) (toPVar' "r" i)) + (fapp (hasPresym "readsPrec") + [add_prec ("",""), + toVar' "r" (i-1)]) + + readTuple = C.Func (newModName,"readsPrec") (transvis vis) untyped + (Just (map readTupleRule consdecls)) + + readTupleRule (Cons t@(_,tup) arity _ args) = + C.Rule [C.PVar "d",C.PVar "r"] + (C.SimpleExpr + (fapp (hasPresym "map") [sym ("","readTup"), + fapp (hasPresym "readsPrec") + [C.Var "d",C.Var "r"]])) + [C.LocalFunc (C.Func ("","readTup") (transvis vis) untyped + (Just [C.Rule [pair (C.PComb ("",tup) (map toPVar [1..arity])) + (C.PVar "s")] + (C.SimpleExpr + (fapp (sym ("","(,)")) + [fapp (sym (consName opts t)) (map toVar [1..arity]), + C.Var "s"])) []]))] + + pair x y = C.PComb ("","(,)") [x,y] + + +add_prec (_,'(':_) = cusym "zero" +add_prec _ = 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 (m,n) = (modName m,cn) + where + cn | extCons opts = n + | otherwise = constructorName n + +freeVarName opts = N.freeVarName . consName opts +failName opts = N.failName . consName opts +orName opts = N.orName . consName opts +suspName opts = N.suspName . consName opts + +curryName s = (curryModule,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)) = + C.Func (funName n) (transvis vis) (transFType opts 0 t) + (Just [C.Rule [] + (C.SimpleExpr (transExpr opts e)) []]) + +---------------------------------------------------------------- +-- constants and abbreviations for flat, resp. abstract curry +---------------------------------------------------------------- + +-- prelude symbols +sym = C.Symbol +prelude = "Prelude" +addPre = (,) prelude +hasPresym = sym . addPre +cupresym = sym . (,) (modName prelude) +funcupresym = sym . funName . addPre +concupresym opts = sym . consName opts . addPre + +-- symbols from Curry library +curryModule = "Curry.RunTimeSystem" +curryClass = "Curry" +cu = (,) curryModule +cusym = sym . cu + +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 (cupresym "pf")) + +-- partial constructor call, one argument missing +pc :: Options -> Int -> C.Expr -> C.Expr +pc opts = app . partial opts (fapp (cupresym "pc")) + +-- partial application, more than one argument +pa :: Options -> [C.Expr] -> C.Expr +pa opts = fapp (cupresym "pa") + +-- function compostition (.) +cp :: Options -> [C.Expr] -> C.Expr +cp opts = fapp (cupresym "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 (addPre 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 (addPre "[]") [a] +c_tList a = curryTCons "List" [a] + +tPair a b = C.TCons (addPre "(,)") [a,b] + +tMaybe a = C.TCons (addPre "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 (addPre ">>=") [x,y] + +flatEq x y = Comb FuncCall (addPre "===") [x,y] + +flatGst x = Comb FuncCall (addPre "getSearchTree") [x] + +mid = hasPresym "id" + +baseType _ s = addPre s + +toVar i = C.Var (xvar i) + +toVar' s i = C.Var (varName s i) + +xvar = varName "x" + +varName s i = s++show i + +toPVar i = C.PVar (varName "x" i) + +toPVar' s i = C.PVar (varName s i) + +toTVar i = C.TVar (varName "t" i) + +primValue opts v = + app (sym $ consName opts{extCons=True} (addPre "PrimValue")) v + + +toList [] = C.Symbol ("","[]") +toList (x:xs) = app2 (C.Symbol ("",":")) x (toList xs) + +toPList [] = C.PComb ("","[]") [] +toPList (x:xs) = C.PComb ("",":") [x,toPList xs] + +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 (modName "Prelude","C_Char") [C.PLit (C.Charc c)] + | otherwise = C.PComb (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 = cupresym "C_Int" + +toChar opts c = app (sym (consName opts ("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 ("Prelude","IO") [x] +unitT = TCons ("Prelude","()") [] + +hasUnit = sym ("","()") + +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 ("",":")) [x,xs] +nil = sym ("","[]") + +string_ n = list_ (map char_ n) + +c_char_ c = fapp (cusym "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 (cupresym ":<") [x,xs] +c_nil = cupresym "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 (cupresym ":<") [x,xs] +bc_nil = cupresym "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 ("",":") [x,xs] +pnil = C.PComb ("","[]") [] + +c_plist_ [] = c_pnil +c_plist_ (x:xs) = c_pcons_ x (c_plist_ xs) + +c_pcons_ x xs = C.PComb (addPre ":<") [x,xs] +c_pnil = C.PComb (addPre "List") [] + +bc_plist_ [] = bc_pnil +bc_plist_ (x:xs) = bc_pcons_ x (bc_plist_ xs) + +bc_pcons_ x xs = C.PComb (addPre ":<") [x,xs] +bc_pnil = C.PComb (addPre "List") [] + + +pstring_ n = plist_ (map pchar_ n) + +underscores i = replicate i (_x) + +qname_ (m,f) = string_ (m++'.':f) + +extInstPresym _ s = sym (modName "Prelude",s) + +extFuncPresym opts s = sym (modName "Prelude",s) + + +_x = C.PVar "_" + +st = C.Var "st" + diff --git a/src/Curry/Compiler/FunctionalProg.hs b/src/Curry/Compiler/FunctionalProg.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/FunctionalProg.hs @@ -0,0 +1,248 @@ +------------------------------------------------------------------------------ +--- 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 Curry.Compiler.FunctionalProg where + +------------------------------------------------------------------------------ +-- 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 +--- +--- (CProg modname imports typedecls functions opdecls) +--- +--- 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. +--- 
+--- 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.
+---
+ +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 Int 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. +--- 
+--- 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.
+---
+ +data FuncDecl = Func { funcName :: QName, + funcVis :: Visibility, + funcType :: Maybe TypeExpr, + funcBody :: Maybe [Rule]} deriving (Show,Eq,Read) + + +--- A rule is either a list of formal parameters together with an expression +--- (i.e., a rule in flat form), a list of general program rules with +--- an evaluation annotation, or it is externally defined + +--- The most general form of a rule. It consists of a list of patterns +--- (left-hand side), a list of guards ("success" if not present in the +--- source text) with their corresponding right-hand sides, and +--- a list of local declarations. +data Rule = Rule { patterns :: [Pattern], + rhs :: Rhs, + locDecls :: [LocalDecl]} + deriving (Show,Eq,Read) + +data Rhs = SimpleExpr Expr | GuardedExpr [(Expr,Expr)] deriving (Show,Eq,Read) + + +--- Data type for representing local (let/where) declarations +data LocalDecl = + LocalFunc FuncDecl -- local function declaration + | LocalPat Pattern Expr [LocalDecl] -- local pattern declaration + deriving (Show,Eq,Read) + +--- Data type for representing Curry expressions. + +data Expr = + Var VarName -- variable (unique index / name) + | Lit Literal -- literal (Integer/Float/Char constant) + | Symbol QName -- a defined symbol with module and name + | Apply Expr Expr -- application (e1 e2) + | Lambda [Pattern] Expr -- lambda abstraction + | LetDecl [LocalDecl] Expr -- local let declarations + | DoExpr [Statement] -- do expression + | ListComp Expr [Statement] -- list comprehension + | Case Expr [BranchExpr] -- case expression + | String String + deriving (Show,Eq,Read) + +--- Data type for representing statements in do expressions and +--- list comprehensions. + +data Statement = SExpr Expr -- an expression (I/O action or boolean) + | SPat Pattern Expr -- a pattern definition + | SLet [LocalDecl] -- a local let declaration + deriving (Show,Eq,Read) + +--- Data type for representing pattern expressions. + +data Pattern = + PVar VarName -- pattern variable (unique index / name) + | PLit Literal -- literal (Integer/Float/Char constant) + | PComb QName [Pattern] -- application (m.c e1 ... en) of n-ary + -- constructor m.c (CPComb (m,c) [e1,...,en]) + | AsPat VarName Pattern + deriving (Show,Eq,Read) + +--- Data type for representing branches in case expressions. + +data BranchExpr = Branch Pattern Expr + deriving (Show,Eq,Read) + +--- Data type for representing literals occurring in an expression. +--- It is either an integer, a float, or a character constant. + +data Literal = Intc Integer + | HasIntc Integer + | Floatc Double + | Charc Char + deriving (Show,Eq,Read) + diff --git a/src/Curry/Compiler/KicsSubdir.hs b/src/Curry/Compiler/KicsSubdir.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/KicsSubdir.hs @@ -0,0 +1,133 @@ +module Curry.Compiler.KicsSubdir where + +import System.Directory +import System.FilePath +import System.Time (ClockTime) +import Control.Monad (when) +import List (intersperse,nubBy) + +curDirPath :: FilePath +curDirPath = "." + +path :: String -> [String] +path = canonPath . separateBy isPathSeparator + where + canonPath (c:cs) = c:filter (not . null) cs + +-- 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@[n] = sub:ps + add ps@[p,n] | p==sub = ps + add (p:ps) = p:add ps + +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 = "kics" +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 + +inModuleSubdir :: String -> String +inModuleSubdir s = s `inSubdir` "Curry" `inSubdir` "Module" + +--write a file to curry subdirectory + +writeKicsFile :: Bool -> String -> String -> IO String +writeKicsFile isHsModule filename contents = do + let filename' | isHsModule = inModuleSubdir (inKicsSubdir filename) + | otherwise = 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 path = do + if any isPathSeparator fn + then findFile fn + else do + let fs = nubBy equalFilePath $ map (++fn) path + founds <- mapM findFile fs + return (nubBy equalFilePath $ concat founds) + + where + findFile = onExistingFileDo doesExist + doesExist fn = do ex <- doesFileExist fn + if ex then return [fn] else return [] diff --git a/src/Curry/Compiler/Names.hs b/src/Curry/Compiler/Names.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/Names.hs @@ -0,0 +1,76 @@ +module Curry.Compiler.Names where + +import Char +import List +import System.FilePath + +import Curry.Compiler.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 (m,n) = + case m of + "" -> ("",preludeConstructorName n) + _ -> (modName 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 +-} + +functionName n | isInfixOpName n = elimInfix n + | otherwise = 'c':'_':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) + +moduleName s = + if isLower (head (takeBaseName s)) then insertName "C_" s else s + +modName s = insertName "Curry.Module." (moduleName s) +funcHsName s = replaceExtension (moduleName s) ".hs" +externalSpecName s = replaceExtension s ".hs.include" + +dbgMName = "Oracle" +dbgModName = insertName dbgMName +strictPrefix = "S" +mkStrictName = insertName strictPrefix + + +-- names for new constructors +--addPrefix s _ (p@"Prelude","Int") = (instModName p,"C_Int"++s) +--addPrefix s _ (p@"Prelude","Float") = (instModName p,"Prim"++s) +addPrefix s (m,n) = (m,n++s) + +freeVarName = addPrefix "FreeVar" +failName = addPrefix "Fail" +orName = addPrefix "Or" +suspName = addPrefix "Susp" + + diff --git a/src/Curry/Compiler/PreTrans.hs b/src/Curry/Compiler/PreTrans.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/PreTrans.hs @@ -0,0 +1,284 @@ +{-# OPTIONS -cpp #-} +-------------------------------- +-- preliminary transformations +-------------------------------- +module Curry.Compiler.PreTrans where + +import Maybe +import List hiding (nub) + +import Curry.FlatCurry.Type +import Curry.FlatCurry.Goodies + +#if __GLASGOW_HASKELL__ >= 604 +import qualified Data.Map as FM + +myFromList = FM.fromList +myLookup = FM.lookup +myMember = FM.member + +#else +import qualified Data.FiniteMap as FM + +myFromList :: Ord key => [(key, elt)] -> FM.FiniteMap key elt +myFromList = FM.listToFM + +myLookup :: Ord key => key -> FM.FiniteMap key elt -> Maybe elt +myLookup = flip FM.lookupFM +myMember = FM.elemFM +#endif + +------------------------------------------------------------------------------- +-- some auxiliary functions +------------------------------------------------------------------------------- + +transFM p f ps = myFromList (filter (p . snd) (map f (allFuncs ps))) + +funcDecls (Prog _ _ _ fs _) = fs + +allFuncs ps = concatMap funcDecls ps + +--- compute number of arguments by function type +typeArity :: TypeExpr -> Int +typeArity (TVar _) = 0 +typeArity (TCons _ _) = 0 +typeArity (FuncType _ t2) = 1+typeArity t2 + + +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 :: CaseType -> Expr -> [Expr -> Either (Expr,Expr) BranchExpr] -> Expr +noCCaseExpr ct v bs = + either (foldr ifte (Comb FuncCall (pre "failed") [])) (Case 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) + + ifte (b,e1) e2 = Comb FuncCall (pre "if_then_else") [b,e1,e2] + +noCCaseBr :: Pattern -> Expr -> Expr -> Either (Expr,Expr) BranchExpr +noCCaseBr p@(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 (snd . 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 cm e@(Var v) bs -> + let (e',i',ffe,_) = trans e i0 + (bs',i'',ffbs,_) = + fold i' (map (\ (Branch pat be) -> branch pat (trans be)) bs) + in (Case 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 (snd $ funcName f) mod aux i'' env e',i''+1, + (genFunc (snd $ 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 mod aux i env e = + Comb FuncCall (mod,f++aux++show i) (map Var env ++ [e]) + +genFunc :: String -> String -> String -> Int -> [VarIndex] -> Expr -> + CaseType -> [BranchExpr] -> FuncDecl +genFunc f mod aux i env e ct bs = + Func (mod,f++aux++show i) (length env+1) Private (TVar (-42)) $ + Rule (env++[v]) (Case ct (Var v) bs) + where + v = case e of + Var idx -> idx + _ -> foldr max 0 env + 1 + +removePVars :: [Int] -> Pattern -> [Int] +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 = flip elem + +nub xs = map fst $ FM.toList $ FM.fromList $ zip xs (repeat ()) + +------------------------------------------------------------ +-- elimination of constants +------------------------------------------------------------ + +externalConstants = map ((,) "Prelude") ["success","failed"] ++ + map ((,) "IO") ["stdin","stdout","stderr"] + +isToElim (Rule _ _) t = typeArity t==0 && t /= TVar (-42) +isToElim (External _) _ = False + +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 ct e bs) = Case ct (mapExp f e) (map mbr bs) + where + mbr (Branch p be) = Branch p (mapExp f be) + +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@(m,n) _ _ t r) = (mn,isToElim r t) + + elimConstsF f@(Func mn@(m,n) a v t (External s)) = 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 myMember fn constsfm + then Comb FuncCall fn [unit] + else e + _ -> e + +unit = Comb ConsCall (pre "()") [] +unitType = TCons (pre "()") [] + +pre s = ("Prelude",s) + +------------------------------------------------------------ +-- typing ambiguous type variables +------------------------------------------------------------ + +makeTypeMap :: [Prog] -> QName -> QName +makeTypeMap ps s = maybe (errorMsg s) id (myLookup s fm) + where + fm = myFromList (concatMap typeMapTypeDecl (concatMap typeDecls ps)) + errorMsg (m,n) = error ("PreTrans.makeTypeMap: cannot find type"++ + " of constructor "++m++"."++n) + +typeMapTypeDecl (TypeSyn _ _ _ _) = [] +typeMapTypeDecl (Type typeName _ _ consDecls) = + zip (map (\ (Cons name _ _ _) -> name) consDecls) (repeat typeName) + +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,noGlobal) = partition (containsGlobal . resultType . funcType) + (progFuncs prog) + + (gs,fs) = partition isGlobalDecl (progFuncs prog) + + isGlobal (TCons ("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 ("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 -> n/=("Global","global") + && and args) + (\bs e->and (e:map snd bs)) + (\_ ->id) (&&) + (\_ e bs -> and (e:bs)) (\_->id) + +isMonomorph :: TypeExpr -> Bool +isMonomorph (TVar _) = False +isMonomorph (TCons _ xs) = all isMonomorph xs +isMonomorph (FuncType a b) = all isMonomorph [a,b] + diff --git a/src/Curry/Compiler/SafeCalls.hs b/src/Curry/Compiler/SafeCalls.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/SafeCalls.hs @@ -0,0 +1,56 @@ +{-# OPTIONS -cpp #-} +{-# LANGUAGE FlexibleInstances #-} + +module Curry.Compiler.SafeCalls where + +#if __GLASGOW_HASKELL__ >= 610 +import Control.OldException +#else +import Control.Exception +#endif + +import Prelude hiding (catch) +import System + +-------------------- +-- safe calls +-------------------- + +data Safe m a = Safe (m (Maybe a)) + +(>>+) :: (Monad m) => m (Maybe a) -> m (Maybe b) -> m (Maybe b) +m >>+ f = m >>=+ (\_ -> f) + +(>>=+) :: (Monad m) => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) +m >>=+ f = do + res <- m + maybe (return Nothing) f res + +instance Monad (Safe IO) where + return x = Safe (return (Just x)) + (Safe act) >>= f = Safe $ do + res <- act + maybe (return Nothing) (\x->let Safe act = f x in act) res + fail s = Safe (putStrLn s >> return Nothing) + +safeSystem :: Bool -> String -> Safe IO () +safeSystem _ "" = Safe $ return (Just ()) +safeSystem verbose sysCall = Safe $ do + if verbose then putStrLn sysCall else return () + ec <- system sysCall + if ec==ExitSuccess then return (Just ()) else return Nothing + +safeIO :: IO a -> Safe IO a +safeIO action = Safe $ do + catch (action >>= return . Just) + putErr + +safeIOSeq :: IO a -> Safe IO a +safeIOSeq action = Safe $ do + catch (action >>= \x -> seq x (return (Just x))) + putErr + +safe :: Safe m a -> m (Maybe a) +safe (Safe act) = act + +putErr e = putStrLn ("IO action failed: "++show e) >> return Nothing diff --git a/src/Curry/Compiler/ShowFlatCurry.hs b/src/Curry/Compiler/ShowFlatCurry.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/ShowFlatCurry.hs @@ -0,0 +1,329 @@ +------------------------------------------------------------------------------ +--- Some tools to support meta-programming in Curry based on FlatCurry. +--- +--- This library contains +---
    +---
  • a show function for a string representation of FlatCurry programs +--- (function "showFlatProg") +--- +---
  • a function for showing FlatCurry expressions in (almost) Curry syntax +--- (function "showCurryExpr") +---
+--- +--- Note that the previously contained function "writeFLC" +--- is no longer supported. Use Flat2Fcy.writeFCY instead +--- and change file suffix into ".fcy"! +--- +--- @author Michael Hanus +--- @version August 2005 +------------------------------------------------------------------------------ + +module Curry.Compiler.ShowFlatCurry(showFlatProg,showFlatType,showFlatFunc, + showCurryType,showCurryExpr,showCurryId,showCurryVar) + where + +import List +import Char + +import Curry.FlatCurry.Type +import Curry.Compiler.Brace + +--- 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 Public = " Public " +showFlatVisibility Private = " Private " + +showFlatFixity InfixOp = " InfixOp " +showFlatFixity InfixlOp = " InfixlOp " +showFlatFixity InfixrOp = " InfixrOp " + +showFlatOp (Op name fix prec) = + "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" + +showFlatType :: TypeDecl -> String +showFlatType (Type (_,name) _ tpars []) = + "\ndata " ++ name ++ brace " " "" " " (map showTypeVar tpars) ++ " external" +showFlatType (Type (_,name) _ tpars consdecls) = + "\ndata " ++ name + ++ brace " " "" " " (map showTypeVar tpars) ++ " = " + ++ separate " | " (map showCurryCons consdecls) +showFlatType (TypeSyn (_,name) vis tpars texp) = + "\ntype " ++ name ++ brace " " "" " " (map showTypeVar tpars) ++ " = " + ++ showCurryType snd False texp + +showCurryCons (Cons (_,cname) arity vis types) = + cname ++ brace " " "" " " (map (showCurryType snd True) types) + +showFlatFunc :: FuncDecl -> String +showFlatFunc (Func (_,name) arity vis ftype rl) = + '\n':name++" :: "++showCurryType snd False ftype + +showFlatRule (Rule params expr) = + " (Rule " ++ showFlatList show params + ++ showFlatExpr expr ++ ")" +showFlatRule (External name) = + " (External " ++ show name ++ ")" + +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 FuncCall = "FuncCall" +showFlatCombType ConsCall = "ConsCall" +showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" +showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" + +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 (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 (Branch p e) = "(Branch " ++ showFlatPattern p + ++ showFlatExpr e ++ ")" + +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 i = if i<27 then [chr (97+i)] else 't':show i + +showCurryType :: ((String,String) -> 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 + | tc==("Prelude","[]") + = "[" ++ showCurryType tf False (head ts) ++ "]" -- list type + | take 2 (snd tc) == "(," -- tuple type + = "(" ++ concat (intersperse "," (map (showCurryType tf False) ts)) ++ ")" + | otherwise + = showBracketsIf nested + (tf tc ++ concatMap (\t->' ':showCurryType tf True t) ts) + +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 :: ((String,String) -> 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]) + | cf==("Prelude","apply") + = showBracketsIf nested + (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2) + | isAlpha (head (snd 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]))) + ++ "]" + | snd 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)) + | 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) + | take 2 (snd 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 exp) = + 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) exp) + +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 i = "v" ++ show i + +--- Shows an identifier in Curry form. Thus, operators are enclosed in brackets. +showCurryId name | isAlpha (head name) = name + | name == "[]" = name + | otherwise = ('(':name)++")" + +showCurryLit (Intc i) = show i +showCurryLit (Floatc f) = show f +showCurryLit (Charc c) = show c + +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 _ _ (Comb _ ("Prelude","[]") []) = [] +showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) = + showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 + +-- show a string constant +showCurryStringConstant (Comb _ ("Prelude","[]") []) = [] +showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) = + showCharExpr e1 ++ showCurryStringConstant e2 + +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 nested s = if nested then '(' : s ++ ")" else s + +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) + | name==("Prelude","[]") && args==[] = True + | 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 -> (name==("Prelude","[]") && null args) || + (name==("Prelude",":") && length args == 2 && + isCharConstant (head args) && isStringConstant (args!!1)) + _ -> False + +-- Is the expression a character constant? +isCharConstant :: Expr -> Bool +isCharConstant e = case e of + Lit (Charc _) -> True + _ -> False + + +------------------------------------------------------------------------------ + diff --git a/src/Curry/Compiler/ShowFunctionalProg.hs b/src/Curry/Compiler/ShowFunctionalProg.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/ShowFunctionalProg.hs @@ -0,0 +1,386 @@ +{-# 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 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 Curry.Compiler.ShowFunctionalProg( + showProg,showProgOpt,PrintOptions(..),defaultPrintOptions, + showTypeDecls, + showTypeDecl, + showTypeExpr, + showFuncDecl, + showExpr,showPattern, + isInfixOpName,isTuple) where + +import List +import Char(isDigit,ord) +import Maybe (isJust) +import Monad (ap) + +import Curry.Compiler.FunctionalProg +import Curry.Compiler.Brace + +------------------------------------------------------------------------------- +-- Functions to print an AbstractCurry program in standard Curry syntax +------------------------------------------------------------------------------- + +data PrintOptions = PrintOpt { unqual :: Bool, + sep :: String, + include :: String} + +defaultPrintOptions :: PrintOptions +defaultPrintOptions = PrintOpt False "" "" + +--- Shows an AbstractCurry program in standard Curry syntax. +showProg :: Prog -> String +showProg = showProgOpt defaultPrintOptions + +showProgOpt :: PrintOptions -> Prog -> String +showProgOpt opts p@(Prog m imports exports typedecls insdecls funcdecls opdecls) + = "{-# OPTIONS -cpp #-}\n\n" + ++ "{-# LANGUAGE RankNTypes, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}\n\n" + ++ "module "++m++showExports opts m exports ++" where\n\n" + ++ showImports imports + ++ "\n\n-- begin included\n\n" + ++ include opts + ++ "\n\n-- end included\n\n" + ++ showOpDecls opdecls + ++ showTypeDecls opts typedecls + ++ showInsDecls opts insdecls + ++ separate "\n\n" (map (showFuncDeclOpt opts) funcdecls) + ++ "\n" + + +----------------------------------------- +-- export declaration +----------------------------------------- + +showExports :: PrintOptions -> String -> [String] -> String +showExports _ m exports = brace " (" ")" ", " (("module "++m):exports) + +----------------------------------------- +-- import declaration +----------------------------------------- + +showImports :: [String] -> String +showImports imports = brace "" "\n\n" "\n" (map ("import "++) imports) + +----------------------------------------- +-- infix operators +----------------------------------------- + +showOpDecls :: [OpDecl] -> String +showOpDecls opdecls = brace "" "\n\n" "\n" (map showOpDecl opdecls) + +showOpDecl :: OpDecl -> String +showOpDecl (Op (_,name) fixity precedence) + = separate " " [showFixity fixity,show precedence,'`':showIdentifier name++"`"] + +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 :: PrintOptions -> [TypeDecl] -> String +showTypeDecls opts typedecls = + brace "" "\n\n" "\n\n" (map (showTypeDecl opts) typedecls) + +--- Shows an AbstractCurry type declaration in standard Curry syntax. +showTypeDecl :: PrintOptions -> TypeDecl -> String +showTypeDecl opts t = + decl ++ showIdentifier (snd (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 :: PrintOptions -> ConsDecl -> String +showConsDecl opts c + = separate (if strictArgs c then " !" else " ") + (showIdentifier (snd (consName c)) : + map (showTypeExpr opts True) (consArgs c)) + +showInsDecls :: PrintOptions -> [InstanceDecl] -> String +showInsDecls opts is = brace "" "\n\n" "\n\n" (map (showInsDecl opts) is) + +showInsDecl :: PrintOptions -> 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 opts tcs = brace "(" ") => " "," (map (showTypeClass opts) tcs) + +showTypeClass opts (TypeClass qn ts) + = snd 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 :: PrintOptions -> 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 (mod,name) typelist) = + (if nested && not (null typelist) then brace "(" ")" else separate) "" + [showTypeCons opts mod name typelist] +showTypeExpr opts nested (TConstr tcs t) = + (if nested then brace "(" ")" else separate) "" + [showTypeConstr opts tcs ++ showTypeExpr opts False t] + +showTypeCons :: PrintOptions -> String -> String -> [TypeExpr] -> String +showTypeCons opts mod name ts = + showSymbol opts (mod,name) ++ + brace " " "" " " (map (showTypeExpr opts True) ts) + + + +------------------------------------------ +-- function declarations +------------------------------------------ + +--- Shows an AbstractCurry function declaration in standard Curry syntax. +showFuncDecl = showFuncDeclOpt defaultPrintOptions + +showFuncDeclOpt :: PrintOptions -> 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 (snd (funcName f)) + +showRule :: PrintOptions -> 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 :: PrintOptions -> Rhs -> String +showRhs opts (SimpleExpr e) = " = "++showExprOpt opts e +showRhs opts (GuardedExpr gs) = brace "\n " "" "\n " (map (showGuard opts) gs) + +showGuard :: PrintOptions -> (Expr,Expr) -> String +showGuard opts (g,r) = " | " ++ showExprOpt opts g ++ " = " ++ showExprOpt opts r + +showLocalDecl :: PrintOptions -> 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 [] = [] + 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 = showExprOpt defaultPrintOptions + +showExprOpt :: PrintOptions -> Expr -> String +showExprOpt _ (Var name) = showIdentifier name +showExprOpt _ (Lit lit) = showLiteral lit +showExprOpt opts (Symbol name) = showSymbol opts name +showExprOpt opts exp@(Apply func arg) + | Just cs <- expAsCurryString exp = fromCurryString cs + | Just cl <- expAsCurryList exp = fromCurryList cl + | Just hs <- expAsHaskellString exp = fromHaskellString hs + | Just hl <- expAsHaskellList exp = 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 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 :: PrintOptions -> QName -> String +showSymbol _ ("",symName) = showIdentifier symName +showSymbol opts (m,symName) + | isInfixOpName symName = brace "(" ")" "" [m++"."++symName] + | not (unqual opts) || isExternalModule = m++"."++showIdentifier symName + | otherwise = showIdentifier symName + where + isExternalModule + = case m of {('E':'x':'t':'e':'r':'n':'a':'l':_) -> True;_->False} + +showLambda opts patts expr = + brace "\\ " " -> " " " (map (showPatternOpt opts) patts) ++ + showExprOpt opts expr + + +showStatement :: PrintOptions -> 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 ("CurryPrelude","List")) = Just "" +expAsCurryString (Apply (Apply (Symbol ("CurryPrelude",":<")) + (Apply (Symbol ("CurryPrelude","C_Char")) + (Lit (Charc c)))) + cs) + = Just (c:) `ap` expAsCurryString cs +expAsCurryString _ = Nothing + +-- try to transform expression into a Curry list +expAsCurryList :: Expr -> Maybe [Expr] +expAsCurryList (Symbol ("CurryPrelude","List")) = Just [] +expAsCurryList (Apply (Apply (Symbol ("CurryPrelude",":<")) x) xs) + = Just (x:) `ap` expAsCurryList xs +expAsCurryList _ = Nothing + +-- try to transform expression into a non-empty Haskell string +expAsHaskellString :: Expr -> Maybe String +expAsHaskellString (Symbol ("","[]")) = Just "" +expAsHaskellString (Apply (Apply (Symbol ("",":")) (Lit (Charc c))) cs) + = Just (c:) `ap` expAsHaskellString cs +expAsHaskellString _ = Nothing + +-- try to transform expression into a Haskell list +expAsHaskellList :: Expr -> Maybe [Expr] +expAsHaskellList (Symbol ("","[]")) = Just [] +expAsHaskellList (Apply (Apply (Symbol ("",":")) x) xs) + = Just (x:) `ap` expAsHaskellList xs +expAsHaskellList _ = Nothing + +------------------------------------------------------- +-- patterns +------------------------------------------------------- + +showPattern :: Pattern -> String +showPattern = showPatternOpt defaultPrintOptions + +showPatternOpt :: PrintOptions -> 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 :: PrintOptions -> 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) + +isCFuncType t = case t of + FuncType _ _ -> True + _ -> False + +isTuple [] = False +isTuple (c:cs) = c=='(' && dropWhile (==',') cs == ")" + +------------------------------------------------------------------------------ +--- constants used by AbstractCurryPrinter +------------------------------------------------------------------------------ + +infixIDs :: String +infixIDs = "~!@#$%^&*+-=<>?./|\\:" + + + + + + diff --git a/src/Curry/Compiler/Simplification.hs b/src/Curry/Compiler/Simplification.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Compiler/Simplification.hs @@ -0,0 +1,526 @@ +module Curry.Compiler.Simplification (simplifyProg) where + + +import Prelude hiding ( or,fail,catch ) + +import Curry.FlatCurry.Type +import Curry.FlatCurry.Goodies hiding ( freeVars ) +import qualified Curry.FlatCurry.Goodies as FCG + +import List ( sortBy, groupBy, partition ) + + +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 = 1 + maxlist (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) && + (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 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 cmpQName (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 && combName exp == (preludeName,failedName) + +replaceBranches :: Expr -> [BranchExpr] -> Expr +replaceBranches (Case ct e _) bs + | null bs = failed_ + | otherwise = Case 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 ct e bs -> let (ps,es) = unzip (map branch bs) + in (e:es, \ (e:es) -> Case 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 + +cmpQName :: Ord' QName +cmpQName = cmpPair cmpString cmpString + +cmpPair :: Ord' a -> Ord' b -> Ord' (a,b) +cmpPair cmpa cmpb (a1,b1) (a2,b2) = + case cmpa a1 a2 of + EQ -> cmpb b1 b2 + cmp -> cmp + + +-- 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 (preludeName,failedName) [] + +zero_ = Comb ConsCall (preludeName, "Zero") [] +pos_ n = Comb ConsCall (preludeName, "Pos") [n] +neg_ n = Comb ConsCall (preludeName, "Neg") [n] + +iHi_ = Comb ConsCall (preludeName, "IHi") [] +o_ n = Comb ConsCall (preludeName, "O") [n] +i_ n = Comb ConsCall (preludeName, "I") [n] + +x ?~ y = Comb FuncCall (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 ct e bs = exp + in Case 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 ("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 + +maxlist :: [Int] -> Int +maxlist [n] = n +maxlist (n:m:ns) = max n (maxlist (m:ns)) + + +--- A datatype is Traversable 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 Nothing. +--- 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 :: Int -> 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' = take arity [n ..] + in Just (Rule args' (replace (zip args (map Var args')) body) + ,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 + diff --git a/src/Curry/RunTimeSystem.hs b/src/Curry/RunTimeSystem.hs new file mode 100644 --- /dev/null +++ b/src/Curry/RunTimeSystem.hs @@ -0,0 +1,139 @@ +{-# OPTIONS -O0 #-} +module Curry.RunTimeSystem ( + module Curry.RunTimeSystem.BaseCurry, + module Curry.RunTimeSystem + ) where + +import System.IO +import Curry.RunTimeSystem.BaseCurry +import System.IO.Unsafe +import Data.IORef + +------------------------------------------------- +-- normal forms which are all based on ctcStore +-- and may be called from compiled programs. +------------------------------------------------- + + +--SHOCKING: there was an additional ctcStore False (nf ...) around here, +-- runtimes were desastrous. Why was that?????? +nfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a +nfCTC cont = ctcStore False (nf cont) + +hnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a +hnfCTC = ctcStore False + +gnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a +gnfCTC cont = ctcStore True (gnf cont) + +ghnfCTC :: (BaseCurry a,BaseCurry b) => (b -> Result a) -> b -> Result a +ghnfCTC = ctcStore True + +----------------------------------------------------------------- +-- treatment for the basic cases of flexible pattern matching +----------------------------------------------------------------- + +-- called by generated functions for matching failure +patternFail :: (BaseCurry a,BaseCurry b) => String -> a -> b +patternFail s x = case consKind x of + Failed -> addException (curryError s) x + _ -> failed (PatternMatchFail s) + + +---------------------------------------------------------------------- +-- generate logic objects +---------------------------------------------------------------------- + +-- generate branching +withRef :: (Int -> a) -> Int -> a +withRef f 0 = f 0 +withRef f i = f $! nextRef i + +--------------------------------------------------------------- +-- manipulating references: the unsafe part of CurryToHaskell +--------------------------------------------------------------- + +-- the global state of references +storeRefCounter :: IORef Int +{-# NOINLINE storeRefCounter #-} +storeRefCounter = unsafePerformIO (newIORef 1) + +-- generate a new reference +nextRef :: Int -> Int +{-# NOINLINE nextRef #-} +nextRef i = unsafePerformIO (do + v <- readIORef storeRefCounter + writeIORef storeRefCounter (v+i+1) + return v) + +--------------------------------------------------------------- +-- run-time options (also unsafe) +--------------------------------------------------------------- + +-- the easiest way to have different modes for run-time behaviour is +-- a global state of run-time options. +-- the settings are only read once and stay the same during the whole computation. + +data RunTimeOptions = RTO {currentModule :: String} + +runTimeDefaults :: RunTimeOptions +runTimeDefaults = RTO {currentModule = ""} + +runTimeOptions :: IORef RunTimeOptions +{-# NOINLINE runTimeOptions #-} +runTimeOptions = unsafePerformIO (newIORef runTimeDefaults) + +setRunTimeOptions :: RunTimeOptions -> IO () +setRunTimeOptions = writeIORef runTimeOptions + +freeF :: (BaseCurry b, BaseCurry a) => (b -> a) -> a +freeF = freeOrBased + +orF :: BaseCurry a => a -> a -> a +orF = orCTC + +----------------------------------------------------------------------- +-- implementation of getProgName (module System) expressions +----------------------------------------------------------------------- + +setProgName :: String -> IO () +setProgName n = do + opts <- readIORef runTimeOptions + writeIORef runTimeOptions (opts{currentModule=n}) + +setProgNameAndOrBased :: String -> IO () +setProgNameAndOrBased = setProgName + +getProgName :: IO String +getProgName = readIORef runTimeOptions >>= return . currentModule + +---------------------------------------------------------------------- +-- alternatives for implementation of options +---------------------------------------------------------------------- + +orCTC :: BaseCurry a => a -> a -> a +orCTC x y = branching (mkRefWithGenInfo NoGenerator (nextRef 0)) [x,y] + +-- free variables in or-based mode +freeOrBased :: (BaseCurry b, BaseCurry a) => (b -> a) -> a +freeOrBased f = f (generator (nextRef 0)) + +---------------------------------------------------------- +-- some declarations for external read and show instances +---------------------------------------------------------- + +ten,eleven,zero :: Int +ten = 10 +eleven = 11 +zero = 0 + +readQualified :: String -> String -> String -> [((),String)] +readQualified mod name r = [((),s) | (name',s) <- lex r, name' == name] + ++ [((),s3) | (mod',s1) <- lex r + , mod' == mod + , (".",s2) <- lex s1 + , (name',s3) <- lex s2 + , name' == name] + + + diff --git a/src/Curry/RunTimeSystem/BaseCurry.hs b/src/Curry/RunTimeSystem/BaseCurry.hs new file mode 100644 --- /dev/null +++ b/src/Curry/RunTimeSystem/BaseCurry.hs @@ -0,0 +1,103 @@ +module Curry.RunTimeSystem.BaseCurry ( + module Curry.RunTimeSystem.BaseCurry, + module Curry.RunTimeSystem.Store) where + +import Curry.RunTimeSystem.Store +import Data.IORef +import System.IO.Unsafe + +--trace' s x = unsafePerformIO (putStrLn s >> return x) + +-- On the top level io monad of each program we manage a store. +-- Because there is unsafe io and because some operations on +-- stores start out without one, a state might be without store. +type State = Store + +-- curry data terms are classified into ConsKinds +data ConsKind = Val | Branching | Failed deriving (Show,Eq) + +-- computations of (head) normal forms might residuate or not. +type HNFMode = Bool + +type Branches a = [a] + +data Exception + = ErrorCall String + | PatternMatchFail String + | AssertionFailed String + | PreludeFailed + | IOException String deriving Eq + +type C_Exceptions = Exception + +type Result a = State -> a +type Result' a = Store -> a + +---------------------------------------------------------------- +-- the BaseCurry class +---------------------------------------------------------------- + +class BaseCurry a where + -- computations of normal forms + nf :: BaseCurry b => (a -> Result b) -> a -> Result b + gnf :: BaseCurry b => (a -> Result b) -> a -> Result b + + -- constructors + generator :: Int -> a + failed :: C_Exceptions -> a + branching :: OrRef -> Branches a -> a + + -- category of given constructor + consKind :: a -> ConsKind + + -- selectors + exceptions :: a -> C_Exceptions + orRef :: a -> OrRef + branches :: a -> Branches a + +------------------------------------------------------------------ +-- implementation of call-time choice +------------------------------------------------------------------ + +-- This function controls all kinds of evaluations to (head) normal forms +-- IMPORTANT: if you change anything here, also update ExternalPrelude.prim_do +ctcStore :: (BaseCurry a,BaseCurry b) => HNFMode -> (a -> Result b) -> a -> Result b +ctcStore mode cont x state = + case consKind x of + Val -> cont x state + Failed -> addException err x + Branching -> let ref = orRef x + bs = branches x + in manipulateStore + (failed (curryError "ctcStore")) + contCTC + (\ ref' contSt -> if mode || not (isGenerator ref) + then lift contCTC (narrowOrRef ref) bs contSt + else cont (branching ref' bs) state) + + ( \ ref' x' state' -> branching ref' [contCTC x' state']) + ref bs state + where + contCTC = ctcStore mode cont + err = curryError ("Prelude."++if mode then "$#" else "$!") + +mapOr :: BaseCurry b => (a -> Result b) -> OrRef -> Branches a -> Result b +mapOr cont ref bs = manipulateStore + (failed (curryError "mapOr")) + cont + (\ _ -> lift cont (narrowOrRef ref) bs) + (\ ref x st -> branching ref [cont x st]) + ref bs + +lift :: BaseCurry b => (a -> Result b) -> OrRef -> Branches a + -> (Int -> State) -> b +lift cont ref bs contSt = + branching ref (zipWith (\ x i -> cont x (contSt i)) bs [0..]) + +addException :: (BaseCurry a,BaseCurry b) => Exception -> a -> b +addException _ x = failed (exceptions x) + +curryError :: String -> Exception +curryError = ErrorCall + + diff --git a/src/Curry/RunTimeSystem/Store.hs b/src/Curry/RunTimeSystem/Store.hs new file mode 100644 --- /dev/null +++ b/src/Curry/RunTimeSystem/Store.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Curry.RunTimeSystem.Store + (Store, + + emptyStore,changeStore, storeSize, + + + OrRef,OrRefKind(..), + deref,genInfo,cover,uncover,mkRef,isCovered, + manipulateStore, + + mkRefWithGenInfo,equalFromTo, + + isGenerator, isConstr,updRef, + + + narrowOrRef + ) where + +import Data.Generics (Data,Typeable) +import Data.IntMap +import Prelude hiding (lookup) +import System.IO.Unsafe + +trace s x = unsafePerformIO (putStrLn s >> return x) +trace' x = trace (show x) x + +---------------------------- +-- or references +---------------------------- + +data OrRefKind = Generator Int Int | Narrowed Int Int | NoGenerator + deriving (Data,Typeable,Eq,Ord,Show,Read) + +minMax :: OrRefKind -> (Int->Entry,Maybe (Int,Int)) +minMax NoGenerator = (Choice,Nothing) +minMax (Generator a b) = (Binding a b,Just (a,b)) +minMax (Narrowed a b) = (Binding a b,Just (a,b)) + +data OrRef = OrRef OrRefKind Int + | Layer OrRef + | Equality Int Int Int Int Int Int deriving (Data,Typeable,Eq,Ord,Show,Read) + +uncover :: OrRef -> OrRef +uncover (Layer x) = x +uncover x = x + +-- constructors +cover :: OrRef -> OrRef +cover = Layer + +mkRef :: Int -> Int -> Int -> OrRef +mkRef i j = OrRef (Generator i (i+j-1)) + +mkRefWithGenInfo :: OrRefKind -> Int -> OrRef +mkRefWithGenInfo = OrRef + +-- selectors +deref :: OrRef -> Int +deref r = case uncover r of + OrRef _ i -> i + _ -> (-42) + +genInfo :: OrRef -> (Int,Int,Int) +genInfo r = case uncover r of + OrRef (Generator i j) k -> (i,j,k) + +--refKind :: OrRef -> OrRefKind +--refKind r = (\ (OrRef x _) -> x) (uncover r) + +-- tester +isCovered :: OrRef -> Bool +isCovered (Layer _) = True +isCovered _ = False + +isGenerator :: OrRef -> Bool +isGenerator r = case uncover r of + OrRef (Generator _ _) _ -> True + _ -> False + + +--operations +updKind :: (OrRefKind -> OrRefKind) -> OrRef -> OrRef +updKind f (Layer r) = Layer (updKind f r) +updKind f (OrRef k i) = OrRef (f k) i +updKind f c@(Equality _ _ _ _ _ _) = c + +updRef :: (Int -> Int) -> OrRef -> OrRef +updRef f (Layer r) = Layer (updRef f r) +updRef f (OrRef k i) = OrRef k (f i) +updRef f c@(Equality _ _ _ _ _ _) = c + + +narrowOrRef :: OrRef -> OrRef +narrowOrRef = updKind narrow + where + narrow o@NoGenerator = o + narrow o@(Narrowed _ _)= o + narrow (Generator i j) = Narrowed i j + + +equalFromTo :: Int -> Int -> Int -> Int -> Int -> Int -> OrRef +equalFromTo = Equality + +isConstr :: OrRef -> Bool +isConstr (Equality _ _ _ _ _ _) = True +isConstr _ = False + +------------------------------------------------------- +-- finally: the store +------------------------------------------------------- +-- negative numbers are references to other variables +------------------------------------------------------- + +data Entry = Equal Int + | Choice Int + | Binding Int Int Int deriving (Eq,Ord,Show) + +choice :: Entry -> Int +choice (Choice i) = i +choice (Binding _ _ i) = i + +newtype Store = Store (IntMap Entry) deriving (Eq,Ord,Show) + +emptyStore :: Store +emptyStore = Store empty + +data StoreResult = Inconsistent + | NoBinding OrRef (Int -> Store) + | Found Int + | NewInfo OrRef Store + | FoundAndNewInfo Int OrRef Store + + +instance Show StoreResult where + show Inconsistent = "I" + show (NoBinding i _) = "no"++show i + show (Found i) = "f "++show i + show (NewInfo r st) = "n"++show (r,st) + show (FoundAndNewInfo i r st) = "fn"++show (i,r,st) + +changeStore :: OrRef -> Store -> StoreResult +changeStore r st = + case uncover r of + ref@(OrRef k r) -> let (toEntry,mima) = minMax k in + access (\ i -> updRef (\_->i) ref) + toEntry + (mima >>= \ (i,j) -> Just (i,j,r)) + r + st + eq -> chainInStore eq st + +chainInStore :: OrRef -> Store -> StoreResult +chainInStore r@(Equality fromMin fromMax from toMin toMax to) = + maybe Inconsistent (NewInfo r) . + foldChain (from:[fromMin .. fromMax]) (to:[toMin .. toMax]) + + +foldChain :: [Int] -> [Int] -> Store -> Maybe Store +foldChain xs@(x:_) ys@(y:_) st = foldl (>>=) (Just st) $ + case compare x y of + EQ -> [Just] + LT -> zipWith insertChain xs ys + GT -> zipWith insertChain ys xs + +--------------------------------------------------------------- +-- insert a chain, i.e. one variable referring to another +-- for future work: +-- result should have shortest chains and maximal entries +-- implement occur check along the line +--------------------------------------------------------------- + +insertChain :: Int -> Int -> Store -> Maybe Store +insertChain key val st@(Store store) = + case lookup key store of + Nothing -> Just (Store (insert key (Equal val) store)) + Just (Equal i) -> case compare i val of + EQ -> Just st + LT -> insertChain i val st + GT -> insertChain val i st + Just e -> insertEntry val e st + + +insertEntry :: Int -> Entry -> Store -> Maybe Store +insertEntry key e st@(Store store) = case lookup key store of + Nothing -> Just (Store (insert key e store)) + Just (Equal key') -> insertEntry key' e st + Just e' -> if choice e==choice e' + then Just st + else Nothing + +--------------------------------------------------------------- +-- access a reference, i.e. give back entry or insert function +-- for future work: +-- result should have shortest chains and maximal entries +--------------------------------------------------------------- + +access :: (Int->OrRef) -> (Int->Entry) -> Maybe (Int,Int,Int) -> Int -> Store -> StoreResult +access toOrRef toEntry mima key st@(Store store) = case lookup key store of + Nothing -> NoBinding (toOrRef key) (\ i -> Store (insert key (toEntry i) store)) + Just (Equal key') -> access toOrRef toEntry mima key' st + Just (Choice i) -> Found i + Just (Binding bmin bmax i) -> case mima of + Nothing -> Found i + Just (amin,amax,key0) -> case compare amin bmin of + EQ -> Found i + _ -> let info = Equality amin amax key0 bmin bmax key in + maybe Inconsistent (FoundAndNewInfo i info) $ + foldChain [amin .. amax] [bmin .. bmax] st + + +storeSize :: Store -> Int +storeSize (Store st) = size st + + +-- this is the way to access store from outside +manipulateStore :: a -> (b -> Store -> a) + -> (OrRef -> (Int -> Store) -> a) + -> (OrRef -> b -> Store -> a) + -> OrRef -> [b] -> Store -> a +manipulateStore err det br new ref bs st = case changeStore ref st of + Inconsistent -> err + Found i -> det (bs!!i) st + NoBinding i contSt -> br i contSt + NewInfo ref st -> new ref (head bs) st + FoundAndNewInfo i ref st -> new ref (bs!!i) st diff --git a/src/CurryToHaskell.hs b/src/CurryToHaskell.hs deleted file mode 100644 --- a/src/CurryToHaskell.hs +++ /dev/null @@ -1,1241 +0,0 @@ -module CurryToHaskell where - -import List -import Char -import System -import System.FilePath - -import MetaProgramming.FlatCurry -import MetaProgramming.FlatCurryGoodies hiding (consName) -import qualified FunctionalProg as C -import ShowFunctionalProg -import PreTrans hiding (nub,pre) -import Simplification ( simplifyProg ) -import Maybe -import SafeCalls -import Brace -import Config -import Names (modName,dbgModName,funcHsName,externalSpecName, - elimInfix,funName,functionName,constructorName) -import qualified Names as N -import Monad - ---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} - -compilations :: [String] -> Options -> IO [String] -compilations [] opts = return (done opts) -compilations (f:fs) opts = - safe (startCompilation opts{filename=f}) >>= - compilations fs . maybe opts id - -startCompilation :: Options -> Safe IO 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 -> Safe IO 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 -> Safe IO (String,[String],Options) -process opts0@(Opts{filename=fn}) = do - prog <- safeReadFlat opts0 (replaceExtension fn ".fcy") - 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 -> Safe IO (String,[String],Options) -skip opts = do - let fname = if doNotUseInterface opts - then replaceExtension (filename opts) ".fcy" - 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) -> Safe IO 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 ".fcy") lib) - foundFile <- warning basename (toPathList lib) foundFiles - let foundBasename = dropExtensions foundFile - return (opts{filename=foundBasename}) - -notUptodate opts@(Opts{filename=foundBasename}) = do - tSource1 <- getModTime (replaceExtension foundBasename ".fcy") - tSource2 <- getModTime (externalSpecName foundBasename) - let destination = inModuleSubdir (inKicsSubdir (funcHsName foundBasename)) - tDestination <- getModTime destination - return (tSource1 > tDestination || tSource2 > tDestination) - -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 ".fcy" - 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,unqualified,prog) = do - let fn' = inModuleSubdir (inKicsSubdir fn) - put 3 opts ("writing "++ fn') - let printOpts = defaultPrintOptions{unqual=unqualified,include=toInclude opts} - safeIO (writeKicsFile True 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 -> Safe IO 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 = [funcHsName 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} - hasInternalData = not $ null $ filter (not . isExternalType) types - - modules = [allinclusiveProg] - - -- filename, flag and module definitions - allinclusiveProg = (funcHsName (filename opts),False,allinclusive) - - - modul mName mImports mExports mTypes mInsts mFuncs = - C.Prog mName mImports mExports mTypes mInsts mFuncs [] - - allinclusive = modul funcName allIImports allIExports dataTypes instances functions - - -- the module names are: - funcName = modName name - - mainModuleName = "Main" - - -- the file names of these modules are: - funcFileName = funcHsName (filename opts) - mainFileName = "Main.hs" - - -- import lists - newImports = map modName imports - allIImports = ["Curry"] ++ newImports - - {- - -- this is the only special prelude treatment: - instImportName - | name=="Prelude" = instName ++ " hiding ("++opsUsedInInstances++")" - | otherwise = instName - opsUsedInInstances = "op_38_38" - -} - - -- export lists - allIExports = [] - - -- 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 (snd $ typeName t) (extData opts))) types - isToTransform t = case lookup (snd $ 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 (snd . funcName) fs - - genNewName s ts = if elem s ts then genNewName ('a':s) ts else s - - -mainMod (_,aux2) m opts = let aux = (m,snd (funName ("",aux2))) in - C.Prog "Main" ["Curry",modName "Prelude",m] - [] [] [] - [C.Func (m,"main") public untyped - (Just [C.Rule [] - (noguard $ fapp (hasPresym ">>") - [app (setProg opts) (C.String (mainModule opts)), - app (C.Symbol (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 = (m,aux1) - a2 = (m,aux2) - calla1 t orc = if debug opts - then Comb FuncCall ("Oracle","oracle"++if orc then "IO" else "") - [Comb (FuncPartCall 1) a1 []] - else Comb FuncCall a1 [] - printIO = ("Interactive","printIO") - lfs = zip (map (snd . 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 = ("Interactive","interactiveSols") -df = ("Prelude","allValuesD") -bf = ("Prelude","allValuesB") -pr = ("Interactive","printTerm") -hd = ("Prelude","head") -f ... g = Comb FuncCall (addPre ".") - [Comb (FuncPartCall 1) f [],Comb (FuncPartCall 1) g []] -ap_ f e = Comb FuncCall (addPre ".") [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") 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") 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 (m,n) vs - = [C.Cons (m,n++"Fail") 0 private False [tExceptions], - C.Cons (m,n++"Or") 2 private False - [tOrRef, tBranches newT]] - where - newT = C.TCons (m,n) (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 (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) = consName opts origName - - origMod = fst origName - - isPrelude = origMod=="Prelude" - - strEq = C.Func (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 [1..arity]), - C.PComb (consName opts cname) (map (toPVar' "y") [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 i,toVar' "y" i]) - - eq = C.Func (newModName,"eq") (transvis vis) untyped - (Just - (map eqRule consdecls - ++otherwiseExp 3 (concupresym opts "False"))) - - eqRule (Cons cname arity _ _) = - rule [C.PComb (consName opts cname) (map toPVar [1..arity]), - C.PComb (consName opts cname) (map (toPVar' "y") [1..arity])] - (noguard $ if arity==0 then concupresym opts "True" - else foldr1 (\ e es -> fapp (funcupresym "&&") (addStateArg [e,es])) - (map eqArgs [1..arity])) [] - where - eqArgs i = fapp (extInstPresym isPrelude "genEq") (addStateArg [toVar i,toVar' "y" i]) - - propagate = C.Func (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 [1..arity])]) - (noguard $ fapp (sym (consName opts cname)) - (map propCall [1 .. arity])) [] - where propCall i = fapp (C.Var "f") (addStateArg [toHInt (i-1),toVar i]) - - foldCurry = C.Func (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 [1..arity])]) - (noguard $ foldr appFold (C.Var "c") (map toVar [1 .. arity])) [] - where - appFold v e = fapp (C.Var "f") (addStateArg [v,e]) - - typeName = C.Func (newModName,"typeName") (transvis vis) untyped - (Just [C.Rule [_x] - (noguard $ C.String (snd origName)) []]) - - toTerm = C.Func (newModName,"toC_Term") (transvis vis) untyped - (Just - (map toTermRule (zip [1..] consdecls) ++ - [C.Rule [_x,_x, - C.PComb (newModName,name++"FreeVar") [C.PVar "r"]] - (noguard $ app (cupresym "C_Free") - (app c_int - (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 [1..arity])] - (noguard $ fapp (cupresym "C_Data") - [toInt nr,c_string_ origMod (snd cname), - dList isPrelude (map su [1..arity])]) [] - where - su i = fapp (cusym "ctcStore") - [C.Var "mode",app (cusym "toC_Term") (C.Var "mode"), - C.Var "store",toVar i] - - fromTerm = C.Func (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 (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) (snd cname)) - pts = dpList isPrelude (map toPVar [1..arity]) - e = noguard $ fapp (sym (consName opts cname)) - (map (app (cusym "fromC_Term") . toVar) [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) = consName opts origName - - origMod = fst origName - - isPrelude = origMod=="Prelude" - - nf gr = C.Func (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 [1..arity]), - C.PVar "state0"] - (noguard $ foldr (nflambda gr) - (fapp (C.Var "f") - [fapp (sym $ consName opts cname) - (map (toVar' "v") [1..arity]), - toVar' "state" arity]) - [1..arity]) []] - - nflambda gr i e = - fapp (cusym (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 (newModName,s) (transvis vis) untyped - (Just [C.Rule [C.PVar "i"] (noguard $ - fapp (cusym "withRef") [ - C.Lambda [C.PVar "r"] $ - fapp (sym (orName opts origName)) - [fapp (cusym "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 (cusym 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 (newModName,"consKind") (transvis vis) untyped - (Just - (map tester [(orName, 2, "Branching"), - (failName, 1, "Failed")] ++ - [C.Rule [_x] - (noguard $ (cusym "Val")) []])) - - tester (namer,arity,nameTest) = - C.Rule [C.PComb (namer opts origName) (take arity (repeat (_x)))] - (noguard (cusym nameTest)) [] - - selector nameSel namer arity number = - C.Func (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 (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 = funName fname - f = (modName (fst fname),auxName 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 ct _ bs -> error "case not normalized" - _ -> Just [rule (map toPVar lhs) (noguard trhs) []] - - auxName (_,name) = - if isInfixOpName name - then elimInfix name - else name - -transFunc opts _ (Func (m,fname) arity vis t (External _)) = - C.Func (funName (m,fname)) (transvis vis) (transFType opts arity t) - (Just [rule (map toPVar [1..arity]) - (noguard (fapp (C.Symbol (modName m,fname)) - (addStateArg (map toVar [1..arity])))) []]) - - -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 <- [("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@("Global","global") args) = - C.LetDecl [C.LocalPat (C.PVar "st") (hasPresym "Nothing") []] - (fapp (C.Symbol (funName 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 (funName fname) (addStateArg newArgs) - FuncPartCall i -> symApp (funName 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 -> ("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 && take 11 (fst f)=="CurryOracle" && length (fst f) > 11 - - 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 (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_ oName,C.Var "x"])] - - - closeRef i e = fapp (sym $ 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 (funcupresym "===") [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 (funName name) C.InfixOp p -transOp (Op name InfixlOp p) = C.Op (funName name) C.InfixlOp p -transOp (Op name InfixrOp p) = C.Op (funName name) C.InfixrOp p - - ----------------------------------------------------------------- --- generating instances for read and show ----------------------------------------------------------------- - -genInstances _ _ _ [] = [] -genInstances cl genFunc opts (t:ts) - | maybe False (elem cl) (lookup (snd $ 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 (addPre "Show") [toTVar v]) vars) - (C.TypeClass (addPre "Show") [C.TCons (newModName,name) (map toTVar vars)]) - [showFunction False opts t] - where - (newModName,name) = consName opts origName - - - -showFunction showQ opts t@(Type origName vis vars consdecls) - | maybe False (elem Show) (lookup (snd $ typeName t) (extInsts opts)) - = showsPrec [C.Rule [] (C.SimpleExpr (hasPresym "showsPrec")) []] - | otherwise = showsPrec (map showsPrecRule consdecls - ++[showGenerator]) - where - showParenArg (_,'(':_) = hasPresym "True" - showParenArg _ = if showQ then hasPresym "True" else lt (C.Var "d") app_prec - showsPrecName = if showQ then "showQ" else "showsPrec" - showsPrecSym = (if showQ then extInstPresym (fst origName=="Prelude") - else hasPresym) showsPrecName - - identifier (_,"()") = "()" - identifier (cm,cn) = if showQ then cm++"."++cn else cn - - opening (_,'(':_) = "" - opening cmn = identifier cmn ++ " " - - separator (_,'(':_) = ',' - separator _ = ' ' - - showsPrec rs = C.Func (newModName,showsPrecName) - (transvis vis) untyped - (Just rs) - - (newModName,name) = 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 [1..arity])] - (C.SimpleExpr (fapp (hasPresym "showParen") - [showParenArg cname,sym ("","showStr")])) - [C.LocalFunc (C.Func ("","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 [1..arity])) - - - callShowsPrec i = fapp showsPrecSym [add_prec cname,toVar i] - - points = foldr1 point - - point x y = fapp (hasPresym ".") [x,y] - - - showTuple = C.Func (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 [1..arity])] - (C.SimpleExpr (app (hasPresym "showString") - (app (hasPresym "show") - (fapp (sym ("",snd cname)) - (map toVar [1..arity]))))) [] - - showGenerator = C.Rule [_x, - C.PComb (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@(modName,name) vis vars consdecls) = - C.Instance (map (\v -> C.TypeClass (addPre "Read") [toTVar v]) vars) - (C.TypeClass (addPre "Read") [C.TCons (newModName,newName) (map toTVar vars)]) - [if isTuple (snd origName) then readTuple else readsPrec] - where - c@(newModName,newName) = consName opts origName - - readsPrec = C.Func (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@(cmodName,cname) arity _ args) = C.Lambda [C.PVar "r"] - (C.ListComp (fapp (sym ("","(,)")) - [fapp (sym newC) - (map toVar [1..arity]), - toVar' "r" arity ]) - (C.SPat (pair (C.PVar "_") (toPVar' "r" 0)) - (fapp (cusym "readQualified") [string_ cmodName,string_ cname,C.Var "r"]): - map readArg [1..arity])) - - where - newC@(newMod,newCName) = consName opts cn - - readArg i = C.SPat (pair (toPVar' "x" i) (toPVar' "r" i)) - (fapp (hasPresym "readsPrec") - [add_prec ("",""), - toVar' "r" (i-1)]) - - readTuple = C.Func (newModName,"readsPrec") (transvis vis) untyped - (Just (map readTupleRule consdecls)) - - readTupleRule (Cons t@(_,tup) arity _ args) = - C.Rule [C.PVar "d",C.PVar "r"] - (C.SimpleExpr - (fapp (hasPresym "map") [sym ("","readTup"), - fapp (hasPresym "readsPrec") - [C.Var "d",C.Var "r"]])) - [C.LocalFunc (C.Func ("","readTup") (transvis vis) untyped - (Just [C.Rule [pair (C.PComb ("",tup) (map toPVar [1..arity])) - (C.PVar "s")] - (C.SimpleExpr - (fapp (sym ("","(,)")) - [fapp (sym (consName opts t)) (map toVar [1..arity]), - C.Var "s"])) []]))] - - pair x y = C.PComb ("","(,)") [x,y] - - -add_prec (_,'(':_) = cusym "zero" -add_prec _ = 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 (m,n) = (modName m,cn) - where - cn | extCons opts = n - | otherwise = constructorName n - -freeVarName opts = N.freeVarName . consName opts -failName opts = N.failName . consName opts -orName opts = N.orName . consName opts -suspName opts = N.suspName . consName opts - -curryName s = ("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)) = - C.Func (funName n) (transvis vis) (transFType opts 0 t) - (Just [C.Rule [] - (C.SimpleExpr (transExpr opts e)) []]) - ----------------------------------------------------------------- --- constants and abbreviations for flat, resp. abstract curry ----------------------------------------------------------------- - --- prelude symbols -sym = C.Symbol -prelude = "Prelude" -addPre = (,) prelude -hasPresym = sym . addPre -cupresym = sym . (,) (modName prelude) -funcupresym = sym . funName . addPre -concupresym opts = sym . consName opts . addPre - --- symbols from Curry library -curryModule = "Curry" -cu = (,) curryModule -cusym = sym . cu - -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 (cupresym "pf")) - --- partial constructor call, one argument missing -pc :: Options -> Int -> C.Expr -> C.Expr -pc opts = app . partial opts (fapp (cupresym "pc")) - --- partial application, more than one argument -pa :: Options -> [C.Expr] -> C.Expr -pa opts = fapp (cupresym "pa") - --- function compostition (.) -cp :: Options -> [C.Expr] -> C.Expr -cp opts = fapp (cupresym "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 (addPre 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 (addPre "[]") [a] -c_tList a = curryTCons "List" [a] - -tPair a b = C.TCons (addPre "(,)") [a,b] - -tMaybe a = C.TCons (addPre "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 (addPre ">>=") [x,y] - -flatEq x y = Comb FuncCall (addPre "===") [x,y] - -flatGst x = Comb FuncCall (addPre "getSearchTree") [x] - -mid = hasPresym "id" - -baseType _ s = addPre s - -toVar i = C.Var (xvar i) - -toVar' s i = C.Var (varName s i) - -xvar = varName "x" - -varName s i = s++show i - -toPVar i = C.PVar (varName "x" i) - -toPVar' s i = C.PVar (varName s i) - -toTVar i = C.TVar (varName "t" i) - -primValue opts v = - app (sym $ consName opts{extCons=True} (addPre "PrimValue")) v - - -toList [] = C.Symbol ("","[]") -toList (x:xs) = app2 (C.Symbol ("",":")) x (toList xs) - -toPList [] = C.PComb ("","[]") [] -toPList (x:xs) = C.PComb ("",":") [x,toPList xs] - -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 (modName "Prelude","C_Char") [C.PLit (C.Charc c)] - | otherwise = C.PComb (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 = cupresym "C_Int" - -toChar opts c = app (sym (consName opts ("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 ("Prelude","IO") [x] -unitT = TCons ("Prelude","()") [] - -hasUnit = sym ("","()") - -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 ("",":")) [x,xs] -nil = sym ("","[]") - -string_ n = list_ (map char_ n) - -c_char_ c = fapp (cusym "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 (cupresym ":<") [x,xs] -c_nil = cupresym "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 (cupresym ":<") [x,xs] -bc_nil = cupresym "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 ("",":") [x,xs] -pnil = C.PComb ("","[]") [] - -c_plist_ [] = c_pnil -c_plist_ (x:xs) = c_pcons_ x (c_plist_ xs) - -c_pcons_ x xs = C.PComb (addPre ":<") [x,xs] -c_pnil = C.PComb (addPre "List") [] - -bc_plist_ [] = bc_pnil -bc_plist_ (x:xs) = bc_pcons_ x (bc_plist_ xs) - -bc_pcons_ x xs = C.PComb (addPre ":<") [x,xs] -bc_pnil = C.PComb (addPre "List") [] - - -pstring_ n = plist_ (map pchar_ n) - -underscores i = replicate i (_x) - -qname_ (m,f) = string_ (m++'.':f) - -extInstPresym _ s = sym (modName "Prelude",s) - -extFuncPresym opts s = sym (modName "Prelude",s) - - -_x = C.PVar "_" - -st = C.Var "st" - diff --git a/src/FunctionalProg.hs b/src/FunctionalProg.hs deleted file mode 100644 --- a/src/FunctionalProg.hs +++ /dev/null @@ -1,248 +0,0 @@ ------------------------------------------------------------------------------- ---- 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 - ------------------------------------------------------------------------------- --- 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 ---- ---- (CProg modname imports typedecls functions opdecls) ---- ---- 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. ---- 
---- 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.
----
- -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 Int 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. ---- 
---- 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.
----
- -data FuncDecl = Func { funcName :: QName, - funcVis :: Visibility, - funcType :: Maybe TypeExpr, - funcBody :: Maybe [Rule]} deriving (Show,Eq,Read) - - ---- A rule is either a list of formal parameters together with an expression ---- (i.e., a rule in flat form), a list of general program rules with ---- an evaluation annotation, or it is externally defined - ---- The most general form of a rule. It consists of a list of patterns ---- (left-hand side), a list of guards ("success" if not present in the ---- source text) with their corresponding right-hand sides, and ---- a list of local declarations. -data Rule = Rule { patterns :: [Pattern], - rhs :: Rhs, - locDecls :: [LocalDecl]} - deriving (Show,Eq,Read) - -data Rhs = SimpleExpr Expr | GuardedExpr [(Expr,Expr)] deriving (Show,Eq,Read) - - ---- Data type for representing local (let/where) declarations -data LocalDecl = - LocalFunc FuncDecl -- local function declaration - | LocalPat Pattern Expr [LocalDecl] -- local pattern declaration - deriving (Show,Eq,Read) - ---- Data type for representing Curry expressions. - -data Expr = - Var VarName -- variable (unique index / name) - | Lit Literal -- literal (Integer/Float/Char constant) - | Symbol QName -- a defined symbol with module and name - | Apply Expr Expr -- application (e1 e2) - | Lambda [Pattern] Expr -- lambda abstraction - | LetDecl [LocalDecl] Expr -- local let declarations - | DoExpr [Statement] -- do expression - | ListComp Expr [Statement] -- list comprehension - | Case Expr [BranchExpr] -- case expression - | String String - deriving (Show,Eq,Read) - ---- Data type for representing statements in do expressions and ---- list comprehensions. - -data Statement = SExpr Expr -- an expression (I/O action or boolean) - | SPat Pattern Expr -- a pattern definition - | SLet [LocalDecl] -- a local let declaration - deriving (Show,Eq,Read) - ---- Data type for representing pattern expressions. - -data Pattern = - PVar VarName -- pattern variable (unique index / name) - | PLit Literal -- literal (Integer/Float/Char constant) - | PComb QName [Pattern] -- application (m.c e1 ... en) of n-ary - -- constructor m.c (CPComb (m,c) [e1,...,en]) - | AsPat VarName Pattern - deriving (Show,Eq,Read) - ---- Data type for representing branches in case expressions. - -data BranchExpr = Branch Pattern Expr - deriving (Show,Eq,Read) - ---- Data type for representing literals occurring in an expression. ---- It is either an integer, a float, or a character constant. - -data Literal = Intc Integer - | HasIntc Integer - | Floatc Double - | Charc Char - deriving (Show,Eq,Read) - diff --git a/src/InstallDir.hs b/src/InstallDir.hs deleted file mode 100644 --- a/src/InstallDir.hs +++ /dev/null @@ -1,3 +0,0 @@ -module InstallDir where -installDir = "/home/bbr/kics" -ghc_call= "/home/ghc/bin/ghc" diff --git a/src/KicsSubdir.hs b/src/KicsSubdir.hs deleted file mode 100644 --- a/src/KicsSubdir.hs +++ /dev/null @@ -1,133 +0,0 @@ -module KicsSubdir where - -import System.Directory -import System.FilePath -import System.Time (ClockTime) -import Control.Monad (when) -import List (intersperse,nubBy) - -curDirPath :: FilePath -curDirPath = "." - -path :: String -> [String] -path = canonPath . separateBy isPathSeparator - where - canonPath (c:cs) = c:filter (not . null) cs - --- 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@[n] = sub:ps - add ps@[p,n] | p==sub = ps - add (p:ps) = p:add ps - -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 = "kics" -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 - -inModuleSubdir :: String -> String -inModuleSubdir s = s `inSubdir` "Curry" `inSubdir` "Module" - ---write a file to curry subdirectory - -writeKicsFile :: Bool -> String -> String -> IO String -writeKicsFile isHsModule filename contents = do - let filename' | isHsModule = inModuleSubdir (inKicsSubdir filename) - | otherwise = 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 path = do - if any isPathSeparator fn - then findFile fn - else do - let fs = nubBy equalFilePath $ map (++fn) path - founds <- mapM findFile fs - return (nubBy equalFilePath $ concat founds) - - where - findFile = onExistingFileDo doesExist - doesExist fn = do ex <- doesFileExist fn - if ex then return [fn] else return [] diff --git a/src/MyReadline.hs b/src/MyReadline.hs deleted file mode 100644 --- a/src/MyReadline.hs +++ /dev/null @@ -1,6 +0,0 @@ -module MyReadline (readline, addHistory,initializeReadline) where - -import System.Console.Readline - -initializeReadline :: IO () -initializeReadline = return () diff --git a/src/Names.hs b/src/Names.hs deleted file mode 100644 --- a/src/Names.hs +++ /dev/null @@ -1,74 +0,0 @@ -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 (m,n) = - case m of - "" -> ("",preludeConstructorName n) - _ -> (modName 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 --} - -functionName n | isInfixOpName n = elimInfix n - | otherwise = 'c':'_':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.Module." s -funcHsName s = replaceExtension s ".hs" - -externalSpecName s = replaceExtension s ".hs.include" - -dbgMName = "Oracle" -dbgModName = insertName dbgMName -strictPrefix = "S" -mkStrictName = insertName strictPrefix - - --- names for new constructors ---addPrefix s _ (p@"Prelude","Int") = (instModName p,"C_Int"++s) ---addPrefix s _ (p@"Prelude","Float") = (instModName p,"Prim"++s) -addPrefix s (m,n) = (m,n++s) - -freeVarName = addPrefix "FreeVar" -failName = addPrefix "Fail" -orName = addPrefix "Or" -suspName = addPrefix "Susp" - - diff --git a/src/PreTrans.hs b/src/PreTrans.hs deleted file mode 100644 --- a/src/PreTrans.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# OPTIONS -cpp #-} --------------------------------- --- preliminary transformations --------------------------------- -module PreTrans - where - -import MetaProgramming.FlatCurry -import MetaProgramming.FlatCurryGoodies -import Maybe -import List hiding (nub) - -#if __GLASGOW_HASKELL__ >= 604 -import qualified Data.Map as FM - -myFromList = FM.fromList -myLookup = FM.lookup -myMember = FM.member - -#else -import qualified Data.FiniteMap as FM - -myFromList :: Ord key => [(key, elt)] -> FM.FiniteMap key elt -myFromList = FM.listToFM - -myLookup :: Ord key => key -> FM.FiniteMap key elt -> Maybe elt -myLookup = flip FM.lookupFM -myMember = FM.elemFM -#endif - -------------------------------------------------------------------------------- --- some auxiliary functions -------------------------------------------------------------------------------- - -transFM p f ps = myFromList (filter (p . snd) (map f (allFuncs ps))) - -funcDecls (Prog _ _ _ fs _) = fs - -allFuncs ps = concatMap funcDecls ps - ---- compute number of arguments by function type -typeArity :: TypeExpr -> Int -typeArity (TVar _) = 0 -typeArity (TCons _ _) = 0 -typeArity (FuncType _ t2) = 1+typeArity t2 - - -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 :: CaseType -> Expr -> [Expr -> Either (Expr,Expr) BranchExpr] -> Expr -noCCaseExpr ct v bs = - either (foldr ifte (Comb FuncCall (pre "failed") [])) (Case 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) - - ifte (b,e1) e2 = Comb FuncCall (pre "if_then_else") [b,e1,e2] - -noCCaseBr :: Pattern -> Expr -> Expr -> Either (Expr,Expr) BranchExpr -noCCaseBr p@(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 (snd . 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 cm e@(Var v) bs -> - let (e',i',ffe,_) = trans e i0 - (bs',i'',ffbs,_) = - fold i' (map (\ (Branch pat be) -> branch pat (trans be)) bs) - in (Case 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 (snd $ funcName f) mod aux i'' env e',i''+1, - (genFunc (snd $ 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 mod aux i env e = - Comb FuncCall (mod,f++aux++show i) (map Var env ++ [e]) - -genFunc :: String -> String -> String -> Int -> [VarIndex] -> Expr -> - CaseType -> [BranchExpr] -> FuncDecl -genFunc f mod aux i env e ct bs = - Func (mod,f++aux++show i) (length env+1) Private (TVar (-42)) $ - Rule (env++[v]) (Case ct (Var v) bs) - where - v = case e of - Var idx -> idx - _ -> foldr max 0 env + 1 - -removePVars :: [Int] -> Pattern -> [Int] -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 = flip elem - -nub xs = map fst $ FM.toList $ FM.fromList $ zip xs (repeat ()) - ------------------------------------------------------------- --- elimination of constants ------------------------------------------------------------- - -externalConstants = map ((,) "Prelude") ["success","failed"] ++ - map ((,) "IO") ["stdin","stdout","stderr"] - -isToElim (Rule _ _) t = typeArity t==0 && t /= TVar (-42) -isToElim (External _) _ = False - -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 ct e bs) = Case ct (mapExp f e) (map mbr bs) - where - mbr (Branch p be) = Branch p (mapExp f be) - -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@(m,n) _ _ t r) = (mn,isToElim r t) - - elimConstsF f@(Func mn@(m,n) a v t (External s)) = 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 myMember fn constsfm - then Comb FuncCall fn [unit] - else e - _ -> e - -unit = Comb ConsCall (pre "()") [] -unitType = TCons (pre "()") [] - -pre s = ("Prelude",s) - ------------------------------------------------------------- --- typing ambiguous type variables ------------------------------------------------------------- - -makeTypeMap :: [Prog] -> QName -> QName -makeTypeMap ps s = maybe (errorMsg s) id (myLookup s fm) - where - fm = myFromList (concatMap typeMapTypeDecl (concatMap typeDecls ps)) - errorMsg (m,n) = error ("PreTrans.makeTypeMap: cannot find type"++ - " of constructor "++m++"."++n) - -typeMapTypeDecl (TypeSyn _ _ _ _) = [] -typeMapTypeDecl (Type typeName _ _ consDecls) = - zip (map (\ (Cons name _ _ _) -> name) consDecls) (repeat typeName) - -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,noGlobal) = partition (containsGlobal . resultType . funcType) - (progFuncs prog) - - (gs,fs) = partition isGlobalDecl (progFuncs prog) - - isGlobal (TCons ("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 ("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 -> n/=("Global","global") - && and args) - (\bs e->and (e:map snd bs)) - (\_ ->id) (&&) - (\_ e bs -> and (e:bs)) (\_->id) - -isMonomorph :: TypeExpr -> Bool -isMonomorph (TVar _) = False -isMonomorph (TCons _ xs) = all isMonomorph xs -isMonomorph (FuncType a b) = all isMonomorph [a,b] - diff --git a/src/SafeCalls.hs b/src/SafeCalls.hs deleted file mode 100644 --- a/src/SafeCalls.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS -cpp #-} -{-# LANGUAGE FlexibleInstances #-} - -module SafeCalls where - -#if __GLASGOW_HASKELL__ >= 610 -import Control.OldException -#else -import Control.Exception -#endif - -import Prelude hiding (catch) -import System - --------------------- --- safe calls --------------------- - -data Safe m a = Safe (m (Maybe a)) - -(>>+) :: (Monad m) => m (Maybe a) -> m (Maybe b) -> m (Maybe b) -m >>+ f = m >>=+ (\_ -> f) - -(>>=+) :: (Monad m) => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) -m >>=+ f = do - res <- m - maybe (return Nothing) f res - -instance Monad (Safe IO) where - return x = Safe (return (Just x)) - (Safe act) >>= f = Safe $ do - res <- act - maybe (return Nothing) (\x->let Safe act = f x in act) res - fail s = Safe (putStrLn s >> return Nothing) - -safeSystem :: Bool -> String -> Safe IO () -safeSystem _ "" = Safe $ return (Just ()) -safeSystem verbose sysCall = Safe $ do - if verbose then putStrLn sysCall else return () - ec <- system sysCall - if ec==ExitSuccess then return (Just ()) else return Nothing - -safeIO :: IO a -> Safe IO a -safeIO action = Safe $ do - catch (action >>= return . Just) - putErr - -safeIOSeq :: IO a -> Safe IO a -safeIOSeq action = Safe $ do - catch (action >>= \x -> seq x (return (Just x))) - putErr - -safe :: Safe m a -> m (Maybe a) -safe (Safe act) = act - -putErr e = putStrLn ("IO action failed: "++show e) >> return Nothing diff --git a/src/ShowFlatCurry.hs b/src/ShowFlatCurry.hs deleted file mode 100644 --- a/src/ShowFlatCurry.hs +++ /dev/null @@ -1,328 +0,0 @@ ------------------------------------------------------------------------------- ---- Some tools to support meta-programming in Curry based on FlatCurry. ---- ---- This library contains ----
    ----
  • a show function for a string representation of FlatCurry programs ---- (function "showFlatProg") ---- ----
  • a function for showing FlatCurry expressions in (almost) Curry syntax ---- (function "showCurryExpr") ----
---- ---- Note that the previously contained function "writeFLC" ---- is no longer supported. Use Flat2Fcy.writeFCY instead ---- and change file suffix into ".fcy"! ---- ---- @author Michael Hanus ---- @version August 2005 ------------------------------------------------------------------------------- - -module ShowFlatCurry(showFlatProg,showFlatType,showFlatFunc, - showCurryType,showCurryExpr,showCurryId,showCurryVar) - where - -import MetaProgramming.FlatCurry -import List -import Char -import Brace - ---- 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 Public = " Public " -showFlatVisibility Private = " Private " - -showFlatFixity InfixOp = " InfixOp " -showFlatFixity InfixlOp = " InfixlOp " -showFlatFixity InfixrOp = " InfixrOp " - -showFlatOp (Op name fix prec) = - "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" - -showFlatType :: TypeDecl -> String -showFlatType (Type (_,name) _ tpars []) = - "\ndata " ++ name ++ brace " " "" " " (map showTypeVar tpars) ++ " external" -showFlatType (Type (_,name) _ tpars consdecls) = - "\ndata " ++ name - ++ brace " " "" " " (map showTypeVar tpars) ++ " = " - ++ separate " | " (map showCurryCons consdecls) -showFlatType (TypeSyn (_,name) vis tpars texp) = - "\ntype " ++ name ++ brace " " "" " " (map showTypeVar tpars) ++ " = " - ++ showCurryType snd False texp - -showCurryCons (Cons (_,cname) arity vis types) = - cname ++ brace " " "" " " (map (showCurryType snd True) types) - -showFlatFunc :: FuncDecl -> String -showFlatFunc (Func (_,name) arity vis ftype rl) = - '\n':name++" :: "++showCurryType snd False ftype - -showFlatRule (Rule params expr) = - " (Rule " ++ showFlatList show params - ++ showFlatExpr expr ++ ")" -showFlatRule (External name) = - " (External " ++ show name ++ ")" - -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 FuncCall = "FuncCall" -showFlatCombType ConsCall = "ConsCall" -showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" -showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" - -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 (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 (Branch p e) = "(Branch " ++ showFlatPattern p - ++ showFlatExpr e ++ ")" - -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 i = if i<27 then [chr (97+i)] else 't':show i - -showCurryType :: ((String,String) -> 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 - | tc==("Prelude","[]") - = "[" ++ showCurryType tf False (head ts) ++ "]" -- list type - | take 2 (snd tc) == "(," -- tuple type - = "(" ++ concat (intersperse "," (map (showCurryType tf False) ts)) ++ ")" - | otherwise - = showBracketsIf nested - (tf tc ++ concatMap (\t->' ':showCurryType tf True t) ts) - -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 :: ((String,String) -> 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]) - | cf==("Prelude","apply") - = showBracketsIf nested - (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2) - | isAlpha (head (snd 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]))) - ++ "]" - | snd 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)) - | 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) - | take 2 (snd 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 exp) = - 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) exp) - -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 i = "v" ++ show i - ---- Shows an identifier in Curry form. Thus, operators are enclosed in brackets. -showCurryId name | isAlpha (head name) = name - | name == "[]" = name - | otherwise = ('(':name)++")" - -showCurryLit (Intc i) = show i -showCurryLit (Floatc f) = show f -showCurryLit (Charc c) = show c - -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 _ _ (Comb _ ("Prelude","[]") []) = [] -showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) = - showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 - --- show a string constant -showCurryStringConstant (Comb _ ("Prelude","[]") []) = [] -showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) = - showCharExpr e1 ++ showCurryStringConstant e2 - -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 nested s = if nested then '(' : s ++ ")" else s - -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) - | name==("Prelude","[]") && args==[] = True - | 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 -> (name==("Prelude","[]") && null args) || - (name==("Prelude",":") && length args == 2 && - isCharConstant (head args) && isStringConstant (args!!1)) - _ -> False - --- Is the expression a character constant? -isCharConstant :: Expr -> Bool -isCharConstant e = case e of - Lit (Charc _) -> True - _ -> False - - ------------------------------------------------------------------------------- - diff --git a/src/ShowFunctionalProg.hs b/src/ShowFunctionalProg.hs deleted file mode 100644 --- a/src/ShowFunctionalProg.hs +++ /dev/null @@ -1,385 +0,0 @@ -{-# 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 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,PrintOptions(..),defaultPrintOptions, - showTypeDecls, - showTypeDecl, - showTypeExpr, - showFuncDecl, - showExpr,showPattern, - isInfixOpName,isTuple) where - -import FunctionalProg -import List -import Char(isDigit,ord) -import Maybe (isJust) -import Monad (ap) -import Brace -import Debug.Trace - -------------------------------------------------------------------------------- --- Functions to print an AbstractCurry program in standard Curry syntax -------------------------------------------------------------------------------- - -data PrintOptions = PrintOpt { unqual :: Bool, - sep :: String, - include :: String} - -defaultPrintOptions :: PrintOptions -defaultPrintOptions = PrintOpt False "" "" - ---- Shows an AbstractCurry program in standard Curry syntax. -showProg :: Prog -> String -showProg = showProgOpt defaultPrintOptions - -showProgOpt :: PrintOptions -> Prog -> String -showProgOpt opts p@(Prog m imports exports typedecls insdecls funcdecls opdecls) - = "{-# OPTIONS -cpp #-}\n\n" - ++ "{-# LANGUAGE RankNTypes, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}\n\n" - ++ "module "++m++showExports opts m exports ++" where\n\n" - ++ showImports imports - ++ "\n\n-- begin included\n\n" - ++ include opts - ++ "\n\n-- end included\n\n" - ++ showOpDecls opdecls - ++ showTypeDecls opts typedecls - ++ showInsDecls opts insdecls - ++ separate "\n\n" (map (showFuncDeclOpt opts) funcdecls) - ++ "\n" - - ------------------------------------------ --- export declaration ------------------------------------------ - -showExports :: PrintOptions -> String -> [String] -> String -showExports _ m exports = brace " (" ")" ", " (("module "++m):exports) - ------------------------------------------ --- import declaration ------------------------------------------ - -showImports :: [String] -> String -showImports imports = brace "" "\n\n" "\n" (map ("import "++) imports) - ------------------------------------------ --- infix operators ------------------------------------------ - -showOpDecls :: [OpDecl] -> String -showOpDecls opdecls = brace "" "\n\n" "\n" (map showOpDecl opdecls) - -showOpDecl :: OpDecl -> String -showOpDecl (Op (_,name) fixity precedence) - = separate " " [showFixity fixity,show precedence,'`':showIdentifier name++"`"] - -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 :: PrintOptions -> [TypeDecl] -> String -showTypeDecls opts typedecls = - brace "" "\n\n" "\n\n" (map (showTypeDecl opts) typedecls) - ---- Shows an AbstractCurry type declaration in standard Curry syntax. -showTypeDecl :: PrintOptions -> TypeDecl -> String -showTypeDecl opts t = - decl ++ showIdentifier (snd (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 :: PrintOptions -> ConsDecl -> String -showConsDecl opts c - = separate (if strictArgs c then " !" else " ") - (showIdentifier (snd (consName c)) : - map (showTypeExpr opts True) (consArgs c)) - -showInsDecls :: PrintOptions -> [InstanceDecl] -> String -showInsDecls opts is = brace "" "\n\n" "\n\n" (map (showInsDecl opts) is) - -showInsDecl :: PrintOptions -> 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 opts tcs = brace "(" ") => " "," (map (showTypeClass opts) tcs) - -showTypeClass opts (TypeClass qn ts) - = snd 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 :: PrintOptions -> 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 (mod,name) typelist) = - (if nested && not (null typelist) then brace "(" ")" else separate) "" - [showTypeCons opts mod name typelist] -showTypeExpr opts nested (TConstr tcs t) = - (if nested then brace "(" ")" else separate) "" - [showTypeConstr opts tcs ++ showTypeExpr opts False t] - -showTypeCons :: PrintOptions -> String -> String -> [TypeExpr] -> String -showTypeCons opts mod name ts = - showSymbol opts (mod,name) ++ - brace " " "" " " (map (showTypeExpr opts True) ts) - - - ------------------------------------------- --- function declarations ------------------------------------------- - ---- Shows an AbstractCurry function declaration in standard Curry syntax. -showFuncDecl = showFuncDeclOpt defaultPrintOptions - -showFuncDeclOpt :: PrintOptions -> 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 (snd (funcName f)) - -showRule :: PrintOptions -> 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 :: PrintOptions -> Rhs -> String -showRhs opts (SimpleExpr e) = " = "++showExprOpt opts e -showRhs opts (GuardedExpr gs) = brace "\n " "" "\n " (map (showGuard opts) gs) - -showGuard :: PrintOptions -> (Expr,Expr) -> String -showGuard opts (g,r) = " | " ++ showExprOpt opts g ++ " = " ++ showExprOpt opts r - -showLocalDecl :: PrintOptions -> 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 [] = [] - 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 = showExprOpt defaultPrintOptions - -showExprOpt :: PrintOptions -> Expr -> String -showExprOpt _ (Var name) = showIdentifier name -showExprOpt _ (Lit lit) = showLiteral lit -showExprOpt opts (Symbol name) = showSymbol opts name -showExprOpt opts exp@(Apply func arg) - | Just cs <- expAsCurryString exp = fromCurryString cs - | Just cl <- expAsCurryList exp = fromCurryList cl - | Just hs <- expAsHaskellString exp = fromHaskellString hs - | Just hl <- expAsHaskellList exp = 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 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 :: PrintOptions -> QName -> String -showSymbol _ ("",symName) = showIdentifier symName -showSymbol opts (m,symName) - | isInfixOpName symName = brace "(" ")" "" [m++"."++symName] - | not (unqual opts) || isExternalModule = m++"."++showIdentifier symName - | otherwise = showIdentifier symName - where - isExternalModule - = case m of {('E':'x':'t':'e':'r':'n':'a':'l':_) -> True;_->False} - -showLambda opts patts expr = - brace "\\ " " -> " " " (map (showPatternOpt opts) patts) ++ - showExprOpt opts expr - - -showStatement :: PrintOptions -> 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 ("CurryPrelude","List")) = Just "" -expAsCurryString (Apply (Apply (Symbol ("CurryPrelude",":<")) - (Apply (Symbol ("CurryPrelude","C_Char")) - (Lit (Charc c)))) - cs) - = Just (c:) `ap` expAsCurryString cs -expAsCurryString _ = Nothing - --- try to transform expression into a Curry list -expAsCurryList :: Expr -> Maybe [Expr] -expAsCurryList (Symbol ("CurryPrelude","List")) = Just [] -expAsCurryList (Apply (Apply (Symbol ("CurryPrelude",":<")) x) xs) - = Just (x:) `ap` expAsCurryList xs -expAsCurryList _ = Nothing - --- try to transform expression into a non-empty Haskell string -expAsHaskellString :: Expr -> Maybe String -expAsHaskellString (Symbol ("","[]")) = Just "" -expAsHaskellString (Apply (Apply (Symbol ("",":")) (Lit (Charc c))) cs) - = Just (c:) `ap` expAsHaskellString cs -expAsHaskellString _ = Nothing - --- try to transform expression into a Haskell list -expAsHaskellList :: Expr -> Maybe [Expr] -expAsHaskellList (Symbol ("","[]")) = Just [] -expAsHaskellList (Apply (Apply (Symbol ("",":")) x) xs) - = Just (x:) `ap` expAsHaskellList xs -expAsHaskellList _ = Nothing - -------------------------------------------------------- --- patterns -------------------------------------------------------- - -showPattern :: Pattern -> String -showPattern = showPatternOpt defaultPrintOptions - -showPatternOpt :: PrintOptions -> 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 :: PrintOptions -> 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) - -isCFuncType t = case t of - FuncType _ _ -> True - _ -> False - -isTuple [] = False -isTuple (c:cs) = c=='(' && dropWhile (==',') cs == ")" - ------------------------------------------------------------------------------- ---- constants used by AbstractCurryPrinter ------------------------------------------------------------------------------- - -infixIDs :: String -infixIDs = "~!@#$%^&*+-=<>?./|\\:" - - - - - - diff --git a/src/Simplification.hs b/src/Simplification.hs deleted file mode 100644 --- a/src/Simplification.hs +++ /dev/null @@ -1,526 +0,0 @@ -module Simplification (simplifyProg) where - - -import Prelude hiding ( or,fail,catch ) - -import MetaProgramming.FlatCurry -import MetaProgramming.FlatCurryGoodies hiding ( freeVars ) -import qualified MetaProgramming.FlatCurryGoodies as FCG - -import List ( sortBy, groupBy, partition ) - - -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 = 1 + maxlist (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) && - (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 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 cmpQName (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 && combName exp == (preludeName,failedName) - -replaceBranches :: Expr -> [BranchExpr] -> Expr -replaceBranches (Case ct e _) bs - | null bs = failed_ - | otherwise = Case 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 ct e bs -> let (ps,es) = unzip (map branch bs) - in (e:es, \ (e:es) -> Case 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 - -cmpQName :: Ord' QName -cmpQName = cmpPair cmpString cmpString - -cmpPair :: Ord' a -> Ord' b -> Ord' (a,b) -cmpPair cmpa cmpb (a1,b1) (a2,b2) = - case cmpa a1 a2 of - EQ -> cmpb b1 b2 - cmp -> cmp - - --- 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 (preludeName,failedName) [] - -zero_ = Comb ConsCall (preludeName, "Zero") [] -pos_ n = Comb ConsCall (preludeName, "Pos") [n] -neg_ n = Comb ConsCall (preludeName, "Neg") [n] - -iHi_ = Comb ConsCall (preludeName, "IHi") [] -o_ n = Comb ConsCall (preludeName, "O") [n] -i_ n = Comb ConsCall (preludeName, "I") [n] - -x ?~ y = Comb FuncCall (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 ct e bs = exp - in Case 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 ("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 - -maxlist :: [Int] -> Int -maxlist [n] = n -maxlist (n:m:ns) = max n (maxlist (m:ns)) - - ---- A datatype is Traversable 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 Nothing. ---- 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 :: Int -> 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' = take arity [n ..] - in Just (Rule args' (replace (zip args (map Var args')) body) - ,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 - diff --git a/src/kics.hs b/src/kics.hs --- a/src/kics.hs +++ b/src/kics.hs @@ -1,7 +1,9 @@ -import Config -import CurryToHaskell -import SafeCalls import System + +import Curry.Compiler.Config +import Curry.Compiler.CurryToHaskell +import Curry.Compiler.SafeCalls + ------------------------------- -- the kics compiler diff --git a/src/kicsi.hs b/src/kicsi.hs deleted file mode 100644 --- a/src/kicsi.hs +++ /dev/null @@ -1,382 +0,0 @@ -module Main where - -import Maybe -import Data.List -import Data.Char -import System hiding (getEnv) -import System.IO -import System.Directory (doesFileExist) -import Control.Monad (unless,when) -import System.FilePath - - -import CurryToHaskell -import SafeCalls -import MetaProgramming.FlatCurry -import MetaProgramming.FlatCurryGoodies -import ShowFlatCurry -import Config -import Names -import MyReadline - -allFiles = map snd . files -loadedFiles = map snd . filter fst . files - -separate s = concat . intersperse s . filter (not . null) - -svnrev = filter isDigit "$Rev: 1893 $" - -welcome = - [" _ _ _ _" - ," /\\_\\ /\\ \\ /\\ \\ / /\\" - ," / / / _ \\ \\ \\ / \\ \\ / / \\" - ," / / / /\\_\\ /\\ \\_\\ / /\\ \\ \\ / / /\\ \\__" - ," / / /__/ / / / /\\/_/ / / /\\ \\ \\ / / /\\ \\___\\" - ," / /\\_____/ / / / / / / / \\ \\_\\ \\ \\ \\ \\/___/" - ," / /\\_______/ / / / / / / \\/_/ \\ \\ \\" - ," / / /\\ \\ \\ / / / / / / _ \\ \\ \\ The" - ," / / / \\ \\ \\ ___/ / /__ / / /________ /_/\\__/ / / Kiel" - ,"/ / / \\ \\ \\ /\\__\\/_/___\\/ / /_________\\\\ \\/___/ / Curry" - ,"\\/_/ \\_\\_\\\\/_________/\\/____________/ \\_____\\/ System" - ,"","Version 0.8"++svnrev,""] - - -compileCall CTC = "kics -make " -compileCall OrBased = "kics -or -make " - -compileModule file choiceMode = system (compileCall choiceMode++file) - -------------------------------------- --- read history from file -------------------------------------- - -historyFile = "kicsi.hist" - -readHistory :: IO () -readHistory = do - exHist <- doesFileExist historyFile - unless (not exHist) - (readFile historyFile >>= addLineToHistory 1 . lines) - where - addLineToHistory _ [] = return () - addLineToHistory n (s@(':':_):xs) = addHistory s >> addLineToHistory n xs - addLineToHistory n (s:xs) = - addHistory ("{-"++show n++"-} "++s) >> - addLineToHistory (n+1) xs - -main = do - readHistory - home <- getEnv "HOME" - (options,state) <- getOptions - mapM_ (safe . put 1 options) welcome - unless (verbosity options==0) initializeReadline - let files = case filename options of - "" -> ["Prelude"] - fn -> [fn] - curDir:dirs = libpath options - load files state options{userlibpath=pathWithSubdirs [curDir]++dirs} - -interactive state opts = do - mline <- readline (separate "," (loadedFiles state) ++"> ") - case mline of - Just line -> addHistory line >> - interactiveMenue (words line) state opts - Nothing -> return () - -interactiveMenue [] state opts = interactive state opts -interactiveMenue (cmd:cmds) state opts = - case map toLower cmd of - ":load" -> load cmds state opts - ":l" -> load cmds state opts - ":add" -> load (allFiles state++cmds) state opts - ":a" -> load (allFiles state++cmds) state opts - ":set" -> setMenue cmds state opts - ":reload" -> load (allFiles state) state opts - ":r" -> load (allFiles state) state opts - ":type" -> getType (unwords cmds) state opts - ":t" -> getType (unwords cmds) state opts - ":quit" -> return () - ":q" -> return () - ":help" -> help state opts - ":h" -> help state opts - ":?" -> help state opts - ":info" -> info cmds (loadedFiles state) state opts - ":i" -> info cmds (loadedFiles state) state opts - ":save" -> writeConfig opts state >> interactive state opts - ":s" -> writeConfig opts state >> interactive state opts - ':':'!':c -> safe (safeSystem False (unwords (c:cmds))) >> interactive state opts - ':':_ -> putStrLn "unknown command, type :? for help" >> - interactive state opts - _ -> requestExpr state opts (unwords (cmd:cmds)) - -setMenue [] state opts = do - putStrLn "options" - putStrLn "-------" - putStrLn $ "search mode: " ++ (show (pm opts)) - putStrLn $ "timing: " ++ onOff (time state) - putStrLn $ "debug: " ++ onOff (debug opts) - ++ maybe "" (" -- "++) (debugger opts) - putStrLn $ "evaluation mode: " ++ evalMode (eval opts) - putStrLn $ "verbosity level: " ++ show (verbosity opts) - putStrLn $ "recompilation: " ++ if force opts then "always (+f)" - else "only if older (-f)" - putStrLn "\npaths and commands" - putStrLn "------------------" - putStrLn $ "command line options: " ++ cmdLineArgs state - putStrLn $ "run time settings: " ++ rts state - putStrLn $ "ghc compiler options: " ++ ghcOpts opts - putStrLn "paths to libraries: " - let dir:_:_:dirs = libpath opts - mapM_ putPath (dir:dirs) - interactive state opts - where - putPath p = putStr " " >> putStrLn p - -setMenue (opt:vals) state opts = do - case map (map toLower) (opt:vals) of - ["or"] -> load (allFiles state) state opts{cm=OrBased} - ["ctc"] -> load (allFiles state) state opts{cm=CTC} - ["depth","first"] -> interactive state (newSm opts DF) - ["df"] -> interactive state (newSm opts DF) - ["breadth","first"] -> interactive state (newSm opts BF) - ["bf"] -> interactive state (newSm opts BF) - ["all","solutions"] -> interactive state (newPm opts (All DF)) - ["all"] -> interactive state (newPm opts (All DF)) - ["first","solution"] -> interactive state (newPm opts (First DF)) - ["first"] -> interactive state (newPm opts (First DF)) - ["interactive"] -> interactive state (newPm opts (Interactive DF)) - ["i"] -> interactive state (newPm opts (Interactive DF)) - ["search","tree"] -> interactive state opts{pm=ST} - ["st"] -> interactive state opts{pm=ST} - ["path",path] -> let (thisDir:oldPath)=userlibpath opts - in interactive state opts{userlibpath=thisDir:path:oldPath} - ["verbosity",i] | all isDigit i -> interactive state opts{verbosity=read i} - ["v",i] | all isDigit i -> interactive state opts{verbosity=read i} - ("command":_) -> interactive state{cmdLineArgs=unwords vals} opts - ("cmd":_) -> interactive state{cmdLineArgs=unwords vals} opts - ("rts":_) -> interactive state{rts=' ':unwords vals++" "} opts - ("rts+":_)-> interactive state{rts=rts state++' ':unwords vals++" "} opts - ("ghc":_) -> interactive state opts{ghcOpts=' ':unwords vals++" "} - ("ghc+":_) -> interactive state - opts{ghcOpts=ghcOpts opts++' ':unwords vals++" "} - ["debugger",debugTool] -> interactive state - opts{debugger=Just (head vals)} - ['+':'+':setting] -> longSetting True state opts setting - ['-':'-':setting] -> longSetting False state opts setting - (('+':s):sets) -> shortSettings True state opts (concat (s:sets)) - (('-':s):sets) -> shortSettings False state opts (concat (s:sets)) - _ -> putStrLn ("invalid setting. Example \":set breadth first\" to " ++ - "set search strategy to breadth first") >> - interactive state opts - -longSetting flag state opts "debug" = - interactive state opts{debug=flag,doNotUseInterface=flag} -longSetting flag state opts "time" = do - warn state{time=flag} opts - interactive state{time=flag} opts -longSetting flag state opts "eval" = do - warn state opts{eval=flag} - interactive state opts{eval=flag} -longSetting flag state opts "make" = interactive state opts{make=flag} -longSetting flag state opts "force" = interactive state opts{force=flag} -longSetting _ state opts _ = putStrLn "invalid setting." >> interactive state opts - -shortSettings _ state opts [] = do - warn state opts - interactive state opts -shortSettings flag state opts ('t':settings) = do - putStrLn $ "setting time " ++ onOff flag - shortSettings flag state{time=flag} opts settings -shortSettings flag state opts ('-':settings) = - shortSettings False state opts settings -shortSettings flag state opts ('+':settings) = - shortSettings True state opts settings -shortSettings flag state opts (c:settings) = do - o <- newOpts c - shortSettings flag state o settings - where - newOpts 'd' = putStrLn ("setting debbug " ++ onOff flag) >> - return opts{debug=flag,doNotUseInterface=flag} - newOpts 'e' = putStrLn ("setting evaluation mode to " ++ evalMode flag) >> - return opts{eval=flag} - newOpts 'm' = putStrLn ("setting make " ++ onOff flag) >> - return opts{make=flag} - newOpts 'f' = putStrLn ("setting recompilation to " ++ forceMode flag) >> - return opts{force=flag} - newOpts c = putStrLn ("unknown short option: "++show c) >> - putStrLn (" (long options are set with \"++\" and \"--\", e.g.,\ - \ \":set ++time\"") >> - return opts - -onOff True = "on" -onOff False = "off" -evalMode True = "interpreted (+e)" -evalMode False = "compiled (-e)" -forceMode True = "always (+f)" -forceMode False = "only if older (-f)" - -warn state opts = - when (time state && eval opts) - (putStrLn "warning: for benchmarking you should use +t together with -e") - - -help state opts = do - mapM_ putStrLn - [":load load a (number of) file(s)" - ,":set