{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Nix.Identifier
( Identifier, ident, quote, needsQuoting
, parseSimpleIdentifier, parseQuotedIdentifier
)
where
import Control.DeepSeq
import Control.Lens
import Data.Char
import Data.Either
import Data.String
import GHC.Generics ( Generic )
import Test.QuickCheck
import Text.Parsec.Class as P
import Text.PrettyPrint.HughesPJClass as PP
declareLenses [d| newtype Identifier = Identifier { ident :: String }
deriving (Show, Eq, Ord, IsString, Generic)
|]
instance NFData Identifier where
rnf (Identifier str) = rnf str
instance Arbitrary Identifier where
arbitrary = Identifier <$> listOf1 arbitraryUnicodeChar
shrink (Identifier i) = map Identifier (shrink i)
instance CoArbitrary Identifier
instance Pretty Identifier where
pPrint = view (ident . to quote . to text)
instance HasParser Identifier where
parser = parseQuotedIdentifier <|> parseSimpleIdentifier
parseSimpleIdentifier :: CharParser st tok m Identifier
parseSimpleIdentifier = do
c <- satisfy (\x -> x == '_' || isAlpha x)
cs <- many (satisfy (\x -> x `elem` "_'-" || isAlphaNum x))
return (Identifier (c:cs))
parseQuotedIdentifier :: CharParser st tok m Identifier
parseQuotedIdentifier = Identifier <$> qstring
where
qstring :: CharParser st tok m String
qstring = do txt <- between (P.char '"') (P.char '"') (many qtext)
return (read ('"' : concat txt ++ ['"']))
qtext :: CharParser st tok m String
qtext = quotedPair <|> many1 (P.noneOf "\\\"")
quotedPair :: CharParser st tok m String
quotedPair = do
c1 <- P.char '\\'
c2 <- anyChar
return [c1,c2]
needsQuoting :: String -> Bool
needsQuoting = isLeft . runParser (parseSimpleIdentifier >> eof) () ""
quote :: String -> String
quote s = if needsQuoting s then show s else s