Commit 80511965 authored by Michael Hanus's avatar Michael Hanus
Browse files

Some top-level type signatures added

parent 17919ef8
......@@ -207,6 +207,7 @@ analysisName (CombinedDependencyFuncAnalysis _ nameB _ _ _) = nameB
analysisName (CombinedDependencyTypeAnalysis _ nameB _ _ _) = nameB
--- Name of the base analysis of a combined analysis.
baseAnalysisName :: Analysis a -> String
baseAnalysisName (CombinedSimpleFuncAnalysis bName _ _ _) = bName
baseAnalysisName (CombinedSimpleTypeAnalysis bName _ _ _) = bName
baseAnalysisName (CombinedDependencyFuncAnalysis bName _ _ _ _) = bName
......
......@@ -26,6 +26,7 @@ import Sort(mergeSort)
import Global
import Char(isSpace)
systemBanner :: String
systemBanner =
let bannerText = "CASS: Curry Analysis Server System ("++
"version of 20/01/2015 for "++curryCompiler++")"
......@@ -36,18 +37,23 @@ systemBanner =
--- The base directory of the analysis tool containing all programs.
--- Required to copy the configuration file and to the find executables
--- of the server and the workers.
baseDir :: String
baseDir = installDir ++ "/currytools/CASS"
--- The address of the server when it is connected from the worker clients.
getServerAddress :: IO String
getServerAddress = return "127.0.0.1" -- run only on local machine
--------------------------------------------------------------------------
-- Name of user property file:
propertyFileName :: IO String
propertyFileName = getHomeDirectory >>= return . (</> ".curryanalysisrc")
defaultPropertyFileName :: String
defaultPropertyFileName = baseDir </> "curryanalysisrc"
--- Install user property file if it does not exist.
installPropertyFile :: IO ()
installPropertyFile = do
fname <- propertyFileName
pfexists <- doesFileExist fname
......@@ -101,6 +107,7 @@ updateCurrentProperty pn pv = do
currprops <- getProperties
writeGlobal currProps (Just (replaceKeyValue pn pv currprops))
replaceKeyValue :: a -> b -> [(a,b)] -> [(a,b)]
replaceKeyValue k v [] = [(k,v)]
replaceKeyValue k v ((k1,v1):kvs) =
if k==k1 then (k,v):kvs else (k1,v1) : replaceKeyValue k v kvs
......@@ -109,6 +116,7 @@ replaceKeyValue k v ((k1,v1):kvs) =
--------------------------------------------------------------------------
--- Gets the name of file containing the current server port and pid
--- ($HOME has to be set)
getServerPortFileName :: IO String
getServerPortFileName = do
homeDir <- getHomeDirectory
return $ homeDir++"/.curryanalysis.port"
......@@ -160,28 +168,34 @@ getServerPortNumber = do
--------------------------------------------------------------------------
-- Get terminalCommand from Config file
getTerminalCommand :: IO String
getTerminalCommand = do
properties <- getProperties
let tcmd = lookup "terminalCommand" properties
return (maybe "" id tcmd)
-- Get the fixpoint computation method from Config file
getFPMethod :: IO String
getFPMethod =
getProperties >>= return . maybe "simple" id . lookup "fixpoint"
-- Get the option to analyze also the prelude from Config file
getWithPrelude :: IO String
getWithPrelude =
getProperties >>= return . maybe "yes" id . lookup "prelude"
-- timeout for network message passing: -1 is wait time infinity
waitTime :: Int
waitTime = -1
-- Default number of workers (if the number is not found in the
-- configuration file).
defaultWorkers :: Int
defaultWorkers=0
--- Gets the default load path from the property file (added at the end
--- of CURRYPATH).
getDefaultPath :: IO String
getDefaultPath = do
currypath <- getEnviron "CURRYPATH"
properties <- getProperties
......@@ -192,6 +206,7 @@ getDefaultPath = do
Nothing -> currypath
-- number of worker threads running at the same time
numberOfWorkers :: IO Int
numberOfWorkers = do
properties <- getProperties
let number = lookup "numberOfWorkers" properties
......
......@@ -21,6 +21,7 @@ dependsDirectlyOnTypes (Type _ _ _ consDeclList) =
dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)
tconsOf :: TypeExpr -> [(String,String)]
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName _) = [qName]
......@@ -53,13 +54,17 @@ funcSetOfExpr (Case _ e bs) = unionRBT (funcSetOfExpr e)
where funcSetOfBranch (Branch _ be) = funcSetOfExpr be
funcSetOfExpr (Typed e _) = funcSetOfExpr e
isConstructorComb :: CombType -> Bool
isConstructorComb ct = case ct of
ConsCall -> True
ConsPartCall _ -> True
_ -> False
unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName
unionMap f = foldr unionRBT emptySet . map f
emptySet :: SetRBT QName
emptySet = emptySetRBT leqQName
leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2)
......@@ -115,12 +115,16 @@ groundApply (P ps) gargs =
--- is non-ground (if i is a member of the third argument).
data NDEffect = NDEffect Bool Bool [Int]
noEffect :: NDEffect
noEffect = NDEffect False False []
orEffect :: NDEffect
orEffect = NDEffect True False []
narrEffect :: NDEffect
narrEffect = NDEffect False True []
narrIfEffect :: [Int] -> NDEffect
narrIfEffect = NDEffect False False
-- Show non-determinitic effect information as a string.
......@@ -222,6 +226,7 @@ ndEffectApply (fgd,fnd) argsgnd =
foldr lubE (ndEffectReplace argsgd fnd) argsnd)
-- replace (narrIf i) by i-th ground value
ndEffectReplace :: [(Int,Ground)] -> NDEffect -> NDEffect
ndEffectReplace argsgd (NDEffect ornd narrnd ifs) = replaceProjs [] ifs
where
-- replace i by i-th ground value
......@@ -242,6 +247,7 @@ mergeInts (x:xs) (y:ys) | x==y = x : mergeInts xs ys
| x<y = x : mergeInts xs (y:ys)
| x>y = y : mergeInts (x:xs) ys
prelude :: String
prelude = "Prelude"
-----------------------------------------------------------------------
......@@ -43,6 +43,7 @@ orderOfType (TypeSyn _ _ _ typeExpr) usedtypes =
-- compute the order of a type expression (ignore the type constructors,
-- i.e., check whether this expression contains a `FuncType`).
orderOfTypeExpr :: TypeExpr -> Order
orderOfTypeExpr (TVar _) = FO
orderOfTypeExpr (FuncType _ _) = HO
orderOfTypeExpr (TCons _ typeExprs) =
......
......@@ -56,6 +56,7 @@ choiceInExpr (Case _ e bs) = choiceInExpr e || any choiceInBranch bs
where choiceInBranch (Branch _ be) = choiceInExpr be
choiceInExpr (Typed e _) = choiceInExpr e
indetFuns :: [QName]
indetFuns = [("Prelude","commit"),
("Ports","send"),("Ports","doSend"),
("SetFunctions","select")]
......
......@@ -100,6 +100,7 @@ updateVarInEnv ((i,ov):env) v nv =
--- Drop the first n elements from the environment component
--- of an environment/type pair:
dropEnv :: Int -> ([a],b) -> ([a],b)
dropEnv n (env,rtype) = (drop n env, rtype)
-- Sorts a list of environment/type pairs by the type.
......@@ -111,6 +112,7 @@ sortEnvTypes = mergeSort (\ (e1,t1) (e2,t2) -> (t1,e1) <= (t2,e2))
--- required value analysis. If a type has more constructors than
--- specified here, it will not be analyzed for individual required
--- constructor values.
maxReqValues :: Int
maxReqValues = 3
--- Required value analysis.
......@@ -268,4 +270,5 @@ joinEnv ((i1,v1):env1) env2@(_:_) =
(lookup i1 env2)
-- Name of the standard prelude:
prelude :: String
prelude = "Prelude"
......@@ -42,6 +42,7 @@ showRightLinear ANote False = ""
hasRightLinearRules :: FuncDecl -> Bool
hasRightLinearRules (Func _ _ _ _ rule) = isRightLinearRule rule
isRightLinearRule :: Rule -> Bool
isRightLinearRule (Rule _ e) = linearExpr e
isRightLinearRule (External _) = True
......
......@@ -58,6 +58,7 @@ showSolComplete _ True = "solution complete"
showSolComplete _ False = "maybe suspend"
pre :: String -> QName
pre n = ("Prelude",n)
-- end of SolutionCompleteness
......@@ -119,6 +119,7 @@ isComplete consinfo (Case _ _ (Branch (Pattern cons _) bexp : ces)) =
isComplete consinfo (Typed e _) = isComplete consinfo e
-- Combines the completeness results in different Or branches.
combineOrResults :: Completeness -> Completeness -> Completeness
combineOrResults Complete _ = Complete
combineOrResults InComplete Complete = Complete
combineOrResults InComplete InComplete = InCompleteOr
......@@ -128,6 +129,7 @@ combineOrResults InCompleteOr InComplete = InCompleteOr
combineOrResults InCompleteOr InCompleteOr = InCompleteOr
-- Combines the completeness results in different case branches.
combineAndResults :: Completeness -> Completeness -> Completeness
combineAndResults InComplete _ = InComplete
combineAndResults Complete Complete = Complete
combineAndResults Complete InComplete = InComplete
......
......@@ -40,18 +40,22 @@ showInterface genstub (Prog mod imports types funcs ops) =
(mergeSort leqFunc funcs) ++ "\n"
-- show import declaration
showInterfaceImport :: String -> String
showInterfaceImport impmod = if impmod=="Prelude" then ""
else "import "++impmod++"\n"
-- show operator declaration
showInterfaceOpDecl :: OpDecl -> String
showInterfaceOpDecl (Op op InfixOp prec) = "infix "++show prec++" "++showOp op++"\n"
showInterfaceOpDecl (Op op InfixlOp prec) = "infixl "++show prec++" "++showOp op++"\n"
showInterfaceOpDecl (Op op InfixrOp prec) = "infixr "++show prec++" "++showOp op++"\n"
showOp :: (_,String) -> String
showOp (_,on) = if isAlpha (head on) then '`':on++"`"
else on
-- show type declaration
showInterfaceType :: (QName -> String) -> TypeDecl -> String
showInterfaceType tt (Type (_,tcons) vis tvars constrs) =
if vis==Public
then "data " ++ tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
......@@ -68,10 +72,12 @@ showInterfaceType tt (TypeSyn (_,tcons) vis tvars texp) =
" = " ++ showCurryType tt True texp ++ "\n"
else ""
showExportConsDecl :: (QName -> String) -> ConsDecl -> String
showExportConsDecl tt (Cons (_,cname) _ _ argtypes) =
cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes
-- show function type declaration
showInterfaceFunc :: (QName -> String) -> Bool -> FuncDecl -> String
showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) =
if vis==Public
then showCurryId fname ++ " :: " ++
......@@ -96,6 +102,7 @@ showCurryMod ascase (Prog mod imports types funcs ops) =
(showQNameInModule mod) ascase) funcs
++ "\n-- end of module " ++ mod ++ "\n"
showTypeExports :: [TypeDecl] -> String
showTypeExports types = concatMap (++",") (concatMap exptype types)
where
exptype (Type tcons vis _ cdecls) =
......@@ -107,10 +114,12 @@ showTypeExports types = concatMap (++",") (concatMap exptype types)
expcons cds = "(" ++ intercalate "," (concatMap expc cds) ++ ")"
expc (Cons cname _ vis _) = if vis==Public then [snd cname] else []
showFuncExports :: [FuncDecl] -> String
showFuncExports funcs = intercalate "," (concatMap expfun funcs)
where
expfun (Func fname _ vis _ _) = if vis==Public then [snd fname] else []
showCurryDataDecl :: (QName -> String) -> TypeDecl -> String
showCurryDataDecl tt (Type tcons _ tvars constrs) =
"data " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
(if null constxt then "" else " = " ++ constxt)
......@@ -120,21 +129,25 @@ showCurryDataDecl tt (TypeSyn tcons _ tvars texp) =
"type " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
" = " ++ showCurryType tt True texp ++ "\n"
showCurryConsDecl :: (QName -> String) -> ConsDecl -> String
showCurryConsDecl tt (Cons cname _ _ argtypes) =
snd cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes
-- generate function definitions:
showCurryFuncDecl :: (QName -> String) -> (QName -> String) -> Bool -> FuncDecl -> String
showCurryFuncDecl tt tf ascase (Func fname _ _ ftype frule) =
showCurryId (snd fname) ++" :: "++ showCurryType tt False ftype ++ "\n" ++
showCurryRule tf ascase fname frule
showCurryRule :: (QName -> String) -> Bool -> QName -> Rule -> String
showCurryRule _ _ fname (External _) = showCurryId (snd fname) ++ " external\n\n"
showCurryRule tf ascase fname (Rule lhs rhs) =
if ascase then showCurryRuleAsCase tf fname (Rule lhs rhs)
else showCurryRuleAsPatterns tf fname (Rule lhs rhs)
-- format rule as case expression:
showCurryRuleAsCase :: (QName -> String) -> QName -> Rule -> String
showCurryRuleAsCase tf fname (Rule lhs rhs)
| length lhs == 2 && not (isAlpha (head (snd fname))) -- infix op
= showCurryVar (head lhs) ++ " " ++ tf fname ++ " " ++ showCurryVar (lhs!!1) ++
......@@ -145,15 +158,18 @@ showCurryRuleAsCase tf fname (Rule lhs rhs)
showCurryRuleAsCase _ fname (External _) = showCurryId (snd fname) ++ " external\n"
-- format rule as set of pattern matching rules:
showCurryRuleAsPatterns :: (QName -> String) -> QName -> Rule -> String
showCurryRuleAsPatterns tf fname (Rule lhs rhs) =
concatMap (\ (l,r) -> showCurryPatternRule tf l r)
(rule2equations (shallowPattern2Expr fname lhs) rhs)
++ "\n"
splitFreeVars :: Expr -> ([Int],Expr)
splitFreeVars exp = case exp of
Free vars e -> (vars,e)
_ -> ([],exp)
showCurryPatternRule :: (QName -> String) -> Expr -> Expr -> String
showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
showCurryExpr tf False 0 l ++
showCurryCRHS tf e ++
......@@ -161,6 +177,7 @@ showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
" where " ++ intercalate "," (map showCurryVar vars) ++ " free")
++ "\n"
showCurryCRHS :: (QName -> String) -> Expr -> String
showCurryCRHS tf r =
if isGuardedExpr r
then " | " ++ showCurryCondRule r
......@@ -178,6 +195,7 @@ rule2equations lhs rhs = case rhs of
Or e1 e2 -> rule2equations lhs e1 ++ rule2equations lhs e2
_ -> [(lhs,rhs)]
caseIntoLhs :: Expr -> Int -> [BranchExpr] -> [(Expr,Expr)]
caseIntoLhs _ _ [] = []
caseIntoLhs lhs vi (Branch (Pattern c vs) e : bs) =
rule2equations (substitute [vi] [shallowPattern2Expr c vs] lhs) e
......@@ -186,6 +204,7 @@ caseIntoLhs lhs vi (Branch (LPattern lit) e : bs) =
rule2equations (substitute [vi] [Lit lit] lhs) e
++ caseIntoLhs lhs vi bs
shallowPattern2Expr :: QName -> [Int] -> Expr
shallowPattern2Expr name vars =
Comb ConsCall name (map (\i->Var i) vars)
......@@ -193,6 +212,7 @@ shallowPattern2Expr name vars =
-- (substitute vars exps expr) = expr[vars/exps]
-- i.e., replace all occurrences of vars by corresponding exps in the
-- expression expr
substitute :: [Int] -> [Expr] -> Expr -> Expr
substitute vars exps expr = substituteAll vars exps 0 expr
-- (substituteAll vars exps base expr):
......@@ -222,6 +242,7 @@ substituteAll vs es b (Or e1 e2) =
substituteAll vs es b (Case ctype e cases) =
Case ctype (substituteAll vs es b e) (map (substituteAllCase vs es b) cases)
substituteAllCase :: [Int] -> [Expr] -> Int -> BranchExpr -> BranchExpr
substituteAllCase vs es b (Branch (Pattern l pvs) e) =
Branch (Pattern l (map (+b) pvs)) (substituteAll vs es b e)
substituteAllCase vs es b (Branch (LPattern l) e) =
......@@ -238,23 +259,29 @@ isGuardedExpr e = case e of
-------- Definition of some orderings:
leqOp :: OpDecl -> OpDecl -> Bool
leqOp (Op (_,op1) _ p1) (Op (_,op2) _ p2) = p1>p2 || p1==p2 && op1<=op2
leqType :: TypeDecl -> TypeDecl -> Bool
leqType t1 t2 = (tname t1) <= (tname t2)
where tname (Type (_,tn) _ _ _) = tn
tname (TypeSyn (_,tn) _ _ _) = tn
leqFunc :: FuncDecl -> FuncDecl -> Bool
leqFunc (Func (_,f1) _ _ _ _) (Func (_,f2) _ _ _ _) = f1 <= f2
---------------------------------------------------------------------------
-- Show individual functions:
showFuncDeclAsCurry :: FuncDecl -> String
showFuncDeclAsCurry fd =
showCurryFuncDecl (showQNameInModule (funcModule fd))
(showQNameInModule (funcModule fd)) False fd
showFuncDeclAsFlatCurry :: FuncDecl -> String
showFuncDeclAsFlatCurry fd =
showCurryFuncDecl (showQNameInModule (funcModule fd))
(showQNameInModule (funcModule fd)) True fd
funcModule :: FuncDecl -> String
funcModule fd = fst (funcName fd)
......@@ -26,6 +26,7 @@ import Maybe(isJust)
---------------------------------------------------------------------
-- add a directory name for a Curry source file by looking up the
-- current load path (CURRYPATH):
findSourceFileInLoadPath :: String -> IO (String)
findSourceFileInLoadPath modname = do
loadpath <- getLoadPathForFile modname
mbfname <- lookupFileInPath (baseName modname) [".lcurry",".curry"] loadpath
......@@ -39,6 +40,7 @@ findFunDeclInProgText progtext fname =
findFirstDeclLine (showCurryId fname) (lines progtext) 1
-- finds first declaration line:
findFirstDeclLine :: String -> [String] -> Int -> Int
findFirstDeclLine _ [] _ = 0 -- not found
findFirstDeclLine f (l:ls) n =
if isPrefixOf f l then n else findFirstDeclLine f ls (n+1)
......@@ -80,6 +82,7 @@ sourceProgGUI cnt progdefs =
return []
-- start the counter GUI:
startGUI :: String -> IO ()
startGUI prog = do
filename <- findSourceFileInLoadPath prog
contents <- readFile filename
......@@ -87,6 +90,7 @@ startGUI prog = do
(sourceProgGUI contents (splitProgDefs contents))
[stdin]
main :: IO ()
main = do
args <- getArgs
startGUI (head args)
......@@ -101,6 +105,7 @@ splitProgDefs ptxt =
(\ (mb,i) -> maybe [] (\s->if s `elem` keywords then [] else [(s,i)]) mb)
(zip (map funDefOfLine (lines ptxt)) [1..]))))
groupFuns :: [(String,Int)] -> [(String,(Int,Int))]
groupFuns [] = []
groupFuns [(f,i)] = [(f,(i,i))]
groupFuns [(f1,i1),(f2,i2)] =
......@@ -113,14 +118,17 @@ groupFuns ((f1,i1):(f2,i2):(f3,i3):fis)
| otherwise = (f1,(i1,i2-1)) : groupFuns ((f2,i2):(f3,i3):fis)
-- delete subsequent function definitions
deleteAdjacentFuns :: [(String,Int)] -> [(String,Int)]
deleteAdjacentFuns [] = []
deleteAdjacentFuns [x] = [x]
deleteAdjacentFuns ((f1,i1):(f2,i2):xs) =
if f1==f2 then deleteAdjacentFuns ((f1,i1):xs)
else (f1,i1) : deleteAdjacentFuns ((f2,i2):xs)
keywords :: [String]
keywords = ["module","import","data","infix","infixr","infixl"]
funDefOfLine :: String -> Maybe (String)
funDefOfLine l
| all isSpace l = Nothing
| isAlpha (head l) = Just (head (words l))
......@@ -128,10 +136,12 @@ funDefOfLine l
| isCommentLine l = Just ""
| otherwise = Nothing
isCommentLine :: String -> Bool
isCommentLine l = take 2 (dropWhile isSpace l) == "--"
----------------------------------------------------------------------------
m :: String -> IO ()
m prog = do
filename <- findSourceFileInLoadPath prog
contents <- readFile filename
......
......@@ -135,15 +135,19 @@ funcSetOfExpr (Or e1 e2) = unionRBT (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = unionRBT (funcSetOfExpr e) (unionMap funcSetOfBranch bs)
where funcSetOfBranch (Branch _ be) = funcSetOfExpr be
isConstructorComb :: CombType -> Bool
isConstructorComb ct = case ct of
ConsCall -> True
ConsPartCall _ -> True
_ -> False
unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName
unionMap f = foldr unionRBT emptySet . map f
emptySet :: SetRBT QName
emptySet = emptySetRBT leqQName
leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = leqString (m1++('.':n1)) (m2++('.':n2))
-- end of Dependency
......
......@@ -30,6 +30,7 @@ analyseRightLinearity = analyseWithDependencies hasRightLinearRules and
hasRightLinearRules :: FuncDecl -> Bool
hasRightLinearRules (Func _ _ _ _ rule) = isRightLinearRule rule
isRightLinearRule :: Rule -> Bool
isRightLinearRule (Rule _ e) = linearExpr e
isRightLinearRule (External _) = True
......
......@@ -24,21 +24,27 @@ import ReadNumeric(readNat)
-- Should higher-order calls (i.e., "apply") be implemented as an explicit
-- apply function? Otherwise, they are implemented as anonymous functions.
explicitApply :: Bool
explicitApply = False
-- Optimization options:
-- Optimize single occurrences of variables in JavaScript code?
optimizeSingleVars :: Bool
optimizeSingleVars = True
-- Optimize cases on data types containing only a single constructor?
optimizeUniqueCase :: Bool
optimizeUniqueCase = True
-- Should strings be lazily converted into character lists?
lazyStringConversion :: Bool
lazyStringConversion = True
-- The name of the prelude module:
prelude :: String
prelude = "Prelude"
-- The name of the WUI module:
wuiModName :: String
wuiModName = "WUIjs"
------------------------------------------------------------------------------
......@@ -52,6 +58,7 @@ flatprog2JS (Prog _ _ tdecls allfdecls _) =
where
fdecls = filter isRelevantFunction allfdecls
isRelevantFunction :: FuncDecl -> Bool
isRelevantFunction (Func fname _ _ _ (External _))
| fname `elem` ignoredFunctions = False
| otherwise = error $ "External function "++show fname++" not handled!"
......@@ -59,6 +66,7 @@ isRelevantFunction (Func fname _ _ _ (Rule _ _)) =
fname `notElem` ignoredFunctions
genApply :: [(QName,Int)] -> JSFDecl
genApply fs =
JSFDecl "fullapply" [1,2]
[JSSwitch (JSIArrayIdx 1 0)
......@@ -190,6 +198,7 @@ flatExp2JS _ _ _ _ _ (Or _ _) =
-- Translate list of FlatCurry expressions:
flatExps2JS :: [TypeDecl] -> Int -> Int -> [(Int,(Int,Int))] -> [(Int,Expr)] -> [JSStat]
flatExps2JS _ maxo maxn _ [] | maxn=:=maxo = []
flatExps2JS decls maxo maxn patvars ((retvar,exp):retvarexps) =
JSVarDecl retvar : flatExp2JS decls maxo maxe patvars retvar exp ++
......@@ -199,6 +208,7 @@ flatExps2JS decls maxo maxn patvars ((retvar,exp):retvarexps) =
-- Translate case expressions:
case2JS :: [TypeDecl] -> Int -> Int -> [(Int,(Int,Int))] -> Int -> Expr -> [BranchExpr] -> [JSStat]
case2JS decls maxo maxn patvars retvar cexp branches =
let casevar = maxo+1
max1 free
......@@ -229,6 +239,7 @@ case2JS decls maxo maxn patvars retvar cexp branches =
branchWithUniqueCase (Branch (Pattern cname _) _) =
isUniqueConstructor decls cname
branch2JS :: [TypeDecl] -> Int -> Int -> [(Int,(Int,Int))] -> Int -> Int -> [BranchExpr] -> [JSBranch]
branch2JS _ maxo maxn _ _ _ [] | maxn=:=maxo = []
branch2JS decls maxo maxn patvars casevar retvar
(Branch (Pattern cname cargs) bexp : branches) =
......@@ -251,6 +262,7 @@ isUniqueConstructor (Type _ _ _ cdecls : tdecls) c =
else isUniqueConstructor tdecls c
-- Translate if-then-else
ite2JS :: [TypeDecl] -> Int -> Int -> [(Int,(Int,Int))] -> Int -> Expr -> Expr -> Expr -> [JSStat]
ite2JS decls maxo maxn patvars retvar bexp exp1 exp2 =
let ifretvar = maxo+1
max1,max2 free
......@@ -262,6 +274,7 @@ ite2JS decls maxo maxn patvars retvar bexp exp1 exp2 =
-- translates a function call into the corresponding JavaScript operator
-- or function call:
curryFunc2JSFunc :: QName -> [JSExp] -> JSExp
curryFunc2JSFunc fname args = case args of
[a1,a2] -> maybe (let jsfname = qname2JS fname in
if jsfname/="apply" || explicitApply
......@@ -271,6 +284,7 @@ curryFunc2JSFunc fname args = case args of
(lookup fname jsOperators)
_ -> JSFCall (qname2JS fname) args
consQName2JS :: QName -> String
consQName2JS qname@(md,f)
| take 2 f == "(," = f
| otherwise = maybe (md ++ "_" ++ encodeCurryId f)
......@@ -278,12 +292,14 @@ consQName2JS qname@(md,f)
(lookup qname jsConstructors)
qname2JS :: QName -> String
qname2JS qname@(md,f) =
maybe (md ++ "_" ++ encodeCurryId f)
id
(lookup qname (jsFunctions++jsOperators))
-- encode a Curry identifier into a form allowed in JavaScript:
encodeCurryId :: String -> String
encodeCurryId [] = []
encodeCurryId (c:cs)
| isAlphaNum c = c : encodeCurryId cs
......@@ -293,6 +309,7 @@ encodeCurryId (c:cs)
int2hex i = if i<10 then chr (ord '0' + i)
else chr (ord 'A' + i - 10)
jsFunctions :: [(QName,String)]
jsFunctions =
[((prelude,"apply"),"apply"),
((prelude,"$#"),"apply"),
......@@ -305,11 +322,13 @@ jsFunctions =
((prelude,"failed"),"alertFailed"),
((prelude,"=="),"boolEq")]
jsConstructors :: [(QName,String)]
jsConstructors =
[((prelude,":"),":"),
((prelude,"[]"),"[]")
]
jsOperators :: [(QName,String)]
jsOperators =
[((prelude,"+"),"+"),
((prelude,"-"),"-"),
......@@ -324,6 +343,7 @@ jsOperators =
((prelude,"<"),"<")
]
ignoredFunctions :: [QName]
ignoredFunctions =
map fst (jsFunctions ++ jsOperators) ++
[(prelude,"prim_Int_plus"),(prelude,"prim_Int_minus"),
......@@ -361,6 +381,7 @@ freeVarsInExp (Let bs e) = let (bvs,bes) = unzip bs in
freeVarsInExp (Free vs exp) = filter (`notElem` vs) (freeVarsInExp exp)
freeVarsInExp (Case _ e bs) = freeVarsInExp e ++ concatMap freeVarsInBranch bs
freeVarsInBranch :: BranchExpr -> [Int]
freeVarsInBranch (Branch (Pattern _ vs) e) =
filter (`notElem` vs) (freeVarsInExp e)
freeVarsInBranch (Branch (LPattern _) e) = freeVarsInExp e
......@@ -385,14 +406,18 @@ maxVarIndexInExp exp = let allvars = allVarsInExp exp in
------------------------------------------------------------------------------
-- compute all partially applied functions in a program:
pafsOfProg :: Prog -> [(QName,Int)]
pafsOfProg (Prog _ _ _ fdecls _) =
pafsOfFuncs (filter isRelevantFunction fdecls)
pafsOfFuncs :: [FuncDecl] -> [(QName,Int)]
pafsOfFuncs fdecls = mapUnion (map pafsOfFunc fdecls)
pafsOfFunc :: FuncDecl -> [(QName,Int)]
pafsOfFunc (Func _ _ _ _ (External _)) = []
pafsOfFunc (Func _ _ _ _ (Rule _ exp)) = pafsOfExpr exp
pafsOfExpr :: Expr -> [(QName,Int)]
pafsOfExpr (Var _) = []
pafsOfExpr (Lit _) = []
pafsOfExpr (Comb FuncCall _ args) = mapUnion (map pafsOfExpr args)
......@@ -407,6 +432,7 @@ pafsOfExpr (Let defs exp) =
pafsOfExpr (Free _ exp) = pafsOfExpr exp
pafsOfExpr (Or exp1 exp2) = union (pafsOfExpr exp1) (pafsOfExpr exp2)
mapUnion :: [[a]] -> [a]
mapUnion = foldr union []
------------------------------------------------------------------------------
......@@ -417,11 +443,14 @@ mapUnion = foldr union []
jscOfProg :: Prog -> [(QName,Bool)]
jscOfProg (Prog _ _ _ fdecls _) = jscOfFuncs fdecls
jscOfFuncs :: [FuncDecl] -> [(QName,Bool)]
jscOfFuncs fdecls = mapUnion (map jscOfFunc fdecls)