{- |
    Module      :  $Header$
    Description :  Build tool for compiling multiple Curry modules
    Copyright   :  (c) 2005        Martin Engelke
                       2007        Sebastian Fischer
                       2011 - 2015 Björn Peemöller
                       2018        Kai-Oliver Prott
    License     :  BSD-3-clause

    Maintainer  :  fte@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.
-}
module CurryBuilder (buildCurry, findCurry) where

import Control.Monad   (foldM, liftM)
import Data.Char       (isSpace)
import Data.Maybe      (catMaybes, fromMaybe, mapMaybe)
import System.FilePath ((</>), normalise)

import Curry.Base.Ident
import Curry.Base.Monad
import Curry.Base.SpanInfo (SpanInfo)
import Curry.Base.Pretty
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax ( ModulePragma (..), Extension (KnownExtension)
                    , KnownExtension (CPP), Tool (CYMAKE, FRONTEND) )

import Base.Messages

import CompilerOpts ( Options (..), CppOpts (..), DebugOpts (..)
                    , TargetType (..), defaultDebugOpts, updateOpts )
import CurryDeps    (Source (..), flatDeps)
import Modules      (compileModule)

-- |Compile the Curry module in the given source file including all imported
-- modules w.r.t. the given 'Options'.
buildCurry :: Options -> String -> CYIO ()
buildCurry :: Options -> String -> CYIO ()
buildCurry opts :: Options
opts s :: String
s = do
  String
fn   <- Options -> String -> CYIO String
findCurry Options
opts String
s
  [(ModuleIdent, Source)]
deps <- Options -> String -> CYIO [(ModuleIdent, Source)]
flatDeps  Options
opts String
fn
  Options -> [(ModuleIdent, Source)] -> CYIO ()
makeCurry Options
opts' [(ModuleIdent, Source)]
deps
  where
  opts' :: Options
opts' | [TargetType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TargetType] -> Bool) -> [TargetType] -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> [TargetType]
optTargetTypes Options
opts = Options
opts { optTargetTypes :: [TargetType]
optTargetTypes = [TargetType
FlatCurry] }
        | Bool
otherwise                  = Options
opts

-- |Search for a compilation target identified by the given 'String'.
findCurry :: Options -> String -> CYIO FilePath
findCurry :: Options -> String -> CYIO String
findCurry opts :: Options
opts s :: String
s = do
  Maybe String
mbTarget <- WriterT [Message] (ExceptT [Message] IO) (Maybe String)
findFile WriterT [Message] (ExceptT [Message] IO) (Maybe String)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`orIfNotFound` WriterT [Message] (ExceptT [Message] IO) (Maybe String)
findModule
  case Maybe String
mbTarget of
    Nothing -> [Message] -> CYIO String
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [Message
complaint]
    Just fn :: String
fn -> String -> CYIO String
forall (m :: * -> *) a. Monad m => a -> CYT m a
ok String
fn
  where
  canBeFile :: Bool
canBeFile    = String -> Bool
isCurryFilePath String
s
  canBeModule :: Bool
canBeModule  = String -> Bool
isValidModuleName String
s
  moduleFile :: String
moduleFile   = ModuleIdent -> String
moduleNameToFile (ModuleIdent -> String) -> ModuleIdent -> String
forall a b. (a -> b) -> a -> b
$ String -> ModuleIdent
fromModuleName String
s
  paths :: [String]
paths        = "." String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Options -> [String]
optImportPaths Options
opts
  findFile :: WriterT [Message] (ExceptT [Message] IO) (Maybe String)
findFile     = if Bool
canBeFile
                    then IO (Maybe String)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String)
 -> WriterT [Message] (ExceptT [Message] IO) (Maybe String))
-> IO (Maybe String)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> String -> IO (Maybe String)
lookupCurryFile [String]
paths String
s
                    else Maybe String
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
  findModule :: WriterT [Message] (ExceptT [Message] IO) (Maybe String)
findModule   = if Bool
canBeModule
                    then IO (Maybe String)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String)
 -> WriterT [Message] (ExceptT [Message] IO) (Maybe String))
-> IO (Maybe String)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> String -> IO (Maybe String)
lookupCurryFile [String]
paths String
moduleFile
                    else Maybe String
