{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Parser for Haskell source code.
module Ormolu.Parser
  ( parseModule,
    manualExts,
  )
where

import qualified CmdLineParser as GHC
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.List ((\\), foldl', isPrefixOf)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes)
import DynFlags as GHC
import qualified FastString as GHC
import GHC hiding (IE, UnicodeSyntax)
import GHC.DynFlags (baseDynFlags)
import GHC.LanguageExtensions.Type (Extension (..))
import qualified HeaderInfo as GHC
import qualified HscTypes as GHC
import qualified Lexer as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import qualified Outputable as GHC
import qualified Panic as GHC
import qualified Parser as GHC
import qualified StringBuffer as GHC

-- | Parse a complete module from string.
parseModule ::
  MonadIO m =>
  -- | Ormolu configuration
  Config ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for parser
  String ->
  m
    ( [GHC.Warn],
      Either (SrcSpan, String) ParseResult
    )
parseModule :: Config
-> FilePath
-> FilePath
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
parseModule Config {..} path :: FilePath
path input' :: FilePath
input' = IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
 -> m ([Warn], Either (SrcSpan, FilePath) ParseResult))
-> IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
forall a b. (a -> b) -> a -> b
$ do
  let (input :: FilePath
input, extraComments :: [Located FilePath]
extraComments) = FilePath -> FilePath -> (FilePath, [Located FilePath])
extractCommentsFromLines FilePath
path FilePath
input'
  -- It's important that 'setDefaultExts' is done before
  -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
  -- extension that was explicitly disabled in the file.
  let baseFlags :: DynFlags
baseFlags =
        GeneralFlag -> DynFlags -> DynFlags
GHC.setGeneralFlag'
          GeneralFlag
GHC.Opt_Haddock
          (DynFlags -> DynFlags
setDefaultExts DynFlags
baseDynFlags)
      extraOpts :: [Located FilePath]
extraOpts = DynOption -> Located FilePath
dynOptionToLocatedStr (DynOption -> Located FilePath)
-> [DynOption] -> [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DynOption]
cfgDynOptions
  (warnings :: [Warn]
warnings, dynFlags :: DynFlags
dynFlags) <-
    DynFlags
-> [Located FilePath]
-> FilePath
-> FilePath
-> IO (Either FilePath ([Warn], DynFlags))
parsePragmasIntoDynFlags DynFlags
baseFlags [Located FilePath]
extraOpts FilePath
path FilePath
input' IO (Either FilePath ([Warn], DynFlags))
-> (Either FilePath ([Warn], DynFlags) -> IO ([Warn], DynFlags))
-> IO ([Warn], DynFlags)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right res :: ([Warn], DynFlags)
res -> ([Warn], DynFlags) -> IO ([Warn], DynFlags)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn], DynFlags)
res
      Left err :: FilePath
err ->
        let loc :: SrcSpan
loc =
              SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan
                (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
path) 1 1)
                (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
path) 1 1)
         in OrmoluException -> IO ([Warn], DynFlags)
forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> FilePath -> OrmoluException
OrmoluParsingFailed SrcSpan
loc FilePath
err)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Extension -> DynFlags -> Bool
GHC.xopt Extension
Cpp DynFlags
dynFlags Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cfgTolerateCpp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    OrmoluException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (FilePath -> OrmoluException
OrmoluCppEnabled FilePath
path)
  let useRecordDot :: Bool
useRecordDot =
        "record-dot-preprocessor" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> FilePath
pgm_F DynFlags
dynFlags
          Bool -> Bool -> Bool
|| (ModuleName -> Bool) -> [ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
            (("RecordDotPreprocessor" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==) (FilePath -> Bool)
-> (ModuleName -> FilePath) -> ModuleName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FilePath
moduleNameString)
            (DynFlags -> [ModuleName]
pluginModNames DynFlags
dynFlags)
      r :: Either (SrcSpan, FilePath) ParseResult
r = case P (Located (HsModule GhcPs))
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located (HsModule GhcPs))
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located (HsModule GhcPs))
GHC.parseModule DynFlags
dynFlags FilePath
path FilePath
input of
        GHC.PFailed _ ss :: SrcSpan
ss m :: MsgDoc
m ->
          (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) ParseResult
