Make.curry 4.98 KB
Newer Older
bbr's avatar
bbr committed
1
2
3
4
5
6
7
8
9
10
11
-------------------------------------------------------
-- This module provides basic make functionality for 
-- curry programs. The provided actions traverse the
-- import tree and execute a given action only if 
-- necessary.
-------------------------------------------------------

module Make (
  ModuleName,
  Path,
  FileName,
12
13
14
15
  make, obsolete, unless,

  parseArgs,Parameter,
  quiet,force,modulename,output) where
bbr's avatar
bbr committed
16
17

import FlatCurry
18
import FlatCurryGoodies (progImports)
19
import Distribution as D
bbr's avatar
bbr committed
20
21
22
23
24
25
import FiniteMap
import IOExts
import Sort (leqString)
import FileGoodies (dirName)
import Time
import Directory
26
import System (getArgs)
bbr's avatar
bbr committed
27
28
29
30
31

type ModuleName = String
type Path       = String
type FileName   = String

32
33
type TestAct a = Path -> ModuleName -> IO (Maybe a)
type ProgAct a = Path -> [a] -> Prog -> IO a
bbr's avatar
bbr committed
34

35
type Done a = IORef (FM String a)
bbr's avatar
bbr committed
36

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
data Parameter = Parameter Bool Bool (Maybe String) String

defaults :: Parameter
defaults = Parameter False False Nothing ""

type Getter a = Parameter -> a
type Setter a = a -> Parameter -> Parameter

quiet :: Getter Bool
quiet (Parameter x _ _ _) = x

setQuiet :: Setter Bool
setQuiet x (Parameter _ y z m) = Parameter x y z m

force :: Getter Bool
force (Parameter _ x _ _) = x

setForce :: Setter Bool
setForce x (Parameter y _ z m) = Parameter y x z m

output :: Getter (Maybe String)
output (Parameter _ _ x _) = x

setOutput :: Setter (Maybe String)
setOutput x (Parameter y z _ m) = Parameter y z x m

modulename :: Getter String
modulename (Parameter _ _ _ x) = x

setModulename :: Setter String
setModulename x (Parameter y z m _) = Parameter y z m x

parseArgs :: IO Parameter
parseArgs = getArgs >>= return . parse defaults
  where
    parse _ []      = usage
    parse p (x:xs) 
     | x=="-q"      = parse (setQuiet True p) xs
     | x=="--quiet" = parse (setQuiet True p) xs
     | x=="-f"      = parse (setForce True p) xs
     | x=="--force" = parse (setForce True p) xs
     | x=="-o"      = case xs of
                       o:xs' -> parse (setOutput (Just o) p) xs'
     | null xs      = setModulename x p
    
    usage = error "usage: <-f/--force> <-q/--quiet> <-o outputdir> modulename"

bbr's avatar
bbr committed
84
85
--- calls act on each imported module transitively
--- if test returns Nothing.
Bernd Brassel's avatar
Bernd Brassel committed
86
make :: Bool -> ModuleName -> TestAct a -> ProgAct a -> IO ()
87
88
89
90
91
92
93
94
make qu modu test act = do
  mbCurryFile  <- lookupFileInLoadPath (modu++".curry")
  mbLCurryFile <- lookupFileInLoadPath (modu++".lcurry")
  unless (mbCurryFile==Nothing && mbLCurryFile==Nothing)
         (do
          unless qu $ putStrLn "ensuring existence of fcy/fint files..."  
          callFrontendWithParams FCY (D.setQuiet True defaultParams) modu
          unless qu $ putStrLn "...ensured")
bbr's avatar
bbr committed
95
96
  done <- newIORef (emptyFM (\ x y -> not (leqString x y)))
  workUpDependence done test act modu
97
  return ()
bbr's avatar
bbr committed
98

99
workUpDependence ::  Done a -> TestAct a -> ProgAct a -> ModuleName -> IO a
bbr's avatar
bbr committed
100
101
workUpDependence done test act modu = do
  fm <- readIORef done
102
  maybe (process done test act modu) return (lookupFM fm modu)
bbr's avatar
bbr committed
103

104
105
process ::  Done a -> TestAct a -> ProgAct a ->  ModuleName -> IO a
process done test act modu = do
106
  fn <- findFileInLoadPath (flatCurryFileName modu)
107
  imps <- fastReadImports fn >>= mapIO (workUpDependence done test act)
bbr's avatar
bbr committed
108
  let dir = dirName fn++"/"
109
110
111
112
  result <- test dir modu >>= 
            maybe (readFlatCurryFile fn >>= act dir imps) return 
  updateIORef done (\fm -> addToFM fm modu result)
  return result
bbr's avatar
bbr committed
113

114
115
116
--- a standard test if a given file is newer than a list of other files
--- if other files do not exist, the given file is assumed to be up-to-date
--- on up-to-date files a given action is performed
117
obsolete :: Bool -> (String -> String -> String) -> [String -> String] 
Bernd Brassel's avatar
Bernd Brassel committed
118
         -> ([String] -> IO a) -> TestAct a
119
120
obsolete qu f fs action dir modu = do
  let fn  = f dir modu
121
122
      fns = map ((dir++).($modu)) fs
  ex <- doesFileExist fn
bbr's avatar
bbr committed
123
  if ex then do
124
125
126
               t  <- getModificationTime fn
               ns <- mapIO (isNewerThan t) fns
               if or ns
127
                 then do
128
                   unless qu $ putStrLn $ "obsolete  : " ++ fn
129
130
                   return Nothing
                 else do
131
                   unless qu $ putStrLn $ "up-to-date: " ++ fn
bbr's avatar
bbr committed
132
                   action fns >>= return . Just
133
        else do unless qu $ putStrLn ("missing   : "++ fn) 
Bernd Brassel's avatar
Bernd Brassel committed
134
                return Nothing
135
136
137
138
139
140
 where
   isNewerThan t file = do 
     ex <- doesFileExist file
     if not ex then return False else do
      t' <- getModificationTime file
      return (compareClockTime t t'/=GT)
bbr's avatar
bbr committed
141
142
143
144
145
146
147
148
149
150
151

fastReadImports :: FileName -> IO [String]
fastReadImports fn = do 
  cont <- readFile fn
  return (strings (takeWhile (/=']') (dropWhile (/='[') cont)))

strings :: String -> [String]
strings [] = []
strings (c:cs) | c=='"' = case break (=='"') cs of
                            (s,_:rest) -> s : strings rest
               | otherwise = strings cs
152
153
154
155
156
157

updateIORef :: IORef a -> (a -> a) -> IO ()
updateIORef ref f = do
  x <- readIORef ref
  writeIORef ref (f x)

Bernd Brassel's avatar
Bernd Brassel committed
158
159
160
161
unless :: Bool -> IO () -> IO ()
unless True  _   = return ()
unless False act = act

bbr's avatar
bbr committed
162
163
164
165