-----------------------------------------------------------------------------
-- |
-- Module      :  Make.Imports
-- Copyright   :  (c) Malcolm Wallace (1998-2007), taken and extendend from the hmake source by Andrea Vezzosi (2008)
-- License     :  BSD3
-- 
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Get the imports for a single Haskell or C2hs module.
-----------------------------------------------------------------------------

module Make.Imports
  ( importsHs,importsChs,pragmas,headerPragmas,languageExtensions
  ) where

import Data.Char
import Data.List
import Data.Maybe

-------------------------------------------------------------------------------
-- * Imports

importsHs,importsChs :: FilePath -> String -> [String]
importsHs  = parseBy modname moduleStoppers "import" 
importsChs = parseBy modname moduleStoppers "#import" 

modname :: [String] -> String
modname ws =
      let one = head ws
          two = head (tail ws)
      in
      if one == "qualified" then 
           takeUntil "(-{;#" two
      else takeUntil "(-{;#" one

moduleStoppers = 
    ["data",
     "type",
     "class",
     "infix",
     "infixl",
     "infixr",
     "newtype",
     "default",
     "instance"
    ]

-------------------------------------------------------------------------------
-- * Pragmas

pragmas, headerPragmas :: FilePath -> String -> [(String, [String])]
pragmas       = parseBy pragma []             "{-#" 
headerPragmas = parseBy pragma headerStoppers "{-#" 

pragma :: [String] -> (String, [String])
pragma ws = (\xs -> (head xs, tail xs)) . words . takeUntil "#" $ unwords ws

headerStoppers = ["module","where","import"] ++ moduleStoppers

languageExtensions :: FilePath -> String -> [String]
languageExtensions s = concat 
                       . map (map (filter (/=',')) . snd)
                       . filter (("LANGUAGE"==) . map toUpper . fst) 
                       . headerPragmas s

-------------------------------------------------------------------------------
-- * Parser

parseBy :: ([String] -> a)
             -> [String]
             -> String
             -> String
             -> FilePath
             -> [a]
parseBy pragma stoppers keyword fp = go . lines . nestcomment' fp 0
    where 
     go (x:xs)
      | null x || all isSpace x  = go xs
      | otherwise =
        case concatMap words (x:xs) of
          (w:ws) | w == keyword  -> pragma ws: go xs
				-- allow for import spanning several lines.
                 | w `elem` stoppers -> []
                                -- truncate search at first non-import keyword 
          _              -> go xs	-- non-keyword: continue search
     go [] = []


nestcomment' :: (Ord a, Num a) => [Char] -> a -> [Char] -> [Char]
nestcomment' fp = nestcomment
  where
    nestcomment 0 ('{':'-':'#':cs) = "{-#" ++ nestcomment 0 cs
    nestcomment 0 ('#':'-':'}':cs) = "#-}" ++ nestcomment 0 cs
    nestcomment n ('{':'-':cs) | n>=0 = nestcomment (n+1) cs
    
    nestcomment n ('-':'}':cs) | n>0  = nestcomment (n-1) cs
    nestcomment n (c:cs)       | n>0  = nestcomment n cs
    
    nestcomment 0 ('-':'}':cs)        =
        error ("In file "++fp++"\n"
               ++"    found close comment -} but no matching open {-")
    nestcomment 0 ('-':'-':cs)        =
        if null munch
          || isSpace nextchr
          || nextchr `elem` ",()[]{};\"'`"
          || isAlphaNum nextchr
        then nestcomment 0 (dropWhile (/='\n') munch)
        else '-':'-': nestcomment 0 cs
      where munch = dropWhile (=='-') cs
            nextchr = head munch
    nestcomment 0 ('\'':'"':'\'':cs)  = '\'':'"':'\'': nestcomment 0 cs
    nestcomment 0 ('\\':'"':cs)       = '\\':'"': nestcomment 0 cs
    nestcomment 0 ('"':cs)            = '"': endstring cs
    nestcomment 0 ('{':cs)            = '{':'\n': nestcomment 0 cs	-- HACK
    nestcomment 0 (';':cs)            = '\n': nestcomment 0 cs	-- HACK
    nestcomment 0 (c:cs)              = c: nestcomment 0 cs
    nestcomment 0 []                  = []
    nestcomment n []                  =
        error ("In file "++fp++"\n    found "++show n
               ++" open comments {- but no matching close -}")

    endstring ('\\':'\\':cs) = '\\':'\\': endstring cs
    endstring ('\\':'"':cs)  = '\\':'"': endstring cs
    endstring ('\\':w:cs)    | isSpace w = stringgap cs
    endstring ('"':cs) = '"': nestcomment 0 cs
    endstring (c:cs)   = c  : endstring cs
    endstring []       = []
    stringgap ('\\':cs) = endstring cs
    stringgap (c:cs)    = stringgap cs
    stringgap []        = []	-- source file is corrupt


takeUntil :: String -> String -> String
takeUntil cs [] = []
takeUntil cs (x:xs)
  | x`elem`cs = []
  | otherwise = x: takeUntil cs xs

----