将模块恢复为记录

Question

Suppose I have an arbitrary module

module Foo where
foo :: Moo -> Goo
bar :: Car -> Far
baz :: Can -> Haz

where foo , bar , and baz are correctly implemented, etc.

I'd like to reify this module into an automatically-generated data type and corresponding object:

import Foo (Moo, Goo, Car, Far, Can, Haz)
import qualified Foo

data FooModule = Foo
  { foo :: Moo -> Goo
  , bar :: Car -> Far
  , baz :: Can -> Haz
  }

_Foo_ = Foo
  { foo = Foo.foo
  , bar = Foo.bar
  , baz = Foo.baz
  }

Names must be precisely the same as the original module.

I could do this by hand, but that is very tedious, so I'd like to write some code to perform this task for me.

I'm not really sure how to approach such a task. Does Template Haskell provide a way to inspect modules? Should I hook into some GHC api? Or am I just as well off with a more ad-hoc approach such as scraping haddock pages?

Answer 1

(This is for GHC-7.4.2; it probably won't compile with HEAD or 7.6 because of some changes in Outputable ). I didn't find anything to inspect modules in TH.

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS -Wall #-}
import GHC
import GHC.Paths -- ghc-paths package
import Outputable
import GhcMonad

main :: IO ()
main = runGhc (Just libdir) $ goModule "Data.Map"

goModule :: GhcMonad m => String -> m ()
goModule modStr = do
  df <- getSessionDynFlags
  _ <- setSessionDynFlags df  
  -- ^ Don't know if this is the correct way, but it works for this purpose

  setContext [IIDecl (simpleImportDecl (mkModuleName modStr))]
  infos <- mapM getInfo =<< getNamesInScope 
  let ids = onlyIDs infos
  liftIO . putStrLn . showSDoc . render $ ids 

onlyIDs :: [Maybe (TyThing, Fixity, [Instance])] -> [Id]
onlyIDs infos = [ i | Just (AnId i, _, _) <- infos ] 

render :: [Id] -> SDoc
render ids = mkFields ids $$ text "------------" $$ mkInits ids 

mkFields :: [Id] -> SDoc
mkFields = vcat . map (\i ->
  text "," <+> pprUnqual i <+> text "::" <+> ppr (idType i))

mkInits :: [Id] -> SDoc
mkInits = vcat . map (\i ->
  text "," <+> pprUnqual i <+> text "=" <+> ppr i)


-- * Helpers

withUnqual :: SDoc -> SDoc
withUnqual  = withPprStyle (mkUserStyle neverQualify AllTheWay)

pprUnqual :: Outputable a => a -> SDoc
pprUnqual = withUnqual . ppr