-> WriterT [Message] (ExceptT [Message] IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
  complaint :: Message
complaint
    | Bool
canBeFile Bool -> Bool -> Bool
&& Bool
canBeModule = String -> String -> Message
errMissing "target" String
s
    | Bool
canBeFile                = String -> String -> Message
errMissing "file"   String
s
    | Bool
canBeModule              = String -> String -> Message
errMissing "module" String
s
    | Bool
otherwise                = String -> Message
errUnrecognized  String
s
  first :: m (Maybe a)
first orIfNotFound :: m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`orIfNotFound` second :: m (Maybe a)
second = do
    Maybe a
mbFile <- m (Maybe a)
first
    case Maybe a
mbFile of
      Nothing -> m (Maybe a)
second
      justFn :: Maybe a
justFn  -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
justFn

-- |Compiles the given source modules, which must be in topological order.
makeCurry :: Options -> [(ModuleIdent, Source)] ->  CYIO ()
makeCurry :: Options -> [(ModuleIdent, Source)] -> CYIO ()
makeCurry opts :: Options
opts srcs :: [(ModuleIdent, Source)]
srcs = ((Int, (ModuleIdent, Source)) -> CYIO ())
-> [(Int, (ModuleIdent, Source))] -> CYIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, (ModuleIdent, Source)) -> CYIO ()
process' ([Int] -> [(ModuleIdent, Source)] -> [(Int, (ModuleIdent, Source))]
forall a b. [a] -> [b] -> [(a, b)]
zip [1 ..] [(ModuleIdent, Source)]
srcs)
  where
  total :: Int
total    = [(ModuleIdent, Source)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ModuleIdent, Source)]
srcs
  tgtDir :: ModuleIdent -> String -> String
tgtDir m :: ModuleIdent
m = Bool -> String -> ModuleIdent -> String -> String
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> String
optOutDir Options
opts) ModuleIdent
m

  process' :: (Int, (ModuleIdent, Source)) -> CYIO ()
  process' :: (Int, (ModuleIdent, Source)) -> CYIO ()
process' (n :: Int
n, (m :: ModuleIdent
m, Source fn :: String
fn ps :: [ModulePragma]
ps is :: [ModuleIdent]
is)) = do
    Options
opts' <- Options -> [ModulePragma] -> CYIO Options
processPragmas Options
opts [ModulePragma]
ps
    Options
-> (Int, Int) -> ModuleIdent -> String -> [String] -> CYIO ()
process (Bool -> Options -> Options
adjustOptions (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
total) Options
opts') (Int
n, Int
total) ModuleIdent
m String
fn [String]
deps
    where
    deps :: [String]
deps = String
fn String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ModuleIdent -> Maybe String) -> [ModuleIdent] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ModuleIdent -> Maybe String
curryInterface [ModuleIdent]
is

    curryInterface :: ModuleIdent -> Maybe String
