Commit 3fb17eef authored by Michael Hanus's avatar Michael Hanus
Browse files

Tools updated

parent cf2d729e
...@@ -13,6 +13,8 @@ optimize/.cpm/packages/currypath-0.0.1 ...@@ -13,6 +13,8 @@ optimize/.cpm/packages/currypath-0.0.1
optimize/.cpm/packages/flatcurry-2.0.0 optimize/.cpm/packages/flatcurry-2.0.0
optimize/.cpm/packages/frontend-exec-0.0.1 optimize/.cpm/packages/frontend-exec-0.0.1
optimize/.cpm/packages/propertyfile-0.0.1 optimize/.cpm/packages/propertyfile-0.0.1
optimize/.cpm/packages/random-0.0.1
optimize/.cpm/packages/redblacktree-0.0.1
optimize/.cpm/packages/scc-0.0.1 optimize/.cpm/packages/scc-0.0.1
optimize/.cpm/packages/socket-0.0.1 optimize/.cpm/packages/socket-0.0.1
optimize/.cpm/packages/xml-2.0.0 optimize/.cpm/packages/xml-2.0.0
......
...@@ -20,9 +20,10 @@ module CPM.LookupSet ...@@ -20,9 +20,10 @@ module CPM.LookupSet
) where ) where
import List (sortBy, delete, deleteBy) import List (sortBy, delete, deleteBy)
import TableRBT
import Test.EasyCheck import Test.EasyCheck
import Data.Table.RBTree as Table ( TableRBT, empty, lookup, toList,update )
import CPM.Package import CPM.Package
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
...@@ -40,7 +41,7 @@ data LookupOptions = LookupOptions ...@@ -40,7 +41,7 @@ data LookupOptions = LookupOptions
--- The empty lookup set. --- The empty lookup set.
emptySet :: LookupSet emptySet :: LookupSet
emptySet = LookupSet (emptyTableRBT (<=)) defaultOptions emptySet = LookupSet (empty (<=)) defaultOptions
defaultOptions :: LookupOptions defaultOptions :: LookupOptions
defaultOptions = LookupOptions [] defaultOptions = LookupOptions []
...@@ -60,7 +61,7 @@ addPackages :: LookupSet -> [Package] -> LookupSource -> LookupSet ...@@ -60,7 +61,7 @@ addPackages :: LookupSet -> [Package] -> LookupSource -> LookupSet
addPackages ls pkgs src = foldl (\l p -> addPackage l p src) ls pkgs addPackages ls pkgs src = foldl (\l p -> addPackage l p src) ls pkgs
allPackages :: LookupSet -> [Package] allPackages :: LookupSet -> [Package]
allPackages (LookupSet ls _) = map snd $ concat $ map snd $ tableRBT2list ls allPackages (LookupSet ls _) = map snd $ concat $ map snd $ toList ls
--- Adds a package to a lookup set. --- Adds a package to a lookup set.
--- ---
...@@ -68,10 +69,10 @@ allPackages (LookupSet ls _) = map snd $ concat $ map snd $ tableRBT2list ls ...@@ -68,10 +69,10 @@ allPackages (LookupSet ls _) = map snd $ concat $ map snd $ tableRBT2list ls
--- @param p the package to add --- @param p the package to add
--- @param s where is the package spec from? --- @param s where is the package spec from?
addPackage :: LookupSet -> Package -> LookupSource -> LookupSet addPackage :: LookupSet -> Package -> LookupSource -> LookupSet
addPackage (LookupSet ls o) pkg src = case lookupRBT (name pkg) ls of addPackage (LookupSet ls o) pkg src = case Table.lookup (name pkg) ls of
Nothing -> LookupSet (updateRBT (name pkg) [(src, pkg)] ls) o Nothing -> LookupSet (update (name pkg) [(src, pkg)] ls) o
Just ps -> let ps' = filter ((/= packageId pkg) . packageId . snd) ps Just ps -> let ps' = filter ((/= packageId pkg) . packageId . snd) ps
in LookupSet (updateRBT (name pkg) ((src, pkg):ps') ls) o in LookupSet (update (name pkg) ((src, pkg):ps') ls) o
--- Finds a specific entry (including the source) in the lookup set. --- Finds a specific entry (including the source) in the lookup set.
--- ---
...@@ -80,7 +81,7 @@ addPackage (LookupSet ls o) pkg src = case lookupRBT (name pkg) ls of ...@@ -80,7 +81,7 @@ addPackage (LookupSet ls o) pkg src = case lookupRBT (name pkg) ls of
findEntry :: LookupSet -> Package -> Maybe (LookupSource, Package) findEntry :: LookupSet -> Package -> Maybe (LookupSource, Package)
findEntry (LookupSet ls _) p = maybeHead candidates findEntry (LookupSet ls _) p = maybeHead candidates
where where
allVersions = lookupRBT (name p) ls allVersions = Table.lookup (name p) ls
candidates = case allVersions of candidates = case allVersions of
Nothing -> [] Nothing -> []
Just ps -> filter ((packageIdEq p) . snd) ps Just ps -> filter ((packageIdEq p) . snd) ps
...@@ -95,7 +96,7 @@ findEntry (LookupSet ls _) p = maybeHead candidates ...@@ -95,7 +96,7 @@ findEntry (LookupSet ls _) p = maybeHead candidates
findAllVersions :: LookupSet -> String -> Bool -> [Package] findAllVersions :: LookupSet -> String -> Bool -> [Package]
findAllVersions (LookupSet ls o) p pre = localSorted' ++ nonLocalSorted findAllVersions (LookupSet ls o) p pre = localSorted' ++ nonLocalSorted
where where
packageVersions = case lookupRBT p ls of packageVersions = case Table.lookup p ls of
Nothing -> [] Nothing -> []
Just vs -> vs Just vs -> vs
onlyLocal = filter isLocal packageVersions onlyLocal = filter isLocal packageVersions
......
...@@ -12,6 +12,7 @@ ...@@ -12,6 +12,7 @@
"currypath" : ">= 0.0.1", "currypath" : ">= 0.0.1",
"flatcurry" : ">= 2.0.0", "flatcurry" : ">= 2.0.0",
"propertyfile" : ">= 0.0.1", "propertyfile" : ">= 0.0.1",
"redblacktree" : ">= 0.0.1",
"scc" : ">= 0.0.1", "scc" : ">= 0.0.1",
"socket" : ">= 0.0.1", "socket" : ">= 0.0.1",
"xml" : ">= 2.0.0" "xml" : ">= 2.0.0"
......
...@@ -8,8 +8,9 @@ ...@@ -8,8 +8,9 @@
module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where
import FlatCurry.Types import FlatCurry.Types
import List import List ( nub )
import SetRBT
import Data.Set.RBTree ( SetRBT, empty, insert, toList, union)
--- Return the type constructors occurring in a type declaration. --- Return the type constructors occurring in a type declaration.
dependsDirectlyOnTypes :: TypeDecl -> [QName] dependsDirectlyOnTypes :: TypeDecl -> [QName]
...@@ -31,7 +32,7 @@ tconsOf (ForallType _ te) = tconsOf te ...@@ -31,7 +32,7 @@ tconsOf (ForallType _ te) = tconsOf te
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- list of direct dependencies for a function -- list of direct dependencies for a function
callsDirectly :: FuncDecl -> [QName] callsDirectly :: FuncDecl -> [QName]
callsDirectly fun = setRBT2list (snd (directlyDependent fun)) callsDirectly fun = toList (snd (directlyDependent fun))
-- set of direct dependencies for a function -- set of direct dependencies for a function
directlyDependent :: FuncDecl -> (QName,SetRBT QName) directlyDependent :: FuncDecl -> (QName,SetRBT QName)
...@@ -45,12 +46,12 @@ funcSetOfExpr (Var _) = emptySet ...@@ -45,12 +46,12 @@ funcSetOfExpr (Var _) = emptySet
funcSetOfExpr (Lit _) = emptySet funcSetOfExpr (Lit _) = emptySet
funcSetOfExpr (Comb ct f es) = funcSetOfExpr (Comb ct f es) =
if isConstructorComb ct then unionMap funcSetOfExpr es if isConstructorComb ct then unionMap funcSetOfExpr es
else insertRBT f (unionMap funcSetOfExpr es) else insert f (unionMap funcSetOfExpr es)
funcSetOfExpr (Free _ e) = funcSetOfExpr e funcSetOfExpr (Free _ e) = funcSetOfExpr e
funcSetOfExpr (Let bs e) = unionRBT (unionMap (funcSetOfExpr . snd) bs) funcSetOfExpr (Let bs e) = union (unionMap (funcSetOfExpr . snd) bs)
(funcSetOfExpr e) (funcSetOfExpr e)
funcSetOfExpr (Or e1 e2) = unionRBT (funcSetOfExpr e1) (funcSetOfExpr e2) funcSetOfExpr (Or e1 e2) = union (funcSetOfExpr e1) (funcSetOfExpr e2)
funcSetOfExpr (Case _ e bs) = unionRBT (funcSetOfExpr e) funcSetOfExpr (Case _ e bs) = union (funcSetOfExpr e)
(unionMap funcSetOfBranch bs) (unionMap funcSetOfBranch bs)
where funcSetOfBranch (Branch _ be) = funcSetOfExpr be where funcSetOfBranch (Branch _ be) = funcSetOfExpr be
funcSetOfExpr (Typed e _) = funcSetOfExpr e funcSetOfExpr (Typed e _) = funcSetOfExpr e
...@@ -62,10 +63,10 @@ isConstructorComb ct = case ct of ...@@ -62,10 +63,10 @@ isConstructorComb ct = case ct of
_ -> False _ -> False
unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName
unionMap f = foldr unionRBT emptySet . map f unionMap f = foldr union emptySet . map f
emptySet :: SetRBT QName emptySet :: SetRBT QName
emptySet = emptySetRBT leqQName emptySet = empty leqQName
leqQName :: QName -> QName -> Bool leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2) leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2)
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
--- In particular, it contains some simple fixpoint computations. --- In particular, it contains some simple fixpoint computations.
--- ---
--- @author Heiko Hoffmann, Michael Hanus --- @author Heiko Hoffmann, Michael Hanus
--- @version September 2018 --- @version December 2018
-------------------------------------------------------------------------- --------------------------------------------------------------------------
module CASS.WorkerFunctions where module CASS.WorkerFunctions where
...@@ -12,7 +12,6 @@ import FiniteMap ...@@ -12,7 +12,6 @@ import FiniteMap
import IOExts import IOExts
import List ( partition ) import List ( partition )
import Maybe ( fromJust ) import Maybe ( fromJust )
import SetRBT
import System ( getCPUTime ) import System ( getCPUTime )
import Analysis.Files import Analysis.Files
...@@ -26,6 +25,7 @@ import FlatCurry.Types ...@@ -26,6 +25,7 @@ import FlatCurry.Types
import FlatCurry.Files import FlatCurry.Files
import FlatCurry.Goodies import FlatCurry.Goodies
import Data.SCC ( scc ) import Data.SCC ( scc )
import Data.Set.RBTree as Set ( SetRBT, member, empty, insert, null )
import CASS.Configuration import CASS.Configuration
import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes ) import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes )
...@@ -193,17 +193,17 @@ runAnalysis analysis prog importInfos startvals fpmethod = do ...@@ -193,17 +193,17 @@ runAnalysis analysis prog importInfos startvals fpmethod = do
SimpleTypeAnalysis _ _ -> SimpleTypeAnalysis _ _ ->
(definedTypes, typeInfos2ProgInfo defaultTypes deflts) (definedTypes, typeInfos2ProgInfo defaultTypes deflts)
SimpleConstructorAnalysis _ _ -> -- there are no external constructors SimpleConstructorAnalysis _ _ -> -- there are no external constructors
if null deflts then (prog,emptyProgInfo) if Prelude.null deflts then (prog,emptyProgInfo)
else error "SimpleConstructorAnalysis with default values!" else error "SimpleConstructorAnalysis with default values!"
DependencyFuncAnalysis _ _ _ -> DependencyFuncAnalysis _ _ _ ->
(definedFuncs, funcInfos2ProgInfo defaultFuncs deflts) (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts)
DependencyTypeAnalysis _ _ _ -> DependencyTypeAnalysis _ _ _ ->
(definedTypes, typeInfos2ProgInfo defaultTypes deflts) (definedTypes, typeInfos2ProgInfo defaultTypes deflts)
SimpleModuleAnalysis _ _ -> SimpleModuleAnalysis _ _ ->
if null deflts then (definedFuncs, emptyProgInfo) if Prelude.null deflts then (definedFuncs, emptyProgInfo)
else error defaultNotEmptyError else error defaultNotEmptyError
DependencyModuleAnalysis _ _ -> DependencyModuleAnalysis _ _ ->
if null deflts then (definedFuncs, emptyProgInfo) if Prelude.null deflts then (definedFuncs, emptyProgInfo)
else error defaultNotEmptyError else error defaultNotEmptyError
_ -> error "Internal error in WorkerFunctions.runAnalysis" _ -> error "Internal error in WorkerFunctions.runAnalysis"
let result = executeAnalysis analysis progWithoutDefaults let result = executeAnalysis analysis progWithoutDefaults
...@@ -260,7 +260,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog ...@@ -260,7 +260,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog
"wlist" -> "wlist" ->
let declsWithDeps = map addCalledFunctions (progFuncs prog) let declsWithDeps = map addCalledFunctions (progFuncs prog)
in funcInfos2ProgInfo prog $ fmToList $ in funcInfos2ProgInfo prog $ fmToList $
wlIteration anaFunc funcName declsWithDeps [] (emptySetRBT (<)) wlIteration anaFunc funcName declsWithDeps [] (empty (<))
importInfos (listToFM (<) startvals) importInfos (listToFM (<) startvals)
"wlistscc" -> "wlistscc" ->
let declsWithDeps = map addCalledFunctions (progFuncs prog) let declsWithDeps = map addCalledFunctions (progFuncs prog)
...@@ -268,7 +268,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog ...@@ -268,7 +268,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog
sccDecls = scc ((:[]) . funcName . fst) snd declsWithDeps sccDecls = scc ((:[]) . funcName . fst) snd declsWithDeps
in funcInfos2ProgInfo prog $ fmToList $ in funcInfos2ProgInfo prog $ fmToList $
foldr (\scc sccstartvals -> foldr (\scc sccstartvals ->
wlIteration anaFunc funcName scc [] (emptySetRBT (<)) wlIteration anaFunc funcName scc [] (empty (<))
importInfos sccstartvals) importInfos sccstartvals)
(listToFM (<) startvals) (listToFM (<) startvals)
(reverse sccDecls) (reverse sccDecls)
...@@ -284,7 +284,7 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog ...@@ -284,7 +284,7 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
"wlist" -> "wlist" ->
let declsWithDeps = map addUsedTypes (progTypes prog) let declsWithDeps = map addUsedTypes (progTypes prog)
in typeInfos2ProgInfo prog $ fmToList $ in typeInfos2ProgInfo prog $ fmToList $
wlIteration anaType typeName declsWithDeps [] (emptySetRBT (<)) wlIteration anaType typeName declsWithDeps [] (empty (<))
importInfos (listToFM (<) startvals) importInfos (listToFM (<) startvals)
"wlistscc" -> "wlistscc" ->
let declsWithDeps = map addUsedTypes (progTypes prog) let declsWithDeps = map addUsedTypes (progTypes prog)
...@@ -292,7 +292,7 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog ...@@ -292,7 +292,7 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
sccDecls = scc ((:[]) . typeName . fst) snd declsWithDeps sccDecls = scc ((:[]) . typeName . fst) snd declsWithDeps
in typeInfos2ProgInfo prog $ fmToList $ in typeInfos2ProgInfo prog $ fmToList $
foldr (\scc sccstartvals -> foldr (\scc sccstartvals ->
wlIteration anaType typeName scc [] (emptySetRBT (<)) wlIteration anaType typeName scc [] (empty (<))
importInfos sccstartvals) importInfos sccstartvals)
(listToFM (<) startvals) (listToFM (<) startvals)
(reverse sccDecls) (reverse sccDecls)
...@@ -359,13 +359,13 @@ wlIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName) ...@@ -359,13 +359,13 @@ wlIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName)
-- importInfos currvals -- importInfos currvals
wlIteration analysis nameOf [] alldecls changedEntities importInfos currvals = wlIteration analysis nameOf [] alldecls changedEntities importInfos currvals =
if isEmptySetRBT changedEntities if Set.null changedEntities
then currvals -- no todos, no changed values, so we are done: then currvals -- no todos, no changed values, so we are done:
else -- all declarations processed, compute todos for next round: else -- all declarations processed, compute todos for next round:
let (declsToDo,declsDone) = let (declsToDo,declsDone) =
partition (\ (_,calls) -> any (`elemRBT` changedEntities) calls) partition (\ (_,calls) -> any (`member` changedEntities) calls)
alldecls alldecls
in wlIteration analysis nameOf declsToDo declsDone (emptySetRBT (<)) in wlIteration analysis nameOf declsToDo declsDone (empty (<))
importInfos currvals importInfos currvals
-- process a single declaration: -- process a single declaration:
wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone
...@@ -380,7 +380,7 @@ wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone ...@@ -380,7 +380,7 @@ wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone
then wlIteration analysis nameOf decls (decldeps:declsDone) then wlIteration analysis nameOf decls (decldeps:declsDone)
changedEntities importInfos currvals changedEntities importInfos currvals
else wlIteration analysis nameOf decls (decldeps:declsDone) else wlIteration analysis nameOf decls (decldeps:declsDone)
(insertRBT decname changedEntities) importInfos (insert decname changedEntities) importInfos
(updFM currvals decname (const newval)) (updFM currvals decname (const newval))
......
...@@ -10,6 +10,7 @@ ...@@ -10,6 +10,7 @@
"base" : ">= 1.0.0, < 2.0.0", "base" : ">= 1.0.0, < 2.0.0",
"currypath" : ">= 0.0.1", "currypath" : ">= 0.0.1",
"frontend-exec" : ">= 0.0.1", "frontend-exec" : ">= 0.0.1",
"redblacktree" : ">= 0.0.1",
"wl-pprint" : ">= 0.0.1", "wl-pprint" : ">= 0.0.1",
"xml" : ">= 2.0.0" "xml" : ">= 2.0.0"
}, },
......
...@@ -14,19 +14,20 @@ module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry, ...@@ -14,19 +14,20 @@ module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry,
Option(..),RequiredSpec,requires,alwaysRequired, Option(..),RequiredSpec,requires,alwaysRequired,
defaultRequired) where defaultRequired) where
import FlatCurry.Types import Directory
import FlatCurry.Files
import SetRBT
import TableRBT
import Maybe
import List ( nub, union )
import FileGoodies import FileGoodies
import FilePath ( takeFileName, (</>) ) import FilePath ( takeFileName, (</>) )
import Directory import List ( nub, union )
import Maybe
import Sort ( cmpString, leqString ) import Sort ( cmpString, leqString )
import XML import XML
import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix ) import Data.Set.RBTree as Set ( SetRBT, member, empty, insert )
import Data.Table.RBTree as Table ( TableRBT, empty, lookup, update )
import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix )
import FlatCurry.Types
import FlatCurry.Files
infix 0 `requires` infix 0 `requires`
...@@ -180,7 +181,7 @@ computeCompactFlatCurry orgoptions progname = ...@@ -180,7 +181,7 @@ computeCompactFlatCurry orgoptions progname =
makeCompactFlatCurry :: Prog -> [Option] -> IO Prog makeCompactFlatCurry :: Prog -> [Option] -> IO Prog
makeCompactFlatCurry mainmod options = do makeCompactFlatCurry mainmod options = do
(initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options (initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options
let initFuncTable = extendFuncTable (emptyTableRBT leqQName) let initFuncTable = extendFuncTable (Table.empty leqQName)
(concatMap moduleFuns loadedmods) (concatMap moduleFuns loadedmods)
required = getRequiredFromOptions options required = getRequiredFromOptions options
loadedreqfuns = concatMap (getRequiredInModule required) loadedreqfuns = concatMap (getRequiredInModule required)
...@@ -189,8 +190,8 @@ makeCompactFlatCurry mainmod options = do ...@@ -189,8 +190,8 @@ makeCompactFlatCurry mainmod options = do
(finalmods,finalfuncs,finalcons,finaltcons) <- (finalmods,finalfuncs,finalcons,finaltcons) <-
getCalledFuncs required getCalledFuncs required
loadedmnames loadedmods initFuncTable loadedmnames loadedmods initFuncTable
(foldr insertRBT (emptySetRBT leqQName) initreqfuncs) (foldr insert (Set.empty leqQName) initreqfuncs)
(emptySetRBT leqQName) (emptySetRBT leqQName) (Set.empty leqQName) (Set.empty leqQName)
initreqfuncs initreqfuncs
putStrLn ("\nCompactFlat: Total number of functions (without unused imports): " putStrLn ("\nCompactFlat: Total number of functions (without unused imports): "
++ show (foldr (+) 0 (map (length . moduleFuns) finalmods))) ++ show (foldr (+) 0 (map (length . moduleFuns) finalmods)))
...@@ -201,7 +202,7 @@ makeCompactFlatCurry mainmod options = do ...@@ -201,7 +202,7 @@ makeCompactFlatCurry mainmod options = do
reqTCons = extendTConsWithConsType finalcons finaltcons reqTCons = extendTConsWithConsType finalcons finaltcons
allTDecls allTDecls
allReqTCons = requiredDatatypes reqTCons allTDecls allReqTCons = requiredDatatypes reqTCons allTDecls
in filter (\tdecl->tconsName tdecl `elemRBT` allReqTCons) in filter (\tdecl->tconsName tdecl `member` allReqTCons)
allTDecls) allTDecls)
finalfuncs finalfuncs
(filter (\ (Op oname _ _) -> oname `elem` finalfnames) (filter (\ (Op oname _ _) -> oname `elem` finalfnames)
...@@ -215,18 +216,18 @@ requiredDatatypes tcnames tdecls = ...@@ -215,18 +216,18 @@ requiredDatatypes tcnames tdecls =
let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls
in if null newtcons in if null newtcons
then tcnames then tcnames
else requiredDatatypes (foldr insertRBT tcnames newtcons) tdecls else requiredDatatypes (foldr insert tcnames newtcons) tdecls
-- Extract the new type constructors (w.r.t. a given set) contained in a -- Extract the new type constructors (w.r.t. a given set) contained in a
-- type declaration: -- type declaration:
newTypeConsOfTDecl :: SetRBT QName -> TypeDecl -> [QName] newTypeConsOfTDecl :: SetRBT QName -> TypeDecl -> [QName]
newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) = newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) =
if tcons `elemRBT` tcnames if tcons `member` tcnames
then filter (\tc -> not (tc `elemRBT` tcnames)) (allTypesOfTExpr texp) then filter (\tc -> not (tc `member` tcnames)) (allTypesOfTExpr texp)
else [] else []
newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) = newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) =
if tcons `elemRBT` tcnames if tcons `member` tcnames
then filter (\tc -> not (tc `elemRBT` tcnames)) then filter (\tc -> not (tc `member` tcnames))
(concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps) (concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps)
cdecls) cdecls)
else [] else []
...@@ -237,11 +238,11 @@ extendTConsWithConsType :: SetRBT QName -> SetRBT QName -> [TypeDecl] ...@@ -237,11 +238,11 @@ extendTConsWithConsType :: SetRBT QName -> SetRBT QName -> [TypeDecl]
-> SetRBT QName -> SetRBT QName
extendTConsWithConsType _ tcons [] = tcons extendTConsWithConsType _ tcons [] = tcons
extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) = extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) =
extendTConsWithConsType cnames (insertRBT tname tcons) tds extendTConsWithConsType cnames (insert tname tcons) tds
extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) = extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
if tname `elem` defaultRequiredTypes || if tname `elem` defaultRequiredTypes ||
any (\cdecl->consName cdecl `elemRBT` cnames) cdecls any (\cdecl->consName cdecl `member` cnames) cdecls
then extendTConsWithConsType cnames (insertRBT tname tcons) tds then extendTConsWithConsType cnames (insert tname tcons) tds
else extendTConsWithConsType cnames tcons tds else extendTConsWithConsType cnames tcons tds
-- Extend function table (mapping from qualified names to function declarations) -- Extend function table (mapping from qualified names to function declarations)
...@@ -249,7 +250,7 @@ extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) = ...@@ -249,7 +250,7 @@ extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
extendFuncTable :: TableRBT QName FuncDecl -> [FuncDecl] extendFuncTable :: TableRBT QName FuncDecl -> [FuncDecl]
-> TableRBT QName FuncDecl -> TableRBT QName FuncDecl
extendFuncTable ftable fdecls = extendFuncTable ftable fdecls =
foldr (\f t -> updateRBT (functionName f) f t) ftable fdecls foldr (\f t -> update (functionName f) f t) ftable fdecls
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
...@@ -289,9 +290,9 @@ requiredInCompactProg mainmod options ...@@ -289,9 +290,9 @@ requiredInCompactProg mainmod options
mainexports = exportedFuncNames (moduleFuns mainmod) mainexports = exportedFuncNames (moduleFuns mainmod)
mainmodset = insertRBT mainmodname (emptySetRBT leqString) mainmodset = insert mainmodname (Set.empty leqString)
add2mainmodset mnames = foldr insertRBT mainmodset mnames add2mainmodset mnames = foldr insert mainmodset mnames
-- extract the names of all exported functions: -- extract the names of all exported functions:
...@@ -321,30 +322,30 @@ getCalledFuncs :: [RequiredSpec] -> SetRBT String -> [Prog] ...@@ -321,30 +322,30 @@ getCalledFuncs :: [RequiredSpec] -> SetRBT String -> [Prog]
getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts) getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts)
getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames
loadedtnames ((m,f):fs) loadedtnames ((m,f):fs)
| not (elemRBT m loadedmnames) | not (member m loadedmnames)
= do newmod <- readCurrentFlatCurry m = do newmod <- readCurrentFlatCurry m
let reqnewfun = getRequiredInModule required m let reqnewfun = getRequiredInModule required m
getCalledFuncs required (insertRBT m loadedmnames) (newmod:progs) getCalledFuncs required (insert m loadedmnames) (newmod:progs)
(extendFuncTable functable (moduleFuns newmod)) (extendFuncTable functable (moduleFuns newmod))
(foldr insertRBT loadedfnames reqnewfun) loadedcnames (foldr insert loadedfnames reqnewfun) loadedcnames
loadedtnames ((m,f):fs ++ reqnewfun) loadedtnames ((m,f):fs ++ reqnewfun)
| isNothing (lookupRBT (m,f) functable) | isNothing (Table.lookup (m,f) functable)
= -- this must be a data constructor: ingore it since already considered = -- this must be a data constructor: ingore it since already considered
getCalledFuncs required loadedmnames progs getCalledFuncs required loadedmnames progs
functable loadedfnames loadedcnames loadedtnames fs functable loadedfnames loadedcnames loadedtnames fs
| otherwise = do | otherwise = do
let fdecl = fromJust (lookupRBT (m,f) functable) let fdecl = fromJust (Table.lookup (m,f) functable)
funcCalls = allFuncCalls fdecl funcCalls = allFuncCalls fdecl
newFuncCalls = filter (\qn->not (elemRBT qn loadedfnames)) funcCalls newFuncCalls = filter (\qn->not (member qn loadedfnames)) funcCalls
newReqs = concatMap (getImplicitlyRequired required) newFuncCalls newReqs = concatMap (getImplicitlyRequired required) newFuncCalls
consCalls = allConstructorsOfFunc fdecl consCalls = allConstructorsOfFunc fdecl
newConsCalls = filter (\qn->not (elemRBT qn loadedcnames)) consCalls newConsCalls = filter (\qn->not (member qn loadedcnames)) consCalls
newtcons = allTypesOfFunc fdecl newtcons = allTypesOfFunc fdecl
(newprogs,newfuns,newcons, newtypes) <- (newprogs,newfuns,newcons, newtypes) <-
getCalledFuncs required loadedmnames progs functable getCalledFuncs required loadedmnames progs functable
(foldr insertRBT loadedfnames (newFuncCalls++newReqs)) (foldr insert loadedfnames (newFuncCalls++newReqs))
(foldr insertRBT loadedcnames consCalls) (foldr insert loadedcnames consCalls)
(foldr insertRBT loadedtnames newtcons) (foldr insert loadedtnames newtcons)
(fs ++ newFuncCalls ++ newReqs ++ newConsCalls) (fs ++ newFuncCalls ++ newReqs ++ newConsCalls)
return (newprogs, fdecl:newfuns, newcons, newtypes) return (newprogs, fdecl:newfuns, newcons, newtypes)
...@@ -525,7 +526,7 @@ mergePrimSpecIntoModule trans (Prog name imps types funcs ops) = ...@@ -525,7 +526,7 @@ mergePrimSpecIntoModule trans (Prog name imps types funcs ops) =
mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl] mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl]
mergePrimSpecIntoFunc trans (Func name ar vis tp rule) = mergePrimSpecIntoFunc trans (Func name ar vis tp rule) =
let fname = lookup name trans in let fname = Prelude.lookup name trans in
if fname==Nothing if fname==Nothing
then [Func name ar vis tp rule] then [Func name ar vis tp rule]
else let Just (lib,entry) = fname else let Just (lib,entry) = fname
......
Copyright (c) 2018, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the names of the copyright holders nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
random
======
This package contains the library `System.Random`
for pseudo-random number generation in Curry.