mcm-0.6.8.1: Parser.hs

-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2018 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
--     This program is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.
--
--     This program is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.
--
--     You should have received a copy of the GNU General Public License
--     along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Parser (mcmParse, mcmLoadAndParse, mcmParsePackagePath)
where

import Control.Monad(unless, when)
import Data.Char (isLower, isUpper, isAlpha, isAlphaNum, isSpace, generalCategory, GeneralCategory(..))
import Data.Int (Int64)
import Data.Foldable (foldlM)
import qualified Data.Map as Map
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TextIO
import Text.ParserCombinators.Poly.StateText

import ParserTypes

-- State is (LineNumber, [ParseErrors])
newtype State = State (Int, [String])
    deriving Show

type P = Parser State

initState :: State
initState = State (1, [])

incNewline :: P ()
incNewline = stUpdate (\(State (n, es)) -> State(n+1, es))

lineNo :: P Int
lineNo = stQuery (\(State (n, _)) -> n)

addError :: String -> P ()
addError e = stUpdate (\(State (n, es)) -> State(n, prep n:es))
    where
        prep n = "line " ++ show n ++ ": " ++ e

adjustError :: P a -> String -> P a
adjustError pa e = do
    n <- stQuery (\(State (n, _)) -> n)
    pa `adjustErr` (("line " ++ show n ++ ": " ++ e ++ "\n")++)

prettyFail :: String -> P ()
prettyFail e = do
    n <- stQuery (\(State (n, _)) -> n)
    fail $ "line " ++ show n ++ ": " ++ e

prettyFailBad :: String -> P ()
prettyFailBad = commit . prettyFail

ensureEof :: P ()
ensureEof =
    oneOf
        [eof
        ,do
            n <- stQuery (\(State (n, _)) -> n)
            r <- manySatisfy(/= '\n')
            failBad $ "Parsing unexpectedly ended at line " ++ show n ++
                " with the rest of the line being " ++ show r
        ]

toContent' :: Int -> ContentType -> ContentLine -> P [Content]
toContent' lineno ct cl = case toContent lineno ct cl of
    Left e -> addError e >> return []
    Right cs -> return cs

checkUniqueAndInsert :: (Show t, Ord t) => String -> Map.Map t a -> (t, a) -> P (Map.Map t a)
checkUniqueAndInsert s m (k,v) = do
    when (k `Map.member` m) $ addError $ s ++ " \"" ++ show k ++ "\" is defined multiple times"
    return $ Map.insert k v m

checkUniqueAndUnion :: (Show t, Ord t) => String -> Map.Map t a -> Map.Map t a -> P (Map.Map t a)
checkUniqueAndUnion s m1 m2 = do
    let i = m1 `Map.intersection` m2
    unless (Map.null i) $ mapM_ ((\k -> addError $ s ++ "\" \"" ++ k ++ "\" is defined multiple times") . show) $ Map.keys i
    return $ Map.union m1 m2

char :: Char -> P ()
char c = do
    n <- next
    unless (c == n) $ prettyFail $ "expected " ++ show c ++ " but got " ++ show n

isSpaceOrTab :: Char -> Bool
isSpaceOrTab '\t' = True
isSpaceOrTab ' ' = True
isSpaceOrTab _ = False

pSpaceButCheckOthers :: P ()
pSpaceButCheckOthers = do
    w <- manySatisfy isSpaceOrTab
    unless (T.length w == 1 && T.unpack w == " ") $
        addError $ "was expecting a single space character but got " ++ show w

pSpaceButCheckSingleTab :: P ()
pSpaceButCheckSingleTab = do
    c <- next
    when (c == '\t') $
        addError $ "was expecting a single space character but got " ++ show c
    unless (isSpaceOrTab c) $
        prettyFail $ "was expecting a single space character but got " ++ show c

nToWord :: Int64 -> String -> String -> String
nToWord 0 _ plural = "no " ++ plural
nToWord 1 single _ = "one " ++ single
nToWord 2 _ plural = "two " ++ plural
nToWord 3 _ plural = "three " ++ plural
nToWord 4 _ plural = "four " ++ plural
nToWord 5 _ plural = "five " ++ plural
nToWord 6 _ plural = "six " ++ plural
nToWord 7 _ plural = "seven " ++ plural
nToWord 8 _ plural = "eight " ++ plural
nToWord 9 _ plural = "nine " ++ plural
nToWord 10 _ plural = "ten " ++ plural
nToWord n _ plural = show n ++ " " ++ plural

pIndentN :: Int64 -> P ()
pIndentN n = do
    w <- many1Satisfy isSpaceOrTab `adjustError`
        "was expecting at least one tab"
    let tabs = nToWord n "tab character" "tab characters"
        nspaces = T.count (T.pack " ") w
        spaces = nToWord nspaces "space" "spaces"
    when (nspaces /= 0) $
        prettyFailBad $ "was expecting an indent using just tabs but found " ++ spaces ++ ": " ++ show w
    unless (T.length w == n && T.count (T.pack "\t") w == n) $
        prettyFail $ "was expecting an indent with " ++ tabs ++ " but got " ++ show w

pIndent :: P ()
pIndent = pIndentN 1

pIndent2 :: P ()
pIndent2 = pIndentN 2

pIndent3 :: P ()
pIndent3 = pIndentN 3

keyword :: T.Text -> P ()
keyword s = do
    let fmsg = "was expecting the keyword '" ++ T.unpack s ++ "'"
    found <- many1Satisfy isAlpha `adjustError` fmsg
    when (s /= found) $ prettyFail $ fmsg ++ " but found '" ++ T.unpack found ++ "'"
    return ()

isOtherLetter :: Char -> Bool
isOtherLetter c = generalCategory c == OtherLetter

isUnderscore :: Char -> Bool
isUnderscore c = c == '_'

isAt :: Char -> Bool
isAt c = c == '@'

pOUword_ :: P T.Text
pOUword_ = do
    let fmsg = "expected a word_ starting with an uppercase letter"
    as <- many1Satisfy (\c -> isAlphaNum c || isUnderscore c) `adjustError` fmsg
    let f c = isUpper c || isOtherLetter c
    unless (f $ T.head as) $ prettyFail fmsg
    return as

pOLwordMaker :: (Char -> Bool) -> P T.Text
pOLwordMaker validChar = do
    let fmsg = "expected a word starting with a lowercase letter"
    as <- many1Satisfy validChar `adjustError` fmsg
    let f c = isLower c || isOtherLetter c
    unless (f $ T.head as) $ prettyFail fmsg
    return as

pOLword_ :: P T.Text
pOLword_ = pOLwordMaker (\c -> isAlphaNum c || isUnderscore c)

pOLwordAt_ :: P T.Text
pOLwordAt_ = do
    let validChar c = isAlphaNum c || isUnderscore c || isAt c
    let fmsg = "expected a word starting with a lowercase letter or '@'"
    as <- many1Satisfy validChar `adjustError` fmsg
    let f c = isLower c || isOtherLetter c || isAt c
    unless (f $ T.head as) $ prettyFail fmsg
    return as

mcmParsePackagePath :: T.Text -> Either [String] PackagePath
mcmParsePackagePath t = case runParser pPackagePath' initState t of
    (Left s, State(_, es), _) -> Left (s:reverse es)
    (Right pp, State(_, []), v) | T.null v -> Right pp
    (Right _, State(_, es), v) | T.null v -> Left $ reverse es
    (Right _, State(_, es), v) -> Left (("Failed to parse end: " ++ T.unpack v):reverse es)
    where
        pPackagePath' = do {r <- pPackagePath; eof; return r}

mcmParse :: T.Text -> Either [String] MCMFile
mcmParse t = case runParser pFile initState t of
    (Left s, State(_, es), _) -> Left (s:reverse es)
    (Right pp, State(_, []), v) | T.null v -> Right pp
    (Right _, State(_, es), v) | T.null v -> Left $ reverse es
    (Right _, State(_, es), v) -> Left (("Failed to parse end: " ++ T.unpack v):reverse es)

mcmLoadAndParse :: FilePath -> IO (Either [String] MCMFile)
mcmLoadAndParse f = do
    t <- TextIO.readFile f
    return $ mcmParse t