curryInterface i :: ModuleIdent
i = case ModuleIdent -> [(ModuleIdent, Source)] -> Maybe Source
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleIdent
i [(ModuleIdent, Source)]
srcs of
      Just (Source    fn' :: String
fn' _ _) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> String -> String
tgtDir ModuleIdent
i (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
interfName String
fn'
      Just (Interface fn' :: String
fn'    ) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> String -> String
tgtDir ModuleIdent
i (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
interfName String
fn'
      _                        -> Maybe String
forall a. Maybe a
Nothing

  process' _ = () -> CYIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

adjustOptions :: Bool -> Options -> Options
adjustOptions :: Bool -> Options -> Options
adjustOptions final :: Bool
final opts :: Options
opts
  | Bool
final      = Options
opts { optForce :: Bool
optForce         = Options -> Bool
optForce Options
opts Bool -> Bool -> Bool
|| Bool
isDump }
  | Bool
otherwise  = Options
opts { optForce :: Bool
optForce         = Bool
False
                      , optDebugOpts :: DebugOpts
optDebugOpts     = DebugOpts
defaultDebugOpts
                      }
  where
  isDump :: Bool
isDump = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [DumpLevel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([DumpLevel] -> Bool) -> [DumpLevel] -> Bool
forall a b. (a -> b) -> a -> b
$ DebugOpts -> [DumpLevel]
dbDumpLevels (DebugOpts -> [DumpLevel]) -> DebugOpts -> [DumpLevel]
forall a b. (a -> b) -> a -> b
$ Options -> DebugOpts
optDebugOpts Options
opts


processPragmas :: Options -> [ModulePragma] -> CYIO Options
processPragmas :: Options -> [ModulePragma] -> CYIO Options
processPragmas opts0 :: Options
opts0 ps :: [ModulePragma]
ps = do
  let opts1 :: Options
opts1 = (Options -> KnownExtension -> Options)
-> Options -> [KnownExtension] -> Options
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Options -> KnownExtension -> Options
processLanguagePragma Options
opts0
                [ KnownExtension
e | LanguagePragma _ es :: [Extension]
es <- [ModulePragma]
ps, KnownExtension _ e :: KnownExtension
e <- [Extension]
es ]
  (Options -> (SpanInfo, String) -> CYIO Options)
-> Options -> [(SpanInfo, String)] -> CYIO Options
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Options -> (SpanInfo, String) -> CYIO Options
forall (m :: * -> *).
Monad m =>
Options -> (SpanInfo, String) -> CYT m Options
processOptionPragma Options
opts1 ([(SpanInfo, String)] -> CYIO Options)
-> [(SpanInfo, String)] -> CYIO Options
forall a b. (a -> b) -> a -> b
$
    [ (SpanInfo
p, String
s) | OptionsPragma p :: SpanInfo
p (Just FRONTEND) s :: String
s <- [ModulePragma]
ps ] [(SpanInfo, String)]
-> [(SpanInfo, String)] -> [(SpanInfo, String)]
forall a. [a] -> [a] -> [a]
++
      [ (SpanInfo
p, String
s) | OptionsPragma p :: SpanInfo
p (Just CYMAKE) s :: String
s <- [ModulePragma]
ps ]
  where
  processLanguagePragma :: Options -> KnownExtension -> Options
processLanguagePragma opts :: Options
opts CPP
    = Options
opts { optCppOpts :: CppOpts
optCppOpts = (Options -> CppOpts
optCppOpts Options
opts) { cppRun :: Bool
cppRun = Bool
True } }
  processLanguagePragma opts :: Options
opts _
    = Options
opts
  processOptionPragma :: Options -> (SpanInfo, String) -> CYT m Options
processOptionPragma opts :: Options
opts (p :: SpanInfo
p, s :: String
s)
    | Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unknownFlags)
    = [Message] -> CYT m Options
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [SpanInfo -> [String] -> Message
errUnknownOptions SpanInfo
p [String]
unknownFlags]
    | Options -> CymakeMode
optMode         Options
opts CymakeMode -> CymakeMode -> Bool
forall a. Eq a => a -> a -> Bool
/= Options -> CymakeMode
optMode         Options
opts'
    = [Message] -> CYT m Options
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [SpanInfo -> String -> Message
errIllegalOption SpanInfo
p "Cannot change mode"]
    | Options -> [String]
optLibraryPaths Options
opts [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= Options -> [String]
optLibraryPaths Options
opts'
    = [Message] -> CYT m Options
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [SpanInfo -> String -> Message
errIllegalOption SpanInfo
p "Cannot change library path"]
    | Options -> [String]
optImportPaths  Options
opts [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= Options -> [String]
optImportPaths  Options
opts'
    = [Message] -> CYT m Options
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [SpanInfo -> String -> Message
errIllegalOption SpanInfo
p "Cannot change import path"]
    | Options -> [TargetType]
optTargetTypes  Options
opts [TargetType] -> [TargetType] -> Bool
forall a. Eq a => a -> a -> Bool
/= Options -> [TargetType]
optTargetTypes  Options
opts'
    = [Message] -> CYT m Options
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [SpanInfo -> String -> Message
errIllegalOption SpanInfo
p "Cannot change target type"]
    | Bool
otherwise
    = Options -> CYT m Options
forall (m :: * -> *) a. Monad m => a -> m a
return Options
opts'
    where
    (opts' :: Options
opts', files :: [String]
files, errs :: [String]
errs) = Options -> [String] -> (Options, [String], [String])
updateOpts Options
opts (String -> [String]
quotedWords String
s)
    unknownFlags :: [String]
unknownFlags = [String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
errs

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

-- |Compile a single source module.
process :: Options -> (Int, Int)
        -> ModuleIdent -> FilePath -> [FilePath] -> CYIO ()
process :: Options
-> (Int, Int) -> ModuleIdent -> String -> [String] -> CYIO ()
process opts :: Options
opts idx :: (Int, Int)
idx m :: ModuleIdent
m fn :: String
fn deps :: [String]
deps
  | Options -> Bool
optForce Options
opts = CYIO ()
compile
  | Bool
otherwise     = [String] -> [String] -> CYIO () -> CYIO () -> CYIO ()
forall a. [String] -> [String] -> CYIO a -> CYIO a -> CYIO a
smake (String -> String
tgtDir (String -> String
interfName String
fn) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
destFiles) [String]
deps CYIO ()
compile CYIO ()
skip
  where
  skip :: CYIO ()
skip    = Options -> String -> CYIO ()
forall (m :: * -> *). MonadIO m => Options -> String -> m ()
status Options
opts (String -> CYIO ()) -> String -> CYIO ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> String -> ModuleIdent -> (String, String) -> String
compMessage (Int, Int)
idx "Skipping" ModuleIdent
m (String
fn, [String] -> String
forall a. [a] -> a
head [String]
destFiles)
  compile :: CYIO ()
compile = do
    Options -> String -> CYIO ()
forall (m :: * -> *). MonadIO m => Options -> String -> m ()
status Options
opts (String -> CYIO ()) -> String -> CYIO ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> String -> ModuleIdent -> (String, String) -> String
compMessage (Int, Int)
idx "Compiling" ModuleIdent
m (String
fn, [String] -> String
forall a. [a] -> a
head [String]
destFiles)
    Options -> ModuleIdent -> String -> CYIO ()
compileModule Options
opts ModuleIdent
m String
fn

  tgtDir :: String -> String
tgtDir = Bool -> String -> ModuleIdent -> String -> String
addOutDirModule (Options -> Bool
optUseOutDir Options
opts) (Options -> String
optOutDir Options
opts) ModuleIdent
m

  destFiles :: [String]
destFiles = [ String -> String
gen String
fn | (t :: TargetType
t, gen :: String -> String
gen) <- [(TargetType, String -> String)]
nameGens, TargetType
t TargetType -> [TargetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Options -> [TargetType]
optTargetTypes Options
opts]
  nameGens :: [(TargetType, String -> String)]
nameGens  =
    [ (TargetType
Tokens              , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
tokensName       )
    , (TargetType
Comments            , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
commentsName)
    , (TargetType
Parsed              , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sourceRepName    )
    , (TargetType
FlatCurry           , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
flatName         )
    , (TargetType
TypedFlatCurry      , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
typedFlatName    )
    , (TargetType
AnnotatedFlatCurry  , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
annotatedFlatName)
    , (TargetType
AbstractCurry       , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
acyName          )
    , (TargetType
UntypedAbstractCurry, String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
uacyName         )
    , (TargetType
AST                 , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
astName          )
    , (TargetType
ShortAST            , String -> String
tgtDir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
shortASTName     )
    , (TargetType
Html                , String -> String -> String
forall a b. a -> b -> a
const (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "." (Options -> Maybe String
optHtmlDir Options
opts) String -> String -> String
</> ModuleIdent -> String
htmlName ModuleIdent
m))
    ]

-- |Create a status message like
-- @[m of n] Compiling Module          ( M.curry, .curry/M.fcy )@
compMessage :: (Int, Int) -> String -> ModuleIdent
            -> (FilePath, FilePath) -> String
compMessage :: (Int, Int) -> String -> ModuleIdent -> (String, String) -> String
compMessage (curNum :: Int
curNum, maxNum :: Int
maxNum) what :: String
what m :: ModuleIdent
m (src :: String
src, dst :: String
dst)
  =  '[' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String -> String
lpad (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sMaxNum) (Int -> String
forall a. Show a => a -> String
show Int
curNum) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sMaxNum  String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ ' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String -> String
rpad 9 String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ ' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String -> String
rpad 16 (ModuleIdent -> String
moduleName ModuleIdent
m)
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalise String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalise String
dst String -> String -> String
forall a. [a] -> [a] -> [a]
++ " )"
  where
  sMaxNum :: String
sMaxNum  = Int -> String
forall a. Show a => a -> String
show Int
maxNum
  lpad :: Int -> String -> String
lpad n :: Int
n s :: String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) ' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
  rpad :: Int -> String -> String
rpad n :: Int
n s :: String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) ' '

-- |A simple make function
smake :: [FilePath] -- ^ destination files
      -> [FilePath] -- ^ dependency files
      -> CYIO a     -- ^ action to perform if depedency files are newer
      -> CYIO a     -- ^ action to perform if destination files are newer
      -> CYIO a
smake :: [String] -> [String] -> CYIO a -> CYIO a -> CYIO a
smake dests :: [String]
dests deps :: [String]
deps actOutdated :: CYIO a
actOutdated actUpToDate :: CYIO a
actUpToDate = do
  [UTCTime]
destTimes <- [Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UTCTime] -> [UTCTime])
-> WriterT [Message] (ExceptT [Message] IO) [Maybe UTCTime]
-> WriterT [Message] (ExceptT [Message] IO) [UTCTime]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (String
 -> WriterT [Message] (ExceptT [Message] IO) (Maybe UTCTime))
-> [String]
-> WriterT [Message] (ExceptT [Message] IO) [Maybe UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO (Maybe UTCTime)
-> WriterT [Message] (ExceptT [Message] IO) (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime)
 -> WriterT [Message] (ExceptT [Message] IO) (Maybe UTCTime))
-> (String -> IO (Maybe UTCTime))
-> String
-> WriterT [Message] (ExceptT [Message] IO) (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe UTCTime)
getModuleModTime) [String]
dests
  [UTCTime]
depTimes  <- (String -> WriterT [Message] (ExceptT [Message] IO) UTCTime)
-> [String] -> WriterT [Message] (ExceptT [Message] IO) [UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> IO (Maybe UTCTime))
-> String -> WriterT [Message] (ExceptT [Message] IO) UTCTime
forall a. (String -> IO (Maybe a)) -> String -> CYIO a
cancelMissing String -> IO (Maybe UTCTime)
getModuleModTime) [String]
deps
  [UTCTime] -> [UTCTime] -> CYIO a
forall a. Ord a => [a] -> [a] -> CYIO a
make [UTCTime]
destTimes [UTCTime]
depTimes
  where
  make :: [a] -> [a] -> CYIO a
make destTimes :: [a]
destTimes depTimes :: [a]
depTimes
    | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
destTimes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
dests = CYIO a
actOutdated
    | [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
outOfDate [a]
destTimes [a]
depTimes    = CYIO a
actOutdated
    | Bool
otherwise                       = CYIO a
actUpToDate

  outOfDate :: [a] -> [a] -> Bool
outOfDate tgtimes :: [a]
tgtimes dptimes :: [a]
dptimes = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ a
tg a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
dp | a
tg <- [a]
tgtimes, a
dp <- [a]
dptimes]

cancelMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> CYIO a
cancelMissing :: (String -> IO (Maybe a)) -> String -> CYIO a
cancelMissing act :: String -> IO (Maybe a)
act f :: String
f = IO (Maybe a) -> WriterT [Message] (ExceptT [Message] IO) (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe a)
act String
f) WriterT [Message] (ExceptT [Message] IO) (Maybe a)
-> (Maybe a -> CYIO a) -> CYIO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \res :: Maybe a
res -> case Maybe a
res of
  Nothing  -> [Message] -> CYIO a
forall (m :: * -> *) a. Monad m => [Message] -> CYT m a
failMessages [String -> Message
errModificationTime String
f]
  Just val :: a
val -> a -> CYIO a
forall (m :: * -> *) a. Monad m => a -> CYT m a
ok a
val

errUnknownOptions :: SpanInfo -> [String] -> Message
errUnknownOptions :: SpanInfo -> [String] -> Message
errUnknownOptions spi :: SpanInfo
spi errs :: [String]
errs = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Unknown flag(s) in {-# OPTIONS_FRONTEND #-} pragma:"
  Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
errs)

errIllegalOption :: SpanInfo -> String -> Message
errIllegalOption :: SpanInfo -> String -> Message
errIllegalOption spi :: SpanInfo
spi err :: String
err = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage SpanInfo
spi (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Illegal option in {-# OPTIONS_FRONTEND #-} pragma:" Doc -> Doc -> Doc
<+> String -> Doc
text String
err

errMissing :: String -> String -> Message
errMissing :: String -> String -> Message
errMissing what :: String
what which :: String
which = Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Missing", String
what, String -> String
quote String
which ]

errUnrecognized :: String -> Message
errUnrecognized :: String -> Message
errUnrecognized f :: String
f = Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Unrecognized input", String -> String
quote String
f ]

errModificationTime :: FilePath -> Message
errModificationTime :: String -> Message
errModificationTime f :: String
f = Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ "Could not inspect modification time of file", String -> String
quote String
f ]

quote :: String -> String
quote :: String -> String
quote s :: String
s = "\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\""