コメントの削除 in Haskell DouKaku?

ソースコードからコメント部分を削除するプログラム decomment を書いてください．
すくなくとも，decomment を記述したのと同じ言語で書かれているソースコードが
扱えるようにしてください．

α置換の時に使ったパーサーがコメントを読み落としてしまうことを利用しました。もっと単純に文字列のパースでもできるはずですが、既存のソースに手を加えればできるということで…

module Main where

import Language.Haskell.Syntax
import Language.Haskell.Parser
import Language.Haskell.Pretty
import Data.Generics

pp :: ParseResult HsModule -> String
pp (ParseOk hsm) = prettyPrint hsm
pp _ = "parse failed"

main :: IO ()
main 
  = do mod <- getContents
       putStr $ pp $ parseModule mod

おもいっきりベタな実装してみました。もしかすると抜けている部分があるかもしれません…。

decomment :: String -> String
decomment s = decommentNormal s
  where
    decommentNormal         []                      = []
    decommentNormal         ('\'':'"':'\'':cs)      = '\'':'"':'\'':(decommentNormal cs)
    decommentNormal         ('\'':'\\':'"':'\'':cs) = '\'':'\\':'"':'\'':(decommentNormal cs)
    decommentNormal         ('"':cs)                = '"':(decommentQuote cs)
    decommentNormal         ('-':'-':cs)            = decommentCommentLine cs
    decommentNormal         ('{':'-':cs)            = decommentCommentBlock 0 cs
    decommentNormal         (c:cs)                  = c:(decommentNormal cs)
    decommentQuote          ('"':cs)                = '"':(decommentNormal cs)
    decommentQuote          ('\\':'"':cs)           = '\\':'"':(decommentQuote cs)
    decommentQuote          (c:cs)                  = c:(decommentQuote cs)
    decommentCommentLine    ('\n':cs)               = '\n':(decommentNormal cs)
    decommentCommentLine    (_:cs)                  = decommentCommentLine cs
    decommentCommentBlock 0 ('-':'}':cs)            = '\n':(decommentNormal cs)
    decommentCommentBlock n ('-':'}':cs)            = decommentCommentBlock (n-1) cs
    decommentCommentBlock n ('{':'-':cs)            = decommentCommentBlock (n+1) cs
    decommentCommentBlock n (c:cs)                  = decommentCommentBlock n     cs

main = getContents >>= putStrLn.decomment

ちょっと長いけど，Haskell, C, C++ 対応のつもり，

CommentStyleクラスとQuoteStyleクラスを使って，いろいろな言語に対応できるように工夫してみた．

commentLeadings メソッドは一行コメントの開始マーク(複数可)文字列を返すメソッド
commentOpenings メソッドはブロックコメントの開始マーク(複数可)文字列を返すメソッド
commentClosing メソッドは与えられたブロックコメントの開始マークに対応する修了マークを返すメソッド
commentNestable はブロックコメントがネスト可能かどうかを返すメソッド

など．

文字列リテラル
ブロックコメントのネスト

に対応する．厳密にやるには，その言語のパーザを読んで結果の構文木データを，プリティプリンタ(自作することになる)に食わせるのかな．めんどうだけど．．.

