module CurryToHaskell where import Control.Monad import Data.List import Data.Char import Data.Maybe import System import System.FilePath import Curry.ExtendedFlat.Type import Curry.ExtendedFlat.Goodies hiding (consName) import qualified FunctionalProg as C import ShowFunctionalProg import PreTrans hiding (nub,pre) import Simplification ( simplifyProg ) import SafeCalls import Brace import Config import Names (dataHsName,instHsName,funcHsName, extDataHsName,extInstHsName,extFuncHsName, extDataModName,extInstModName,extFuncModName, dataModName,instModName,modName,dbgModName, elimInfix,funName,functionName,constructorName) import qualified Names as N --import Debug.Trace --trace' x = trace (show x) x ------------------------------- -- main compilation routine ------------------------------- -- call this function to start compilation -- arguments: record of Type Options as defined -- in Config.hs startCompilations :: Options -> [String] -> IO [String] startCompilations _ [] = return [] startCompilations opts fs = compilations fs opts{done=[],mainModule=head fs} -- FIXME errors in retrieving options are silently ignored compilations :: [String] -> Options -> IO [String] compilations [] opts = return (done opts) compilations (f:fs) opts = safe (startCompilation opts{filename=f}) >>= compilations fs . either (const opts) id startCompilation :: Options -> SafeIO Options startCompilation opts = do put 2 opts "calling frontend" newOpts <- callFrontend opts visited <- compile newOpts >>= return . done put 2 opts "calling ghc" ghcProgram False newOpts (funcHsName (filename newOpts)) return newOpts{done=visited} -- compile not only returns the current Options -- but also a flag whether no significant changes -- have been made. A significant change forces -- recompilation of dependent modules. compile :: Options -> SafeIO Options compile opts = do newOpts <- getFlatCurryFileName opts old <- notUptodate newOpts if old || force opts || executable opts -- possible improvement: generate only Main.hs if up-to-date then process newOpts >>= makeImports else skip newOpts >>= makeImports process :: Options -> SafeIO (String,[String],Options) process opts0@(Opts{filename=fn}) = do prog <- safeReadFlat opts0 (replaceExtension fn ".efc") unless (executable opts0) (put 1 opts0 ("processing: "++progName prog)) opts <- readExternalSpec opts0 fn unless (null $ extData opts) (put 5 opts "external data declarations found") unless (null $ extInsts opts) (put 5 opts "external instance declarations found") unless (null $ extFuncs opts) (put 5 opts "external function declarations found") applyFlatTransformations opts prog >>= generateHaskellFiles opts return (progName prog,progImports prog,opts0) -- only read beginning of interface file, return name and list of imports skip :: Options -> SafeIO (String,[String],Options) skip opts = do let fname = if doNotUseInterface opts then replaceExtension (filename opts) ".efc" else replaceExtension (filename opts) ".fint" fn <- safeIO (findFileInPath fname (libpath opts)) >>= warning (filename opts) (cmdLibpath opts) cont <- safeIOSeq (readModule fn) let [("Prog",rest)] = lex cont [(name,rest')] = reads rest [(imps,_)] = reads rest' put 3 opts ("up-to-date: "++name) return (name,imps,opts) makeImports :: (String,[String],Options) -> SafeIO Options makeImports (name,imps,opts@(Opts{filename=fn})) = do impOpts <- foldCompile imps opts{executable=False} return impOpts{done=name : done impOpts} --------------------------------------------------------------------------------- -- sub routines of compilation --------------------------------------------------------------------------------- callFrontend opts@(Opts{filename=givenFile}) = do let lib = libpath opts foundCurry <- safeIO (findFileInPath (replaceExtension givenFile ".curry") lib) foundSources <- if null foundCurry then safeIO (findFileInPath (replaceExtension givenFile ".lcurry") lib) else return foundCurry unless (null foundSources) (if debug opts then prophecy opts else cymake opts) return (if debug opts then opts{filename=dbgModName givenFile} else opts) getFlatCurryFileName opts@(Opts{filename=basename}) = do let lib = libpath opts foundFiles <- safeIO (findFileInPath (replaceExtension basename ".efc") lib) foundFile <- warning basename (toPathList lib) foundFiles let foundBasename = dropExtensions foundFile return (opts{filename=foundBasename}) notUptodate opts@(Opts{filename=foundBasename}) = do tSource <- getModTime (replaceExtension foundBasename ".efc") tDestination <- getModTime (funcHsName foundBasename) return (tSource > tDestination) --applyFlatTransformations :: Options -> Prog -> ([FuncDecl], Prog, [Prog], ([Char], [Char])) applyFlatTransformations opts prog = do let auxNames = generateAuxNames (progFuncs prog) mexprog = if executable opts then addExec auxNames opts prog else Left prog exprog <- either return fail mexprog let suffix = flip replaceExtension $ if doNotUseInterface opts then ".efc" else ".fint" interfaces <- mapM (safeReadFlat opts . suffix) (progImports exprog) (globals,locProg) <- safeIOSeq (return (splitGlobals exprog)) let liftedProg = noCharCase (liftCases True (simplifyProg locProg)) --disAmb <- disambiguate interfaces ceprog unless (null globals) (put 5 opts ("module contains "++show (length globals) ++" global declarations")) return (globals,liftedProg,interfaces,auxNames) generateHaskellFiles opts (globals,prog,interfaces,auxNames) = do let typeMapping = makeTypeMap (prog:interfaces) modules = transform typeMapping auxNames opts prog put 3 opts "generating Haskell" mapM (writeProgram opts) (addGlobalDefs opts globals modules) return (haskellFiles opts (progName prog)) writeProgram opts (fn,printOpts,prog) = do put 3 opts ("writing "++inKicsSubdir fn) safeIO (writeKicsFile fn (showProgOpt printOpts prog)) put 3 opts (fn++" written") return fn ghcProgram skipping opts fn = unless (eval opts && executable opts) $ do found <- safeIO (findFileInPath fn (libpath opts)) let hsFile = head found ghc = safeSystem (verbosity opts >= 2) (ghcCall opts{make=True,filename=hsFile,target=""}) shFile = drop 2 (reverse hsFile) oFile = reverse ('o':shFile) hiFile = reverse ('i':'h':shFile) unless (null found) $ if skipping then do ex <- safeIO (mapM doesModuleExist [oFile,hiFile]) unless (and ex) ghc else ghc foldCompile :: [String] -> Options -> SafeIO Options foldCompile [] opts = return opts foldCompile (f:fs) opts | elem f (done opts) = foldCompile fs opts | otherwise = compile (opts{filename=f}) >>= foldCompile fs ------------------------------------------------------ -- auxiliary functions ------------------------------------------------------ -- names of all haskell files associated with program haskellFiles :: Options -> String -> [String] haskellFiles opts name = ifAdd (extData opts) (add [extDataHsName]) $ ifAdd (extInsts opts) (add [dataHsName,extInstHsName]) $ ifAdd (extFuncs opts) (add [instHsName,extFuncHsName]) $ add [funcHsName] [] where ifAdd (_:_) f ds = f ds ifAdd [] _ ds = ds add = foldr (\ f -> ((f name:) .)) id ------------------------------------------------------ -- basic transformation ------------------------------------------------------ -- for a given module up to three haskell modules are generated: -- one for the functions, -- one for the data declarations (possibly empty) -- one "Main"-module to generate executables, -- if the executable flag is set in the options -- introduce Modules CallTime/RunTimeChoice transform typeMapping aux opts0 (Prog name imports types funcs _) = (if executable opts then [(mainFileName,False,mainModule)] else []) ++ modules where opts = opts0{hasData=hasInternalData} hasExternalData = hasExtData opts hasExternalInstances = hasExtInsts opts hasExternalFuncs = hasExtFuncs opts hasInternalData = not $ null $ filter (not . isExternalType) types modules | not hasInternalData = [allinclusiveProg] | hasExternalInstances && hasExternalFuncs = [dataProg,instProg,funcProg] | hasExternalInstances = [dataProg,instFuncProg] | hasExternalFuncs = [dataInstProg,funcProg] | otherwise = [allinclusiveProg] -- filename, flag and module definitions dataProg = (dataHsName (filename opts),False,dataModule) instProg = (instHsName (filename opts),False,instModule) funcProg = (funcHsName (filename opts),False,funcModule) instFuncProg = (funcHsName (filename opts),False,instFuncModule) dataInstProg = (instHsName (filename opts),False,dataInstModule) allinclusiveProg = (funcHsName (filename opts),False,allinclusive) modul mName mImports mExports mTypes mInsts mFuncs = C.Prog mName mImports mExports mTypes mInsts mFuncs [] dataModule = modul dataName dataImports dataExports dataTypes [] [] instModule = modul instName instImports instExports [] instances [] funcModule = modul funcName funcImports funcExports [] [] functions instFuncModule = modul funcName instImports funcExports [] instances functions dataInstModule = modul instName dataImports dataExports dataTypes instances [] allinclusive = modul funcName allIImports allIExports dataTypes instances functions -- the module names are: dataName = dataModName name instName = instModName name funcName = N.modName name mainModuleName = "Main" -- the file names of these modules are: funcFileName = funcHsName (filename opts) dataFileName = dataHsName (filename opts) mainFileName = "Main.hs" -- import lists newImports = map N.modName imports allIImports = ["Curry"] ++ (if hasExternalData then [extDataModName name] else []) ++ (if hasExternalFuncs then [extFuncModName name] else []) ++ newImports dataImports | hasExternalData = "Curry" : (extDataModName name) : newImports | otherwise = "Curry" : newImports instImports = "Curry" : dataName : (extInstModName name) : newImports funcImports = "Curry" : instImportName : (extFuncModName name) : newImports -- this is the only special prelude treatment: instImportName | name=="Prelude" = instName ++ " hiding ("++opsUsedInInstances++")" | otherwise = instName opsUsedInInstances = "op_38_38" -- export lists allIExports = map ("module "++) $ (if hasExternalData then [extDataModName name] else []) ++ (if hasExternalFuncs then [extFuncModName name] else []) dataExports | hasExternalData = ["module "++extDataModName name] | otherwise = [] instExports = map ("module "++) [dataName,extInstModName name] funcExports = map ("module "++) [instName,extFuncModName name] -- the generated types, instances and functions dataTypes = map (transTypeDecl opts{consUse=DataDef}) (typeSyns++filter isToTransform typeDecls) instances = genInstances BaseCurry baseCurryInstance opts typeDecls ++ genInstances Curry curryInstance opts typeDecls ++ genInstances Show showInstance opts typeDecls ++ genInstances Read readInstance opts typeDecls functions = map (transFunc opts typeMapping) funcs mainModule = mainMod aux funcName opts -- information about original module (typeSyns,typeDecls) = partition isTypeSyn $ filter (\t-> not (elem (localName $ typeName t) (extData opts))) types isToTransform t = case lookup (localName $ typeName t) (extInsts opts) of Nothing -> True Just is -> not (elem Declaration is) -------------------------------------------------------- -- adding main function for executables -------------------------------------------------------- generateAuxNames fs = (genNewName "aux1" fns,genNewName "aux2" fns) where fns = map (localName . funcName) fs genNewName s ts = if elem s ts then genNewName ('a':s) ts else s mainMod (_,aux2) m opts = let aux = mkQName (m,localName (mkQName $ funName ("",aux2))) in C.Prog "Main" ["Curry",N.modName "Prelude",m] [] [] [] [C.Func (mkQName (m,"main")) public untyped (Just [C.Rule [] (noguard $ fapp (hasPresym ">>") [app (setProg opts) (C.String (mainModule opts)), app (C.Symbol (mkQName (N.modName "Prelude","curryIOVoid"))) (sym aux)]) []])] [] where setProg Opts{cm=OrBased} = cusym "setProgNameAndOrBased" setProg _ = cusym "setProgName" addExec (aux1,aux2) opts (Prog m is ts funcs ops) = case lookup (mainFunc opts) lfs of Just f@(Func n a vis t (Rule vs e)) | t == ioT unitT -> prog False [Func a2 0 vis t (Rule [] (flatApp n []))] | isIOType t -> prog True [Func a1 0 vis (monomorph t) (Rule [] (flatApp n [])), Func a2 0 vis (ioT unitT) (Rule [] (flatApp printIO [calla1 t True]))] | isFuncType t && not (debug opts) -- && not (isFuncType (range t))) -> Right (mainFunc opts++" is no constant") | debug opts -> prog False [Func a1 1 vis (monomorph t) (Rule [0] (flatApp n [Var 0])), Func a2 0 vis (ioT unitT) (Rule [] (calla1 t (isFuncType (range t) && isFuncType (range (range t)) && isIOType (range (range (range t))))))] | otherwise -> prog True [Func a1 0 vis (monomorph t) (Rule [] (flatApp n [])), Func a2 0 vis (ioT unitT) (Rule [] (flatBind (flatGst (calla1 t True)) (startFunc opts)))] _ -> Right (mainFunc opts++" undefined") where a1 = mkQName (m,aux1) a2 = mkQName (m,aux2) calla1 t orc = if debug opts then Comb FuncCall (mkQName ("Oracle","oracle"++if orc then "IO" else "") ) [Comb (FuncPartCall 1) a1 []] else Comb FuncCall a1 [] printIO = mkQName ("Interactive","printIO") lfs = zip (map (localName . funcName) funcs) funcs startFunc Opts{pm=Interactive DF} = ask ... df startFunc Opts{pm=Interactive BF} = ask ... bf startFunc Opts{pm=All DF} = pr ... df startFunc Opts{pm=All BF} = pr ... bf startFunc Opts{pm=First DF} = ap_ pr $ hd ... df startFunc Opts{pm=First BF} = ap_ pr $ hd ... bf startFunc Opts{pm=ST} = Comb (FuncPartCall 1) pr [] monomorph (TVar _) = unitT monomorph (TCons n args) = TCons n (map monomorph args) monomorph (FuncType t1 t2) = FuncType (monomorph t1) (monomorph t2) prog addInt fs = Left (Prog m (if addInt then "Interactive":is else is) ts (fs++funcs) ops) ask = mkQName ("Interactive","interactiveSols") df = mkQName ("Prelude","allValuesD") bf = mkQName ("Prelude","allValuesB") pr = mkQName ("Interactive","printTerm") hd = mkQName ("Prelude","head") f ... g = Comb FuncCall (flatPre ".") [Comb (FuncPartCall 1) f [],Comb (FuncPartCall 1) g []] ap_ f e = Comb FuncCall (flatPre ".") [Comb (FuncPartCall 1) f [],e] ------------------------------------------------------ -- transformation of type declarations ------------------------------------------------------ -- each type declaration has to derive instances for Show and Read -- moreover, new constructors for logical variables, ors and fails -- have to be added. transTypeDecl :: Options -> TypeDecl -> C.TypeDecl transTypeDecl opts (Type name vis vars consdecls) = C.Type (consName opts name) (transvis vis) (map (varName "t" . mkIdx) vars) (map (transConsdecls opts) consdecls ++ newConsDecls (consName opts name) vars) [] transTypeDecl opts (TypeSyn name vis vars t) = C.TypeSyn (consName opts name) (transvis vis) (map (varName "t" . mkIdx) vars) (transTypeExpr opts t) transConsdecls :: Options -> ConsDecl -> C.ConsDecl transConsdecls opts (Cons name arity vis ts) = C.Cons (consName opts name) arity (transvis vis) False (map (transTypeExprF opts) ts) transTypeExpr, transTypeExprF :: Options -> TypeExpr -> C.TypeExpr transTypeExpr _ (TVar n) = toTVar n transTypeExpr opts (FuncType t1 t2) = C.FuncType (transTypeExprF opts t1) (transTypeExpr opts t2) transTypeExpr opts (TCons name ts) = C.TCons (consName opts name) (map (transTypeExprF opts) ts) transTypeExprF _ (TVar n) = toTVar n transTypeExprF opts (FuncType t1 t2) = C.TCons (consName opts{extCons=True} (addPre "Prim")) [addStateType (C.FuncType (transTypeExprF opts t1) (transTypeExprF opts t2))] transTypeExprF opts (TCons name ts) = C.TCons (consName opts name) (map (transTypeExprF opts) ts) newConsDecls qn vs = [C.Cons qn{ localName = localName qn ++ "Fail"} 0 private False [tExceptions], C.Cons qn{ localName = localName qn ++ "Or"} 2 private False [tOrRef, tBranches newT]] where newT = C.TCons qn (map toTVar vs) ------------------------------------------- -- generating instances ------------------------------------------- inst newModName name vars classname = C.Instance (map (\v -> C.TypeClass (cu classname) [toTVar v]) vars) (C.TypeClass (cu classname) [C.TCons (mkQName (newModName,name)) (map toTVar vars)]) curryInstance opts t@(Type origName vis vars consdecls) = inst newModName name vars "Curry" [strEq,eq,propagate,foldCurry,typeName,showFunction True opts t] --toTerm,fromTerm where (newModName,name) = qnOf $ consName opts origName origMod = Curry.ExtendedFlat.Type.modName origName isPrelude = origMod=="Prelude" strEq = C.Func (mkQName (newModName,"strEq")) (transvis vis) untyped (Just (map strEqRule consdecls++ [C.Rule [_x,toPVar 0,_x] (noguard $ fapp (extInstPresym isPrelude "strEqFail") [fapp (extInstPresym isPrelude "typeName") [toVar 0]]) []])) strEqRule (Cons cname arity _ _) = rule [C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]), C.PComb (consName opts cname) (map (toPVar' "y" . mkIdx) [1..arity])] (noguard $ if arity==0 then (extInstPresym isPrelude "strEqSuccess") else foldr1 (\ e es -> fapp (extInstPresym isPrelude "concAnd") (addStateArg [e,es])) (map sEq [1..arity])) [] where sEq i = fapp (extInstPresym isPrelude "genStrEq") (addStateArg [toVar $ mkIdx i,toVar' "y" (mkIdx i)]) eq = C.Func (mkQName (newModName,"eq")) (transvis vis) untyped (Just (map eqRule consdecls ++otherwiseExp 3 (baseTypesym isPrelude "C_False"))) eqRule (Cons cname arity _ _) = rule [C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]), C.PComb (consName opts cname) (map (toPVar' "y" . mkIdx) [1..arity])] (noguard $ if arity==0 then baseTypesym isPrelude "C_True" else foldr1 (\ e es -> fapp (fbasesym opts "&&") (addStateArg [e,es])) (map eqArgs [1..arity])) [] where eqArgs i = fapp (extInstPresym isPrelude "genEq") (addStateArg [toVar $ mkIdx i,toVar' "y" (mkIdx i)]) propagate = C.Func (mkQName (newModName,"propagate")) (transvis vis) untyped (Just (map propRule consdecls)) propRule (Cons cname arity _ _) = C.Rule (addStatePat [C.PVar "f",C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])]) (noguard $ fapp (sym (consName opts cname)) (map propCall [1 .. arity])) [] where propCall i = fapp (C.Var "f") (addStateArg [toHInt (i-1),toVar $ mkIdx i]) foldCurry = C.Func (mkQName (newModName,"foldCurry")) (transvis vis) untyped (Just (map foldRule consdecls)) foldRule (Cons cname arity _ _) = C.Rule (addStatePat [C.PVar "f",C.PVar "c",C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])]) (noguard $ foldr appFold (C.Var "c") (map (toVar . mkIdx) [1 .. arity])) [] where appFold v e = fapp (C.Var "f") (addStateArg [v,e]) typeName = C.Func (mkQName (newModName,"typeName")) (transvis vis) untyped (Just [C.Rule [_x] (noguard $ C.String (localName origName)) []]) toTerm = C.Func (mkQName (newModName,"toC_Term")) (transvis vis) untyped (Just (map toTermRule (zip [1..] consdecls) ++ [C.Rule [_x,_x, C.PComb (mkQName (newModName,name++"FreeVar")) [C.PVar "r"]] (noguard $ app (baseTypesym isPrelude "C_Free") (app (c_int isPrelude) (app (hasPresym "toInteger") (C.Var "r")))) []])) toTermRule (nr,(Cons cname arity _ _)) = C.Rule [C.PVar "mode",C.PVar "store", C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])] (noguard $ fapp (baseTypesym isPrelude "C_Data") [toInt nr,c_string_ origMod (localName cname), dList isPrelude (map su [1..arity])]) [] where su i = fapp (basesym "ctcStore") [C.Var "mode",app (basesym "toC_Term") (C.Var "mode"), C.Var "store",toVar $ mkIdx i] fromTerm = C.Func (mkQName (newModName,"fromC_Term")) (transvis vis) untyped (Just (concatMap fromTermRule (zip [1..] consdecls) ++ [C.Rule [C.PComb (baseType isPrelude "C_Free") [C.PComb (baseType isPrelude "C_Int") [C.PVar "r"]]] (noguard $ app (sym (mkQName (newModName,name++"FreeVar"))) (app (hasPresym "fromInteger") (C.Var "r"))) []])) fromTermRule (nr,(Cons cname arity _ _)) = [rule "C_Data" [pnr,_x,pts], rule "C_Data" [pfree,pname,pts]] where pnr = toPInt opts nr pfree = C.PComb (baseType isPrelude "C_IntFreeVar") [_x] pname = dpList isPrelude (map (toPChar opts) (localName cname)) pts = dpList isPrelude (map (toPVar . mkIdx) [1..arity]) e = noguard $ fapp (sym (consName opts cname)) (map (app (basesym "fromC_Term") . toVar . mkIdx) [1..arity]) rule c args = C.Rule [C.PComb (baseType isPrelude c) args] e [] baseCurryInstance opts (Type origName vis vars consdecls) = inst newModName name vars "BaseCurry" [nf False, nf True, free "generator" "generator",failed,branching, consKind, exceptions,orRef,branches] where (newModName,name) = qnOf $ consName opts origName origMod = Curry.ExtendedFlat.Type.modName origName isPrelude = origMod=="Prelude" nf gr = C.Func (mkQName (newModName,if gr then "gnf" else "nf")) (transvis vis) untyped (Just (concatMap (nfrule gr) (filter ((1<=) . consArity) consdecls) ++ [C.Rule (addStatePat [C.PVar "f",C.PVar "x"]) (noguard (fapp (C.Var "f") (addStateArg [C.Var "x"]))) []])) nfrule gr (Cons cname arity _ _) = [C.Rule [C.PVar "f", C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity]), C.PVar "state0"] (noguard $ foldr (nflambda gr) (fapp (C.Var "f") [fapp (sym $ consName opts cname) (map (toVar' "v" . mkIdx) [1..arity]), toVar' "state" (mkIdx arity)]) (map mkIdx [1..arity])) []] nflambda gr i e = fapp (basesym (if gr then "gnfCTC" else "nfCTC")) [C.Lambda [toPVar' "v" i,toPVar' "state" i] e,toVar i,toVar' "state" (i-1)] free s t = C.Func (mkQName (newModName,s)) (transvis vis) untyped (Just [C.Rule [C.PVar "i"] (noguard $ fapp (basesym "withRef") [ C.Lambda [C.PVar "r"] $ fapp (sym (orName opts origName)) [fapp (basesym "mkRef") [C.Var "r",maxAr,C.Var "i"], list_ (map freeCons consdecls)], maxAr]) []]) where maxAr = C.Var (show (foldr max 0 (map consArity consdecls))) freeCons (Cons cname arity _ _) = fapp (sym (consName opts cname)) (snd $ foldr addOne (0,[]) (replicate arity (app (basesym t)))) addOne e (n,es) = (n+1,e (fapp (hasPresym "+") [C.Var "r",toHInt n]):es) failed = constructor "failed" failName freeVarFunc = constructor "freeVar" freeVarName branching = constructor "branching" orName suspend = constructor "suspend" suspName consKind = C.Func (mkQName (newModName,"consKind")) (transvis vis) untyped (Just (map tester [(orName, 2, "Branching"), (failName, 1, "Failed")] ++ [C.Rule [_x] (noguard $ (basesym "Val")) []])) tester (namer,arity,nameTest) = C.Rule [C.PComb (namer opts origName) (take arity (repeat (_x)))] (noguard (basesym nameTest)) [] selector nameSel namer arity number = C.Func (mkQName (newModName,nameSel)) (transvis vis) untyped (Just [C.Rule [C.PComb (namer opts origName) (underscores (number-1)++[C.PVar "x"]++ underscores (arity-number))] (noguard (C.Var "x")) []]) constructor nameConstr namer = C.Func (mkQName (newModName,nameConstr)) (transvis vis) untyped (Just [C.Rule [] (noguard $ sym (namer opts origName)) []]) exceptions = selector "exceptions" failName 1 1 freeVarRef = selector "freeVarRef" freeVarName 1 1 orRef = selector "orRef" orName 2 1 branches = selector "branches" orName 2 2 suspRef = selector "suspRef" suspName 2 1 suspCont = selector "suspCont" suspName 2 2 --------------------------------------------------------------------------- ------------------------------------------------------ -- transformation of functions and expressions ------------------------------------------------------ transFunc :: Options -> (QName -> QName) -> FuncDecl -> C.FuncDecl transFunc opts typeMapping (Func fname arity vis t (Rule lhs rhs)) = C.Func newFName (transvis vis) (transFType opts arity t) crules where newFName = mkQName $ funName $ qnOf fname f = mkQName (N.modName (Curry.ExtendedFlat.Type.modName fname),auxName $ localName newFName) trhs = transExpr opts rhs crules = case rhs of Case _ ct (Var n) bs -> Just (transBranching ct (break (==n) lhs) opts f typeMapping fname bs) Case _ _ _ _ -> error "case not normalized" _ -> Just [rule (map toPVar lhs) (noguard trhs) []] auxName name | isInfixOpName name = elimInfix name | otherwise = name transFunc opts _ (Func qn arity vis t (External _)) = C.Func (mkQName $ funName $ qnOf qn) (transvis vis) (transFType opts arity t) (Just [rule (map (toPVar . mkIdx) [1..arity]) (noguard (fapp (C.Symbol (mkQName (extFuncModName m,fname))) (addStateArg (map (toVar . mkIdx) [1..arity])))) []]) where (m, fname) = qnOf qn transFType :: Options -> Int -> TypeExpr -> Maybe C.TypeExpr -- the first line is for transformations too lazy to compute correct type transFType _ _ (TVar (-42)) = Nothing transFType opts arity t = Just $ C.TConstr [C.TypeClass c [toTVar tv] | tv <- nub (allVarsInTypeExpr t), c <- [mkQName ("Curry","Curry")]] (addStateType (transFTypeExpr opts arity t)) transFTypeExpr opts 0 t = transTypeExprF opts t transFTypeExpr opts (n+1) (FuncType t1 t2) = C.FuncType (transTypeExprF opts t1) (transFTypeExpr opts n t2) transvis x | x==Private = C.Private | x==Public = C.Public transExpr :: Options -> Expr -> C.Expr transExpr opts (Var n) = toVar n transExpr opts (Lit l) = transLit opts l transExpr opts (Free [] e) = transExpr opts e transExpr opts (Free (v:vs) e) = app freeCall (C.Lambda [toPVar v] (transExpr opts (Free vs e))) transExpr opts (Or e1 e2) = fapp orSym (map (transExpr opts) [e1, e2]) transExpr opts (Let vbs e) = C.LetDecl (map locdecl vbs) (transExpr opts e) where locdecl (v,b) = C.LocalPat (toPVar v) (transExpr opts b) [] transExpr opts (Comb FuncCall fn args) | qnOf fn == ("Global","global") = C.LetDecl [C.LocalPat (C.PVar "st") (hasPresym "Nothing") []] (fapp (C.Symbol (mkQName $ funName $ qnOf fn)) (map (transExpr opts) args)) transExpr opts (Comb combType fname args) = newExpr where newArgs = map (transExpr opts) args call = case combType of ConsCall -> symApp (consName opts fname) newArgs FuncCall -> symApp (mkQName $ funName $ qnOf fname) (addStateArg newArgs) FuncPartCall i -> symApp (mkQName $ funName $ qnOf fname) newArgs ConsPartCall i -> symApp (consName opts fname) newArgs symApp s xs = fapp (C.Symbol s) xs newExpr = case combType of ConsCall -> call FuncCall -> call FuncPartCall i -> pf opts i call ConsPartCall i -> pc opts i call transExpr _ (Case _ _ _ _) = error "unlifted case" transLit :: Options -> Literal -> C.Expr transLit opts (Charc _ c) = toChar opts c transLit opts (Floatc _ f) = toFloat opts f transLit opts (Intc _ i) = toInt i transBranching :: CaseType -> ([VarIndex],[VarIndex]) -> Options -> QName -> (QName -> QName) -> QName -> [BranchExpr] -> [C.Rule] transBranching caseMode vs@(as,v:bs) opts f tm oName branches = oldRules++newRules where oldRules = map (transRule vs opts) branches typeName = case (\ (Branch p _) -> p) (head branches) of Pattern c _ -> tm c LPattern l -> mkQName ("Prelude",case l of {Intc _ _->"Int";Charc _ _->"Char"}) freePat = C.AsPat "x" (C.PComb (freeVarName opts typeName) [C.PVar "ref"]) orPat = C.PComb (orName opts typeName) [C.PVar "i",C.PVar "xs"] suspPat = C.PComb (suspName opts typeName) [C.PVar "ref",C.PVar "susp"] isOracleMod = debug opts && "CurryOracle" `isPrefixOf` mname && length mname > 11 mname = Curry.ExtendedFlat.Type.modName f refVar = 1 --if null (as++bs) then error $ "where is the ref?" ++ show f -- else last (as++bs) applyf b = C.Lambda (addStatePat (if b then [toPVar refVar,C.PVar "x"] else [C.PVar "x"])) (fapp (sym f) (addStateArg (map toVar as ++ C.Var "x" : map toVar bs))) newLhs p e = rule (map toPVar as ++ (p:map toPVar bs)) e [] newRules = [newLhs orPat (noguard ((if isOracleMod then fapp (sym (mkQName (funName ("CEventOracle","onBranches")))) . (toVar refVar :) else fapp (cusym "mapOr")) (addStateArg [applyf isOracleMod, C.Var "i",C.Var "xs"]))) ,newLhs (C.PVar "x") (noguard $ (if isOracleMod then closeRef refVar else id) $ fapp (cusym "patternFail") [qname_ $ qnOf oName,C.Var "x"])] closeRef i e = fapp (sym $ mkQName $ funName ("CEventOracle","closeRef")) $ addStateArg [toVar i,e] transRule :: ([VarIndex],[VarIndex]) -> Options -> BranchExpr -> C.Rule transRule (as,v:bs) opts (Branch (LPattern l@(Charc _ _)) e) = rule ps (C.GuardedExpr [(guard,transExpr opts e)]) [] where guard = app (extInstPresym False "isC_True") (fapp (fbasesym opts "===") [toVar v,toLit opts l]) ps = map toPVar as ++ toPVar v : map toPVar bs transRule (as,v:bs) opts (Branch (LPattern l) e) = rule ps (noguard (transExpr opts e)) [] where ps = map toPVar as ++ C.AsPat (xvar v) (toPLit opts l) : map toPVar bs transRule (as,v:bs) opts (Branch (Pattern name args) e) = rule ps (noguard (transExpr opts e)) [] where ps = map toPVar as ++ (if elem v args then id else C.AsPat (xvar v)) (C.PComb (consName opts name) (map toPVar args)) : map toPVar bs rule ps = C.Rule (addStatePat ps) transOp (Op name InfixOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixOp p transOp (Op name InfixlOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixlOp p transOp (Op name InfixrOp p) = C.Op (mkQName $ funName $ qnOf name) C.InfixrOp p ---------------------------------------------------------------- -- generating instances for read and show ---------------------------------------------------------------- genInstances _ _ _ [] = [] genInstances cl genFunc opts (t:ts) | maybe False (elem cl) (lookup (localName $ typeName t) (extInsts opts)) = genInstances cl genFunc opts ts | otherwise = genFunc opts{consUse=InstanceDef} t : genInstances cl genFunc opts ts showInstance opts t@(Type origName vis vars consdecls) = C.Instance (map (\v -> C.TypeClass (has "Show") [toTVar v]) vars) (C.TypeClass (has "Show") [C.TCons (mkQName (newModName,name)) (map toTVar vars)]) [showFunction False opts t] where (newModName,name) = qnOf $ consName opts origName showFunction showQ opts t@(Type origName vis vars consdecls) | maybe False (elem Show) (lookup (localName $ typeName t) (extInsts opts)) = showsPrec [C.Rule [] (C.SimpleExpr (hasPresym "showsPrec")) []] | otherwise = showsPrec (map showsPrecRule consdecls ++[showGenerator]) where showParenArg qn = case localName qn of '(':_ -> hasPresym "True" _ | showQ -> hasPresym "True" | otherwise -> lt (C.Var "d") app_prec showsPrecName = if showQ then "showQ" else "showsPrec" showsPrecSym = (if showQ then extInstPresym (Curry.ExtendedFlat.Type.modName origName=="Prelude") else hasPresym) showsPrecName identifier qn = case localName qn of "()" -> "()" _ -> let (cm,cn) = qnOf qn in if showQ then cm++"."++cn else cn opening qn = case localName qn of '(':_ -> "" _ -> identifier qn ++ " " separator qn = case localName qn of '(':_ -> ',' _ -> ' ' showsPrec rs = C.Func (mkQName (newModName,showsPrecName)) (transvis vis) untyped (Just rs) (newModName,name) = qnOf $ consName opts origName showsPrecRule (Cons cname 0 _ []) = C.Rule [_x, C.PComb (consName opts cname) []] (C.SimpleExpr (app (hasPresym "showString") (string_ (identifier cname)))) [] showsPrecRule (Cons cname arity _ args) = C.Rule [C.PVar "d", C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])] (C.SimpleExpr (fapp (hasPresym "showParen") [showParenArg cname,sym (mkQName ("","showStr"))])) [C.LocalFunc (C.Func (mkQName ("","showStr")) (transvis vis) untyped (Just [C.Rule [] (C.SimpleExpr showStr) []]))] where showStr = points (app (hasPresym "showString") (string_ (opening cname)): intersperse (app (hasPresym "showChar") (char_ (separator cname))) (map (callShowsPrec . mkIdx) [1..arity])) callShowsPrec i = fapp showsPrecSym [add_prec cname,toVar i] points = foldr1 point point x y = fapp (hasPresym ".") [x,y] showTuple = C.Func (mkQName (newModName,showsPrecName)) (transvis vis) untyped (Just (map showTupleRule consdecls++[showGenerator])) showTupleRule (Cons cname arity _ args) = C.Rule [C.PVar "d", C.PComb (consName opts cname) (map (toPVar . mkIdx) [1..arity])] (C.SimpleExpr (app (hasPresym "showString") (app (hasPresym "show") (fapp (sym (mkQName ("",localName cname))) (map (toVar . mkIdx) [1..arity]))))) [] showGenerator = C.Rule [_x, C.PComb (mkQName (newModName,name++"Or")) [C.PVar "r",_x]] (C.SimpleExpr (app (hasPresym "showString") (cons_ (char_ '_') (app (hasPresym "show") (app (cusym "deref") (C.Var "r")))))) [] readInstance :: Config.Options -> TypeDecl -> C.InstanceDecl readInstance opts (Type origName vis vars consdecls) = C.Instance (map (\v -> C.TypeClass (has "Read") [toTVar v]) $ vars) (C.TypeClass (has "Read") [C.TCons c (map toTVar vars)]) [if isTuple (localName origName) then readTuple else readsPrec] where c = consName opts origName newModName = Curry.ExtendedFlat.Type.modName c readsPrec = C.Func (mkQName (newModName,"readsPrec")) (transvis vis) untyped (Just [C.Rule [C.PVar "d",C.PVar "r"] (C.SimpleExpr (plusplus (map read consdecls))) []]) plusplus = foldr1 (\x y->fapp (hasPresym "++") [x,y]) read cons@(Cons _ 0 _ []) = fapp (hasPresym "readParen") [hasPresym "False",lamb cons,C.Var "r"] read cons = fapp (hasPresym "readParen") [lt (C.Var "d") app_prec,lamb cons,C.Var "r"] lamb (Cons cn arity _ args) = C.Lambda [C.PVar "r"] (C.ListComp (fapp (sym (mkQName ("","(,)"))) [fapp (sym newC) (map (toVar . mkIdx) [1..arity]), toVar' "r" (mkIdx arity) ]) (C.SPat (pair (C.PVar "_") (toPVar' "r" 0)) (fapp (cusym "readQualified") [string_ (Curry.ExtendedFlat.Type.modName cn),string_ (localName cn),C.Var "r"]): map (readArg . mkIdx) [1..arity])) where newC = consName opts cn readArg i = C.SPat (pair (toPVar' "x" i) (toPVar' "r" i)) (fapp (hasPresym "readsPrec") [add_prec $ mkQName ("",""), toVar' "r" (i-1)]) readTuple = C.Func (mkQName (newModName,"readsPrec")) (transvis vis) untyped (Just (map readTupleRule consdecls)) readTupleRule (Cons t arity _ args) = C.Rule [C.PVar "d",C.PVar "r"] (C.SimpleExpr (fapp (hasPresym "map") [sym (mkQName ("","readTup")), fapp (hasPresym "readsPrec") [C.Var "d",C.Var "r"]])) [C.LocalFunc (C.Func (mkQName ("","readTup")) (transvis vis) untyped (Just [C.Rule [pair (C.PComb (mkQName ("",localName t)) (map (toPVar . mkIdx) [1..arity])) (C.PVar "s")] (C.SimpleExpr (fapp (sym (mkQName ("","(,)"))) [fapp (sym (consName opts t)) (map (toVar . mkIdx) [1..arity]), C.Var "s"])) []]))] pair x y = C.PComb (mkQName ("","(,)")) [x,y] add_prec qn = case localName qn of '(':_ -> cusym "zero" _ -> cusym "eleven" app_prec = cusym "ten" lt x y = fapp (hasPresym ">") [x,y] int i = app (hasPresym "fromInteger") (C.Lit (C.Intc i)) -------------------------- -- naming conventions -------------------------- consName,freeVarName,failName,orName,suspName :: Options -> QName -> QName consName opts qn | m/=currentModule opts = mkQName (N.modName m,cn) | dataDef && isExtDataName = mkQName (extDataModName m,cn) | dataDef && existsDataModule = mkQName (dataModName m,cn) | dataDef && existsInstModule = mkQName (instModName m,cn) | dataDef = mkQName (N.modName m,cn) | instDef && existsDataModule = mkQName (dataModName m,cn) | instDef && isExtDataName = mkQName (extDataModName m,cn) | instDef && existsInstModule = mkQName (instModName m,cn) | instDef = mkQName (N.modName m,cn) | funcDef && existsInstModule = mkQName (instModName m,cn) | funcDef && isExtDataName = mkQName (extDataModName m,cn) | funcDef = mkQName (N.modName m,cn) where m = Curry.ExtendedFlat.Type.modName qn n = localName qn existsDataModule = hasExtInsts opts existsInstModule = hasData opts && hasExtFuncs opts isExtDataName = elem n (extData opts) cn | extCons opts = n | otherwise = constructorName n instDef = consUse opts==InstanceDef funcDef = consUse opts==FunctionDef dataDef = consUse opts==DataDef -- FIXME N.freeVarName, failName, orName, suspName :: QName -> QName freeVarName opts = mkQName . N.freeVarName . qnOf . consName opts failName opts = mkQName . N.failName . qnOf . consName opts orName opts = mkQName . N.orName . qnOf . consName opts suspName opts = mkQName . N.suspName . qnOf . consName opts curryName s = mkQName ("Curry",s) curryTCons = C.TCons . curryName ---------------------------------------- -- treating the additional state argument ---------------------------------------- stateTypeName :: String stateTypeName = "State" addStateType :: C.TypeExpr -> C.TypeExpr addStateType t@(C.TVar _) = C.FuncType (curryTCons stateTypeName []) t addStateType t@(C.TCons _ _) = C.FuncType (curryTCons stateTypeName []) t addStateType (C.FuncType t1 t2) = C.FuncType t1 (addStateType t2) addStatePat :: [C.Pattern] -> [C.Pattern] addStatePat = (++[C.PVar "st"]) addStateArg :: [C.Expr] -> [C.Expr] addStateArg = (++[C.Var "st"]) -- global definitions must not have a state argument addGlobalDefs :: Options -> [FuncDecl] -> [(String,Bool,C.Prog)] -> [(String,Bool,C.Prog)] addGlobalDefs opts gs (x:xs@(_:_)) = x : addGlobalDefs opts gs xs addGlobalDefs opts gs [(s,b,prog)] = [(s,b,prog{C.funcDecls=gs'++C.funcDecls prog})] where gs' = map transformGlobal gs transformGlobal (Func n 0 vis t (Rule [] e)) = -- FIXME funName :: QName -> QName C.Func (mkQName $ funName $ qnOf n) (transvis vis) (transFType opts 0 t) (Just [C.Rule [] (C.SimpleExpr (transExpr opts e)) []]) ---------------------------------------------------------------- -- constants and abbreviations for flat, resp. abstract curry ---------------------------------------------------------------- part opts i e = if i<2 then primValue opts (C.Lambda (addStatePat [toPVar' "v" 1]) e) else primValue opts (C.Lambda [toPVar' "v" i, _x] (part opts (i-1) e)) isPrelude :: Options -> Bool isPrelude opts = currentModule opts=="Prelude" -- partial function call, one argument missing pf :: Options -> Int -> C.Expr -> C.Expr pf opts = app . partial opts (fapp (extFuncPresym opts "pf")) -- partial constructor call, one argument missing pc :: Options -> Int -> C.Expr -> C.Expr pc opts = app . partial opts (fapp (extFuncPresym opts "pc")) -- partial application, more than one argument pa :: Options -> [C.Expr] -> C.Expr pa opts = fapp (extFuncPresym opts "pa") -- function compostition (.) cp :: Options -> [C.Expr] -> C.Expr cp opts = fapp (extFuncPresym opts "cp") partial :: Options -> ([C.Expr] -> C.Expr) -> Int -> C.Expr partial opts part n = foldr1 (\f g -> cp opts [f,g]) . map (\ (k,p) -> dotted opts (k-1) (p [])) $ reverse (zip (reverse [1..n]) (part:repeat (pa opts))) -- add a lot of dots to compose part call functions dotted :: Options -> Int -> C.Expr -> C.Expr dotted opts n p | n == 0 = p | otherwise = dotted opts (n-1) (cp opts [p]) prelPCons opts s = C.PComb (consName opts (mkQName ("Prelude",s))) pO opts x = prelPCons opts "O" [x] pI opts x = prelPCons opts "I" [x] pIHi opts = prelPCons opts "IHi" [] p0 opts = prelPCons opts "Zero" [] pPos opts x = prelPCons opts "Pos" [x] pNeg opts x = prelPCons opts "Neg" [x] public = C.Public isMain (_,fname) = fname=="main" isFirst (_,fname) = fname=="first" cunit opts = sym (consName opts{extCons=True} $ addPre "T0") -- types tFreeVarRef t = curryTCons "FreeVarRef" [t] tOrRef = curryTCons "OrRef" [] tExceptions = curryTCons "C_Exceptions" [] tSuspRef = curryTCons "SuspRef" [] tList a = C.TCons (mkQName ("Prelude","[]")) [a] c_tList a = curryTCons "List" [a] tPair a b = C.TCons (mkQName ("Prelude","(,)")) [a,b] tMaybe a = C.TCons (mkQName ("Prelude","Maybe")) [a] tBranches x = curryTCons "Branches" [x] tSusp x = curryTCons "SuspCont" [x] private = C.Private untyped = Nothing noguard e = C.SimpleExpr e freeCall = cusym "freeF" orSym = cusym "orF" app a b = C.Apply a b app2 a b c = app (app a b) c fapp x xs = foldl C.Apply x xs flatApp = Comb FuncCall flatBind x y = Comb FuncCall (flatPre ">>=") [x,y] flatEq x y = Comb FuncCall (flatPre "===") [x,y] flatPre s = mkQName ("Prelude",s) flatGst x = Comb FuncCall (flatPre "getSearchTree") [x] mid = hasPresym "id" sym = C.Symbol cusym s = sym (cu s) fcusym s = sym (mkQName (funName ("Prelude",s))) basesym s = sym (ba s) baseTypesym isP s = sym (baseType isP s) baseType True s = mkQName (dataModName "Prelude",s) baseType False s = mkQName (N.modName "Prelude",s) fbasesym opts s | currentModule opts=="Prelude" = sym (mkQName (extInstModName "Prelude",functionName s)) | otherwise = sym (mkQName (N.modName "Prelude",functionName s)) cu s = mkQName ("Curry",s) ba s = mkQName ("Curry",s) toVar i = C.Var (xvar i) toVar' s i = C.Var (varName s i) xvar = varName "x" mkVarName :: String -> Int -> String mkVarName s i = s++show i varName :: String -> VarIndex -> String varName s i = mkVarName s (idxOf i) toPVar i = C.PVar (varName "x" i) toPVar' s i = C.PVar (varName s i) toTVar i = C.TVar (mkVarName "t" i) primValue opts v = app (sym $ consName opts{extCons=True} (addPre "PrimValue")) v -- FIXME addPre s = mkQName ("Prelude",s) has s = mkQName ("Prelude",s) toList [] = C.Symbol (mkQName ("","[]")) toList (x:xs) = app2 (C.Symbol (mkQName ("",":"))) x (toList xs) toPList [] = C.PComb (mkQName ("","[]")) [] toPList (x:xs) = C.PComb (mkQName ("",":")) [x,toPList xs] hasPresym s = sym (has s) toPLit opts (Intc _ i) = toPInt opts i toPLit opts (Charc _ c) = toPChar opts c toPLit opts (Floatc _ f) = toPFloat opts f toPInt opts n | n>0 = pPos opts (toPNat opts n) | n<0 = pNeg opts (toPNat opts (negate n)) | n==0 = p0 opts toPNat opts n | d==0 = pIHi opts | m==1 = pI opts (toPNat opts d) | m==0 = pO opts (toPNat opts d) where d = div n 2 m = mod n 2 toPChar opts c | currentModule opts=="Prelude" = C.PComb (mkQName (dataModName "Prelude","C_Char")) [C.PLit (C.Charc c)] | otherwise = C.PComb (mkQName (N.modName "Prelude","C_Char")) [C.PLit (C.Charc c)] toPFloat opts n = primPValue opts (C.PLit (C.Floatc n)) primPValue opts p = C.PComb (consName opts{extCons=True} (addPre "PrimValue")) [p] toLit opts (Intc _ i) = toInt i toLit opts (Charc _ c) = toChar opts c toLit opts (Floatc _ f) = toFloat opts f toInt n = C.Lit (C.Intc (toInteger n)) toHInt n = C.Lit (C.HasIntc (toInteger n)) c_int isP = baseTypesym isP "C_Int" toChar opts c = app (sym (consName opts (mkQName ("Prelude","Char")))) (C.Lit (C.Charc c)) toFloat opts f = primValue opts (C.Lit (C.Floatc f)) otherwiseExp n e = [C.Rule (map C.PVar (take n (repeat "_"))) (noguard e) []] ioT x = TCons (mkQName ("Prelude","IO")) [x] unitT = TCons (mkQName ("Prelude","()")) [] hasUnit = sym (mkQName ("","()")) hasBind x y = fapp (hasPresym ">>=") [x,y] hasReturn x = app (hasPresym "return") x char_ c = C.Lit (C.Charc c) list_ [] = nil list_ (x:xs) = cons_ x (list_ xs) cons_ x xs = fapp (sym (mkQName ("",":"))) [x,xs] nil = sym (mkQName ("","[]")) string_ n = list_ (map char_ n) c_char_ c = fapp (basesym "C_Char") [C.Lit (C.Charc c)] c_list_ [] = c_nil c_list_ (x:xs) = c_cons_ x (c_list_ xs) c_cons_ x xs = fapp (sym (mkQName ("DataPrelude",":<"))) [x,xs] c_nil = sym (mkQName ("DataPrelude","List")) bc_list_ [] = bc_nil bc_list_ (x:xs) = bc_cons_ x (bc_list_ xs) dList True = bc_list_ dList False = c_list_ dpList True = bc_plist_ dpList False = c_plist_ bc_cons_ x xs = fapp (sym (mkQName ("DataPrelude",":<"))) [x,xs] bc_nil = sym (mkQName ("DataPrelude","List")) c_string_ "Prelude" n = bc_list_ (map c_char_ n) c_string_ _ n = c_list_ (map c_char_ n) pchar_ c = C.PLit (C.Charc c) plist_ [] = pnil plist_ (x:xs) = pcons_ x (plist_ xs) pcons_ x xs = C.PComb (mkQName ("",":")) [x,xs] pnil = C.PComb (mkQName ("","[]")) [] c_plist_ [] = c_pnil c_plist_ (x:xs) = c_pcons_ x (c_plist_ xs) c_pcons_ x xs = C.PComb (mkQName ("DataPrelude",":<")) [x,xs] c_pnil = C.PComb (mkQName ("DataPrelude","List")) [] bc_plist_ [] = bc_pnil bc_plist_ (x:xs) = bc_pcons_ x (bc_plist_ xs) bc_pcons_ x xs = C.PComb (mkQName ("DataPrelude",":<")) [x,xs] bc_pnil = C.PComb (mkQName ("DataPrelude","List")) [] pstring_ n = plist_ (map pchar_ n) underscores i = replicate i (_x) qname_ (m,f) = string_ (m++'.':f) extInstPresym True s = sym $ mkQName (extInstModName "Prelude",s) extInstPresym False s = sym $ mkQName (N.modName "Prelude",s) extFuncPresym opts s | isPrelude opts = sym $ mkQName (extFuncModName "Prelude",s) | otherwise = sym $ mkQName (N.modName "Prelude",s) _x = C.PVar "_" st = C.Var "st"