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)
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
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
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
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))
]
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) ' '
smake :: [FilePath]
-> [FilePath]
-> CYIO a
-> CYIO a
-> 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]
++ "\""