module Graphmod.Utils
  ( parseFile
  , parseString
  , Qualifier
  , qualifierNodes
  , fromHierarchy
  , Import(..)
  , ImpType(..)
  , splitQualifier
  , ModName
  , splitModName
  , joinModName
  , relPaths
  , modToFile
  , suffixes
  ) where

import Language.Haskell.Lexer(lexerPass0,Token(..),PosToken,line)

import Control.Monad(mplus, filterM)
import Control.Exception(evaluate)
import Data.List(intercalate,isPrefixOf,nub)
import System.Directory(doesFileExist)
import qualified System.IO as IO
import System.FilePath

data Import = Import { Import -> ModName
impMod :: ModName, Import -> ImpType
impType :: ImpType }
                deriving (Int -> Import -> ShowS
[Import] -> ShowS
Import -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Import] -> ShowS
$cshowList :: [Import] -> ShowS
show :: Import -> FilePath
$cshow :: Import -> FilePath
showsPrec :: Int -> Import -> ShowS
$cshowsPrec :: Int -> Import -> ShowS
Show, Import -> Import -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Import -> Import -> Bool
$c/= :: Import -> Import -> Bool
== :: Import -> Import -> Bool
$c== :: Import -> Import -> Bool
Eq)

data ImpType = NormalImp | SourceImp
                deriving (Int -> ImpType -> ShowS
[ImpType] -> ShowS
ImpType -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ImpType] -> ShowS
$cshowList :: [ImpType] -> ShowS
show :: ImpType -> FilePath
$cshow :: ImpType -> FilePath
showsPrec :: Int -> ImpType -> ShowS
$cshowsPrec :: Int -> ImpType -> ShowS
Show,ImpType -> ImpType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImpType -> ImpType -> Bool
$c/= :: ImpType -> ImpType -> Bool
== :: ImpType -> ImpType -> Bool
$c== :: ImpType -> ImpType -> Bool
Eq,Eq ImpType
ImpType -> ImpType -> Bool
ImpType -> ImpType -> Ordering
ImpType -> ImpType -> ImpType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ImpType -> ImpType -> ImpType
$cmin :: ImpType -> ImpType -> ImpType
max :: ImpType -> ImpType -> ImpType
$cmax :: ImpType -> ImpType -> ImpType
>= :: ImpType -> ImpType -> Bool
$c>= :: ImpType -> ImpType -> Bool
> :: ImpType -> ImpType -> Bool
$c> :: ImpType -> ImpType -> Bool
<= :: ImpType -> ImpType -> Bool
$c<= :: ImpType -> ImpType -> Bool
< :: ImpType -> ImpType -> Bool
$c< :: ImpType -> ImpType -> Bool
compare :: ImpType -> ImpType -> Ordering
$ccompare :: ImpType -> ImpType -> Ordering
Ord)

-- | Get the imports of a file.
parseFile          :: FilePath -> IO (ModName,[Import])
parseFile :: FilePath -> IO (ModName, [Import])
parseFile FilePath
f =
  do Handle
h <- FilePath -> IOMode -> IO Handle
IO.openFile FilePath
f IOMode
IO.ReadMode
     Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h TextEncoding
IO.utf8
     (ModName
modName, [Import]
imps) <- (FilePath -> (ModName, [Import])
parseString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
get_text) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle -> IO FilePath
IO.hGetContents Handle
h
     Int
_ <- forall a. a -> IO a
evaluate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Import]
imps) -- this is here so that the file gets closed
     Handle -> IO ()
IO.hClose Handle
h
     if FilePath
ext forall a. Eq a => a -> a -> Bool
== FilePath
".imports"
       then forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ModName
splitModName (ShowS
takeBaseName FilePath
f), [Import]
imps)
       else case ModName
modName of
            -- disambiguate Main modules with no qualifiers
            (Hierarchy [],FilePath
"Main") -> forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ModName
splitFilePath FilePath
f,[Import]
imps)
            ModName
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (ModName
modName, [Import]
imps)


  where get_text :: ShowS
get_text FilePath
txt = if FilePath
ext forall a. Eq a => a -> a -> Bool
== FilePath
".lhs" then ShowS
delit FilePath
txt else FilePath
txt
        ext :: FilePath
ext          = ShowS
takeExtension FilePath
f

-- | Get the imports from a string that represents a program.
parseString        :: String -> (ModName,[Import])
parseString :: FilePath -> (ModName, [Import])
parseString         = [PosToken] -> (ModName, [Import])
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PosToken] -> [PosToken]
dropApproxCPP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PosToken] -> [PosToken]
dropComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [PosToken]
lexerPass0


