KiCS 0.8.4 → 0.8.5
raw patch · 13 files changed
+613/−866 lines, 13 files
Files
- KiCS.cabal +2/−3
- src/Config.hs +24/−63
- src/CurryToHaskell.hs +273/−375
- src/FunctionalProg.hs +2/−5
- src/KicsSubdir.hs +17/−16
- src/Names.hs +6/−42
- src/PreTrans.hs +59/−82
- src/SafeCalls.hs +32/−21
- src/ShowFlatCurry.hs +57/−103
- src/ShowFunctionalProg.hs +85/−104
- src/Simplification.hs +44/−37
- src/kics.hs +1/−1
- src/kicsi.hs +11/−14
KiCS.cabal view
@@ -1,5 +1,5 @@ Name: KiCS-Version: 0.8.4+Version: 0.8.5 Cabal-Version: >= 1.6 Author: Bernd Braßel Maintainer: Bernd Braßel@@ -12,7 +12,7 @@ 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: experimental+Stability: *INCOMPLETE* do not download yet! (sorry...) Executable kics main-is: kics.hs@@ -68,4 +68,3 @@ Brace InstallDir MyReadline-
src/Config.hs view
@@ -1,17 +1,14 @@ module Config (module Config,module KicsSubdir) where -import Data.Char- import System.FilePath-import System.Environment (getEnvironment,getArgs)-import System.Directory hiding (executable)-import System.Time-import Control.Monad.Trans(liftIO) -import Curry.ExtendedFlat.Type(Prog, readFlat)- import InstallDir import SafeCalls+import Char+import System.Environment (getEnvironment,getArgs)+import System.Directory hiding (executable)+import System.Time+import MetaProgramming.FlatCurry(readFlatCurry) import Names import KicsSubdir @@ -62,8 +59,6 @@ parseOptions opts [x] = Right (opts{filename=x,mainModule=takeBaseName x}) parseOptions _ (x:_) = Left ("unrecognized option: "++x) --usage :: String -> IO b usage problem = do putStrLn problem putStrLn "Usage: kics [options] filename"@@ -108,7 +103,8 @@ extCons,hasData :: Bool, pm :: PresentationMode, extData, extFuncs :: [String],- extInsts :: [(String,[ProvidedInstance])]} deriving Show+ extInsts :: [(String,[ProvidedInstance])],+ toInclude :: String} deriving Show data ConsUse = DataDef | InstanceDef | FunctionDef deriving (Eq,Show) @@ -118,7 +114,7 @@ libpath :: Options -> [String]-libpath Opts{userlibpath=up,kicspath=kp} +libpath opts@Opts{userlibpath=up,kicspath=kp,filename=fn} = --(case takeDirectory fn of "" -> id; dir -> ((dir++[pathSeparator]):)) up ++ [unpath [kp,"src","lib",""]] @@ -140,9 +136,7 @@ not (null (filter (any (/=Declaration) . snd) (extInsts opts))) hasExtFuncs opts = not (null (extFuncs opts)) --defaultOpts :: t -> Options-defaultOpts _ = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Main",+defaultOpts curDir = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Main", target = "request", frontend=cymake_call, kicspath=installDir,@@ -164,10 +158,9 @@ pm=Interactive DF, extData=[], extInsts=[],- extFuncs=[]}-+ extFuncs=[],+ toInclude=""} -kicsrc :: String -> String kicsrc home = unpath [home,".kicsrc"] data ChoiceMode = OrBased | CTC deriving (Eq,Read,Show)@@ -193,16 +186,12 @@ files :: [(Bool,String)], time :: Bool} deriving Show --defaultState :: String -> State defaultState home = State {home=home, rts=" -H400M ", cmdLineArgs="", files=[], time=False} --readPMode :: String -> PresentationMode readPMode s = readPM (words (map toLower s)) where readPM ("interactive":ws) = Interactive (readSM ws)@@ -248,7 +237,6 @@ path -> " -i"++show (addKicsSubdir path)++" " -stricthsCall :: Options -> String stricthsCall opts = callnorm (installDir++"/bin/stricths --hs " ++ ("-s"++mainModule opts++" ")@@ -257,8 +245,6 @@ ++ (if verbosity opts < 2 then "-q " else "") ++ filename opts) --mkStrictCall :: Options -> String mkStrictCall opts = callnorm (installDir++"/bin/mkstrict " ++ (if verbosity opts < 2 then "--quiet " else "")@@ -269,23 +255,16 @@ ++ (if force opts then "-f " else "") ++ filename opts-}) -cyCall :: Options -> String-cyCall opts = callnorm $ frontend opts++" --extended-flat -e " +++cyCall opts = callnorm $ frontend opts++" -e " ++ unwords (map (("-i"++) . show) (libpath opts)) --callnorm :: String -> String callnorm s = unwords (words s) ++ " " --cymake :: Options -> SafeIO () cymake opts = do safeSystem (verbosity opts >= 3) (cyCall opts ++ show (filename opts) ++ if verbosity opts >= 3 then "" else " 1>/dev/null ") --prophecy :: Options -> SafeIO () prophecy opts = safeSystem (verbosity opts >= 4) $ installDir++"/bin/prophecy " ++ (if make opts then " -m " else "")@@ -293,9 +272,8 @@ ++ (if verbosity opts < 2 then " -q " else "") ++ show (dropExtension $ filename opts) ++ if verbosity opts >= 4 then "" else " 1>/dev/null "- -readConfig :: IO (Options, State)+ readConfig = do home <- getEnv "HOME" curDir <- getCurrentDirectory@@ -308,8 +286,6 @@ putStrLn ("You might need to edit it.") error "Please verify .kicsrc") --writeConfig :: Options -> State -> IO () writeConfig opts state = do home <- getEnv "HOME" writeFile (kicsrc home)@@ -328,13 +304,10 @@ entry n s = (configs!!(n-1)) ++ "="++s++"\n\n" -mkTags :: [Options -> String] mkTags = [kicspath, (toPathList . userlibpath), (show . pm)] --getConfigs :: String -> String -> IO (Options, State) getConfigs home cfgs | cfgs == cfgs = do punkt <- getCurrentDirectory @@ -361,8 +334,6 @@ return (opts,state) --entries :: String -> [(String, String)] entries s = equations (lines s) where equations [] = []@@ -370,12 +341,8 @@ (l,_:r) -> (l,r):equations xs _ -> equations xs --selOpts :: [(String, a)] -> [Maybe a] selOpts cfgs = map (selTag cfgs) configs --configs :: [String] configs = ["Libraries", "PresentationMode",@@ -383,38 +350,32 @@ "Time", "RunTimeSettings"] --selTag :: [(String, a)] -> String -> Maybe a selTag [] _ = Nothing selTag ((t,v):xs) s = if map toLower t==map toLower s then Just v else selTag xs s --- FIXME use library functions for path manipulation (hsi)-paths :: String -> [FilePath]+ paths s = case break (==':') s of ("","") -> [] (w,"") -> [w] ("",_:ws) -> paths ws (w,_:ws) -> w : paths ws -getModTime :: String -> SafeIO ClockTime getModTime fn = safeIO (do ex<-doesModuleExist fn if ex then getModuleModTime fn else return (TOD 0 0)) --- FIXME When readFlatCurry fails, no cause is reported (hsi)-safeReadFlat :: Options -> String -> SafeIO (Curry.ExtendedFlat.Type.Prog)+ safeReadFlat opts s = do fs <- safeIO (findFileInPath s (libpath opts)) fn <- warning s (cmdLibpath opts) fs- prog <- safeIOSeq (readFlat fn)- maybe (fail $ "readFlat "++ show s) return prog+ safeIOSeq (readFlatCurry fn) -warning :: String -> FilePath -> [FilePath] -> SafeIO FilePath+ warning fn path [] = fail ("module "++fn++" not found in path "++path) warning _ _ (f:fs) = do mapM_ (safeIO . putStrLn) @@ -441,12 +402,11 @@ -- fortype <typename> [definition|nodef] instances <instname>* -- extfunc <funcname> -put :: Int -> Options -> String -> SafeIO ()-put i Opts{verbosity=j} s - | i > j = return ()- | otherwise = safeIO (putStrLn s)+put :: Int -> Options -> String -> Safe IO ()+put i Opts{verbosity=j} s | i>j = return ()+ | i<=j = safeIO (putStrLn s) -readExternalSpec :: Options -> String -> SafeIO Options+readExternalSpec :: Options -> String -> Safe IO Options readExternalSpec opts p = do specs <- safeIO $ findFileInPath (externalSpecName (p `withoutSubdir` currySubdir)) @@ -456,7 +416,8 @@ else do spec <- warning "" "" specs >>= safeIO . readModule put 5 opts "reading external specification"- let newOpts = foldr insertP opts (read spec)+ let [(specs,stringToInclude)] = reads spec+ newOpts = foldr insertP opts{toInclude=stringToInclude} specs safeIO (seq newOpts (return ())) put 5 opts "external specification read" return newOpts@@ -466,7 +427,7 @@ insertP (ForType t Nothing) opts = opts{extData = t : extData opts} insertP (ForType t (Just is)) opts = opts{extInsts = (t,is) : extInsts opts} -baseName :: String -> String+ baseName f = case reverse f of 'y':'r':'r':'u':'c':'.':f' -> reverse f' 'y':'r':'r':'u':'c':'l':'.':f' -> reverse f'
src/CurryToHaskell.hs view
@@ -1,30 +1,24 @@ module CurryToHaskell where -import Control.Monad-import Data.List-import Data.Char-import Data.Maybe-import System-import System.FilePath--import Curry.ExtendedFlat.Type-import Curry.ExtendedFlat.Goodies hiding (consName)+import 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 (dataHsName,instHsName,funcHsName,- extDataHsName,extInstHsName,extFuncHsName,- extDataModName,extInstModName,extFuncModName,- dataModName,instModName,modName,dbgModName,+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@@ -42,15 +36,13 @@ startCompilations opts fs = compilations fs opts{done=[],mainModule=head fs} --- FIXME errors in retrieving options are silently ignored compilations :: [String] -> Options -> IO [String] compilations [] opts = return (done opts) compilations (f:fs) opts = safe (startCompilation opts{filename=f}) >>=- compilations fs . either (const opts) id-+ compilations fs . maybe opts id -startCompilation :: Options -> SafeIO Options+startCompilation :: Options -> Safe IO Options startCompilation opts = do put 2 opts "calling frontend" newOpts <- callFrontend opts @@ -63,7 +55,7 @@ -- but also a flag whether no significant changes -- have been made. A significant change forces -- recompilation of dependent modules.-compile :: Options -> SafeIO Options+compile :: Options -> Safe IO Options compile opts = do newOpts <- getFlatCurryFileName opts old <- notUptodate newOpts@@ -72,9 +64,9 @@ then process newOpts >>= makeImports else skip newOpts >>= makeImports -process :: Options -> SafeIO (String,[String],Options)+process :: Options -> Safe IO (String,[String],Options) process opts0@(Opts{filename=fn}) = do- prog <- safeReadFlat opts0 (replaceExtension fn ".efc")+ prog <- safeReadFlat opts0 (replaceExtension fn ".fcy") unless (executable opts0) (put 1 opts0 ("processing: "++progName prog)) opts <- readExternalSpec opts0 fn@@ -88,10 +80,10 @@ return (progName prog,progImports prog,opts0) -- only read beginning of interface file, return name and list of imports -skip :: Options -> SafeIO (String,[String],Options)+skip :: Options -> Safe IO (String,[String],Options) skip opts = do let fname = if doNotUseInterface opts - then replaceExtension (filename opts) ".efc"+ then replaceExtension (filename opts) ".fcy" else replaceExtension (filename opts) ".fint" fn <- safeIO (findFileInPath fname (libpath opts)) >>= warning (filename opts) (cmdLibpath opts) @@ -102,7 +94,7 @@ put 3 opts ("up-to-date: "++name) return (name,imps,opts) -makeImports :: (String,[String],Options) -> SafeIO Options+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}@@ -124,25 +116,25 @@ getFlatCurryFileName opts@(Opts{filename=basename}) = do let lib = libpath opts- foundFiles <- safeIO (findFileInPath (replaceExtension basename ".efc") lib)+ 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- tSource <- getModTime (replaceExtension foundBasename ".efc")- tDestination <- getModTime (funcHsName foundBasename)- return (tSource > tDestination)-+ tSource1 <- getModTime (replaceExtension foundBasename ".fcy")+ tSource2 <- getModTime (externalSpecName foundBasename)+ let destination = inModuleSubdir (inKicsSubdir (funcHsName foundBasename))+ tDestination <- getModTime destination+ return (tSource1 > tDestination || tSource2 > tDestination) ---applyFlatTransformations :: Options -> Prog -> ([FuncDecl], Prog, [Prog], ([Char], [Char])) applyFlatTransformations opts prog = do let auxNames = generateAuxNames (progFuncs prog) mexprog = if executable opts then addExec auxNames opts prog else Left prog exprog <- either return fail mexprog let suffix = flip replaceExtension $ if doNotUseInterface opts- then ".efc"+ then ".fcy" else ".fint" interfaces <- mapM (safeReadFlat opts . suffix) (progImports exprog) (globals,locProg) <- safeIOSeq (return (splitGlobals exprog))@@ -161,10 +153,12 @@ mapM (writeProgram opts) (addGlobalDefs opts globals modules) return (haskellFiles opts (progName prog)) -writeProgram opts (fn,printOpts,prog) = do- put 3 opts ("writing "++inKicsSubdir fn)- safeIO (writeKicsFile fn (showProgOpt printOpts prog))- put 3 opts (fn++" written")+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 @@ -184,7 +178,7 @@ unless (and ex) ghc else ghc -foldCompile :: [String] -> Options -> SafeIO Options+foldCompile :: [String] -> Options -> Safe IO Options foldCompile [] opts = return opts foldCompile (f:fs) opts | elem f (done opts) = foldCompile fs opts@@ -198,7 +192,8 @@ -- names of all haskell files associated with program haskellFiles :: Options -> String -> [String]-haskellFiles opts name =+haskellFiles opts name = [funcHsName name]+ {- ifAdd (extData opts) (add [extDataHsName]) $ ifAdd (extInsts opts) (add [dataHsName,extInstHsName]) $ ifAdd (extFuncs opts) (add [instHsName,extFuncHsName]) $ @@ -208,7 +203,7 @@ ifAdd [] _ ds = ds add = foldr (\ f -> ((f name:) .)) id - + -} ------------------------------------------------------ -- basic transformation@@ -225,75 +220,42 @@ where opts = opts0{hasData=hasInternalData}- hasExternalData = hasExtData opts- hasExternalInstances = hasExtInsts opts- hasExternalFuncs = hasExtFuncs opts hasInternalData = not $ null $ filter (not . isExternalType) types - modules - | not hasInternalData = [allinclusiveProg]- | hasExternalInstances && hasExternalFuncs = [dataProg,instProg,funcProg]- | hasExternalInstances = [dataProg,instFuncProg]- | hasExternalFuncs = [dataInstProg,funcProg]- | otherwise = [allinclusiveProg]+ modules = [allinclusiveProg] -- filename, flag and module definitions- dataProg = (dataHsName (filename opts),False,dataModule)- instProg = (instHsName (filename opts),False,instModule)- funcProg = (funcHsName (filename opts),False,funcModule)- instFuncProg = (funcHsName (filename opts),False,instFuncModule)- dataInstProg = (instHsName (filename opts),False,dataInstModule) allinclusiveProg = (funcHsName (filename opts),False,allinclusive) modul mName mImports mExports mTypes mInsts mFuncs = C.Prog mName mImports mExports mTypes mInsts mFuncs [] - dataModule = modul dataName dataImports dataExports dataTypes [] []- instModule = modul instName instImports instExports [] instances []- funcModule = modul funcName funcImports funcExports [] [] functions- instFuncModule = modul funcName instImports funcExports [] instances functions- dataInstModule = modul instName dataImports dataExports dataTypes instances [] allinclusive = modul funcName allIImports allIExports dataTypes instances functions -- the module names are:- dataName = dataModName name- instName = instModName name- funcName = N.modName name+ funcName = modName name mainModuleName = "Main" -- the file names of these modules are: funcFileName = funcHsName (filename opts)- dataFileName = dataHsName (filename opts) mainFileName = "Main.hs" -- import lists- newImports = map N.modName imports- allIImports = - ["Curry"] ++ (if hasExternalData then [extDataModName name] else []) - ++ (if hasExternalFuncs then [extFuncModName name] else [])- ++ newImports- dataImports - | hasExternalData = "Curry" : (extDataModName name) : newImports- | otherwise = "Curry" : newImports- instImports = "Curry" : dataName : (extInstModName name) : newImports- funcImports = "Curry" : instImportName : (extFuncModName name) : newImports+ 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 = map ("module "++) $- (if hasExternalData then [extDataModName name] else [])- ++ (if hasExternalFuncs then [extFuncModName name] else [])- dataExports - | hasExternalData = ["module "++extDataModName name]- | otherwise = []- instExports = map ("module "++) [dataName,extInstModName name]- funcExports = map ("module "++) [instName,extFuncModName name]+ allIExports = [] -- the generated types, instances and functions dataTypes = map (transTypeDecl opts{consUse=DataDef}) @@ -308,8 +270,8 @@ -- information about original module (typeSyns,typeDecls) = partition isTypeSyn $ - filter (\t-> not (elem (localName $ typeName t) (extData opts))) types- isToTransform t = case lookup (localName $ typeName t) (extInsts opts) of+ 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) @@ -320,19 +282,19 @@ generateAuxNames fs = (genNewName "aux1" fns,genNewName "aux2" fns) where - fns = map (localName . funcName) fs+ 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 = mkQName (m,localName (mkQName $ funName ("",aux2))) in- C.Prog "Main" ["Curry",N.modName "Prelude",m]+mainMod (_,aux2) m opts = let aux = (m,snd (funName ("",aux2))) in+ C.Prog "Main" ["Curry",modName "Prelude",m] [] [] [] - [C.Func (mkQName (m,"main")) public untyped + [C.Func (m,"main") public untyped (Just [C.Rule [] (noguard $ fapp (hasPresym ">>") [app (setProg opts) (C.String (mainModule opts)),- app (C.Symbol (mkQName (N.modName "Prelude","curryIOVoid")))+ app (C.Symbol (modName "Prelude","curryIOVoid")) (sym aux)]) []])] [] where@@ -361,14 +323,14 @@ (flatBind (flatGst (calla1 t True)) (startFunc opts)))] _ -> Right (mainFunc opts++" undefined") where- a1 = mkQName (m,aux1)- a2 = mkQName (m,aux2)+ a1 = (m,aux1)+ a2 = (m,aux2) calla1 t orc = if debug opts - then Comb FuncCall (mkQName ("Oracle","oracle"++if orc then "IO" else "") )+ then Comb FuncCall ("Oracle","oracle"++if orc then "IO" else "") [Comb (FuncPartCall 1) a1 []] else Comb FuncCall a1 []- printIO = mkQName ("Interactive","printIO")- lfs = zip (map (localName . funcName) funcs) funcs+ printIO = ("Interactive","printIO")+ lfs = zip (map (snd . funcName) funcs) funcs startFunc Opts{pm=Interactive DF} = ask ... df startFunc Opts{pm=Interactive BF} = ask ... bf @@ -385,14 +347,14 @@ prog addInt fs = Left (Prog m (if addInt then "Interactive":is else is) ts (fs++funcs) ops) -ask = mkQName ("Interactive","interactiveSols")-df = mkQName ("Prelude","allValuesD")-bf = mkQName ("Prelude","allValuesB")-pr = mkQName ("Interactive","printTerm")-hd = mkQName ("Prelude","head")-f ... g = Comb FuncCall (flatPre ".") +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 (flatPre ".") [Comb (FuncPartCall 1) f [],e]+ap_ f e = Comb FuncCall (addPre ".") [Comb (FuncPartCall 1) f [],e] ------------------------------------------------------ -- transformation of type declarations@@ -404,12 +366,12 @@ transTypeDecl :: Options -> TypeDecl -> C.TypeDecl transTypeDecl opts (Type name vis vars consdecls) - = C.Type (consName opts name) (transvis vis) (map (varName "t" . mkIdx) vars) + = 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" . mkIdx) vars) + = C.TypeSyn (consName opts name) (transvis vis) (map (varName "t") vars) (transTypeExpr opts t) transConsdecls :: Options -> ConsDecl -> C.ConsDecl@@ -431,12 +393,12 @@ transTypeExprF opts (TCons name ts) = C.TCons (consName opts name) (map (transTypeExprF opts) ts) -newConsDecls qn vs - = [C.Cons qn{ localName = localName qn ++ "Fail"} 0 private False [tExceptions],- C.Cons qn{ localName = localName qn ++ "Or"} 2 private False +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 qn (map toTVar vs)+ newT = C.TCons (m,n) (map toTVar vs) -------------------------------------------@@ -446,20 +408,20 @@ inst newModName name vars classname = C.Instance (map (\v -> C.TypeClass (cu classname) [toTVar v]) vars) (C.TypeClass (cu classname) - [C.TCons (mkQName (newModName,name)) (map toTVar vars)])+ [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) = qnOf $ consName opts origName + (newModName,name) = consName opts origName - origMod = Curry.ExtendedFlat.Type.modName origName+ origMod = fst origName isPrelude = origMod=="Prelude" - strEq = C.Func (mkQName (newModName,"strEq")) (transvis vis) untyped + strEq = C.Func (newModName,"strEq") (transvis vis) untyped (Just (map strEqRule consdecls++ [C.Rule [_x,toPVar 0,_x]@@ -468,82 +430,82 @@ [fapp (extInstPresym isPrelude "typeName") [toVar 0]]) []])) strEqRule (Cons cname arity _ _) =- rule [C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]),- C.PComb (consName opts cname) (map (toPVar' "y" . mkIdx) [1..arity])]+ 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 $ mkIdx i,toVar' "y" (mkIdx i)])+ sEq i = fapp (extInstPresym isPrelude "genStrEq") (addStateArg [toVar i,toVar' "y" i]) - eq = C.Func (mkQName (newModName,"eq")) (transvis vis) untyped + eq = C.Func (newModName,"eq") (transvis vis) untyped (Just (map eqRule consdecls- ++otherwiseExp 3 (baseTypesym isPrelude "C_False")))+ ++otherwiseExp 3 (concupresym opts "False"))) eqRule (Cons cname arity _ _) =- rule [C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]),- C.PComb (consName opts cname) (map (toPVar' "y" . mkIdx) [1..arity])]- (noguard $ if arity==0 then baseTypesym isPrelude "C_True"- else foldr1 (\ e es -> fapp (fbasesym opts "&&") (addStateArg [e,es]))+ 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 $ mkIdx i,toVar' "y" (mkIdx i)])+ eqArgs i = fapp (extInstPresym isPrelude "genEq") (addStateArg [toVar i,toVar' "y" i]) - propagate = C.Func (mkQName (newModName,"propagate")) (transvis vis) untyped + 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 . mkIdx) [1..arity])])+ (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 $ mkIdx i])+ where propCall i = fapp (C.Var "f") (addStateArg [toHInt (i-1),toVar i]) - foldCurry = C.Func (mkQName (newModName,"foldCurry")) (transvis vis) untyped + 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 . mkIdx) [1..arity])])- (noguard $ foldr appFold (C.Var "c") (map (toVar . mkIdx) [1 .. arity])) []+ (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 (mkQName (newModName,"typeName")) (transvis vis) untyped + typeName = C.Func (newModName,"typeName") (transvis vis) untyped (Just [C.Rule [_x] - (noguard $ C.String (localName origName)) []])+ (noguard $ C.String (snd origName)) []]) - toTerm = C.Func (mkQName (newModName,"toC_Term")) (transvis vis) untyped + toTerm = C.Func (newModName,"toC_Term") (transvis vis) untyped (Just (map toTermRule (zip [1..] consdecls) ++ [C.Rule [_x,_x,- C.PComb (mkQName (newModName,name++"FreeVar")) [C.PVar "r"]] - (noguard $ app (baseTypesym isPrelude "C_Free") - (app (c_int isPrelude)+ 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 . mkIdx) [1..arity])] - (noguard $ fapp (baseTypesym isPrelude "C_Data") - [toInt nr,c_string_ origMod (localName cname),+ 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 (basesym "ctcStore") - [C.Var "mode",app (basesym "toC_Term") (C.Var "mode"),- C.Var "store",toVar $ mkIdx i]+ su i = fapp (cusym "ctcStore") + [C.Var "mode",app (cusym "toC_Term") (C.Var "mode"),+ C.Var "store",toVar i] - fromTerm = C.Func (mkQName (newModName,"fromC_Term")) (transvis vis) untyped + 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 (mkQName (newModName,name++"FreeVar")))+ (noguard $ app (sym (newModName,name++"FreeVar")) (app (hasPresym "fromInteger") (C.Var "r"))) []])) @@ -553,10 +515,10 @@ where pnr = toPInt opts nr pfree = C.PComb (baseType isPrelude "C_IntFreeVar") [_x]- pname = dpList isPrelude (map (toPChar opts) (localName cname))- pts = dpList isPrelude (map (toPVar . mkIdx) [1..arity])+ pname = dpList isPrelude (map (toPChar opts) (snd cname))+ pts = dpList isPrelude (map toPVar [1..arity]) e = noguard $ fapp (sym (consName opts cname)) - (map (app (basesym "fromC_Term") . toVar . mkIdx) [1..arity])+ (map (app (cusym "fromC_Term") . toVar) [1..arity]) rule c args = C.Rule [C.PComb (baseType isPrelude c) args] e [] @@ -567,13 +529,13 @@ consKind, exceptions,orRef,branches] where- (newModName,name) = qnOf $ consName opts origName + (newModName,name) = consName opts origName - origMod = Curry.ExtendedFlat.Type.modName origName+ origMod = fst origName isPrelude = origMod=="Prelude" - nf gr = C.Func (mkQName (newModName,if gr then "gnf" else "nf")) (transvis vis) untyped + 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"])@@ -581,32 +543,32 @@ nfrule gr (Cons cname arity _ _) = [C.Rule [C.PVar "f",- C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]),+ 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" . mkIdx) [1..arity]),- toVar' "state" (mkIdx arity)])- (map mkIdx [1..arity])) []]+ (map (toVar' "v") [1..arity]),+ toVar' "state" arity])+ [1..arity]) []] nflambda gr i e = - fapp (basesym (if gr then "gnfCTC" else "nfCTC")) + 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 (mkQName (newModName,s)) (transvis vis) untyped + free s t = C.Func (newModName,s) (transvis vis) untyped (Just [C.Rule [C.PVar "i"] (noguard $ - fapp (basesym "withRef") [+ fapp (cusym "withRef") [ C.Lambda [C.PVar "r"] $ fapp (sym (orName opts origName)) - [fapp (basesym "mkRef") [C.Var "r",maxAr,C.Var "i"],+ [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 (basesym t))))+ (snd $ foldr addOne (0,[]) (replicate arity (app (cusym t)))) addOne e (n,es) = (n+1,e (fapp (hasPresym "+") [C.Var "r",toHInt n]):es) @@ -616,26 +578,26 @@ suspend = constructor "suspend" suspName - consKind = C.Func (mkQName (newModName,"consKind")) (transvis vis) untyped + consKind = C.Func (newModName,"consKind") (transvis vis) untyped (Just (map tester [(orName, 2, "Branching"), (failName, 1, "Failed")] ++ [C.Rule [_x]- (noguard $ (basesym "Val")) []]))+ (noguard $ (cusym "Val")) []])) tester (namer,arity,nameTest) = C.Rule [C.PComb (namer opts origName) (take arity (repeat (_x)))]- (noguard (basesym nameTest)) []+ (noguard (cusym nameTest)) [] selector nameSel namer arity number =- C.Func (mkQName (newModName,nameSel)) (transvis vis) untyped + 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 (mkQName (newModName,nameConstr)) (transvis vis) untyped + C.Func (newModName,nameConstr) (transvis vis) untyped (Just [C.Rule [] (noguard $ sym (namer opts origName)) []]) @@ -663,27 +625,26 @@ = C.Func newFName (transvis vis) (transFType opts arity t) crules where- newFName = mkQName $ funName $ qnOf fname- f = mkQName (N.modName (Curry.ExtendedFlat.Type.modName fname),auxName $ localName newFName) + 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 _ _ _ _ -> error "case not normalized"- _ -> Just [rule (map toPVar lhs) (noguard trhs) []]-- auxName name- | isInfixOpName name = elimInfix name- | otherwise = name+ 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 qn arity vis t (External _))- = C.Func (mkQName $ funName $ qnOf qn) (transvis vis) (transFType opts arity t)- (Just [rule (map (toPVar . mkIdx) [1..arity]) - (noguard (fapp (C.Symbol (mkQName (extFuncModName m,fname)))- (addStateArg (map (toVar . mkIdx) [1..arity])))) []])- where (m, fname) = qnOf qn+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@@ -692,7 +653,7 @@ transFType opts arity t = Just $ C.TConstr [C.TypeClass c [toTVar tv] | tv <- nub (allVarsInTypeExpr t),- c <- [mkQName ("Curry","Curry")]]+ c <- [("Curry","Curry")]] (addStateType (transFTypeExpr opts arity t)) transFTypeExpr opts 0 t = transTypeExprF opts t@@ -713,10 +674,9 @@ C.LetDecl (map locdecl vbs) (transExpr opts e) where locdecl (v,b) = C.LocalPat (toPVar v) (transExpr opts b) []-transExpr opts (Comb FuncCall fn args)- | qnOf fn == ("Global","global") - = C.LetDecl [C.LocalPat (C.PVar "st") (hasPresym "Nothing") []] - (fapp (C.Symbol (mkQName $ funName $ qnOf fn)) (map (transExpr opts) args))+transExpr opts (Comb 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@@ -724,8 +684,8 @@ call = case combType of ConsCall -> symApp (consName opts fname) newArgs- FuncCall -> symApp (mkQName $ funName $ qnOf fname) (addStateArg newArgs)- FuncPartCall i -> symApp (mkQName $ funName $ qnOf fname) newArgs+ 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@@ -735,13 +695,13 @@ FuncCall -> call FuncPartCall i -> pf opts i call ConsPartCall i -> pc opts i call-transExpr _ (Case _ _ _ _) = error "unlifted case"+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+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 -> @@ -752,14 +712,13 @@ oldRules = map (transRule vs opts) branches typeName = case (\ (Branch p _) -> p) (head branches) of Pattern c _ -> tm c- LPattern l -> mkQName ("Prelude",case l of {Intc _ _->"Int";Charc _ _->"Char"})+ 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 && "CurryOracle" `isPrefixOf` mname && length mname > 11- mname = Curry.ExtendedFlat.Type.modName f+ 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)@@ -773,7 +732,7 @@ newRules = [newLhs orPat (noguard ((if isOracleMod- then fapp (sym (mkQName (funName ("CEventOracle","onBranches")))) .+ then fapp (sym (funName ("CEventOracle","onBranches"))) . (toVar refVar :) else fapp (cusym "mapOr")) (addStateArg [applyf isOracleMod,@@ -781,18 +740,18 @@ ,newLhs (C.PVar "x") (noguard $ (if isOracleMod then closeRef refVar else id) $ fapp (cusym "patternFail") - [qname_ $ qnOf oName,C.Var "x"])]+ [qname_ oName,C.Var "x"])] - closeRef i e = fapp (sym $ mkQName $ funName ("CEventOracle","closeRef")) $+ 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) +transRule (as,v:bs) opts (Branch (LPattern l@(Charc _)) e) = rule ps (C.GuardedExpr [(guard,transExpr opts e)]) [] where guard = app (extInstPresym False "isC_True")- (fapp (fbasesym opts "===") [toVar v,toLit opts l])+ (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)) []@@ -808,9 +767,9 @@ rule ps = C.Rule (addStatePat ps) -transOp (Op name InfixOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixOp p-transOp (Op name InfixlOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixlOp p-transOp (Op name InfixrOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixrOp p+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 ----------------------------------------------------------------@@ -819,70 +778,62 @@ genInstances _ _ _ [] = [] genInstances cl genFunc opts (t:ts) - | maybe False (elem cl) (lookup (localName $ typeName t) (extInsts opts)) + | 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 (has "Show") [toTVar v]) vars)- (C.TypeClass (has "Show") [C.TCons (mkQName (newModName,name)) (map toTVar vars)])+ 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) = qnOf $ consName opts origName+ (newModName,name) = consName opts origName showFunction showQ opts t@(Type origName vis vars consdecls) - | maybe False (elem Show) (lookup (localName $ typeName t) (extInsts opts)) + | 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 qn - = case localName qn of- '(':_ -> hasPresym "True"- _ | showQ -> hasPresym "True"- | otherwise -> lt (C.Var "d") app_prec-+ 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 (Curry.ExtendedFlat.Type.modName origName=="Prelude") + showsPrecSym = (if showQ then extInstPresym (fst origName=="Prelude") else hasPresym) showsPrecName - identifier qn = case localName qn of- "()" -> "()"- _ -> let (cm,cn) = qnOf qn- in if showQ then cm++"."++cn else cn+ identifier (_,"()") = "()"+ identifier (cm,cn) = if showQ then cm++"."++cn else cn - opening qn = case localName qn of- '(':_ -> ""- _ -> identifier qn ++ " "+ opening (_,'(':_) = ""+ opening cmn = identifier cmn ++ " " - separator qn = case localName qn of- '(':_ -> ','- _ -> ' '+ separator (_,'(':_) = ','+ separator _ = ' ' - showsPrec rs = C.Func (mkQName (newModName,showsPrecName))+ showsPrec rs = C.Func (newModName,showsPrecName) (transvis vis) untyped (Just rs) - (newModName,name) = qnOf $ consName opts origName+ (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 . mkIdx) [1..arity])]+ C.Rule [C.PVar "d", C.PComb (consName opts cname) (map toPVar [1..arity])] (C.SimpleExpr (fapp (hasPresym "showParen") - [showParenArg cname,sym (mkQName ("","showStr"))]))- [C.LocalFunc (C.Func (mkQName ("","showStr")) (transvis vis) untyped + [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 . mkIdx) [1..arity]))+ (map callShowsPrec [1..arity])) callShowsPrec i = fapp showsPrecSym [add_prec cname,toVar i]@@ -892,18 +843,18 @@ point x y = fapp (hasPresym ".") [x,y] - showTuple = C.Func (mkQName (newModName,showsPrecName)) (transvis vis) untyped + 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 . mkIdx) [1..arity])]+ C.Rule [C.PVar "d", C.PComb (consName opts cname) (map toPVar [1..arity])] (C.SimpleExpr (app (hasPresym "showString") (app (hasPresym "show") - (fapp (sym (mkQName ("",localName cname)))- (map (toVar . mkIdx) [1..arity]))))) []+ (fapp (sym ("",snd cname)) + (map toVar [1..arity]))))) [] showGenerator = C.Rule [_x, - C.PComb (mkQName (newModName,name++"Or")) [C.PVar "r",_x]]+ C.PComb (newModName,name++"Or") [C.PVar "r",_x]] (C.SimpleExpr (app (hasPresym "showString") (cons_ (char_ '_') @@ -912,15 +863,14 @@ (C.Var "r")))))) [] readInstance :: Config.Options -> TypeDecl -> C.InstanceDecl-readInstance opts (Type origName vis vars consdecls) =- C.Instance (map (\v -> C.TypeClass (has "Read") [toTVar v]) $ vars)- (C.TypeClass (has "Read") [C.TCons c (map toTVar vars)])- [if isTuple (localName origName) then readTuple else readsPrec]+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 = consName opts origName- newModName = Curry.ExtendedFlat.Type.modName c+ c@(newModName,newName) = consName opts origName - readsPrec = C.Func (mkQName (newModName,"readsPrec")) (transvis vis) untyped + readsPrec = C.Func (newModName,"readsPrec") (transvis vis) untyped (Just [C.Rule [C.PVar "d",C.PVar "r"] (C.SimpleExpr (plusplus (map read consdecls))) []]) @@ -931,46 +881,45 @@ read cons = fapp (hasPresym "readParen") [lt (C.Var "d") app_prec,lamb cons,C.Var "r"] - lamb (Cons cn arity _ args) = C.Lambda [C.PVar "r"] - (C.ListComp (fapp (sym (mkQName ("","(,)")))+ lamb (Cons cn@(cmodName,cname) arity _ args) = C.Lambda [C.PVar "r"] + (C.ListComp (fapp (sym ("","(,)")) [fapp (sym newC) - (map (toVar . mkIdx) [1..arity]),- toVar' "r" (mkIdx arity) ])+ (map toVar [1..arity]),+ toVar' "r" arity ]) (C.SPat (pair (C.PVar "_") (toPVar' "r" 0)) - (fapp (cusym "readQualified") [string_ (Curry.ExtendedFlat.Type.modName cn),string_ (localName cn),C.Var "r"]):- map (readArg . mkIdx) [1..arity]))+ (fapp (cusym "readQualified") [string_ cmodName,string_ cname,C.Var "r"]):+ map readArg [1..arity])) where- newC = consName opts cn+ newC@(newMod,newCName) = consName opts cn readArg i = C.SPat (pair (toPVar' "x" i) (toPVar' "r" i)) (fapp (hasPresym "readsPrec") - [add_prec $ mkQName ("",""),+ [add_prec ("",""), toVar' "r" (i-1)]) - readTuple = C.Func (mkQName (newModName,"readsPrec")) (transvis vis) untyped + readTuple = C.Func (newModName,"readsPrec") (transvis vis) untyped (Just (map readTupleRule consdecls)) - readTupleRule (Cons t arity _ args) =+ readTupleRule (Cons t@(_,tup) arity _ args) = C.Rule [C.PVar "d",C.PVar "r"] (C.SimpleExpr - (fapp (hasPresym "map") [sym (mkQName ("","readTup")),+ (fapp (hasPresym "map") [sym ("","readTup"), fapp (hasPresym "readsPrec") [C.Var "d",C.Var "r"]])) - [C.LocalFunc (C.Func (mkQName ("","readTup")) (transvis vis) untyped - (Just [C.Rule [pair (C.PComb (mkQName ("",localName t)) (map (toPVar . mkIdx) [1..arity])) + [C.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 (mkQName ("","(,)")))- [fapp (sym (consName opts t)) (map (toVar . mkIdx) [1..arity]),+ (fapp (sym ("","(,)"))+ [fapp (sym (consName opts t)) (map toVar [1..arity]), C.Var "s"])) []]))] - pair x y = C.PComb (mkQName ("","(,)")) [x,y]+ pair x y = C.PComb ("","(,)") [x,y] -add_prec qn = case localName qn of- '(':_ -> cusym "zero"- _ -> cusym "eleven"+add_prec (_,'(':_) = cusym "zero"+add_prec _ = cusym "eleven" app_prec = cusym "ten" @@ -984,40 +933,17 @@ -------------------------- consName,freeVarName,failName,orName,suspName :: Options -> QName -> QName-consName opts qn- | m/=currentModule opts = mkQName (N.modName m,cn)- | dataDef && isExtDataName = mkQName (extDataModName m,cn)- | dataDef && existsDataModule = mkQName (dataModName m,cn)- | dataDef && existsInstModule = mkQName (instModName m,cn)- | dataDef = mkQName (N.modName m,cn)- | instDef && existsDataModule = mkQName (dataModName m,cn)- | instDef && isExtDataName = mkQName (extDataModName m,cn)- | instDef && existsInstModule = mkQName (instModName m,cn)- | instDef = mkQName (N.modName m,cn)- | funcDef && existsInstModule = mkQName (instModName m,cn)- | funcDef && isExtDataName = mkQName (extDataModName m,cn)- | funcDef = mkQName (N.modName m,cn)+consName opts (m,n) = (modName m,cn) where- m = Curry.ExtendedFlat.Type.modName qn- n = localName qn- existsDataModule = hasExtInsts opts- existsInstModule = hasData opts && hasExtFuncs opts- isExtDataName = elem n (extData opts)- cn | extCons opts = n | otherwise = constructorName n - instDef = consUse opts==InstanceDef- funcDef = consUse opts==FunctionDef- dataDef = consUse opts==DataDef---- FIXME N.freeVarName, failName, orName, suspName :: QName -> QName-freeVarName opts = mkQName . N.freeVarName . qnOf . consName opts-failName opts = mkQName . N.failName . qnOf . consName opts-orName opts = mkQName . N.orName . qnOf . consName opts-suspName opts = mkQName . N.suspName . qnOf . consName opts+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 = mkQName ("Curry",s)+curryName s = ("Curry",s) curryTCons = C.TCons . curryName ----------------------------------------@@ -1045,8 +971,7 @@ where gs' = map transformGlobal gs transformGlobal (Func n 0 vis t (Rule [] e)) = - -- FIXME funName :: QName -> QName- C.Func (mkQName $ funName $ qnOf n) (transvis vis) (transFType opts 0 t) + C.Func (funName n) (transvis vis) (transFType opts 0 t) (Just [C.Rule [] (C.SimpleExpr (transExpr opts e)) []]) @@ -1054,6 +979,20 @@ -- 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)@@ -1064,19 +1003,19 @@ -- partial function call, one argument missing pf :: Options -> Int -> C.Expr -> C.Expr-pf opts = app . partial opts (fapp (extFuncPresym opts "pf"))+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 (extFuncPresym opts "pc"))+pc opts = app . partial opts (fapp (cupresym "pc")) -- partial application, more than one argument pa :: Options -> [C.Expr] -> C.Expr-pa opts = fapp (extFuncPresym opts "pa")+pa opts = fapp (cupresym "pa") -- function compostition (.) cp :: Options -> [C.Expr] -> C.Expr-cp opts = fapp (extFuncPresym opts "cp")+cp opts = fapp (cupresym "cp") partial :: Options -> ([C.Expr] -> C.Expr) -> Int -> C.Expr partial opts part n@@ -1090,7 +1029,7 @@ | n == 0 = p | otherwise = dotted opts (n-1) (cp opts [p]) -prelPCons opts s = C.PComb (consName opts (mkQName ("Prelude",s)))+prelPCons opts s = C.PComb (consName opts (addPre s)) pO opts x = prelPCons opts "O" [x] pI opts x = prelPCons opts "I" [x]@@ -1118,12 +1057,12 @@ tSuspRef = curryTCons "SuspRef" [] -tList a = C.TCons (mkQName ("Prelude","[]")) [a]+tList a = C.TCons (addPre "[]") [a] c_tList a = curryTCons "List" [a] -tPair a b = C.TCons (mkQName ("Prelude","(,)")) [a,b]+tPair a b = C.TCons (addPre "(,)") [a,b] -tMaybe a = C.TCons (mkQName ("Prelude","Maybe")) [a]+tMaybe a = C.TCons (addPre "Maybe") [a] tBranches x = curryTCons "Branches" [x] @@ -1147,40 +1086,15 @@ flatApp = Comb FuncCall -flatBind x y = Comb FuncCall (flatPre ">>=") [x,y]--flatEq x y = Comb FuncCall (flatPre "===") [x,y]+flatBind x y = Comb FuncCall (addPre ">>=") [x,y] -flatPre s = mkQName ("Prelude",s)+flatEq x y = Comb FuncCall (addPre "===") [x,y] -flatGst x = Comb FuncCall (flatPre "getSearchTree") [x]+flatGst x = Comb FuncCall (addPre "getSearchTree") [x] mid = hasPresym "id" -sym = C.Symbol --cusym s = sym (cu s)--fcusym s = sym (mkQName (funName ("Prelude",s)))----basesym s = sym (ba s)--baseTypesym isP s = sym (baseType isP s)--baseType True s = mkQName (dataModName "Prelude",s)-baseType False s = mkQName (N.modName "Prelude",s)----fbasesym opts s - | currentModule opts=="Prelude" = sym (mkQName (extInstModName "Prelude",functionName s))- | otherwise = sym (mkQName (N.modName "Prelude",functionName s))---cu s = mkQName ("Curry",s)-ba s = mkQName ("Curry",s)+baseType _ s = addPre s toVar i = C.Var (xvar i) @@ -1188,40 +1102,27 @@ xvar = varName "x" -mkVarName :: String -> Int -> String-mkVarName s i = s++show i--varName :: String -> VarIndex -> String-varName s i = mkVarName s (idxOf i)+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 (mkVarName "t" i)+toTVar i = C.TVar (varName "t" i) primValue opts v = app (sym $ consName opts{extCons=True} (addPre "PrimValue")) v --- FIXME-addPre s = mkQName ("Prelude",s)-has s = mkQName ("Prelude",s)---toList [] = C.Symbol (mkQName ("","[]"))-toList (x:xs) = app2 (C.Symbol (mkQName ("",":"))) x (toList xs)--toPList [] = C.PComb (mkQName ("","[]")) []-toPList (x:xs) = C.PComb (mkQName ("",":")) [x,toPList xs] --hasPresym s = sym (has s)-+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+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)@@ -1237,23 +1138,23 @@ m = mod n 2 toPChar opts c - | currentModule opts=="Prelude" = C.PComb (mkQName (dataModName "Prelude","C_Char")) [C.PLit (C.Charc c)]- | otherwise = C.PComb (mkQName (N.modName "Prelude","C_Char")) [C.PLit (C.Charc c)]+ | 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+toLit opts (Intc i) = toInt i+toLit opts (Charc c) = toChar opts c+toLit opts (Floatc f) = toFloat opts f toInt n = C.Lit (C.Intc (toInteger n)) toHInt n = C.Lit (C.HasIntc (toInteger n)) -c_int isP = baseTypesym isP "C_Int"+c_int = cupresym "C_Int" -toChar opts c = app (sym (consName opts (mkQName ("Prelude","Char")))) (C.Lit (C.Charc c))+toChar opts c = app (sym (consName opts ("Prelude","Char"))) (C.Lit (C.Charc c)) toFloat opts f = primValue opts (C.Lit (C.Floatc f)) @@ -1261,10 +1162,10 @@ otherwiseExp n e = [C.Rule (map C.PVar (take n (repeat "_"))) (noguard e) []] -ioT x = TCons (mkQName ("Prelude","IO")) [x]-unitT = TCons (mkQName ("Prelude","()")) []+ioT x = TCons ("Prelude","IO") [x]+unitT = TCons ("Prelude","()") [] -hasUnit = sym (mkQName ("","()"))+hasUnit = sym ("","()") hasBind x y = fapp (hasPresym ">>=") [x,y] hasReturn x = app (hasPresym "return") x@@ -1274,18 +1175,18 @@ list_ [] = nil list_ (x:xs) = cons_ x (list_ xs) -cons_ x xs = fapp (sym (mkQName ("",":"))) [x,xs]-nil = sym (mkQName ("","[]"))+cons_ x xs = fapp (sym ("",":")) [x,xs]+nil = sym ("","[]") string_ n = list_ (map char_ n) -c_char_ c = fapp (basesym "C_Char") [C.Lit (C.Charc c)]+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 (sym (mkQName ("DataPrelude",":<"))) [x,xs]-c_nil = sym (mkQName ("DataPrelude","List"))+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)@@ -1296,8 +1197,8 @@ dpList True = bc_plist_ dpList False = c_plist_ -bc_cons_ x xs = fapp (sym (mkQName ("DataPrelude",":<"))) [x,xs]-bc_nil = sym (mkQName ("DataPrelude","List"))+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)@@ -1307,20 +1208,20 @@ plist_ [] = pnil plist_ (x:xs) = pcons_ x (plist_ xs) -pcons_ x xs = C.PComb (mkQName ("",":")) [x,xs]-pnil = C.PComb (mkQName ("","[]")) []+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 (mkQName ("DataPrelude",":<")) [x,xs]-c_pnil = C.PComb (mkQName ("DataPrelude","List")) []+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 (mkQName ("DataPrelude",":<")) [x,xs]-bc_pnil = C.PComb (mkQName ("DataPrelude","List")) []+bc_pcons_ x xs = C.PComb (addPre ":<") [x,xs]+bc_pnil = C.PComb (addPre "List") [] pstring_ n = plist_ (map pchar_ n)@@ -1329,12 +1230,9 @@ qname_ (m,f) = string_ (m++'.':f) -extInstPresym True s = sym $ mkQName (extInstModName "Prelude",s)-extInstPresym False s = sym $ mkQName (N.modName "Prelude",s)+extInstPresym _ s = sym (modName "Prelude",s) -extFuncPresym opts s - | isPrelude opts = sym $ mkQName (extFuncModName "Prelude",s)- | otherwise = sym $ mkQName (N.modName "Prelude",s)+extFuncPresym opts s = sym (modName "Prelude",s) _x = C.PVar "_"
src/FunctionalProg.hs view
@@ -19,9 +19,6 @@ module FunctionalProg where -import Curry.ExtendedFlat.Type(QName)-- ------------------------------------------------------------------------------ -- Definition of data types for representing abstract Curry programs: -- ==================================================================@@ -49,7 +46,7 @@ --- 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)+type QName = (String,String) -- Data type to specify the visibility of various entities.@@ -140,7 +137,7 @@ --- An operator declaration "fix p n" in Curry corresponds to the --- AbstractCurry term (COp n fix p). -data OpDecl = Op QName Fixity Integer deriving (Show,Eq,Read)+data OpDecl = Op QName Fixity Int deriving (Show,Eq,Read) data Fixity = InfixOp -- non-associative infix operator | InfixlOp -- left-associative infix operator
src/KicsSubdir.hs view
@@ -3,6 +3,7 @@ import System.Directory import System.FilePath import System.Time (ClockTime)+import Control.Monad (when) import List (intersperse,nubBy) curDirPath :: FilePath@@ -12,7 +13,6 @@ path = canonPath . separateBy isPathSeparator where canonPath (c:cs) = c:filter (not . null) cs- canonPath [] = [] -- separate a list by separator predicate @@ -43,10 +43,9 @@ inSubdir :: String -> String -> String inSubdir fn sub = unpath $ add (path fn) where- add ps@[_] = sub:ps- add ps@[p,_] | p==sub = ps+ add ps@[n] = sub:ps+ add ps@[p,n] | p==sub = ps add (p:ps) = p:add ps- add [] = error "inSubdir: empty path" withoutSubdir :: String -> String -> String withoutSubdir fn sub = unpath $ rmv (path fn) @@ -64,10 +63,7 @@ inCurrySubdir :: String -> String inCurrySubdir = (`inSubdir` currySubdir) -kicsSubdir :: String kicsSubdir = "kics"--addKicsSubdir :: String -> String addKicsSubdir s = unpath [s,currySubdir,kicsSubdir] pathWithSubdirs :: [FilePath] -> [FilePath]@@ -79,16 +75,21 @@ 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 :: String -> String -> IO String-writeKicsFile filename contents = do- let filename' = inKicsSubdir filename +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@@ -98,8 +99,8 @@ if ex then act filename else do let filename' = inCurrySubdir filename- ex' <- doesFileExist filename'- if ex' then act filename' + ex <- doesFileExist filename'+ if ex then act filename' else do let filename'' = inKicsSubdir filename act filename''@@ -118,15 +119,15 @@ getModuleModTime = onExistingFileDo getModificationTime findFileInPath :: String -> [String] -> IO [String]-findFileInPath fn p = do+findFileInPath fn path = do if any isPathSeparator fn then findFile fn else do- let fs = nubBy equalFilePath $ map (++fn) p+ 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'- return [ fn' | ex ]+ doesExist fn = do ex <- doesFileExist fn + if ex then return [fn] else return []
src/Names.hs view
@@ -20,11 +20,10 @@ constructorName = preludeConstructorName -consName extFuncs (m,n) = +consName (m,n) = case m of- "Prelude" -> (dataDefMod extFuncs m,preludeConstructorName n) "" -> ("",preludeConstructorName n)- _ -> (dataDefMod extFuncs m,constructorName n)+ _ -> (modName m,constructorName n) {-@@ -36,18 +35,9 @@ datamod = if elem (m,n) exts then extDataModName else dataModName -} -dataDefMod :: Bool -> String -> String-dataDefMod False = modName-dataDefMod True = instModName---- function names-preludeFunctionName s@"share" = s-preludeFunctionName n = functionName n- functionName n | isInfixOpName n = elimInfix n | otherwise = 'c':'_':n -funName (p@"Prelude",n) = (modName p,preludeFunctionName n) funName (m,n) = (modName m,functionName n) elimInfix name = "op_"++concat (intersperse "_" (map (show . ord) name))@@ -60,40 +50,14 @@ insertName :: String -> FilePath -> FilePath insertName s xs = replaceFileName xs (s++takeFileName xs) -modName s = insertName "Curry" s--dataMName = "Data"-instMName = "Instances"-funcMName = "Functions"-dbgMName = "Oracle"--external = insertName "External"+modName s = insertName "Curry.Module." s+funcHsName s = replaceExtension s ".hs" -extDataMName = external dataMName-extInstMName = external instMName-extFuncMName = external funcMName+externalSpecName s = replaceExtension s ".hs.include" -dataModName = insertName dataMName -instModName = insertName instMName -funcModName = insertName funcMName +dbgMName = "Oracle" dbgModName = insertName dbgMName--extDataModName = insertName extDataMName -extInstModName = insertName extInstMName -extFuncModName = insertName extFuncMName --dataHsName s = replaceExtension (dataModName s) ".hs"-instHsName s = replaceExtension (instModName s) ".hs"-funcHsName s = replaceExtension (modName s) ".hs"--extDataHsName s = replaceExtension (extDataModName s) ".hs"-extInstHsName s = replaceExtension (extInstModName s) ".hs"-extFuncHsName s = replaceExtension (extFuncModName s) ".hs"--externalSpecName s = replaceExtension (external s) ".spec"- strictPrefix = "S"- mkStrictName = insertName strictPrefix
src/PreTrans.hs view
@@ -5,32 +5,38 @@ module PreTrans where +import MetaProgramming.FlatCurry+import MetaProgramming.FlatCurryGoodies import Maybe import List hiding (nub) -import Curry.Base.Position(noRef)--import Curry.ExtendedFlat.Type-import Curry.ExtendedFlat.Goodies--+#if __GLASGOW_HASKELL__ >= 604+import qualified Data.Map as FM +myFromList = FM.fromList+myLookup = FM.lookup+myMember = FM.member -import qualified Data.Map as FM+#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 :: Ord k => (a -> Bool) -> (FuncDecl -> (k, a)) -> [Prog] -> FM.Map k a-transFM p f ps = FM.fromList (filter (p . snd) (map f (allFuncs ps)))+transFM p f ps = myFromList (filter (p . snd) (map f (allFuncs ps))) +funcDecls (Prog _ _ _ fs _) = fs -allFuncs :: [Prog] -> [FuncDecl]-allFuncs ps = concatMap progFuncs ps+allFuncs ps = concatMap funcDecls ps --- compute number of arguments by function type typeArity :: TypeExpr -> Int@@ -39,11 +45,8 @@ typeArity (FuncType _ t2) = 1+typeArity t2 --- FIXME stupid-maxL :: (Num a, Ord a) => [a] -> a maxL = foldl max 0 - --- is root type constructor IO? isIOType :: TypeExpr -> Bool isIOType = trTypeExpr (const False) (\ q _ -> q==(pre "IO")) (\ _ _ -> False)@@ -58,18 +61,17 @@ noCCase :: Expr -> Expr noCCase = trExpr Var Lit Comb Let Free Or noCCaseExpr noCCaseBr -noCCaseExpr :: SrcRef -> CaseType -> Expr -> [Expr -> Either (Expr,Expr) BranchExpr] -> Expr-noCCaseExpr pos ct v bs = - either (foldr ifte (Comb FuncCall (pre "failed") [])) (Case pos ct v) (lrs (map ($ v) bs))+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)- -- FIXME Patterns not matched: [] ifte (b,e1) e2 = Comb FuncCall (pre "if_then_else") [b,e1,e2] noCCaseBr :: Pattern -> Expr -> Expr -> Either (Expr,Expr) BranchExpr-noCCaseBr (LPattern c@(Charc _ _)) e v = +noCCaseBr p@(LPattern c@(Charc _)) e v = Left (Comb FuncCall (pre "===") [v,Lit c],e) noCCaseBr p e _ = Right (Branch p e) @@ -81,7 +83,7 @@ liftCases :: Bool -> Prog -> Prog liftCases nestedOnly p = let fs = progFuncs p- aux = genAuxName (map (localName . funcName) fs)+ aux = genAuxName (map (snd . funcName) fs) (exts,ins) = partition isExternal fs (newFsf,_,auxFf) = foldr (liftCasesFunc nestedOnly (progName p) aux) (id,0,id) @@ -99,11 +101,11 @@ (exp,i',ffe,_) = if onlyNested then (case body of- Case p cm e@(Var _) bs -> + 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 p cm e' bs', i'',ffe . ffbs,[])+ in (Case cm e' bs', i'',ffe . ffbs,[]) _ -> trans body i0) else trans body i0 @@ -123,22 +125,21 @@ 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+ let ([e1',e2'],i',ff,vs) = fold i [e1,e2]+ in (Or e1' e2',i',ff,vs)+ casE ct e bs i = + let (e',i',ffe,ve) = e i (bs',i'',ffbs,vbs) = fold i' bs envRes = nub (ve ++ vbs) env = case e' of Var v -> delete v envRes _ -> envRes- in (genFuncCall (localName $ funcName f) mod aux i'' env e',i''+1,- (genFunc (localName $ funcName f) mod aux i'' env e' ct bs':) . ffe' . ffbs,+ 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)-+ 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,[])@@ -146,24 +147,21 @@ once f (es,j,ff1,vs1) = let (e,k,ff2,vs2) = f j in (e:es,k,ff1 . ff2,vs1++vs2) - genFuncCall :: String -> String -> String -> Int -> [VarIndex] -> Expr -> Expr-genFuncCall f m aux i env e = - Comb FuncCall (mkQName (m, f++aux++show i)) (map Var env ++ [e])-+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 m aux i env e ct bs = - Func (mkQName (m, f++aux++show i)) (length env+1) Private (TVar (-42)) $- Rule (env++[v]) (Case noRef ct (Var v) bs)+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 :: [VarIndex] -> Pattern -> [VarIndex]+removePVars :: [Int] -> Pattern -> [Int] removePVars e = trPattern (\ _ vs -> filter (not . elemOf vs) e) (const e) genAuxName :: [String] -> String@@ -172,27 +170,20 @@ addUnderscores :: String -> String -> String addUnderscores n m = if isPrefixOf n m then addUnderscores (n++"_") m else n -elemOf :: Eq a => [a] -> a -> Bool elemOf = flip elem -nub :: Ord k => [k] -> [k] nub xs = map fst $ FM.toList $ FM.fromList $ zip xs (repeat ()) ------------------------------------------------------------ -- elimination of constants ------------------------------------------------------------ -externalConstants :: [QName]-externalConstants = map (curry mkQName "Prelude") ["success","failed"] ++- map (curry mkQName "IO") ["stdin","stdout","stderr"]-+externalConstants = map ((,) "Prelude") ["success","failed"] +++ map ((,) "IO") ["stdin","stdout","stderr"] -isToElim :: Rule -> TypeExpr -> Bool isToElim (Rule _ _) t = typeArity t==0 && t /= TVar (-42) isToElim (External _) _ = False --mapExp :: (Expr -> Expr) -> Expr -> Expr mapExp f (Var i) = f (Var i) mapExp f (Lit l) = f (Lit l) mapExp f (Comb ct n es) = f (Comb ct n (map (mapExp f) es))@@ -200,21 +191,18 @@ Let (zip vs (map (mapExp f) bs)) (mapExp f e) mapExp f (Free vs e) = Free vs (mapExp f e) mapExp f (Or e1 e2) = Or (mapExp f e1) (mapExp f e2)-mapExp f (Case pos ct e bs) = Case pos ct (mapExp f e) (map mbr bs)+mapExp f (Case ct e bs) = Case ct (mapExp f e) (map mbr bs) where mbr (Branch p be) = Branch p (mapExp f be)--- FIXME Patterns not matched: _ (TypedExpr _ _) --elimConsts :: [Prog] -> Prog -> Prog elimConsts interfaces p@(Prog pn is ts fs os) = Prog pn is ts (map elimConstsF fs) os where constsfm = transFM id ftypeArity (p:interfaces) - ftypeArity (Func mn _ _ t r) = (mn,isToElim r t)+ ftypeArity (Func mn@(m,n) _ _ t r) = (mn,isToElim r t) - elimConstsF f@(Func _ _ _ _ (External _)) = f+ 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) @@ -222,40 +210,31 @@ | otherwise = Func n a v t (Rule vs (mapExp elimConstsE e)) elimConstsE e = case e of- Comb FuncCall fn [] -> if FM.member fn constsfm+ Comb FuncCall fn [] -> if myMember fn constsfm then Comb FuncCall fn [unit] else e _ -> e --unit :: Expr unit = Comb ConsCall (pre "()") []--unitType :: TypeExpr unitType = TCons (pre "()") [] -pre :: String ->QName-pre s = mkQName ("Prelude",s)+pre s = ("Prelude",s) ------------------------------------------------------------ -- typing ambiguous type variables ------------------------------------------------------------ makeTypeMap :: [Prog] -> QName -> QName-makeTypeMap ps s = maybe (errorMsg s) id (FM.lookup s fm)+makeTypeMap ps s = maybe (errorMsg s) id (myLookup s fm) where- fm = FM.fromList (concatMap typeMapTypeDecl (concatMap typeDecls ps))- errorMsg qn = error ("PreTrans.makeTypeMap: cannot find type"++- " of constructor "++modName qn++"."++localName qn)-+ fm = myFromList (concatMap typeMapTypeDecl (concatMap typeDecls ps))+ errorMsg (m,n) = error ("PreTrans.makeTypeMap: cannot find type"+++ " of constructor "++m++"."++n) -typeMapTypeDecl :: TypeDecl -> [(QName, QName)] typeMapTypeDecl (TypeSyn _ _ _ _) = []-typeMapTypeDecl (Type tn _ _ consDecls) = - zip (map (\ (Cons name _ _ _) -> name) consDecls) (repeat tn)-+typeMapTypeDecl (Type typeName _ _ consDecls) = + zip (map (\ (Cons name _ _ _) -> name) consDecls) (repeat typeName) -typeDecls :: Prog -> [TypeDecl] typeDecls (Prog _ _ ts _ _) = ts ------------------------------------------------------------@@ -269,14 +248,13 @@ | otherwise = error $ "function global not allowed in this context " ++ show (map funcName (filter (not . okDef) gs)) where- (toTest,_) = partition (containsGlobal . resultType . funcType) + (toTest,noGlobal) = partition (containsGlobal . resultType . funcType) (progFuncs prog) (gs,fs) = partition isGlobalDecl (progFuncs prog) - isGlobal (TCons qn _)- | qnOf qn == ("Global","Global") = True- isGlobal _ = False+ isGlobal (TCons ("Global","Global") _) = True+ isGlobal _ = False isGlobalDecl f = isGlobal (funcType f) && isGlobalDef (funcBody f) @@ -284,9 +262,8 @@ containsGlobal t@(TCons _ args) = isGlobal t || any containsGlobal args containsGlobal (FuncType _ _) = False - isGlobalDef (Comb FuncCall qn _)- | qnOf qn == ("Global","global") = True- isGlobalDef _ = False+ isGlobalDef (Comb FuncCall ("Global","global") _) = True+ isGlobalDef _ = False okDef f | isGlobal (funcType f) && isGlobalDef (funcBody f) = @@ -294,11 +271,11 @@ | otherwise = noCallToGlobal (funcBody f) noCallToGlobal = trExpr (\_->True) (\_->True)- (\ _ n args -> qnOf n/=("Global","global") + (\ _ n args -> n/=("Global","global") && and args) (\bs e->and (e:map snd bs)) (\_ ->id) (&&)- (\_ _ e bs -> and (e:bs)) (\_->id)+ (\_ e bs -> and (e:bs)) (\_->id) isMonomorph :: TypeExpr -> Bool isMonomorph (TVar _) = False
src/SafeCalls.hs view
@@ -1,8 +1,7 @@ {-# OPTIONS -cpp #-} -module SafeCalls(SafeIO, safeSystem, safeIO, safeIOSeq, safe) where--import Control.Monad.Error+{-# LANGUAGE FlexibleInstances #-} +module SafeCalls where #if __GLASGOW_HASKELL__ >= 610 import Control.OldException @@ -17,29 +16,41 @@ -- safe calls -------------------- -type SafeIO = ErrorT String IO+data Safe m a = Safe (m (Maybe a)) -safeSystem :: Bool -> String -> SafeIO ()-safeSystem _ "" = return ()-safeSystem verbose sysCall = do- when verbose $ liftIO $ putStrLn sysCall- ec <- liftIO $ system sysCall- if ec==ExitSuccess then return () else fail ("safeSystem: "++show ec)+(>>+) :: (Monad m) => m (Maybe a) -> m (Maybe b) -> m (Maybe b)+m >>+ f = m >>=+ (\_ -> f) -safeIO :: IO a -> SafeIO a-safeIO action = foo (liftM Right action)+(>>=+) :: (Monad m) => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)+m >>=+ f = do + res <- m+ maybe (return Nothing) f res -safeIOSeq :: IO a -> SafeIO a-safeIOSeq action = foo (action >>= \x -> seq x (return (Right x)))+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) -foo :: IO (Either String a) -> SafeIO a-foo x = liftIO (catch x putErr) >>= either fail return+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 -safe :: SafeIO a -> IO (Either String a)-safe = runErrorT +safeIOSeq :: IO a -> Safe IO a+safeIOSeq action = Safe $ do+ catch (action >>= \x -> seq x (return (Just x)))+ putErr -putErr :: Show a => a -> IO (Either String b)-putErr e = putStrLn ("IO action failed: "++show e) >> - return (Left $ "SafeCalls.putErr: " ++ show e)+safe :: Safe m a -> m (Maybe a)+safe (Safe act) = act +putErr e = putStrLn ("IO action failed: "++show e) >> return Nothing
src/ShowFlatCurry.hs view
@@ -12,25 +12,21 @@ --- --- Note that the previously contained function "writeFLC" --- is no longer supported. Use Flat2Fcy.writeFCY instead---- and change file suffix into ".efc"!+--- and change file suffix into ".fcy"! --- --- @author Michael Hanus --- @version August 2005--- modified to support new ExtendedFlat format in August 2009 (Holger Siegel) ------------------------------------------------------------------------------ - module ShowFlatCurry(showFlatProg,showFlatType,showFlatFunc, showCurryType,showCurryExpr,showCurryId,showCurryVar) where +import MetaProgramming.FlatCurry import List import Char import Brace -import Curry.ExtendedFlat.Type-- --- Shows a FlatCurry program term as a string (with some pretty printing). showFlatProg :: Prog -> String showFlatProg (Prog modname imports types funcs ops) =@@ -39,8 +35,6 @@ ++ concatMap showFlatType types ++ concatMap showFlatFunc funcs --showFlatVisibility :: Visibility -> [Char] showFlatVisibility Public = " Public " showFlatVisibility Private = " Private " @@ -48,39 +42,33 @@ showFlatFixity InfixlOp = " InfixlOp " showFlatFixity InfixrOp = " InfixrOp " -showFlatOp :: OpDecl -> [Char] showFlatOp (Op name fix prec) = "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" showFlatType :: TypeDecl -> String-showFlatType (Type qn _ tpars []) = - "\ndata " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " external"-showFlatType (Type qn _ tpars consdecls) =- "\ndata " ++ localName qn +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 qn _ tpars texp) =- "\ntype " ++ localName qn ++ brace " " "" " " (map showTypeVar tpars) ++ " = "- ++ showCurryType localName False texp -+showFlatType (TypeSyn (_,name) vis tpars texp) =+ "\ntype " ++ name ++ brace " " "" " " (map showTypeVar tpars) ++ " = "+ ++ showCurryType snd False texp -showCurryCons :: ConsDecl -> [Char]-showCurryCons (Cons qn _ _ types) =- localName qn ++ brace " " "" " " (map (showCurryType localName True) types)+showCurryCons (Cons (_,cname) arity vis types) =+ cname ++ brace " " "" " " (map (showCurryType snd True) types) showFlatFunc :: FuncDecl -> String-showFlatFunc (Func qn _ _ ftype _) =- '\n':localName qn++" :: "++showCurryType localName False ftype+showFlatFunc (Func (_,name) arity vis ftype rl) =+ '\n':name++" :: "++showCurryType snd False ftype -showFlatRule :: Rule -> [Char] showFlatRule (Rule params expr) = " (Rule " ++ showFlatList show params ++ showFlatExpr expr ++ ")" showFlatRule (External name) = " (External " ++ show name ++ ")" --showFlatTypeExpr :: TypeExpr -> String showFlatTypeExpr (FuncType t1 t2) = "(FuncType " ++ showFlatTypeExpr t1 ++ " " ++ showFlatTypeExpr t2 ++ ")" showFlatTypeExpr (TCons tc ts) =@@ -89,14 +77,11 @@ showFlatTypeExpr (TVar n) = "(TVar " ++ show n ++ ")" -showFlatCombType :: CombType -> String showFlatCombType FuncCall = "FuncCall" showFlatCombType ConsCall = "ConsCall" showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" --showFlatExpr :: Expr -> String showFlatExpr (Var n) = "(Var " ++ show n ++ ")" showFlatExpr (Lit l) = "(Lit " ++ showFlatLit l ++ ")" showFlatExpr (Comb ctype cf es) =@@ -109,26 +94,21 @@ "(Free " ++ showFlatList show xs ++ showFlatExpr e ++ ")" showFlatExpr (Or e1 e2) = "(Or " ++ showFlatExpr e1 ++ " " ++ showFlatExpr e2 ++ ")"-showFlatExpr (Case _ Rigid e bs) =+showFlatExpr (Case Rigid e bs) = "(Case Rigid " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")"-showFlatExpr (Case _ Flex e bs) =+showFlatExpr (Case Flex e bs) = "(Case Flex " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" --showFlatLit :: Literal -> String-showFlatLit (Intc _ i) = "(Intc " ++ show i ++ ")"-showFlatLit (Floatc _ f) = "(Floatc " ++ show f ++ ")"-showFlatLit (Charc _ c) =+showFlatLit (Intc i) = "(Intc " ++ show i ++ ")"+showFlatLit (Floatc f) = "(Floatc " ++ show f ++ ")"+showFlatLit (Charc c) = if ord c >= 32 && ord c < 127 then "(Charc '" ++ [c] ++ "')" else "(Charc (chr " ++ show (ord c) ++ "))" -showFlatBranch :: BranchExpr -> String showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p ++ showFlatExpr e ++ ")" --showFlatPattern :: Pattern -> String showFlatPattern (Pattern qn xs) = "(Pattern " ++ show qn ++ showFlatList show xs ++ ")"@@ -152,10 +132,10 @@ --- @param texpr - the FlatCurry type expression to be formatted --- @return the String representation of the formatted type expression -showTypeVar :: Int -> String+ showTypeVar i = if i<27 then [chr (97+i)] else 't':show i -showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String+showCurryType :: ((String,String) -> String) -> Bool -> TypeExpr -> String showCurryType _ _ (TVar i) = showTypeVar i showCurryType tf nested (FuncType t1 t2) =@@ -163,17 +143,15 @@ (showCurryType tf (isFuncType t1) t1 ++ " -> " ++ showCurryType tf False t2) showCurryType tf nested (TCons tc ts)- | ts==[] = tf tc- | qnOf tc==("Prelude","[]")- = "[" ++ showCurryType tf False (head ts) ++ "]" -- list type- | "(," `isPrefixOf` localName tc -- tuple type- = "(" ++ concat (intersperse "," (map (showCurryType tf False) ts)) ++ ")"- | otherwise- = showBracketsIf nested- (tf tc ++ concatMap (\t->' ':showCurryType tf True t) ts)-+ | 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 :: TypeExpr -> Bool isFuncType (TVar _) = False isFuncType (FuncType _ _) = True isFuncType (TCons _ _) = False@@ -189,7 +167,7 @@ --- @param expr - the FlatCurry expression to be formatted --- @return the String representation of the formatted expression -showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String+showCurryExpr :: ((String,String) -> String) -> Bool -> Int -> Expr -> String showCurryExpr _ _ _ (Var n) = showCurryVar n @@ -200,10 +178,10 @@ showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryExpr tf True b e) showCurryExpr tf nested b (Comb ct cf [e1,e2])- | qnOf cf==("Prelude","apply")+ | cf==("Prelude","apply") = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2)- | isAlpha (head (localName cf))+ | isAlpha (head (snd cf)) = showBracketsIf nested (tf cf ++" "++ showCurryElems (showCurryExpr tf True b) [e1,e2]) | isFiniteList (Comb ct cf [e1,e2])@@ -212,7 +190,7 @@ else "[" ++ concat (intersperse "," (showCurryFiniteList tf b (Comb ct cf [e1,e2]))) ++ "]"- | localName cf == "(,)" -- pair constructor?+ | snd cf == "(,)" -- pair constructor? = "(" ++ showCurryExpr tf False b e1 ++ "," ++ showCurryExpr tf False b e2 ++ ")" | otherwise@@ -220,13 +198,13 @@ (showCurryExpr tf True b e1 ++ " " ++ tf cf ++ " " ++ showCurryExpr tf True b e2 ) showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es))- | qnOf cf==("Prelude","if_then_else") && es==[]+ | cf==("Prelude","if_then_else") && es==[] = showBracketsIf nested ("\n" ++ sceBlanks b ++ " if " ++ showCurryExpr tf False (b+2) e1 ++ "\n" ++ sceBlanks b ++ " then " ++ showCurryExpr tf False (b+2) e2 ++ "\n" ++ sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3)- | "(," `isPrefixOf` localName cf -- tuple constructor?+ | take 2 (snd cf) == "(," -- tuple constructor? = "(" ++ concat (intersperse "," (map (showCurryExpr tf False b) (e1:e2:e3:es))) ++ ")"@@ -235,11 +213,11 @@ (showCurryId (tf cf) ++ " " ++ showCurryElems (showCurryExpr tf True b) (e1:e2:e3:es)) -showCurryExpr tf nested b (Let bindings expr) =+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) expr)+ ("\n"++sceBlanks b++" in ") ++ showCurryExpr tf False (b+4) exp) showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e @@ -252,29 +230,24 @@ showBracketsIf nested (showCurryExpr tf True b e1 ++ " ? " ++ showCurryExpr tf True b e2) -showCurryExpr tf nested b (Case _ ctype e cs) =+showCurryExpr tf nested b (Case ctype e cs) = showBracketsIf nested ((if ctype==Rigid then "case " else "fcase ") ++ showCurryExpr tf True b e ++ " of\n " ++ showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b) -showCurryVar :: VarIndex -> String-showCurryVar i = "v" ++ show (idxOf i) +showCurryVar i = "v" ++ show i+ --- Shows an identifier in Curry form. Thus, operators are enclosed in brackets.-showCurryId :: String -> String showCurryId name | isAlpha (head name) = name | name == "[]" = name | otherwise = ('(':name)++")" --showCurryLit :: Literal -> String-showCurryLit (Intc _ i) = show i-showCurryLit (Floatc _ f) = show f-showCurryLit (Charc _ c) = show c-+showCurryLit (Intc i) = show i+showCurryLit (Floatc f) = show f+showCurryLit (Charc c) = show c -showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String showCurryCase tf b (Branch (Pattern l vs) e) = sceBlanks b ++ showPattern (tf l) vs ++ " -> " ++ showCurryExpr tf False b e ++ "\n"@@ -296,27 +269,16 @@ sceBlanks b ++ showCurryLit l ++ " " ++ " -> " ++ showCurryExpr tf False b e ++ "\n" --showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String]-showCurryFiniteList _ _ (Comb _ qn [])- | qnOf qn == ("Prelude","[]")- = []-showCurryFiniteList tf b (Comb _ qn [e1,e2])- | qnOf qn == ("Prelude",":")- = showCurryExpr tf False b e1 : showCurryFiniteList tf b e2+showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = []+showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) =+ showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 -- show a string constant-showCurryStringConstant :: Expr -> String-showCurryStringConstant (Comb _ qn [])- | qnOf qn == ("Prelude","[]")- = []-showCurryStringConstant (Comb _ qn [e1,e2])- | qnOf qn == ("Prelude",":")- = showCharExpr e1 ++ showCurryStringConstant e2+showCurryStringConstant (Comb _ ("Prelude","[]") []) = []+showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) =+ showCharExpr e1 ++ showCurryStringConstant e2 --- FIXME Pattern match(es) are non-exhaustive-showCharExpr :: Expr -> String-showCharExpr (Lit (Charc _ c))+showCharExpr (Lit (Charc c)) | c=='"' = "\\\"" | c=='\'' = "\\\'" | c=='\n' = "\\n"@@ -330,13 +292,8 @@ showCurryElems format elems = concat (intersperse " " (map format elems)) --showBracketsIf :: Bool -> String -> String-showBracketsIf True s ='(' : s ++ ")"-showBracketsIf False s = s- +showBracketsIf nested s = if nested then '(' : s ++ ")" else s -sceBlanks :: Int -> String sceBlanks b = take b (repeat ' ') -- Is the expression a finite list (with an empty list at the end)?@@ -344,29 +301,26 @@ isFiniteList (Var _) = False isFiniteList (Lit _) = False isFiniteList (Comb _ name args)- | qnOf name==("Prelude","[]") && args==[]- = True- | qnOf name==("Prelude",":") && length args == 2- = isFiniteList (args!!1)- | otherwise- = False+ | 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+isFiniteList (Case _ _ _) = False -- Is the expression a string constant? isStringConstant :: Expr -> Bool isStringConstant e = case e of- Comb _ name args -> (qnOf name==("Prelude","[]") && null args) ||- (qnOf name==("Prelude",":") && length args == 2 &&+ 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+ Lit (Charc _) -> True _ -> False
src/ShowFunctionalProg.hs view
@@ -17,7 +17,7 @@ -- in May 2007: -- - prettier representation of Curry and Haskell Strings -------------------------------------------------------------------------------module ShowFunctionalProg(showProg,showProgOpt,+module ShowFunctionalProg(showProg,showProgOpt,PrintOptions(..),defaultPrintOptions, showTypeDecls, showTypeDecl, showTypeExpr,@@ -25,53 +25,58 @@ showExpr,showPattern, isInfixOpName,isTuple) where -import Curry.ExtendedFlat.Type(QName(..), qnOf) import FunctionalProg-import Data.List-import Data.Char(ord)+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 Options = PrintOpt { unqual :: Bool,- sep :: String}+data PrintOptions = PrintOpt { unqual :: Bool,+ sep :: String,+ include :: String} -defaultOptions :: Options-defaultOptions = PrintOpt False ""+defaultPrintOptions :: PrintOptions+defaultPrintOptions = PrintOpt False "" "" --- Shows an AbstractCurry program in standard Curry syntax. showProg :: Prog -> String-showProg = showProgOpt (unqual defaultOptions)+showProg = showProgOpt defaultPrintOptions -showProgOpt :: Bool -> Prog -> String-showProgOpt uq (Prog m imps exps typedecls insdecls funcdecls opdecls)- = "module "++m++showExports m exps ++" where\n\n"- ++ showImports imps+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"- where- opts = defaultOptions{unqual=uq} + ----------------------------------------- -- export declaration ----------------------------------------- -showExports :: String -> [String] -> String-showExports m exps = brace " (" ")" ", " (("module "++m):exps)+showExports :: PrintOptions -> String -> [String] -> String+showExports _ m exports = brace " (" ")" ", " (("module "++m):exports) ----------------------------------------- -- import declaration ----------------------------------------- showImports :: [String] -> String-showImports imps = brace "" "\n\n" "\n" (map ("import "++) imps)+showImports imports = brace "" "\n\n" "\n" (map ("import "++) imports) ----------------------------------------- -- infix operators@@ -81,11 +86,8 @@ showOpDecls opdecls = brace "" "\n\n" "\n" (map showOpDecl opdecls) showOpDecl :: OpDecl -> String-showOpDecl (Op qn fixity precedence)- = separate " " [showFixity fixity,- show precedence,- '`':showIdentifier (localName qn) ++"`"]-+showOpDecl (Op (_,name) fixity precedence)+ = separate " " [showFixity fixity,show precedence,'`':showIdentifier name++"`"] showFixity :: Fixity -> String showFixity InfixOp = "infix"@@ -97,14 +99,14 @@ -------------------------------------------------- --- Shows a list of AbstractCurry type declarations in standard Curry syntax.-showTypeDecls :: Options -> [TypeDecl] -> String+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 :: Options -> TypeDecl -> String+showTypeDecl :: PrintOptions -> TypeDecl -> String showTypeDecl opts t = - decl ++ showIdentifier (localName (typeName t)) ++ + decl ++ showIdentifier (snd (typeName t)) ++ brace " " "" " " (map (showTypeExpr opts False . TVar) (typeVars t)) ++ " = "++ (case t of TypeSyn{typeExpr=e} -> showTypeExpr opts False e@@ -113,50 +115,46 @@ where decl = case t of {TypeSyn{} -> "type "; Type{} -> "data "} -showConsDecl :: Options -> ConsDecl -> String+showConsDecl :: PrintOptions -> ConsDecl -> String showConsDecl opts c = separate (if strictArgs c then " !" else " ") - (showIdentifier (localName (consName c)) : + (showIdentifier (snd (consName c)) : map (showTypeExpr opts True) (consArgs c)) -showInsDecls :: Options -> [InstanceDecl] -> String+showInsDecls :: PrintOptions -> [InstanceDecl] -> String showInsDecls opts is = brace "" "\n\n" "\n\n" (map (showInsDecl opts) is) -showInsDecl :: Options -> InstanceDecl -> String+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 :: Options -> [TypeClass] -> String showTypeConstr opts tcs = brace "(" ") => " "," (map (showTypeClass opts) tcs) --showTypeClass :: Options -> TypeClass -> String showTypeClass opts (TypeClass qn ts) - = localName qn ++ brace " " "" " " (map (showTypeExpr opts True) ts)+ = 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 :: Options -> Bool -> TypeExpr -> String+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 qn typelist) = +showTypeExpr opts nested (TCons (mod,name) typelist) = (if nested && not (null typelist) then brace "(" ")" else separate) ""- [showTypeCons opts qn typelist]+ [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 :: Options -> QName -> [TypeExpr] -> String-showTypeCons opts qn ts = - showSymbol opts qn ++ +showTypeCons :: PrintOptions -> String -> String -> [TypeExpr] -> String+showTypeCons opts mod name ts = + showSymbol opts (mod,name) ++ brace " " "" " " (map (showTypeExpr opts True) ts) @@ -166,10 +164,9 @@ ------------------------------------------ --- Shows an AbstractCurry function declaration in standard Curry syntax.-showFuncDecl :: FuncDecl -> String-showFuncDecl = showFuncDeclOpt defaultOptions+showFuncDecl = showFuncDeclOpt defaultPrintOptions -showFuncDeclOpt :: Options -> FuncDecl -> String+showFuncDeclOpt :: PrintOptions -> FuncDecl -> String showFuncDeclOpt opts f = maybe "" (\t->fname ++" :: "++ (showTypeExpr opts False t) ++ "\n") (funcType f) ++@@ -177,22 +174,22 @@ (brace (fname++" ") "\n\n" ("\n"++sep opts++fname++" ") . map (showRule opts)) (funcBody f) where- fname = showIdentifier (localName (funcName f))+ fname = showIdentifier (snd (funcName f)) -showRule :: Options -> Rule -> String+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 :: Options -> Rhs -> String+showRhs :: PrintOptions -> Rhs -> String showRhs opts (SimpleExpr e) = " = "++showExprOpt opts e showRhs opts (GuardedExpr gs) = brace "\n " "" "\n " (map (showGuard opts) gs) -showGuard :: Options -> (Expr,Expr) -> String+showGuard :: PrintOptions -> (Expr,Expr) -> String showGuard opts (g,r) = " | " ++ showExprOpt opts g ++ " = " ++ showExprOpt opts r -showLocalDecl :: Options -> LocalDecl -> String+showLocalDecl :: PrintOptions -> LocalDecl -> String showLocalDecl opts (LocalFunc funcdecl) = showFuncDeclOpt (opts{sep=" "}) funcdecl showLocalDecl opts (LocalPat pattern expr ls) = showPatternOpt opts pattern ++ " = " ++ showExprOpt opts expr ++@@ -215,7 +212,6 @@ | otherwise = let newName = normChars name in if head newName=='\'' then "c_"++newName else newName where- normChars :: String -> String normChars [] = [] normChars (c@'_':cs) = c:normChars cs normChars (c:cs) @@ -233,19 +229,17 @@ n9 = 57 --- Shows an AbstractCurry expression in standard Curry syntax.--showExpr :: Expr -> String-showExpr = showExprOpt defaultOptions+showExpr = showExprOpt defaultPrintOptions -showExprOpt :: Options -> Expr -> String+showExprOpt :: PrintOptions -> Expr -> String showExprOpt _ (Var name) = showIdentifier name showExprOpt _ (Lit lit) = showLiteral lit showExprOpt opts (Symbol name) = showSymbol opts name-showExprOpt opts e@(Apply func arg)- | Just cs <- expAsCurryString e = fromCurryString cs- | Just cl <- expAsCurryList e = fromCurryList cl- | Just hs <- expAsHaskellString e = fromHaskellString hs- | Just hl <- expAsHaskellList e = fromHaskellList hl+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)@@ -255,7 +249,6 @@ = "(fromHaskellList [" ++ concat (intersperse "," (map (showExprOpt opts) es)) ++ "])" - fromHaskellString :: String -> String fromHaskellString s = show s -- quotation marks and quoted special chars fromHaskellList es@@ -275,26 +268,22 @@ (map (showBranchExpr opts) branches) showExprOpt _ (String s) = '"':s++"\"" --" -showSymbol :: Options -> QName -> String-showSymbol _ qn- | modName qn == ""- = showIdentifier (localName qn)-showSymbol opts qn- | isInfixOpName (localName qn)- = brace "(" ")" "" [modName qn ++ "." ++ localName qn]- | not (unqual opts) || "External" `isPrefixOf` modName qn- = modName qn++"."++showIdentifier (localName qn)- | otherwise- = showIdentifier (localName qn)-+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 :: Options -> [Pattern] -> Expr -> String showLambda opts patts expr = brace "\\ " " -> " " " (map (showPatternOpt opts) patts) ++ showExprOpt opts expr -showStatement :: Options -> Statement -> String+showStatement :: PrintOptions -> Statement -> String showStatement opts (SExpr expr) = showExprOpt opts expr showStatement opts (SPat pattern expr) = showPatternOpt opts pattern ++ " <- " ++ showExprOpt opts expr@@ -303,44 +292,33 @@ -- try to transform expression into a non-empty Curry string expAsCurryString :: Expr -> Maybe String-expAsCurryString (Symbol qn) - | qnOf qn == ("CurryPrelude","List")- = Just ""-expAsCurryString (Apply (Apply (Symbol qn1)- (Apply (Symbol qn2)+expAsCurryString (Symbol ("CurryPrelude","List")) = Just ""+expAsCurryString (Apply (Apply (Symbol ("CurryPrelude",":<"))+ (Apply (Symbol ("CurryPrelude","C_Char")) (Lit (Charc c)))) cs)- | qnOf qn1 == ("CurryPrelude",":<") && qnOf qn2 == ("CurryPrelude","C_Char")- = Just (c:) `ap` expAsCurryString cs+ = Just (c:) `ap` expAsCurryString cs expAsCurryString _ = Nothing -- try to transform expression into a Curry list expAsCurryList :: Expr -> Maybe [Expr]-expAsCurryList (Symbol qn) - | qnOf qn == ("CurryPrelude","List")- = Just []-expAsCurryList (Apply (Apply (Symbol qn) x) xs)- | qnOf qn == ("CurryPrelude",":<")- = Just (x:) `ap` expAsCurryList xs+expAsCurryList (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 qn)- | qnOf qn == ("","[]")- = Just ""-expAsHaskellString (Apply (Apply (Symbol qn) (Lit (Charc c))) cs)- | qnOf qn == ("",":")- = Just (c:) `ap` expAsHaskellString cs+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 qn)- | qnOf qn == ("","[]") = Just []-expAsHaskellList (Apply (Apply (Symbol qn) x) xs)- | qnOf qn == ("",":")- = Just (x:) `ap` expAsHaskellList xs+expAsHaskellList (Symbol ("","[]")) = Just []+expAsHaskellList (Apply (Apply (Symbol ("",":")) x) xs)+ = Just (x:) `ap` expAsHaskellList xs expAsHaskellList _ = Nothing -------------------------------------------------------@@ -348,9 +326,9 @@ ------------------------------------------------------- showPattern :: Pattern -> String-showPattern = showPatternOpt defaultOptions+showPattern = showPatternOpt defaultPrintOptions -showPatternOpt :: Options -> Pattern -> String+showPatternOpt :: PrintOptions -> Pattern -> String showPatternOpt _ (PVar name) = showIdentifier name showPatternOpt _ (PLit lit) = showLiteral lit showPatternOpt opts (PComb name []) = showSymbol opts name @@ -359,7 +337,7 @@ showPatternOpt opts (AsPat v p) = showPatternOpt opts (PVar v)++"@"++showPatternOpt opts p -showBranchExpr :: Options -> BranchExpr -> String+showBranchExpr :: PrintOptions -> BranchExpr -> String showBranchExpr opts (Branch pattern expr) = showPatternOpt opts pattern ++ " -> " ++ showExprOpt opts expr @@ -386,8 +364,11 @@ isInfixOpName :: String -> Bool isInfixOpName = all (`elem` infixIDs) -isTuple :: String -> Bool-isTuple "" = False+isCFuncType t = case t of+ FuncType _ _ -> True+ _ -> False++isTuple [] = False isTuple (c:cs) = c=='(' && dropWhile (==',') cs == ")" ------------------------------------------------------------------------------
src/Simplification.hs view
@@ -3,14 +3,11 @@ import Prelude hiding ( or,fail,catch ) -import Data.Ord(comparing)-import Data.List ( sortBy, groupBy, partition )--import Curry.Base.Position(noRef)-import Curry.ExtendedFlat.Type-import Curry.ExtendedFlat.Goodies hiding ( freeVars )-import qualified Curry.ExtendedFlat.Goodies as FCG+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@@ -29,7 +26,7 @@ elimCase `or` propagate - next = mkIdx (1 + maxVarIndex (0:allVarsInProg prog))+ next = 1 + maxlist (0:allVarsInProg prog) rs = map rule (filter isInlined (preludeFuncs ++ progFuncs prog)) rule func = (funcName func, funcRule func)@@ -37,7 +34,7 @@ -- inline only flat constants and if_then_else isInlined func = not (isExternal func) &&- (qnOf(funcName func) == (preludeName,if_then_elseName) ||+ (funcName func == (preludeName,if_then_elseName) || isConstant (funcBody func) || isVar (funcBody func)) @@ -78,13 +75,13 @@ | otherwise = fail where lit = literal exp- Case _ ct e bs = exp+ Case ct e bs = exp isIntLit :: Literal -> Bool-isIntLit exp = case exp of Intc _ _ -> True; _ -> False+isIntLit exp = case exp of Intc _ -> True; _ -> False intLitToCons :: Literal -> Expr-intLitToCons (Intc _ n) = int_ (intToInt' n)+intLitToCons (Intc n) = int_ (intToInt' n) isIntPattern :: Pattern -> Bool isIntPattern pat = not (isConsPattern pat) && isIntLit (patLiteral pat)@@ -92,7 +89,7 @@ nestedBranch :: BranchExpr -> ([Expr],Expr) nestedBranch (Branch pat exp) = case patExpr pat of- Lit (Intc _ n) -> ([int_ (intToInt' n)], exp)+ Lit (Intc n) -> ([int_ (intToInt' n)], exp) pexp -> ([pexp], exp) -- flattens a case expression.@@ -106,12 +103,12 @@ | all isVar pats = flatCase ct es (map replaceVar bs) err | not (null bs) && all isConsCall pats- = liftSimp (Case noRef ct e) (mapSimp branch groupedBs)+ = 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 compare (combName . 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)@@ -137,12 +134,12 @@ isFailBranch = isFailed . branchExpr isFailed :: Expr -> Bool-isFailed exp = isFuncCall exp && qnOf (combName exp) == (preludeName,failedName)+isFailed exp = isFuncCall exp && combName exp == (preludeName,failedName) replaceBranches :: Expr -> [BranchExpr] -> Expr-replaceBranches (Case p ct e _) bs+replaceBranches (Case ct e _) bs | null bs = failed_- | otherwise = Case p ct e bs+ | otherwise = Case ct e bs -- elimination of case applied to constructor terms@@ -195,8 +192,8 @@ Let bs e -> let (xs,es) = unzip bs in (e:es, \ (e:es) -> Let (zip xs es) e) Free xs e -> ([e], \ [e] -> Free xs e) Or e1 e2 -> ([e1,e2], \ [e1,e2] -> Or e1 e2)- Case p ct e bs -> let (ps,es) = unzip (map branch bs)- in (e:es, \ (e:es) -> Case p ct e (zipWith Branch ps es))+ 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)@@ -221,7 +218,16 @@ 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@@ -231,17 +237,17 @@ failedName = "failed" failed_ :: Expr-failed_ = Comb FuncCall (mkQName (preludeName,failedName)) []+failed_ = Comb FuncCall (preludeName,failedName) [] -zero_ = Comb ConsCall (mkQName (preludeName, "Zero")) []-pos_ n = Comb ConsCall (mkQName (preludeName, "Pos")) [n]-neg_ n = Comb ConsCall (mkQName (preludeName, "Neg")) [n]+zero_ = Comb ConsCall (preludeName, "Zero") []+pos_ n = Comb ConsCall (preludeName, "Pos") [n]+neg_ n = Comb ConsCall (preludeName, "Neg") [n] -iHi_ = Comb ConsCall (mkQName (preludeName, "IHi")) []-o_ n = Comb ConsCall (mkQName (preludeName, "O")) [n]-i_ n = Comb ConsCall (mkQName (preludeName, "I")) [n]+iHi_ = Comb ConsCall (preludeName, "IHi") []+o_ n = Comb ConsCall (preludeName, "O") [n]+i_ n = Comb ConsCall (preludeName, "I") [n] -x ?~ y = Comb FuncCall (mkQName (preludeName, "?")) [x,y]+x ?~ y = Comb FuncCall (preludeName, "?") [x,y] int_ :: Int' -> Expr int_ = foldChildren tInt tNat intExp natExp@@ -286,7 +292,7 @@ (Let bs _,_) -> concatMap ( $ filter (not . (`elem` map fst bs)) scope) cs (Free vs _,[e]) -> e (filter (not . (`elem` vs)) scope)- (Case _ _ _ bs,e:es) ->+ (Case _ _ bs,e:es) -> e scope ++ concat (zipWith (scopeBranch scope) bs es) _ -> concatMap ( $ scope) cs @@ -304,14 +310,14 @@ | isVar exp = fromEnv [] (varNr exp) env | isLet exp = mapChildren tExpr (replace (removeLetBinds exp env)) exp | isFree exp = mapChildren tExpr (replace (remove (FCG.freeVars exp) env)) exp- | isCase exp = let Case p ct e bs = exp- in Case p ct (replace env e) (map (replaceBranch env) bs)+ | 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 (mkQName ("Prelude","failed")) [] + Just (Var j) -> if elem j is then Comb FuncCall ("Prelude","failed") [] else fromEnv (j:is) j env Just e -> replace env e @@ -325,8 +331,9 @@ replaceBranch env b = mapChildren tBranchExpr (replace (remove (patArgs (branchPattern b)) env)) b -maxVarIndex :: [VarIndex] -> Int-maxVarIndex vis = maximum (0 : map idxOf vis)+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@@ -429,7 +436,7 @@ type Rules = [(QName,Rule)] type Simp a = VarIndex -> Rules -> Maybe (a,VarIndex) -runSimp :: VarIndex -> Rules -> Simp a -> a+runSimp :: Int -> Rules -> Simp a -> a runSimp n rs o = maybe (error "Simplification.runSimp: simplification fails") fst (o n rs) @@ -468,9 +475,9 @@ where defRule (Rule args body) = let arity = length args- args' = map mkIdx (take arity [idxOf n ..])+ args' = take arity [n ..] in Just (Rule args' (replace (zip args (map Var args')) body)- ,incVarIndex n arity)+ ,n+arity) defRule (External _) = Nothing sequenceSimp :: [Simp a] -> Simp [a]
src/kics.hs view
@@ -14,7 +14,7 @@ then usage "no file to compile" else do safe (startCompilation opts) >>=- either (\msg -> error $ "error during compilaton: " ++ msg) (\_ -> return ())+ maybe (error "error during compilaton") (\_ -> return ()) let call = ghcCall opts{filename=inKicsSubdir "Main.hs"} if executable opts then do
src/kicsi.hs view
@@ -12,9 +12,8 @@ import CurryToHaskell import SafeCalls--import Curry.ExtendedFlat.Type-import Curry.ExtendedFlat.Goodies+import MetaProgramming.FlatCurry+import MetaProgramming.FlatCurryGoodies import ShowFlatCurry import Config import Names@@ -258,12 +257,10 @@ t <- (safe $ do genReqModule (loadedFiles state) expr cymake (opts{filename=reqModuleName})- mp <- safeIO (readFlatCurry reqModuleFile)- let p = fromJust mp- let (f:_) = filter ((==mainExpr) . localName . funcName) (progFuncs p)+ p <- safeIO (readFlatCurry reqModuleFile)+ let (f:_) = filter ((==mainExpr) . snd . funcName) (progFuncs p) return (funcType f))- either (\msg -> putStrLn ("caught error in kicsi.hs: "++msg))- (putStrLn . showCurryType localName False) t+ maybe (return ()) (putStrLn . showCurryType snd False) t interactive state opts load [] state opts = interactive state opts@@ -287,7 +284,7 @@ let ls = loadedFiles state mainMod = if null ls then "Prelude" else head ls --safeSystem (verbosity opts >= 5) - -- ("rm -f request Request.efc "++reqMod ++".o ") + -- ("rm -f request Request.fcy "++reqMod ++".o ") requestFile <- genReqModule (loadedFiles state) line let compileOpts = (opts{executable=True,filename=requestFile, mainFunc=mainExpr,@@ -338,11 +335,11 @@ requestCall state _ = (inKicsSubdir "request"++" "++cmdLineArgs state++" +RTS "++rts state) reqModuleName = "Request"-reqModuleFile = replaceExtension (inKicsSubdir reqModuleName) ".efc"+reqModuleFile = replaceExtension (inKicsSubdir reqModuleName) ".fcy" genReqModule fs line = - safeIO (writeKicsFile (replaceExtension reqModuleName ".curry")- (imports fs++"\n\n"++mainExpr++" = "++ line))+ safeIO (writeKicsFile False (replaceExtension reqModuleName ".curry")+ (imports fs++"\n\n"++mainExpr++" = "++ line)) timing (State{time=True}) s = "time "++s timing _ s = s@@ -359,7 +356,7 @@ isExtAlpha '\'' = True isExtAlpha c = isDigit c || isAlpha c -reqMod = Names.modName reqModuleName+reqMod = modName reqModuleName imports :: [String] -> String imports = concatMap ("\nimport "++) @@ -379,7 +376,7 @@ \ run (S.strict_"++mainExpr++") \""++mod++"\"" --safeIO $ putStrLn modName --safeIO $ putStrLn modCont- safeIO (writeKicsFile modName modCont)+ safeIO (writeKicsFile False modName modCont)