Pragma.hs

{-# LANGUAGE OverloadedStrings #-}

module CabalGild.Pragma where

import CabalGild.Comments
import CabalGild.Glob
import CabalGild.Prelude
import qualified Data.ByteString as BS
import qualified Distribution.Compat.CharParsing as C
import qualified Distribution.ModuleName as C
import qualified Distribution.Parsec as C
import qualified Distribution.Parsec.FieldLineStream as C

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

data Pragma
  = FieldPragma FieldPragma
  | GlobalPragma GlobalPragma
  deriving (Show)

-- | Pragmas applied per field
data FieldPragma
  = PragmaExpandModules FilePath [C.ModuleName]
  | PragmaGlobFiles Glob
  | PragmaFragment FilePath
  deriving (Show)

-- | Pragmas affecting global output
data GlobalPragma
  = PragmaOptIndent Int
  | PragmaOptTabular Bool
  deriving (Show)

-------------------------------------------------------------------------------
-- Parser
-------------------------------------------------------------------------------

-- | Parse pragma from 'ByteString'.
--
-- An error ('Left') is reported only if input 'ByteString' starts with @-- cabal-gild:@.
parsePragma :: ByteString -> Either String (Maybe Pragma)
parsePragma bs = case dropPrefix bs of
  Nothing -> Right Nothing
  Just bs' -> bimap show Just $ C.runParsecParser parser "<input>" $ C.fieldLineStreamFromBS bs'
  where
    dropPrefix bs0 = do
      bs1 <- BS.stripPrefix "--" bs0
      bs2 <- BS.stripPrefix "cabal-gild:" (stripWhitespace bs1)
      return (stripWhitespace bs2)

    parser :: C.ParsecParser Pragma
    parser = do
      t <- C.parsecToken
      case t of
        "expand" -> expandModules
        "indent" -> indent
        "glob-files" -> globFiles
        "tabular" -> return $ GlobalPragma $ PragmaOptTabular True
        "no-tabular" -> return $ GlobalPragma $ PragmaOptTabular False
        "fragment" -> fragment
        _ -> fail $ "Unknown pragma " ++ t

    expandModules :: C.ParsecParser Pragma
    expandModules = do
      C.spaces
      dir <- C.parsecToken
      mns <- C.many (C.space *> C.spaces *> C.char '-' *> C.parsec)
      return $ FieldPragma $ PragmaExpandModules dir mns

    indent :: C.ParsecParser Pragma
    indent = do
      C.spaces
      GlobalPragma . PragmaOptIndent <$> C.integral

    fragment :: C.ParsecParser Pragma
    fragment = do
      C.spaces
      FieldPragma . PragmaFragment <$> C.parsecToken

    globFiles :: C.ParsecParser Pragma
    globFiles = do
      C.spaces
      t <- C.parsecToken
      case parseGlob t of
        Right g -> return $ FieldPragma $ PragmaGlobFiles g
        Left e -> C.unexpected e

stripWhitespace :: ByteString -> ByteString
stripWhitespace bs = case BS.uncons bs of
  Nothing -> bs
  Just (w, bs')
    | w == 32 -> stripWhitespace bs'
    | otherwise -> bs

parsePragmas :: Comments -> ([String], [Pragma])
parsePragmas = fmap catMaybes . partitionEithers . map parsePragma . unComments