2

I want to collect EpAnns from a Located HsModule. (Docs: Located and HsModule) EpAnn has a kind * -> *, but I do not care which type an EpAnn contains. I want pairs of EpAnns' entrys and commentss.

I have a haskell-playground.cabal. GHC's version is 9.2.2.

cabal-version:      2.4
name:               haskell-playground
version:            0.1.0.0

executable haskell-playground
    main-is:          Main.hs
    build-depends:    base == 4.16.1.0
                    , ghc-lib-parser == 9.2.2.20220307
                    , ghc-lib-parser-ex == 9.2.1.0
                    , syb == 0.7.2.1
    ghc-options:      -Wall
    hs-source-dirs:   app
    default-language: Haskell2010

Firstly, I tried to collect EpAnn AnnListItems. (Doc: AnnListItem) The following code is app/Main.hs.

module Main
  ( main
  ) where

import           Generics.SYB                                        hiding
                                                                     (empty)
import           GHC.Data.EnumSet
import           GHC.Data.FastString
import           GHC.Data.StringBuffer
import           GHC.Driver.Ppr
import           GHC.Driver.Session
import           GHC.Hs
import           GHC.Parser
import           GHC.Parser.Lexer
import           GHC.Stack
import           GHC.Types.SrcLoc
import           GHC.Utils.Outputable                                hiding
                                                                     (empty)
import           Language.Haskell.GhclibParserEx.GHC.Settings.Config

main :: IO ()
main = do
  src <- readFile filename
  let m = unwrapParseResult $ runParser parserOpts src parseModule
  printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m

runParser :: ParserOpts -> String -> P a -> ParseResult a
runParser opts str parser = unP parser parserState
  where
    parserState = initParserState opts b location
    b = stringToStringBuffer str
    location = mkRealSrcLoc (mkFastString filename) 1 1

unwrapParseResult :: HasCallStack => ParseResult a -> a
unwrapParseResult (POk _ m)  = m
unwrapParseResult PFailed {} = error "Parse failed."

isUsedEpAnn :: EpAnn a -> Bool
isUsedEpAnn EpAnn {}        = True
isUsedEpAnn EpAnnNotUsed {} = False

printOutputable :: Outputable a => a -> IO ()
printOutputable = putStrLn . showOutputable

showOutputable :: Outputable a => a -> String
showOutputable = showPpr dynFlags

parserOpts :: ParserOpts
parserOpts = mkParserOpts empty empty False True True True

dynFlags :: DynFlags
dynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

collectEpAnns :: EpAnn AnnListItem -> Bool
collectEpAnns = const True

filename :: FilePath
filename = "app/Main.hs"

It works.

Next, I replaced EpAnn AnnListItem with EpAnn a.

collectEpAnns :: EpAnn a -> Bool
collectEpAnns = const True

It fails to compile.

Build profile: -w ghc-9.2.2 -O1
In order, the following will be built (use -v for more details):
 - haskell-playground-0.1.0.0 (exe:haskell-playground) (file app/Main.hs changed)
Preprocessing executable 'haskell-playground' for haskell-playground-0.1.0.0..
Building executable 'haskell-playground' for haskell-playground-0.1.0.0..
[1 of 1] Compiling Main             ( app/Main.hs, /home/hiroki/git_repository/haskell_playground/dist-newstyle/build/x86_64-linux/ghc-9.2.2/haskell-playground-0.1.0.0/x/haskell-playground/build/haskell-playground/haskell-playground-tmp/Main.o )

app/Main.hs:25:3: error:
    • Ambiguous type variable ‘a0’ arising from a use of ‘printOutputable’
      prevents the constraint ‘(Outputable a0)’ from being solved.
      Probable fix: use a type annotation to specify what ‘a0’ should be.
      These potential instances exist:
        instance (Outputable a, Outputable b) => Outputable (Either a b)
          -- Defined in ‘GHC.Utils.Outputable’
        instance Outputable FastString -- Defined in ‘GHC.Utils.Outputable’
        instance Outputable LexicalFastString
          -- Defined in ‘GHC.Utils.Outputable’
        ...plus 153 others
        ...plus 31 instances involving out-of-scope types
        (use -fprint-potential-instances to see them all)
    • In the first argument of ‘($)’, namely ‘printOutputable’
      In a stmt of a 'do' block:
        printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
      In the expression:
        do src <- readFile filename
           let m = unwrapParseResult $ runParser parserOpts src parseModule
           printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |
