From 1a7c345d3d530c566840c72f59a932f292cefd09 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Wed, 17 Feb 2021 16:01:53 +0100
Subject: Initial

---
 Coolbal/Target.hs | 112 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 112 insertions(+)
 create mode 100644 Coolbal/Target.hs

(limited to 'Coolbal/Target.hs')

diff --git a/Coolbal/Target.hs b/Coolbal/Target.hs
new file mode 100644
index 0000000..c698ceb
--- /dev/null
+++ b/Coolbal/Target.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module Coolbal.Target (
+    IsTarget(..),
+    AnyTarget(..),
+    ExeTarget(..),
+    useAnyTarget,
+) where
+
+import Data.Char (ord)
+import Data.List (intercalate)
+import Numeric (showHex)
+import System.Directory (createDirectoryIfMissing)
+import System.Exit (ExitCode(..), die)
+import System.FilePath ((</>))
+import System.Process (rawSystem)
+
+import Coolbal.Util
+
+
+class IsTarget a where
+    -- | The name of the target.
+    targetName :: a -> String
+
+    -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target.
+    targetNameQualified :: a -> String
+
+    -- | The name of the target, qualified with a cabal-style prefix indicating
+    -- the kind of target, except that the ':' is rendered as a '-'.
+    targetNameQualifiedFilename :: a -> FilePath
+    targetNameQualifiedFilename tg = case break (== ':') (targetNameQualified tg) of
+        (pre, ':' : post) -> pre ++ '-' : post
+        _ -> error "targetNameQualifiedFilename: unexpected form of targetNameQualified"
+
+    -- | Check whether the target must be recompiled due to changes on disk.
+    -- Argument is the root directory of the project.
+    targetCheckOld :: FilePath -> a -> IO Bool
+
+    -- | Recompile the target. Argument is the root directory of the project.
+    targetBuild :: FilePath -> a -> IO ()
+
+data AnyTarget = forall a. (Show a, IsTarget a) => AnyTarget a
+
+deriving instance Show AnyTarget
+
+useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r
+useAnyTarget f (AnyTarget x) = f x
+
+data ExeTarget = ExeTarget
+    { exeTargetName :: String
+      -- ^ Target name, and name of output executable file
+    , exeTargetPkgDbDir :: FilePath
+      -- ^ Absolute path to the package.db directory
+    , exeTargetDeps :: [String]
+      -- ^ Package identifiers of dependencies (for -package-id flags)
+    , exeTargetLanguage :: String
+      -- ^ Haskell language (e.g. Haskell2010)
+    , exeTargetMain :: FilePath
+      -- ^ Main file
+    , exeTargetModules :: [[String]]
+      -- ^ Other modules in the target
+    , exeTargetFlags :: [String]
+      -- ^ User-specified compiler flags
+    }
+  deriving (Show)
+
+instance IsTarget ExeTarget where
+    targetName = exeTargetName
+    targetNameQualified e = "exe:" ++ targetName e
+
+    targetCheckOld _ _ = return True
+
+    targetBuild projdir tg = do
+        let buildDir = projdir </> "dist-coolbal/build"
+                               </> escapeFileName (targetNameQualifiedFilename tg)
+            binDir = projdir </> "dist-coolbal/bin"
+            binName = binDir </> escapeFileName (exeTargetName tg)
+        createDirectoryIfMissing True binDir
+        rawSystem "ghc" (concat
+            [["--make", "-static"]
+            ,concat [[flag, buildDir]
+                    | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]]
+            ,["-i" ++ buildDir, "-I" ++ buildDir]
+            ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"]
+            ,["-package-db", exeTargetPkgDbDir tg]
+            ,concat [["-package-id", dep] | dep <- exeTargetDeps tg]
+            ,["-X" ++ exeTargetLanguage tg]
+            ,[exeTargetMain tg]
+            ,map (intercalate ".") (exeTargetModules tg)
+            ,["-o", binName]
+            ,exeTargetFlags tg])
+          >>= checkExitCode "ghc"
+
+checkExitCode :: String -> ExitCode -> IO ()
+checkExitCode _ ExitSuccess = return ()
+checkExitCode procname (ExitFailure c) =
+    die (procname ++ " exited with code " ++ show c)
+
+escapeFileName :: String -> FilePath
+escapeFileName =
+    -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ |
+    -- We use ! as an escape character, and hence disallow that too.
+    genericEscapeString
+        (\c -> let n = ord c
+               in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!")
+        (\c -> case (c, ord c) of
+            ('!', _) -> "!!"
+            (_, n) | n <= 0xFF -> '!' : showHex n ""
+                   | n <= 0xFFFF -> '!' : 'u' : showHex n ""
+                   | n <= 0xFFFFFF -> '!' : 'U' : showHex n ""
+                   | otherwise -> error "Super-high unicode?")
-- 
cgit v1.2.3-70-g09d2