103 lines
3.0 KiB
Haskell
103 lines
3.0 KiB
Haskell
|
{-# LANGUAGE CPP #-}
|
||
|
|
|
||
|
|
module System.OsRelease.Megaparsec where
|
||
|
|
|
||
|
|
import Control.Applicative
|
||
|
|
import Control.Monad
|
||
|
|
#if !MIN_VERSION_base(4,13,0)
|
||
|
|
import Control.Monad.Fail ( MonadFail )
|
||
|
|
#endif
|
||
|
|
import Data.Char
|
||
|
|
import Data.Functor
|
||
|
|
import Data.Void
|
||
|
|
|
||
|
|
import qualified Text.Megaparsec as MP
|
||
|
|
import qualified Text.Megaparsec.Char as MP
|
||
|
|
|
||
|
|
|
||
|
|
-- | Parse the entire file, handling newlines and comments gracefully.
|
||
|
|
--
|
||
|
|
-- This parser generally shouldn't fail, but instead report a failed
|
||
|
|
-- parsed line as @Left@ value.
|
||
|
|
parseAssignments :: MP.Parsec
|
||
|
|
Void
|
||
|
|
String
|
||
|
|
[Either (MP.ParseError String Void) (String, String)]
|
||
|
|
parseAssignments =
|
||
|
|
(\xs x -> join xs ++ x) <$> many (line MP.eol) <*> line MP.eof
|
||
|
|
where
|
||
|
|
line eol = choice'
|
||
|
|
[ comment $> []
|
||
|
|
, blank $> []
|
||
|
|
, fmap
|
||
|
|
(: [])
|
||
|
|
( MP.withRecovery (\e -> parseUntil eol $> Left e)
|
||
|
|
. fmap Right
|
||
|
|
$ (parseAssignment <* eol)
|
||
|
|
)
|
||
|
|
]
|
||
|
|
where
|
||
|
|
comment = pWs *> MP.char '#' *> parseUntil eol *> eol
|
||
|
|
blank = pWs *> eol
|
||
|
|
|
||
|
|
|
||
|
|
-- | Parse a single line assignment and extract the right hand side.
|
||
|
|
-- This is only a subset of a shell parser, refer to the spec for
|
||
|
|
-- details.
|
||
|
|
parseAssignment :: MP.Parsec Void String (String, String)
|
||
|
|
parseAssignment =
|
||
|
|
(,) <$> (pWs *> key) <*> (MP.char '=' *> (MP.try qval <|> mempty) <* pWs)
|
||
|
|
where
|
||
|
|
dropSpace :: String -> String
|
||
|
|
dropSpace = reverse . dropWhile (\x -> x == ' ' || x == '\t') . reverse
|
||
|
|
|
||
|
|
key :: MP.Parsec Void String String
|
||
|
|
key = some (MP.try MP.alphaNumChar <|> MP.char '_')
|
||
|
|
|
||
|
|
qval :: MP.Parsec Void String String
|
||
|
|
qval = do
|
||
|
|
c <- MP.lookAhead MP.printChar
|
||
|
|
case c of
|
||
|
|
' ' -> pure ""
|
||
|
|
'"' -> MP.char c *> val c <* MP.char c
|
||
|
|
'\'' -> MP.char c *> val c <* MP.char c
|
||
|
|
-- no quote, have to drop trailing spaces
|
||
|
|
_ -> fmap
|
||
|
|
dropSpace
|
||
|
|
(some $ MP.satisfy (\x -> isAlphaNum x || (x `elem` ['_', '-', '.']))) -- this is more lax than the spec
|
||
|
|
val :: Char -> MP.Parsec Void String String
|
||
|
|
val !q = many (qspecial q <|> MP.noneOf (specials q)) -- noneOf may be too lax
|
||
|
|
|
||
|
|
qspecial :: Char -> MP.Parsec Void String Char
|
||
|
|
qspecial !q =
|
||
|
|
fmap (!! 1)
|
||
|
|
. (\xs -> choice' xs)
|
||
|
|
. fmap (\s -> MP.try . MP.chunk $ ['\\', s])
|
||
|
|
$ (specials q)
|
||
|
|
|
||
|
|
specials :: Char -> [Char]
|
||
|
|
specials !q = [q, '\\', '$', '`']
|
||
|
|
|
||
|
|
|
||
|
|
parseUntil :: MP.Parsec Void String a -> MP.Parsec Void String String
|
||
|
|
parseUntil !p = do
|
||
|
|
(MP.try (MP.lookAhead p) $> [])
|
||
|
|
<|> (do
|
||
|
|
c <- MP.anySingle
|
||
|
|
c2 <- parseUntil p
|
||
|
|
pure ([c] `mappend` c2)
|
||
|
|
)
|
||
|
|
|
||
|
|
|
||
|
|
-- | Parse one or more white spaces or tabs.
|
||
|
|
pWs :: MP.Parsec Void String ()
|
||
|
|
pWs = many (MP.satisfy (\x -> x == ' ' || x == '\t')) $> ()
|
||
|
|
|
||
|
|
|
||
|
|
-- | Try all parses in order, failing if all failed. Also fails
|
||
|
|
-- on empty list.
|
||
|
|
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
|
||
|
|
choice' = \case
|
||
|
|
[] -> fail "Empty list"
|
||
|
|
xs -> foldr1 (\x y -> MP.try x <|> MP.try y) xs
|