一致するコンストラクタの過度の定型文を避ける方法

Question

現在、私はLexer/Parserを実装中です。そして、私は私のParser.hsでの私のコードの現在の半分は、単に単一のトークン取得するために専用されようとしているということですバグ一つのこと：

data Tok 
    = IdLower String 
    | IdUpper String 
    | IdSymbol String 
    | IdColon String 
    | Equals 
    | Newline 

I：このような小さなデータタイプについて

をこのような何か必要があるように見える：

idLower :: Parser String 
idLower = get >>= \s -> if 
    | (_, IdLower n) :- xs <- s -> put xs *> pure n 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

idUpper :: Parser String 
idUpper = get >>= \s -> if 
    | (_, IdUpper n) :- xs <- s -> put xs *> pure n 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

idSymbol :: Parser String 
idSymbol = get >>= \s -> if 
    | (_, IdSymbol n) :- xs <- s -> put xs *> pure n 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

idColon :: Parser String 
idColon = get >>= \s -> if 
    | (_, IdColon n) :- xs <- s -> put xs *> pure n 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

equals :: Parser() 
equals = get >>= \s -> if 
    | (_, Equals) :- xs <- s -> put xs 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

newline :: Parser() 
newline = get >>= \s -> if 
    | (_, Newline) :- xs <- s -> put xs 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

99％を繰り返すコードのようなものです、それらの間の唯一の違いは使用コンストラクタです、と私は内容を持っているもののためpure nのようなものを持っているかどうか。

シンボルごとにTok -> Maybe()またはTok -> Maybe Stringという関数を1つだけ持つようにリファクタリングしてから、これらの関数をパラメータとして使用する高次関数を作成しました。しかし、それぞれのTok -> Maybe a関数は、3行と1行のスペーサーを取ります。そして今、私はそれをサポートするために別の高次関数が必要です。もし簡略化したいのであれば、getToken idLowerの代わりにidLowerを使うことができます。 、それ以上ではない！

私はちょうど上記に代わるものがあることを本当に望んでいます。今私はおそらく最初のガードがヒットしない場合に延期することができる関連するthrowErrorを常に呼び出す自動的に機能しない関数を作成することによって、少し重複を減らすことができることを知っています。

Answer 1

lens libraryなどのプリズムを使用してTok -> Maybe()とTok -> Maybe Stringの機能を「無料で」（テンプレートHaskell経由で）入手できます。

その後

GHCi> preview _IdLower (IdLower "foo") 
Just "foo" 
GHCi> preview _IdLower (IdUpper "Foo") 
Nothing 

、あなた自身を提案するとして、あなたはあなたのトークン固有の機能では、プリズムから抽象することができます：：

tok :: Prism' Tok a -> Parser a 
tok p = get >>= \ s -> if 
    | (_, t) :- xs <- s, Just n <- preview p t -> put xs *> pure n 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")] 

そして、あなたができる今、あなたが言うことができる

data Tok = 
    IdLower String 
    | IdUpper String 
    | IdSymbol String 
    | IdColon String 
    | Equals 
    | Newline 

makePrisms ''Tok 

tok _IdLowerまたはtok _Equalsと言って個々の機能を戻してください。

Answer 2

ここでは、定型コードを少し必要とするがテンプレートHaskellは必要ない別のアプローチがあります。

あなたが一致するのではなく、平等テストの形式を使用できるように、あなたのTokタイプの再編に基づいている、と一様トークンのペイロードを抽出することができます。

data Tok where 
    Tok :: TokKind a -> a -> Tok 

すべてのトークンは、トークンの種類とありペイロード。トークンの種類のタイプは、ペイロードのタイプを決定GADT です：

data TokKind :: * -> * where 
    IdLower :: TokKind String 
    IdUpper :: TokKind String 
    IdSymbol :: TokKind String 
    IdColon :: TokKind String 
    Equal :: TokKind() 
    Newline :: TokKind() 

我々は今、2つのトークンは同じ種類を持っている場合、そのペイロードタイプは互換性がなければならないことを意味平等のフォームを必要としています。

instance TestEquality TokKind where 
    testEquality IdLower IdLower = Just Refl 
    testEquality IdUpper IdUpper = Just Refl 
    testEquality IdSymbol IdSymbol = Just Refl 
    testEquality IdColon IdColon = Just Refl 
    testEquality Equal Equal = Just Refl 
    testEquality Newline Newline = Just Refl 
    testEquality _  _  = Nothing 

次に、あなたのパラメータ化トークンの機能は、私はテンプレートを避けるために好き

tok :: TokKind a -> Parser a 
tok tk' = get >>= \ s -> if 
    | (_, Tok tk x) :- xs <- s, Just Refl <- testEquality tk tk' -> put xs *> pure x 
    | (l, t) :- _ <- s -> throwError [(l, "Unexpected " <> description t)] 
    | Nil l <- s -> throwError [(l, "Unexpected end of input")]