{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UndecidableInstances  #-}
-- | Parsing of Haskell source files, and error reporting for unparsable files.
module Language.Haskell.Homplexity.Parse (parseSource, parseTest) where

import           Control.Exception                    as E
--import Data.Functor
--import Data.Maybe
import           Data.Map.Strict                      (Map)
import qualified Data.Map.Strict                      as Map

import           Language.Haskell.Exts
--import           Language.Haskell.Exts.SrcLoc
--import           Language.Haskell.Exts.Syntax
import           Language.Haskell.Homplexity.Comments
import           Language.Haskell.Homplexity.Message
import           Language.Preprocessor.Cpphs

--import HFlags


-- | CppHs options that should be compatible with haskell-src-exts
cppHsOptions ::  CpphsOptions
cppHsOptions :: CpphsOptions
cppHsOptions = CpphsOptions
defaultCpphsOptions {
                 boolopts :: BoolOptions
boolopts = BoolOptions
defaultBoolOptions {
                              macros :: Bool
macros    = Bool
False,
                              stripEol :: Bool
stripEol  = Bool
True,
                              stripC89 :: Bool
stripC89  = Bool
True,
                              pragma :: Bool
pragma    = Bool
False,
                              hashline :: Bool
hashline  = Bool
False,
                              locations :: Bool
locations = Bool
True -- or False if doesn't compile...
                            }
               }


-- | Removes duplicate and switching extensions.
--
--   Example:
--
--   >>> [ EnableExtension ScopedTypeVariables, DisableExtension ScopedTypeVariables, EnableExtension DoRec ]
--   [ DisableExtension ScopedTypeVariables, EnableExtension DoRec ]
--
collapseSameExtensions :: [Extension] -> [Extension]
collapseSameExtensions :: [Extension] -> [Extension]
collapseSameExtensions = Map KnownExtension Bool -> [Extension]
mkList (Map KnownExtension Bool -> [Extension])
-> ([Extension] -> Map KnownExtension Bool)
-> [Extension]
-> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map KnownExtension Bool -> Extension -> Map KnownExtension Bool)
-> Map KnownExtension Bool
-> [Extension]
-> Map KnownExtension Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map KnownExtension Bool -> Extension -> Map KnownExtension Bool
processExtension Map KnownExtension Bool
forall k a. Map k a
Map.empty
  where
    processExtension :: Map KnownExtension Bool -> Extension -> Map KnownExtension Bool
    processExtension :: Map KnownExtension Bool -> Extension -> Map KnownExtension Bool
processExtension Map KnownExtension Bool
m (UnknownExtension String
_) = Map KnownExtension Bool
m
    processExtension Map KnownExtension Bool
m (EnableExtension  KnownExtension
e) = KnownExtension
-> Bool -> Map KnownExtension Bool -> Map KnownExtension Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KnownExtension
e Bool
True  Map KnownExtension Bool
m
    processExtension Map KnownExtension Bool
m (DisableExtension KnownExtension
e) = KnownExtension
-> Bool -> Map KnownExtension Bool -> Map KnownExtension Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KnownExtension
e Bool
False Map KnownExtension Bool
m
    mkList :: Map KnownExtension Bool -> [Extension]
mkList = ((KnownExtension, Bool) -> Extension)
-> [(KnownExtension, Bool)] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map (\case (KnownExtension
e, Bool
True)  -> KnownExtension -> Extension
EnableExtension KnownExtension
e
                        (KnownExtension
e, Bool
False) -> KnownExtension -> Extension
DisableExtension KnownExtension
e
                 )
             ([(KnownExtension, Bool)] -> [Extension])
