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