-- | Drop comments, but keep {-# SOURCE #-} pragmas.
dropComments :: [PosToken] -> [PosToken]
dropComments :: [PosToken] -> [PosToken]
dropComments = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Token, (a, FilePath)) -> Bool
skip)
  where
  skip :: (Token, (a, FilePath)) -> Bool
skip (Token
t, (a
_,FilePath
txt))
    |  Token
t forall a. Eq a => a -> a -> Bool
== Token
Whitespace
    Bool -> Bool -> Bool
|| Token
t forall a. Eq a => a -> a -> Bool
== Token
Commentstart
    Bool -> Bool -> Bool
|| Token
t forall a. Eq a => a -> a -> Bool
== Token
Comment
    Bool -> Bool -> Bool
|| Token
t forall a. Eq a => a -> a -> Bool
== Token
LiterateComment = Bool
True
    |  Token
t forall a. Eq a => a -> a -> Bool
== Token
NestedComment   = Bool -> Bool
not (FilePath -> Bool
isSourcePragma FilePath
txt)
    | Bool
otherwise             = Bool
False


isSourcePragma :: String -> Bool
isSourcePragma :: FilePath -> Bool
isSourcePragma FilePath
txt = case FilePath -> [FilePath]
words FilePath
txt of
                       [FilePath
"{-#", FilePath
"SOURCE", FilePath
"#-}"] -> Bool
True
                       [FilePath]
_                        -> Bool
False


dropApproxCPP :: [PosToken] -> [PosToken]

 -- this is some artifact of the lexer
dropApproxCPP :: [PosToken] -> [PosToken]
dropApproxCPP ((Token
_, (Pos
_,FilePath
"")) : [PosToken]
more) = [PosToken] -> [PosToken]
dropApproxCPP [PosToken]
more

dropApproxCPP ((Token
Varsym, (Pos
_,FilePath
"#")) : (Token
_, (Pos
pos,FilePath
tok)) : [PosToken]
more)
  | FilePath
tok forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ FilePath
"if", FilePath
"ifdef", FilePath
"ifndef" ] = [PosToken] -> [PosToken]
dropToEndif [PosToken]
more
  | FilePath
tok forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ FilePath
"include", FilePath
"define", FilePath
"undef" ] = [PosToken] -> [PosToken]
dropToEOL [PosToken]
more
  where
  dropToEndif :: [PosToken] -> [PosToken]
dropToEndif ((Token
Varsym, (Pos
_,FilePath
"#")) : (Token
_, (Pos
_,FilePath
"endif")) : [PosToken]
rest)
                         = [PosToken] -> [PosToken]
dropApproxCPP [PosToken]
rest
  dropToEndif (PosToken
_ : [PosToken]
rest) = [PosToken] -> [PosToken]
dropToEndif [PosToken]
rest
  dropToEndif []         = []

  dropToEOL :: [PosToken] -> [PosToken]
dropToEOL ((Token
_, (Pos
pos1,FilePath
_)) : [PosToken]
rest)
    | Pos -> Int
line Pos
pos forall a. Eq a => a -> a -> Bool
== Pos -> Int
line Pos
pos1 = [PosToken] -> [PosToken]
dropToEOL [PosToken]
rest
  dropToEOL [PosToken]
xs  = [PosToken] -> [PosToken]
dropApproxCPP [PosToken]
xs

dropApproxCPP (PosToken
x : [PosToken]
xs) = PosToken
x forall a. a -> [a] -> [a]
: [PosToken] -> [PosToken]
dropApproxCPP [PosToken]
xs
dropApproxCPP []       = []


-- 'import' maybe_src maybe_safe optqualified maybe_pkg modid
--                                                        maybeas maybeimpspec
isImp :: [PosToken] -> Maybe (Import, [PosToken])
isImp :: [PosToken] -> Maybe (Import, [PosToken])
isImp [PosToken]
ts = forall {t} {a}.
(Ord t, Num t) =>
t
-> [(Token, (a, FilePath))]
-> Maybe (Import, [(Token, (a, FilePath))])
attempt (Int
1::Int) (forall a. Int -> [a] -> [a]
drop Int
1 [PosToken]
ts)
  where
  attempt :: t
-> [(Token, (a, FilePath))]
-> Maybe (Import, [(Token, (a, FilePath))])
attempt t
n [(Token, (a, FilePath))]
toks
    -- import safe qualified "package" ModId
    | t
n forall a. Ord a => a -> a -> Bool
> t
4     = forall a. Maybe a
Nothing
    | Bool