pFile :: P MCMFile
pFile = do
    pp <- pHeader
    pMaybeEmptyLinesAndComments
    is <- many pImport
    when (is /= []) pMaybeEmptyLinesAndComments
    packagelocals <- many pPackageLocals
    packagelocals' <- foldlM (checkUniqueAndUnion "packagelocal") Map.empty packagelocals
    unless (Map.null packagelocals') pMaybeEmptyLinesAndComments
    defines <- many (do {d <- pDefine; pMaybeEmptyLinesAndComments; return d})
    defines' <- foldlM (checkUniqueAndInsert "define") Map.empty defines
    ensureEof
    return $ MCMFile pp (Section is packagelocals' defines')

pHeader :: P PackagePath
pHeader = do
    keyword (T.pack "MCM")
    pSpaceButCheckOthers
    pp <- pPackagePath
    pJustNewline
    return pp

pMaybeEmptyLinesAndComments :: P ()
pMaybeEmptyLinesAndComments = do
    _ <- many $ oneOf [pJustNewline, pComment]
    return ()

pIndentAndMaybeComments :: P ()
pIndentAndMaybeComments = do
    pIndent
    _ <- many (do {pComment; pIndent `adjustError`
        "expected a tab to indent the line following the comment"})
    return ()

pIndent3AndMaybeComments :: P ()
pIndent3AndMaybeComments = do
    pIndent3
    _ <- many (do {pComment; pIndent3 `adjustError`
        "expected three tabs to indent the line following the comment"})
    return ()

pJustNewline :: P ()
pJustNewline = do
    c <- next
    unless (c == '\n') $ prettyFail "failed to match end of line"
    incNewline

pManyUntilNewline :: P T.Text
pManyUntilNewline = manySatisfy (/= '\n')

pComment :: P ()
pComment = do
    char '#'
    commit nop
    _ <- pManyUntilNewline
    pJustNewline

nop :: P ()
nop = return ()

pPackagePath :: P PackagePath
pPackagePath = do
    ps <- sepBy1 pOUword_ (char '.' >> commit nop) `adjustError`
        "failed to parse package path"
    return $ PackagePath ps

pImport :: P Import
pImport = do
    keyword (T.pack "import")
    pSpaceButCheckOthers
    pp <- pPackagePath
    pSpaceButCheckOthers
    keyword (T.pack "as")
    pSpaceButCheckOthers
    label <- pOUword_
    pJustNewline
    return $ Import pp label

pPackageLocals :: P (Map.Map Ident [Content])
pPackageLocals = pLocals

pLocals :: P (Map.Map Ident [Content])
pLocals = do
    keyword (T.pack "let")
    ls <- oneOf
        [do pSpaceButCheckSingleTab
            l <- pImmediateLocal
            ls <- many pIndentedLocal
            return (l:ls)
        ,pJustNewline >> many pIndentedLocal
        ] `adjustError` "Invalid syntax for 'let'"
    foldlM (checkUniqueAndInsert "local") Map.empty ls

pImmediateLocal :: P (Ident, [Content])
pImmediateLocal = do
    i <- fmap Ident pOLword_
    pSpaceButCheckOthers
    char '='
    c <- oneOf
        [pContent
        ,return []
        ]
    cs <- pArgMore
    pJustNewline
    return (i, c ++ cs)

pIndentedLocal :: P (Ident, [Content])
pIndentedLocal = do
    pIndent2
    pImmediateLocal

pContent :: P [Content]
pContent = do
    lineno <- lineNo
    ct <- pContentType pSpaceButCheckSingleTab
    c <- pManyUntilNewline
    toContent' lineno ct (Plain c)

pDefine :: P (DefName, Define)
pDefine = do
    keyword (T.pack "define")
    pSpaceButCheckOthers
    name <- fmap DefName pOLword_
    char '('
    args <- sepBy (fmap Ident pOLword_) (char ' ') `adjustError`
        "failed to parse define arguments"
    optargs <- oneOf
        [do {char ')'; return []}
        ,do {pJustNewline; r <- many pIndentedLocal; pIndent; char ')'; return r}
        ] `adjustError` "failed to parse arguments list"
    optargs' <- OptArgs <$> foldlM (checkUniqueAndInsert "optarg") Map.empty optargs
    pJustNewline
    (locals, condlocals, invokes) <- oneOf
        [do {pIndentAndMaybeComments; pDefine'}
        ,return (Locals Map.empty, [], [])
        ]
    return (name, Define name args optargs' locals condlocals invokes)

-- NB. Must parse something before the end of the define
--  (Comments don't count as "something")
pDefine' :: P (Locals, [CondLocal], [Invocation])
pDefine' = do
    locals <- sepBy pLocals pIndentAndMaybeComments `adjustError`
        "failed to parse define locals"
    (condlocals, invokes) <- if locals /= []
        then oneOf
            [do {pIndentAndMaybeComments; pDefine''}
            ,return ([], [])
            ]
        else pDefine''
    locals' <- Locals <$> foldlM (checkUniqueAndUnion "local") Map.empty locals
    return (locals', condlocals, invokes)

pDefine'' :: P ([CondLocal], [Invocation])
pDefine'' = do
    condlocals <- sepBy pCondLocal pIndentAndMaybeComments
    invokes <- if condlocals /= []
        then oneOf
            [do {pIndentAndMaybeComments; sepBy pInvoke pIndentAndMaybeComments}
            ,return []
            ]
        else sepBy pInvoke pIndentAndMaybeComments
    return (condlocals, invokes)

pCondLocal :: P CondLocal
pCondLocal = do
    keyword (T.pack "case")
    pSpaceButCheckOthers
    cond <- fmap Ident pOLword_
    pJustNewline
    whens <- many pWhen
    whensMaps <- foldlM (checkUniqueAndInsert "when") Map.empty whens
    let whenKeys = map (Map.keys . fromLocals . snd) whens
    let allTheSame [] = True
        allTheSame (x:xs) = all (==x) xs
    unless (allTheSame whenKeys) $
        addError $ unwords
            ["conditional mismatch:"
            ,show whenKeys
            ]
    return $ CondLocal cond whensMaps

pWhen :: P (Value, Locals)
pWhen = do
    pIndent
    keyword (T.pack "when")
    pSpaceButCheckOthers
    v <- fmap Value pManyUntilNewline
    pJustNewline
    locals <- many pIndentedLocal
    locals' <- foldlM (checkUniqueAndInsert "when local") Map.empty locals
    return (v, Locals locals')

pInvoke :: P Invocation
pInvoke = do
    cmd <- pInvokationCmd
    args <- many pArg
    args' <- InvocationArgs <$> foldlM (checkUniqueAndInsert "arg") Map.empty args
    pJustNewline
    return $ Invocation cmd args'

pInvokationCmd :: P InvocationCmd
pInvokationCmd = oneOf
    [do {char '.'; (InvLocal . UnexpandedDefName) <$> pOLwordAt_}
    ,do k <- pOUword_
        case T.unpack k of
            "Absent"   -> return InvAbsent
            "Dir"      -> return InvDir
            "Symlink"  -> return InvSymlink
            "File"     -> return InvFile
            "Fragment" -> return InvFragment
            _ -> oneOf
                [do char '.'
                    d <- pOLwordAt_
                    return $ InvImport k (UnexpandedDefName d)
                ,do addError $ "Unexpected command " ++ show k
                    return $ InvImport k (UnexpandedDefName $ T.pack "unexpectedCommand")
                ]
    ]

pArg :: P (Ident, [Content])
pArg = do
    oneOf
        [do {pJustNewline; pIndent2}
        ,pSpaceButCheckOthers
        ]
    i <- fmap Ident pOLword_
    a <- pInitialArg
    as <- pArgMore
    return (i, a ++ as)

pContentType :: P () -> P ContentType
pContentType spaceparser = oneOf
    [char '$' >> return CTDollar
    ,pNothingIfAtEndOfLine >> return CTSpace
    ,spaceparser >> return CTSpace
    ]

pInitialArg :: P [Content]
pInitialArg = oneOf
    [do char ':'
        lineno <- lineNo
        ct <- pContentType pSpaceButCheckSingleTab
        l <- pManyUntilNewline
        toContent' lineno ct (Plain l)
    ,do char '>'
        lineno <- lineNo
        ct <- pContentType pSpaceButCheckOthers
        l <- many1Satisfy (not . isSpace)
        toContent' lineno ct (Plain l)
    ]

pArgMore :: P [Content]
pArgMore = concat <$> many pArgCont

pArgCont :: P [Content]
pArgCont = do
    pJustNewline
    pIndent3AndMaybeComments
    lineno <- lineNo
    t <- oneOf
        [do {char '+'; return PrependNewline}
        ,do {char '\\'; return Plain}
        ] `adjustError` "was expecting '+' or '\\'"
    ct <- pContentType pSpaceButCheckSingleTab
    l <- pManyUntilNewline
    toContent' lineno ct (t l)

-- Parse nothing if at the end of the line already
pNothingIfAtEndOfLine :: P T.Text
pNothingIfAtEndOfLine = do
    cs <- pManyUntilNewline
    unless (T.null cs) $ prettyFail "expected end of line"
    return T.empty