never executed always true always false

    1 {-# LANGUAGE RecordWildCards #-}
    2 
    3 module Conjure.Language.Parser
    4   ( runLexerAndParser,
    5     lexAndParse,
    6     parseIO,
    7     parseModel,
    8     parseTopLevels,
    9     parseExpr,
   10     parseDomain,
   11     parseDomainWithRepr,
   12     prettyPrintWithChecks,
   13     Pipeline,
   14     PipelineError (..),
   15     runPipeline,
   16   )
   17 where
   18 
   19 import Conjure.Language.AST.ASTParser (ParserError, parseProgram, runASTParser)
   20 import Conjure.Language.AST.ASTParser qualified as P
   21 import Conjure.Language.AST.Helpers qualified as P
   22 import Conjure.Language.AST.Reformer (HighLevelTree (..), flatten)
   23 import Conjure.Language.AST.Syntax (DomainNode, ProgramTree)
   24 import Conjure.Language.AST.Syntax qualified as S
   25 import Conjure.Language.Definition
   26 import Conjure.Language.Domain
   27 import Conjure.Language.Lexer (ETokenStream, LexerError)
   28 import Conjure.Language.Lexer qualified as L
   29 import Conjure.Language.Pretty
   30 import Conjure.Language.Type (Type (..))
   31 import Conjure.Language.Validator ((?=>))
   32 import Conjure.Language.Validator qualified as V
   33 import Conjure.Prelude
   34 import Conjure.UI.ErrorDisplay (showDiagnosticsForConsole)
   35 import Data.Text qualified as T
   36 import Data.Void (Void)
   37 import Prettyprinter qualified as Pr
   38 import Text.Megaparsec (Parsec)
   39 
   40 type Pipeline a b = ((Parsec Void ETokenStream) a, a -> V.ValidatorS b, Bool)
   41 
   42 data PipelineError = LexErr LexerError | ParserError ParserError | ValidatorError Doc
   43   deriving (Show)
   44 
   45 instance Pretty PipelineError where
   46   pretty (ValidatorError d) = d
   47   pretty e = pretty $ show e
   48 
   49 lexAndParse :: (HighLevelTree a) => P.Parser a -> Text -> Either PipelineError a
   50 lexAndParse parse t = do
   51   lr <- either (Left . LexErr) Right $ L.runLexer t Nothing
   52   either (Left . ParserError) Right $ runASTParser parse lr
   53 
   54 runPipeline :: (HighLevelTree a) => Pipeline a b -> (Maybe FilePath, Text) -> Either PipelineError b
   55 runPipeline (parse, val, tc) (fp, txt) = do
   56   lexResult <- either (Left . LexErr) Right $ L.runLexer txt fp
   57   parseResult <- either (Left . ParserError) Right $ runASTParser parse lexResult
   58   let fileNameText = T.pack <$> fp
   59   let x = V.runValidator (val parseResult) (V.initialState parseResult fileNameText) {V.typeChecking = tc}
   60   case x of
   61     (m, ds, _) | not $ any V.isError ds -> Right m
   62     (_, ves, _) -> Left $ ValidatorError $ pretty (showDiagnosticsForConsole ves fp txt)
   63 
   64 parseModel :: Pipeline ProgramTree Model
   65 parseModel = (parseProgram, V.validateModel, True)
   66 
   67 parseIO :: (MonadFailDoc m, HighLevelTree i) => Pipeline i a -> String -> m a
   68 parseIO p s = do
   69   case runPipeline p $ (Just "IO", T.pack s) of
   70     Left err -> failDoc $ pretty $ show err
   71     Right x -> return x
   72 
   73 -- --------------------------------------------------------------------------------
   74 -- -- Actual parsers --------------------------------------------------------------
   75 -- --------------------------------------------------------------------------------
   76 
   77 parseTopLevels :: Pipeline [S.StatementNode] [Statement]
   78 parseTopLevels = (P.parseTopLevels, V.validateProgramTree, False)
   79 
   80 parseDomain :: Pipeline DomainNode (Domain () Expression)
   81 parseDomain = (P.parseDomain, fmap V.untype . V.validateDomain, True)
   82 
   83 parseDomainWithRepr :: Pipeline DomainNode (Domain HasRepresentation Expression)
   84 parseDomainWithRepr = (P.parseDomain, fmap V.untype . V.validateDomainWithRepr, True)
   85 
   86 parseExpr :: Pipeline S.ExpressionNode Expression
   87 parseExpr = (P.parseExpression, \x -> V.validateExpression x ?=> V.exactly TypeAny, True)
   88 
   89 runLexerAndParser :: (HighLevelTree n) => Pipeline n a -> String -> T.Text -> Either Doc a
   90 runLexerAndParser p file inp = case runPipeline p (Just file, inp) of
   91   Left pe -> Left $ pretty pe
   92   Right a -> Right a
   93 
   94 prettyPrintWithChecks :: (MonadFailDoc m) => Text -> m (Pr.Doc ann)
   95 prettyPrintWithChecks src = do
   96   v <- case lexAndParse parseProgram src of
   97     Left pe -> failDoc $ pretty $ show pe
   98     Right pt -> return pt
   99   return $ (if V.isSyntacticallyValid V.validateModel v then Pr.pretty else partialPretty) v
  100 
  101 partialPretty :: ProgramTree -> Pr.Doc ann
  102 partialPretty (S.ProgramTree lv sns lt) =
  103   Pr.vcat
  104     [ langVer,
  105       Pr.vcat $ map pTopLevel sns,
  106       Pr.pretty lt
  107     ]
  108   where
  109     langVer = case lv of
  110       Nothing -> "language Essence 1.3"
  111       Just _ -> if V.isSyntacticallyValid V.validateLanguageVersion lv then Pr.pretty lv else fallback lv
  112     fallback :: (HighLevelTree a) => a -> Pr.Doc ann
  113     fallback v = Pr.pretty $ L.reformList $ flatten v
  114     pTopLevel st = if V.isSyntacticallyValid V.validateStatement st then Pr.pretty st else fallback st