mach

  1{-# LANGUAGE LambdaCase #-}
  2{-# LANGUAGE RecordWildCards #-}
  3
  4-- | This module performs Makefile macro expansion.
  5module Mach.Eval
  6  ( TgtDef,
  7    MkDef,
  8    getPreqs,
  9    Cmd,
 10    cmdIgnore,
 11    cmdSilent,
 12    cmdExec,
 13    cmdShell,
 14    getCmds,
 15    phony,
 16    silent,
 17    ignore,
 18    defaultTarget,
 19    firstTarget,
 20    lookupRule,
 21    eval,
 22    Target,
 23    getName,
 24    getDef,
 25  )
 26where
 27
 28import Control.Applicative ((<|>))
 29import Control.Exception (throwIO)
 30import Control.Monad (foldM, unless)
 31import Data.Functor ((<&>))
 32import Data.List (elemIndices, isSuffixOf)
 33import qualified Data.Map as Map
 34import Data.Maybe (fromMaybe)
 35import Mach.Error (MakeErr (TargetErr), TargetError (MultipleDefines, NoTargetOrFile, UnexpectedPrereqs))
 36import Mach.Parser (parseMkFile)
 37import qualified Mach.Types as T
 38import Mach.Util (firstJustM, isSpecial, stripSuffix)
 39import System.Directory (doesPathExist)
 40
 41-- | Expanded target definition of a target rule or inference rule.
 42-- The same target definition may be used for multiple files. For
 43-- example, when a target rule is defined for multiple targets.
 44--
 45-- Refer to 'Target' for more information.
 46data TgtDef = TgtDef
 47  { -- | Prerequisites (expanded)
 48    getPreqs :: [String],
 49    -- | Commands
 50    getRawCmds :: [T.Token]
 51  }
 52  deriving (Show)
 53
 54-- | Expanded makefile definition.
 55data MkDef = MkDef
 56  { -- | Macros defined in this Makefile.
 57    assigns :: Env,
 58    -- | First "normal" target defined in the Makefile.
 59    firstTarget :: Maybe String,
 60    -- | Single suffix inference rules.
 61    singleSuffix :: [(String, TgtDef)],
 62    -- | Double suffix inference rules.
 63    doubleSuffix :: [(String, TgtDef)],
 64    -- | TgtDefs defined in this Makefile.
 65    targetDefs :: Map.Map String TgtDef
 66  }
 67  deriving (Show)
 68
 69getSpecialPreqs :: MkDef -> String -> Maybe [String]
 70getSpecialPreqs MkDef {targetDefs = targets} name =
 71  getPreqs <$> Map.lookup name targets
 72
 73-- | Return all suffixes (.SUFFIXES special target).
 74suffixes :: MkDef -> [String]
 75suffixes mkDef = fromMaybe [] (getSpecialPreqs mkDef ".SUFFIXES")
 76
 77phony :: MkDef -> [String]
 78phony mkDef = fromMaybe [] (getSpecialPreqs mkDef ".PHONY")
 79
 80-- | Returns all names of silent targets (.SILENT special target).
 81silent :: MkDef -> Maybe [String]
 82silent mkDef = getSpecialPreqs mkDef ".SILENT"
 83
 84-- | Returns all names of ignored targets (.IGNORE special target).
 85ignore :: MkDef -> Maybe [String]
 86ignore mkDef = getSpecialPreqs mkDef ".IGNORE"
 87
 88-- | Returns a target built from the default rule (if defined).
 89defaultTarget :: FilePath -> MkDef -> Either TargetError Target
 90defaultTarget name MkDef {targetDefs = targets} = do
 91  target <- case Map.lookup ".DEFAULT" targets of
 92    Nothing -> Left $ NoTargetOrFile name
 93    Just t -> pure t
 94
 95  unless (null $ getPreqs target) $
 96    Left UnexpectedPrereqs
 97
 98  pure $ Target name (TgtDef [] $ getRawCmds target)
 99
100-- | Lookup a target definition, the definition may be inferred.
101lookupRule :: MkDef -> String -> IO (Maybe Target)
102lookupRule mk@MkDef {targetDefs = targets} name =
103  lookupRule' $ Map.lookup name targets
104  where
105    lookupRule' :: Maybe TgtDef -> IO (Maybe Target)
106    lookupRule' Nothing = infRule
107    lookupRule' (Just t)
108      | null (getRawCmds t) =
109          infRule <&> \case
110            Nothing -> Just (Target name t)
111            -- mergeDef will never return Nothing as
112            -- inference rules do not have any prerqs.
113            Just x -> setDef x <$> mergeDef (getDef x) t
114      | otherwise = pure $ Just (Target name t)
115
116    infRule :: IO (Maybe Target)
117    infRule = suffixLookup mk name (suffixes mk)
118
119suffixLookup :: MkDef -> String -> [String] -> IO (Maybe Target)
120suffixLookup _ _ [] = pure Nothing
121suffixLookup mk@MkDef {singleSuffix = inf1, doubleSuffix = inf2} name (suffix : xs) = do
122  target <-
123    if '.' `elem` name
124      then firstJustM (lookupDouble name) inf2
125      else firstJustM (lookupSingle name) inf1
126
127  case target of
128    Nothing -> suffixLookup mk name xs
129    result -> pure result
130  where
131    maybeTarget :: TgtDef -> FilePath -> FilePath -> IO (Maybe Target)
132    maybeTarget tgtDef tgtName srcName = do
133      srcExists <- doesPathExist srcName
134      pure $
135        if srcExists
136          then Just $ Inferred tgtName srcName (TgtDef [srcName] $ getRawCmds tgtDef)
137          else Nothing
138
139    lookupSingle :: String -> (String, TgtDef) -> IO (Maybe Target)
140    lookupSingle tgtName (ruleName, tgtDef) =
141      if ruleName == suffix
142        then maybeTarget tgtDef tgtName (tgtName ++ suffix)
143        else pure Nothing
144
145    lookupDouble :: String -> (String, TgtDef) -> IO (Maybe Target)
146    lookupDouble tgtName (ruleName, tgtDef) =
147      let indices = elemIndices '.' ruleName
148          baseName = stripSuffix tgtName
149          (src, tgt) = splitAt (last indices) ruleName
150       in if suffix `isSuffixOf` name && suffix `isSuffixOf` ruleName
151            then maybeTarget tgtDef (baseName ++ tgt) (baseName ++ src)
152            else pure Nothing
153
154-- A target that has prerequisites, but does not have any commands,
155-- can be used to add to the prerequisite list for that target.
156-- Returns nothing if the targets cannot be merged, i.e. if both
157-- targets define commands.
158mergeDef :: TgtDef -> TgtDef -> Maybe TgtDef
159mergeDef (TgtDef p c) (TgtDef p' c')
160  | null c || null c' = Just $ TgtDef (p ++ p') (c ++ c')
161  | otherwise = Nothing
162
163mergeDefs :: Map.Map String TgtDef -> Map.Map String TgtDef -> Maybe (Map.Map String TgtDef)
164mergeDefs old new =
165  flip Map.union old
166    <$> Map.traverseWithKey
167      ( \k v -> case Map.lookup k old of
168          Just v' -> mergeDef v' v
169          Nothing -> Just v
170      )
171      new
172
173------------------------------------------------------------------------
174
175-- | A 'TgtDef' initialized for a specific target. The target
176-- can either be build from a target rule or an inference rule.
177data Target
178  = -- | A target build from a target rule
179    Target
180      -- | The target name
181      FilePath
182      -- | The target definition
183      TgtDef
184  | -- | A target build from an inference rule
185    Inferred
186      -- | The target name
187      FilePath
188      -- | The source file name (`$<`)
189      FilePath
190      -- | The target definition
191      TgtDef
192  deriving (Show)
193
194-- | Obtain the target name.
195getName :: Target -> String
196getName (Target name _) = name
197getName (Inferred name _ _) = name
198
199-- | Obtain the target definition, see 'TgtDef'.
200getDef :: Target -> TgtDef
201getDef (Target _ def) = def
202getDef (Inferred _ _ def) = def
203
204-- | Create a new 'Target' where the encapsulated 'TgtDef' is changed.
205setDef :: Target -> TgtDef -> Target
206setDef (Target name _) newDef = Target name newDef
207setDef (Inferred name src _) newDef = Inferred name src newDef
208
209------------------------------------------------------------------------
210
211-- | A command consisting of a list of prefixes and the shell command.
212data Cmd = Cmd
213  { cmdIgnore :: Bool,
214    cmdSilent :: Bool,
215    cmdExec :: Bool,
216    cmdShell :: String
217  }
218
219instance Show Cmd where
220  show cmd = cmdShell cmd
221
222mkCmd :: String -> Cmd
223mkCmd str = mkCmd' $ Cmd False False False str
224  where
225    mkCmd' :: Cmd -> Cmd
226    mkCmd' Cmd {cmdShell = '-' : xs, ..} =
227      mkCmd' $ Cmd True cmdSilent cmdExec xs
228    mkCmd' Cmd {cmdShell = '@' : xs, ..} =
229      mkCmd' $ Cmd cmdIgnore True cmdExec xs
230    mkCmd' Cmd {cmdShell = '+' : xs, ..} =
231      mkCmd' $ Cmd cmdIgnore cmdSilent True xs
232    mkCmd' cmd = cmd
233
234-- | Retrieve expanded commands for a 'Target'.
235getCmds :: MkDef -> Target -> [Cmd]
236getCmds MkDef {assigns = env} target =
237  (mkCmd . (expand $ Map.union internalMacros env)) <$> getRawCmds targetDef
238  where
239    targetDef :: TgtDef
240    targetDef = getDef target
241
242    internalMacros :: Env
243    internalMacros =
244      Map.fromList
245        [ ("^", T.AssignI $ unwords (getPreqs targetDef)),
246          ("@", T.AssignI $ getName target),
247          ( "<",
248            T.AssignI $ case target of
249              Target _ _ -> ""
250              Inferred _ src _ -> src
251          ),
252          ("*", T.AssignI $ stripSuffix (getName target))
253        ]
254
255------------------------------------------------------------------------
256
257-- | Makefile environment consisting of macro definitions.
258type Env = Map.Map String T.MacroAssign
259
260lookupAssign :: Env -> String -> Maybe String
261lookupAssign env name = Map.lookup name env >>= lookupAssign'
262  where
263    lookupAssign' :: T.MacroAssign -> Maybe String
264    lookupAssign' (T.AssignI str) = Just str
265    lookupAssign' (T.AssignD tok) = Just $ expand env tok
266
267-- Expand a given macro in the context of a given environment.
268expand :: Env -> T.Token -> String
269expand _ (T.Lit t) = t
270expand env (T.Exp t) = fromMaybe "" (lookupAssign env (expand env t))
271expand env (T.Seq s) = foldr (\x acc -> expand env x ++ acc) "" s
272expand env (T.ExpSub t s1 s2) =
273  unwords $
274    map
275      (subWord s1 s2)
276      (words $ expand env t)
277  where
278    subWord :: String -> String -> String -> String
279    subWord s r w
280      | s `isSuffixOf` w = take (length w - length s) w ++ r
281      | otherwise = w
282
283------------------------------------------------------------------------
284
285evalAssign :: Env -> T.Assign -> (String, T.MacroAssign)
286evalAssign env (T.Assign name' ty val) =
287  let name = expand env name'
288   in case ty of
289        T.Delayed -> (name, T.AssignD val)
290        T.Immediate -> (name, T.AssignI $ expand env val)
291        T.StrictDelay -> error "unsupported"
292        T.System -> error "unsupported"
293        T.Cond -> (name, fromMaybe (T.AssignD val) $ Map.lookup name env)
294        T.Append -> (name, maybe (T.AssignD val) appendAssign $ Map.lookup name env)
295  where
296    appendAssign :: T.MacroAssign -> T.MacroAssign
297    appendAssign (T.AssignI str) = T.AssignI $ str ++ " " ++ expand env val
298    appendAssign (T.AssignD tok) = T.AssignD $ T.Seq [tok, T.Lit " ", val]
299
300evalInclude :: MkDef -> [T.Token] -> IO MkDef
301evalInclude def@MkDef {assigns = env} elems =
302  foldM
303    ( \mkDef path -> do
304        mk <- parseMkFile path
305        eval' mkDef mk
306    )
307    def
308    $ map (expand env) elems
309
310evalTgtRule :: Env -> T.TgtRule -> Map.Map String TgtDef
311evalTgtRule env (T.TgtRule tgts preqs cmds) =
312  let def = TgtDef (exLst preqs) cmds
313   in Map.fromList $ map (\tgt -> (tgt, def)) (exLst tgts)
314  where
315    exLst = concatMap (words . expand env)
316
317eval' :: MkDef -> T.MkFile -> IO MkDef
318eval' def [] = pure def
319eval' (MkDef env fstTgt inf1 inf2 targets) ((T.MkAssign assign) : xs) =
320  let (key, val) = evalAssign env assign
321      newEnviron = Map.insert key val env
322   in eval' (MkDef newEnviron fstTgt inf1 inf2 targets) xs
323eval' def ((T.MkInclude elems) : xs) =
324  evalInclude def elems >>= flip eval' xs
325eval' (MkDef env fstTgt inf1 inf2 targets) ((T.MkInfRule (T.InfRule target cmds)) : xs) =
326  let tdef = TgtDef [] cmds
327      (inf1', inf2') =
328        case length $ elemIndices '.' target of
329          1 -> ((target, tdef) : inf1, inf2)
330          2 -> (inf1, (target, tdef) : inf2)
331          _ -> error "unreachable"
332   in eval' (MkDef env fstTgt inf1' inf2' targets) xs
333eval' (MkDef env fstTgt inf1 inf2 targets) ((T.MkTgtRule rule) : xs) =
334  let newTgtDefs = evalTgtRule env rule
335      newTargets = Map.keys newTgtDefs
336      initTgtDef =
337        if isSpecial (head newTargets)
338          then Nothing
339          else Just (head newTargets)
340   in case mergeDefs targets newTgtDefs of
341        Nothing -> throwIO $ TargetErr MultipleDefines
342        Just nt -> eval' (MkDef env (fstTgt <|> initTgtDef) inf1 inf2 nt) xs
343
344eval :: T.MkFile -> IO MkDef
345eval = eval' (MkDef Map.empty Nothing [] [] Map.empty)