-> (Map KnownExtension Bool -> [(KnownExtension, Bool)])
-> Map KnownExtension Bool
-> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map KnownExtension Bool -> [(KnownExtension, Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList


mkParseMode :: FilePath -> [Extension] -> ParseMode
mkParseMode :: String -> [Extension] -> ParseMode
mkParseMode String
inputFilename [Extension]
extensions = ParseMode
    { parseFilename :: String
parseFilename         = String
inputFilename
    , baseLanguage :: Language
baseLanguage          = Language
Haskell2010
    , extensions :: [Extension]
extensions            = [Extension]
extensions
    , ignoreLanguagePragmas :: Bool
ignoreLanguagePragmas = Bool
False
    , ignoreLinePragmas :: Bool
ignoreLinePragmas     = Bool
False
    , fixities :: Maybe [Fixity]
fixities              = [Fixity] -> Maybe [Fixity]
forall a. a -> Maybe a
Just [Fixity]
preludeFixities
    , ignoreFunctionArity :: Bool
ignoreFunctionArity   = Bool
False
    }


parseSourceInternal :: [Extension] -> FilePath -> String -> IO (ParseResult (Module SrcSpanInfo, [Comment]))
parseSourceInternal :: [Extension]
-> String
-> String
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
parseSourceInternal [Extension]
additionalExtensions String
inputFilename String
inputFileContents = do
    String
deCppHsInput <- CpphsOptions -> String -> String -> IO String
runCpphs CpphsOptions
cppHsOptions String
inputFilename String
inputFileContents
    let fileExtensions :: [Extension]
fileExtensions = [Extension]
-> ((Maybe Language, [Extension]) -> [Extension])
-> Maybe (Maybe Language, [Extension])
-> [Extension]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Maybe Language, [Extension]) -> [Extension]
forall a b. (a, b) -> b
snd (Maybe (Maybe Language, [Extension]) -> [Extension])
-> Maybe (Maybe Language, [Extension]) -> [Extension]
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Maybe Language, [Extension])
readExtensions String
deCppHsInput
        extensions :: [Extension]
extensions     = [Extension] -> [Extension]
collapseSameExtensions ([Extension]
additionalExtensions [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
fileExtensions)
        result :: ParseResult (Module SrcSpanInfo, [Comment])
result         = ParseMode -> String -> ParseResult (Module SrcSpanInfo, [Comment])
parseModuleWithComments (String -> [Extension] -> ParseMode
mkParseMode String
inputFilename [Extension]
extensions) String
deCppHsInput
    ParseResult (Module SrcSpanInfo, [Comment])
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult (Module SrcSpanInfo, [Comment])
result


-- | Parse Haskell source file, using CppHs for preprocessing,
-- and haskell-src-exts for parsing.
--
-- Catches all exceptions and wraps them as @Critical@ log messages.
parseSource :: [Extension] -> FilePath -> IO (Either Log (Module SrcLoc, [CommentLink]))
parseSource :: [Extension]
-> String -> IO (Either Log (Module SrcLoc, [CommentLink]))
parseSource [Extension]
additionalExtensions String
inputFilename = do
  ParseResult (Module SrcSpanInfo, [Comment])
parseResult <- (    String -> IO String
readFile String
inputFilename
                  IO String
-> (String -> IO (ParseResult (Module SrcSpanInfo, [Comment])))
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Extension]
-> String
-> String
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
parseSourceInternal [Extension]
additionalExtensions String
inputFilename
                  IO (ParseResult (Module SrcSpanInfo, [Comment]))
-> (ParseResult (Module SrcSpanInfo, [Comment])
    -> IO (ParseResult (Module SrcSpanInfo, [Comment])))
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseResult (Module SrcSpanInfo, [Comment])
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
forall a. a -> IO a
evaluate)
      IO (ParseResult (Module SrcSpanInfo, [Comment]))
-> (SomeException
    -> IO (ParseResult (Module SrcSpanInfo, [Comment])))
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (String -> ParseResult (Module SrcSpanInfo, [Comment]))
-> SomeException
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
forall {m :: * -> *} {a}.
Monad m =>
(String -> a) -> SomeException -> m a
handleException (SrcLoc -> String -> ParseResult (Module SrcSpanInfo, [Comment])
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
thisFileLoc)
  case ParseResult (Module SrcSpanInfo, [Comment])
