content: {-|
  Module      : MasterPlan.Parser
  Description : export parser for project systems
  Copyright   : (c) Rodrigo Setti, 2017
  License     : MIT
  Maintainer  : rodrigosetti@gmail.com
  Stability   : experimental
  Portability : POSIX
  -}
  {-# LANGUAGE OverloadedLists   #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE UnicodeSyntax     #-}
  module MasterPlan.Parser (ProjectKey, runParser) where
  
  import           Control.Monad.State
  import qualified Data.List.NonEmpty         as NE
  import           Data.Maybe                 (fromMaybe, isJust)
  import qualified Data.Scientific            as Sci
  import qualified Data.Text                  as T
  import           Data.Void
  import           MasterPlan.Data
  import           Text.Megaparsec            hiding (State, runParser)
  import           Text.Megaparsec.Char
  import qualified Text.Megaparsec.Char.Lexer as L
  import           Text.Megaparsec.Expr
  
  type Parser = Parsec Void T.Text
  
  -- |Space consumer
  sc ∷ Parser ()
  sc = L.space space1 (L.skipLineComment "//") $
                       L.skipBlockComment "/*" "*/"
  
  lexeme ∷ Parser a → Parser a
  lexeme = L.lexeme sc
  
  symbol ∷ T.Text → Parser T.Text
  symbol = L.symbol sc
  
  -- | 'parens' parses something between parenthesis.
  parens ∷ Parser a → Parser a
  parens = between (symbol "(") (symbol ")")
  
  -- |list of reserved words
  rws ∷ [String]
  rws = map show [minBound :: ProjAttribute ..]
  
  identifier ∷ Parser String
  identifier = (lexeme . try) $ (:) <$> letterChar <*> many alphaNumChar
  
  projectKey :: Parser String
  projectKey = (identifier >>= check) <?> "project key"
    where
      check x
        | x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier"
        | otherwise    = pure x
  
  stringLiteral :: Parser String
  stringLiteral = char '"' >> manyTill L.charLiteral (char '"')
  
  percentage :: Parser Float
  percentage = do n <- Sci.toRealFloat <$> L.scientific <?> "percentage value"
                  when (n > 100) $ fail $ "number " ++ show n ++ " is not within (0,100) range"
                  void $ symbol "%"
                  pure $ n / 100
  
  -- |Parses the part of right-hand-side after the optional properties
  --  (literal string title or properties between curly brackets)
  expression ∷ ProjectProperties -> Parser (Project ProjectKey)
  expression props =
      simplify <$> makeExprParser term table <?> "expression"
    where
      term =  parens (expression defaultProjectProps) <|> (Annotated <$> projectKey)
      table = [[binary "*" (combineWith Product)]
              ,[binary "->" (combineWith Sequence)]
              ,[binary "+" (combineWith Sum)]]
      binary  op f = InfixL (f <$ symbol op)
  
      combineWith c p1 p2 = c props $ p1 NE.<| [p2]
  
  -- |Parses the entire right-hand-side of definitions
  binding :: ProjectKey -> Parser (Project ProjectKey)
  binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttributes <|> noAttributes
                   case (mc, mt, mp) of
                    (Nothing, Nothing, Nothing) ->
                       try (sc *> optional (symbol "=") *> expression props) <|>
                         pure (Atomic props defaultCost defaultTrust defaultProgress)
                    (mc', mt', mp') -> pure $ Atomic props
                                                     (fromMaybe defaultCost mc')
                                                     (fromMaybe defaultTrust mt')
                                                     (fromMaybe defaultProgress mp')
   where
     attrKey :: Parser ProjAttribute
     attrKey = do n <- identifier <?> "attribute name"
                  case lookup n [(show a, a) | a <- [minBound::ProjAttribute ..]] of
                    Nothing -> fail $ "invalid attribute: \"" ++ n ++ "\""
                    Just a  -> pure a
  
     simpleTitle, bracketAttributes, noAttributes :: Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)
     simpleTitle = do s <- stringLiteral <?> "title"
                      pure (defaultProjectProps {title= Just s}, Nothing, Nothing, Nothing)
  
     bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=Just key}) Nothing Nothing Nothing
  
     noAttributes = pure (defaultProjectProps {title=Just key}, Nothing, Nothing, Nothing)
  
     attributes :: ProjectProperties -> Maybe Cost -> Maybe Trust -> Maybe Progress
                -> Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)
     attributes props mc mt mp =
       try (sc *> symbol "}" *> pure (props, mc, mt, mp)) <|>
           do attr <- sc *> attrKey
              case attr of
                PTitle -> do s <- stringLiteral <?> "title"
                             attributes (props {title=Just s}) mc mt mp
                PDescription -> do when (isJust $ description props) $ fail "redefinition of description"
                                   s <- stringLiteral <?> "description"
                                   attributes (props {description=Just s}) mc mt mp
                PUrl -> do when (isJust $ url props) $ fail "redefinition of url"
                           s <- stringLiteral <?> "url"
                           attributes (props {url=Just s}) mc mt mp
                POwner -> do when (isJust $ owner props) $ fail "redefinition of owner"
                             s <- stringLiteral <?> "owner"
                             attributes (props {owner=Just s}) mc mt mp
                PCost -> do when (isJust mc) $ fail "redefinition of cost"
                            c <- Cost <$> Sci.toRealFloat <$> L.scientific <?> "cost"
                            attributes props (Just c) mt mp
                PTrust -> do when (isJust mt) $ fail "redefinition of cost"
                             t <- Trust <$> percentage <?> "trust"
                             attributes props mc (Just t) mp
                PProgress -> do when (isJust mp) $ fail "redefinition of progress"
                                p <- Progress <$> percentage <?> "progress"
                                attributes props mc mt (Just p)
  
  
  -- |Parses the entire plan file, given the name of the "root" project.
  --  returns this project
  plan :: Bool -- ^ strict mode: fails if a reference has no definition
       -> ProjectKey -- ^ the name of the root project
       -> Parser ProjectExpr
  plan strictMode root =
      do bindings <- definitions []
         case lookup root bindings of
           Nothing -> fail $ "root project \"" ++ root ++ "\" is undefined"
           Just p  -> resolveReferences bindings [root] p
   where
  
     -- definitions will parse into a list of tuples: (key, Project ProjectKey)
     definitions :: [(ProjectKey, Project ProjectKey)] -> Parser [(ProjectKey, Project ProjectKey)]
     definitions ds = do key <- sc *> projectKey
                         when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ key ++ "\""
                         b <- binding key <* symbol ";"
                         let ds' = (key,b):ds
                         (try eof *> pure ds') <|> definitions ds'
  
     resolveReferences :: [(ProjectKey, Project ProjectKey)]
                       -> [ProjectKey]
                       -> Project ProjectKey
                       -> Parser ProjectExpr
     resolveReferences bs ks (Sum r ps) = Sum r <$> mapM (resolveReferences bs ks) ps
     resolveReferences bs ks (Sequence r ps) = Sequence r <$> mapM (resolveReferences bs ks) ps
     resolveReferences bs ks (Product r ps) = Product r <$> mapM (resolveReferences bs ks) ps
     resolveReferences bs ks (Annotated k)
        | k `elem` ks  = fail $ "definition of \"" ++ k ++ "\" is recursive"
        | otherwise = case lookup k bs of
                        Nothing
                         | strictMode -> fail $ "project \"" ++ k ++ "\" is undefined"
                         | otherwise -> pure $ Atomic defaultProjectProps {title=Just k}
                                                      defaultCost defaultTrust defaultProgress
                        Just p  -> resolveReferences bs (k:ks) p
     resolveReferences _ _ (Atomic r c t p) = pure $ Atomic r c t p
  
  runParser :: Bool -- ^ strict mode: fails if a reference has no definition
            -> FilePath -- ^ the file name to use in error messages
            -> T.Text -- ^ contents of the plan to parse
            -> ProjectKey -- ^ the name of the root project
            -> Either String ProjectExpr
  runParser strictMode filename contents root =
    case parse (plan strictMode root) filename contents of
        Left e  -> Left $ parseErrorPretty' contents e
        Right v -> Right v
  