mirror of
https://github.com/edwinb/Idris2-boot.git
synced 2024-11-28 14:06:26 +03:00
Merge pull request #136 from clayrat/sourcedir
Add 'sourcedir' option to IPKG
This commit is contained in:
Edwin Brady
GitHub
commit
dab2bb36c1
@ -1637,6 +1637,12 @@ setBuildDir dir
|
||||
= do defs <- get Ctxt
|
||||
put Ctxt (record { options->dirs->build_dir = dir } defs)
|
||||
|
||||
export
|
||||
setSourceDir : {auto c : Ref Ctxt Defs} -> Maybe String -> Core ()
|
||||
setSourceDir mdir
|
||||
= do defs <- get Ctxt
|
||||
put Ctxt (record { options->dirs->source_dir = mdir } defs)
|
||||
|
||||
export
|
||||
setWorkingDir : {auto c : Ref Ctxt Defs} -> String -> Core ()
|
||||
setWorkingDir dir
|
||||
|
||||
@ -395,6 +395,11 @@ export
|
||||
traverse : (a -> Core b) -> List a -> Core (List b)
|
||||
traverse f xs = traverse' f xs []
|
||||
|
||||
export
|
||||
traverseOpt : (a -> Core b) -> Maybe a -> Core (Maybe b)
|
||||
traverseOpt f Nothing = pure Nothing
|
||||
traverseOpt f (Just x) = map Just (f x)
|
||||
|
||||
export
|
||||
traverse_ : (a -> Core b) -> List a -> Core ()
|
||||
traverse_ f [] = pure ()
|
||||
|
||||
@ -50,7 +50,7 @@ readDataFile : {auto c : Ref Ctxt Defs} ->
|
||||
String -> Core String
|
||||
readDataFile fname
|
||||
= do d <- getDirs
|
||||
let fs = map (\p => p ++ cast sep ++ fname) (data_dirs d)
|
||||
let fs = map (\p => p ++ dirSep ++ fname) (data_dirs d)
|
||||
Just f <- firstAvailable fs
|
||||
| Nothing => throw (InternalError ("Can't find data file " ++ fname))
|
||||
Right d <- coreLift $ readFile f
|
||||
@ -65,8 +65,8 @@ findLibraryFile : {auto c : Ref Ctxt Defs} ->
|
||||
String -> Core String
|
||||
findLibraryFile fname
|
||||
= do d <- getDirs
|
||||
let fs = map (\p => p ++ cast sep ++ fname)
|
||||
(lib_dirs d ++ map (\x => x ++ cast sep ++ "lib")
|
||||
let fs = map (\p => p ++ dirSep ++ fname)
|
||||
(lib_dirs d ++ map (\x => x ++ dirSep ++ "lib")
|
||||
(extra_dirs d))
|
||||
Just f <- firstAvailable fs
|
||||
| Nothing => throw (InternalError ("Can't find library " ++ fname))
|
||||
@ -79,9 +79,9 @@ nsToPath : {auto c : Ref Ctxt Defs} ->
|
||||
FC -> List String -> Core (Either Error String)
|
||||
nsToPath loc ns
|
||||
= do d <- getDirs
|
||||
let fnameBase = showSep (cast sep) (reverse ns)
|
||||
let fs = map (\p => p ++ cast sep ++ fnameBase ++ ".ttc")
|
||||
((build_dir d ++ cast sep ++ "ttc") :: extra_dirs d)
|
||||
let fnameBase = showSep dirSep (reverse ns)
|
||||
let fs = map (\p => p ++ dirSep ++ fnameBase ++ ".ttc")
|
||||
((build_dir d ++ dirSep ++ "ttc") :: extra_dirs d)
|
||||
Just f <- firstAvailable fs
|
||||
| Nothing => pure (Left (ModuleNotFound loc ns))
|
||||
pure (Right f)
|
||||
@ -93,28 +93,32 @@ nsToSource : {auto c : Ref Ctxt Defs} ->
|
||||
FC -> List String -> Core String
|
||||
nsToSource loc ns
|
||||
= do d <- getDirs
|
||||
let fnameBase = showSep (cast sep) (reverse ns)
|
||||
let fnameOrig = showSep dirSep (reverse ns)
|
||||
let fnameBase = maybe fnameOrig (\srcdir => srcdir ++ dirSep ++ fnameOrig) (source_dir d)
|
||||
let fs = map (\ext => fnameBase ++ ext)
|
||||
[".yaff", ".idr", ".lidr"]
|
||||
Just f <- firstAvailable fs
|
||||
| Nothing => throw (ModuleNotFound loc ns)
|
||||
pure f
|
||||
|
||||
-- Given a filename in the working directory, return the correct
|
||||
-- Given a filename in the working directory + source directory, return the correct
|
||||
-- namespace for it
|
||||
export
|
||||
pathToNS : String -> String -> List String
|
||||
pathToNS wdir fname
|
||||
pathToNS : String -> Maybe String -> String -> List String
|
||||
pathToNS wdir sdir fname
|
||||
= let wsplit = splitSep wdir
|
||||
fsplit = splitSep fname in
|
||||
dropWdir wsplit fsplit fsplit
|
||||
ssplit = maybe [] splitSep sdir
|
||||
fsplit = splitSep fname
|
||||
wdrop = dropDir wsplit fsplit fsplit
|
||||
in
|
||||
dropDir ssplit wdrop wdrop
|
||||
where
|
||||
dropWdir : List String -> List String -> List String -> List String
|
||||
dropWdir wdir orig [] = []
|
||||
dropWdir wdir orig (x :: xs)
|
||||
= if wdir == xs
|
||||
dropDir : List String -> List String -> List String -> List String
|
||||
dropDir dir orig [] = []
|
||||
dropDir dir orig (x :: xs)
|
||||
= if dir == xs
|
||||
then [x]
|
||||
else x :: dropWdir wdir orig xs
|
||||
else x :: dropDir dir orig xs
|
||||
|
||||
splitSep : String -> List String
|
||||
splitSep fname
|
||||
@ -150,9 +154,9 @@ makeBuildDirectory ns
|
||||
let ndirs = case ns of
|
||||
[] => []
|
||||
(n :: ns) => ns -- first item is file name
|
||||
let fname = showSep (cast sep) (reverse ndirs)
|
||||
let fname = showSep dirSep (reverse ndirs)
|
||||
Right _ <- coreLift $ mkdirs (build_dir d :: "ttc" :: reverse ndirs)
|
||||
| Left err => throw (FileErr (bdir ++ cast sep ++ fname) err)
|
||||
| Left err => throw (FileErr (bdir ++ dirSep ++ fname) err)
|
||||
pure ()
|
||||
|
||||
-- Given a source file, return the name of the ttc file to generate
|
||||
@ -164,14 +168,14 @@ getTTCFileName inp ext
|
||||
d <- getDirs
|
||||
-- Get its namespace from the file relative to the working directory
|
||||
-- and generate the ttc file from that
|
||||
let ns = pathToNS (working_dir d) inp
|
||||
let fname = showSep (cast sep) (reverse ns) ++ ext
|
||||
let ns = pathToNS (working_dir d) (source_dir d) inp
|
||||
let fname = showSep dirSep (reverse ns) ++ ext
|
||||
let bdir = build_dir d
|
||||
pure $ bdir ++ cast sep ++ "ttc" ++ cast sep ++ fname
|
||||
pure $ bdir ++ dirSep ++ "ttc" ++ dirSep ++ fname
|
||||
|
||||
-- Given a root executable name, return the name in the build directory
|
||||
export
|
||||
getExecFileName : {auto c : Ref Ctxt Defs} -> String -> Core String
|
||||
getExecFileName efile
|
||||
= do d <- getDirs
|
||||
pure $ build_dir d ++ cast sep ++ efile
|
||||
pure $ build_dir d ++ dirSep ++ efile
|
||||
|
||||
@ -8,6 +8,7 @@ public export
|
||||
record Dirs where
|
||||
constructor MkDirs
|
||||
working_dir : String
|
||||
source_dir : Maybe String -- source directory, relative to working directory
|
||||
build_dir : String -- build directory, relative to working directory
|
||||
dir_prefix : String -- installation prefix, for finding data files (e.g. run time support)
|
||||
extra_dirs : List String -- places to look for import files
|
||||
@ -16,8 +17,9 @@ record Dirs where
|
||||
|
||||
public export
|
||||
toString : Dirs -> String
|
||||
toString (MkDirs wdir bdir dfix edirs ldirs ddirs) =
|
||||
toString (MkDirs wdir sdir bdir dfix edirs ldirs ddirs) =
|
||||
unlines [ "+ Working Directory :: " ++ show wdir
|
||||
, "+ Source Directory :: " ++ show sdir
|
||||
, "+ Build Directory :: " ++ show bdir
|
||||
, "+ Installation Prefix :: " ++ show dfix
|
||||
, "+ Extra Directories :: " ++ show edirs
|
||||
@ -109,7 +111,7 @@ record Options where
|
||||
extensions : List LangExt
|
||||
|
||||
defaultDirs : Dirs
|
||||
defaultDirs = MkDirs "." "build" "/usr/local" ["."] ["."] []
|
||||
defaultDirs = MkDirs "." Nothing "build" "/usr/local" ["."] ["."] []
|
||||
|
||||
defaultPPrint : PPrinter
|
||||
defaultPPrint = MkPPOpts False True False
|
||||
|
||||
@ -25,6 +25,9 @@ record ModTree where
|
||||
sourceFile : Maybe String
|
||||
deps : List ModTree
|
||||
|
||||
Show ModTree where
|
||||
show t = show (sourceFile t) ++ " " ++ show (nspace t) ++ "<-" ++ show (deps t)
|
||||
|
||||
-- A module file to build, and its list of dependencies
|
||||
-- From this we can work out if the source file needs rebuilding, assuming
|
||||
-- things are build in dependency order. A source file needs rebuilding
|
||||
@ -122,8 +125,7 @@ getBuildMods : {auto c : Ref Ctxt Defs} ->
|
||||
getBuildMods loc fname
|
||||
= do a <- newRef AllMods []
|
||||
d <- getDirs
|
||||
|
||||
t <- mkModTree {a} loc [] (pathToNS (working_dir d) fname)
|
||||
t <- mkModTree {a} loc [] (pathToNS (working_dir d) (source_dir d) fname)
|
||||
pure (reverse (mkBuildMods [] t))
|
||||
|
||||
fnameModified : String -> Core Integer
|
||||
|
||||
@ -44,6 +44,7 @@ record PkgDesc where
|
||||
mainmod : Maybe (List String, String) -- main file (i.e. file to load at REPL)
|
||||
executable : Maybe String -- name of executable
|
||||
options : Maybe (FC, String)
|
||||
sourcedir : Maybe String
|
||||
prebuild : Maybe (FC, String) -- Script to run before building
|
||||
postbuild : Maybe (FC, String) -- Script to run after building
|
||||
preinstall : Maybe (FC, String) -- Script to run after building, before installing
|
||||
@ -65,7 +66,7 @@ Show PkgDesc where
|
||||
maybe "" (\m => "Main: " ++ snd m ++ "\n") (mainmod pkg) ++
|
||||
maybe "" (\m => "Exec: " ++ m ++ "\n") (executable pkg) ++
|
||||
maybe "" (\m => "Opts: " ++ snd m ++ "\n") (options pkg) ++
|
||||
maybe "" (\m => "Prebuild: " ++ snd m ++ "\n") (prebuild pkg) ++
|
||||
maybe "" (\m => "SourceDir: " ++ m ++ "\n") (sourcedir pkg) ++
|
||||
maybe "" (\m => "Postbuild: " ++ snd m ++ "\n") (postbuild pkg) ++
|
||||
maybe "" (\m => "Preinstall: " ++ snd m ++ "\n") (preinstall pkg) ++
|
||||
maybe "" (\m => "Postinstall: " ++ snd m ++ "\n") (postinstall pkg)
|
||||
@ -75,7 +76,7 @@ initPkgDesc pname
|
||||
= MkPkgDesc pname "0" "Anonymous" Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing
|
||||
[] []
|
||||
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data DescField : Type where
|
||||
PVersion : FC -> String -> DescField
|
||||
@ -92,6 +93,7 @@ data DescField : Type where
|
||||
PMainMod : FC -> List String -> DescField
|
||||
PExec : String -> DescField
|
||||
POpts : FC -> String -> DescField
|
||||
PSourceDir : FC -> String -> DescField
|
||||
PPrebuild : FC -> String -> DescField
|
||||
PPostbuild : FC -> String -> DescField
|
||||
PPreinstall : FC -> String -> DescField
|
||||
@ -110,6 +112,7 @@ field fname
|
||||
<|> strField PBugTracker "bugtracker"
|
||||
<|> strField POpts "options"
|
||||
<|> strField POpts "opts"
|
||||
<|> strField PSourceDir "sourcedir"
|
||||
<|> strField PPrebuild "prebuild"
|
||||
<|> strField PPostbuild "postbuild"
|
||||
<|> strField PPreinstall "preinstall"
|
||||
@ -154,37 +157,57 @@ parsePkgDesc fname
|
||||
fields <- many (field fname)
|
||||
pure (name, fields)
|
||||
|
||||
addField : {auto c : Ref Ctxt Defs} ->
|
||||
DescField -> PkgDesc -> Core PkgDesc
|
||||
addField (PVersion fc n) pkg = pure (record { version = n } pkg)
|
||||
addField (PAuthors fc a) pkg = pure (record { authors = a } pkg)
|
||||
addField (PMaintainers fc a) pkg = pure (record { maintainers = Just a } pkg)
|
||||
addField (PLicense fc a) pkg = pure (record { license = Just a } pkg)
|
||||
addField (PBrief fc a) pkg = pure (record { brief = Just a } pkg)
|
||||
addField (PReadMe fc a) pkg = pure (record { readme = Just a } pkg)
|
||||
addField (PHomePage fc a) pkg = pure (record { homepage = Just a } pkg)
|
||||
addField (PSourceLoc fc a) pkg = pure (record { sourceloc = Just a } pkg)
|
||||
addField (PBugTracker fc a) pkg = pure (record { bugtracker = Just a } pkg)
|
||||
data ParsedMods : Type where
|
||||
|
||||
addField (PDepends ds) pkg = pure (record { depends = ds } pkg)
|
||||
addField (PModules ms) pkg
|
||||
= pure (record { modules = !(traverse toSource ms) } pkg)
|
||||
where
|
||||
toSource : (FC, List String) -> Core (List String, String)
|
||||
toSource (loc, ns) = pure (ns, !(nsToSource loc ns))
|
||||
addField (PMainMod loc n) pkg
|
||||
= pure (record { mainmod = Just (n, !(nsToSource loc n)) } pkg)
|
||||
addField (PExec e) pkg = pure (record { executable = Just e } pkg)
|
||||
addField (POpts fc e) pkg = pure (record { options = Just (fc, e) } pkg)
|
||||
addField (PPrebuild fc e) pkg = pure (record { prebuild = Just (fc, e) } pkg)
|
||||
addField (PPostbuild fc e) pkg = pure (record { postbuild = Just (fc, e) } pkg)
|
||||
addField (PPreinstall fc e) pkg = pure (record { preinstall = Just (fc, e) } pkg)
|
||||
addField (PPostinstall fc e) pkg = pure (record { postinstall = Just (fc, e) } pkg)
|
||||
data MainMod : Type where
|
||||
|
||||
addField : {auto c : Ref Ctxt Defs} ->
|
||||
{auto p : Ref ParsedMods (List (FC, List String))} ->
|
||||
{auto m : Ref MainMod (Maybe (FC, List String))} ->
|
||||
DescField -> PkgDesc -> Core PkgDesc
|
||||
addField (PVersion fc n) pkg = pure $ record { version = n } pkg
|
||||
addField (PAuthors fc a) pkg = pure $ record { authors = a } pkg
|
||||
addField (PMaintainers fc a) pkg = pure $ record { maintainers = Just a } pkg
|
||||
addField (PLicense fc a) pkg = pure $ record { license = Just a } pkg
|
||||
addField (PBrief fc a) pkg = pure $ record { brief = Just a } pkg
|
||||
addField (PReadMe fc a) pkg = pure $ record { readme = Just a } pkg
|
||||
addField (PHomePage fc a) pkg = pure $ record { homepage = Just a } pkg
|
||||
addField (PSourceLoc fc a) pkg = pure $ record { sourceloc = Just a } pkg
|
||||
addField (PBugTracker fc a) pkg = pure $ record { bugtracker = Just a } pkg
|
||||
addField (PDepends ds) pkg = pure $ record { depends = ds } pkg
|
||||
-- we can't resolve source files for modules without knowing the source directory,
|
||||
-- so we save them for the second pass
|
||||
addField (PModules ms) pkg = do put ParsedMods ms
|
||||
pure pkg
|
||||
addField (PMainMod loc n) pkg = do put MainMod (Just (loc, n))
|
||||
pure pkg
|
||||
addField (PExec e) pkg = pure $ record { executable = Just e } pkg
|
||||
addField (POpts fc e) pkg = pure $ record { options = Just (fc, e) } pkg
|
||||
addField (PSourceDir fc a) pkg = pure $ record { sourcedir = Just a } pkg
|
||||
addField (PPrebuild fc e) pkg = pure $ record { prebuild = Just (fc, e) } pkg
|
||||
addField (PPostbuild fc e) pkg = pure $ record { postbuild = Just (fc, e) } pkg
|
||||
addField (PPreinstall fc e) pkg = pure $ record { preinstall = Just (fc, e) } pkg
|
||||
addField (PPostinstall fc e) pkg = pure $ record { postinstall = Just (fc, e) } pkg
|
||||
|
||||
addFields : {auto c : Ref Ctxt Defs} ->
|
||||
List DescField -> PkgDesc -> Core PkgDesc
|
||||
addFields [] desc = pure desc
|
||||
addFields (x :: xs) desc = addFields xs !(addField x desc)
|
||||
addFields xs desc = do p <- newRef ParsedMods []
|
||||
m <- newRef MainMod Nothing
|
||||
added <- go {p} {m} xs desc
|
||||
setSourceDir (sourcedir added)
|
||||
ms <- get ParsedMods
|
||||
mmod <- get MainMod
|
||||
pure $ record { modules = !(traverse toSource ms)
|
||||
, mainmod = !(traverseOpt toSource mmod)
|
||||
} added
|
||||
where
|
||||
toSource : (FC, List String) -> Core (List String, String)
|
||||
toSource (loc, ns) = pure (ns, !(nsToSource loc ns))
|
||||
go : {auto p : Ref ParsedMods (List (FC, List String))} ->
|
||||
{auto m : Ref MainMod (Maybe (FC, List String))} ->
|
||||
List DescField -> PkgDesc -> Core PkgDesc
|
||||
go [] dsc = pure dsc
|
||||
go (x :: xs) dsc = go xs !(addField x dsc)
|
||||
|
||||
runScript : Maybe (FC, String) -> Core ()
|
||||
runScript Nothing = pure ()
|
||||
@ -197,8 +220,7 @@ addDeps : {auto c : Ref Ctxt Defs} ->
|
||||
PkgDesc -> Core ()
|
||||
addDeps pkg
|
||||
= do defs <- get Ctxt
|
||||
traverse addPkgDir (depends pkg)
|
||||
pure ()
|
||||
traverse_ addPkgDir (depends pkg)
|
||||
|
||||
processOptions : {auto c : Ref Ctxt Defs} ->
|
||||
{auto o : Ref ROpts REPLOpts} ->
|
||||
|
||||
@ -185,7 +185,7 @@ processMod srcf ttcf msg mod sourcecode
|
||||
when (ns /= ["Main"]) $
|
||||
do let MkFC fname _ _ = headerloc mod
|
||||
d <- getDirs
|
||||
when (pathToNS (working_dir d) fname /= ns) $
|
||||
when (pathToNS (working_dir d) (source_dir d) fname /= ns) $
|
||||
throw (GenericMsg (headerloc mod)
|
||||
("Module name " ++ showSep "." (reverse ns) ++
|
||||
" does not match file name " ++ fname))
|
||||
@ -265,7 +265,7 @@ process buildmsg file
|
||||
then
|
||||
do defs <- get Ctxt
|
||||
d <- getDirs
|
||||
makeBuildDirectory (pathToNS (working_dir d) file)
|
||||
makeBuildDirectory (pathToNS (working_dir d) (source_dir d) file)
|
||||
logTime ("Writing TTC for " ++ file) $
|
||||
writeToTTC !(get Syn) fn
|
||||
mfn <- getTTCFileName file ".ttm"
|
||||
|
||||
@ -54,7 +54,7 @@ yaffleMain fname args
|
||||
_ => do coreLift $ putStrLn "Processing as TTImp"
|
||||
ok <- processTTImpFile fname
|
||||
when ok $
|
||||
do makeBuildDirectory (pathToNS (working_dir d) fname)
|
||||
do makeBuildDirectory (pathToNS (working_dir d) (source_dir d) fname)
|
||||
writeToTTC () !(getTTCFileName fname ".ttc")
|
||||
coreLift $ putStrLn "Written TTC"
|
||||
ust <- get UST
|
||||
|
||||
Loading…
Reference in New Issue
Block a user