Rework command dispatch

diff --git a/app/Main.hs b/app/Main.hs
index f59f326..fabf651 100644 (file)
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 module Main where
@@ -130,7 +128,7 @@ entry config = do
   pure "\nThanks for using xyz!"
 
 config :: ProjectConfig -> ExceptT Text IO Text
-config config = pure $ "\nProject details:\n" +++ (unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where
+config config = pure $ "\nProject details:\n\n" +++ (unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where
              n = name (config :: ProjectConfig)
              d = description (config :: ProjectConfig)
              t = theme (config :: ProjectConfig)
@@ -140,14 +138,25 @@ config config = pure $ "\nProject details:\n" +++ (unlines $ zipWith (+++) ["Nam
                Just g -> g
                Nothing -> "Not set"
 
-usage :: IO ()
-usage =  putStr . ununlines $ [
+data Command = Command {
+  name :: Text,
+  description :: Text,
+  dispatch :: ExceptT Text IO Text
+                       }
+
+commands :: [Command]
+commands = [
+  Command "init" "Initialise a new site" $ init getLocalProjectConfig getGlobalProjectConfig,
+  Command "build" "Build the site" $ resolveProjectConfig >>= build,
+  Command "entry" "Initialise an entry" $ resolveProjectConfig >>= entry,
+  Command "config" "Show project configuration" $ resolveProjectConfig >>= config
+  ]
+
+usage :: [Command] -> ExceptT Text IO Text
+usage c =  pure . ununlines $ [
   "usage: xyz <command>",
-  "Commands:", unlines [
-      "\tinit\t\tInitialise a new site",
-      "\tbuild\t\tBuild the site",
-      "\tentry\t\tInitialise an entry"
-                       ]
+  "Commands:",
+  unlines $ fmap (\x ->"\t" +++ name (x :: Command) +++ ": " +++ description (x :: Command)) c
   ]
 
 runExceptTAndOutput :: ExceptT Text IO Text -> IO ()
@@ -157,12 +166,12 @@ runExceptTAndOutput e = do
     Left error -> putStrLn error >> (exitWith $ ExitFailure 1)
     Right output -> putStrLn output >> exitWith ExitSuccess
 
+parse :: [Command] -> [Text] -> ExceptT Text IO Text
+parse commands [] = usage commands
+parse commands theCommand = case (lookup 0 ththing) of
+  Just whatever -> dispatch whatever
+  Nothing -> usage commands
+  where ththing = Prelude.zip [0..] (Prelude.filter (\x -> name (x :: Command) == (theCommand !! 0)) commands)
+
 main :: IO ()
-main = getArgs >>= parse
-
-parse ["init"] = runExceptTAndOutput $ init getLocalProjectConfig getGlobalProjectConfig
-parse ["build"] = runExceptTAndOutput $ resolveProjectConfig >>= build
-parse ["entry"] = runExceptTAndOutput $ resolveProjectConfig >>= entry
-parse ["config"] = runExceptTAndOutput $ resolveProjectConfig >>= config
-parse [_] = usage
-parse [] = usage
+main = getArgs >>= runExceptTAndOutput . ((parse commands)) . (fmap pack)