Help.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Command.Help (
  Help (..)
, help
, commandShortHelp
, commandHelpText
) where

import           Control.Monad
import           Data.Maybe
import           Data.String
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax

import           Command.Type
import           Util (strip)

-- | A `QuasiQuoter` for help text.
help :: QuasiQuoter
help = QuasiQuoter {
    quoteExp  = lift . parseHelp
  , quotePat  = error "Command.Help.help: quotePat is undefined!"
  , quoteType = error "Command.Help.help: quoteType is undefined!"
  , quoteDec  = error "Command.Help.help: quoteDec is undefined!"
  }

instance Lift Help where
  lift (Help xs) = AppE `fmap` [|Help|] `ap` lift xs

instance IsString Help where
  fromString = parseHelp

-- | Parse help text.
parseHelp :: String -> Help
parseHelp = Help . go . map strip . lines
  where
    go l = case dropWhile null l of
      [] -> []
      xs -> let (ys, zs) = break null xs in (wordWrapping . unwords) ys ++ go zs

-- | Apply automatic word wrapping.
wordWrapping :: String -> [String]
wordWrapping = run . words
  where
    -- we start each recursion step at 2, this makes sure that each step
    -- consumes at least one word
    run = go 2
    go n xs
      | null xs                  = []
      | 60 < length (unwords ys) = let (as, bs) = splitAt (pred n) xs in unwords as : run bs
      | null zs                  = [unwords ys]
      | otherwise                = go (succ n) xs
      where
        (ys, zs) = splitAt n xs

-- | The first line of the command description.
commandShortHelp :: Command -> String
commandShortHelp = fromMaybe "" . listToMaybe . unHelp . commandHelp_

commandHelpText :: Command -> [String]
commandHelpText = unHelp . commandHelp_