parseResult of
    ParseOk (Module SrcSpanInfo
parsed, [Comment]
comments) -> Either Log (Module SrcLoc, [CommentLink])
-> IO (Either Log (Module SrcLoc, [CommentLink]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Log (Module SrcLoc, [CommentLink])
 -> IO (Either Log (Module SrcLoc, [CommentLink])))
-> Either Log (Module SrcLoc, [CommentLink])
-> IO (Either Log (Module SrcLoc, [CommentLink]))
forall a b. (a -> b) -> a -> b
$ (Module SrcLoc, [CommentLink])
-> Either Log (Module SrcLoc, [CommentLink])
forall a b. b -> Either a b
Right (SrcSpanInfo -> SrcLoc
forall si. SrcInfo si => si -> SrcLoc
getPointLoc (SrcSpanInfo -> SrcLoc) -> Module SrcSpanInfo -> Module SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module SrcSpanInfo
parsed,
                                                  [Comment] -> [CommentLink]
classifyComments [Comment]
comments)
    ParseFailed SrcLoc
aLoc String
msg       -> Either Log (Module SrcLoc, [CommentLink])
-> IO (Either Log (Module SrcLoc, [CommentLink]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Log (Module SrcLoc, [CommentLink])
 -> IO (Either Log (Module SrcLoc, [CommentLink])))
-> Either Log (Module SrcLoc, [CommentLink])
-> IO (Either Log (Module SrcLoc, [CommentLink]))
forall a b. (a -> b) -> a -> b
$ Log -> Either Log (Module SrcLoc, [CommentLink])
forall a b. a -> Either a b
Left (Log -> Either Log (Module SrcLoc, [CommentLink]))
-> Log -> Either Log (Module SrcLoc, [CommentLink])
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> Log
critical SrcLoc
aLoc String
msg
  where
    handleException :: (String -> a) -> SomeException -> m a
handleException String -> a
helper (SomeException
e :: SomeException) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ String -> a
helper (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
    thisFileLoc :: SrcLoc
thisFileLoc = SrcLoc
noLoc { srcFilename :: String
srcFilename = String
inputFilename }


-- | For use in test suite
parseTest ::  String -> String -> IO (Module SrcLoc, [CommentLink])
parseTest :: String -> String -> IO (Module SrcLoc, [CommentLink])
parseTest String
testId String
testSource = do
    [Extension]
-> String
-> String
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
parseSourceInternal [] String
testId String
testSource IO (ParseResult (Module SrcSpanInfo, [Comment]))
-> (ParseResult (Module SrcSpanInfo, [Comment])
    -> IO (Module SrcLoc, [CommentLink]))
-> IO (Module SrcLoc, [CommentLink])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ParseOk (Module SrcSpanInfo
parsed, [Comment]
comments) -> (Module SrcLoc, [CommentLink]) -> IO (Module SrcLoc, [CommentLink])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Module SrcLoc, [CommentLink])
 -> IO (Module SrcLoc, [CommentLink]))
-> (Module SrcLoc, [CommentLink])
-> IO (Module SrcLoc, [CommentLink])
forall a b. (a -> b) -> a -> b
$ (SrcSpanInfo -> SrcLoc
forall si. SrcInfo si => si -> SrcLoc
getPointLoc (SrcSpanInfo -> SrcLoc) -> Module SrcSpanInfo -> Module SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module SrcSpanInfo
parsed, [Comment] -> [CommentLink]
classifyComments [Comment]
comments)
        ParseResult (Module SrcSpanInfo, [Comment])
other                      -> String -> IO (Module SrcLoc, [CommentLink])
forall a. HasCallStack => String -> a
error (String -> IO (Module SrcLoc, [CommentLink]))
-> String -> IO (Module SrcLoc, [CommentLink])
forall a b. (a -> b) -> a -> b
$ ParseResult (Module SrcSpanInfo, [Comment]) -> String
forall a. Show a => a -> String
show ParseResult (Module SrcSpanInfo, [Comment])
other