Cabal/src/Distribution/Simple/Program/Script.hs

   1 {-# LANGUAGE GADTs #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -- |
   6 -- Module      :  Distribution.Simple.Program.Script
   7 -- Copyright   :  Duncan Coutts 2009
   8 --
   9 -- Maintainer  :  cabal-devel@haskell.org
  10 -- Portability :  portable
  11 --
  12 -- This module provides an library interface to the @hc-pkg@ program.
  13 -- Currently only GHC and LHC have hc-pkg programs.
  14 module Distribution.Simple.Program.Script
  15   ( invocationAsSystemScript
  16   , invocationAsShellScript
  17   , invocationAsBatchFile
  18   ) where
  19
  20 import Distribution.Compat.Prelude
  21 import Prelude ()
  22
  23 import Distribution.Simple.Program.Run
  24 import Distribution.Simple.Utils
  25 import Distribution.System
  26
  27 -- | Generate a system script, either POSIX shell script or Windows batch file
  28 -- as appropriate for the given system.
  29 invocationAsSystemScript :: OS -> ProgramInvocation -> String
  30 invocationAsSystemScript Windows = invocationAsBatchFile
  31 invocationAsSystemScript _ = invocationAsShellScript
  32
  33 -- | Generate a POSIX shell script that invokes a program.
  34 invocationAsShellScript :: ProgramInvocation -> String
  35 invocationAsShellScript
  36   ProgramInvocation
  37     { progInvokePath = path
  38     , progInvokeArgs = args
  39     , progInvokeEnv = envExtra
  40     , progInvokeCwd = mcwd
  41     , progInvokeInput = minput
  42     } =
  43     unlines $
  44       ["#!/bin/sh"]
  45         ++ concatMap setEnv envExtra
  46         ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd]
  47         ++ [ ( case minput of
  48                 Nothing -> ""
  49                 Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | "
  50              )
  51               ++ unwords (map quote $ path : args)
  52               ++ " \"$@\""
  53            ]
  54     where
  55       setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var]
  56       setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]
  57
  58       quote :: String -> String
  59       quote s = "'" ++ escape s ++ "'"
  60
  61       escape [] = []
  62       escape ('\'' : cs) = "'\\''" ++ escape cs
  63       escape (c : cs) = c : escape cs
  64
  65 iodataToText :: IOData -> String
  66 iodataToText (IODataText str) = str
  67 iodataToText (IODataBinary lbs) = fromUTF8LBS lbs
  68
  69 -- | Generate a Windows batch file that invokes a program.
  70 invocationAsBatchFile :: ProgramInvocation -> String
  71 invocationAsBatchFile
  72   ProgramInvocation
  73     { progInvokePath = path
  74     , progInvokeArgs = args
  75     , progInvokeEnv = envExtra
  76     , progInvokeCwd = mcwd
  77     , progInvokeInput = minput
  78     } =
  79     unlines $
  80       ["@echo off"]
  81         ++ map setEnv envExtra
  82         ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd]
  83         ++ case minput of
  84           Nothing ->
  85             [path ++ concatMap (' ' :) args]
  86           Just input ->
  87             ["("]
  88               ++ ["echo " ++ escape line | line <- lines $ iodataToText input]
  89               ++ [ ") | "
  90                     ++ "\""
  91                     ++ path
  92                     ++ "\""
  93                     ++ concatMap (\arg -> ' ' : quote arg) args
  94                  ]
  95     where
  96       setEnv (var, Nothing) = "set " ++ var ++ "="
  97       setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val
  98
  99       quote :: String -> String
 100       quote s = "\"" ++ escapeQ s ++ "\""
 101
 102       escapeQ [] = []
 103       escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs
 104       escapeQ (c : cs) = c : escapeQ cs
 105
 106       escape [] = []
 107       escape ('|' : cs) = "^|" ++ escape cs
 108       escape ('<' : cs) = "^<" ++ escape cs
 109       escape ('>' : cs) = "^>" ++ escape cs
 110       escape ('&' : cs) = "^&" ++ escape cs
 111       escape ('(' : cs) = "^(" ++ escape cs
 112       escape (')' : cs) = "^)" ++ escape cs
 113       escape ('^' : cs) = "^^" ++ escape cs
 114       escape (c : cs) = c : escape cs