otherwise = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (forall {a}.
[(Token, (a, FilePath))]
-> Maybe (Import, [(Token, (a, FilePath))])
isMod [(Token, (a, FilePath))]
toks) (t
-> [(Token, (a, FilePath))]
-> Maybe (Import, [(Token, (a, FilePath))])
attempt (t
nforall a. Num a => a -> a -> a
+t
1) (forall a. Int -> [a] -> [a]
drop Int
1 [(Token, (a, FilePath))]
toks))

  isMod :: [(Token, (a, FilePath))]
-> Maybe (Import, [(Token, (a, FilePath))])
isMod ((Token
ty, (a
_,FilePath
x)) : [(Token, (a, FilePath))]
xs) = case Token
ty of
                               Token
Conid  -> forall a. a -> Maybe a
Just (FilePath -> Import
toImp FilePath
x,[(Token, (a, FilePath))]
xs)
                               Token
Qconid -> forall a. a -> Maybe a
Just (FilePath -> Import
toImp FilePath
x,[(Token, (a, FilePath))]
xs)
                               Token
_      -> forall a. Maybe a
Nothing
  isMod [(Token, (a, FilePath))]
_                   = forall a. Maybe a
Nothing

  toImp :: FilePath -> Import
toImp FilePath
x = Import { impMod :: ModName
impMod = FilePath -> ModName
splitModName FilePath
x, impType :: ImpType
impType = ImpType
isSrc }
  isSrc :: ImpType
isSrc   = case [PosToken]
ts of
              PosToken
_ : (Token
_,(Pos
_,FilePath
x)) : [PosToken]
_ | FilePath -> Bool
isSourcePragma FilePath
x -> ImpType
SourceImp
              [PosToken]
_                                    -> ImpType
NormalImp



parse              :: [PosToken] -> (ModName,[Import])
parse :: [PosToken] -> (ModName, [Import])
parse ((Token
Reservedid,(Pos
_,FilePath
"module")) : (Token
_,(Pos
_,FilePath
m)) : [PosToken]
is) =
                                                  (FilePath -> ModName
splitModName FilePath
m,[PosToken] -> [Import]
imports [PosToken]
is)
parse [PosToken]
is            = (([FilePath] -> Qualifier
Hierarchy [],FilePath
"Main"),[PosToken] -> [Import]
imports [PosToken]
is)
-- TODO: special handling for Main modules, 
-- to disambiguate multiple main Modules in a single project

imports            :: [PosToken] -> [Import]
imports :: [PosToken] -> [Import]
imports [PosToken]
ts          = case [PosToken] -> Maybe (Import, [PosToken])
isImp forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
"import" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) [PosToken]
ts of
                        Just (Import
x,[PosToken]
xs) -> Import
x forall a. a -> [a] -> [a]
: [PosToken] -> [Import]
imports [PosToken]
xs
                        Maybe (Import, [PosToken])
_           -> []

-- | A hierarchical module name.
-- We make this an opaque type with accessors 'qualifierNodes' and 'fromHierarchy' 
-- so that we can transparently add new structure to this type.
data Qualifier = Hierarchy [String]
    | FromFile [String] deriving (Int -> Qualifier -> ShowS
[Qualifier] -> ShowS
Qualifier -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Qualifier] -> ShowS
$cshowList :: [Qualifier] -> ShowS
show :: Qualifier -> FilePath
$cshow :: Qualifier -> FilePath
showsPrec :: Int -> Qualifier -> ShowS
$cshowsPrec :: Int -> Qualifier -> ShowS
Show, Qualifier -> Qualifier -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Qualifier -> Qualifier -> Bool
$c/= :: Qualifier -> Qualifier -> Bool
== :: Qualifier -> Qualifier -> Bool
$c== :: Qualifier -> Qualifier -> Bool
Eq)
qualifierNodes :: Qualifier -> [String]
qualifierNodes :: Qualifier -> [FilePath]
qualifierNodes (Hierarchy [FilePath]
qs) = [FilePath]
qs
qualifierNodes (FromFile [FilePath]
qs) = [FilePath]
qs
fromHierarchy :: [String] -> Qualifier
fromHierarchy :: [FilePath] -> Qualifier
fromHierarchy = [FilePath] -> Qualifier
Hierarchy

type ModName        = (Qualifier,String)

