1 files changed, 52 insertions, 0 deletions
diff --git a/Coolbal/MakeParse.hs b/Coolbal/MakeParse.hs
new file mode 100644
index 0000000..efe75e1
--- /dev/null
+++ b/Coolbal/MakeParse.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+module Coolbal.MakeParse (
+    parseGHCmake,
+) where
+
+import Data.Char (isSpace)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes)
+import System.FilePath ((</>), makeRelative, takeExtension, dropExtension)
+
+
+-- | Parse output of @ghc -M@ to give a module dependency graph.
+-- @projdir@ should be the canonical path of the project root directory;
+-- @builddir@ should be a relative path from @projdir@ to the build directory.
+parseGHCmake :: FilePath -> FilePath -> String -> Either String (Map [String] [[String]])
+parseGHCmake projdir builddir output = do
+    rules <- sequence (catMaybes (map (parseRule projdir builddir) (lines output)))
+    return (Map.fromListWith (++) (map (\case Node k -> (k, []) ; Rule k v -> (k, [v])) rules))
+
+data Rule = Node [String] | Rule [String] [String]
+  deriving (Show)
+
+parseRule :: FilePath -> FilePath -> String -> Maybe (Either String Rule)
+parseRule _ _ ('#' : _) = Nothing
+parseRule projdir builddir line =
+    case splitOn1 ':' line of
+      Just (lhs, rhs) ->
+          let lhs' = dropWhile (== '/') (makeRelative (projdir </> builddir) (strip lhs))
+              rhs' = makeRelative builddir (strip rhs)
+          in case takeExtension rhs' of
+               ".hi" -> Just (Right (Rule (toModule lhs') (toModule rhs')))
+               ".hs" -> Just (Right (Node (toModule lhs')))
+               _ -> errmsg
+      _ -> errmsg
+  where
+    errmsg = Just (Left ("Cannot parse -M line: " ++ show line))
+    toModule = splitOn '/' . dropExtension
+
+strip :: String -> String
+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+splitOn1 :: Eq a => a -> [a] -> Maybe ([a], [a])
+splitOn1 x xs = case span (/= x) xs of
+                  (pre, _ : post) -> Just (pre, post)
+                  _ -> Nothing
+
+splitOn :: Eq a => a -> [a] -> [[a]]
+splitOn x xs = case span (/= x) xs of
+                 (pre, _ : post) -> pre : splitOn x post
+                 (pre, []) -> [pre]