tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Workspace.hs (4817B)

      1 -- Source location policy only: the portable compiler still owns all header,
      2 -- dependency, scope, cycle and cache semantics. No source rewriting occurs here.
      3 module Workspace (workspaceSources, withWorkspace, parseWorkspace) where
      4 
      5 import Control.Monad (foldM, forM, forM_, unless)
      6 import qualified Data.ByteString as BS
      7 import qualified Data.Map.Strict as M
      8 import qualified Data.Text as T
      9 import Data.Text.Encoding (decodeUtf8')
     10 import Data.Char (toLower)
     11 import Data.List (sort)
     12 import System.Directory
     13 import System.FilePath
     14 import System.IO (withBinaryFile, IOMode(ReadMode))
     15 import System.Posix.Files (getSymbolicLinkStatus, isRegularFile)
     16 import System.IO.Temp (withSystemTempDirectory)
     17 
     18 validName :: String -> Bool
     19 validName [] = False
     20 validName (c:cs) = first c && all (\x -> first x || x >= '0' && x <= '9' || x == '-') cs
     21   where first x = x >= 'a' && x <= 'z' || x >= 'A' && x <= 'Z' || x == '_'
     22 
     23 parseWorkspace :: BS.ByteString -> Either String [(String, FilePath)]
     24 parseWorkspace bytes = do
     25   unless (BS.length bytes <= 65536) $ Left "workspace exceeds 64 KiB"
     26   text <- either (const $ Left "workspace must be UTF-8") Right (decodeUtf8' bytes)
     27   unless (T.isSuffixOf "\n" text && not (T.any (== '\r') text)) $
     28     Left "workspace requires LF lines and a final newline"
     29   case T.lines text of
     30     "tricu.workspace.v1":rows -> reverse . snd <$> foldM row ([], []) rows
     31     _ -> Left "invalid workspace header (expected tricu.workspace.v1)"
     32   where
     33     row (seen, entries) line = case map T.unpack (T.splitOn "\t" line) of
     34       [name,path] -> do
     35         unless (validName name && length name <= 128) $ Left "invalid workspace module name"
     36         unless (not (null path) && not (isAbsolute path) && takeExtension path == ".tri" && all (>= ' ') path) $
     37           Left "workspace paths must be relative .tri paths"
     38         let key = map toLower name
     39         unless (key `notElem` seen) $ Left ("duplicate workspace module: " ++ name)
     40         pure (key:seen, (name,path):entries)
     41       _ -> Left "workspace rows require NAME<TAB>PATH"
     42 
     43 findWorkspace :: FilePath -> IO (Maybe FilePath)
     44 findWorkspace directory = do
     45   let path = directory </> "tricu.workspace"
     46   exists <- doesPathExist path
     47   if exists then pure (Just path)
     48   else if takeDirectory directory == directory then pure Nothing
     49   else findWorkspace (takeDirectory directory)
     50 
     51 -- The nearest declaration is authoritative; parent declarations are not merged.
     52 -- Sibling modules remain available, but may not silently shadow mapped modules.
     53 workspaceSources :: FilePath -> IO (M.Map String FilePath)
     54 workspaceSources input = do
     55   regularSource input
     56   source <- canonicalizePath input
     57   let directory = takeDirectory source
     58   unless (takeExtension source == ".tri" && validName (takeBaseName source)) $
     59     fail "Portable compilation requires a .tri module with a valid module basename"
     60   declaration <- findWorkspace directory
     61   mapped <- case declaration of
     62     Nothing -> pure []
     63     Just path -> do
     64       regularSource path
     65       bytes <- withBinaryFile path ReadMode (\h -> BS.hGet h 65537)
     66       rows <- either (fail . ((path ++ ": ") ++)) pure (parseWorkspace bytes)
     67       forM rows $ \(name,relative) -> do
     68         regularSource (takeDirectory path </> relative)
     69         resolved <- canonicalizePath (takeDirectory path </> relative)
     70         exists <- doesFileExist resolved
     71         unless exists $ fail ("Workspace module missing: " ++ name ++ " at " ++ resolved)
     72         pure (name,resolved)
     73   siblings <- sort <$> listDirectory directory
     74   local <- forM [p | p <- siblings, takeExtension p == ".tri", validName (takeBaseName p)] $ \p -> do
     75     regularSource (directory </> p)
     76     resolved <- canonicalizePath (directory </> p)
     77     pure (takeBaseName p,resolved)
     78   foldM insert M.empty (mapped ++ local)
     79   where
     80     insert entries (name,path) = do
     81       let collisions = [(n,p) | (n,p) <- M.toList entries, map toLower n == map toLower name]
     82       case collisions of
     83         [] -> pure (M.insert name path entries)
     84         [(n,p)] | n == name && p == path -> pure entries
     85         _ -> fail ("Ambiguous workspace module: " ++ name ++ " (mapped and/or sibling sources conflict)")
     86 
     87 -- Snapshot locations into the existing compiler ABI. Temporary paths are not
     88 -- build identities; receipts use module names and source bytes, as before.
     89 withWorkspace :: FilePath -> (FilePath -> IO a) -> IO a
     90 withWorkspace input action = do
     91   sources <- workspaceSources input
     92   withSystemTempDirectory "tricu-workspace" $ \directory -> do
     93     forM_ (M.toList sources) $ \(name,path) -> copyFile path (directory </> name <.> "tri")
     94     action directory
     95 
     96 regularSource :: FilePath -> IO ()
     97 regularSource path = do
     98   status <- getSymbolicLinkStatus path
     99   unless (isRegularFile status) $ fail ("Workspace inputs require regular files (no symlinks): " ++ path)