KiCS-0.8.4: src/CurryToHaskell.hs
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"