Как я могу избежать написания кода шаблона для функций, выполняющих сопоставление шаблонов?

В этот ответ на еще один вопрос был предоставлен небольшой эскиз кода Haskell, который использует функции-обертки для выставьте код для проверки синтаксиса в аргументах командной строки. Вот часть кода, которую я пытаюсь упростить:

takesSingleArg :: (String -> IO ()) -> [String] -> IO ()
takesSingleArg act [arg] = act arg
takesSingleArg _   _     = showUsageMessage

takesTwoArgs :: (String -> String -> IO ()) -> [String] -> IO ()
takesTwoArgs act [arg1, arg2] = act arg1 arg2
takesTwoArgs _   _            = showUsageMessage

Есть ли способ (возможно, использовать Template Haskell?), чтобы избежать необходимости писать дополнительные функции для каждого числа аргументов? В идеале я хотел бы написать что-то вроде (я делаю этот синтаксис)

generateArgumentWrapper<2, showUsageMessage>

И это расширяется до

\fn args -> case args of
                 [a, b] -> fn a b
                 _      -> showUsageMessage

В идеале я мог бы даже иметь переменное количество аргументов в мета-функции generateArgumentWrapper, чтобы я мог делать

generateArgumentWrapper<2, asInt, asFilePath, showUsageMessage>

И это расширяется до

\fn args -> case args of
                 [a, b] -> fn (asInt a) (asFilePath b)
                 _      -> showUsageMessage

Кто-нибудь знает, как это достичь? Было бы очень просто связать аргументы командной строки ([String]) с произвольными функциями. Или может быть, совсем другой, лучший подход?

Ответ 1

Хаскелл имеет поливарианские функции. Представьте, что у вас был тип типа

data Act = Run (String -> Act) | Res (IO ())

с некоторыми функциями делать то, что вы хотите

runAct (Run f) x = f x
runAct (Res _) x = error "wrong function type"

takeNargs' 0 (Res b) _ = b
takeNargs' 0 (Run _) _ = error "wrong function type"
takeNargs' n act (x:xs) = takeNargs' (n-1) (runAct act x) xs
takeNargs' _ _ [] = error "not long enough list"

теперь все, что вам нужно, - это маршалирование функций в этом типе Act. Вам нужны некоторые расширения

{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}

а затем вы можете определить

class Actable a where
  makeAct :: a -> Act
  numberOfArgs :: a -> Int

instance Actable (String -> IO ()) where
  makeAct f = Run $ Res . f
  numberOfArgs _ = 1

instance Actable (b -> c) => Actable (String -> (b -> c)) where
  makeAct f = Run $ makeAct . f
  numberOfArgs f = 1 + numberOfArgs (f "")

теперь вы можете определить

takeNArgs n act = takeNargs' n (makeAct act)

что упрощает определение ваших исходных функций

takesSingleArg :: (String -> IO ()) -> [String] -> IO ()
takesSingleArg = takeNArgs 1

takesTwoArgs :: (String -> String -> IO ()) -> [String] -> IO ()
takesTwoArgs = takeNArgs 2

Но мы можем сделать еще лучше

takeTheRightNumArgs f = takeNArgs (numberOfArgs f) f

Удивительно, но это работает (GHCI)

*Main> takeTheRightNumArgs putStrLn ["hello","world"]
hello
*Main> takeTheRightNumArgs (\x y -> putStrLn x >> putStrLn y)  ["hello","world"] 
hello
world

Изменить: код выше намного сложнее, чем нужно. На самом деле все, что вам нужно, это

class TakeArgs a where
   takeArgs :: a -> [String] -> IO ()

instance TakeArgs (IO ()) where
   takeArgs a _ = a

instance TakeArgs a => TakeArgs (String -> a) where
   takeArgs f (x:xs) = takeArgs (f x) xs
   takeArgs f [] = error "end of list"

Ответ 2

Возможно, вы захотите использовать существующие библиотеки для обработки аргументов командной строки. Я считаю, что фактический стандарт сейчас cmdargs, но существуют другие варианты, такие как ReadArgs и console-program.

Ответ 3

Комбинаторы - ваш друг. Попробуйте следующее:

take1 :: [String] -> Maybe String
take1 [x] = Just x
take1 _ = Nothing

take2 :: [String] -> Maybe (String,String)
take2 [x,y] = Just (x,y)
take2 _ = Nothing

take3 :: [String] -> Maybe ((String,String),String)
take3 [x,y,z] = Just ((x,y),z)
take3 _ = Nothing

type ErrorMsg = String

with1 :: (String -> IO ()) -> ErrorMsg -> [String] -> IO ()
with1 f msg = maybe (fail msg) f . take1

with2 :: (String -> String -> IO ()) -> ErrorMsg -> [String] -> IO ()
with2 f msg = maybe (fail msg) (uncurry f) . take2

with3 :: (String -> String -> String -> IO ()) -> ErrorMsg -> [String] -> IO ()
with3 f msg = maybe (fail msg) (uncurry . uncurry $ f) . take3

foo a b c = putStrLn $ a ++ " :: " ++ b ++ " = " ++ c

bar = with3 foo "You must send foo a name, type, definition"

main = do
  bar [ "xs", "[Int]", "[1..3]" ]
  bar [ "xs", "[Int]", "[1..3]", "What am I doing here?" ]

И если вам нравятся расширенные расширения языка:

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

foo a b c = putStrLn $ a ++ " :: " ++ b ++ " = " ++ c
foo_msg = "You must send foo a name, type, definition"

class ApplyArg a b | a -> b where
  appArg :: ErrorMsg -> a -> [String] -> IO b

instance ApplyArg (IO b) b where
  appArg _msg todo [] = todo
  appArg msg _todo _ = fail msg

instance ApplyArg v q => ApplyArg (String -> v) q where
  appArg msg todo (x:xs) = appArg msg (todo x) xs
  appArg msg _todo _ = fail msg

quux :: [String] -> IO ()
quux xs = appArg foo_msg foo xs

main = do
  quux [ "xs", "[int]", "[1..3]" ]
  quux [ "xs", "[int]", "[1..3]", "what am i doing here?" ]