{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
module Stack.Types.FlagName
(FlagName
,FlagNameParseFail(..)
,flagNameParser
,parseFlagName
,parseFlagNameFromString
,flagNameString
,flagNameText
,fromCabalFlagName
,toCabalFlagName
,mkFlagName)
where
import Control.Applicative
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinators
import Data.Binary.VersionTagged
import qualified Data.ByteString as S
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Char (isLetter)
import Data.Data
import Data.Hashable
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Data.Word8 as Word8
import qualified Distribution.PackageDescription as Cabal
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
data FlagNameParseFail
= FlagNameParseFail ByteString
deriving (Typeable)
instance Exception FlagNameParseFail
instance Show FlagNameParseFail where
show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs
newtype FlagName =
FlagName ByteString
deriving (Typeable,Data,Generic,Hashable,Binary,NFData)
instance HasStructuralInfo FlagName
instance Eq FlagName where
x == y = compare x y == EQ
instance Ord FlagName where
compare (FlagName x) (FlagName y) =
compare (S.map Word8.toLower x) (S.map Word8.toLower y)
instance Lift FlagName where
lift (FlagName n) =
appE (conE 'FlagName)
(stringE (S8.unpack n))
instance Show FlagName where
show (FlagName n) = S8.unpack n
instance FromJSON FlagName where
parseJSON j =
do s <- parseJSON j
case parseFlagNameFromString s of
Nothing ->
fail ("Couldn't parse flag name: " ++ s)
Just ver -> return ver
-- | Attoparsec parser for a flag name from bytestring.
flagNameParser :: Parser FlagName
flagNameParser =
fmap (FlagName . S8.pack)
(appending (many1 (satisfy isLetter))
(concating (many (alternating
(pured (satisfy isAlphaNum))
(appending (pured (satisfy separator))
(pured (satisfy isAlphaNum)))))))
where separator c = c == '-' || c == '_'
isAlphaNum c = isLetter c || isDigit c
-- | Make a flag name.
mkFlagName :: String -> Q Exp
mkFlagName s =
case parseFlagNameFromString s of
Nothing -> error ("Invalid flag name: " ++ show s)
Just pn -> [|pn|]
-- | Convenient way to parse a flag name from a bytestring.
parseFlagName :: MonadThrow m => ByteString -> m FlagName
parseFlagName x = go x
where go =
either (const (throwM (FlagNameParseFail x))) return .
parseOnly (flagNameParser <* endOfInput)
-- | Migration function.
parseFlagNameFromString :: MonadThrow m => String -> m FlagName
parseFlagNameFromString =
parseFlagName . S8.pack
-- | Produce a string representation of a flag name.
flagNameString :: FlagName -> String
flagNameString (FlagName n) = S8.unpack n
-- | Produce a string representation of a flag name.
flagNameText :: FlagName -> Text
flagNameText (FlagName n) = T.decodeUtf8 n
-- | Convert from a Cabal flag name.
fromCabalFlagName :: Cabal.FlagName -> FlagName
fromCabalFlagName (Cabal.FlagName name) =
let !x = S8.pack name
in FlagName x
-- | Convert to a Cabal flag name.
toCabalFlagName :: FlagName -> Cabal.FlagName
toCabalFlagName (FlagName name) =
let !x = S8.unpack name
in Cabal.FlagName x
instance ToJSON a => ToJSON (Map FlagName a) where
toJSON = toJSON . Map.mapKeysWith const flagNameText
instance FromJSON a => FromJSON (Map FlagName a) where
parseJSON val = do
m <- parseJSON val
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = fmap (, v) $ either (fail . show) return $ parseFlagNameFromString k