25 |   printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |   ^^^^^^^^^^^^^^^

app/Main.hs:25:42: error:
    • No instance for (Typeable a0) arising from a use of ‘listify’
    • In the second argument of ‘($)’, namely ‘listify collectEpAnns m’
      In the second argument of ‘($)’, namely
        ‘filter isUsedEpAnn $ listify collectEpAnns m’
      In a stmt of a 'do' block:
        printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |
25 |   printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |                                          ^^^^^^^

Since EpAnn a implements Data and Outputable if and only if a implements Data and Outputable respectively, and Data implies Typeable, I added the Data and Outputable boundaries.

collectEpAnns :: (Data a, Outputable a) => EpAnn a -> Bool
collectEpAnns = const True

However, it also fails to compile.

Build profile: -w ghc-9.2.2 -O1
In order, the following will be built (use -v for more details):
 - haskell-playground-0.1.0.0 (exe:haskell-playground) (file app/Main.hs changed)
Preprocessing executable 'haskell-playground' for haskell-playground-0.1.0.0..
Building executable 'haskell-playground' for haskell-playground-0.1.0.0..
[1 of 1] Compiling Main             ( app/Main.hs, /home/hiroki/git_repository/haskell_playground/dist-newstyle/build/x86_64-linux/ghc-9.2.2/haskell-playground-0.1.0.0/x/haskell-playground/build/haskell-playground/haskell-playground-tmp/Main.o )

app/Main.hs:25:3: error:
    • Ambiguous type variable ‘a0’ arising from a use of ‘printOutputable’
      prevents the constraint ‘(Outputable a0)’ from being solved.
      Probable fix: use a type annotation to specify what ‘a0’ should be.
      These potential instances exist:
        instance (Outputable a, Outputable b) => Outputable (Either a b)
          -- Defined in ‘GHC.Utils.Outputable’
        instance Outputable FastString -- Defined in ‘GHC.Utils.Outputable’
        instance Outputable LexicalFastString
          -- Defined in ‘GHC.Utils.Outputable’
        ...plus 153 others
        ...plus 31 instances involving out-of-scope types
        (use -fprint-potential-instances to see them all)
    • In the first argument of ‘($)’, namely ‘printOutputable’
      In a stmt of a 'do' block:
        printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
      In the expression:
        do src <- readFile filename
           let m = unwrapParseResult $ runParser parserOpts src parseModule
           printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |
25 |   printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |   ^^^^^^^^^^^^^^^

app/Main.hs:25:42: error:
    • No instance for (Typeable a0) arising from a use of ‘listify’
    • In the second argument of ‘($)’, namely ‘listify collectEpAnns m’
      In the second argument of ‘($)’, namely
        ‘filter isUsedEpAnn $ listify collectEpAnns m’
      In a stmt of a 'do' block:
        printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |
25 |   printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |                                          ^^^^^^^

app/Main.hs:25:50: error:
    • Ambiguous type variable ‘a0’ arising from a use of ‘collectEpAnns’
      prevents the constraint ‘(Data a0)’ from being solved.
      Probable fix: use a type annotation to specify what ‘a0’ should be.
      These potential instances exist:
        instance Data DataType -- Defined in ‘Data.Generics.Instances’
        instance (Data a, Data b) => Data (Either a b)
          -- Defined in ‘Data.Data’
        instance forall i j (a :: i) (b :: j).
                 (Typeable i, Typeable j, Typeable a, Typeable b, a ~~ b) =>
                 Data (a :~~: b)
          -- Defined in ‘Data.Data’
        ...plus 390 others
        ...plus 72 instances involving out-of-scope types
        (use -fprint-potential-instances to see them all)
    • In the first argument of ‘listify’, namely ‘collectEpAnns’
      In the second argument of ‘($)’, namely ‘listify collectEpAnns m’
      In the second argument of ‘($)’, namely
        ‘filter isUsedEpAnn $ listify collectEpAnns m’
   |
