diff --git a/KiCS.cabal b/KiCS.cabal --- a/KiCS.cabal +++ b/KiCS.cabal @@ -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 - diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 [definition|nodef] instances * -- extfunc -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' diff --git a/src/CurryToHaskell.hs b/src/CurryToHaskell.hs --- a/src/CurryToHaskell.hs +++ b/src/CurryToHaskell.hs @@ -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 "_" diff --git a/src/FunctionalProg.hs b/src/FunctionalProg.hs --- a/src/FunctionalProg.hs +++ b/src/FunctionalProg.hs @@ -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 diff --git a/src/KicsSubdir.hs b/src/KicsSubdir.hs --- a/src/KicsSubdir.hs +++ b/src/KicsSubdir.hs @@ -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 [] diff --git a/src/Names.hs b/src/Names.hs --- a/src/Names.hs +++ b/src/Names.hs @@ -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 diff --git a/src/PreTrans.hs b/src/PreTrans.hs --- a/src/PreTrans.hs +++ b/src/PreTrans.hs @@ -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 diff --git a/src/SafeCalls.hs b/src/SafeCalls.hs --- a/src/SafeCalls.hs +++ b/src/SafeCalls.hs @@ -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 diff --git a/src/ShowFlatCurry.hs b/src/ShowFlatCurry.hs --- a/src/ShowFlatCurry.hs +++ b/src/ShowFlatCurry.hs @@ -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 diff --git a/src/ShowFunctionalProg.hs b/src/ShowFunctionalProg.hs --- a/src/ShowFunctionalProg.hs +++ b/src/ShowFunctionalProg.hs @@ -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 == ")" ------------------------------------------------------------------------------ diff --git a/src/Simplification.hs b/src/Simplification.hs --- a/src/Simplification.hs +++ b/src/Simplification.hs @@ -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 Traversable 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] diff --git a/src/kics.hs b/src/kics.hs --- a/src/kics.hs +++ b/src/kics.hs @@ -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 diff --git a/src/kicsi.hs b/src/kicsi.hs --- a/src/kicsi.hs +++ b/src/kicsi.hs @@ -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)