由于感冒的原因，下午头疼的要命，什么也不想干。所以就找了一段代码娱乐一下。没敢找大的，找了一个相对独立的很小的一段。
CmdLineParser.hs是ghc/compiler/main/下的一个小文件。
-----------------------------------------------------------------------------
-- 命令行参数分析器
-- 该命令行分析器可以用于StaticFlags以及DynFlags
-----------------------------------------------------------------------------
module CmdLineParser (
processArgs, OptKind(..),
CmdLineP(..), getCmdLineState, putCmdLineState,
Flag(..), Deprecated(..),
errorsToGhcException
) where
#include "HsVersions.h"
import Util
import Outputable
import Panic
import SrcLoc
-- Flag 数据结构的定义，每一个Flag用于描述一个命令行参数，它是该命令行参数
-- 的规格说明。其中m应该是一个Monad
-- 这里使用了面向对象的思想，将数据和处理数据的函数放在一起
data Flag m = Flag
{
flagName :: String, -- 参数名，不包括开始的'-'
flagOptKind :: (OptKind m), -- 该参数后面可能有一些辅助的参数，
-- 例如"-fxxx=12"，这个动作用于处理辅助
-- 参数
flagDeprecated :: Deprecated -- 该参数是否是"不建议使用"的
}
-- 用于表示一个参数是否不建议使用，如果是，指出原因
data Deprecated = Supported | Deprecated String
-- 用于处理辅助参数的过程
data OptKind m -- 以-f参数为例
= NoArg (m ()) -- -f就是一个完整的参数
| HasArg (String -> m ()) -- -farg 或者 -f arg
| SepArg (String -> m ()) -- -f arg
| Prefix (String -> m ()) -- -farg
| OptPrefix (String -> m ()) -- -f或者-farg (即arg是可选的)
| OptIntSuffix (Maybe Int -> m ()) -- -f或者-f=n
| IntSuffix (Int -> m ()) -- -f=n
| PassFlag (String -> m ()) -- -f，将"-f"整个参数传递给指定的动作
| AnySuffix (String -> m ()) -- -f或者-farg，将"-farg"传递给指定的动作
| PrefixPred (String -> Bool) (String -> m ()) -- -farg, 并且使用第一个函数
-- 判断该arg部分是否合法
| AnySuffixPred (String -> Bool) (String -> m ()) -- -f后者-farg，并且用第一个
-- 函数判断该参数整体是否合法
parseInt :: String -> Maybe Int
-- 分析如"433"或者"=342"的辅助参数，后面没有额外的字符(非空白字符)
-- "n"或者"=n" => Just n
-- 出现额外的字符 => Nothing
parseInt s = case reads s of
((n,""):_) -> Just n
_ -> Nothing
dropEq :: String -> String
-- 去掉开始的'='符号
dropEq ('=' : s) = s
dropEq s = s
-- 出错，未知的参数
unknownFlagErr :: String -> Either String a
unknownFlagErr f = Left ("unrecognised flag: " ++ f)
-- 出错，该参数缺少辅助参数
missingArgErr :: String -> Either String a
missingArgErr f = Left ("missing argument for flag: " ++ f)
-- 从[Flag m]指定的所有可能参数的规格说明中找出String指定参数，
-- 找到，返回Just (该arg中剩下的字符串，该参数对应的动作，该参数的deprecate)
-- 没找到，返回Nothing
findArg :: [Flag m] -> String -> Maybe (String, OptKind m, Deprecated)
findArg spec arg
= case [ (removeSpaces rest, optKind, flagDeprecated flag)
| flag <- spec,
let optKind = flagOptKind flag,
Just rest <- [maybePrefixMatch (flagName flag) arg],
arg_ok optKind rest arg ]
-- 这里使用了构造列表的“解释”形式
of
[] -> Nothing
(one:_) -> Just one
-- 用于判断一个解析的参数是否合法
arg_ok :: OptKind t -> [Char] -> String -> Bool
arg_ok (NoArg _) rest _ = null rest
arg_ok (HasArg _) _ _ = True
arg_ok (SepArg _) rest _ = null rest
arg_ok (Prefix _) rest _ = notNull rest
arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest)
arg_ok (OptIntSuffix _) _ _ = True
arg_ok (IntSuffix _) _ _ = True
arg_ok (OptPrefix _) _ _ = True
arg_ok (PassFlag _) rest _ = null rest
arg_ok (AnySuffix _) _ _ = True
arg_ok (AnySuffixPred p _) _ arg = p arg
-- 分析一个参数 OptKind m 为findArg找到的该参数对应的规格说明中的动作；
-- 第一个String是findArg返回的该参数剩下的辅助参数；第二个String是当前
-- 被分析的参数的整体；[Located String]是当前参数后面的所有东西;
-- 返回可能是Left 错误信息；
-- 或者是Right (m (), 下面该分析的参数)
processOneArg :: OptKind m -> String -> String -> [Located String]
-> Either String (m (), [Located String])
processOneArg action rest arg args
= let dash_arg = '-' : arg -- 完整的带有'-'的参数
rest_no_eq = dropEq rest -- 不带'='开始的辅助参数
in case action of
-- 不需要处理辅助参数，返回
NoArg a -> ASSERT(null rest) Right (a, args)
-- f是处理辅助参数的函数，f rest_no_eq是m ()的动作
-- 辅助参数可能在rest_no_eq里面: -farg
-- 辅助参数可能在后面: -f arg
HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
| otherwise -> case args of
[] -> missingArgErr dash_arg
(L _ arg1:args1) -> Right (f arg1, args1)
-- 类似于HasArg的第二种情况
-- 这里的出错应该是 missingArgErr吧？
SepArg f -> case args of
[] -> unknownFlagErr dash_arg
(L _ arg1:args1) -> Right (f arg1, args1)
-- 类似于HasArg的第一种情况
-- 这里的出错应该是 missingArgErr?
Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
| otherwise -> unknownFlagErr dash_arg
-- 与上面类似，此时已经判断了rest_no_eq为合法的(findArg中)
PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
| otherwise -> unknownFlagErr dash_arg
-- 将本参数作为整体传递给辅助参数处理函数
PassFlag f | notNull rest -> unknownFlagErr dash_arg
| otherwise -> Right (f dash_arg, args)
-- 该参数可能带有整型的辅助参数
OptIntSuffix f | null rest -> Right (f Nothing, args)
| Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
| otherwise -> Left ("malformed integer argument in " ++ dash_arg)
-- 该参数一定带有整型的辅助参数
IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
| otherwise -> Left ("malformed integer argument in " ++ dash_arg)
-- 带有可选的辅助参数，如果辅助参数不存在, rest_no_eq为""
OptPrefix f -> Right (f rest_no_eq, args)
-- 将参数及其可能带有的辅助参数整体传递给辅助参数处理函数
AnySuffix f -> Right (f dash_arg, args)
-- 与上面类似，此时已经判断了dash_arg是合法的(findArg中)
AnySuffixPred _ f -> Right (f dash_arg, args)
-- 处理命令行参数的主函数
processArgs :: Monad m
=> [Flag m] -- 所有可能参数的规格说明
-> [Located String] -- 所有待处理的参数
-> m (
[Located String], -- 剩下的，未被处理的参数
[Located String], -- 有错误的参数
[Located String] -- 有警告的参数
)
processArgs spec args = process spec args [] [] []
where
process _spec [] spare errs warns =
-- 由于每次发现错误等时都是添加在列表的前面，返回时需要将这些列表反转
return (reverse spare, reverse errs, reverse warns)
process spec (locArg@(L loc dash_arg@('-' : arg)) : args) spare errs warns =
case findArg spec arg of -- 从规格说明中找到arg对应的项
Just (rest, action, deprecated) ->
let warns' = case deprecated of
Deprecated warning -> -- 如果该参数“不建议使用”，增加警告信息
L loc ("Warning: " ++ dash_arg ++ " is deprecated: " ++ warning) : warns
Supported -> warns
in case processOneArg action rest arg args of
-- 如果单个参数处理出错，增加错误信息，并继续处理后续的参数
Left err -> process spec args spare (L loc err : errs) warns'
-- 如果单个参数处理正确，完成该参数对应的处理辅助参数的动作，
-- 并继续处理后续的参数
Right (action,rest) -> do action
process spec rest spare errs warns'
Nothing -> process spec args (locArg : spare) errs warns
-- 对于其他的命令行参数(不是以'-'开始的那些)，放到未被处理参数的列表中
process spec (arg : args) spare errs warns =
process spec args (arg : spare) errs warns
-- -----------------------------------------------------------------------------
-- 在命令行参数分析中用到的一个带有状态信息的Monad
-- 这个怎么用？或者说，什么时候用？
-- s 代表的是状态信息的类型，a是CmdLineP s这个Monad的结果、参数类型
-- 该Monad类型只有一个成员，它是一个以状态为参数，
-- 返回一个结构和一个后续状态的函数
-- 结构在一系列操作中显式的传递，而状态则同时隐式的传递
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
instance Monad (CmdLineP s) where
-- 将值a包装在Monad中，成员是：任给一个状态，返回a值和那个状态的常函数
return a = CmdLineP $ \s -> (a, s)
-- 绑定操作：将一个状态作为参数给操作结果的成员，等于首先把该状态传递给
-- m的成员函数，得到结果a和新状态s'，然后，以a为参数调用函数k，并得到
-- 一个新的Monad，再以把s'传递给新的Monad的成员，得到最终的结果.
m >>= k = CmdLineP $ \s -> let
(a, s') = runCmdLine m s
in runCmdLine (k a) s'
getCmdLineState :: CmdLineP s s
getCmdLineState = CmdLineP $ \s -> (s,s)
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState s = CmdLineP $ \_ -> ((),s)
-- ---------------------------------------------------------------------
-- 辅助工具，将上面收集的错误信息转换成一个GhcException，以遍高层统一处理
errorsToGhcException :: [Located String] -> GhcException
errorsToGhcException errs =
let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
in UsageError (showSDoc errors)
阅读(1693) | 评论(0) | 转发(0) |