-- | Convert a string name into a hierarchical name qualifier.
splitQualifier     :: String -> Qualifier
splitQualifier :: FilePath -> Qualifier
splitQualifier FilePath
cs = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
'.'forall a. Eq a => a -> a -> Bool
==) FilePath
cs of
                        (FilePath
xs,Char
_:FilePath
ys)  -> let Hierarchy [FilePath]
qs = FilePath -> Qualifier
splitQualifier FilePath
ys
                            in [FilePath] -> Qualifier
Hierarchy (FilePath
xsforall a. a -> [a] -> [a]
:[FilePath]
qs)
                        (FilePath, FilePath)
_          -> [FilePath] -> Qualifier
Hierarchy [FilePath
cs]

-- | The 'Qualifier' for a Main module is the path leading to it, 
-- the module name is the file's basename, which is Main in typical cases.  
splitFilePath :: FilePath -> ModName
splitFilePath :: FilePath -> ModName
splitFilePath FilePath
path = let (FilePath
d,FilePath
f) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
path
    in ([FilePath] -> Qualifier
FromFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeDirectory forall a b. (a -> b) -> a -> b
$ FilePath
d, ShowS
dropExtensions FilePath
f)

-- | Convert a string name into a hierarchical name.
-- It is important that 
-- 
-- @
-- f `elem` (('relPaths' . 'splitFilePath') f)
-- @
splitModName       :: String -> ModName
splitModName :: FilePath -> ModName
splitModName FilePath
cs     = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
'.'forall a. Eq a => a -> a -> Bool
==) FilePath
cs of
                        (FilePath
xs,Char
_:FilePath
ys)  -> let (Hierarchy [FilePath]
as,FilePath
bs) = FilePath -> ModName
splitModName FilePath
ys
                                   in ([FilePath] -> Qualifier
Hierarchy (FilePath
xsforall a. a -> [a] -> [a]
:[FilePath]
as),FilePath
bs)
                        (FilePath, FilePath)
_ -> ([FilePath] -> Qualifier
Hierarchy [],FilePath
cs)

joinModName        :: ModName -> String
joinModName :: ModName -> FilePath
joinModName (Qualifier
q,FilePath
y)  = forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." (Qualifier -> [FilePath]
qualifierNodes Qualifier
q forall a. [a] -> [a] -> [a]
++ [FilePath
y])

-- | The files in which a module might reside.
relPaths           :: ModName -> [FilePath]
relPaths :: ModName -> [FilePath]
relPaths (Qualifier
q,FilePath
y)     = [ FilePath
prefix forall a. [a] -> [a] -> [a]
++ FilePath
suffix | FilePath
suffix <- [FilePath]
suffixes ]
  where prefix :: FilePath
prefix      = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FilePath -> ShowS
(</>) FilePath
y (Qualifier -> [FilePath]
qualifierNodes Qualifier
q)

suffixes           :: [String]
suffixes :: [FilePath]
suffixes            = [FilePath
".hs",FilePath
".lhs", FilePath
".imports"]

-- | The files in which a module might reside.
-- We report only files that exist.
modToFile          :: [FilePath] -> ModName -> IO [FilePath]
modToFile :: [FilePath] -> ModName -> IO [FilePath]
modToFile [FilePath]
dirs ModName
m    = forall a. Eq a => [a] -> [a]
nub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [FilePath]
paths
  where
  paths :: [FilePath]
paths             = [ FilePath
d FilePath -> ShowS
</> FilePath
r | FilePath
d <- [FilePath]
dirs, FilePath
r <- ModName -> [FilePath]
relPaths ModName
m ]


delit :: String -> String
delit :: ShowS
delit FilePath
txt = [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
bird forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
txt
  where
  bird :: [FilePath] -> [FilePath]
bird ((Char
'>' : FilePath
cs) : [FilePath]
ls)  = (Char
' ' forall a. a -> [a] -> [a]
: FilePath
cs) forall a. a -> [a] -> [a]
: [FilePath] -> [FilePath]
bird [FilePath]
ls
  bird (FilePath
l : [FilePath]
ls)
    | FilePath
"\\begin{code}" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
l  = [FilePath] -> [FilePath]
in_code [FilePath]
ls
    | Bool
otherwise                       = [FilePath] -> [FilePath]
bird [FilePath]
ls
  bird []                             = []

  in_code :: [FilePath] -> [FilePath]
in_code (FilePath
l : [FilePath]
ls)
    | FilePath
"\\end{code}" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
l    = [FilePath] -> [FilePath]
bird [FilePath]
ls
    | Bool
otherwise                       = FilePath
l forall a. a -> [a] -> [a]
: [FilePath] -> [FilePath]
in_code [FilePath]
ls
  in_code []                          = []    -- unterminated code...