{-# LANGUAGE EmptyDataDecls #-}
module Main (main) where

import Control.Arrow
import Data.Char
import Data.List
import Data.Maybe
import System.Environment

main :: IO ()
main = interact . genDecomment . listToMaybe . map (map toLower) =<< getArgs
   
genDecomment :: Maybe String -> String -> String
genDecomment (Just "c")    = decomment cstyle
genDecomment (Just "c++")  = decomment cppstyle
genDecomment _             = decomment hstyle

class CommentStyle c where
  commentLeadings  :: c -> [String]
  commentOpenings  :: c -> [String]
  commentClosing   :: c -> String -> String
  commentNestable  :: c -> Bool

class QuoteStyle q where
  quoteOpenings  :: q -> [Char]
  quoteClosing   :: q -> Char -> Char
  quoteEscape    :: q -> Char

splitWithPrefix :: Eq a => [a] -> [a] -> Maybe ([a],[a])
splitWithPrefix [] xs = Just ([],xs)
splitWithPrefix (p:ps) xxs@(x:xs)
  | p == x     = splitWithPrefix ps xs >>= return . ((x:) *** id)
  | otherwise  = Nothing

splitQuoted :: Eq a => a -> a -> [a] -> ([a], [a])
splitQuoted esc qm []   = ([],[])
splitQuoted esc qm (c:cs)
           | c == qm    = ([],cs)    
           | c == esc   = case cs of 
                            []     -> ([c],[])
                            c':cs' -> ((c:).(c':) *** id) $ splitQuoted esc qm cs'
           | otherwise  = ((c:) *** id) $ splitQuoted esc qm cs

decomment :: (CommentStyle s, QuoteStyle s) => s -> String -> String
decomment s ""         = ""
decomment s ccs@(c:cs) = case mapMaybe (flip splitWithPrefix ccs) $ commentLeadings s of
  (_,xs):_ -> decomment s $ snd $ break ('\n'==) xs
  []       -> case mapMaybe (flip splitWithPrefix ccs) $ commentOpenings s of
                (p,xs):_ -> decommentC s [p] xs
                []       -> if elem c (quoteOpenings s) then c:decommentQ s c cs 
                            else c:decomment s cs

decommentC :: (CommentStyle s, QuoteStyle s) => s -> [String] -> String -> String
decommentC s [] xs = ' ':decomment s xs
decommentC s pps@(p:ps) xxs@(x:xs)
  | commentNestable s  = case splitWithPrefix (commentClosing s p) xxs of
      Just (_,ys) -> decommentC s ps ys
      Nothing     -> case mapMaybe (flip splitWithPrefix xxs) $ commentOpenings s of
                       [] -> decommentC s pps xs
                       (p',yys):_ -> decommentC s (p':pps) yys
  | otherwise   = case mapMaybe (splitWithPrefix (commentClosing s p)) $ tails xs of
      (_,ys):_ -> ' ':decomment s ys
      []       -> ""

decommentQ :: (CommentStyle s, QuoteStyle s) => s -> Char -> String -> String
decommentQ s c xs = case splitQuoted (quoteEscape s) (quoteClosing s c) xs of
                      (ys,zs) -> ys ++ '"':decomment s zs

data Haskell

hstyle :: Haskell
hstyle = undefined

instance CommentStyle Haskell where
  commentLeadings = const ["--"]
  commentOpenings = const ["{-"]
  commentClosing  = const (\ "{-" -> "-}")
  commentNestable = const True

instance QuoteStyle Haskell where
  quoteOpenings = const ['"']
  quoteClosing  = const (\ '"' -> '"')
  quoteEscape   = const '\\'

data C

cstyle :: C
cstyle = undefined

instance CommentStyle C where
  commentLeadings = const []
  commentOpenings = const ["/*"]
  commentClosing  = const (\ "/*" -> "*/")
  commentNestable = const False

instance QuoteStyle C where
  quoteOpenings = const ['"']
  quoteClosing  = const (\ '"' -> '"')
  quoteEscape   = const '\\'

data CPlusPlus

cppstyle :: CPlusPlus
cppstyle = undefined

instance Show CPlusPlus where
  show = const "C++"

instance CommentStyle CPlusPlus where
  commentLeadings = const ["//"]
  commentOpenings = const ["/*"]
  commentClosing  = const (\ "/*" -> "*/")
  commentNestable = const False

instance QuoteStyle CPlusPlus where
  quoteOpenings = const ['"']
  quoteClosing  = const (\ '"' -> '"')
  quoteEscape   = const '\\'

ここまでParsecなし、と

module Main where                                                                                                            

import Text.ParserCombinators.Parsec

decommentParser :: CharParser st String
decommentParser = try (eof >> return "") <|> do
    c <- anyChar
    case c of
      '{' -> anyChar >>= f skips1 c
      '-' -> anyChar >>= f (manyTill (noneOf "\n") (char '\n')) c
      _   -> decommentParser >>= return . ((:) c)
  where skips1 = do
            c <- anyChar
            case c of
              '-' -> anyChar >>= \x -> if x == '}' then return "" else skips1
              _   -> skips1
        f g c x = if x == '-' then g >> decommentParser
                              else decommentParser >>= \xs -> return $ c:x:xs

decomment content = parse decommentParser "decomment" content  

main = do
    content <- readFile "test.hs"
    case decomment content  of  
      Left e  -> print e
      Right s -> mapM_ putStrLn $ lines s

DouKaku?

コメントの削除

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq