udon / src / Parser.hs

{-# LANGUAGE PatternGuards #-}
module Parser
    ( parseDaemonFile
    , parseDaemon
    , daemon
    ) where

import Control.Applicative ((<*), (*>), (<$>), (<*>))
import Data.List (intercalate)
import Text.ParserCombinators.Parsec

import Common


data DaemonFields = DF { dfName      :: Maybe String
                       , dfCommand   :: Maybe String
                       , dfArgs      :: Maybe [String]
                       , dfCwd       :: Maybe String
                       , dfEnv       :: Maybe [(String, String)]
                       , dfAutoStart :: Maybe Bool
                       }

fieldToDaemon (DF (Just name) (Just cmd) (Just args) (Just cwd) (Just env) (Just auto)) = Daemon name cmd args cwd env auto

emptyFields = DF Nothing Nothing Nothing Nothing Nothing Nothing

completed :: DaemonFields -> Bool
completed df = undefinedNames df == []

undefinedNames :: DaemonFields -> [String]
undefinedNames df = undefinedNames' df []

undefinedNames' :: DaemonFields -> [String] -> [String]
undefinedNames' df fs
    | Nothing <- dfAutoStart df = undefinedNames' df { dfAutoStart = Just undefined } $ "dAutoStart":fs
    | Nothing <- dfEnv df       = undefinedNames' df { dfEnv = Just undefined } $ "dEnv":fs
    | Nothing <- dfCwd df       = undefinedNames' df { dfCwd = Just undefined } $ "dCwd":fs
    | Nothing <- dfArgs df      = undefinedNames' df { dfArgs = Just undefined } $ "dArgs":fs
    | Nothing <- dfCommand df   = undefinedNames' df { dfCommand = Just undefined } $ "dCommand":fs
    | Nothing <- dfName df      = undefinedNames' df { dfName = Just undefined } $ "dName":fs
    | otherwise = fs

parseDaemonFile :: FilePath -> IO (Either ParseError Daemon)
parseDaemonFile fp = parseFromFile daemon fp

parseDaemon :: String -> Either ParseError Daemon
parseDaemon = parse daemon ""

daemon :: Parser Daemon
daemon = do
    spaces
    string "Daemon"
    spaces
    df <- braces $ fields emptyFields
    if completed df
      then return $ fieldToDaemon df
      else fail $ "undefined fields: " ++ intercalate ", " (undefinedNames df)

fields :: DaemonFields -> Parser DaemonFields
fields df = do
    df' <- field df
    try ((lookAhead $ symbol "}") >> return df')
        <|> (comma >> fields df')

field :: DaemonFields -> Parser DaemonFields
field df = fieldName df <|> fieldCommand df <|> fieldArgs df <|> fieldCwd df <|> fieldAutoStart df <|> fieldEnv df

fieldName, fieldCommand, fieldArgs, fieldCwd, fieldEnv, fieldAutoStart :: DaemonFields -> Parser DaemonFields
fieldName = mkFieldParser "dName" dfName quotedString (\v f -> f { dfName = Just v })
fieldCommand = mkFieldParser "dCommand" dfCommand quotedString (\v f -> f { dfCommand = Just v })
fieldArgs = mkFieldParser "dArgs" dfArgs listOfString (\v f -> f { dfArgs = Just v })
fieldCwd = mkFieldParser "dCwd" dfCwd quotedString (\v f -> f { dfCwd = Just v })
fieldEnv = mkFieldParser "dEnv" dfEnv aListOfString (\v f -> f { dfEnv = Just v })
fieldAutoStart = mkFieldParser "dAutoStart" dfAutoStart bool (\v f -> f { dfAutoStart = Just v })

mkFieldParser :: String         -- ^ Field name
              -> (f -> Maybe a) -- ^ field duplication check function
              -> Parser b       -- ^ parser for field body
              -> (b -> f -> f)  -- ^ field update function
              -> (f -> Parser f)
mkFieldParser fn fc p fu df = do
    try $ string fn
    spaces
    equal
    fv <- lexeme p
    case fc df of
        Just _  -> fail $ "duplicated field: " ++ fn
        Nothing -> return (fu fv df)

quotedString :: Parser String
quotedString = (lexeme $ char '"' *> (concat <$> many quotedChar) <* char '"')
    <?> "quoted-string"

quotedChar :: Parser String
quotedChar = do
    c <- noneOf ['"']
    case c of
        '\\' -> do
            c' <- anyChar
            return [c, c']
        _    -> return [c]

list :: Parser a -> Parser [a]
list p = bracket $ sepBy p comma

listOfString :: Parser [String]
listOfString = lexeme $ list quotedString

aListOfString :: Parser [(String, String)]
aListOfString = lexeme $ list $ pair quotedString quotedString

pair :: Parser a -> Parser b -> Parser (a, b)
pair p p' = lexeme $ parens $ (,) <$> p <*> (comma *> p')

bool :: Parser Bool
bool = string "True" *> return True
   <|> string "False" *> return False

lexeme p = p <* spaces

symbol = lexeme . string

braces = between (symbol "{") (symbol "}")
bracket = between (symbol "[") (symbol "]")
parens  = between (symbol "(") (symbol ")")

comma = symbol ","
equal = symbol "="
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.