CurryBuilder.hs 8.15 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.Monad
25
import Curry.Base.Position (Position)
Björn Peemöller 's avatar
Björn Peemöller committed
26
import Curry.Base.Pretty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
27
import Curry.Files.Filenames
28
import Curry.Files.PathUtils
29
import Curry.Syntax (ModulePragma (..), Tool (CYMAKE))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
30

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

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

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

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

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

  process' :: (Int, (ModuleIdent, Source)) -> CYIO ()
85 86 87
  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
88 89 90 91
    where
    deps = fn : mapMaybe curryInterface is

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

  process' _ = return ()

98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
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)
117
    = failMessages [errUnknownOptions p unknownFlags]
118
    | optMode         opts /= optMode         opts'
119
    = failMessages [errIllegalOption p "Cannot change mode"]
120
    | optLibraryPaths opts /= optLibraryPaths opts'
121
    = failMessages [errIllegalOption p "Cannot change library path"]
122
    | optImportPaths  opts /= optImportPaths  opts'
123
    = failMessages [errIllegalOption p "Cannot change import path"]
124
    | optTargetTypes  opts /= optTargetTypes  opts'
125
    = failMessages [errIllegalOption p "Cannot change target type"]
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
    | 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
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  )
    , (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
cancelMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> CYIO a
cancelMissing act f = liftIO (act f) >>= \res -> case res of
200 201
  Nothing  -> failMessages [errModificationTime f]
  Just val -> ok 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 ++ "\""