refactoring on convert.

This commit is contained in:
Kazu Yamamoto 2012-02-14 11:33:27 +09:00
parent 86d5419309
commit 1e1b729e15
3 changed files with 53 additions and 27 deletions

35
Info.hs
View File

@ -7,6 +7,7 @@ import Control.Applicative hiding (empty)
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import CoreUtils import CoreUtils
import Data.Function
import Data.Generics as G import Data.Generics as G
import Data.List import Data.List
import Data.Maybe import Data.Maybe
@ -42,10 +43,7 @@ info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo
---------------------------------------------------------------- ----------------------------------------------------------------
typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String
typeExpr opt modstr lineNo colNo file = addNewline (outputStyle opt) <$> Info.typeOf opt file modstr lineNo colNo typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo
where
addNewline LispStyle = (++ "\n")
addNewline PlainStyle = id
typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType
@ -56,29 +54,26 @@ typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr ex
tcm <- typecheckModule p tcm <- typecheckModule p
es <- liftIO $ findExpr tcm lineNo colNo es <- liftIO $ findExpr tcm lineNo colNo
ts <- catMaybes <$> mapM (getType tcm) es ts <- catMaybes <$> mapM (getType tcm) es
return $ format (outputStyle opt) $ sortBy (\a b -> fst a `cmp` fst b) ts let sss = map toTup $ sortBy (cmp `on` fst) ts
return $ convert opt sss
format :: OutputStyle -> [(SrcSpan, Type)] -> String toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
format LispStyle = tolisp . map (\(loc, e) -> "(" ++ l loc ++ " " ++ show (pretty e) ++ ")") toTup (spn, typ) = (l spn, pretty typ)
format PlainStyle = unlines . map (\(loc, e) -> l loc ++ " " ++ pretty e)
l :: SrcSpan -> String l :: SrcSpan -> (Int,Int,Int,Int)
#if __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 702
l (RealSrcSpan spn) l (RealSrcSpan spn)
#else #else
l spn | isGoodSrcSpan spn l spn | isGoodSrcSpan spn
#endif #endif
= unwords . map show $ = (srcSpanStartLine spn, srcSpanStartCol spn
[ srcSpanStartLine spn, srcSpanStartCol spn , srcSpanEndLine spn, srcSpanEndCol spn)
, srcSpanEndLine spn, srcSpanEndCol spn ] l _ = (0,0,0,0)
l _ = "0 0 0 0"
cmp a b cmp a b
| a `isSubspanOf` b = O.LT | a `isSubspanOf` b = O.LT
| b `isSubspanOf` a = O.GT | b `isSubspanOf` a = O.GT
| otherwise = O.EQ | otherwise = O.EQ
tolisp ls = "(" ++ unwords ls ++ ")"
findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id] findExpr :: TypecheckedModule -> Int -> Int -> IO [LHsExpr Id]
findExpr tcm line col = do findExpr tcm line col = do
@ -93,7 +88,7 @@ findExpr tcm line col = do
return $ case mret of return $ case mret of
Left (SomeException _) -> G.empty Left (SomeException _) -> G.empty
Right ret -> ret Right ret -> ret
f :: LHsExpr Id -> Bool f :: LHsExpr Id -> Bool
f (L spn _) = spn `spans` (line, col) f (L spn _) = spn `spans` (line, col)
@ -139,9 +134,9 @@ pprInfo pefas (thing, fixity, insts)
$$ show_fixity fixity $$ show_fixity fixity
$$ vcat (map pprInstance insts) $$ vcat (map pprInstance insts)
where where
show_fixity fix show_fixity fx
| fix == defaultFixity = Outputable.empty | fx == defaultFixity = Outputable.empty
| otherwise = ppr fix <+> ppr (getName thing) | otherwise = ppr fx <+> ppr (getName thing)
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleInstances #-}
module Types where module Types where
import Control.Monad import Control.Monad
@ -19,12 +21,41 @@ data Options = Options {
, operators :: Bool , operators :: Bool
} }
convert :: Options -> [String] -> String ----------------------------------------------------------------
convert Options{ outputStyle = LispStyle } ms = "(" ++ unwords quoted ++ ")\n" convert :: ToString a => Options -> a -> String
where convert Options{ outputStyle = LispStyle } = toLisp
quote x = "\"" ++ x ++ "\"" convert Options{ outputStyle = PlainStyle } = toPlain
quoted = map quote ms
convert Options{ outputStyle = PlainStyle } ms = unlines ms class ToString a where
toLisp :: a -> String
toPlain :: a -> String
instance ToString [String] where
toLisp = addNewLine . toSexp True
toPlain = unlines
instance ToString [((Int,Int,Int,Int),String)] where
toLisp = addNewLine . toSexp False . map toS
where
toS x = "(" ++ tupToString x ++ ")"
toPlain = unlines . map tupToString
toSexp :: Bool -> [String] -> String
toSexp False ss = "(" ++ unwords ss ++ ")"
toSexp True ss = "(" ++ unwords (map quote ss) ++ ")"
tupToString :: ((Int,Int,Int,Int),String) -> String
tupToString ((a,b,c,d),s) = show a ++ " "
++ show b ++ " "
++ show c ++ " "
++ show d ++ " "
++ quote s
quote :: String -> String
quote x = "\"" ++ x ++ "\""
addNewLine :: String -> String
addNewLine = (++ "\n")
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -125,7 +125,7 @@
(lambda () (lambda ()
(cd cdir) (cd cdir)
(apply 'call-process ghc-module-command nil t nil (apply 'call-process ghc-module-command nil t nil
`(,@(ghc-make-ghc-options) "type" ,file ,modname ,ln ,cn)) `(,@(ghc-make-ghc-options) "-l" "type" ,file ,modname ,ln ,cn))
(goto-char (point-min)) (goto-char (point-min))
(while (search-forward "[Char]" nil t) (while (search-forward "[Char]" nil t)
(replace-match "String")))))) (replace-match "String"))))))