-- birbsh 012 -- a tiny, friendly, readable shell in one file.
--
-- generations so far:
--   000 REPL        001 history     002 config     003 isocline
--   004 pipes       005 tokenizer   006 $VAR       007 set/env
--   008 redirects   008c ctrl-c     009 severed pipes + whole-file tidy
--   010 chaining:  ; (always)  && / ;and (after success)  || / ;or (after failure)
--   011 substitution: (cmd) splices its output in, one word per line
--   012 $VAR tab completion
--
-- build: ghc birbsh.hs
-- (one dependency: isocline)

module Main (main) where

import Control.Exception (SomeException, catch, evaluate, fromException, throwIO, try)
import Data.Char (isAlphaNum, isSpace)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import System.Console.Isocline
  ( CompletionEnv, Fmt, completionsFor, completeFileName, completeWord
  , enableMultilineIndent, plain, pre, readlineExMaybe
  , setHistory, setPromptMarker, style, styleDef )
import System.Directory
  ( XdgDirectory (XdgConfig), doesFileExist, getCurrentDirectory
  , getHomeDirectory, getXdgDirectory, listDirectory, setCurrentDirectory )
import System.Environment (getArgs, getEnvironment)
import System.Exit (ExitCode (..), exitWith)
import System.FilePath ((</>))
import System.IO (Handle, IOMode (..), hClose, hGetContents, openFile)
import System.IO.Error (ioeGetErrorString)
-- createPipe is a POSIX thing, not a plain IO thing -- System.IO doesn't
-- export it; System.Posix.IO does (and gives us fdToHandle to boot)
import System.Posix.IO (createPipe, fdToHandle)
import System.Posix.Signals (Handler (Catch), installHandler, sigINT)
import System.Process
  ( CreateProcess (..), ProcessHandle, StdStream (..)
  , createProcess, proc, waitForProcess )

-- ---------------------------------------------------------------------------
-- the birb's world
-- ---------------------------------------------------------------------------

-- | The birb's session environment: a plain association list we can read
--   purely (for $VAR) and hand to children whole.
type Env = [(String, String)]

-- | The birb's config file: `key = value` lines, '#' comments.
data Config = Config
  { cfgPrompt   :: Maybe String
  , cfgGreeting :: Maybe String
  }

main :: IO ()
main = do
  args <- getArgs
  case args of
    ["--version"] -> putStrLn "birbsh 012"
    _             -> nest
  where
    nest = do
      -- ^C interrupts the running command, not the birb itself.
      -- (Catch, not Ignore: SIG_IGN survives exec and would make every
      -- child unkillable -- a classic POSIX trap.)
      _ <- installHandler sigINT (Catch (return ())) Nothing
      home <- getHomeDirectory
      cfgDir <- getXdgDirectory XdgConfig "birbsh"
      config <- loadConfig (cfgDir </> "config.birb")
      setHistory (cfgDir </> "history") 500
      setPromptMarker " " " "
      _ <- enableMultilineIndent False   -- wrapped lines start at the left edge
      putStrLn "i am the birb"
      putStrLn "type 'help' to see what the birb can do"
      case cfgGreeting config of
        Just g  -> putStrLn g
        Nothing -> return ()
      env <- getEnvironment
      cmds <- snapshotCommands env
      loop config home cmds env ExitSuccess

-- | The nest: prompt, read, run, repeat.
loop :: Config -> FilePath -> Set.Set String -> Env -> ExitCode -> IO ()
loop config home cmds env code = do
  -- the prompt blushes red after a failed command
  styleDef "ic-prompt" (if code == ExitSuccess then "#40b0a0" else "#d06050")
  cwd <- getCurrentDirectory
  let base = case cfgPrompt config of
        Just p  -> p
        Nothing -> "birb " ++ shrinkHome home cwd ++ " $"
  minput <- readlineExMaybe base (Just (completer cmds env)) (Just (highlighter cmds))
  case minput of
    Nothing -> return ()                        -- Ctrl-D: leave the nest
    Just input
      | all isSpace input -> loop config home cmds env code   -- blank: keep the status
      | otherwise -> do
          (env', code') <- runLine home env input `catch` \e ->
            case fromException e of
              Just (_ :: ExitCode) -> throwIO e          -- `exit` means it
              Nothing -> do                            -- the crash shield
                putStrLn ("birbsh: " ++ show (e :: SomeException))
                return (env, ExitFailure 1)
          -- if the birb changed its PATH, re-learn the command landscape
          cmds' <- if lookup "PATH" env == lookup "PATH" env'
                     then return cmds
                     else snapshotCommands env'
          loop config home cmds' env' code'

-- | Show the cwd with the nest tucked away as a ~.
shrinkHome :: FilePath -> FilePath -> String
shrinkHome home cwd
  | cwd == home                     = "~"
  | (home ++ "/") `isPrefixOf` cwd  = "~" ++ drop (length home) cwd
  | otherwise                       = cwd

-- ---------------------------------------------------------------------------
-- config
-- ---------------------------------------------------------------------------

loadConfig :: FilePath -> IO Config
loadConfig path = do
  there <- doesFileExist path
  if not there
    then return emptyConfig
    else do raw <- readFile path
            return (foldl use emptyConfig (lines raw))
  where
    emptyConfig = Config Nothing Nothing
    use cfg l = case break (== '=') (takeWhile (/= '#') l) of
      (k, '=':v) -> setField (trim k) (trim v) cfg
      _          -> cfg
    setField "prompt"   v cfg = cfg { cfgPrompt   = Just v }
    setField "greeting" v cfg = cfg { cfgGreeting = Just v }
    setField _          _ cfg = cfg
    trim s = dropWhile isSpace (reverse (dropWhile isSpace (reverse s)))

-- ---------------------------------------------------------------------------
-- tab completion and highlighting (isocline)
-- ---------------------------------------------------------------------------

-- | Tab completes commands, paths, and -- when the word starts with a
--   $ -- the birb's remembered variables, all in one breath.
completer :: Set.Set String -> Env -> CompletionEnv -> String -> IO ()
completer cmds env cenv input = do
  completeWord cenv input Nothing (\w ->
    if "$" `isPrefixOf` w
      then completionsFor w (map ('$':) (Set.toList (Set.fromList (map fst env))))
      else completionsFor w (Set.toList cmds))
  completeFileName cenv input Nothing [] []

