KiCS 0.8.5 → 0.8.6
raw patch · 31 files changed
+4240/−4175 lines, 31 filesdep +sybdep −readlinedep ~basesetup-changed
Dependencies added: syb
Dependencies removed: readline
Dependency ranges changed: base
Files
- KiCS.cabal +29/−45
- Setup.hs +1/−14
- src/Brace.hs +0/−10
- src/Config.hs +0/−437
- src/Curry/Compiler/Brace.hs +10/−0
- src/Curry/Compiler/Config.hs +456/−0
- src/Curry/Compiler/CurryToHaskell.hs +1232/−0
- src/Curry/Compiler/FunctionalProg.hs +248/−0
- src/Curry/Compiler/KicsSubdir.hs +133/−0
- src/Curry/Compiler/Names.hs +76/−0
- src/Curry/Compiler/PreTrans.hs +284/−0
- src/Curry/Compiler/SafeCalls.hs +56/−0
- src/Curry/Compiler/ShowFlatCurry.hs +329/−0
- src/Curry/Compiler/ShowFunctionalProg.hs +386/−0
- src/Curry/Compiler/Simplification.hs +526/−0
- src/Curry/RunTimeSystem.hs +139/−0
- src/Curry/RunTimeSystem/BaseCurry.hs +103/−0
- src/Curry/RunTimeSystem/Store.hs +227/−0
- src/CurryToHaskell.hs +0/−1241
- src/FunctionalProg.hs +0/−248
- src/InstallDir.hs +0/−3
- src/KicsSubdir.hs +0/−133
- src/MyReadline.hs +0/−6
- src/Names.hs +0/−74
- src/PreTrans.hs +0/−284
- src/SafeCalls.hs +0/−56
- src/ShowFlatCurry.hs +0/−328
- src/ShowFunctionalProg.hs +0/−385
- src/Simplification.hs +0/−526
- src/kics.hs +5/−3
- src/kicsi.hs +0/−382
KiCS.cabal view
@@ -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+++
Setup.hs view
@@ -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
− src/Brace.hs
@@ -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
− src/Config.hs
@@ -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 <n> | set verbosity level to n, e.g., -v 3"- putStrLn "-q | scarce output"- putStrLn "-force | force recompilation"- putStrLn "-noforce | do not force recompilation"- putStrLn "-all df | print all solutions depth first"- putStrLn "-all bf | print all solutions breadth first"- putStrLn "-st | print solutions as search tree"- putStrLn "-i df | interactively show solutions depth first"- putStrLn "-i bf | interactively show solutions breadth first"- putStrLn "-o | name of output file"- putStrLn "-d | turn on debug mode"- putStrLn "--debugger <n> | use debug tool <n>"- error "compilation aborted"---data Options = Opts{ cm :: ChoiceMode,- filename, mainFunc, mainModule, target,- frontend, ghc, ghcOpts,- kicspath :: String,- userlibpath, done :: [String],- verbosity :: Int,- make, executable, eval, - force, debug, doNotUseInterface :: Bool, - debugger :: Maybe String,- consUse :: ConsUse,- extCons,hasData :: Bool,- pm :: PresentationMode,- extData, extFuncs :: [String],- extInsts :: [(String,[ProvidedInstance])],- 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 <typename> [definition|nodef] instances <instname>*--- extfunc <funcname>--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
+ src/Curry/Compiler/Brace.hs view
@@ -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
+ src/Curry/Compiler/Config.hs view
@@ -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 <n> | set verbosity level to n, e.g., -v 3"+ putStrLn "-q | scarce output"+ putStrLn "-force | force recompilation"+ putStrLn "-noforce | do not force recompilation"+ putStrLn "-all df | print all solutions depth first"+ putStrLn "-all bf | print all solutions breadth first"+ putStrLn "-st | print solutions as search tree"+ putStrLn "-i df | interactively show solutions depth first"+ putStrLn "-i bf | interactively show solutions breadth first"+ putStrLn "-o | name of output file"+ putStrLn "-d | turn on debug mode"+ putStrLn "--debugger <n> | use debug tool <n>"+ error "compilation aborted"+++data Options = Opts{ cm :: ChoiceMode,+ filename, mainFunc, mainModule, target,+ frontend, 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 <typename> [definition|nodef] instances <instname>*+-- extfunc <funcname>++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
+ src/Curry/Compiler/CurryToHaskell.hs view
@@ -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"+
+ src/Curry/Compiler/FunctionalProg.hs view
@@ -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+--- <CODE>+--- (CProg modname imports typedecls functions opdecls)+--- </CODE>+--- where modname: name of this module,+--- imports: list of modules names that are imported,+--- typedecls, opdecls, functions: see below++data Prog = Prog { progName :: String,+ imports,exports ::[String],+ typeDecls :: [TypeDecl],+ instanceDecls :: [InstanceDecl],+ funcDecls :: [FuncDecl],+ opDecls :: [OpDecl] } deriving (Show,Eq,Read)++emptyProg = Prog "" [] [] [] [] [] []+++--- The data type for representing qualified names.+--- In AbstractCurry all names are qualified to avoid name clashes.+--- The first component is the module name and the second component the+--- unqualified name as it occurs in the source program.+type QName = (String,String)+++-- Data type to specify the visibility of various entities.++data Visibility = Public -- exported entity+ | Private -- private entity+ deriving (Show,Eq,Read)+++--- The data type for representing type variables.+--- They are represented by (i,n) where i is a type variable index+--- which is unique inside a function and n is a name (if possible,+--- the name written in the source program).+type VarName = String++--- Data type for representing definitions of algebraic data types+--- and type synonyms.+--- <PRE>+--- A data type definition of the form+---+--- data t x1...xn = ...| c t1....tkc |...+---+--- is represented by the Curry term+---+--- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])+---+--- where each ij is the index of the type variable xj+---+--- Note: the type variable indices are unique inside each type declaration+--- and are usually numbered from 0+---+--- Thus, a data type declaration consists of the name of the data type,+--- a list of type parameters and a list of constructor declarations.+--- </PRE>++data TypeDecl = Type { + typeName :: QName,+ typeVis :: Visibility,+ typeVars :: [VarName],+ consDecls :: [ConsDecl],+ derive :: [String]}+ | TypeSyn + { typeName :: QName,+ typeVis :: Visibility,+ typeVars :: [VarName],+ typeExpr :: TypeExpr}+ deriving (Show,Eq,Read)++--- For a type declaration the membership to certain classes can be derived in +--- Haskell.++data TypeClass = TypeClass { className :: QName, + classArgs :: [TypeExpr]} deriving (Show,Eq,Read)++data InstanceDecl = Instance {+ constraint :: [TypeClass],+ instanciated :: TypeClass,+ instanceFunc :: [FuncDecl]} deriving (Show,Eq,Read)++--- A constructor declaration consists of the name and arity of the+--- constructor and a list of the argument types of the constructor.++data ConsDecl = Cons { consName :: QName,+ consArity :: Int, + consVis :: Visibility,+ strictArgs :: Bool,+ consArgs :: [TypeExpr]} deriving (Show,Eq,Read)+++--- Data type for type expressions.+--- A type expression is either a type variable, a function type,+--- or a type constructor application.+---+--- Note: the names of the predefined type constructors are+--- "Int", "Float", "Bool", "Char", "IO", "Success",+--- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)++data TypeExpr =+ TVar VarName -- type variable+ | FuncType TypeExpr TypeExpr -- function type t1->t2+ | TCons QName [TypeExpr] -- type constructor application+ -- (CTCons (module,name) arguments)+ | TConstr [TypeClass] TypeExpr+ deriving (Show,Eq,Read)+++--- Data type for operator declarations.+--- An operator declaration "fix p n" in Curry corresponds to the+--- AbstractCurry term (COp n fix p).++data OpDecl = Op QName Fixity 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.+--- <PRE>+--- A function declaration in FlatCurry is a term of the form+---+--- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))+---+--- and represents the function "name" with definition+---+--- name :: type+--- rule1+--- ...+--- rulek+---+--- Note: the variable indices are unique inside each rule+---+--- External functions are represented as (CFunc name arity type (CExternal s))+--- where s is the external name associated to this function.+---+--- Thus, a function declaration consists of the name, arity, type, and+--- a list of rules.+--- </PRE>++data FuncDecl = Func { funcName :: QName,+ funcVis :: Visibility,+ funcType :: Maybe TypeExpr,+ funcBody :: Maybe [Rule]} deriving (Show,Eq,Read)+++--- A rule is either a list of formal parameters together with an expression+--- (i.e., a rule in flat form), a list of general program rules with+--- an evaluation annotation, or it is externally defined++--- The most general form of a rule. It consists of a list of patterns+--- (left-hand side), a list of guards ("success" if not present in the+--- source text) with their corresponding right-hand sides, and+--- a list of local declarations.+data Rule = Rule { patterns :: [Pattern],+ rhs :: Rhs,+ locDecls :: [LocalDecl]}+ deriving (Show,Eq,Read)++data Rhs = SimpleExpr Expr | GuardedExpr [(Expr,Expr)] deriving (Show,Eq,Read)+++--- Data type for representing local (let/where) declarations+data LocalDecl =+ LocalFunc FuncDecl -- local function declaration+ | LocalPat Pattern Expr [LocalDecl] -- local pattern declaration+ deriving (Show,Eq,Read)++--- Data type for representing Curry expressions.++data Expr =+ Var VarName -- variable (unique index / name)+ | Lit Literal -- literal (Integer/Float/Char constant)+ | Symbol QName -- a defined symbol with module and name+ | Apply Expr Expr -- application (e1 e2)+ | Lambda [Pattern] Expr -- lambda abstraction+ | LetDecl [LocalDecl] Expr -- local let declarations+ | DoExpr [Statement] -- do expression+ | ListComp Expr [Statement] -- list comprehension+ | Case Expr [BranchExpr] -- case expression+ | String String + deriving (Show,Eq,Read)++--- Data type for representing statements in do expressions and+--- list comprehensions.++data Statement = SExpr Expr -- an expression (I/O action or boolean)+ | SPat Pattern Expr -- a pattern definition+ | SLet [LocalDecl] -- a local let declaration+ deriving (Show,Eq,Read)++--- Data type for representing pattern expressions.++data Pattern =+ PVar VarName -- pattern variable (unique index / name)+ | PLit Literal -- literal (Integer/Float/Char constant)+ | PComb QName [Pattern] -- application (m.c e1 ... en) of n-ary+ -- constructor m.c (CPComb (m,c) [e1,...,en])+ | AsPat VarName Pattern+ deriving (Show,Eq,Read)++--- Data type for representing branches in case expressions.++data BranchExpr = Branch Pattern Expr+ deriving (Show,Eq,Read)++--- Data type for representing literals occurring in an expression.+--- It is either an integer, a float, or a character constant.++data Literal = Intc Integer+ | HasIntc Integer+ | Floatc Double+ | Charc Char+ deriving (Show,Eq,Read)+
+ src/Curry/Compiler/KicsSubdir.hs view
@@ -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 []
+ src/Curry/Compiler/Names.hs view
@@ -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"++
+ src/Curry/Compiler/PreTrans.hs view
@@ -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]+
+ src/Curry/Compiler/SafeCalls.hs view
@@ -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
+ src/Curry/Compiler/ShowFlatCurry.hs view
@@ -0,0 +1,329 @@+------------------------------------------------------------------------------+--- Some tools to support meta-programming in Curry based on FlatCurry.+---+--- This library contains+--- <UL>+--- <LI> a show function for a string representation of FlatCurry programs+--- (function "showFlatProg")+---+--- <LI> a function for showing FlatCurry expressions in (almost) Curry syntax+--- (function "showCurryExpr")+--- </UL>+---+--- Note that the previously contained function "writeFLC"+--- is no longer supported. Use Flat2Fcy.writeFCY instead+--- and change file suffix into ".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+++------------------------------------------------------------------------------+
+ src/Curry/Compiler/ShowFunctionalProg.hs view
@@ -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 <var0> as var0, like in Prelude)+-- - prettyprint list patterns+-- in July 2005:+-- - added options to most functions+-- - print qualified symbol when necessary (local functions missing)+-- in May 2007:+-- - prettier representation of Curry and Haskell Strings+------------------------------------------------------------------------------+module 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 = "~!@#$%^&*+-=<>?./|\\:"++++++
+ src/Curry/Compiler/Simplification.hs view
@@ -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 <code>Traversable</code> if it defines a function+--- that can decompose a value into a list of children of the same type+--- and recombine new children to a new value of the original type. +---+type Traversable a b = a -> ([b], [b] -> a)++--- Traversal function for constructors without children.+---+noChildren :: Traversable a b+noChildren x = ([], const x)++--- Yields the children of a value.+---+children :: Traversable a b -> a -> [b]+children tr = fst . tr++--- Replaces the children of a value.+--- +replaceChildren :: Traversable a b -> a -> [b] -> a+replaceChildren tr = snd . tr++--- Applies the given function to each child of a value.+---+mapChildren :: Traversable a b -> (b -> b) -> a -> a+mapChildren tr f x = replaceChildren tr x (map f (children tr x))++--- Computes a list of the given value, its children, those children, etc.+---+family :: Traversable a a -> a -> [a]+family tr x = familyFL tr x []++--- Computes a list of family members of the children of a value.+--- The value and its children can have different types.+---+childFamilies :: Traversable a b -> Traversable b b -> a -> [b]+childFamilies tra trb x = childFamiliesFL tra trb x [] ++-- implementation of 'family' with functional lists for efficiency reasons++type FunList a = [a] -> [a]++familyFL :: Traversable a a -> a -> FunList a+familyFL tr x xs = x : childFamiliesFL tr tr x xs++childFamiliesFL :: Traversable a b -> Traversable b b -> a -> FunList b+childFamiliesFL tra trb x xs = concatFL (map (familyFL trb) (children tra x)) xs++--- Concatenates a list of functional lists.+---+concatFL :: [FunList a] -> FunList a+concatFL [] ys = ys+concatFL (x:xs) ys = x (concatFL xs ys)++--- Applies the given function to each member of the family of a value.+--- Proceeds bottom-up.+---+mapFamily :: Traversable a a -> (a -> a) -> a -> a+mapFamily tr f = f . mapChildFamilies tr tr f++--- Applies the given function to each member of the families of the children+--- of a value. The value and its children can have different types.+--- Proceeds bottom-up.+---+mapChildFamilies :: Traversable a b -> Traversable b b -> (b -> b) -> a -> a+mapChildFamilies tra trb = mapChildren tra . mapFamily trb++--- Applies the given function to each member of the family of a value +--- as long as possible. On each member of the family of the result the given+--- function will yield <code>Nothing</code>.+--- Proceeds bottom-up.+---+evalFamily :: Traversable a a -> (a -> Maybe a) -> a -> a+evalFamily tr f = mapFamily tr g+ where g x = maybe x (mapFamily tr g) (f x)++--- Applies the given function to each member of the families of the children+--- of a value as long as possible.+--- Similar to 'evalFamily'.+---+evalChildFamilies :: Traversable a b -> Traversable b b+ -> (b -> Maybe b) -> a -> a+evalChildFamilies tra trb = mapChildren tra . evalFamily trb++--- Implements a traversal similar to a fold with possible default cases.+---+fold :: Traversable a a -> (a -> [r] -> r) -> a -> r+fold tr f = foldChildren tr tr f f++--- Fold the children and combine the results.+---+foldChildren :: Traversable a b -> Traversable b b+ -> (a -> [rb] -> ra) -> (b -> [rb] -> rb) -> a -> ra+foldChildren tra trb f g a = f a (map (fold trb g) (children tra a))++infixl 1 .>>=, .>>+++type Rules = [(QName,Rule)]+type Simp a = VarIndex -> Rules -> Maybe (a,VarIndex)++runSimp :: 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+
+ src/Curry/RunTimeSystem.hs view
@@ -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]+++
+ src/Curry/RunTimeSystem/BaseCurry.hs view
@@ -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 ++
+ src/Curry/RunTimeSystem/Store.hs view
@@ -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
− src/CurryToHaskell.hs
@@ -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"-
− src/FunctionalProg.hs
@@ -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---- <CODE>---- (CProg modname imports typedecls functions opdecls)---- </CODE>---- where modname: name of this module,---- imports: list of modules names that are imported,---- typedecls, opdecls, functions: see below--data Prog = Prog { progName :: String,- imports,exports ::[String],- typeDecls :: [TypeDecl],- instanceDecls :: [InstanceDecl],- funcDecls :: [FuncDecl],- opDecls :: [OpDecl] } deriving (Show,Eq,Read)--emptyProg = Prog "" [] [] [] [] [] []------ The data type for representing qualified names.---- In AbstractCurry all names are qualified to avoid name clashes.---- The first component is the module name and the second component the---- unqualified name as it occurs in the source program.-type QName = (String,String)----- Data type to specify the visibility of various entities.--data Visibility = Public -- exported entity- | Private -- private entity- deriving (Show,Eq,Read)------ The data type for representing type variables.---- They are represented by (i,n) where i is a type variable index---- which is unique inside a function and n is a name (if possible,---- the name written in the source program).-type VarName = String----- Data type for representing definitions of algebraic data types---- and type synonyms.---- <PRE>---- A data type definition of the form-------- data t x1...xn = ...| c t1....tkc |...-------- is represented by the Curry term-------- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])-------- where each ij is the index of the type variable xj-------- Note: the type variable indices are unique inside each type declaration---- and are usually numbered from 0-------- Thus, a data type declaration consists of the name of the data type,---- a list of type parameters and a list of constructor declarations.---- </PRE>--data TypeDecl = Type { - typeName :: QName,- typeVis :: Visibility,- typeVars :: [VarName],- consDecls :: [ConsDecl],- derive :: [String]}- | TypeSyn - { typeName :: QName,- typeVis :: Visibility,- typeVars :: [VarName],- typeExpr :: TypeExpr}- deriving (Show,Eq,Read)----- For a type declaration the membership to certain classes can be derived in ---- Haskell.--data TypeClass = TypeClass { className :: QName, - classArgs :: [TypeExpr]} deriving (Show,Eq,Read)--data InstanceDecl = Instance {- constraint :: [TypeClass],- instanciated :: TypeClass,- instanceFunc :: [FuncDecl]} deriving (Show,Eq,Read)----- A constructor declaration consists of the name and arity of the---- constructor and a list of the argument types of the constructor.--data ConsDecl = Cons { consName :: QName,- consArity :: Int, - consVis :: Visibility,- strictArgs :: Bool,- consArgs :: [TypeExpr]} deriving (Show,Eq,Read)------ Data type for type expressions.---- A type expression is either a type variable, a function type,---- or a type constructor application.-------- Note: the names of the predefined type constructors are---- "Int", "Float", "Bool", "Char", "IO", "Success",---- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)--data TypeExpr =- TVar VarName -- type variable- | FuncType TypeExpr TypeExpr -- function type t1->t2- | TCons QName [TypeExpr] -- type constructor application- -- (CTCons (module,name) arguments)- | TConstr [TypeClass] TypeExpr- deriving (Show,Eq,Read)------ Data type for operator declarations.---- An operator declaration "fix p n" in Curry corresponds to the---- AbstractCurry term (COp n fix p).--data OpDecl = Op QName Fixity 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.---- <PRE>---- A function declaration in FlatCurry is a term of the form-------- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))-------- and represents the function "name" with definition-------- name :: type---- rule1---- ...---- rulek-------- Note: the variable indices are unique inside each rule-------- External functions are represented as (CFunc name arity type (CExternal s))---- where s is the external name associated to this function.-------- Thus, a function declaration consists of the name, arity, type, and---- a list of rules.---- </PRE>--data FuncDecl = Func { funcName :: QName,- funcVis :: Visibility,- funcType :: Maybe TypeExpr,- funcBody :: Maybe [Rule]} deriving (Show,Eq,Read)------ A rule is either a list of formal parameters together with an expression---- (i.e., a rule in flat form), a list of general program rules with---- an evaluation annotation, or it is externally defined----- The most general form of a rule. It consists of a list of patterns---- (left-hand side), a list of guards ("success" if not present in the---- source text) with their corresponding right-hand sides, and---- a list of local declarations.-data Rule = Rule { patterns :: [Pattern],- rhs :: Rhs,- locDecls :: [LocalDecl]}- deriving (Show,Eq,Read)--data Rhs = SimpleExpr Expr | GuardedExpr [(Expr,Expr)] deriving (Show,Eq,Read)------ Data type for representing local (let/where) declarations-data LocalDecl =- LocalFunc FuncDecl -- local function declaration- | LocalPat Pattern Expr [LocalDecl] -- local pattern declaration- deriving (Show,Eq,Read)----- Data type for representing Curry expressions.--data Expr =- Var VarName -- variable (unique index / name)- | Lit Literal -- literal (Integer/Float/Char constant)- | Symbol QName -- a defined symbol with module and name- | Apply Expr Expr -- application (e1 e2)- | Lambda [Pattern] Expr -- lambda abstraction- | LetDecl [LocalDecl] Expr -- local let declarations- | DoExpr [Statement] -- do expression- | ListComp Expr [Statement] -- list comprehension- | Case Expr [BranchExpr] -- case expression- | String String - deriving (Show,Eq,Read)----- Data type for representing statements in do expressions and---- list comprehensions.--data Statement = SExpr Expr -- an expression (I/O action or boolean)- | SPat Pattern Expr -- a pattern definition- | SLet [LocalDecl] -- a local let declaration- deriving (Show,Eq,Read)----- Data type for representing pattern expressions.--data Pattern =- PVar VarName -- pattern variable (unique index / name)- | PLit Literal -- literal (Integer/Float/Char constant)- | PComb QName [Pattern] -- application (m.c e1 ... en) of n-ary- -- constructor m.c (CPComb (m,c) [e1,...,en])- | AsPat VarName Pattern- deriving (Show,Eq,Read)----- Data type for representing branches in case expressions.--data BranchExpr = Branch Pattern Expr- deriving (Show,Eq,Read)----- Data type for representing literals occurring in an expression.---- It is either an integer, a float, or a character constant.--data Literal = Intc Integer- | HasIntc Integer- | Floatc Double- | Charc Char- deriving (Show,Eq,Read)-
− src/InstallDir.hs
@@ -1,3 +0,0 @@-module InstallDir where-installDir = "/home/bbr/kics"-ghc_call= "/home/ghc/bin/ghc"
− src/KicsSubdir.hs
@@ -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 []
− src/MyReadline.hs
@@ -1,6 +0,0 @@-module MyReadline (readline, addHistory,initializeReadline) where--import System.Console.Readline--initializeReadline :: IO ()-initializeReadline = return ()
− src/Names.hs
@@ -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"--
− src/PreTrans.hs
@@ -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]-
− src/SafeCalls.hs
@@ -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
− src/ShowFlatCurry.hs
@@ -1,328 +0,0 @@----------------------------------------------------------------------------------- Some tools to support meta-programming in Curry based on FlatCurry.-------- This library contains---- <UL>---- <LI> a show function for a string representation of FlatCurry programs---- (function "showFlatProg")-------- <LI> a function for showing FlatCurry expressions in (almost) Curry syntax---- (function "showCurryExpr")---- </UL>-------- Note that the previously contained function "writeFLC"---- is no longer supported. Use Flat2Fcy.writeFCY instead---- and change file suffix into ".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----------------------------------------------------------------------------------
− src/ShowFunctionalProg.hs
@@ -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 <var0> as var0, like in Prelude)--- - prettyprint list patterns--- in July 2005:--- - added options to most functions--- - print qualified symbol when necessary (local functions missing)--- in May 2007:--- - prettier representation of Curry and Haskell Strings--------------------------------------------------------------------------------module ShowFunctionalProg(showProg,showProgOpt,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 = "~!@#$%^&*+-=<>?./|\\:"------
− src/Simplification.hs
@@ -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 <code>Traversable</code> if it defines a function---- that can decompose a value into a list of children of the same type---- and recombine new children to a new value of the original type. -----type Traversable a b = a -> ([b], [b] -> a)----- Traversal function for constructors without children.-----noChildren :: Traversable a b-noChildren x = ([], const x)----- Yields the children of a value.-----children :: Traversable a b -> a -> [b]-children tr = fst . tr----- Replaces the children of a value.---- -replaceChildren :: Traversable a b -> a -> [b] -> a-replaceChildren tr = snd . tr----- Applies the given function to each child of a value.-----mapChildren :: Traversable a b -> (b -> b) -> a -> a-mapChildren tr f x = replaceChildren tr x (map f (children tr x))----- Computes a list of the given value, its children, those children, etc.-----family :: Traversable a a -> a -> [a]-family tr x = familyFL tr x []----- Computes a list of family members of the children of a value.---- The value and its children can have different types.-----childFamilies :: Traversable a b -> Traversable b b -> a -> [b]-childFamilies tra trb x = childFamiliesFL tra trb x [] ---- implementation of 'family' with functional lists for efficiency reasons--type FunList a = [a] -> [a]--familyFL :: Traversable a a -> a -> FunList a-familyFL tr x xs = x : childFamiliesFL tr tr x xs--childFamiliesFL :: Traversable a b -> Traversable b b -> a -> FunList b-childFamiliesFL tra trb x xs = concatFL (map (familyFL trb) (children tra x)) xs----- Concatenates a list of functional lists.-----concatFL :: [FunList a] -> FunList a-concatFL [] ys = ys-concatFL (x:xs) ys = x (concatFL xs ys)----- Applies the given function to each member of the family of a value.---- Proceeds bottom-up.-----mapFamily :: Traversable a a -> (a -> a) -> a -> a-mapFamily tr f = f . mapChildFamilies tr tr f----- Applies the given function to each member of the families of the children---- of a value. The value and its children can have different types.---- Proceeds bottom-up.-----mapChildFamilies :: Traversable a b -> Traversable b b -> (b -> b) -> a -> a-mapChildFamilies tra trb = mapChildren tra . mapFamily trb----- Applies the given function to each member of the family of a value ---- as long as possible. On each member of the family of the result the given---- function will yield <code>Nothing</code>.---- Proceeds bottom-up.-----evalFamily :: Traversable a a -> (a -> Maybe a) -> a -> a-evalFamily tr f = mapFamily tr g- where g x = maybe x (mapFamily tr g) (f x)----- Applies the given function to each member of the families of the children---- of a value as long as possible.---- Similar to 'evalFamily'.-----evalChildFamilies :: Traversable a b -> Traversable b b- -> (b -> Maybe b) -> a -> a-evalChildFamilies tra trb = mapChildren tra . evalFamily trb----- Implements a traversal similar to a fold with possible default cases.-----fold :: Traversable a a -> (a -> [r] -> r) -> a -> r-fold tr f = foldChildren tr tr f f----- Fold the children and combine the results.-----foldChildren :: Traversable a b -> Traversable b b- -> (a -> [rb] -> ra) -> (b -> [rb] -> rb) -> a -> ra-foldChildren tra trb f g a = f a (map (fold trb g) (children tra a))--infixl 1 .>>=, .>>---type Rules = [(QName,Rule)]-type Simp a = VarIndex -> Rules -> Maybe (a,VarIndex)--runSimp :: 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-
src/kics.hs view
@@ -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
− src/kicsi.hs
@@ -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 <option> set a KiCSi <option>"- ,":set see current KiCSi options"- ,":reload reload current files" - ,":type <expression> show type of <expression>"- ,":quit leave KiCSi"- ,":help this message"- ,":! system command"]- interactive state opts- -info _ [] state opts = interactive state opts-info x (f:fs) state opts = do - safe (do - p <- safeReadFlat opts (f++".fint")- safeIO (putStrLn (showFlatProg p))- safeIO (putStrLn ""))- info x fs state opts--newSm opts@Opts{pm=All _} x = opts{pm=All x}-newSm opts@Opts{pm=Interactive _} x = opts{pm=Interactive x}-newSm opts@Opts{pm=ST} x = opts{pm=Interactive x}--newPm opts@Opts{pm=ST} x = opts{pm=x}-newPm opts@Opts{pm=All x} (Interactive _) = opts{pm=Interactive x}-newPm opts@Opts{pm=Interactive x} (All _) = opts{pm=All x}-newPm opts@Opts{pm=All x} (First _) = opts{pm=First x}-newPm opts@Opts{pm=Interactive x} (First _) = opts{pm=First x}-newPm opts@Opts{pm=First x} (Interactive _) = opts{pm=Interactive x}-newPm opts@Opts{pm=First x} (All _) = opts{pm=All x}-newPm opts _ = opts--getType expr state opts = do - t <- (safe $ do - genReqModule (loadedFiles state) expr- cymake (opts{filename=reqModuleName})- p <- safeIO (readFlatCurry reqModuleFile)- let (f:_) = filter ((==mainExpr) . snd . funcName) (progFuncs p)- return (funcType f))- maybe (return ()) (putStrLn . showCurryType snd False) t- interactive state opts- -load [] state opts = interactive state opts-load xs state opts = do- done <- startCompilations opts{executable=False} fs- interactive state{files=map (isLoaded done) (nub fs)} opts- where- fs = map baseName xs- isLoaded done f = (elem f done,f)-- -toMode _ ["or"] = OrBased-toMode _ ["ctc"] = CTC-toMode m _ = m--mainExpr = "expression"---requestExpr state opts line = do - safe $ do- let ls = loadedFiles state- mainMod = if null ls then "Prelude" else head ls- --safeSystem (verbosity opts >= 5) - -- ("rm -f request Request.fcy "++reqMod ++".o ") - requestFile <- genReqModule (loadedFiles state) line- let compileOpts = (opts{executable=True,filename=requestFile,- mainFunc=mainExpr,- mainModule = mainMod,- make=False}) - startCompilation compileOpts- let call = timing state (requestCall state opts)- when (not (eval opts))- (safeSystem (verbosity opts >= 3) - (ghcCall opts{target=inKicsSubdir "request",- filename=inKicsSubdir "Main.hs"}))- when (verbosity opts >= 2 || not (eval opts))- (put 1 opts ("starting evaluation of "++line))- safeSystem (verbosity opts >= 3) call- when (debug opts) $ do- if debugger opts == Nothing - then do- safeSystem (verbosity opts >= 5) (stricthsCall compileOpts{make=True})- safeSystem (verbosity opts >= 5) - (ghcCall opts{make=True,ghcOpts=ghcOpts opts++" -O2 ", - filename="StrictRequest"})- safeSystem (verbosity opts >= 5) - (ghcCall opts{make=False,eval=True, - ghcOpts=ghcOpts opts++" -e "++mainExpr++" ",- filename="StrictRequest"})- else do- safeSystem (verbosity opts >= 5) - (mkStrictCall compileOpts{filename=inKicsSubdir reqModuleName,- make=True})- genDebugModule opts{mainModule=mainMod} (loadedFiles state) line- safeSystem (verbosity opts >= 5) - (ghcCall opts{target=inKicsSubdir "debug",debug=False,- make=True,ghcOpts=ghcOpts opts++" -O2 ", - filename=inKicsSubdir debugModuleName})- safeSystem (verbosity opts >= 5) - (inKicsSubdir "debug")- - interactive state opts---- in ghc 6.10 we cannot combine make with "-e"--- In order to avoid link errors we somehow need --- to start make before calling "-e", but it is not yet clear--- how to avoid generating a binary.-requestCall state opts@Opts{eval=True} = - ghcCall opts{make=False,- ghcOpts=ghcOpts opts++ " +RTS "++ rts state ++ " -RTS -e main ",- filename=inKicsSubdir "Main.hs"}-requestCall state _ = (inKicsSubdir "request"++" "++cmdLineArgs state++" +RTS "++rts state)--reqModuleName = "Request"-reqModuleFile = replaceExtension (inKicsSubdir reqModuleName) ".fcy"--genReqModule fs line = - safeIO (writeKicsFile False (replaceExtension reqModuleName ".curry")- (imports fs++"\n\n"++mainExpr++" = "++ line))--timing (State{time=True}) s = "time "++s-timing _ s = s---unqualMain s = examine (groupBy (\x y->isExtAlpha x && isExtAlpha y) s)- where- examine (_:".":"main":xs) = examine xs- examine ("main":_) = True- examine (_:xs) = examine xs- examine [] = False--isExtAlpha '_' = True-isExtAlpha '\'' = True-isExtAlpha c = isDigit c || isAlpha c--reqMod = modName reqModuleName--imports :: [String] -> String-imports = concatMap ("\nimport "++) ----------------------------------- triggering the debug tool---------------------------------debugModuleName = "debug.hs"-genDebugModule Opts{debugger=Just tool,mainModule=mod} fs line = do- let modName = debugModuleName- modImports = imports $ "Debugger.DebugMonad":- ("Debugger.Tools."++tool++"."++"Monad"):- map mkStrictName ((reqModuleName++" as S"):fs)- modCont = modImports ++- "\n\nmain = do\n\- \ run (S.strict_"++mainExpr++") \""++mod++"\""- --safeIO $ putStrLn modName- --safeIO $ putStrLn modCont- safeIO (writeKicsFile False modName modCont)- - -