{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# LANGUAGE QuasiQuotes #-}
module ParserTest
  ( main
  ) where

import Data.ByteString.Lazy.Char8 ()
import Data.Either
import Data.List
import Test.HUnit

import TestRunner
import Compat.Prettyprinter.Render.Text
import Util.String.Quasi

import Glean.Angle.Parser
import Glean.Angle.Types
import Glean.Display
import Glean.Init
import Glean.Schema.Resolve

queryParser :: Test
queryParser = TestCase $ do
  let r = parseQuery "cxx1.Name \"foo\""
  either print (putDoc . displayDefault) r
  assertBool "simple query" $ case r of
    Right (SourceQuery Nothing [
      SourceStatement (Wildcard _) (App _ _pred [String _ _str])] _) -> True
    _ -> False

  -- lexer error
  let r = parseQuery "\""
  either print (putDoc . displayDefault) r
  assertBool "lexical error" $ case r of
    Left s -> "lexical error" `isPrefixOf` s
    _ -> False

  -- parse error
  let r = parseQuery "}"
  either print (putDoc . displayDefault) r
  assertBool "parse error" $ case r of
    Left s -> "line 1, column 1\nparse error at: }" `isPrefixOf` s
    _ -> False

  let r = parseQuery "A\n    where"
  either print (putDoc . displayDefault) r
  assertBool "parse error 2" $ case r of
    Left s -> "line 2, column 10\nparse error at: end of string" `isPrefixOf` s
    _ -> False


schemaParser :: Test
schemaParser = TestCase $ do
  -- schema parse errors, with #FILE
  let r = parseAndResolveSchema [s|
#FILE parsertest.angle
    parse error
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema parser 1" $ case r of
    Left s -> "line 1, column 5\nparsertest.angle:" `isInfixOf` s
    _ -> False

  -- empty enum is not allowed
  let r = parseSchema [s|
    schema a.1 {
      type X = enum {}
    }
  |]
  assertBool "schema parser 2" $ case r of
    Left s -> "parse error at: }" `isInfixOf` s
    _ -> False

  -- test all the constructs
  let r = parseAndResolveSchema [s|
    schema a.1 {}
    schema b.1 {}
    schema a.2 : a.1 {
      import b.1
      type Y =
        {
          x1  : byte,
          x2  : nat,
          x3  : string,
          x4  : bool,
          x5  : [X],
          x6  : {},  # empty record
          x7  : { a : X },  # singleton record
          x8  : { a : X, },  # trailing comma in a record
          x9  : { a : X, b : Y },
          # field names can be keywords:
          x10 : { nat : nat },
          x11 : { a : X | },  # singleton sum type
          x12 : { a : X | b : Y },
          x13 : { a : X | b : Y | }, # trailing |
          x14 : { nothing | just : string },
          x15 : enum { a },
          x16 : enum { a | b },
          x17 : maybe X,
          x18 : maybe (maybe {}),  # parens
        }
      predicate X : Y

      # predicate names can also be keywords
      predicate type : { nat | bool_ }
    }
  #last line can be a comment|]
  either print (putDoc . displayDefault . fst) r
  putStr "\n"
  assertBool "schema parser 1" $ case r of
    Right _ -> True
    _ -> False


schemaResolver :: Test
schemaResolver = TestCase $ do
  -- schemas must have versions
  let r = parseAndResolveSchema [s|
    schema test {}
  |]
  assertBool "schema resolver 1" $ case r of
    Left s -> "missing version" `isInfixOf` s
    _ -> False

  -- cycles aren't allowed
  let r = parseAndResolveSchema [s|
    schema test.1 : test.1 {}
  |]
  assertBool "schema resolver 2" $ case r of
    Left s -> "cycle" `isInfixOf` s
    _ -> False

  -- a bigger cycle
  let r = parseAndResolveSchema [s|
    schema test.1 { import test.2 }
    schema test.2 : test.1 {}
  |]
  assertBool "schema resolver 3" $ case r of
    Left s -> "cycle" `isInfixOf` s
    _ -> False

  -- schemas parent must exist
  let r = parseAndResolveSchema [s|
    schema test.2 : test.1 {}
  |]
  assertBool "schema resolver 4" $ case r of
    Left s -> "unknown schema: test.1" `isInfixOf` s
    _ -> False

  -- schema import must exist
  let r = parseAndResolveSchema [s|
    schema test.2 { import test.1 }
  |]
  assertBool "schema resolver 5" $ case r of
    Left s -> "unknown schema: test.1" `isInfixOf` s
    _ -> False

  -- schema import does not re-export
  let r = parseAndResolveSchema [s|
    schema test.1 { type X = nat }
    schema test.2 { import test.1 }
    schema test.3 {
      import test.2
      type Y = test.X
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 6" $ case r of
    Left s -> "not in scope: test.X" `isInfixOf` s
    _ -> False

  -- 1. unversioned predicates get the schema version
  -- 2. we can use an explicit version if we want
  let r = parseAndResolveSchema [s|
    schema test.3 {
      predicate X : string
      predicate Y.2 : X.3
    }
    schema foo.1 {
      import test.3
      predicate Z : { a: test.Y.2, b: test.X.3 }
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 7" $ isRight r

  -- imported names are not in scope unqualified
  let r = parseAndResolveSchema [s|
    schema test.1 { type X = nat }
    schema test.2 {
      import test.1
      type Y = X
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 8" $ case r of
    Left s -> "not in scope: X" `isInfixOf` s
    _ -> False

  -- ambiguity
  let r = parseAndResolveSchema [s|
    schema a.1 { type X = nat }
    schema a.2 { type X = string }
    schema test.1 {
      import a.1
      import a.2
      type Y = a.X
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 9" $ case r of
    Left s -> "a.X is ambiguous" `isInfixOf` s
    _ -> False

  -- ambiguity from multiple inheritance
  let r = parseAndResolveSchema [s|
    schema a.1 { type X = nat }
    schema b.1 { type X = string }
    schema test.1 : a.1, b.1 {
      type Y = X
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 10" $ case r of
    Left s -> "inherited schemas give multiple definitions for: X" `isInfixOf` s
    _ -> False

  -- resolve ambiguity by specifying a version
  let r = parseAndResolveSchema [s|
    schema a.1 { type X = nat }
    schema a.2 { type X = string }
    schema test.1 {
      import a.1
      import a.2
      type Y = a.X.2
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 11" $ isRight r

  -- no ambiguity when we inherit
  let r = parseAndResolveSchema [s|
    schema a.1 { type X = nat }
    schema a.2 : a.1 { type X = string }
    schema test.1 {
      import a.2
      type Y = a.X  # picks the latest version of a.X
    }
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 12" $ isRight r

  let r = parseAndResolveSchema [s|
    schema a.1 { type X = nat }
    schema a.2 : a.1 { type X = string }
    schema a.3 : a.2 {
      type Y = X
    }
    # should be legal to inherit from both a.2 and a.3, because X
    # refers to the same thing.
    schema test.1 : a.2, a.3 {}
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 12a" $ isRight r

  let r = parseAndResolveSchema [s|
    schema a.1 { type X = nat }
    schema a.2 : a.1 { type X = string }
    schema a.3 : a.2 {
      type Y = X
    }
    # but illegal to inherit from a.1 and a.3, because X refers to
    # different things.
    schema test.1 : a.1, a.3 {}
  |]
  either print (putDoc . displayDefault . fst) r
  assertBool "schema resolver 12b" $ case r of
    Left s -> "inherited schemas give multiple definitions for: X" `isInfixOf` s
    _ -> False

  -- duplicate definitions
  let r = parseAndResolveSchema [s|
    schema test.1 {
       predicate X : nat
       predicate X.1 : string
    }
  |]
  assertBool "schema resolver 13" $ case r of
    Left s -> "multiple definitions for: test.X.1" `isInfixOf` s
    _ -> False

  -- type and predicate with the same name
  let r = parseAndResolveSchema [s|
    schema test.1 {
       predicate X : nat
       type X = nat
    }
  |]
  assertBool "schema resolver 14" $ case r of
    Left s -> "multiple definitions for: test.X.1" `isInfixOf` s
    _ -> False

  -- duplicate field names
  let r = parseAndResolveSchema [s|
    schema test.1 {
       predicate X : { a: nat, a: string }
    }
  |]
  assertBool "schema resolver 15" $ case r of
    Left s -> "duplicate field: a" `isInfixOf` s
    _ -> False

  -- reserved words are not allowed
  let r = parseAndResolveSchema [s|
    schema a.1 {
      predicate class : string
    }
  |]
  assertBool "schema resolver 16" $ case r of
    Left s -> "class is a reserved word" `isInfixOf` s
    _ -> False


main :: IO ()
main = withUnitTest $ testRunner $ TestList
  [ TestLabel "query" queryParser
  , TestLabel "schema" schemaParser
  , TestLabel "resolve" schemaResolver
  ]