content: {-# LANGUAGE OverloadedStrings #-}
  module CabalFmt.Pragma where
  
  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
  
  import CabalFmt.Prelude
  import CabalFmt.Comments
  import CabalFmt.Glob
  
  -------------------------------------------------------------------------------
  -- 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-fmt:@.
  --
  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-fmt:" (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
          n <- C.integral
          return $ GlobalPragma $ PragmaOptIndent n
  
      fragment :: C.ParsecParser Pragma
      fragment = do
          C.spaces
          fn <- C.parsecToken
          return $ FieldPragma $ PragmaFragment fn
  
      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
  