-- | The highlighter.  Pure on purpose: isocline calls it after every
--   keystroke, so no I/O in here -- the PATH lives in a Set we snapshot.
--   Recognised commands light up teal; quotes go green; operators blush.
highlighter :: Set.Set String -> String -> Fmt
highlighter cmds = go True
  where
    special c = isSpace c || c `elem` "|<>&;'\"()"
    op s = style "b #d08770" s
    quoted q cs = case break (== q) cs of
      (body, [])      -> pre "#98c379" (q : body) ++ go False []
      (body, q':cs') -> pre "#98c379" (q : body ++ [q']) ++ go False cs'
    go _     []        = ""
    go cmdPos (c:cs)
      | isSpace c = c : go cmdPos cs
      | c == '|'  = op "|" ++ go True cs      -- a pipe: next word is a command
      | c == '<'  = op "<" ++ go False cs
      | c == '>'  = op ">" ++ go False cs
      | c == '&'  = op "&" ++ go False cs
      | c == ';'  = op ";" ++ go True cs      -- a chain: next word is a command
      | c == '('  = op "(" ++ go True cs      -- substitution: inner word is a command
      | c == ')'  = op ")" ++ go False cs
      | c == '\'' || c == '"' = quoted c cs
      | otherwise =
          let (w, rest) = span (not . special) (c:cs)
          in (if cmdPos && Set.member w cmds
                then style "b #4ec9b0" w
                else plain w)
             -- `and` / `or` hand the command position on through,
             -- so `; and echo ...` still lights up the echo
             ++ go (if w `elem` ["and", "or"] then cmdPos else False) rest

-- ---------------------------------------------------------------------------
-- the tokenizer: line -> tokens, with $VAR, quotes, escapes, ~, (cmd)
-- ---------------------------------------------------------------------------

data Token
  = Tok String      -- a plain word (already expanded)
  | Subst [Token]   -- ( cmd ... )  run it, splice its output lines in
  | Pipe            -- |
  | Semi            -- ;        chain: run the next one anyway
  | ChainAnd        -- && / ;and  chain: run the next one after success
  | ChainOr         -- || / ;or   chain: run the next one after failure
  | RedirIn         -- <        (or the speakable in<)
  | RedirOut        -- >        (or out>)
  | RedirAppend     -- >>       (or out>>)
  | RedirErr        -- 2>       (or err>)
  | RedirErrAppend  -- 2>>      (or err>>)
  | RedirAll        -- &>       (or all>)

tokenize :: Env -> FilePath -> String -> Either String [Token]
tokenize env home input = case go [] [] input False of
  Left msg        -> Left msg
  Right (toks, _) -> Right toks
  where
    -- pending word (held reversed) becomes a token, if there is one
    flush toks []  = toks
    flush toks acc = Tok (reverse acc) : toks

    -- go takes four bites: tokens so far, the half-built word (reversed),
    -- the rest of the line, and whether we're inside parens (where a ')'
    -- hands the rest of the line back instead of ending it)
    go :: [Token] -> String -> String -> Bool -> Either String ([Token], String)
    go toks acc [] inParens
      | inParens  = Left "unterminated ("
      | otherwise = Right (reverse (flush toks acc), "")
    go toks acc (')':cs) inParens
      | inParens  = Right (reverse (flush toks acc), cs)
      | otherwise = Left "unmatched )"
    go toks acc (c:cs) inParens
      | isSpace c = go (flush toks acc) [] cs inParens
      | c == '(' = do                          -- substitution: (cmd)
          (inner, rest) <- go [] [] cs True    -- tokenize until our ')'
          go (Subst inner : flush toks acc) [] rest inParens
      | c == '|' = case cs of                  -- || chains, | pipes
          ('|':cs') -> go (ChainOr : flush toks acc) [] cs' inParens
          _         -> go (Pipe : flush toks acc) [] cs inParens
      | c == '<' =
          if reverse acc == "in"
            then go (RedirIn : toks) [] cs inParens            -- speakable: in<
            else go (RedirIn : flush toks acc) [] cs inParens
      | c == '>' = case (reverse acc, cs) of        -- glued words become ops
          ("err", '>':cs') -> go (RedirErrAppend : toks) [] cs' inParens
          ("err", _)       -> go (RedirErr : toks) [] cs inParens
          ("out", '>':cs') -> go (RedirAppend   : toks) [] cs' inParens
          ("out", _)       -> go (RedirOut     : toks) [] cs inParens
          ("2",   '>':cs') -> go (RedirErrAppend : toks) [] cs' inParens
          ("2",   _)       -> go (RedirErr     : toks) [] cs inParens
          ("all", _)       -> go (RedirAll     : toks) [] cs inParens
          (_,     '>':cs') -> go (RedirAppend : flush toks acc) [] cs' inParens
          (_,     _)       -> go (RedirOut    : flush toks acc) [] cs inParens
      | c == '&' = case cs of
          ('>':cs') -> go (RedirAll : flush toks acc) [] cs' inParens  -- &>
          ('&':cs') -> go (ChainAnd : flush toks acc) [] cs' inParens -- && chains;
          _         -> go toks (c:acc) cs inParens  -- a lone & is just a letter
      | c == ';' = case startsWord "and" cs of
          Just rest -> go (ChainAnd : flush toks acc) [] rest inParens  -- ;and
          Nothing   -> case startsWord "or" cs of
            Just rest -> go (ChainOr : flush toks acc) [] rest inParens  -- ;or
            Nothing   -> go (Semi : flush toks acc) [] cs inParens
      | c == '\\' = case cs of
          (x:cs') -> go toks (x:acc) cs' inParens   -- \ escapes any single character
          []      -> Left "dangling \\"
      | c == '\'' = case break (== '\'') cs of        -- literal, no expansion
          (body, '\'':cs') -> go toks (reverse body ++ acc) cs' inParens
          _                -> Left "unterminated '"
      | c == '"' = do (acc', rest) <- dquote acc cs
                      go toks acc' rest inParens
      | c == '$' = do (v, rest) <- varRef cs
                      go toks (reverse v ++ acc) rest inParens
      | c == '~', null acc = case cs of               -- bare ~ means home
          []                -> go toks (reverse home ++ acc) [] inParens
          (x:cs') | x == '/'       -> go toks (reverse (home ++ "/") ++ acc) cs' inParens
                  | x `elem` "|<>" -> go toks (reverse home ++ acc) cs inParens
                  | isSpace x       -> go toks (reverse home ++ acc) cs inParens
                  | otherwise       -> go toks (c:acc) cs inParens
      | otherwise = go toks (c:acc) cs inParens

    -- inside "double quotes": backslash escapes any single character,
    -- and $VAR still expands (parens are just letters in here)
    dquote acc []          = Left "unterminated \""
    dquote acc ('"':cs)    = Right (acc, cs)
    dquote acc ('\\':x:cs) = dquote (x:acc) cs
    dquote acc ('$':cs)    = do (v, rest) <- varRef cs
                                dquote (reverse v ++ acc) rest
    dquote acc (c:cs)      = dquote (c:acc) cs

    -- everything just after a '$': $VAR or ${VAR}; empty when unset;
    -- a lone $ stays a literal $
    varRef ('{':cs) = case break (== '}') cs of
      (name, '}':rest) -> if null name
                            then Left "${}: expected a variable name"
                            else Right (fromMaybe "" (lookup name env), rest)
      _                -> Left "unterminated ${"
    varRef s = let (name, rest) = span isNameChar s
               in if null name
                    then Right ("$", rest)
                    else Right (fromMaybe "" (lookup name env), rest)

    -- does the string begin with this little word, at a boundary?
    -- (`;and echo` chains, but `;android` is a command named android)
    startsWord :: String -> String -> Maybe String
    startsWord w s = case splitAt (length w) s of
      (w', rest) | w' == w, boundaryOk rest -> Just rest
      _                                    -> Nothing
    boundaryOk []     = True
    boundaryOk (x:_)  = not (isNameChar x)

isNameChar :: Char -> Bool
isNameChar c = isAlphaNum c || c == '_'

-- ---------------------------------------------------------------------------
-- the parser: tokens -> chains of pipelines of segments
-- ---------------------------------------------------------------------------

-- | How one pipeline decides whether the next one runs.
data ChainOp
  = SepAll   -- ;         always
  | SepAnd   -- && / ;and  after success
  | SepOr    -- || / ;or   after failure

-- | One command with its arguments and redirects.
data Segment = Segment
  { segCmd  :: String
  , segArgs :: [String]
  , segIn   :: Maybe FilePath
  , segOut  :: Maybe (Bool, FilePath)   -- (append?, file)
  , segErr  :: Maybe (Bool, FilePath)
  , segAll  :: Maybe FilePath
  }

-- | Split the token list at pipes into command groups.
splitPipe :: [Token] -> [[Token]]
splitPipe []   = []
splitPipe toks = go toks []
  where
    go []         grp = [reverse grp]
    go (Pipe:ts)  grp = reverse grp : go ts []
    go (t:ts)     grp = go ts (t:grp)

-- | Break the line at chaining operators.  Each group remembers the op
--   that led into it; the first group carries a placeholder SepAll (a
--   line always runs its first pipeline).  Fish's spaced `; and` /
--   `; or` are welcomed here too.  A line may end on a separator
--   (`ls ;` is fine, like bash).
splitChain :: [Token] -> [(ChainOp, [Token])]
splitChain toks = dropTrailing (go toks [] SepAll)
  where
    go (Semi:Tok "and":ts) grp pending = (pending, reverse grp) : go ts [] SepAnd
    go (Semi:Tok "or":ts)  grp pending = (pending, reverse grp) : go ts [] SepOr
    go (Semi:ts)           grp pending = (pending, reverse grp) : go ts [] SepAll
    go (ChainAnd:ts)       grp pending = (pending, reverse grp) : go ts [] SepAnd
    go (ChainOr:ts)        grp pending = (pending, reverse grp) : go ts [] SepOr
    go []                  grp pending = [(pending, reverse grp)]
    go (t:ts)              grp pending = go ts (t:grp) pending

    dropTrailing chain = case reverse chain of
      ((_, []):rest) -> reverse rest
      _              -> chain

-- | Each chain piece parsed as a pipeline of segments.
parseChain :: [Token] -> Either String [(ChainOp, [Segment])]
parseChain toks = mapM piece (splitChain toks)
  where
    piece (op, ts) = do
      segs <- mapM parseGroup (splitPipe ts)
      if null ts
        then Left (chainName op ++ ": expected a command")
        else Right (op, segs)

parseGroup :: [Token] -> Either String Segment
parseGroup []         = Left "expected a command"
parseGroup (Tok c:ts) = collect (Segment c [] Nothing Nothing Nothing Nothing) ts
parseGroup (op:_)     = Left (opName op ++ ": expected a command")

-- | Fold arguments and redirects onto a segment.  Top-level on purpose:
--   a `where` only belongs to the clause it trails, so a helper used by
--   several clauses must live outside, with its own name and its own job.
collect :: Segment -> [Token] -> Either String Segment
collect seg []           = Right seg
collect seg (Tok w : ts) = collect (seg { segArgs = segArgs seg ++ [w] }) ts
collect seg (op   : ts)  = case (op, ts) of
  (RedirIn,        (Tok f:ts')) -> collect (seg { segIn  = Just f }) ts'
  (RedirOut,       (Tok f:ts')) -> collect (seg { segOut = Just (False, f) }) ts'
  (RedirAppend,    (Tok f:ts')) -> collect (seg { segOut = Just (True,  f) }) ts'
  (RedirErr,       (Tok f:ts')) -> collect (seg { segErr = Just (False, f) }) ts'
  (RedirErrAppend, (Tok f:ts')) -> collect (seg { segErr = Just (True,  f) }) ts'
  (RedirAll,       (Tok f:ts')) -> collect (seg { segAll = Just f }) ts'
  (Pipe,           _)            -> Left (segCmd seg ++ ": unexpected |")
  (_,              _)            -> Left (opName op ++ ": expected a filename")

opName :: Token -> String
opName Pipe            = "|"
opName Semi            = ";"
opName ChainAnd        = "&&"
opName ChainOr         = "||"
opName RedirIn         = "<"
opName RedirOut        = ">"
opName RedirAppend     = ">>"
opName RedirErr        = "2>"
opName RedirErrAppend  = "2>>"
opName RedirAll        = "&>"
opName (Subst _)       = "( )"
opName (Tok _)         = "a word"

chainName :: ChainOp -> String
chainName SepAll = ";"
chainName SepAnd = "&&"
chainName SepOr  = "||"

-- ---------------------------------------------------------------------------
-- running lines: substitution, then the chain of statements
-- ---------------------------------------------------------------------------

-- | One line of birb-speak: tokenize, run any ( ) substitutions, parse,
--   run the statement chain.
runLine :: FilePath -> Env -> String -> IO (Env, ExitCode)
runLine home env line =
  case tokenize env home line of
    Left msg   -> complain msg
    Right toks -> do
      expanded <- expandSubsts env toks
      case expanded of
        Left msg    -> complain msg
        Right toks' -> case parseChain toks' of
          Left msg    -> complain msg
          Right []    -> return (env, ExitSuccess)
          Right chain -> runStatements home env chain
  where
    complain msg = do putStrLn msg; return (env, ExitFailure 1)

-- | Run every (paren) substitution and splice its output into the token
--   stream: each line of output becomes one word (never space-split --
--   the same stance as $VAR).  Inner parens expand first, so nesting
--   works.  Inner failures don't stop the line; their output just comes
--   up empty.
expandSubsts :: Env -> [Token] -> IO (Either String [Token])
expandSubsts env = go []
  where
    go acc [] = return (Right (reverse acc))
    go acc (Subst inner : ts)
      | null inner = return (Left "( ): nothing inside")
      | otherwise  = do
          nested <- expandSubsts env inner          -- innermost parens first
          case nested of
            Left msg -> return (Left msg)
            Right inner'
              | any isChainOp inner' -> return (Left "no ; or && inside ( ) yet")
              | otherwise -> case mapM parseGroup (splitPipe inner') of
                  Left msg   -> return (Left msg)
                  Right segs -> do
                    out <- capturePipeline env segs
                    go (reverse (map Tok (splitLines out)) ++ acc) ts
    go acc (t:ts) = go (t:acc) ts

isChainOp :: Token -> Bool
isChainOp Semi     = True
isChainOp ChainAnd = True
isChainOp ChainOr  = True
isChainOp _        = False

-- | Output lines become words: fish-style, one word per line.
splitLines :: String -> [String]
splitLines out = filter (not . null) (splitOn '\n' out)

-- | Pipelines chained by ; (always), && or ;and (after success),
--   || or ;or (after failure).  Bash-style left to right: a skipped
--   statement leaves the last exit code standing for the one after it.
runStatements :: FilePath -> Env -> [(ChainOp, [Segment])] -> IO (Env, ExitCode)
runStatements home env chain = go env ExitSuccess chain
  where
    go env' code []              = return (env', code)
    go env' code ((op, segs):rest)
      | chainSays op code        = do
          (env'', code') <- runOne env' segs
          go env'' code' rest
      | otherwise                = go env' code rest    -- skipped: code stands

    chainSays SepAll _    = True
    chainSays SepAnd code = code == ExitSuccess
    chainSays SepOr  code = code /= ExitSuccess

    runOne env' segs
      | [seg] <- segs, segCmd seg `elem` builtins = runBuiltin home env' seg
      | otherwise                                 = runPipeline env' segs

builtins :: [String]
builtins = ["cd", "help", "exit", "set", "unset"]

runBuiltin :: FilePath -> Env -> Segment -> IO (Env, ExitCode)
runBuiltin home env seg = case (segCmd seg, segArgs seg) of
  ("cd", [])      -> do setCurrentDirectory home; ok
  ("cd", (d:_))   -> do
    r <- try (setCurrentDirectory d) :: IO (Either IOError ())
    case r of
      Right () -> ok
      Left e   -> do putStrLn ("birbsh: cd: " ++ d ++ ": " ++ ioeGetErrorString e)
                     return (env, ExitFailure 1)
  ("help", _)     -> do putStrLn helpText; ok
  ("exit", _)     -> exitWith ExitSuccess
  ("set", [])     -> do mapM_ (\(k, v) -> putStrLn (k ++ "=" ++ v)) env; ok
  ("set", (k:vs)) -> return (upsert (k, unwords vs) env, ExitSuccess)
  ("unset", (k:_)) -> return (filter ((/= k) . fst) env, ExitSuccess)
  ("unset", [])   -> do putStrLn ("birbsh: unset: expected a variable name")
                        return (env, ExitFailure 2)
  _               -> ok        -- can't happen: we checked `elem builtins`
  where
    ok = return (env, ExitSuccess)

-- | Insert or update: keep the birb's variables a plain association list.
upsert :: (String, String) -> Env -> Env
upsert (k, v) env = (k, v) : filter ((/= k) . fst) env

-- ---------------------------------------------------------------------------
-- launching pipelines (for effect, or for captured output)
-- ---------------------------------------------------------------------------

-- | Look up every command *before* spawning anything (so a typo doesn't
--   leave half a pipeline running), then run the chain.
launchPipeline :: Bool -> Env -> [Segment] -> IO (ExitCode, Maybe String)
launchPipeline capture env segs = do
  found <- mapM (findInPath env . segCmd) segs
  case [s | (s, Nothing) <- zip segs found] of
    (missing:_) -> do
      putStrLn ("birbsh: " ++ segCmd missing ++ ": command not found")
      return (ExitFailure 127, Nothing)
    [] -> do
      let segs' = [s { segCmd = p } | (s, Just p) <- zip segs found]
      runChain capture env segs'

-- | A pipeline run for its side effects and exit code.
runPipeline :: Env -> [Segment] -> IO (Env, ExitCode)
runPipeline env segs = do
  (code, _) <- launchPipeline False env segs
  return (env, code)

-- | A pipeline run for its output: the last command's stdout, drunk
--   from a pipe to EOF *before* reaping (a full pipe would jam it).
capturePipeline :: Env -> [Segment] -> IO String
capturePipeline env segs = do
  (_, out) <- launchPipeline True env segs
  return (fromMaybe "" out)

-- | Look a command up on the *birb's* PATH (the one `set` can change),
--   not the one birbsh was born with.
findInPath :: Env -> String -> IO (Maybe FilePath)
findInPath env cmd
  | '/' `elem` cmd = do                       -- a path, not a name: as written
      there <- doesFileExist cmd
      return (if there then Just cmd else Nothing)
  | otherwise = search (pathDirs env)
  where
    search []     = return Nothing
    search (d:ds) = do
      let f = d </> cmd
      there <- doesFileExist f
      if there then return (Just f) else search ds

pathDirs :: Env -> [FilePath]
pathDirs env = case lookup "PATH" env of
  Nothing -> []
  Just p  -> filter (not . null) (splitOn ':' p)

splitOn :: Char -> String -> [String]
splitOn c s = case break (== c) s of
  (a, [])     -> [a]
  (a, _:rest) -> a : splitOn c rest

-- | Every command name visible on the birb's PATH: a snapshot for the
--   highlighter and tab completion, refreshed when PATH changes.
snapshotCommands :: Env -> IO (Set.Set String)
snapshotCommands env = do
  found <- mapM safeList (pathDirs env)
  return (Set.union (Set.fromList builtins) (Set.unions found))
  where
    safeList d = Set.fromList <$> (listDirectory d `catch` \(_ :: SomeException) -> return [])

-- ---------------------------------------------------------------------------
-- the pipeline runner
-- ---------------------------------------------------------------------------

-- | A pipe whose write end is already closed: the reader sees instant EOF.
severedPipe :: IO Handle
severedPipe = do
  (rfd, wfd) <- createPipe
  rh <- fdToHandle rfd
  wh <- fdToHandle wfd
  hClose wh
  return rh

-- | Spawn the pipeline left to right, wiring streams as we go:
--   * neighbours get a pipe, unless a redirect steals the stream
--   * a mid-chain command whose stdout went to a file leaves the next
--     command a *closed* pipe: it reads instant EOF, not the keyboard
--   * &> (and matching out>/err> pairs) share one handle, since GHC
--     write-locks a file the same process opens twice
--   * with capture on, the last command's stdout comes back as a String
runChain :: Bool -> Env -> [Segment] -> IO (ExitCode, Maybe String)
runChain capture env = link Nothing []
  where
    link :: Maybe Handle -> [ProcessHandle] -> [Segment] -> IO (ExitCode, Maybe String)
    link _ spawned [] = do
      code <- reap spawned
      return (code, Nothing)
    link mprev spawned (seg:rest) = do
      -- stdin: a redirect wins; otherwise the previous segment's pipe
      mstdin <- case segIn seg of
        Just f  -> do h <- openFile f ReadMode
                      mapM_ hClose mprev          -- not using that pipe after all
                      return (Just h)
        Nothing -> return mprev

      -- stdout and stderr, decided together for the shared &> handle
      (moutH, merrH, mnext) <-
        let wmode a = if a then AppendMode else WriteMode
            eofIfRest = if null rest then return Nothing else Just <$> severedPipe
        in case (segOut seg, segErr seg, segAll seg) of
             (_, _, Just f) -> do
               h <- openFile f WriteMode          -- &>: both streams, one handle
               n <- eofIfRest
               return (Just h, Just h, n)
             (Just (a1, f1), Just (_, f2), _) | f1 == f2 -> do
               h <- openFile f1 (wmode a1)        -- out> and err> agree: share
               n <- eofIfRest
               return (Just h, Just h, n)
             (Just (a, f), _, _) -> do
               h <- openFile f (wmode a)
               n <- eofIfRest
               return (Just h, Nothing, n)
             (_, Just (a, f), _) -> do
               h <- openFile f (wmode a)
               return (Nothing, Just h, Nothing)
             (Nothing, Nothing, Nothing) -> return (Nothing, Nothing, Nothing)

      -- when capturing, the last command pipes to *us* instead of the terminal
      let outSpec = maybe (if null rest then (if capture then CreatePipe else Inherit)
                                       else CreatePipe) UseHandle moutH
          errSpec = maybe Inherit UseHandle merrH
      (_, moutR, _, ph) <- createProcess (proc (segCmd seg) (segArgs seg))
        { std_in  = maybe Inherit UseHandle mstdin
        , std_out = outSpec
        , std_err = errSpec
        , env     = Just env
        }
      -- the children hold their own copies now; shut ours
      mapM_ hClose mstdin
      closeShared moutH merrH
      -- capturing: drink the pipe to EOF *before* reaping -- this is
      -- laziness doing real work (hGetContents hands us a lazy String,
      -- and we force it to the end right now)
      mout <- case (rest, outSpec, moutR) of
        ([], CreatePipe, Just h) | capture -> do
          out <- hGetContents h
          _ <- evaluate (length out)     -- read it all: a full pipe would jam
          return (Just out)              -- (reading to EOF closes it)
        _ -> return Nothing
      -- what does the next command read?
      let mprev' = case outSpec of
            CreatePipe -> moutR         -- the pipe we just opened with the child
            _          -> mnext         -- a file... or the closed pipe (EOF)
      (code, mout') <- link mprev' (spawned ++ [ph]) rest
      return (code, if null rest then mout else mout')

    -- close ours, exactly once, even when both streams share one handle
    closeShared (Just h) (Just h') | h == h' = hClose h
    closeShared mh1 mh2 = mapM_ hClose mh1 >> mapM_ hClose mh2

    -- reap left to right; the last exit code is the pipeline's
    reap []        = return ExitSuccess
    reap [ph]      = waitForProcess ph
    reap (ph:more) = waitForProcess ph >> reap more

-- ---------------------------------------------------------------------------
-- help
-- ---------------------------------------------------------------------------

helpText :: String
helpText = unlines
  [ "i am the birb. the birb can:"
  , ""
  , "  cd [dir]     change directory; no argument flies home"
  , "  help         this"
  , "  exit         leave the nest (Ctrl-D works too)"
  , "  set VAR V    remember VAR=V for this flight (`set` alone lists them)"
  , "  unset VAR    forget VAR"
  , ""
  , "anything else is looked up on PATH and executed."
  , "pipes: cmd | cmd | cmd    redirects: < in, > out, >> append"
  , "speakable: in< out> out>> err> err>> all> -- bash's 2> 2>> &> work too"
  , "operators work glued or spaced: echo hi>f, echo hi > f"
  , "chain: cmd ; cmd -- always.  && (or ;and) -- after success."
  , "  || (or ;or) -- after failure.  a trailing ; is fine."
  , "substitution: (cmd) -- its output spliced in, one word per line;"
  , "  quotes make parens literal, nesting works, no ; inside ( ) yet."
  , "'single' quotes are literal, \"double\" quotes honour \\\" and \\\\,"
  , "and a backslash escapes any single character."
  , "expansion: $VAR and ${VAR} -- empty if unset, never re-split;"
  , "'single' quotes stop expansion, \"double\" quotes allow it, ~ is home."
  , "history: up/down arrows, Ctrl-R; saved between flights."
  , "tab completes paths, commands, and $VARS."
  , "commands light up when the birb recognises them."
  , "shift-tab: multiline input (paste-friendly)."
  , ""
  , "config: ~/.config/birbsh/config.birb   (key = value, '#' comments)"
  , "  prompt = birb $            -- custom prompt (default shows cwd)"
  , "  greeting = happy flight!   -- extra greeting line"
  ]