GhcParser.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Boilerplate.GhcParser (parseHaskell) where

import Boilerplate.Types
import Control.Exception (throwIO)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.List (isSuffixOf)
import Data.List (sortOn)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import DriverPipeline (preprocess)
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified GHC as GHC
import GHC.Paths (libdir)
import qualified HeaderInfo as GHC
import qualified HsInspect.Util as H
import qualified Lexer as GHC
import qualified Outputable as GHC
import qualified Parser
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
import System.Directory (removeFile)

-- FIXME move to hsinspect and share as a library
--
--and then a single boilerplate binary
--      could call out to a package-specific hsinspect? Would centralise all the
--      ghc logic at the expense of a more complex setup. Perhaps make hsinspect
--      available as a library to simplify this process, since this information
--      would be useful for all kinds of tools (e.g. documentation generation).
parseHaskell :: FilePath -> IO ([Type], [Comment])
parseHaskell file = do
  -- TODO construct the real session from .ghc.flags, or use a hardcoded ParserFlags
  env <- liftIO . GHC.runGhc (Just libdir) $ do
    dflags <- GHC.getSessionDynFlags
    -- enablesx comment parsing
    _ <- GHC.setSessionDynFlags $ GHC.gopt_set dflags GHC.Opt_KeepRawTokenStream
    GHC.getSession
  pstate <- mkCppState env file
  let showGhc :: GHC.Outputable a => a -> Text
      showGhc = T.pack . H.showGhc
  case GHC.unP Parser.parseModule pstate of
    -- ParseResult (Located (HsModule GhcPs))
    GHC.POk st (GHC.L _ hsmod) -> do
      -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:HsDecl
      -- [Located (HsDecl p)]
      let decls = GHC.hsmodDecls hsmod
          findType (GHC.L _ (GHC.TyClD _ (GHC.DataDecl _ tycon' (GHC.HsQTvs _ tparams') _ ddn))) =
            let
              tycon = showGhc tycon'
              tparams = renderTparam <$> tparams'
              renderField :: GHC.GenLocated l (GHC.ConDeclField GHC.GhcPs) -> (Text, Text)
              renderField (GHC.L _ field) = (showGhc . head $ GHC.cd_fld_names field, showGhc $ GHC.cd_fld_type field)
              renderArg :: GHC.LBangType GHC.GhcPs -> Text
              renderArg (GHC.L _ arg) = showGhc arg
              rhs = do
                (GHC.L _ ddl) <- GHC.dd_cons ddn
                case ddl of
                  GHC.ConDeclH98 _ cons _ _ _ (GHC.RecCon (GHC.L _ fields)) _ -> [(showGhc cons, Left $ renderField <$> fields)]
                  GHC.ConDeclH98 _ cons _ _ _ (GHC.InfixCon a1 a2) _ -> [(showGhc cons, Right $ [renderArg a1, renderArg a2])]
                  GHC.ConDeclH98 _ cons _ _ _ (GHC.PrefixCon args) _ -> [(showGhc cons, Right $ renderArg <$> args)]
                  _ -> [] -- GADTS

             in case rhs of
              [] -> Nothing
              [(cons, Right tpes)] -> Just $ ProductType tycon tparams cons tpes
              [(cons, Left fields)] -> Just $ RecordType tycon tparams cons fields
              mult -> Just . SumType tycon tparams $ render <$> mult
                where
                  render (cons, Right args) = (cons, args)
                  render (cons, Left fargs) = (cons, snd <$> fargs)

          findType _ = Nothing

          renderTparam :: GHC.GenLocated l (GHC.HsTyVarBndr GHC.GhcPs) -> Text
          renderTparam (GHC.L _ (GHC.UserTyVar _ p)) = showGhc p
          renderTparam (GHC.L _ (GHC.KindedTyVar _ p _)) = showGhc p
          renderTparam (GHC.L _ (GHC.XTyVarBndr _)) = "<unsupported>"

          extractComment (GHC.L (GHC.RealSrcSpan pos) c) =
            let start = Pos (GHC.srcSpanStartLine pos) (GHC.srcSpanStartCol pos)
                end = Pos (GHC.srcSpanEndLine pos) (GHC.srcSpanEndCol pos)
             in (\str -> Comment (T.pack str) start end) <$> case c of
            (GHC.AnnLineComment txt) -> Just txt
            (GHC.AnnBlockComment txt) -> Just txt
            _ -> Nothing
          extractComment _ = Nothing

          types = mapMaybe findType decls
          comments = mapMaybe extractComment $ GHC.comment_q st

      pure (types, sortOn (\(Comment _ s _) -> s) comments)

    GHC.PFailed _ _ err -> throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe err

-- from hsinspect, share with parseHeader'

-- applies CPP rules to the input file and extracts the pragmas,
-- a more portable alternative to GHC.hGetStringBuffer
mkCppState :: GHC.HscEnv -> FilePath -> IO GHC.PState
mkCppState sess file = do
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
  pp <- preprocess sess file Nothing Nothing
  let (dflags, tmp) = case pp of
        Left _ -> error $ "preprocessing failed " <> show file
        Right success -> success
#else
  (dflags, tmp) <- preprocess sess (file, Nothing)
#endif
  full <- GHC.hGetStringBuffer tmp
  when (".hscpp" `isSuffixOf` tmp) $
    liftIO . removeFile $ tmp
  let pragmas = GHC.getOptions dflags full file
      loc  = GHC.mkRealSrcLoc (GHC.mkFastString file) 1 1
  (dflags', _, _) <- GHC.parseDynamicFilePragma dflags pragmas
  pure $ GHC.mkPState dflags' full loc