retrie-1.2.2: Retrie/ExactPrint.hs

-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-- | Provides consistent interface with ghc-exactprint.
module Retrie.ExactPrint
  ( -- * Fixity re-association
    fix
    -- * Parsers
  , Parsers.LibDir
  , parseContent
  , parseContentNoFixity
  , parseDecl
  , parseExpr
  , parseImports
  , parsePattern
  , parseStmt
  , parseType
    -- * Primitive Transformations
  , addAllAnnsT
  -- , cloneT
  -- , setEntryDPT
  , swapEntryDPT
  , transferAnnsT
  , transferEntryAnnsT
  , transferEntryDPT
  -- , tryTransferEntryDPT
  , transferAnchor
    -- * Utils
  , debugDump
  , debugParse
  , debug
  , hasComments
  , isComma
    -- * Annotated AST
  , module Retrie.ExactPrint.Annotated
    -- * ghc-exactprint re-exports
  , module Language.Haskell.GHC.ExactPrint
  -- , module Language.Haskell.GHC.ExactPrint.Annotate
  , module Language.Haskell.GHC.ExactPrint.Types
  , module Language.Haskell.GHC.ExactPrint.Utils
  , module Language.Haskell.GHC.ExactPrint.Transform
  ) where

import Control.Exception
import Control.Monad
import Control.Monad.State.Lazy hiding (fix)
-- import Data.Function (on)
import Data.List (transpose)
-- import Data.Maybe
-- import qualified Data.Map as M
import Text.Printf

import Language.Haskell.GHC.ExactPrint hiding
  (
   setEntryDP
  , transferEntryDP
  )
-- import Language.Haskell.GHC.ExactPrint.ExactPrint (ExactPrint)
import Language.Haskell.GHC.ExactPrint.Utils hiding (debug)
import qualified Language.Haskell.GHC.ExactPrint.Parsers as Parsers
import Language.Haskell.GHC.ExactPrint.Types
  ( showGhc
  )
import Language.Haskell.GHC.ExactPrint.Transform

import Retrie.ExactPrint.Annotated
import Retrie.Fixity
import Retrie.GHC
import Retrie.SYB hiding (ext1)
import Retrie.Util

import GHC.Stack
import Debug.Trace

debug :: c -> String -> c
debug c s = trace s c

-- Fixity traversal -----------------------------------------------------------

-- | Re-associate AST using given 'FixityEnv'. (The GHC parser has no knowledge
-- of operator fixity, because that requires running the renamer, so it parses
-- all operators as left-associated.)
fix :: (Data ast, MonadIO m) => FixityEnv -> ast -> TransformT m ast
fix env = fixAssociativity >=> fixEntryDP
  where
    fixAssociativity = everywhereM (mkM (fixOneExpr env) `extM` fixOnePat env)
    fixEntryDP = everywhereM (mkM fixOneEntryExpr `extM` fixOneEntryPat)

-- Should (x op1 y) op2 z be reassociated as x op1 (y op2 z)?
associatesRight :: Fixity -> Fixity -> Bool
associatesRight (Fixity _ p1 a1) (Fixity _ p2 _a2) =
  p2 > p1 || p1 == p2 && a1 == InfixR

-- We know GHC produces left-associated chains, so 'z' is never an
-- operator application. We also know that this will be applied bottom-up
-- by 'everywhere', so we can assume the children are already fixed.
fixOneExpr
  :: MonadIO m
  => FixityEnv
  -> LHsExpr GhcPs
  -> TransformT m (LHsExpr GhcPs)
