Commit a907e126 authored by Bernd Brassel's avatar Bernd Brassel
Browse files

intermediate state

parent ab985fb9
......@@ -154,9 +154,10 @@ generateHaskellFiles opts (globals,prog,interfaces,auxNames) = do
mapM (writeProgram opts) (addGlobalDefs opts globals modules)
return (haskellFiles opts (progName prog))
writeProgram opts (fn,printOpts,prog) = do
writeProgram opts (fn,unqualified,prog) = do
put 3 opts ("writing "++inKicsSubdir fn)
safeIO (writeKicsFile fn (showProgOpt printOpts prog))
let printOpts = defaultPrintOptions{unqual=unqualified,include=toInclude opts}
safeIO (writeKicsFile True fn (showProgOpt printOpts prog))
put 3 opts (fn++" written")
return fn
......@@ -191,7 +192,8 @@ foldCompile (f:fs) opts
-- names of all haskell files associated with program
haskellFiles :: Options -> String -> [String]
haskellFiles opts name =
haskellFiles opts name = [funcHsName name]
{-
ifAdd (extData opts) (add [extDataHsName]) $
ifAdd (extInsts opts) (add [dataHsName,extInstHsName]) $
ifAdd (extFuncs opts) (add [instHsName,extFuncHsName]) $
......@@ -201,7 +203,7 @@ haskellFiles opts name =
ifAdd [] _ ds = ds
add = foldr (\ f -> ((f name:) .)) id
-}
------------------------------------------------------
-- basic transformation
......@@ -218,40 +220,20 @@ transform typeMapping aux opts0 (Prog name imports types funcs _)
where
opts = opts0{hasData=hasInternalData}
hasExternalData = hasExtData opts
hasExternalInstances = hasExtInsts opts
hasExternalFuncs = hasExtFuncs opts
hasInternalData = not $ null $ filter (not . isExternalType) types
modules
| not hasInternalData = [allinclusiveProg]
| hasExternalInstances && hasExternalFuncs = [dataProg,instProg,funcProg]
| hasExternalInstances = [dataProg,instFuncProg]
| hasExternalFuncs = [dataInstProg,funcProg]
| otherwise = [allinclusiveProg]
modules = [allinclusiveProg]
-- filename, flag and module definitions
dataProg = (dataHsName (filename opts),False,dataModule)
instProg = (instHsName (filename opts),False,instModule)
funcProg = (funcHsName (filename opts),False,funcModule)
instFuncProg = (funcHsName (filename opts),False,instFuncModule)
dataInstProg = (instHsName (filename opts),False,dataInstModule)
allinclusiveProg = (funcHsName (filename opts),False,allinclusive)
modul mName mImports mExports mTypes mInsts mFuncs =
C.Prog mName mImports mExports mTypes mInsts mFuncs []
dataModule = modul dataName dataImports dataExports dataTypes [] []
instModule = modul instName instImports instExports [] instances []
funcModule = modul funcName funcImports funcExports [] [] functions
instFuncModule = modul funcName instImports funcExports [] instances functions
dataInstModule = modul instName dataImports dataExports dataTypes instances []
allinclusive = modul funcName allIImports allIExports dataTypes instances functions
-- the module names are:
dataName = dataModName name
instName = instModName name
funcName = modName name
mainModuleName = "Main"
......@@ -263,30 +245,18 @@ transform typeMapping aux opts0 (Prog name imports types funcs _)
-- import lists
newImports = map 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
allIImports = ["Curry"] ++ newImports
{-
-- this is the only special prelude treatment:
instImportName
| name=="Prelude" = instName ++ " hiding ("++opsUsedInInstances++")"
| otherwise = instName
opsUsedInInstances = "op_38_38"
-}
-- export lists
allIExports = map ("module "++) $
(if hasExternalData then [extDataModName name] else [])
++ (if hasExternalFuncs then [extFuncModName name] else [])
dataExports
| hasExternalData = ["module "++extDataModName name]
| otherwise = []
instExports = map ("module "++) [dataName,extInstModName name]
funcExports = map ("module "++) [instName,extFuncModName name]
allIExports = []
-- the generated types, instances and functions
dataTypes = map (transTypeDecl opts{consUse=DataDef})
......@@ -964,31 +934,11 @@ int i = app (hasPresym "fromInteger") (C.Lit (C.Intc i))
--------------------------
consName,freeVarName,failName,orName,suspName :: Options -> QName -> QName
consName opts (m,n)
| m/=currentModule opts = (modName m,cn)
| dataDef && isExtDataName = (extDataModName m,cn)
| dataDef && existsDataModule = (dataModName m,cn)
| dataDef && existsInstModule = (instModName m,cn)
| dataDef = (modName m,cn)
| instDef && existsDataModule = (dataModName m,cn)
| instDef && isExtDataName = (extDataModName m,cn)
| instDef && existsInstModule = (instModName m,cn)
| instDef = (modName m,cn)
| funcDef && existsInstModule = (instModName m,cn)
| funcDef && isExtDataName = (extDataModName m,cn)
| funcDef = (modName m,cn)
consName opts (m,n) = (modName m,cn)
where
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
freeVarName opts = N.freeVarName . consName opts
failName opts = N.failName . consName opts
orName opts = N.orName . consName opts
......@@ -1040,19 +990,19 @@ 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"))
pf opts = app . partial opts (fapp (cupresym "pf"))
-- partial constructor call, one argument missing
pc :: Options -> Int -> C.Expr -> C.Expr
pc opts = app . partial opts (fapp (extFuncPresym opts "pc"))
pc opts = app . partial opts (fapp (cupresym "pc"))
-- partial application, more than one argument
pa :: Options -> [C.Expr] -> C.Expr
pa opts = fapp (extFuncPresym opts "pa")
pa opts = fapp (cupresym "pa")
-- function compostition (.)
cp :: Options -> [C.Expr] -> C.Expr
cp opts = fapp (extFuncPresym opts "cp")
cp opts = fapp (cupresym "cp")
partial :: Options -> ([C.Expr] -> C.Expr) -> Int -> C.Expr
partial opts part n
......@@ -1066,15 +1016,15 @@ dotted opts n p
| n == 0 = p
| otherwise = dotted opts (n-1) (cp opts [p])
prelPCons opts s = C.PComb (consName opts ("Prelude",s))
prelPCons 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" []
pO opts x = prelPCons "O" [x]
pI opts x = prelPCons "I" [x]
pIHi opts = prelPCons "IHi" []
p0 opts = prelPCons opts "Zero" []
pPos opts x = prelPCons opts "Pos" [x]
pNeg opts x = prelPCons opts "Neg" [x]
p0 opts = prelPCons "Zero" []
pPos opts x = prelPCons "Pos" [x]
pNeg opts x = prelPCons "Neg" [x]
public = C.Public
......@@ -1094,12 +1044,12 @@ tExceptions = curryTCons "C_Exceptions" []
tSuspRef = curryTCons "SuspRef" []
tList a = C.TCons ("Prelude","[]") [a]
tList a = C.TCons (addPre "[]") [a]
c_tList a = curryTCons "List" [a]
tPair a b = C.TCons ("Prelude","(,)") [a,b]
tPair a b = C.TCons (addPre "(,)") [a,b]
tMaybe a = C.TCons ("Prelude","Maybe") [a]
tMaybe a = C.TCons (addPre "Maybe") [a]
tBranches x = curryTCons "Branches" [x]
......@@ -1123,17 +1073,17 @@ 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]
flatBind x y = Comb FuncCall (addPre ">>=") [x,y]
flatPre s = ("Prelude",s)
flatEq x y = Comb FuncCall (addPre "===") [x,y]
flatGst x = Comb FuncCall (flatPre "getSearchTree") [x]
flatGst x = Comb FuncCall (addPre "getSearchTree") [x]
mid = hasPresym "id"
sym = C.Symbol
cupresym = sym . addPre
cusym s = sym (cu s)
......@@ -1145,14 +1095,11 @@ basesym s = sym (ba s)
baseTypesym isP s = sym (baseType isP s)
baseType True s = (dataModName "Prelude",s)
baseType False s = (modName "Prelude",s)
baseType _ s = addPre s
fbasesym opts s
| currentModule opts=="Prelude" = sym (extInstModName "Prelude",functionName s)
| otherwise = sym (modName "Prelude",functionName s)
| otherwise = presym (functionName s)
ba s = ("Curry",s)
......@@ -1250,8 +1197,8 @@ 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 ("DataPrelude",":<")) [x,xs]
c_nil = sym ("DataPrelude","List")
c_cons_ x xs = fapp (presym ":<") [x,xs]
c_nil = presym "List"
bc_list_ [] = bc_nil
bc_list_ (x:xs) = bc_cons_ x (bc_list_ xs)
......@@ -1262,8 +1209,8 @@ dList False = c_list_
dpList True = bc_plist_
dpList False = c_plist_
bc_cons_ x xs = fapp (sym ("DataPrelude",":<")) [x,xs]
bc_nil = sym ("DataPrelude","List")
bc_cons_ x xs = fapp (presym ":<") [x,xs]
bc_nil = presym "List"
c_string_ "Prelude" n = bc_list_ (map c_char_ n)
c_string_ _ n = c_list_ (map c_char_ n)
......@@ -1279,7 +1226,7 @@ pnil = C.PComb ("","[]") []
c_plist_ [] = c_pnil
c_plist_ (x:xs) = c_pcons_ x (c_plist_ xs)
c_pcons_ x xs = C.PComb ("DataPrelude",":<") [x,xs]
c_pcons_ x xs = C.PComb (pre ":<") [x,xs]
c_pnil = C.PComb ("DataPrelude","List") []
bc_plist_ [] = bc_pnil
......@@ -1295,12 +1242,9 @@ underscores i = replicate i (_x)
qname_ (m,f) = string_ (m++'.':f)
extInstPresym True s = sym (extInstModName "Prelude",s)
extInstPresym False s = sym (modName "Prelude",s)
extInstPresym _ s = sym (modName "Prelude",s)
extFuncPresym opts s
| isPrelude opts = sym (extFuncModName "Prelude",s)
| otherwise = sym (modName "Prelude",s)
extFuncPresym opts s = sym (modName "Prelude",s)
_x = C.PVar "_"
......
......@@ -77,9 +77,10 @@ inKicsSubdir s = inCurrySubdir s `inSubdir` kicsSubdir
--write a file to curry subdirectory
writeKicsFile :: String -> String -> IO String
writeKicsFile filename contents = do
let filename' = inKicsSubdir filename
writeKicsFile :: Bool -> String -> String -> IO String
writeKicsFile isHsModule filename contents = do
let filename' | isHsModule = inKicsSubdir filename `inSubdir` "Curry" `inSubdir` "Module"
| otherwise = inKicsSubdir filename
subdir = dirname filename'
createDirectoryIfMissing True subdir
writeFile filename' contents
......
......@@ -17,7 +17,7 @@
-- in May 2007:
-- - prettier representation of Curry and Haskell Strings
------------------------------------------------------------------------------
module ShowFunctionalProg(showProg,showProgOpt,
module ShowFunctionalProg(showProg,showProgOpt,PrintOptions(..),defaultPrintOptions,
showTypeDecls,
showTypeDecl,
showTypeExpr,
......@@ -37,33 +37,38 @@ import Debug.Trace
-- Functions to print an AbstractCurry program in standard Curry syntax
-------------------------------------------------------------------------------
data Options = PrintOpt { unqual :: Bool,
sep :: String}
data PrintOptions = PrintOpt { unqual :: Bool,
sep :: String,
include :: String}
defaultOptions :: Options
defaultOptions = PrintOpt False ""
defaultPrintOptions :: PrintOptions
defaultPrintOptions = PrintOpt False "" ""
--- Shows an AbstractCurry program in standard Curry syntax.
showProg :: Prog -> String
showProg = showProgOpt (unqual defaultOptions)
showProg = showProgOpt defaultPrintOptions
showProgOpt :: Bool -> Prog -> String
showProgOpt uq p@(Prog m imports exports typedecls insdecls funcdecls opdecls)
= "module "++m++showExports opts m exports ++" where\n\n"
showProgOpt :: PrintOptions -> Prog -> String
showProgOpt opts p@(Prog m imports exports typedecls insdecls funcdecls opdecls)
= "{-# OPTIONS -cpp #-}\n\n"
++ "{-# LANGUAGE RankNTypes, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}\n\n"
++ "module "++m++showExports opts m exports ++" where\n\n"
++ showImports imports
++ "\n\n-- begin included\n\n"
++ include opts
++ "\n\n-- end included\n\n"
++ showOpDecls opdecls
++ showTypeDecls opts typedecls
++ showInsDecls opts insdecls
++ separate "\n\n" (map (showFuncDeclOpt opts) funcdecls)
++ "\n"
where
opts = defaultOptions{unqual=uq}
-----------------------------------------
-- export declaration
-----------------------------------------
showExports :: Options -> String -> [String] -> String
showExports :: PrintOptions -> String -> [String] -> String
showExports _ m exports = brace " (" ")" ", " (("module "++m):exports)
-----------------------------------------
......@@ -94,12 +99,12 @@ showFixity InfixrOp = "infixr"
--------------------------------------------------
--- Shows a list of AbstractCurry type declarations in standard Curry syntax.
showTypeDecls :: Options -> [TypeDecl] -> String
showTypeDecls :: PrintOptions -> [TypeDecl] -> String
showTypeDecls opts typedecls =
brace "" "\n\n" "\n\n" (map (showTypeDecl opts) typedecls)
--- Shows an AbstractCurry type declaration in standard Curry syntax.
showTypeDecl :: Options -> TypeDecl -> String
showTypeDecl :: PrintOptions -> TypeDecl -> String
showTypeDecl opts t =
decl ++ showIdentifier (snd (typeName t)) ++
brace " " "" " " (map (showTypeExpr opts False . TVar) (typeVars t)) ++ " = "++
......@@ -110,16 +115,16 @@ showTypeDecl opts t =
where
decl = case t of {TypeSyn{} -> "type "; Type{} -> "data "}
showConsDecl :: Options -> ConsDecl -> String
showConsDecl :: PrintOptions -> ConsDecl -> String
showConsDecl opts c
= separate (if strictArgs c then " !" else " ")
(showIdentifier (snd (consName c)) :
map (showTypeExpr opts True) (consArgs c))
showInsDecls :: Options -> [InstanceDecl] -> String
showInsDecls :: PrintOptions -> [InstanceDecl] -> String
showInsDecls opts is = brace "" "\n\n" "\n\n" (map (showInsDecl opts) is)
showInsDecl :: Options -> InstanceDecl -> String
showInsDecl :: PrintOptions -> InstanceDecl -> String
showInsDecl opts (Instance tcs tc fs)
= "instance "
++ showTypeConstr opts tcs
......@@ -134,7 +139,7 @@ showTypeClass opts (TypeClass qn ts)
--- Shows an AbstractCurry type expression in standard Curry syntax.
--- If the first argument is True, the type expression is enclosed
--- in brackets.
showTypeExpr :: Options -> Bool -> TypeExpr -> String
showTypeExpr :: PrintOptions -> Bool -> TypeExpr -> String
showTypeExpr _ _ (TVar name) = showIdentifier name
showTypeExpr opts nested (FuncType domain range) =
(if nested then brace "(" ")" else separate) " -> "
......@@ -147,7 +152,7 @@ showTypeExpr opts nested (TConstr tcs t) =
(if nested then brace "(" ")" else separate) ""
[showTypeConstr opts tcs ++ showTypeExpr opts False t]
showTypeCons :: Options -> String -> String -> [TypeExpr] -> String
showTypeCons :: PrintOptions -> String -> String -> [TypeExpr] -> String
showTypeCons opts mod name ts =
showSymbol opts (mod,name) ++
brace " " "" " " (map (showTypeExpr opts True) ts)
......@@ -159,9 +164,9 @@ showTypeCons opts mod name ts =
------------------------------------------
--- Shows an AbstractCurry function declaration in standard Curry syntax.
showFuncDecl = showFuncDeclOpt defaultOptions
showFuncDecl = showFuncDeclOpt defaultPrintOptions
showFuncDeclOpt :: Options -> FuncDecl -> String
showFuncDeclOpt :: PrintOptions -> FuncDecl -> String
showFuncDeclOpt opts f =
maybe "" (\t->fname ++" :: "++ (showTypeExpr opts False t) ++ "\n")
(funcType f) ++
......@@ -171,20 +176,20 @@ showFuncDeclOpt opts f =
where
fname = showIdentifier (snd (funcName f))
showRule :: Options -> Rule -> String
showRule :: PrintOptions -> Rule -> String
showRule opts (Rule ps r ls)
= separate " " (map (showPatternOpt opts) ps) ++
showRhs opts r ++
brace "\n where\n " "" "\n " (map (showLocalDecl opts) ls)
showRhs :: Options -> Rhs -> String
showRhs :: PrintOptions -> Rhs -> String
showRhs opts (SimpleExpr e) = " = "++showExprOpt opts e
showRhs opts (GuardedExpr gs) = brace "\n " "" "\n " (map (showGuard opts) gs)
showGuard :: Options -> (Expr,Expr) -> String
showGuard :: PrintOptions -> (Expr,Expr) -> String
showGuard opts (g,r) = " | " ++ showExprOpt opts g ++ " = " ++ showExprOpt opts r
showLocalDecl :: Options -> LocalDecl -> String
showLocalDecl :: PrintOptions -> LocalDecl -> String
showLocalDecl opts (LocalFunc funcdecl) = showFuncDeclOpt (opts{sep=" "}) funcdecl
showLocalDecl opts (LocalPat pattern expr ls) =
showPatternOpt opts pattern ++ " = " ++ showExprOpt opts expr ++
......@@ -224,9 +229,9 @@ showIdentifier name
n9 = 57
--- Shows an AbstractCurry expression in standard Curry syntax.
showExpr = showExprOpt defaultOptions
showExpr = showExprOpt defaultPrintOptions
showExprOpt :: Options -> Expr -> String
showExprOpt :: PrintOptions -> Expr -> String
showExprOpt _ (Var name) = showIdentifier name
showExprOpt _ (Lit lit) = showLiteral lit
showExprOpt opts (Symbol name) = showSymbol opts name
......@@ -263,7 +268,7 @@ showExprOpt opts (Case expr branches)
(map (showBranchExpr opts) branches)
showExprOpt _ (String s) = '"':s++"\"" --"
showSymbol :: Options -> QName -> String
showSymbol :: PrintOptions -> QName -> String
showSymbol _ ("",symName) = showIdentifier symName
showSymbol opts (m,symName)
| isInfixOpName symName = brace "(" ")" "" [m++"."++symName]
......@@ -278,7 +283,7 @@ showLambda opts patts expr =
showExprOpt opts expr
showStatement :: Options -> Statement -> String
showStatement :: PrintOptions -> Statement -> String
showStatement opts (SExpr expr) = showExprOpt opts expr
showStatement opts (SPat pattern expr)
= showPatternOpt opts pattern ++ " <- " ++ showExprOpt opts expr
......@@ -321,9 +326,9 @@ expAsHaskellList _ = Nothing
-------------------------------------------------------
showPattern :: Pattern -> String
showPattern = showPatternOpt defaultOptions
showPattern = showPatternOpt defaultPrintOptions
showPatternOpt :: Options -> Pattern -> String
showPatternOpt :: PrintOptions -> Pattern -> String
showPatternOpt _ (PVar name) = showIdentifier name
showPatternOpt _ (PLit lit) = showLiteral lit
showPatternOpt opts (PComb name []) = showSymbol opts name
......@@ -332,7 +337,7 @@ showPatternOpt opts (PComb sym ps)
showPatternOpt opts (AsPat v p) =
showPatternOpt opts (PVar v)++"@"++showPatternOpt opts p
showBranchExpr :: Options -> BranchExpr -> String
showBranchExpr :: PrintOptions -> BranchExpr -> String
showBranchExpr opts (Branch pattern expr)
= showPatternOpt opts pattern ++ " -> " ++ showExprOpt opts expr
......
......@@ -338,8 +338,8 @@ reqModuleName = "Request"
reqModuleFile = replaceExtension (inKicsSubdir reqModuleName) ".fcy"
genReqModule fs line =
safeIO (writeKicsFile (replaceExtension reqModuleName ".curry")
(imports fs++"\n\n"++mainExpr++" = "++ line))
safeIO (writeKicsFile False (replaceExtension reqModuleName ".curry")
(imports fs++"\n\n"++mainExpr++" = "++ line))
timing (State{time=True}) s = "time "++s
timing _ s = s
......@@ -376,7 +376,7 @@ genDebugModule Opts{debugger=Just tool,mainModule=mod} fs line = do
\ run (S.strict_"++mainExpr++") \""++mod++"\""
--safeIO $ putStrLn modName
--safeIO $ putStrLn modCont
safeIO (writeKicsFile modName modCont)
safeIO (writeKicsFile False modName modCont)
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment