CurryBuilder.hs 8.12 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
2
3
{- |
    Module      :  $Header$
    Description :  Build tool for compiling multiple Curry modules
Björn Peemöller 's avatar
Björn Peemöller committed
4
5
    Copyright   :  (c) 2005        Martin Engelke
                       2007        Sebastian Fischer
Björn Peemöller 's avatar
Björn Peemöller committed
6
                       2011 - 2014 Björn Peemöller
Björn Peemöller 's avatar
Björn Peemöller committed
7
8
9
10
11
12
13
14
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module contains functions to generate Curry representations for a
    Curry source file including all imported modules.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
15
-}
16
module CurryBuilder (buildCurry) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
17

18
19
import Control.Monad   (foldM, liftM)
import Data.Char       (isSpace)
20
import Data.Maybe      (catMaybes, mapMaybe)
21
import System.FilePath (normalise)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
22
23

import Curry.Base.Ident
24
import Curry.Base.Position (Position)
Björn Peemöller 's avatar
Björn Peemöller committed
25
import Curry.Base.Pretty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
26
import Curry.Files.Filenames
27
import Curry.Files.PathUtils
28
import Curry.Syntax (ModulePragma (..), Tool (CYMAKE))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
29

Björn Peemöller 's avatar
Björn Peemöller committed
30
import Base.Messages
Björn Peemöller 's avatar
Björn Peemöller committed
31

32
import CompilerOpts ( Options (..), DebugOpts (..), TargetType (..)
33
                    , defaultDebugOpts, updateOpts)
34
35
import CurryDeps    (Source (..), flatDeps)
import Modules      (compileModule)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
36

Björn Peemöller 's avatar
Björn Peemöller committed
37
-- |Compile the Curry module in the given source file including all imported
Björn Peemöller 's avatar
Björn Peemöller committed
38
-- modules w.r.t. the given 'Options'.
Björn Peemöller 's avatar
Björn Peemöller committed
39
buildCurry :: Options -> String -> CYIO ()
40
buildCurry opts s = do
Björn Peemöller 's avatar
Björn Peemöller committed
41
  fn   <- findCurry opts s
Björn Peemöller 's avatar
Björn Peemöller committed
42
43
  deps <- flatDeps  opts fn
  makeCurry opts' deps
Björn Peemöller 's avatar
Björn Peemöller committed
44
  where
Björn Peemöller 's avatar
Björn Peemöller committed
45
46
  opts' | null $ optTargetTypes opts = opts { optTargetTypes = [FlatCurry] }
        | otherwise                  = opts
47

Björn Peemöller 's avatar
Björn Peemöller committed
48
-- |Search for a compilation target identified by the given 'String'.
Björn Peemöller 's avatar
Björn Peemöller committed
49
findCurry :: Options -> String -> CYIO FilePath
50
findCurry opts s = do
51
  mbTarget <- findFile `orIfNotFound` findModule
52
  case mbTarget of
Björn Peemöller 's avatar
Björn Peemöller committed
53
54
    Nothing -> left [complaint]
    Just fn -> right fn
Björn Peemöller 's avatar
Björn Peemöller committed
55
  where
56
57
58
  canBeFile    = isCurryFilePath s
  canBeModule  = isValidModuleName s
  moduleFile   = moduleNameToFile $ fromModuleName s
59
  paths        = optImportPaths opts
60
  findFile     = if canBeFile
Björn Peemöller 's avatar
Björn Peemöller committed
61
                    then liftIO $ lookupCurryFile paths s
62
                    else return Nothing
63
  findModule   = if canBeModule
Björn Peemöller 's avatar
Björn Peemöller committed
64
                    then liftIO $ lookupCurryFile paths moduleFile
65
66
                    else return Nothing
  complaint
Björn Peemöller 's avatar
Björn Peemöller committed
67
68
69
    | canBeFile && canBeModule = errMissing "target" s
    | canBeFile                = errMissing "file"   s
    | canBeModule              = errMissing "module" s
70
    | otherwise                = errUnrecognized  s
71
72
73
74
75
  first `orIfNotFound` second = do
    mbFile <- first
    case mbFile of
      Nothing -> second
      justFn  -> return justFn
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
76

Björn Peemöller 's avatar
Björn Peemöller committed
77
78
79
-- |Compiles the given source modules, which must be in topological order.
makeCurry :: Options -> [(ModuleIdent, Source)] ->  CYIO ()
makeCurry opts srcs = mapM_ process' (zip [1 ..] srcs)
80
  where
Björn Peemöller 's avatar
Björn Peemöller committed
81
82
83
  total = length srcs

  process' :: (Int, (ModuleIdent, Source)) -> CYIO ()
84
85
86
  process' (n, (m, Source fn ps is)) = do
    opts' <- processPragmas opts ps
    process (adjustOptions (n == total) opts') (n, total) m fn deps
Björn Peemöller 's avatar
Björn Peemöller committed
87
88
89
90
    where
    deps = fn : mapMaybe curryInterface is

    curryInterface i = case lookup i srcs of
91
92
93
      Just (Source    fn' _ _) -> Just $ interfName fn'
      Just (Interface fn'    ) -> Just $ interfName fn'
      _                        -> Nothing
Björn Peemöller 's avatar
Björn Peemöller committed
94
95
96

  process' _ = return ()

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
adjustOptions :: Bool -> Options -> Options
adjustOptions final opts
  | final      = opts { optForce = optForce opts || isDump }
  | otherwise  = opts { optTargetTypes = [flatTarget]
                      , optForce       = False
                      , optDebugOpts   = defaultDebugOpts
                      }
  where
  isDump = not $ null $ dbDumpLevels $ optDebugOpts opts
  flatTarget = if ExtendedFlatCurry `elem` optTargetTypes opts
                  then ExtendedFlatCurry else FlatCurry


processPragmas :: Options -> [ModulePragma] -> CYIO Options
processPragmas opts0 ps = foldM processPragma opts0
                          [ (p, s) | OptionsPragma p (Just CYMAKE) s <- ps ]
  where
  processPragma opts (p, s)
    | not (null unknownFlags)
    = left [errUnknownOptions p unknownFlags]
    | optMode         opts /= optMode         opts'
    = left [errIllegalOption p "Cannot change mode"]
    | optLibraryPaths opts /= optLibraryPaths opts'
    = left [errIllegalOption p "Cannot change library path"]
    | optImportPaths  opts /= optImportPaths  opts'
    = left [errIllegalOption p "Cannot change import path"]
    | optTargetTypes  opts /= optTargetTypes  opts'
    = left [errIllegalOption p "Cannot change target type"]
    | otherwise
    = return opts'
    where
    (opts', files, errs) = updateOpts opts (quotedWords s)
    unknownFlags = files ++ errs

quotedWords :: String -> [String]
quotedWords str = case dropWhile isSpace str of
  []        -> []
  s@('\'' : cs) -> case break (== '\'') cs of
    (_     , []      ) -> def s
    (quoted, (_:rest)) -> quoted : quotedWords rest
  s@('"'  : cs) -> case break (== '"') cs of
    (_     , []      ) -> def s
    (quoted, (_:rest)) -> quoted : quotedWords rest
  s         -> def s
  where
  def s = let (w, rest) = break isSpace s in  w : quotedWords rest

Björn Peemöller 's avatar
Björn Peemöller committed
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
-- |Compile a single source module.
process :: Options -> (Int, Int)
        -> ModuleIdent -> FilePath -> [FilePath] -> CYIO ()
process opts idx m fn deps
  | optForce opts = compile
  | otherwise     = smake (interfName fn : destFiles) deps compile skip
  where
  skip    = status opts $ compMessage idx "Skipping" m (fn, head destFiles)
  compile = do
    status opts $ compMessage idx "Compiling" m (fn, head destFiles)
    compileModule opts fn

  destFiles = [ addCurrySubdir (optUseSubdir opts) (gen fn)
              | (tgt, gen) <- nameGens, tgt `elem` optTargetTypes opts]
  nameGens  =
    [ (FlatCurry            , flatName     )
    , (ExtendedFlatCurry    , extFlatName  )
    , (FlatXml              , xmlName      )
    , (AbstractCurry        , acyName      )
    , (UntypedAbstractCurry , uacyName     )
    , (Parsed               , sourceRepName)
    ]

-- |Create a status message like
-- @[m of n] Compiling Module          ( M.curry, .curry/M.fcy )@
compMessage :: (Int, Int) -> String -> ModuleIdent
            -> (FilePath, FilePath) -> String
compMessage (curNum, maxNum) what m (src, dst)
  =  '[' : lpad (length sMaxNum) (show curNum) ++ " of " ++ sMaxNum  ++ "]"
  ++ ' ' : rpad 9 what ++ ' ' : rpad 16 (show m)
  ++ " ( " ++ normalise src ++ ", " ++ normalise dst ++ " )"
  where
  sMaxNum  = show maxNum
  lpad n s = replicate (n - length s) ' ' ++ s
  rpad n s = s ++ replicate (n - length s) ' '
Björn Peemöller 's avatar
Björn Peemöller committed
179
180
181
182

-- |A simple make function
smake :: [FilePath] -- ^ destination files
      -> [FilePath] -- ^ dependency files
Björn Peemöller 's avatar
Björn Peemöller committed
183
184
      -> CYIO a     -- ^ action to perform if depedency files are newer
      -> CYIO a     -- ^ action to perform if destination files are newer
Björn Peemöller 's avatar
Björn Peemöller committed
185
      -> CYIO a
Björn Peemöller 's avatar
Björn Peemöller committed
186
smake dests deps actOutdated actUpToDate = do
Björn Peemöller 's avatar
Björn Peemöller committed
187
188
  destTimes <- catMaybes `liftM` mapM (liftIO . getModuleModTime) dests
  depTimes  <- mapM (cancelMissing getModuleModTime) deps
189
  make destTimes depTimes
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
190
  where
191
192
193
194
  make destTimes depTimes
    | length destTimes < length dests = actOutdated
    | outOfDate destTimes depTimes    = actOutdated
    | otherwise                       = actUpToDate
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
195

196
  outOfDate tgtimes dptimes = or [ tg < dp | tg <- tgtimes, dp <- dptimes]
197

Björn Peemöller 's avatar
Björn Peemöller committed
198
199
200
201
cancelMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> CYIO a
cancelMissing act f = liftIO (act f) >>= \res -> case res of
  Nothing  -> left [errModificationTime f]
  Just val -> right val
202

203
204
205
206
207
208
209
210
211
errUnknownOptions :: Position -> [String] -> Message
errUnknownOptions p errs = posMessage p $
  text "Unknown flag(s) in {-# OPTIONS_CYMAKE #-} pragma:"
  <+> sep (punctuate comma $ map text errs)

errIllegalOption :: Position -> String -> Message
errIllegalOption p err = posMessage p $
  text "Illegal option in {-# OPTIONS_CYMAKE #-} pragma:" <+> text err

Björn Peemöller 's avatar
Björn Peemöller committed
212
213
214
errMissing :: String -> String -> Message
errMissing what which = message $ sep $ map text
  [ "Missing", what, quote which ]
215

Björn Peemöller 's avatar
Björn Peemöller committed
216
217
218
errUnrecognized :: String -> Message
errUnrecognized f = message $ sep $ map text
  [ "Unrecognized input", quote f ]
219

Björn Peemöller 's avatar
Björn Peemöller committed
220
221
222
errModificationTime :: FilePath -> Message
errModificationTime f = message $ sep $ map text
  [ "Could not inspect modification time of file", quote f ]
223
224
225

quote :: String -> String
quote s = "\"" ++ s ++ "\""