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