25 |   printOutputable $ filter isUsedEpAnn $ listify collectEpAnns m
   |                                                  ^^^^^^^^^^^^^

I noticed that the signature of listify is

listify :: Typeable r => (r -> Bool) -> GenericQ [r]

It says that r is fixed. In other words, All as of the EpAnn as in the list must be the same. However, I do not care whatever the a is. Thus, I defined a new wrapper type.

{-# LANGUAGE RankNTypes #-}

newtype EpAnnWrapper =
  EpAnnWrapper
    { unwrap :: forall a. Outputable a =>
                            EpAnn a
    }

listify' :: Data a => a -> [EpAnnWrapper]
listify' = everything (++) ([] `mkQ` (\x -> [EpAnnWrapper x | p x]))
  where
    p :: Outputable a => EpAnn a -> Bool
    p = const True

main :: IO ()
main = do
  src <- readFile filename
  let m = unwrapParseResult $ runParser parserOpts src parseModule
  printOutputable $ filter isUsedEpAnn $ unwrap <$> listify' m

But I could not compile it, and I am at a loss.

Build profile: -w ghc-9.2.2 -O1
In order, the following will be built (use -v for more details):
 - haskell-playground-0.1.0.0 (exe:haskell-playground) (file app/Main.hs changed)
Preprocessing executable 'haskell-playground' for haskell-playground-0.1.0.0..
Building executable 'haskell-playground' for haskell-playground-0.1.0.0..
[1 of 1] Compiling Main             ( app/Main.hs, /home/hiroki/git_repository/haskell_playground/dist-newstyle/build/x86_64-linux/ghc-9.2.2/haskell-playground-0.1.0.0/x/haskell-playground/build/haskell-playground/haskell-playground-tmp/Main.o )

app/Main.hs:30:59: error:
    • Couldn't match type ‘a1’ with ‘a3’
      Expected: EpAnn a3
        Actual: EpAnn a1
        because type variable ‘a3’ would escape its scope
      This (rigid, skolem) type variable is bound by
        a type expected by the context:
          forall a3. Outputable a3 => EpAnn a3
        at app/Main.hs:30:59
    • In the first argument of ‘EpAnnWrapper’, namely ‘x’
      In the expression: EpAnnWrapper x
      In the expression: [EpAnnWrapper x | p x]
    • Relevant bindings include
        x :: EpAnn a1 (bound at app/Main.hs:30:40)
   |
30 | listify' = everything (++) ([] `mkQ` (\x -> [EpAnnWrapper x | p x]))
   |                                                           ^

app/Main.hs:39:42: error:
    • Couldn't match type: forall a. Outputable a => EpAnn a
                     with: EpAnn a0
      Expected: EpAnnWrapper -> EpAnn a0
        Actual: EpAnnWrapper -> forall a. Outputable a => EpAnn a
    • In the first argument of ‘(<$>)’, namely ‘unwrap’
      In the second argument of ‘($)’, namely ‘unwrap <$> listify' m’
      In the second argument of ‘($)’, namely
        ‘filter isUsedEpAnn $ unwrap <$> listify' m’
   |
39 |   printOutputable $ filter isUsedEpAnn $ unwrap <$> listify' m
   |                                          ^^^^^^

Is it possible to collect all EpAnns or pairs of EpAnns' entrys and commentss from a Located HsModule? If it is possible, how to do it?

While I am using syb here, I can use any library to solve the problem.

toku-sa-n
  • 798
  • 1
  • 8
  • 27

1 Answers1

0

With the help of this answer, I solved the question. Instead of using listify which uses cast indirectly, I defined collectEpAnns which checks if the type of a value is b c and if b == EpAnn.

Full code:

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Main
  ( main,
  )
where

import GHC.Data.EnumSet
import GHC.Data.FastString
import GHC.Data.StringBuffer
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Hs
import GHC.Parser
import GHC.Parser.Lexer
import GHC.Stack
import GHC.Types.SrcLoc
import GHC.Utils.Outputable hiding
  ( empty,
  )
import Generics.SYB hiding
  ( empty,
    typeRep,
  )
import Language.Haskell.GhclibParserEx.GHC.Settings.Config
import Type.Reflection

main :: IO ()
main = do
  src <- readFile filename
  let m = unwrapParseResult $ runParser parserOpts src parseModule
  printOutputable $ collectEpAnns $ unLoc m

collectEpAnns :: HsModule -> [(Anchor, EpAnnComments)]
collectEpAnns = everything (++) extractAnchorAndComments
  where
    extractAnchorAndComments :: forall a. Data a => a -> [(Anchor, EpAnnComments)]
    extractAnchorAndComments x =
      case typeRep @a of -- Is 'a' a type of 'b c' format?
        App g _ ->
          case eqTypeRep g (typeRep @EpAnn) of -- 'b' == 'EpAnn'?
            Just HRefl -> case x of
              (EpAnn anc _ cs) -> [(anc, cs)]
              EpAnnNotUsed -> []
            Nothing -> []
        _ -> []

runParser :: ParserOpts -> String -> P a -> ParseResult a
runParser opts str parser = unP parser parserState
  where
    parserState = initParserState opts b location
    b = stringToStringBuffer str
    location = mkRealSrcLoc (mkFastString filename) 1 1

unwrapParseResult :: HasCallStack => ParseResult a -> a
unwrapParseResult (POk _ m) = m
unwrapParseResult PFailed {} = error "Parse failed."

printOutputable :: Outputable a => a -> IO ()
printOutputable = putStrLn . showOutputable

showOutputable :: Outputable a => a -> String
showOutputable = showPpr dynFlags

parserOpts :: ParserOpts
parserOpts = mkParserOpts empty empty False True True True

dynFlags :: DynFlags
dynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

filename :: FilePath
filename = "app/Main.hs"

The first a few lines of the output:

[(Anchor app\Main.hs:1:1 UnchangedAnchor,
  EpaCommentsBalanced [L Anchor app\Main.hs:4:1-33 UnchangedAnchor EpaComment {ac_tok = EpaBlockComment "{-# LANGUAGE TypeApplications #-}", ac_prior_tok = SrcSpanOneLine "app/Main.hs" 3 1 37},
                       L Anchor app\Main.hs:3:1-36 UnchangedAnchor EpaComment {ac_tok = EpaBlockComment "{-# LANGUAGE ScopedTypeVariables #-}", ac_prior_tok = SrcSpanOneLine "app/Main.hs" 2 1 23},
                       L Anchor app\Main.hs:2:1-22 UnchangedAnchor EpaComment {ac_tok = EpaBlockComment "{-# LANGUAGE GADTs #-}", ac_prior_tok = SrcSpanOneLine "app/Main.hs" 1 1 
43},
                       L Anchor app\Main.hs:1:1-42 UnchangedAnchor EpaComment {ac_tok = EpaBlockComment "{-# LANGUAGE ExistentialQuantification #-}", ac_prior_tok = SrcSpanPoint 
"app/Main.hs" 1 1}] [L Anchor app\Main.hs:75:25 UnchangedAnchor EpaComment {ac_tok = EpaEofComment, ac_prior_tok = SrcSpanOneLine "app/Main.hs" 75 10 11}]),
 (Anchor app\Main.hs:(7,3)-(8,3) UnchangedAnchor, EpaComments []),
 (Anchor app\Main.hs:7:5-8 UnchangedAnchor, EpaComments []),
 (Anchor app\Main.hs:11:1-6 UnchangedAnchor, EpaComments []),
...
toku-sa-n
  • 798
  • 1
  • 8
  • 27