blob: efe75e1f89d6b4b8da565bd15639f34a466bdee1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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]
|
