haskell-te: 603da32a29ab9881890bb137bbb9ceea22f0176e

     1: {-# LANGUAGE OverloadedStrings #-}
     2: import           Control.Lens
     3: import           Data.Aeson
     4: import           Data.Aeson.Lens
     5: import qualified Data.ByteString as BS
     6: import           Data.Char
     7: import           Data.List
     8: import           Data.Semigroup
     9: import           Data.Text.Lens
    10: import           Data.Validation
    11: 
    12: import qualified GetDeps
    13: import qualified SexprHelper
    14: import qualified Types as GD.Types
    15: 
    16: -- Acts like `Either [String] a`, but combines the content
    17: type OrErrors = AccValidation [String]
    18: 
    19: instance (Semigroup e) => Monad (AccValidation e) where
    20:   return = pure
    21:   (AccSuccess x) >>= f = f x
    22:   (AccFailure e) >>= f = AccFailure e
    23: 
    24: -- Read stdin as a JSON array, apply addDeps to each entry and send to stdout
    25: main :: IO ()
    26: main = BS.interact (over _Array go)
    27:   where go vs = case traverse addDeps vs of
    28:                      AccFailure errs -> error (unlines (msg:errs))
    29:                      AccSuccess vs'  -> vs'
    30:         msg   = "getDepsScript: aborting due to errors"
    31: 
    32: -- Add a "dependencies" field containing this entry's dependencies
    33: addDeps :: Value -> OrErrors Value
    34: addDeps v = add <$> deps v
    35:   where add ds = v & _Object . at "dependencies" ?~ toJSON ds
    36: 
    37: -- Looks up the dependencies of an entry, and formats them
    38: deps :: Value -> OrErrors [Value]
    39: deps v = rawDeps v >>= traverse formatDep
    40: 
    41: -- Looks up the "ast" field of an entry, traverses it looking for global
    42: -- names and deduplicates the resulting list
    43: rawDeps :: Value -> OrErrors [GD.Types.Out]
    44: rawDeps v = case v ^? key "ast" . _String . unpacked of
    45:                  Nothing -> AccFailure ["No 'ast' in " ++ show v]
    46:                  Just a  -> AccSuccess (deps' a)
    47:   where deps' = nub . GetDeps.getDeps . SexprHelper.parseSexpr
    48: 
    49: -- Split package fields like "foo-1.2" into package "foo" and version "1.2"
    50: formatDep :: GD.Types.Out -> OrErrors Value
    51: formatDep o = case pair of
    52:                    Nothing     -> AccFailure ["No 'package' in " ++ show dep]
    53:                    Just (p, v) -> AccSuccess $ case v of
    54:                      Just v' -> dep & setP .~ p & setV .~ v'
    55:                      Nothing -> dep & setP .~ p
    56:   where dep  = toJSON o
    57:         pair = dep ^? key "package" . _String . unpacked . to splitOffVersion
    58:         setP = _Object . at "package" . _Just . _String . unpacked
    59:         setV = _Object . at "version" . _Just . _String . unpacked
    60: 
    61: -- Splits the version off a package name (if any)
    62: splitOffVersion :: String -> (String, Maybe String)
    63: splitOffVersion raw = if "-" `isPrefixOf` version
    64:                          then (name, Just (tail version))
    65:                          else (raw,  Nothing)
    66:   where (name, version) = (reverse n, reverse v)
    67:         (v,    n)       = span versionic (reverse raw)
    68:         versionic c     = isNumber c || c `elem` ['-', '.']