fixOneExpr env (L l2 (OpApp x2 ap1@(L l1 (OpApp x1 x op1 y)) op2 z))
  | associatesRight (lookupOp op1 env) (lookupOp op2 env) = do
    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:(l1,l2)="  [showAst (l1,l2)]
    let ap2' = L (stripComments l2) $ OpApp x2 y op2 z
    (ap1_0, ap2'_0) <- swapEntryDPT ap1 ap2'
    ap1_1 <- transferAnnsT isComma ap2'_0 ap1_0
    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:recursing"  []
    rhs <- fixOneExpr env ap2'_0
    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:returning"  [showAst (L l2 $ OpApp x1 x op1 rhs)]
    -- return $ L l1 $ OpApp x1 x op1 rhs
    return $ L l2 $ OpApp x1 x op1 rhs
fixOneExpr _ e = return e

fixOnePat :: Monad m => FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
fixOnePat env (dLPat -> Just (L l2 (ConPat ext2 op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPat ext1 op1 (InfixCon x y)))) z))))
  | associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do
    let ap2' = L l2 (ConPat ext2 op2 (InfixCon y z))
    (ap1_0, ap2'_0) <- swapEntryDPT ap1 ap2'
    ap1_1 <- transferAnnsT isComma ap2' ap1
    rhs <- fixOnePat env (cLPat ap2'_0)
    return $ cLPat $ L l1 (ConPat ext1 op1 (InfixCon x rhs))
fixOnePat _ e = return e

-- TODO: move to ghc-exactprint
stripComments :: SrcAnn an -> SrcAnn an
stripComments (SrcSpanAnn EpAnnNotUsed l) = SrcSpanAnn EpAnnNotUsed l
stripComments (SrcSpanAnn (EpAnn anc an _) l) = SrcSpanAnn (EpAnn anc an emptyComments) l

-- Move leading whitespace from the left child of an operator application
-- to the application itself. We need this so we have correct offsets when
-- substituting into patterns and don't end up with extra leading spaces.
-- We can assume it is run bottom-up, and that precedence is already fixed.
fixOneEntry
  :: (MonadIO m, Data a)
  => LocatedA a -- ^ Overall application
  -> LocatedA a -- ^ Left child
  -> TransformT m (LocatedA a, LocatedA a)
fixOneEntry e x = do
  -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(e,x)="  [showAst (e,x)]
  -- -- anns <- getAnnsT
  -- let
  --   zeros = SameLine 0
  --   (xdp, ard) =
  --     case M.lookup (mkAnnKey x) anns of
  --       Nothing -> (zeros, zeros)
  --       Just ann -> (annLeadingCommentEntryDelta ann, annEntryDelta ann)
  --   xr = getDeltaLine xdp
  --   xc = deltaColumn xdp
  --   actualRow = getDeltaLine ard
  --   edp =
  --     maybe zeros annLeadingCommentEntryDelta $ M.lookup (mkAnnKey e) anns
  --   er = getDeltaLine edp
  --   ec = deltaColumn edp
  -- when (actualRow == 0) $ do
  --   setEntryDPT e $ deltaPos (er, xc + ec)
  --   setEntryDPT x $ deltaPos (xr, 0)

  -- We assume that ghc-exactprint has converted all Anchor's to use their delta variants.
  -- Get the dp for the x component
  let xdp = entryDP x
  let xr = getDeltaLine xdp
  let xc = deltaColumn xdp
  -- Get the dp for the e component
  let edp = entryDP e
  let er = getDeltaLine edp
  let ec = deltaColumn edp
  case xdp of
    SameLine n -> do
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(xdp,edp)="  [showAst (xdp,edp)]
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(dpx,dpe)="  [showAst ((deltaPos er (xc + ec)),(deltaPos xr 0))]
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:e'="  [showAst e]
      -- lift $ liftIO $ debugPrint Loud "fixOneEntry:e'="  [showAst (setEntryDP e (deltaPos er (xc + ec)))]
      return ( setEntryDP e (deltaPos er (xc + ec))
             , setEntryDP x (deltaPos xr 0))
    _ -> return (e,x)

  -- anns <- getAnnsT
  -- let
  --   zeros = DP (0,0)
  --   (DP (xr,xc), DP (actualRow,_)) =
  --     case M.lookup (mkAnnKey x) anns of
  --       Nothing -> (zeros, zeros)
  --       Just ann -> (annLeadingCommentEntryDelta ann, annEntryDelta ann)
  --   DP (er,ec) =
  --     maybe zeros annLeadingCommentEntryDelta $ M.lookup (mkAnnKey e) anns
  -- when (actualRow == 0) $ do
  --   setEntryDPT e $ DP (er, xc + ec)
  --   setEntryDPT x $ DP (xr, 0)
  -- return e

-- TODO: move this somewhere more appropriate
entryDP :: LocatedA a -> DeltaPos
entryDP (L (SrcSpanAnn EpAnnNotUsed _) _) = SameLine 1
entryDP (L (SrcSpanAnn (EpAnn anc _ _) _) _)
  = case anchor_op anc of
      UnchangedAnchor -> SameLine 1
      MovedAnchor dp -> dp


fixOneEntryExpr :: MonadIO m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
fixOneEntryExpr e@(L l (OpApp a x b c)) = do
  -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:(e,x)="  [showAst (e,x)]
  (e',x') <- fixOneEntry e x
  -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:(e',x')="  [showAst (e',x')]
  -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:returning="  [showAst (L (getLoc e') (OpApp a x' b c))]
  return (L (getLoc e') (OpApp a x' b c))
fixOneEntryExpr e = return e

fixOneEntryPat :: MonadIO m => LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat pat
#if __GLASGOW_HASKELL__ < 900
  | Just p@(L l (ConPatIn a (InfixCon x b))) <- dLPat pat = do
#else
  | Just p@(L l (ConPat a b (InfixCon x c))) <- dLPat pat = do
#endif
    (p', x') <- fixOneEntry p (dLPatUnsafe x)
    return (cLPat $ (L (getLoc p') (ConPat a b (InfixCon x' c))))
  | otherwise = return pat

-------------------------------------------------------------------------------


-- Swap entryDP and prior comments between the two args
swapEntryDPT
  :: (Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1, Typeable a2)
  => LocatedAn a1 a -> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT a b = do
  b' <- transferEntryDP a b
  a' <- transferEntryDP b a
  return (a',b')

-- swapEntryDPT
--   :: (Data a, Data b, Monad m)
--   => LocatedAn a1 a -> LocatedAn a2 b -> TransformT m ()
-- swapEntryDPT a b =
--   modifyAnnsT $ \ anns ->
--   let akey = mkAnnKey a
--       bkey = mkAnnKey b
--       aann = fromMaybe annNone $ M.lookup akey anns
--       bann = fromMaybe annNone $ M.lookup bkey anns
--   in M.insert akey
--       aann { annEntryDelta = annEntryDelta bann
--            , annPriorComments = annPriorComments bann } $
--      M.insert bkey
--       bann { annEntryDelta = annEntryDelta aann
--            , annPriorComments = annPriorComments aann } anns

-------------------------------------------------------------------------------

-- Compatibility module with ghc-exactprint

parseContentNoFixity :: Parsers.LibDir -> FilePath -> String -> IO AnnotatedModule
parseContentNoFixity libdir fp str = join $ Parsers.withDynFlags libdir $ \dflags -> do
  r <- Parsers.parseModuleFromString libdir fp str
  case r of
    Left msg -> do
#if __GLASGOW_HASKELL__ < 900
      fail $ show msg
#elif __GLASGOW_HASKELL__ < 904
      fail $ show $ bagToList msg
#else
      fail $ showSDoc dflags $ ppr msg
#endif
    Right m -> return $ unsafeMkA (makeDeltaAst m) 0

parseContent :: Parsers.LibDir -> FixityEnv -> FilePath -> String -> IO AnnotatedModule
parseContent libdir fixities fp =
  parseContentNoFixity libdir fp >=> (`transformA` fix fixities)

-- | Parse import statements. Each string must be a full import statement,
-- including the keyword 'import'. Supports full import syntax.
parseImports :: Parsers.LibDir -> [String] -> IO AnnotatedImports
parseImports _      []      = return mempty
parseImports libdir imports = do
  -- imports start on second line, so delta offsets are correct
  am <- parseContentNoFixity libdir "parseImports" $ "\n" ++ unlines imports
  ais <- transformA am $ pure . hsmodImports . unLoc
  return $ trimA ais

-- | Parse a top-level 'HsDecl'.
parseDecl :: Parsers.LibDir -> String -> IO AnnotatedHsDecl
parseDecl libdir str = parseHelper libdir "parseDecl" Parsers.parseDecl str

-- | Parse a 'HsExpr'.
parseExpr :: Parsers.LibDir -> String -> IO AnnotatedHsExpr
parseExpr libdir str = parseHelper libdir "parseExpr" Parsers.parseExpr str

-- | Parse a 'Pat'.
parsePattern :: Parsers.LibDir -> String -> IO AnnotatedPat
-- parsePattern libdir str = parseHelper libdir "parsePattern" p str
--   where
--     p flags fp str' = fmap dLPatUnsafe <$> Parsers.parsePattern flags fp str'
parsePattern libdir str = parseHelper libdir "parsePattern" Parsers.parsePattern str

-- | Parse a 'Stmt'.
parseStmt :: Parsers.LibDir -> String -> IO AnnotatedStmt
parseStmt libdir str = do
  -- debugPrint Loud "parseStmt:for" [str]
  res <- parseHelper libdir "parseStmt" Parsers.parseStmt str
  return (setEntryDPA res (DifferentLine 1 0))
  -- return res


-- | Parse a 'HsType'.
parseType :: Parsers.LibDir -> String -> IO AnnotatedHsType
parseType libdir str = parseHelper libdir "parseType" Parsers.parseType str

parseHelper :: (ExactPrint a)
  => Parsers.LibDir -> FilePath -> Parsers.Parser a -> String -> IO (Annotated a)
parseHelper libdir fp parser str = join $ Parsers.withDynFlags libdir $ \dflags ->
  case parser dflags fp str of
#if __GLASGOW_HASKELL__ < 900
    Left (_, msg) -> throwIO $ ErrorCall msg
#elif __GLASGOW_HASKELL__ < 904
    Left errBag -> throwIO $ ErrorCall (show $ bagToList errBag)
#else
    Left msg -> throwIO $ ErrorCall (showSDoc dflags $ ppr msg)
#endif
    Right x -> return $ unsafeMkA (makeDeltaAst x) 0

-- type Parser a = GHC.DynFlags -> FilePath -> String -> ParseResult a


-------------------------------------------------------------------------------

debugDump :: (Data a, ExactPrint a) => Annotated a -> IO ()
debugDump ax = do
  let
    str = printA ax
    maxCol = maximum $ map length $ lines str
    (tens, ones) =
      case transpose [printf "%2d" i | i <- [1 .. maxCol]] of
        [ts, os] -> (ts, os)
        _ -> ("", "")
  -- putStrLn $ unlines
  --   [ show k ++ "\n  " ++ show v | (k,v) <- M.toList (annsA ax) ]
  putStrLn tens
  putStrLn ones
  putStrLn str
  putStrLn "------------------------------------"
  putStrLn $ showAstA ax
  putStrLn "------------------------------------"

-- cloneT :: (Data a, Typeable a, Monad m) => a -> TransformT m a
-- cloneT e = getAnnsT >>= flip graftT e

-- The following definitions are all the same as the ones from ghc-exactprint,
-- but the types are liberalized from 'Transform a' to 'TransformT m a'.
transferEntryAnnsT
  :: (HasCallStack, Data a, Data b, Monad m)
  => (TrailingAnn -> Bool)  -- transfer Anns matching predicate
  -> LocatedA a             -- from
  -> LocatedA b             -- to
  -> TransformT m (LocatedA b)
transferEntryAnnsT p a b = do
  b' <- transferEntryDP a b
  transferAnnsT p a b'

-- | 'Transform' monad version of 'transferEntryDP'
transferEntryDPT
  :: (HasCallStack, Data a, Data b, Monad m)
  => Located a -> Located b -> TransformT m ()
-- transferEntryDPT a b = modifyAnnsT (transferEntryDP a b)
transferEntryDPT _a _b = error "transferEntryDPT"

-- tryTransferEntryDPT
--   :: (Data a, Data b, Monad m)
--   => Located a -> Located b -> TransformT m ()
-- tryTransferEntryDPT a b = modifyAnnsT $ \anns ->
--   if M.member (mkAnnKey a) anns
--     then transferEntryDP a b anns
--     else anns

-- This function fails if b is not in Anns, which seems dumb, since we are inserting it.
-- transferEntryDP :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
-- transferEntryDP a b anns = setEntryDP b dp anns'
--   where
--     maybeAnns = do -- Maybe monad
--       anA <- M.lookup (mkAnnKey a) anns
--       let anB = M.findWithDefault annNone (mkAnnKey b) anns
--           anB' = anB { annEntryDelta = DP (0,0) }
--       return (M.insert (mkAnnKey b) anB' anns, annLeadingCommentEntryDelta anA)
--     (anns',dp) = fromMaybe
--                   (error $ "transferEntryDP: lookup failed: " ++ show (mkAnnKey a))
--                   maybeAnns

addAllAnnsT
  :: (HasCallStack, Monoid an, Data a, Data b, MonadIO m, Typeable an)
  => LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an b)
addAllAnnsT a b = do
  -- AZ: to start with, just transfer the entry DP from a to b
  transferEntryDP a b


-- addAllAnnsT
--   :: (HasCallStack, Data a, Data b, Monad m)
--   => Located a -> Located b -> TransformT m ()
-- addAllAnnsT a b = modifyAnnsT (addAllAnns a b)

-- addAllAnns :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
-- addAllAnns a b anns =
--   fromMaybe
--     (error $ "addAllAnns: lookup failed: " ++ show (mkAnnKey a)
--       ++ " or " ++ show (mkAnnKey b))
--     $ do ann <- M.lookup (mkAnnKey a) anns
--          case M.lookup (mkAnnKey b) anns of
--            Just ann' -> return $ M.insert (mkAnnKey b) (ann `annAdd` ann') anns
--            Nothing -> return $ M.insert (mkAnnKey b) ann anns
--   where annAdd ann ann' = ann'
--           { annEntryDelta = annEntryDelta ann
--           , annPriorComments = ((++) `on` annPriorComments) ann ann'
--           , annFollowingComments = ((++) `on` annFollowingComments) ann ann'
--           , annsDP = ((++) `on` annsDP) ann ann'
--           }

transferAnchor :: LocatedA a -> LocatedA b -> LocatedA b
transferAnchor (L (SrcSpanAnn EpAnnNotUsed l)    _) lb = setAnchorAn lb (spanAsAnchor l) emptyComments
transferAnchor (L (SrcSpanAnn (EpAnn anc _ _) _) _) lb = setAnchorAn lb anc              emptyComments


isComma :: TrailingAnn -> Bool
isComma (AddCommaAnn _) = True
isComma _ = False

isCommentKeyword :: AnnKeywordId -> Bool
-- isCommentKeyword (AnnComment _) = True
isCommentKeyword _ = False

-- isCommentAnnotation :: Annotation -> Bool
-- isCommentAnnotation Ann{..} =
--   (not . null $ annPriorComments)
--   || (not . null $ annFollowingComments)
--   || any (isCommentKeyword . fst) annsDP

hasComments :: LocatedAn an a -> Bool
hasComments (L (SrcSpanAnn EpAnnNotUsed _) _) = False
hasComments (L (SrcSpanAnn (EpAnn anc _ cs) _) _)
  = case cs of
      EpaComments [] -> False
      EpaCommentsBalanced [] [] -> False
      _ -> True

-- hasComments :: (Data a, Monad m) => Located a -> TransformT m Bool
-- hasComments e = do
--   anns <- getAnnsT
--   let b = isCommentAnnotation <$> M.lookup (mkAnnKey e) anns
--   return $ fromMaybe False b

-- transferAnnsT
--   :: (Data a, Data b, Monad m)
--   => (KeywordId -> Bool)        -- transfer Anns matching predicate
--   -> Located a                  -- from
--   -> Located b                  -- to
--   -> TransformT m ()
-- transferAnnsT p a b = modifyAnnsT f
--   where
--     bKey = mkAnnKey b
--     f anns = fromMaybe anns $ do
--       anA <- M.lookup (mkAnnKey a) anns
--       anB <- M.lookup bKey anns
--       let anB' = anB { annsDP = annsDP anB ++ filter (p . fst) (annsDP anA) }
--       return $ M.insert bKey anB' anns

transferAnnsT
  :: (Data a, Data b, Monad m)
  => (TrailingAnn -> Bool)      -- transfer Anns matching predicate
  -> LocatedA a                 -- from
  -> LocatedA b                 -- to
  -> TransformT m (LocatedA b)
transferAnnsT p (L (SrcSpanAnn EpAnnNotUsed _) _) b = return b
transferAnnsT p (L (SrcSpanAnn (EpAnn anc (AnnListItem ts) cs) l) a) (L (SrcSpanAnn an lb) b) = do
  let ps = filter p ts
  let an' = case an of
        EpAnnNotUsed -> EpAnn (spanAsAnchor lb) (AnnListItem ps) emptyComments
        EpAnn ancb (AnnListItem tsb) csb -> EpAnn ancb (AnnListItem (tsb++ps)) csb
  return (L (SrcSpanAnn an' lb) b)


-- -- | 'Transform' monad version of 'setEntryDP',
-- --   which sets the entry 'DeltaPos' for an annotation.
-- setEntryDPT
--   :: (Data a, Monad m)
--   => Located a -> DeltaPos -> TransformT m ()
-- setEntryDPT ast dp = do
--   modifyAnnsT (setEntryDP ast dp)

-- -- | Set the true entry 'DeltaPos' from the annotation of a
-- --   given AST element.
-- setEntryDP :: Data a => Located a -> DeltaPos -> Anns -> Anns
-- --  The setEntryDP that comes with exactprint does some really confusing
-- --  entry math around comments that I'm unconvinced is either correct or useful.
-- setEntryDP x dp anns = M.alter (Just . f . fromMaybe annNone) k anns
--   where
--     k = mkAnnKey x
--     f ann = case annPriorComments ann of
--               []       -> ann { annEntryDelta = dp }
--               (c,_):cs -> ann { annPriorComments = (c,dp):cs }

-- Useful for figuring out what annotations should be on something.
-- If you don't care about fixities, pass 'mempty' as the FixityEnv.
-- String should be the entire module contents.
debugParse :: Parsers.LibDir -> FixityEnv -> String -> IO ()
debugParse libdir fixityEnv s = do
  writeFile "debug.txt" s
  r <- parseModule libdir "debug.txt"
  case r of
    Left _ -> putStrLn "parse failed"
    Right modl -> do
      let m = unsafeMkA (makeDeltaAst modl) 0
      putStrLn "parseModule"
      debugDump m
      void $ transformDebug m
  where
    transformDebug =
      run "fixOneExpr D.def" (fixOneExpr fixityEnv)
        >=> run "fixOnePat D.def" (fixOnePat fixityEnv)
        >=> run "fixOneEntryExpr" fixOneEntryExpr
        >=> run "fixOneEntryPat" fixOneEntryPat

    run wat f m = do
      putStrLn wat
      m' <- transformA m (everywhereM (mkM f))
      debugDump m'
      return m'