diff --git a/.gitignore b/.gitignore index a452419f..3aef4c1a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,5 @@ dist-newstyle dist/ -weeder.toml .hie *.o *\.bin diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 00000000..1c84e36e --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,13 @@ +# HLint configuration for the VoLCA engine. +# +# Its presence activates the hlint step in CI, which otherwise skips when no config is +# found. Run locally with: hlint src/ +# +# The hygiene pass either *fixes* a hint or *baselines* it here with a one-line reason. +# All default hints on src/ are fixed; the single baseline below is a deliberate +# exception where the suggested rewrite conflicts with a stronger code-safety rule. + +# `cells !! 0` is guarded by `length cells > colIdx + 2`, so it never fails — but the +# suggested `head cells` is a partial function we ban project-wide. Keep the guarded +# indexing rather than reintroduce `head`. +- ignore: {name: "Use head", within: Method.ParserCSV} diff --git a/CHANGELOG.md b/CHANGELOG.md index d842f67f..5a6806b7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,15 @@ ## [Unreleased] ### Added +- A loaded database can be exported to any of the five supported formats — + SimaPro CSV, EcoSpold 1, EcoSpold 2, ILCD, and Brightway Excel — from both the + API and the CLI, so a database can be moved between tools or re-saved after edits. +- A loaded database can be edited in place: copy it under a new name, delete a + filtered selection of activities, or relink it against a dependency through a + name-to-name alias map. +- Activity records now carry separate `activity_name` and `product_name` fields, + instead of the old `name`/`product` that blurred an activity and its reference + product. - A partial EcoSpold2 import (a handful of `.spold` files cut from a full database) now becomes analyzable by loading its matching ecoinvent background as a dependency: each input is linked to the exact background activity it @@ -19,6 +28,27 @@ connect time to confirm they speak this engine's JSON format, so a version mismatch fails with a clear message instead of a confusing decode error. +### Changed +- Far broader EF 3.1 impact coverage: flows are matched by CAS number across + naming schemes, a substance registry bridges nomenclatures, sub-compartments + fall back sensibly, energy-carrier flows are characterized from their energy + content, land use is regionalized with per-country factors, and a large synonym + set links ecoinvent and Agribalyse flows to the method. Many products that + previously scored short are now characterized. +- Large database uploads stream as raw bytes instead of base64-encoded JSON, + cutting memory use and time on big files. +- A supplier substitution applies across every consumer of the substituted + product, not only the process you queried. + +### Fixed +- ecoinvent waste-treatment activities import and score correctly: the reference + flow stays in the technosphere (these activities are no longer dropped) and + cross-database waste keeps the correct sign. +- EcoSpold packages whose datasets live in a sub-directory now load. +- Requesting a well-formed but non-existent process returns a clear "activity not + found" instead of a confusing error. +- A missing reference CSV is reported as an error instead of crashing the load. + ## [0.7.0] - 2026-05-29 A month of engine work: a third flow kind for waste, regionalized impact diff --git a/bench/Bench/Helpers.hs b/bench/Bench/Helpers.hs index 10fd8982..5475faf7 100644 --- a/bench/Bench/Helpers.hs +++ b/bench/Bench/Helpers.hs @@ -14,7 +14,7 @@ import Data.Text (Text) import Database (buildDatabaseWithMatrices) import qualified Database.Loader as Loader -import Types (Database, sdbActivities, sdbBioFlows, sdbTechFlows, sdbUnits) +import Types (Database, sdbActivities, sdbBioFlows, sdbTechFlows, sdbUnits, sdbWasteFlows) import qualified UnitConversion as UC {- | Parse a fixture path and build the indexed 'Database' with matrices. @@ -36,6 +36,7 @@ loadFullDatabase path = do (sdbActivities sdb) (sdbTechFlows sdb) (sdbBioFlows sdb) + (sdbWasteFlows sdb) (sdbUnits sdb) case built of Left err -> pure (Left ("buildDatabaseWithMatrices failed: " <> err)) diff --git a/bench/Bench/Lcia.hs b/bench/Bench/Lcia.hs index 5da08be6..d165fc0d 100644 --- a/bench/Bench/Lcia.hs +++ b/bench/Bench/Lcia.hs @@ -49,7 +49,6 @@ import Types ( Indexes (..), ProductIndex (..), Unit (..), - emptyCrossDBLinkingStats, ) import qualified UnitConversion as UC @@ -145,6 +144,7 @@ emptyDatabase = , dbActivities = V.empty , dbTechFlows = M.empty , dbBioFlows = M.empty + , dbWasteFlows = M.empty , dbUnits = M.empty , dbIndexes = Indexes M.empty M.empty M.empty M.empty , dbTechnosphereTriples = U.empty @@ -155,7 +155,7 @@ emptyDatabase = , dbBiosphereCount = 0 , dbCrossDBLinks = [] , dbDependsOn = [] - , dbLinkingStats = emptyCrossDBLinkingStats + , dbLinkingStats = mempty , dbSynonymDB = Nothing , dbFlowsByName = M.empty , dbFlowsByCAS = M.empty @@ -197,7 +197,7 @@ buildFixture = ] methods = [mkMethod m [] | m <- [1 .. nMethods]] - rawTables = [buildMethodTables M.empty (mappingsFor s) | s <- [1 .. nMethods]] + rawTables = [buildMethodTables M.empty M.empty (mappingsFor s) | s <- [1 .. nMethods]] filledTables = map (fillBroadcastVector unitCfg unitDB flowDB) rawTables setTables = buildMethodSetTables (zip methods filledTables) @@ -338,7 +338,7 @@ registerReal = do mappings <- mapMethodToFlows Builtin.defaultMappers db method let unitDB = dbUnits db flowDB = dbBioFlows db - tables0 = buildMethodTables M.empty mappings + tables0 = buildMethodTables M.empty M.empty mappings !tables = fillBroadcastVector UC.defaultUnitConfig unitDB flowDB tables0 !nCFs = length (methodFactors method) putStrLn "[bench] lcia.real.score_method: computing inventory for first product..." diff --git a/bench/Bench/Loader.hs b/bench/Bench/Loader.hs index 7ce57e13..db724a41 100644 --- a/bench/Bench/Loader.hs +++ b/bench/Bench/Loader.hs @@ -27,7 +27,7 @@ import qualified Data.Text as T import qualified Database.CrossLinking as CL import qualified Database.Loader as Loader import qualified SynonymDB.Types as Syn -import Types (cdlTotalInputs, sdbActivities) +import Types (GeographyPolicy (..), cdlTotalInputs, sdbActivities) import qualified UnitConversion as UC import Bench.Json (BenchSpec (..), UnitOfWork (..)) @@ -132,6 +132,7 @@ registerCrossDbLinking = do Syn.emptySynonymDB UC.defaultUnitConfig M.empty + GeoGlobal fgPath case probeRes of Left err -> do @@ -179,6 +180,7 @@ crossLinkBench bgIndex fgPath = nfIO $ do Syn.emptySynonymDB UC.defaultUnitConfig M.empty + GeoGlobal fgPath case r of Left err -> evaluate (T.length err) diff --git a/bench/Bench/Parsers.hs b/bench/Bench/Parsers.hs index e136077b..6a396b2e 100644 --- a/bench/Bench/Parsers.hs +++ b/bench/Bench/Parsers.hs @@ -177,7 +177,7 @@ registerSimaPro = do Nothing -> pure [] Just path -> do -- Parse once to learn N_actual; the bench measurement re-parses fresh. - (acts, _, _, _) <- SP.parseSimaProCSV UC.defaultUnitConfig path + (acts, _, _, _, _) <- SP.parseSimaProCSV UC.defaultUnitConfig path let !n = length acts pure [ BenchSpec @@ -192,7 +192,7 @@ registerSimaPro = do , bsMetric = "seconds" , bsFixture = J.Fixture{J.fSource = F.fixtureSourceLabel F.Agribalyse, J.fSlice = "whole file"} , bsAction = nfIO $ do - (acts', _, _, _) <- SP.parseSimaProCSV UC.defaultUnitConfig path + (acts', _, _, _, _) <- SP.parseSimaProCSV UC.defaultUnitConfig path evaluate (length acts') } ] diff --git a/src/API/Auth.hs b/src/API/Auth.hs index fb3c67a4..b999c756 100644 --- a/src/API/Auth.hs +++ b/src/API/Auth.hs @@ -24,12 +24,9 @@ authMiddleware expectedPassword app req respond = isLoginEndpoint = requestMethod req == "POST" && path == "/api/v1/auth" in -- Only protect /api/ routes; static files and SPA index are public -- (so the browser can load the login page) - if not isApiRoute || isLoginEndpoint + if not isApiRoute || isLoginEndpoint || isAuthenticated expectedPassword req then app req respond - else - if isAuthenticated expectedPassword req - then app req respond - else respond unauthorized + else respond unauthorized where unauthorized = responseLBS diff --git a/src/API/DatabaseHandlers.hs b/src/API/DatabaseHandlers.hs index b79a9e00..bcf5e82a 100644 --- a/src/API/DatabaseHandlers.hs +++ b/src/API/DatabaseHandlers.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {- | Module : API.DatabaseHandlers diff --git a/src/API/MCP.hs b/src/API/MCP.hs index bba40f99..004fd20c 100644 --- a/src/API/MCP.hs +++ b/src/API/MCP.hs @@ -52,7 +52,7 @@ import qualified Service import qualified Service.Aggregate as Agg import SharedSolver (SharedSolver, computeInventoryMatrixWithDepsCached, crossDBProcessContributions) import qualified SharedSolver -import Types (Activity (..), BioFlowDB, BiosphereFlow (..), Database (..), Indexes (..), ProcessId, UUID, UnitDB, activityLocation, activityName, bfCompartmentName, bfCompartmentSub, exchangeIsInput, getUnitNameForBioFlow, isTechnosphereExchange, processIdToText, unresolvedCount) +import Types (Activity (..), BiosphereFlow (..), Database (..), Indexes (..), ProcessId, UUID, UnitDB, activityLocation, activityName, bfCompartmentName, bfCompartmentSub, exchangeIsInput, getUnitNameForBioFlow, processIdToText, unresolvedCount) import UnitConversion (defaultUnitConfig) -- --------------------------------------------------------------------------- @@ -1429,13 +1429,12 @@ mkMcpCrossDBEntry :: Text -> -- | method UUID text Text -> - BioFlowDB -> UnitDB -> -- | total score (for share %) Double -> ((Text, ProcessId), Double) -> IO Value -mkMcpCrossDBEntry dbManager rootDbName mBaseUrl colName methodIdText flowDB unitDB score ((depDbName, pid), c) = do +mkMcpCrossDBEntry dbManager rootDbName mBaseUrl colName methodIdText unitDB score ((depDbName, pid), c) = do mLd <- getDatabase dbManager depDbName let (actName, actLoc, prodName, pidText) = case mLd of Just ld -> @@ -1708,7 +1707,7 @@ callGetContributingActivities dbManager mBaseUrl rid args = sorted = L.sortOn (\(_, c) -> negate (abs c)) (M.toList contributions) top = take lim sorted hasNeg = any (\(_, c) -> c < 0) top - rows <- liftIO $ mapM (mkMcpCrossDBEntry dbManager dbName mBaseUrl (lrCollection req) (lrMethodIdText req) mFlows mUnits score) top + rows <- liftIO $ mapM (mkMcpCrossDBEntry dbManager dbName mBaseUrl (lrCollection req) (lrMethodIdText req) mUnits score) top pure $ toolSuccessJson rid $ object diff --git a/src/API/OpenApi.hs b/src/API/OpenApi.hs index 04eaf677..35a8f5fa 100644 --- a/src/API/OpenApi.hs +++ b/src/API/OpenApi.hs @@ -12,22 +12,22 @@ entry in 'API.Resources'. The actual spec derivation from 'LCAAPI' lives in 'API.Routes' to break an otherwise-circular dependency (API.Routes -> API.OpenApi -> API.Routes). -} -module API.OpenApi (enrichWithResources) where +module API.OpenApi (enrichWithResources, stampInfo) where import API.JsonOptions (strippedSchemaOptions) import API.Resources (Resource) import qualified API.Resources as R import API.Types -import Control.Lens ((%~), (&), (?~), (^.)) -import Data.Aeson (Value, toJSON) +import Control.Lens ((%~), (&), (.~), (?~), (^.)) +import Data.Aeson (Value) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.OpenApi import qualified Data.OpenApi.Lens as OA import Data.Text (Text) import qualified Data.Text as T -import Database.Manager (DatabaseSetupInfo, DependencyChoice, DependencyStatus, MissingSupplier) +import Database.Manager (DatabaseSetupInfo) import Network.HTTP.Types.Method (StdMethod (..)) -import Types (LocationFallback, LocationKind, LocationUnresolved) +import qualified Version {- | Orphan schema instance forward declaration for the login request body. The real type lives in "API.Routes"; this is defined there and re-imported @@ -75,6 +75,17 @@ instance ToSchema BinaryContent where NamedSchema (Just "OctetStream") $ mempty & type_ ?~ OpenApiString & format ?~ "binary" +{- | Stamp the spec's @info@ block so each generated @openapi.json@ self-identifies: +@info.version@ = the engine version, @info.title@ = the engine name. servant-openapi3 +leaves both blank, which makes a published spec un-anchorable; stamping them lets a +release's surface be diffed against the previous one. +-} +stampInfo :: OpenApi -> OpenApi +stampInfo spec = + spec + & OA.info . OA.title .~ "VoLCA" + & OA.info . OA.version .~ T.pack Version.version + {- | Walk the spec and stamp metadata from 'API.Resources' onto each resource-backed operation. Operations without a matching 'Resource' (e.g. infrastructure endpoints like @/auth@, @/logs@, @/version@) are diff --git a/src/API/Routes.hs b/src/API/Routes.hs index be3d6e4c..785afea3 100644 --- a/src/API/Routes.hs +++ b/src/API/Routes.hs @@ -382,7 +382,7 @@ Built in two steps: on @operationId@ (e.g. @"get_impacts"@). -} volcaOpenApi :: OpenApi -volcaOpenApi = API.OpenApi.enrichWithResources (toOpenApi (Proxy :: Proxy LCAAPI)) +volcaOpenApi = API.OpenApi.stampInfo (API.OpenApi.enrichWithResources (toOpenApi (Proxy :: Proxy LCAAPI))) {- | Expand a named classification preset from config into the (system, value, exact) triples used by the Service/Aggregate layers. diff --git a/src/CLI/Client.hs b/src/CLI/Client.hs index d5522a7e..70500e1c 100644 --- a/src/CLI/Client.hs +++ b/src/CLI/Client.hs @@ -21,6 +21,7 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.List (intercalate, transpose) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Text (Text) @@ -237,7 +238,7 @@ extractLoadedDbNames = fromMaybe [] . parseMaybe go go :: Value -> Parser [Text] go = withObject "resp" $ \obj -> do dbs <- obj .: "dlrDatabases" - fmap catMaybes $ mapM getName dbs + catMaybes <$> mapM getName dbs getName :: Value -> Parser (Maybe Text) getName = withObject "db" $ \db -> do status <- db .: "dsaStatus" @@ -310,9 +311,9 @@ buildQuery params = where urlEncode = concatMap encodeChar encodeChar c - | c >= 'A' && c <= 'Z' = [c] - | c >= 'a' && c <= 'z' = [c] - | c >= '0' && c <= '9' = [c] + | isAsciiUpper c = [c] + | isAsciiLower c = [c] + | isDigit c = [c] | c `elem` ("-_.~" :: String) = [c] | otherwise = '%' : showHex2 (fromEnum c) showHex2 n = [hexDigit (n `div` 16), hexDigit (n `mod` 16)] @@ -427,7 +428,7 @@ extractTable :: [Value] -> ([String], [[String]]) extractTable [] = ([], []) extractTable rows@(Object first : _) = let keys = map fst (KM.toList first) - headers = map (Key.toString) keys + headers = map Key.toString keys dataRows = map (rowValues keys) rows in (headers, dataRows) extractTable rows = (["value"], map (\v -> [cellValue v]) rows) diff --git a/src/CLI/Command.hs b/src/CLI/Command.hs index 30e9ad66..661aad0b 100644 --- a/src/CLI/Command.hs +++ b/src/CLI/Command.hs @@ -314,10 +314,10 @@ executeExportMatricesCommand registry database outputDir = do ehExport exporter ctx outputDir Nothing -> Service.exportUniversalMatrixFormat outputDir database reportProgress Info "Matrix export completed" - reportProgress Info $ " - ie_index.csv (activity index)" - reportProgress Info $ " - ee_index.csv (biosphere flow index)" - reportProgress Info $ " - A_public.csv (technosphere matrix)" - reportProgress Info $ " - B_public.csv (biosphere matrix)" + reportProgress Info " - ie_index.csv (activity index)" + reportProgress Info " - ee_index.csv (biosphere flow index)" + reportProgress Info " - A_public.csv (technosphere matrix)" + reportProgress Info " - B_public.csv (biosphere matrix)" -- | Execute plugin list command executePluginList :: PluginRegistry -> OutputFormat -> IO () @@ -338,14 +338,11 @@ executePluginList registry fmt = do where pluginEntry name typ backend mPriority = object $ - concat - [ - [ "name" .= name - , "type" .= (typ :: T.Text) - , "backend" .= backendText backend - ] - , maybe [] (\p -> ["priority" .= p]) mPriority - ] + [ "name" .= name + , "type" .= (typ :: T.Text) + , "backend" .= backendText backend + ] + ++ maybe [] (\p -> ["priority" .= p]) mPriority backendText Builtin = "builtin" :: T.Text backendText (External p) = "external:" <> T.pack p diff --git a/src/CLI/Parser.hs b/src/CLI/Parser.hs index b87eaeea..a6745e3e 100644 --- a/src/CLI/Parser.hs +++ b/src/CLI/Parser.hs @@ -4,6 +4,7 @@ module CLI.Parser where import CLI.Types +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Options.Applicative @@ -110,7 +111,7 @@ commandParser = -- | Database command parser with optional subcommand (defaults to list) databaseParser :: Parser Command databaseParser = - Database . maybe DbList id + Database . fromMaybe DbList <$> optional ( subparser ( OA.command "list" (info (pure DbList) (progDesc "List databases")) @@ -169,7 +170,7 @@ deleteActivitiesArgsParser = -- | Method command parser with optional subcommand (defaults to list) methodParser :: Parser Command methodParser = - Method . maybe McList id + Method . fromMaybe McList <$> optional ( subparser ( OA.command "list" (info (pure McList) (progDesc "List method collections")) @@ -181,7 +182,7 @@ methodParser = -- | Plugin command parser with optional subcommand (defaults to list) pluginParser :: Parser Command pluginParser = - Plugin . maybe PluginList id + Plugin . fromMaybe PluginList <$> optional ( subparser (OA.command "list" (info (pure PluginList) (progDesc "List registered plugins"))) @@ -265,10 +266,10 @@ searchFlowsParser = do -- | Impacts (LCIA) command parser impactsParser :: Parser Command -impactsParser = do - uuid <- argument textReader (metavar "PROCESS_ID" <> help "ProcessId (activity_uuid_product_uuid format) for impact assessment") - options <- lciaOptionsParser - pure $ Impacts uuid options +impactsParser = + Impacts + <$> argument textReader (metavar "PROCESS_ID" <> help "ProcessId (activity_uuid_product_uuid format) for impact assessment") + <*> lciaOptionsParser -- | LCIA options parser lciaOptionsParser :: Parser LCIAOptions @@ -280,10 +281,10 @@ lciaOptionsParser = do -- | Debug matrices command parser debugMatricesParser :: Parser Command -debugMatricesParser = do - uuid <- argument textReader (metavar "PROCESS_ID" <> help "ProcessId (activity_uuid_product_uuid format) for matrix debugging") - options <- debugMatricesOptionsParser - pure $ DebugMatrices uuid options +debugMatricesParser = + DebugMatrices + <$> argument textReader (metavar "PROCESS_ID" <> help "ProcessId (activity_uuid_product_uuid format) for matrix debugging") + <*> debugMatricesOptionsParser -- | Debug matrices options parser debugMatricesOptionsParser :: Parser DebugMatricesOptions diff --git a/src/CLI/Repl.hs b/src/CLI/Repl.hs index e47cd6ae..94304511 100644 --- a/src/CLI/Repl.hs +++ b/src/CLI/Repl.hs @@ -7,6 +7,7 @@ import CLI.Parser (commandParser) import CLI.Types import Control.Concurrent (threadDelay) import Control.Exception (SomeException, bracket, try) +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value) import qualified Data.Aeson @@ -62,7 +63,7 @@ runRepl mgr rc globalOpts cfgFile = do Nothing -> return () -- Ctrl+D Just input -> do cont <- dispatch stateRef (words input) - if cont then loop stateRef else return () + when cont $ loop stateRef dispatch _ [] = return True dispatch _ [":quit"] = return False diff --git a/src/CLI/Types.hs b/src/CLI/Types.hs index 8938a658..2ea0e234 100644 --- a/src/CLI/Types.hs +++ b/src/CLI/Types.hs @@ -2,6 +2,7 @@ module CLI.Types where +import Data.Char (isAsciiUpper) import Data.Text (Text) import GHC.Generics @@ -225,4 +226,4 @@ parseOutputFormat s = case map toLower s of "pretty" -> Just Pretty _ -> Nothing where - toLower c = if c >= 'A' && c <= 'Z' then toEnum (fromEnum c + 32) else c + toLower c = if isAsciiUpper c then toEnum (fromEnum c + 32) else c diff --git a/src/Config.hs b/src/Config.hs index c66c1637..77ff4680 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -29,7 +29,7 @@ module Config ( resolveLoadOrder, ) where -import Control.Monad (forM_, when) +import Control.Monad (forM_, unless, when) import Data.List (isPrefixOf) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -362,7 +362,7 @@ validateConfig cfg = do -- Check for duplicate database names let dbNames = map dcName (cfgDatabases cfg) duplicates = findDuplicates dbNames - when (not $ null duplicates) $ + unless (null duplicates) $ Left $ "Duplicate database names: " <> T.intercalate ", " duplicates @@ -376,7 +376,7 @@ validateConfig cfg = do let nameSet = S.fromList dbNames forM_ (cfgDatabases cfg) $ \db -> forM_ (dcDepends db) $ \dep -> - when (not $ S.member dep nameSet) $ + unless (S.member dep nameSet) $ Left $ "Database \"" <> dcName db <> "\" depends on unknown database: \"" <> dep <> "\"" @@ -389,7 +389,7 @@ validateConfig cfg = do -- | Find duplicates in a list findDuplicates :: (Eq a) => [a] -> [a] -findDuplicates xs = go [] [] xs +findDuplicates = go [] [] where go _ dups [] = dups go seen dups (x : rest) @@ -429,6 +429,6 @@ resolveLoadOrder configs = | otherwise = Left "Cycle detected in database dependencies" go revAdj degrees (n : q) result expected = let dependents = M.findWithDefault [] n revAdj - degrees' = foldl (\d dep -> M.adjust (subtract 1) dep d) degrees dependents + degrees' = foldl (flip (M.adjust (subtract 1))) degrees dependents newReady = [dep | dep <- dependents, M.findWithDefault 1 dep degrees' == 0] in go revAdj degrees' (q ++ newReady) (n : result) expected diff --git a/src/Database/CrossLinking.hs b/src/Database/CrossLinking.hs index ebef6f79..89ebcfe3 100644 --- a/src/Database/CrossLinking.hs +++ b/src/Database/CrossLinking.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {- | Cross-Database Activity Linking @@ -67,6 +68,7 @@ module Database.CrossLinking ( normalizeUnicode, ) where +import Data.Bifunctor (first) import Data.Char (isAlpha, isUpper) import Data.Foldable (find) import Data.List (maximumBy) @@ -619,7 +621,7 @@ findSupplierInIndexedDBs LinkingContext{..} productName location unit = Nothing -> CrossDBNotLinked (LocationUnavailable effectiveLocation) _ -> - let scored = map (\(entry, kind) -> (scoreEntry effectiveLocation entry, kind)) accepted + let scored = map (first (scoreEntry effectiveLocation)) accepted !(bestCand, bestKind) = maximumBy (comparing (cdbScore . fst)) scored -- Other databases whose surviving best candidate ties the -- winner's score. Dedup by DB name to ignore intra-DB ties. @@ -636,9 +638,9 @@ findSupplierInIndexedDBs LinkingContext{..} productName location unit = in if cdbScore bestCand >= lcThreshold then let warnings = - if T.null location || bestKind == ExactLoc - then [] - else [UpperLocationUsed effectiveLocation (cdbLocation bestCand) bestKind] + [ UpperLocationUsed effectiveLocation (cdbLocation bestCand) bestKind + | not (T.null location || bestKind == ExactLoc) + ] in CrossDBLinked { cdlrActivityUUID = cdbActivityUUID bestCand , cdlrProductUUID = cdbProductUUID bestCand @@ -698,7 +700,7 @@ findSupplierInIndexedDBs LinkingContext{..} productName location unit = let permissive = mapMaybe ( \(_, SupplierEntry{seLocation}) -> - (\k -> (seLocation, k)) + (seLocation,) <$> acceptableLocation GeoGlobal lcLocationHierarchy queryLoc seLocation ) candidates diff --git a/src/Database/Export.hs b/src/Database/Export.hs index cea2924f..e47b0f41 100644 --- a/src/Database/Export.hs +++ b/src/Database/Export.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {- | Format dispatch for database export. @@ -51,14 +52,14 @@ serializeDatabase fmt db = case fmt of EcoSpold1 -> noWarn (BL.fromStrict . TE.encodeUtf8 <$> ES1.writeDatabase ES1.canonicalWriterOptions db) EcoSpold2 -> noWarn (zipText <$> ES2.writeEcoSpold2 ES2.noVolatileMeta sdb) ILCDProcess -> noWarn (ILCD.writeILCDArchive ILCD.defaultWriteOptions sdb) - BrightwayExcel -> (\bytes -> (bytes, BE.wasteManifest sdb)) <$> BE.renderWorkbook BE.defaultWriterConfig sdb + BrightwayExcel -> (,BE.wasteManifest sdb) <$> BE.renderWorkbook BE.defaultWriterConfig sdb OpenLcaJsonLd -> Left "openLCA JSON-LD export is not supported" UnknownFormat -> Left "cannot export to an unknown format" where sdb = toSimpleDatabase db - noWarn = fmap (\bytes -> (bytes, [])) + noWarn = fmap (,[]) {- | Parse a user-facing export-format name (case- and whitespace-insensitive) to a 'DatabaseFormat'. Shared by the CLI and the HTTP handler so the accepted diff --git a/src/Database/Loader.hs b/src/Database/Loader.hs index c0063bca..fff0517c 100644 --- a/src/Database/Loader.hs +++ b/src/Database/Loader.hs @@ -1,6 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -85,18 +83,19 @@ import Control.Monad import Data.Bits (xor) import qualified Data.ByteString as BS import Data.Char (toLower) -import Data.Either (partitionEithers) +import Data.Either (lefts, partitionEithers, rights) import Data.List (sort, sortBy, sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Ord (Down (..)) +import Data.Proxy (Proxy (..)) import qualified Data.Set as S import Data.Store (decodeEx, encode) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time (UTCTime, diffUTCTime, getCurrentTime) -import Data.Typeable (typeOf, typeRepFingerprint) +import Data.Typeable (typeRep, typeRepFingerprint) import qualified Data.UUID as UUID import qualified Data.UUID.V5 as UUID5 import qualified Data.Vector as V @@ -189,7 +188,7 @@ If it doesn't match, the cache is automatically invalidated and rebuilt. -} schemaSignature :: Word64 schemaSignature = - let Fingerprint hi lo = typeRepFingerprint (typeOf (undefined :: Database)) + let Fingerprint hi lo = typeRepFingerprint (typeRep (Proxy :: Proxy Database)) in hi `xor` lo `xor` 7 {- | @@ -727,11 +726,11 @@ loadEcoSpoldDirectory locationAliases dir = do results <- mapConcurrently (processWorker startTime isEcoSpold1) (zip [1 ..] workers) -- Check for errors from any worker - let errors = [e | Left e <- results] + let errors = lefts results case errors of (firstErr : _) -> return $ Left firstErr [] -> do - let successResults = [r | Right r <- results] + let successResults = rights results let (procMaps, techFlowMaps, bioFlowMaps, wasteFlowMaps, unitMaps, rawFlowCounts, rawUnitCounts, dsIndexes, supplierLinksLists) = unzip9 successResults let !finalProcMap = M.unions procMaps let !finalTechFlowMap = M.unionsWith mergeTechFlows techFlowMaps @@ -809,10 +808,10 @@ loadEcoSpoldDirectory locationAliases dir = do let procEntries = zipWith (buildProcEntry isEcoSpold1) okFiles procs - case [e | Left e <- procEntries] of + case lefts procEntries of (firstErr : _) -> return $ Left firstErr [] -> do - let !procMap = M.fromList [e | Right e <- procEntries] + let !procMap = M.fromList (rights procEntries) let !techFlowMap = M.fromListWith mergeTechFlows [(tfId f, f) | f <- allTechs] let !bioFlowMap = M.fromListWith mergeBioFlows [(bfId f, f) | f <- allBios] let !wasteFlowMap = M.fromList [(wfId f, f) | f <- allWastes] @@ -1712,7 +1711,7 @@ reportCrossDBLinkingStats nActivities stats = do -- Missing suppliers let !missing = sortOn (\(_, (cnt, _)) -> Down cnt) $ M.toList (cdlUnresolvedProducts stats) - when (not (null missing)) $ do + unless (null missing) $ do reportProgress Warning $ printf "Missing suppliers: %d products unresolved" (length missing) forM_ (take 20 missing) $ \(name, (cnt, blocker)) -> @@ -1724,7 +1723,7 @@ reportCrossDBLinkingStats nActivities stats = do -- Unknown units let !unknowns = S.toList (cdlUnknownUnits stats) - when (not (null unknowns)) $ + unless (null unknowns) $ reportProgress Warning $ printf "Unknown units: %s" (T.unpack $ T.intercalate ", " unknowns) diff --git a/src/Database/Manager.hs b/src/Database/Manager.hs index ba63e761..7294eb08 100644 --- a/src/Database/Manager.hs +++ b/src/Database/Manager.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} diff --git a/src/Database/RelinkMapping.hs b/src/Database/RelinkMapping.hs index 25932b8c..26644c01 100644 --- a/src/Database/RelinkMapping.hs +++ b/src/Database/RelinkMapping.hs @@ -88,8 +88,8 @@ blank (whitespace-only) cell normalizes to 'Nothing' so "absent" has a single representation before any consumer relies on it. -} optField :: Csv.NamedRecord -> [Text] -> Csv.Parser (Maybe Text) -optField r names = - foldr (\nm acc -> (blankToNothing <$> r .: enc nm) <|> acc) (pure Nothing) names +optField r = + foldr (\nm acc -> (blankToNothing <$> r .: enc nm) <|> acc) (pure Nothing) where blankToNothing = mfilter (not . T.null) . Just . T.strip @@ -129,8 +129,8 @@ with conflicting targets, fail rather than silently pick one. Identical duplicates collapse harmlessly. -} buildAliasMap :: [AliasRow] -> Either Text (Map Text Text) -buildAliasMap rows = - foldr step (Right M.empty) rows +buildAliasMap = + foldr step (Right M.empty) where step row acc = do m <- acc diff --git a/src/Database/UploadedDatabase.hs b/src/Database/UploadedDatabase.hs index a4e1ec5f..02c91ba5 100644 --- a/src/Database/UploadedDatabase.hs +++ b/src/Database/UploadedDatabase.hs @@ -28,6 +28,7 @@ module Database.UploadedDatabase ( import Control.Exception (SomeException, try) import Control.Monad (filterM, forM) +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -122,7 +123,7 @@ parseMetaToml content = do , let v = T.strip $ T.drop 1 rest ] getValue key = lookup key kvPairs - unquote t = T.dropAround (== '"') t + unquote = T.dropAround (== '"') version <- getValue "version" >>= readMaybe . T.unpack displayName <- unquote <$> getValue "displayName" @@ -192,7 +193,7 @@ scanUploadsIn dir = do return $ case maybeMeta of Just meta -> Just (slug, dirPath, meta) Nothing -> Nothing - return [r | Just r <- results] + return (catMaybes results) {- | Discover all uploaded databases by scanning the uploads directory Scans ./uploads/databases/ first, then legacy ./uploads/ for backward compat diff --git a/src/EcoSpold/Parser2.hs b/src/EcoSpold/Parser2.hs index 98415c98..57d24f85 100644 --- a/src/EcoSpold/Parser2.hs +++ b/src/EcoSpold/Parser2.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module EcoSpold.Parser2 (streamParseActivityAndFlowsFromFile, normalizeCAS) where @@ -321,13 +322,13 @@ resolveGroups inG outG st = -- | Warning emitted (as a singleton, else empty) when an exchange has no unit name. missingUnitWarning :: String -> Text -> Text -> [String] -missingUnitWarning kind flowId unitName = +missingUnitWarning kind flowId unitNm = [ "[WARNING] Missing unit name for " ++ kind ++ " exchange with flow ID: " ++ T.unpack flowId ++ " - using 'UNKNOWN_UNIT' placeholder" - | T.null unitName + | T.null unitNm ] -- | Parse a UUID, treating the empty string as the nil UUID (no warning). @@ -673,7 +674,7 @@ parseWithXeno xmlContent processId = do bios = reverse (psBioFlows st) wastes = reverse (psWasteFlows st) units = reverse (psUnits st) - in (\act -> (act, techs, bios, wastes, units)) <$> applyCutoffStrategy activity + in (,techs,bios,wastes,units) <$> applyCutoffStrategy activity -- | Parse EcoSpold file using Xeno SAX parser streamParseActivityAndFlowsFromFile :: FilePath -> IO (Either String (Activity, [TechnosphereFlow], [BiosphereFlow], [WasteFlow], [Unit])) diff --git a/src/EcoSpold/Writer1.hs b/src/EcoSpold/Writer1.hs index 5e1f4d30..b5365e25 100644 --- a/src/EcoSpold/Writer1.hs +++ b/src/EcoSpold/Writer1.hs @@ -76,6 +76,7 @@ import Amount (readAmount) import Data.Either (lefts) import Data.List (sortOn) import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.UUID as UUID @@ -531,7 +532,7 @@ flowFields res ex = case ex of FlowFields (bfName bf) (bfCompartmentName bf) - (maybe "" id (bfCompartmentSub bf)) + (fromMaybe "" (bfCompartmentSub bf)) (bfCAS bf) Nothing -> FlowFields "" "" "" Nothing WasteExchange{waFlowId = fid} -> diff --git a/src/EcoSpold/Writer2.hs b/src/EcoSpold/Writer2.hs index 82706540..a2771cc4 100644 --- a/src/EcoSpold/Writer2.hs +++ b/src/EcoSpold/Writer2.hs @@ -92,7 +92,7 @@ writeEcoSpold2 meta sdb = do env = ResolveEnv { reTechName = \u -> tfName <$> M.lookup u techFlows - , reBioFlow = \u -> M.lookup u bioFlows + , reBioFlow = (`M.lookup` bioFlows) , reWasteName = \u -> wfName <$> M.lookup u wasteFlows , reTechSyns = \u -> maybe M.empty tfSynonyms (M.lookup u techFlows) , reBioSyns = \u -> maybe M.empty bfSynonyms (M.lookup u bioFlows) diff --git a/src/Expr.hs b/src/Expr.hs index 2ac20456..5eb39e17 100644 --- a/src/Expr.hs +++ b/src/Expr.hs @@ -10,6 +10,7 @@ module Expr ( collectIdentifiers, ) where +import Control.Monad (void) import Data.Either (isRight) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) @@ -183,12 +184,12 @@ pSynPrimary = choice [ between (symbol "(") (symbol ")") pSynExpr , pSynFunc - , () <$ pNumber + , void pNumber , pSynIdent ] pSynIdent :: Parser () -pSynIdent = () <$ lexeme ((:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_')) +pSynIdent = void (lexeme ((:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_'))) pSynFunc :: Parser () pSynFunc = @@ -206,4 +207,4 @@ pSynFunc1 :: Text -> Parser () pSynFunc1 name = try $ lexeme (string name) *> between (symbol "(") (symbol ")") pSynExpr pSynFunc2 :: Text -> Parser () -pSynFunc2 name = try $ lexeme (string name) *> symbol "(" *> pSynExpr *> symbol ";" *> pSynExpr *> symbol ")" *> pure () +pSynFunc2 name = try $ void (lexeme (string name) *> symbol "(" *> pSynExpr *> symbol ";" *> pSynExpr *> symbol ")") diff --git a/src/ILCD/Parser.hs b/src/ILCD/Parser.hs index 3d6a780b..b9410731 100644 --- a/src/ILCD/Parser.hs +++ b/src/ILCD/Parser.hs @@ -126,8 +126,8 @@ listXMLFiles d = do parseUnitGroups :: FilePath -> IO (M.Map UUID (Text, Int)) parseUnitGroups dir = do files <- listXMLFiles dir - results <- mapM (\f -> parseUnitGroupXML <$> BS.readFile f) files - return $ M.fromList [r | Just r <- results] + results <- mapM (fmap parseUnitGroupXML . BS.readFile) files + return $ M.fromList (Data.Maybe.catMaybes results) data UGState = UGState { ugUUID :: !Text @@ -191,8 +191,8 @@ parseUnitGroupXML bytes = parseFlowProperties :: FilePath -> IO (M.Map UUID UUID) parseFlowProperties dir = do files <- listXMLFiles dir - results <- mapM (\f -> parseFlowPropertyXML <$> BS.readFile f) files - return $ M.fromList [r | Just r <- results] + results <- mapM (fmap parseFlowPropertyXML . BS.readFile) files + return $ M.fromList (Data.Maybe.catMaybes results) data FPState = FPState { fpUUID :: !Text @@ -483,7 +483,7 @@ parseProcessXML bytes = let ex = ILCDExchangeRaw { ierInternalId = psExInternalId s - , ierFlowRef = maybe UUID.nil id (UUID.fromText (psExFlowRef s)) + , ierFlowRef = Data.Maybe.fromMaybe UUID.nil (UUID.fromText (psExFlowRef s)) , ierDirection = psExDirection s , ierAmount = psExAmount s , ierLocation = psExLocation s @@ -522,8 +522,8 @@ parseProcessFilesParallel files = do return $ concat workerResults where parseWorker paths = do - results <- mapM (\f -> parseProcessXML <$> BS.readFile f) paths - return [r | Just r <- results] + results <- mapM (fmap parseProcessXML . BS.readFile) paths + return (Data.Maybe.catMaybes results) -------------------------------------------------------------------------------- -- Build ActivityMap from raw processes diff --git a/src/Matrix.hs b/src/Matrix.hs index 413c2c3e..614c90dd 100644 --- a/src/Matrix.hs +++ b/src/Matrix.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -81,6 +82,7 @@ import Control.Exception (SomeException, catch, evaluate, throwIO, toException, import Control.Monad (forM_, unless, void, when) import Data.Int (Int32) import qualified Data.Map as M +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V @@ -243,7 +245,7 @@ submitters that committed before 'csAlive' flipped end up here. drainShutdown :: TQueue WorkerMsg -> IO () drainShutdown inbox = do leftover <- atomically $ flushTQueue inbox - forM_ leftover $ \m -> case m of + forM_ leftover $ \case WSolve _ rv -> putMVar rv (Left $ toException $ userError "MUMPS solver shut down") WStop ack -> putMVar ack () @@ -493,13 +495,11 @@ applySparseMatrix sparseTriples nRows inputVec = let resultVec = U.create $ do result <- MU.new nRows forM_ [0 .. nRows - 1] $ \i -> MU.write result i 0.0 - forM_ sparseTriples $ \(i, j, val) -> do - if j < U.length inputVec - then do - oldVal <- MU.read result i - let newVal = oldVal + val * (inputVec U.! j) - MU.write result i newVal - else return () + forM_ sparseTriples $ \(i, j, val) -> + when (j < U.length inputVec) $ do + oldVal <- MU.read result i + let newVal = oldVal + val * (inputVec U.! j) + MU.write result i newVal return result in resultVec @@ -877,7 +877,7 @@ depDemandsToVector :: depDemandsToVector unitConfig depDbName depDb demands = do converted <- traverse convertEntry (M.toList demands) let n = fromIntegral (dbActivityCount depDb) :: Int - entries = [e | Just e <- converted] + entries = catMaybes converted Right $ U.accum (+) (U.replicate n 0.0) entries where actIdx = dbActivityIndex depDb diff --git a/src/Matrix/Export.hs b/src/Matrix/Export.hs index 3772468f..b5bc3c9d 100644 --- a/src/Matrix/Export.hs +++ b/src/Matrix/Export.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Matrix.Export ( diff --git a/src/Method/FlowResolver.hs b/src/Method/FlowResolver.hs index e9c89859..a9ea057a 100644 --- a/src/Method/FlowResolver.hs +++ b/src/Method/FlowResolver.hs @@ -191,7 +191,7 @@ parseFlowXML bytes = , fpsTextAccum = [] , fpsInBaseName = inBase , fpsInSynonyms = inSyn - , fpsLangIsEn = if isElement tag "synonyms" then False else fpsLangIsEn s + , fpsLangIsEn = not (isElement tag "synonyms") && fpsLangIsEn s , fpsInFlowProperty = inFP } diff --git a/src/Method/Mapping.hs b/src/Method/Mapping.hs index 17785dbd..316d678a 100644 --- a/src/Method/Mapping.hs +++ b/src/Method/Mapping.hs @@ -816,8 +816,8 @@ buildMethodTables cmap energyDensities mappings = M.fromList [ ((bfId flow, loc), (mcfValue cf, mcfUnit cf)) | (cf, Just (flow, _)) <- mappings - , Just loc <- [mcfConsumerLocation cf] , cfSubcompMatchesFlow cf flow + , Just loc <- [mcfConsumerLocation cf] ] , mtCompartmentMap = cmap , mtEnergyDensities = energyDensities @@ -1923,9 +1923,7 @@ findSimilarCFs syns idx flow maxN -- Same-medium candidates (cheap scan); fall back to whole index -- only when we have no medium info to filter by. - mediumIdxs = case M.lookup flowMedium (miByMedium idx) of - Just is -> is - Nothing -> [0 .. V.length (miCFs idx) - 1] + mediumIdxs = fromMaybe [0 .. V.length (miCFs idx) - 1] (M.lookup flowMedium (miByMedium idx)) casBridgeIdxs = case flowCAS' of Nothing -> [] diff --git a/src/Method/Parser.hs b/src/Method/Parser.hs index 3c94635c..409e3730 100644 --- a/src/Method/Parser.hs +++ b/src/Method/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {- | Parser for ILCD LCIA Method XML files using Xeno SAX parser. @@ -32,7 +31,7 @@ import Method.Types -- | Parse an ILCD LCIA Method XML file parseMethodFile :: FilePath -> IO (Either String Method) -parseMethodFile path = parseMethodFileWithFlows M.empty path +parseMethodFile = parseMethodFileWithFlows M.empty -- | Parse with ILCD flow info enrichment parseMethodFileWithFlows :: M.Map UUID ILCDFlowInfo -> FilePath -> IO (Either String Method) @@ -348,9 +347,7 @@ extractFlowName txt = findMarker (m : ms) = case T.breakOn m txt of (before, rest) | not (T.null rest) -> Just before _ -> findMarker ms - in T.strip $ case findMarker markers of - Just before -> before - Nothing -> txt -- no marker found: use full text + in T.strip $ fromMaybe txt (findMarker markers) -- no marker found: use full text {- | Extract compartment info from shortDescription as fallback Format: "... Emissions to air, non-urban ..." diff --git a/src/Method/ParserNW.hs b/src/Method/ParserNW.hs index bfe67a2d..54c43688 100644 --- a/src/Method/ParserNW.hs +++ b/src/Method/ParserNW.hs @@ -21,6 +21,7 @@ module Method.ParserNW ( import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BC +import Data.Char (isAsciiUpper) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -98,5 +99,5 @@ decode = TE.decodeUtf8With TEE.lenientDecode toLowerASCII :: Char -> Char toLowerASCII c - | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32) + | isAsciiUpper c = toEnum (fromEnum c + 32) | otherwise = c diff --git a/src/Method/Types.hs b/src/Method/Types.hs index ac6831bf..dd19a9f9 100644 --- a/src/Method/Types.hs +++ b/src/Method/Types.hs @@ -51,11 +51,11 @@ module Method.Types ( import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString.Lazy as BL +import Data.Char (isAsciiLower, isAsciiUpper) import Data.Csv (HasHeader (..), decode) -import Data.List (sortBy) +import Data.List (sortOn) import qualified Data.Map.Strict as M import qualified Data.Maybe -import Data.Ord (comparing) import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T @@ -275,7 +275,7 @@ resolveComputed env formulas = foldl step (Right env) sorted where -- Simple topological sort: evaluate in order of formula length as heuristic -- (shorter formulas are less likely to depend on longer ones) - sorted = sortBy (comparing (T.length . snd)) (M.toList formulas) + sorted = sortOn (T.length . snd) (M.toList formulas) step (Left err) _ = Left err step (Right currentEnv) (varName, formula) = case Expr.evaluate currentEnv formula of @@ -453,9 +453,8 @@ extractLocationSuffix name = | otherwise = let firstC = T.head t rest = T.unpack (T.tail t) - in firstC >= 'A' - && firstC <= 'Z' - && all (\c -> (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || c == '-') rest + in isAsciiUpper firstC + && all (\c -> isAsciiUpper c || isAsciiLower c || c == '-') rest -- | How a method flow was matched to a database flow data MatchType diff --git a/src/Plugin/Builtin.hs b/src/Plugin/Builtin.hs index cde8b672..336ef278 100644 --- a/src/Plugin/Builtin.hs +++ b/src/Plugin/Builtin.hs @@ -113,8 +113,8 @@ uuidMapper = , mhPriority = 0 , mhMatch = \ctx query -> pure $ case query of MatchCF cf -> - fmap (\f -> MapResult (bfId f) "uuid" 1.0) $ - Mapping.findFlowByUUID (mcBioFlowsByUUID ctx) (mcfFlowRef cf) + (\f -> MapResult (bfId f) "uuid" 1.0) + <$> Mapping.findFlowByUUID (mcBioFlowsByUUID ctx) (mcfFlowRef cf) _ -> Nothing } @@ -144,8 +144,8 @@ nameMapper = , mhPriority = 10 , mhMatch = \ctx query -> pure $ case query of MatchCF cf -> - fmap (\f -> MapResult (bfId f) "name" 0.9) $ - Mapping.findFlowByNameComp (mcBioFlowsByName ctx) (mcfFlowName cf) (mcfCompartment cf) + (\f -> MapResult (bfId f) "name" 0.9) + <$> Mapping.findFlowByNameComp (mcBioFlowsByName ctx) (mcfFlowName cf) (mcfCompartment cf) _ -> Nothing } @@ -157,8 +157,8 @@ synonymMapper = , mhPriority = 20 , mhMatch = \ctx query -> pure $ case query of MatchCF cf -> - fmap (\f -> MapResult (bfId f) "synonym" 0.8) $ - Mapping.findFlowBySynonymComp (mcSynonymDB ctx) (mcBioFlowsByName ctx) (mcfFlowName cf) (mcfCompartment cf) + (\f -> MapResult (bfId f) "synonym" 0.8) + <$> Mapping.findFlowBySynonymComp (mcSynonymDB ctx) (mcBioFlowsByName ctx) (mcfFlowName cf) (mcfCompartment cf) _ -> Nothing } @@ -291,16 +291,13 @@ nameSearcher = , let nameLower = T.toLower (bfName f) synMatches = any - (\syns -> any (T.isInfixOf queryLower . T.toLower) (S.toList syns)) + (any (T.isInfixOf queryLower . T.toLower) . S.toList) (M.elems (bfSynonyms f)) , T.isInfixOf queryLower nameLower || synMatches - , let score = - if queryLower == nameLower - then 1.0 - else - if T.isPrefixOf queryLower nameLower - then 0.9 - else 0.7 + , let score + | queryLower == nameLower = 1.0 + | T.isPrefixOf queryLower nameLower = 0.9 + | otherwise = 0.7 ] limited = take (sqLimit query) matches pure [SearchResult (bfId f) (bfName f) s M.empty | (f, s) <- limited] diff --git a/src/Search/Fuzzy.hs b/src/Search/Fuzzy.hs index 454c8978..8899d780 100644 --- a/src/Search/Fuzzy.hs +++ b/src/Search/Fuzzy.hs @@ -22,9 +22,9 @@ module Search.Fuzzy ( import Control.Monad (forM_) import Control.Monad.ST (runST) -import Data.List (sortBy) +import Data.List (sortOn) import qualified Data.Map.Strict as M -import Data.Ord (Down (..), comparing) +import Data.Ord (Down (..)) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -94,7 +94,7 @@ Results sorted by (jaccard desc, editDistance asc). editCandidates :: BM25Index -> Text -> [Text] editCandidates idx q | S.null qTrigs = [] - | otherwise = map (\(c, _, _) -> c) (sortBy (comparing sortKey) scored) + | otherwise = map (\(c, _, _) -> c) (sortOn sortKey scored) where qTrigs = trigramsOf q k = maxEditK (T.length q) @@ -117,7 +117,7 @@ prefixCandidates :: BM25Index -> Text -> [Text] prefixCandidates idx q | T.length q < minPrefixLen = [] | S.size qTrigs < minSharedTrigrams = [] - | otherwise = map fst (sortBy (comparing sortKey) scored) + | otherwise = map fst (sortOn sortKey scored) where qTrigs = trigramsOf q qLen = T.length q diff --git a/src/Service.hs b/src/Service.hs index 4c60daf2..ae838b9e 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -795,9 +795,7 @@ buildUnitGroups units = -- | Get flow usage count across all activities getFlowUsageCount :: Database -> UUID -> Int getFlowUsageCount db flowUUID = - case M.lookup flowUUID (idxByFlow $ dbIndexes db) of - Nothing -> 0 - Just activityUUIDs -> length activityUUIDs + maybe 0 length (M.lookup flowUUID (idxByFlow $ dbIndexes db)) {- | Get flows used by an activity as lightweight summaries. Each exchange lookup is resolved against the appropriate side (tech vs bio) and wrapped @@ -1563,7 +1561,7 @@ collectSupplyChainEntries db dbName mRootPid supplyVec scf includeEdges qualifyP | i <- [0 .. n - 1] , let v = supplyVec U.! i , abs v > minQ - , maybe True ((/=) (fromIntegral i)) mRootPid + , Just (fromIntegral i) /= mRootPid ] -- One pass: adjacency (for BFS + edges) + consumer counts. @@ -2084,9 +2082,9 @@ globalFromMustLiveInRoot :: RootDb -> [Substitution] -> Either ServiceError () globalFromMustLiveInRoot rootDb subs = case [ fromDb | sub <- subs - , AllConsumers <- [subScope sub] , let (fromDb, _) = parseSubRef rootDb (subFrom sub) , fromDb /= unRootDb rootDb + , AllConsumers <- [subScope sub] ] of [] -> Right () (d : _) -> diff --git a/src/SharedSolver.hs b/src/SharedSolver.hs index b0798eea..f507d708 100644 --- a/src/SharedSolver.hs +++ b/src/SharedSolver.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {- | Module : SharedSolver @@ -440,7 +441,7 @@ crossDBProcessContributions unitConfig unitDB flowDB depLookup rootDb rootName r -- sum across demands (we currently only call with K=1, but keep the -- shape aligned with goWithDeps for future batching). let localByRoot = map (\s -> processContributionsFromTables unitConfig unitDB flowDB db s tables) scalings - localTagged = M.mapKeys ((,) dbName) (foldr (M.unionWith (+)) M.empty localByRoot) + localTagged = M.mapKeys (dbName,) (foldr (M.unionWith (+)) M.empty localByRoot) if depth >= maxDepsDepth then pure (Right localTagged) else do diff --git a/src/SimaPro/Parser.hs b/src/SimaPro/Parser.hs index 8e0de266..5484d4e2 100644 --- a/src/SimaPro/Parser.hs +++ b/src/SimaPro/Parser.hs @@ -44,7 +44,7 @@ import Data.Char (isUpper, toLower) import qualified Data.Csv as Csv import Data.List (dropWhileEnd) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, isJust, isNothing, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, maybeToList) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -776,7 +776,7 @@ extractLocation name = -- "Product (WFLDB)/CN U" → ("Product (WFLDB)", "CN") -- "Product/ha/GLO/I U" → ("Product/ha", "GLO") -- Scans rightward through slash-separated segments for the first geo code. - extractSlashLocation n = go n + extractSlashLocation = go where go t = case T.breakOnEnd "/" t of ("", _) -> Nothing @@ -941,9 +941,7 @@ productToExchange unitCfg env isRef ProductRow{..} = rawAmount = resolveAmount env prAmountRaw prAmount (effUnitName, amount) = if isRef - then case UnitConversion.normalizeToCanonical unitCfg prUnit rawAmount of - Just canonical -> canonical - Nothing -> (prUnit, rawAmount) + then fromMaybe (prUnit, rawAmount) (UnitConversion.normalizeToCanonical unitCfg prUnit rawAmount) else (prUnit, rawAmount) flowUUID = generateFlowUUID cleanName "" effUnitName unitUUID = generateUnitUUID effUnitName diff --git a/src/Tools/SynonymsCompiler.hs b/src/Tools/SynonymsCompiler.hs index 2dcca53c..b29ba3d6 100644 --- a/src/Tools/SynonymsCompiler.hs +++ b/src/Tools/SynonymsCompiler.hs @@ -276,9 +276,9 @@ parseILCDFlowForSynonyms path = do (_, rest) | T.null rest -> Nothing (_, rest) -> let afterOpen = T.drop 1 $ T.dropWhile (/= '>') rest - value = T.takeWhile (/= '<') afterOpen + inner = T.takeWhile (/= '<') afterOpen in if close `T.isInfixOf` rest - then Just (T.strip value) + then Just (T.strip inner) else Nothing -- | Load pairs from a 2-column CSV (name1,name2) @@ -320,7 +320,7 @@ buildSynonymDB :: CASGroups -> [SynonymPair] -> SynonymDB buildSynonymDB casGroups namePairs = let -- Step 1: Create initial groups from CAS - casGroupsList = [(S.toList names) | names <- M.elems casGroups, S.size names >= 2] + casGroupsList = [S.toList names | names <- M.elems casGroups, S.size names >= 2] -- Step 2: Merge name pairs allGroups = mergeNamePairs namePairs casGroupsList -- Step 3: Build maps, enforcing size cap @@ -339,8 +339,8 @@ mergeNamePairs pairs initialGroups = initialGroupMap = M.fromList (zip [0 ..] (map S.fromList initialGroups)) nextId = length initialGroups - -- Process each pair - (finalNameMap, finalGroupMap, _) = foldl' mergePair (initialMap, initialGroupMap, nextId) pairs + -- Process each pair (only the group sets are needed downstream) + (_, finalGroupMap, _) = foldl' mergePair (initialMap, initialGroupMap, nextId) pairs in map S.toList (M.elems finalGroupMap) where @@ -350,8 +350,8 @@ mergeNamePairs pairs initialGroups = (Just g1, Just g2) | g1 == g2 -> (nameMap, groupMap, nid) -- Both in different groups: merge smaller into larger (with cap) (Just g1, Just g2) -> - let s1 = maybe S.empty id (M.lookup g1 groupMap) - s2 = maybe S.empty id (M.lookup g2 groupMap) + let s1 = fromMaybe S.empty (M.lookup g1 groupMap) + s2 = fromMaybe S.empty (M.lookup g2 groupMap) merged = S.union s1 s2 in if S.size merged > 100 then (nameMap, groupMap, nid) -- skip: would exceed cap diff --git a/src/Tree.hs b/src/Tree.hs index 264bbc86..4cd48b78 100644 --- a/src/Tree.hs +++ b/src/Tree.hs @@ -23,12 +23,8 @@ Converts exchange amount to the target activity's reference unit for proper scal getConvertedExchangeAmount :: UnitConfig -> Database -> Exchange -> UUID -> Double getConvertedExchangeAmount unitCfg db exchange targetActivityUUID = let originalAmount = exchangeAmount exchange - exchangeUnitName = case M.lookup (exchangeUnitId exchange) (dbUnits db) of - Just unit -> unitName unit - Nothing -> "unknown" - targetReferenceUnit = case findActivityByActivityUUID db targetActivityUUID of - Just targetActivity -> activityUnit targetActivity - Nothing -> "unknown" + exchangeUnitName = maybe "unknown" unitName (M.lookup (exchangeUnitId exchange) (dbUnits db)) + targetReferenceUnit = maybe "unknown" activityUnit (findActivityByActivityUUID db targetActivityUUID) in if exchangeUnitName == "unknown" || targetReferenceUnit == "unknown" then originalAmount else convertExchangeAmount unitCfg exchangeUnitName targetReferenceUnit originalAmount diff --git a/src/Types.hs b/src/Types.hs index bf85f007..f756b9a7 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -15,6 +15,7 @@ module Types ( import API.JsonOptions (Stripped (..)) import Control.DeepSeq (NFData) +import Control.Monad ((<=<)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Int (Int32) import qualified Data.IntSet as IS @@ -81,7 +82,7 @@ bfCompartmentName = maybe "" compartmentName . bfCompartment when neither the source nor the medium recorded one. -} bfCompartmentSub :: BiosphereFlow -> Maybe Text -bfCompartmentSub = (>>= compartmentSub) . bfCompartment +bfCompartmentSub = compartmentSub <=< bfCompartment {- | Direction of a biosphere exchange. Mirrors the @TechRole@ sum so the biosphere side also gets named variants instead of a load-bearing 'Bool'. diff --git a/test/ServiceSpec.hs b/test/ServiceSpec.hs index 75c02015..f43f3e66 100644 --- a/test/ServiceSpec.hs +++ b/test/ServiceSpec.hs @@ -247,17 +247,6 @@ mkBioFlow cat = , bfCompartment = Just (VT.Compartment cat Nothing) } -mkTechFlow :: Text -> TechnosphereFlow -mkTechFlow _cat = - TechnosphereFlow - { tfId = nil - , tfName = "test" - , tfUnitId = nil - , tfSynonyms = M.empty - , tfCAS = Nothing - , tfSubstanceId = Nothing - } - -- | Build a minimal TreeExport from a list of (id, parentId, name) and edges (from,to) mkTreeExport :: [(Text, Maybe Text, Text)] -> [(Text, Text)] -> TreeExport mkTreeExport nodeSpecs edgeSpecs = diff --git a/volca.cabal b/volca.cabal index 9e88f542..ae2f094d 100644 --- a/volca.cabal +++ b/volca.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: volca -version: 0.7.0 +version: 0.8.0 build-type: Simple license: Apache-2.0 @@ -299,6 +299,8 @@ test-suite lca-tests , ExportSpec , ExportHandlerSpec , PropertiesSpec + , NativeActivityTypeSpec + , WasteCrossDBSpec build-depends: base >=4.14 && <5 , volca , hspec diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 00000000..1b99c920 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,72 @@ +# weeder configuration — finds unused exports and dead modules that `-Wall` cannot see +# (it only catches unused *local* binds and imports, never unused *exports*). +# +# weeder reads `.hie` files, and HIE format is GHC-version-specific, so weeder +# must be built with the same GHC as the project. Generate HIE for every +# component (lib + exe + test + bench) so cross-component use is visible — the +# exe and the test suite both define a module named `Main`, so let cabal write +# HIE into each component's own build tree rather than a shared -hiedir (a shared +# dir makes the two Main.hie collide and hides the real entry point): +# cabal build all --enable-tests --enable-benchmarks \ +# --builddir=dist-weeder --ghc-options=-fwrite-ide-info +# weeder --hie-directory dist-weeder +RTS -K512m -RTS +# (the larger RTS stack avoids a stack-overflow segfault on the big modules). +# +# `roots` keeps legitimate entry points — and exports consumed only outside this +# repository — from being reported as dead. + +roots = [ + "^Main\\.main$", # executable entry point + "^Paths_volca\\.", # cabal-generated module + + # --------------------------------------------------------------------------- + # Public library API exported for out-of-repo consumers. + # + # `volca` is a library: these symbols live in `exposed-modules` and are part + # of the engine's surface for external clients (Python bindings, downstream + # services, embedders). weeder only sees this repo, so anything used solely by + # an external consumer looks dead. Rooting them keeps the API stable; revisit + # if a symbol is confirmed to have no consumer anywhere. + # --------------------------------------------------------------------------- + "^API\\.Resources\\.(requiredParams|optionalParams|cliName)$", + "^API\\.Types\\.(apiFlowId|apiFlowSynonyms)$", + "^Database\\.Loader\\.(validateCacheFile|loadDatabaseFromCacheFile|loadUncompressedCacheFile)$", + "^Database\\.Manager\\.(loadDatabaseFromConfig|loadDatabaseFromConfigWithCrossDB|getStagedDatabase)$", + "^Method\\.Mapping\\.computeLCIAScoreWithDiagnostics$", + "^Method\\.ParserNW\\.parseNormWeightCSV$", + "^Method\\.ParserSimaPro\\.parseSimaProMethodCSV$", + "^Plugin\\.Bridge\\.(callPluginBatch|parseLines)$", + "^Plugin\\.Builtin\\.flowContribution$", + "^SharedSolver\\.(computeScalingVectorCached|computeInventoryMatrixCached)$", + "^Service\\.(getActivityTree|getActivityInventoryWithSharedSolver)$", + "^Service\\.(runPreComputeValidation|runPostComputeValidation|hasValidationErrors)$", + "^Types\\.(flowKindUnitId|searchProductsByLocation|lookupTechFlow|lookupBioFlow)$", + "^UnitConversion\\.(newUnknownUnitTracker|warnIfUnknownUnit|getUnknownUnits)$", + + # Database-export writers — one entry point per output format. Exported so any + # client can serialise a loaded database; not all are exercised in-repo yet. + "^BrightwayExcel\\.Writer\\.writeBrightwayExcel$", + "^SimaPro\\.Writer\\.writeSimaProCSV$", + + # mumps-hs is a separate package; withMUMPSSolver is its bracket-style public + # helper, kept alongside the lower-level solver entry points it wraps. + "^Numerical\\.MUMPS\\.Solver\\.withMUMPSSolver$", + + # --------------------------------------------------------------------------- + # Known-dead, kept here as an explicit baseline rather than silently deleted + # so a maintainer can prune them in a dedicated, reviewed pass: + # + # * Service.{computeLCIA,exportLCIAAsXML,exportLCIAAsCSV} — "(placeholder)" + # stubs with no-op bodies (superseded by Method.Mapping + Matrix.Export). + # * API.MCP.Enrich.valueText, API.Routes.inventoriesWithDeps — leftover + # helpers with no remaining caller. + # * test fixtures with no referencing spec (GoldenData sample* / the + # SAMPLE.min expectations, TestHelpers.findActivityByUUID). + # --------------------------------------------------------------------------- + "^Service\\.(computeLCIA|exportLCIAAsXML|exportLCIAAsCSV)$", + "^API\\.MCP\\.Enrich\\.valueText$", + "^API\\.Routes\\.inventoriesWithDeps$", + "^GoldenData\\.(sampleMin3ActivityY|sampleMin3TechMatrix|sampleMin3BioMatrix|sampleMinExpectedSupply|sampleMinExpectedCO2)$", + "^TestHelpers\\.findActivityByUUID$", +] +type-class-roots = true # instance methods are reachable via their class