forall a b. a -> Either a b
Left (SrcSpan
ss, DynFlags -> MsgDoc -> FilePath
GHC.showSDoc DynFlags
dynFlags MsgDoc
m)
        GHC.POk pstate :: PState
pstate pmod :: Located (HsModule GhcPs)
pmod ->
          let (comments :: CommentStream
comments, exts :: [Pragma]
exts, shebangs :: [Located FilePath]
shebangs) = [Located FilePath]
-> PState -> (CommentStream, [Pragma], [Located FilePath])
mkCommentStream [Located FilePath]
extraComments PState
pstate
           in ParseResult -> Either (SrcSpan, FilePath) ParseResult
forall a b. b -> Either a b
Right
                ParseResult :: Located (HsModule GhcPs)
-> Anns
-> CommentStream
-> [Pragma]
-> [Located FilePath]
-> Bool
-> ParseResult
ParseResult
                  { prParsedSource :: Located (HsModule GhcPs)
prParsedSource = Located (HsModule GhcPs)
pmod,
                    prAnns :: Anns
prAnns = PState -> Anns
mkAnns PState
pstate,
                    prCommentStream :: CommentStream
prCommentStream = CommentStream
comments,
                    prExtensions :: [Pragma]
prExtensions = [Pragma]
exts,
                    prShebangs :: [Located FilePath]
prShebangs = [Located FilePath]
shebangs,
                    prUseRecordDot :: Bool
prUseRecordDot = Bool
useRecordDot
                  }
  ([Warn], Either (SrcSpan, FilePath) ParseResult)
-> IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Warn]
warnings, Either (SrcSpan, FilePath) ParseResult
r)

-- | Extensions that are not enabled automatically and should be activated
-- by user.
manualExts :: [Extension]
manualExts :: [Extension]
manualExts =
  [ Extension
Arrows, -- steals proc
    Extension
Cpp, -- forbidden
    Extension
BangPatterns, -- makes certain patterns with ! fail
    Extension
PatternSynonyms, -- steals the pattern keyword
    Extension
RecursiveDo, -- steals the rec keyword
    Extension
StaticPointers, -- steals static keyword
    Extension
TransformListComp, -- steals the group keyword
    Extension
UnboxedTuples, -- breaks (#) lens operator
    Extension
MagicHash, -- screws {-# these things #-}
    Extension
TypeApplications, -- steals (@) operator on some cases
    Extension
AlternativeLayoutRule,
    Extension
AlternativeLayoutRuleTransitional,
    Extension
MonadComprehensions,
    Extension
UnboxedSums,
    Extension
UnicodeSyntax, -- gives special meanings to operators like (→)
    Extension
TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
    -- apparently interferes with QuasiQuotes in
    -- weird ways
  ]

----------------------------------------------------------------------------
-- Helpers (taken from ghc-exactprint)

-- | Run a 'GHC.P' computation.
runParser ::
  -- | Computation to run
  GHC.P a ->
  -- | Dynamic flags
  GHC.DynFlags ->
  -- | Module path
  FilePath ->
  -- | Module contents
  String ->
  -- | Parse result
  GHC.ParseResult a
runParser :: P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser parser :: P a
parser flags :: DynFlags
flags filename :: FilePath
filename input :: FilePath
input = P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
GHC.unP P a
parser PState
parseState
  where
    location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
filename) 1 1
    buffer :: StringBuffer
buffer = FilePath -> StringBuffer
GHC.stringToStringBuffer FilePath
input
    parseState :: PState
parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
GHC.mkPState DynFlags
flags StringBuffer
buffer RealSrcLoc
location

-- | Transform given lines possibly returning comments extracted from them.
-- This handles LINE pragmas and shebangs.
extractCommentsFromLines ::
  -- | File name, just to use in the spans
  FilePath ->
  -- | List of lines from that file
  String ->
  -- | Adjusted lines together with comments extracted from them
  (String, [Located String])
extractCommentsFromLines :: FilePath -> FilePath -> (FilePath, [Located FilePath])
extractCommentsFromLines path :: FilePath
path =
  ([FilePath], [Maybe (Located FilePath)])
-> (FilePath, [Located FilePath])
forall a. ([FilePath], [Maybe a]) -> (FilePath, [a])
unlines' (([FilePath], [Maybe (Located FilePath)])
 -> (FilePath, [Located FilePath]))
