Commit b1196e71 authored by bbr's avatar bbr
Browse files

the prophecy transformation is now working with higher order types

- make is now more general and holds information about each module
- Transform uses the more general make to record info about data constructors with ho-arguments
parent 2a7337ac
...@@ -12,6 +12,7 @@ module Make ( ...@@ -12,6 +12,7 @@ module Make (
make, obsolete) where make, obsolete) where
import FlatCurry import FlatCurry
import FlatCurryGoodies (progImports)
import Distribution import Distribution
import FiniteMap import FiniteMap
import IOExts import IOExts
...@@ -24,51 +25,55 @@ type ModuleName = String ...@@ -24,51 +25,55 @@ type ModuleName = String
type Path = String type Path = String
type FileName = String type FileName = String
type TestAct = Path -> ModuleName -> IO Bool type TestAct a = Path -> ModuleName -> IO (Maybe a)
type ProgAct = Path -> Prog -> IO () type ProgAct a = Path -> [a] -> Prog -> IO a
type Done = IORef (FM String ()) type Done a = IORef (FM String a)
--- calls act on each imported module transitevely --- calls act on each imported module transitevely
--- if test was True. --- if test was True.
make :: ModuleName -> TestAct -> ProgAct -> IO () make :: ModuleName -> TestAct a -> ProgAct a -> IO ()
make modu test act = do make modu test act = do
putStrLn "ensuring existence of fcy/fint files..." putStrLn "ensuring existence of fcy/fint files..."
callFrontend FCY modu callFrontend FCY modu
putStrLn "...ensured" putStrLn "...ensured"
done <- newIORef (emptyFM (\ x y -> not (leqString x y))) done <- newIORef (emptyFM (\ x y -> not (leqString x y)))
workUpDependence done test act modu workUpDependence done test act modu
return ()
workUpDependence :: Done -> TestAct -> ProgAct -> ModuleName -> IO () workUpDependence :: Done a -> TestAct a -> ProgAct a -> ModuleName -> IO a
workUpDependence done test act modu = do workUpDependence done test act modu = do
fm <- readIORef done fm <- readIORef done
maybe (process fm done test act modu) (const (return ())) (lookupFM fm modu) maybe (process done test act modu) return (lookupFM fm modu)
process :: FM String () -> Done -> TestAct -> ProgAct -> ModuleName -> IO () process :: Done a -> TestAct a -> ProgAct a -> ModuleName -> IO a
process fm done test act modu = do process done test act modu = do
fn <- findFileInLoadPath (modu++".fcy") fn <- findFileInLoadPath (modu++".fcy")
writeIORef done (addToFM fm modu ()) imps <- fastReadImports fn >>= mapIO (workUpDependence done test act)
imps <- fastReadImports fn
mapIO_ (workUpDependence done test act) imps
let dir = dirName fn++"/" let dir = dirName fn++"/"
mk <- test dir modu result <- test dir modu >>=
if mk then (readFlatCurryFile fn >>= act dir) else return () maybe (readFlatCurryFile fn >>= act dir imps) return
updateIORef done (\fm -> addToFM fm modu result)
return result
--- a standard test if a given filename is newer than another --- a standard test if a given filename is newer than another
obsolete :: (String -> String) -> (String -> String) -> TestAct obsolete :: (String -> String) -> (String -> String) -> (String -> IO a) -> TestAct a
obsolete f1 f2 dir modu = do obsolete f1 f2 action dir modu = do
let fn1 = dir++f1 modu let fn1 = dir++f1 modu
fn2 = dir++f2 modu fn2 = dir++f2 modu
ex <- doesFileExist fn2 ex <- doesFileExist fn2
if ex then do if ex then do
t1 <- getModificationTime fn1 t1 <- getModificationTime fn1
t2 <- getModificationTime fn2 t2 <- getModificationTime fn2
let old = compareClockTime t1 t2/=LT if compareClockTime t1 t2/=LT
putStrLn $ (if old then "obsolete : " then do
else "up-to-date: ") ++ f2 modu putStrLn $ "obsolete : " ++ f2 modu
return old return Nothing
else do
putStrLn $ "up-to-date: " ++ f2 modu
action fn1 >>= return . Just
else putStrLn ("missing : "++ f2 modu) >> else putStrLn ("missing : "++ f2 modu) >>
return True return Nothing
fastReadImports :: FileName -> IO [String] fastReadImports :: FileName -> IO [String]
fastReadImports fn = do fastReadImports fn = do
...@@ -80,6 +85,12 @@ strings [] = [] ...@@ -80,6 +85,12 @@ strings [] = []
strings (c:cs) | c=='"' = case break (=='"') cs of strings (c:cs) | c=='"' = case break (=='"') cs of
(s,_:rest) -> s : strings rest (s,_:rest) -> s : strings rest
| otherwise = strings cs | otherwise = strings cs
updateIORef :: IORef a -> (a -> a) -> IO ()
updateIORef ref f = do
x <- readIORef ref
writeIORef ref (f x)
...@@ -26,7 +26,7 @@ main :: IO () ...@@ -26,7 +26,7 @@ main :: IO ()
main = do main = do
putStrLn "this is the curry prophecy generator" putStrLn "this is the curry prophecy generator"
(force,mk,modName) <- parseArgs (force,mk,modName) <- parseArgs
transform force mk modName transform force mk modName
isForce s = s=="-f" || s=="--forced" isForce s = s=="-f" || s=="--forced"
isMake s = s=="-m" || s=="--make" isMake s = s=="-m" || s=="--make"
...@@ -38,40 +38,50 @@ parseArgs = do args <- getArgs ...@@ -38,40 +38,50 @@ parseArgs = do args <- getArgs
else return (any isForce args,any isMake args,args !! (length args - 1)) else return (any isForce args,any isMake args,args !! (length args - 1))
transform :: Bool -> Bool -> String -> IO () transform :: Bool -> Bool -> String -> IO ()
transform _ False mod = readFlatCurry mod >>= writeTrans "" --transform _ False mod = readFlatCurry mod >>= writeTrans "" [] >> return ()
transform force True mod = make mod tester writeTrans transform force _ mod = make mod tester writeTrans
where where
tester = if force then (\ _ _ -> return True) tester = if force then (\ fn _ -> readTypes fn >>= return . Just)
else obsolete addFcy (addFcy . addOrc) else obsolete addFcy (addFcy . addOrc) readTypes
readTypes fn = readFlatCurryFile fn >>=
return . filter hasHOTypeArg . progTypes
writeTrans :: String -> Prog -> IO () writeTrans :: String -> [[TypeDecl]] -> Prog -> IO [TypeDecl]
writeTrans path prog = do writeTrans path imps prog = do
let fn = path++addOrc (progName prog) let fn = path++addOrc (progName prog)
res = show (transProg prog) (trTypes,trProg) = transProg (concat imps) prog
res = show trProg
putStrLn ("generating "++fn) putStrLn ("generating "++fn)
writeFile (fn++".fcy") res writeFile (fn++".fcy") res
writeFile (fn++".fint") res writeFile (fn++".fint") res
return trTypes
transProg :: Prog -> Prog
transProg prog transProg :: [TypeDecl] -> Prog -> ([TypeDecl],Prog)
= updProg newModName transProg impTypes prog
= (typesToTransform,
updProg newModName
(\imps -> oracle:ioexts:progName prog:imps ++ map newModName imps) (\imps -> oracle:ioexts:progName prog:imps ++ map newModName imps)
(const (map (transType isTrType) typesToTransform)) (const (map (transType isLocalTrType) typesToTransform))
(concatMap (transFunc isTrType isTrCons)) (concatMap (transFunc isGlobalTrType isTrCons))
(map (updOpName newModNameQ)) prog' (map (updOpName newModNameQ)) prog')
where where
prog' = rnmAllVarsInProg (+1) prog -- relies on vars starting from 1 prog' = rnmAllVarsInProg (+1) prog -- relies on vars starting from 1
typesToTransform = filter hasHOTypeArg (progTypes prog) typesToTransform = filter hasHOTypeArg (progTypes prog)
isTrType t = elem t $ map typeName typesToTransform isLocalTrType t = elem t $ map typeName typesToTransform
isTrCons c = elem c $ map consName $ concatMap typeConsDecls typesToTransform isGlobalTrType t = elem t $ map typeName $ typesToTransform ++ impTypes
isTrCons c = elem c $ map consName $ concatMap typeConsDecls
$ typesToTransform ++ impTypes
hasHOTypeArg :: TypeDecl -> Bool hasHOTypeArg :: TypeDecl -> Bool
hasHOTypeArg = trType (\_ _ _ cs -> any isFuncType (concatMap consArgs cs)) hasHOTypeArg = trType (\_ _ _ cs -> any isFuncType (concatMap consArgs cs))
(\_ _ _ _ -> False) (\_ _ _ _ -> False)
transType :: (QName -> Bool) -> TypeDecl -> TypeDecl transType :: (QName -> Bool) -> TypeDecl -> TypeDecl
transType isTr = updTypeName newModNameQ . transType isTr t
updTypeConsDecls (map (updCons newModNameQ id id (map (rType isTr)))) | isTr (typeName t) = updTypeName newModNameQ $
updTypeConsDecls (map (updCons newModNameQ id id
(map (rType isTr)))) t
| otherwise = t
when :: (a -> Bool) -> (a -> a) -> a -> a when :: (a -> Bool) -> (a -> a) -> a -> a
when p f x = if p x then f x else x when p f x = if p x then f x else x
......
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