hint 使って型推論、 haskell-src-exts を使って Parse

GHC API のラッパー hint を使えばHaskellでも手軽にリフレクションっぽいことができる。例えば動的にHaskellのソースをロードして関数を呼び出す、といったことが数行で書ける。
ところでリフレクション周りで色々やろうとすると、すぐに関数の型を解析したくなるのだけど、hint は型推論の結果を文字列で返すのでHaskell的には使いにくい。情けない話だが、どうやら GHC APIがそうなっているので仕方ないようだ。Haskellのパーサが必要になる。
haskell-src-exts を使えば、Haskellの型をparse できる。
似たようなことをやる方法に template haskellとか haskell-src という標準のアレがあるけれど、いくつかの拡張構文をサポートしていない。その点 haskell-src-exts はほぼすべての GHC拡張をサポートしている。
というわけで、hint と haskell-src-exts を組み合わせて型を解析する前段階までを作ってみた。
ちょっとした目的にはややオーバーキルだけど、まあしょうがない。

必要なライブラリ

hint と haskell-src-exts どちらも Hackageにある。

cabal install hint
cabel install haskell-src-exts

使い方

Haskellのモジュールと関数名を指定すると、関数の型を推論して表示してくれる。(ついでに haskell-src-exts でパースした結果も出す。)

Impricit Parameters を使った関数の型も出せる。

$ cat IParamExample.hs 
{-# LANGUAGE ImplicitParams, NoMonomorphismRestriction #-}

module IParamExample where

test = ?a ++ ?b

$ ./Main IParamExample test
Right ("(?b::[a], ?a::[a]) => [a]",TyForall Nothing [IParam (IPDup "b") (TyList (TyVar (Ident "a"))),IParam (IPDup "a") (TyList (TyVar (Ident "a")))] (TyList (TyVar (Ident "a"))))

ソース

module Main where

import Control.Monad.Trans (liftIO)
import Control.Monad.Error (throwError)
import Data.Maybe
import Data.List

-- from hint
import qualified Language.Haskell.Interpreter as H
import Language.Haskell.Interpreter.Unsafe

-- from haskell-src-exts
import qualified Language.Haskell.Exts.Syntax as S
import qualified Language.Haskell.Exts.Parser as P
import qualified Language.Haskell.Exts.Extension as E

import System.Environment

-- 他の環境で動かす時はここを変える
confs = ["/opt/local/lib/ghc-6.10.4/package.conf", "/Users/keigoi/.ghc/i386-darwin-6.10.4/package.conf"]

main = do
  [mod,func] <- getArgs
  res <- H.runInterpreter $ infer mod func
  print res


infer mod func = do
    myLoadModule mod
    typstr_ <- H.typeOf func
    let typstr = concat $ lines typstr_ -- 改行を除く
    typ <- extTypeOf func
    return (typstr, typ)

say :: String -> H.Interpreter ()
say = liftIO . putStrLn

myLoadModule :: String -> H.Interpreter ()
myLoadModule mod = do
  H.reset
  unsafeSetGhcOption ("-i"++concat (intersperse ":" confs))
  H.set [H.languageExtensions H.:= [H.ImplicitParams]]
  H.set [H.installedModulesInScope H.:= True]
  H.loadModules $ [mod++".hs"]
  H.setTopLevelModules [mod]
  H.setImportsQ [("Prelude", Nothing)]


extTypeOf :: String -> H.Interpreter S.Type
extTypeOf func = do
  t_str <- H.typeOf func
  case str2ExtType t_str of Right typ -> return typ
                            Left msg -> throwError (H.UnknownError msg)


str2ExtType typ = 
  let mod_str = unlines ["f ::" ++typ, "f = undefined"]
      mode = P.ParseMode "n/a" [E.ImplicitParams] False False [] in
  case P.parseModuleWithMode mode mod_str of
    P.ParseOk (S.Module  _ _ _ _ _ _ (S.TypeSig _ _ qualType:_)) -> Right qualType
    P.ParseFailed _ msg -> Left msg