-> (FilePath -> ([FilePath], [Maybe (Located FilePath)]))
-> FilePath
-> (FilePath, [Located FilePath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, Maybe (Located FilePath))]
-> ([FilePath], [Maybe (Located FilePath)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(FilePath, Maybe (Located FilePath))]
 -> ([FilePath], [Maybe (Located FilePath)]))
-> (FilePath -> [(FilePath, Maybe (Located FilePath))])
-> FilePath
-> ([FilePath], [Maybe (Located FilePath)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> FilePath -> (FilePath, Maybe (Located FilePath)))
-> [Int] -> [FilePath] -> [(FilePath, Maybe (Located FilePath))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (FilePath -> Int -> FilePath -> (FilePath, Maybe (Located FilePath))
extractCommentFromLine FilePath
path) [1 ..] ([FilePath] -> [(FilePath, Maybe (Located FilePath))])
-> (FilePath -> [FilePath])
-> FilePath
-> [(FilePath, Maybe (Located FilePath))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
  where
    unlines' :: ([FilePath], [Maybe a]) -> (FilePath, [a])
unlines' (a :: [FilePath]
a, b :: [Maybe a]
b) = ([FilePath] -> FilePath
unlines [FilePath]
a, [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [Maybe a]
b)

-- | Transform a given line possibly returning a comment extracted from it.
extractCommentFromLine ::
  -- | File name, just to use in the spans
  FilePath ->
  -- | Line number of this line
  Int ->
  -- | The actual line
  String ->
  -- | Adjusted line and possibly a comment extracted from it
  (String, Maybe (Located String))
extractCommentFromLine :: FilePath -> Int -> FilePath -> (FilePath, Maybe (Located FilePath))
extractCommentFromLine path :: FilePath
path line :: Int
line s :: FilePath
s
  | "{-# LINE" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
s =
    let (pragma :: FilePath
pragma, res :: FilePath
res) = FilePath -> (FilePath, FilePath)
getPragma FilePath
s
        size :: Int
size = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
pragma
        ss :: SrcSpan
ss = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (Int -> SrcLoc
mkSrcLoc' 1) (Int -> SrcLoc
mkSrcLoc' (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))
     in (FilePath
res, Located FilePath -> Maybe (Located FilePath)
forall a. a -> Maybe a
Just (Located FilePath -> Maybe (Located FilePath))
-> Located FilePath -> Maybe (Located FilePath)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L SrcSpan
ss FilePath
pragma)
  | FilePath -> Bool
isShebang FilePath
s =
    let ss :: SrcSpan
ss = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (Int -> SrcLoc
mkSrcLoc' 1) (Int -> SrcLoc
mkSrcLoc' (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s))
     in ("", Located FilePath -> Maybe (Located FilePath)
forall a. a -> Maybe a
Just (Located FilePath -> Maybe (Located FilePath))
-> Located FilePath -> Maybe (Located FilePath)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L SrcSpan
ss FilePath
s)
  | Bool
otherwise = (FilePath
s, Maybe (Located FilePath)
forall a. Maybe a
Nothing)
  where
    mkSrcLoc' :: Int -> SrcLoc
mkSrcLoc' = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
path) Int
line

-- | Take a line pragma and output its replacement (where line pragma is
-- replaced with spaces) and the contents of the pragma itself.
getPragma ::
  -- | Pragma line to analyze
  String ->
  -- | Contents of the pragma and its replacement line
  (String, String)
getPragma :: FilePath -> (FilePath, FilePath)
getPragma [] = FilePath -> (FilePath, FilePath)
forall a. HasCallStack => FilePath -> a
error "Ormolu.Parser.getPragma: input must not be empty"
getPragma s :: FilePath
s@(x :: Char
x : xs :: FilePath
xs)
  | "#-}" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
s = ("#-}", "   " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 3 FilePath
s)
  | Bool
otherwise =
    let (prag :: FilePath
prag, remline :: FilePath
remline) = FilePath -> (FilePath, FilePath)
getPragma FilePath
xs
     in (Char
x Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
prag, ' ' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
remline)

-- | Enable all language extensions that we think should be enabled by
-- default for ease of use.
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts flags :: DynFlags
flags = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
GHC.xopt_set DynFlags
flags [Extension]
autoExts
  where
    autoExts :: [Extension]
autoExts = [Extension]
allExts [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Extension]
manualExts
    allExts :: [Extension]
allExts = [Extension
forall a. Bounded a => a
minBound .. Extension
forall a. Bounded a => a
maxBound]

----------------------------------------------------------------------------
-- More helpers (taken from HLint)

parsePragmasIntoDynFlags ::
  -- | Pre-set 'DynFlags'
  DynFlags ->
  -- | Extra options (provided by user)
  [Located String] ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for parser
  String ->
  IO (Either String ([GHC.Warn], DynFlags))
parsePragmasIntoDynFlags :: DynFlags
-> [Located FilePath]
-> FilePath
-> FilePath
-> IO (Either FilePath ([Warn], DynFlags))
parsePragmasIntoDynFlags flags :: DynFlags
flags extraOpts :: [Located FilePath]
extraOpts filepath :: FilePath
filepath str :: FilePath
str =
  IO (Either FilePath ([Warn], DynFlags))
-> IO (Either FilePath ([Warn], DynFlags))
forall (m :: * -> *) b.
ExceptionMonad m =>
m (Either FilePath b) -> m (Either FilePath b)
catchErrors (IO (Either FilePath ([Warn], DynFlags))
 -> IO (Either FilePath ([Warn], DynFlags)))
-> IO (Either FilePath ([Warn], DynFlags))
-> IO (Either FilePath ([Warn], DynFlags))
forall a b. (a -> b) -> a -> b
$ do
    let opts :: [Located FilePath]
opts = DynFlags -> StringBuffer -> FilePath -> [Located FilePath]
GHC.getOptions DynFlags
flags (FilePath -> StringBuffer
GHC.stringToStringBuffer FilePath
str) FilePath
filepath
    (flags' :: DynFlags
flags', leftovers :: [Located FilePath]
leftovers, warnings :: [Warn]
warnings) <-
      DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
flags ([Located FilePath]
opts [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. Semigroup a => a -> a -> a
<> [Located FilePath]
extraOpts)
    case [Located FilePath] -> Maybe (NonEmpty (Located FilePath))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Located FilePath]
leftovers of
      Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just unrecognizedOpts :: NonEmpty (Located FilePath)
unrecognizedOpts ->
        OrmoluException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (NonEmpty FilePath -> OrmoluException
OrmoluUnrecognizedOpts (Located FilePath -> FilePath
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located FilePath -> FilePath)
-> NonEmpty (Located FilePath) -> NonEmpty FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Located FilePath)
unrecognizedOpts))
    let flags'' :: DynFlags
flags'' = DynFlags
flags' DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream
    Either FilePath ([Warn], DynFlags)
-> IO (Either FilePath ([Warn], DynFlags))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath ([Warn], DynFlags)
 -> IO (Either FilePath ([Warn], DynFlags)))
-> Either FilePath ([Warn], DynFlags)
-> IO (Either FilePath ([Warn], DynFlags))
forall a b. (a -> b) -> a -> b
$ ([Warn], DynFlags) -> Either FilePath ([Warn], DynFlags)
forall a b. b -> Either a b
Right ([Warn]
warnings, DynFlags
flags'')
  where
    catchErrors :: m (Either FilePath b) -> m (Either FilePath b)
catchErrors act :: m (Either FilePath b)
act =
      (GhcException -> m (Either FilePath b))
-> m (Either FilePath b) -> m (Either FilePath b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException
        GhcException -> m (Either FilePath b)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either FilePath b)
reportErr
        ((SourceError -> m (Either FilePath b))
-> m (Either FilePath b) -> m (Either FilePath b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError SourceError -> m (Either FilePath b)
forall (m :: * -> *) a b.
(Monad m, Show a) =>
a -> m (Either FilePath b)
reportErr m (Either FilePath b)
act)
    reportErr :: a -> m (Either FilePath b)
reportErr e :: a
e = Either FilePath b -> m (Either FilePath b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath b -> m (Either FilePath b))
-> Either FilePath b -> m (Either FilePath b)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath b
forall a b. a -> Either a b
Left (a -> FilePath
forall a. Show a => a -> FilePath
show a
e)