Resolve.hs

{-
  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 DeriveGeneric #-}

module Glean.Schema.Resolve
  ( parseAndResolveSchema
  , parseAndResolveSchemaCached
  , SchemaParserCache
  , resolveType
  , resolveSchema
  , runResolve
  , resolveQuery
  , resolveSchemaRefs
  ) where

import Control.Monad
import Control.Monad.Reader
import Control.Monad.Except
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import Data.Char
import Data.Graph
import Data.Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Compat.Prettyprinter hiding (group)
import TextShow

import Glean.Angle.Hash
import Glean.Angle.Parser
import Glean.Angle.Types
import Glean.Schema.Types
import Glean.Schema.Util
import Glean.Schema.Evolve (validateResolvedEvolutions)

type SchemaParserCache = HashMap Hash SourceSchemas

-- ---------------------------------------------------------------------------
-- High-level schema parsing / resolution APIs

--
-- | Useful packaging of 'parseSchema' and 'resolveSchema'. Note that
-- parsing and resolution of a schema is a pure function.
--
parseAndResolveSchema
  :: ByteString
  -> Either String (SourceSchemas, ResolvedSchemas)
parseAndResolveSchema str =
  case parseSchema str of
    Left str -> Left str
    Right ss -> case resolveSchema ss of
      Left txt -> Left (Text.unpack txt)
      Right r -> Right (ss, r)

--
-- | Like parseAndResolveSchema but uses a cache to avoid repeatedly
-- parsing the same schema fragments.
--
-- We split the input string at "schema" declarations and hash the
-- content of each one to use as the cache key. There are a couple of
-- caveats here:
--
--  * we lose the benefit of the FILE annotations that tell us the
--    original source file name for error messages. Therefore don't
--    use this parsing method when you want error messages; use
--    the uncached parseAndResolveSchema instead.
--
--  * "schema" should appear in column 0. But if it doesn't, the worst
--    that can happen is we miss out on some caching. Since "schema" is
--    a keyword, it can't appear inside a schema or anything silly like
--    that.
--
parseAndResolveSchemaCached
  :: SchemaParserCache
  -> ByteString
  -> Either String (SourceSchemas, ResolvedSchemas, SchemaParserCache)
parseAndResolveSchemaCached cache str = do
  let
    (ver, rest) = stripAngleVersion str

    cutSchemas b =
      (h <> "\n") : -- put the "\n" back on the end
        if ByteString.null t
          then []
          else cutSchemas (ByteString.drop 1 t) -- drop the "\n"
      where (h,t) = ByteString.breakSubstring "\nschema" b

    schemaFragments =
      [ (hashByteString frag, frag)
      | frag <- cutSchemas rest ]

  parsed <- forM schemaFragments $ \(key, str) ->
    case HashMap.lookup key cache of
      Nothing -> case parseSchemaWithVersion ver str of
        Left err -> Left err
        Right ss -> return (key, ss)
      Just cached -> return (key, cached)

  let
    merged = SourceSchemas
      { srcAngleVersion = ver
      , srcSchemas = schemas
      , srcEvolves = evolves }
      where
        schemas = concatMap (srcSchemas . snd) parsed
        evolves = concatMap (srcEvolves . snd) parsed

    newCache = HashMap.union cache (HashMap.fromList parsed)

  case resolveSchema merged of
    Left txt -> Left (Text.unpack txt)
    Right r -> Right (merged, r, newCache)

--
-- | Turn 'SourceSchemas' into a 'ResolvedSchemas' by resolving all the
-- references and checking for validity.
--
resolveSchema :: SourceSchemas -> Either Text ResolvedSchemas
resolveSchema schemas = runExcept $ do
  checkAngleVersion (srcAngleVersion schemas)

  SourceSchemas{..} <- resolveSchemaRefs schemas

  let
    -- dependency analysis: we want to process schemas in dependency
    -- order, and detect cycles in evolves declarations.
    sccs = stronglyConnComp
      [ (schema, schemaName schema, out schema)
      | schema <- srcSchemas ]

    out s = schemaDependencies s <> evolvesOf (schemaName s)

    schemaDependencies SourceSchema{..} =
      schemaInherits ++ [ name | SourceImport name _ <- schemaDecls ]

    evolves = HashMap.fromListWith (++)
      [ (new, [old])
      | SourceEvolves _ new old <- srcEvolves
      ]

    evolvesOf name = HashMap.lookupDefault [] name evolves

    resolveSchemas env [] = return env
    resolveSchemas env (AcyclicSCC one : rest) = do
      let schemaEvolves = HashMap.lookupDefault [] (schemaName one) evolves
      resolved <- resolveOneSchema env srcAngleVersion
        schemaEvolves one
      resolveSchemas (HashMap.insert (schemaName one) resolved env) rest
    resolveSchemas _ (CyclicSCC some : _) = throwError $
      "cycle in schema definitions between: " <>
        Text.intercalate ", " (map (showRef . schemaName) some)

  -- Resolve all the references in each individual schema
  finalEnv <- resolveSchemas HashMap.empty sccs

  let
    resolved =
        [ schema
        | AcyclicSCC one <- sccs
        , Just schema <- [HashMap.lookup (schemaName one) finalEnv ] ]

    allSchemas =
      [ schema
      | schema@ResolvedSchema{..} <- HashMap.elems finalEnv
      , resolvedSchemaName == "all"
      ]

  when (srcAngleVersion >= AngleVersion 6) $
    liftEither $ validateResolvedEvolutions resolved

  return ResolvedSchemas
    { schemasHighestVersion =
        if null allSchemas
           then Nothing
           else Just (maximum $ map resolvedSchemaVersion allSchemas)
    , schemasResolved = resolved
    }


resolveSchemaRefs :: SourceSchemas -> Except Text SourceSchemas
resolveSchemaRefs SourceSchemas{..} = do
  let
     unqualMap
       | srcAngleVersion >= AngleVersion 10 =
         HashMap.fromListWith (<>)
           [ (SourceRef name Nothing, HashSet.singleton ref)
           | SourceSchema{..} <- srcSchemas
           , let ref@(SourceRef name _) = schemaName
           ]
       | otherwise = HashMap.empty

     refMap = unqualMap <> HashMap.fromList
       [ (schemaName, HashSet.singleton schemaName)
       | SourceSchema{..} <- srcSchemas
       ]

     schemaByName ref =
       case HashMap.lookup ref refMap of
         Nothing -> unknown
         Just s -> case HashSet.toList s of
           [one] -> return one
           names -> throwError $
             "ambiguous schema " <> showRef ref <>
             ", could be one of " <> Text.intercalate ", " (map showRef names)
       where
       unknown = throwError $ "unknown schema: " <> showRef ref

     schemaByNameWithNamespace parentSchema ref =
       let message e = e <> " within schema: " <> showRef parentSchema
       in withExcept message (schemaByName ref)

     resolveDecl parentSchema (SourceImport r s) =
      SourceImport <$> schemaByNameWithNamespace parentSchema r <*> pure s
     resolveDecl _ decl = return decl

     resolveEvolve (SourceEvolves l n o) =
       SourceEvolves l <$> schemaByName n <*> schemaByName o

     resolveSchema SourceSchema{..} = do
       inherits <- mapM (schemaByNameWithNamespace schemaName) schemaInherits
       decls <- mapM (resolveDecl schemaName) schemaDecls
       return SourceSchema
         { schemaName = schemaName
         , schemaInherits = inherits
         , schemaDecls = decls
         , schemaSrcSpan = schemaSrcSpan
         }

  schemas <- traverse resolveSchema srcSchemas
  evolves <- traverse resolveEvolve srcEvolves

  return SourceSchemas
    { srcAngleVersion = srcAngleVersion
    , srcSchemas = schemas
    , srcEvolves = evolves
    }

type Environment = HashMap SourceRef ResolvedSchemaRef

resolveOneSchema
  :: Environment
  -> AngleVersion
  -> [SourceRef]
  -> SourceSchema
  -> Except Text ResolvedSchemaRef

resolveOneSchema env angleVersion evolves SourceSchema{..} =
  let inSchema e = throwError $ "In " <> showRef schemaName <> ":\n  " <> e in
  flip catchError inSchema $ do
  let
    SourceRef namespace maybeVer = schemaName

    schemaByName name = case HashMap.lookup name env of
      Nothing -> throwError $ "unknown schema: " <> showRef name
      Just one -> return one

  checkNameSpace namespace

  -- Version of this schema
  version <- case maybeVer of
    Nothing -> throwError $ "missing version: " <> showRef schemaName
    Just v -> return v

  -- All the schemas we're inheriting from
  inherits <- traverse schemaByName schemaInherits

  -- All the schemas we imported
  imports <- traverse schemaByName [ name | SourceImport name _ <- schemaDecls ]

  let
    qualify :: Name -> Name
    qualify x = namespace <> "." <> x

    qualifyNameEnv :: NameEnv t -> NameEnv t
    qualifyNameEnv env = HashMap.fromList
      [ (SourceRef (qualify name) ver, target)
      | (SourceRef name ver, target) <- HashMap.toList env ]

    localPreds =
      [ let
          SourceRef name explicitVersion = predicateDefRef p
          thisVersion = fromMaybe version explicitVersion
          qname = qualify name
        in
          (name, PredicateRef qname thisVersion, p)
      | SourcePredicate p <- schemaDecls
      ]

    localTypes =
      [ let
          SourceRef name explicitVersion = typeDefRef p
          thisVersion = fromMaybe version explicitVersion
          qname = qualify name
        in
          (name, TypeRef qname thisVersion, p)
      | SourceType p <- schemaDecls
      ]

  -- Check for multiple definitions of the same name/version.
  -- Multiple definitions of the same name is OK: an unqualified
  -- reference will be rejected as ambiguous, but can be resolved by
  -- using an explicit version.
  let
    numRefs = HashMap.fromListWith (+) $
      [ ((predicateRef_name, predicateRef_version), 1::Int)
      | (_, PredicateRef{..}, _) <- localPreds ] ++
      [ ((typeRef_name, typeRef_version), 1)
      | (_, TypeRef{..}, _) <- localTypes]
  forM_ (HashMap.toList numRefs) $ \((name,ver), num) -> do
    when (num > 1) $ throwError $
      "multiple definitions for: " <> name <> "." <> showt ver

  -- Build the scope: a mapping from unversioned names to RefTarget
  let
    -- inherited definitions are in scope unqualified and qualified
    --   (but unqualified local names override unqualified inherited names)
    qualInheritedScope :: NameEnv RefResolved
    qualInheritedScope =
      unionNameEnvs $ map resolvedSchemaQualScope inherits

    unqualInheritedScope :: NameEnv RefResolved
    unqualInheritedScope =
      unionNameEnvs $ map resolvedSchemaUnqualScope inherits

    -- imported names are in scope qualified only
    importedScope :: NameEnv RefResolved
    importedScope = unionNameEnvs $ map resolvedSchemaQualScope imports

    unionNameEnvs :: [NameEnv RefResolved] -> NameEnv RefResolved
    unionNameEnvs = foldl' (HashMap.unionWith Set.union) HashMap.empty

    nameEntries name ver target =
      [ (SourceRef name Nothing, set),
        (SourceRef name (Just ver), set) ]
      where set = Set.singleton target

    -- local definitions are in scope unqualified and qualified
    unqualLocalScope :: NameEnv RefResolved
    unqualLocalScope = HashMap.fromListWith Set.union unqualLocalEntities

    qualLocalScope :: NameEnv RefResolved
    qualLocalScope = qualifyNameEnv unqualLocalScope

    unqualLocalEntities =
      -- P and P.1 for each local predicate
      [ entry
      | (name, r, _) <- localPreds
      , entry <- nameEntries name (predicateRef_version r) (RefPred r)
      ] ++
      -- T and T.1 for each local type
      [ entry
      | (name, r, _) <- localTypes
      , entry <- nameEntries name (typeRef_version r) (RefType r)
      ]

    scope =
      HashMap.union unqualLocalScope $
      HashMap.union unqualInheritedScope $
      HashMap.unionWith Set.union qualLocalScope $
      HashMap.unionWith Set.union qualInheritedScope
      importedScope

  -- Check for inheriting multiple versions of a predicate/types
  --
  -- As a special case, if the schema is called "all" then allow name
  -- clashes in the inheritance set. This is to facilitate our "all.N"
  -- convention for declaring the "top-level" schema which will
  -- inevitably have name clashes, but we don't care about what it
  -- exports.
  unless (namespace == "all") $
    forM_ (HashMap.toList unqualInheritedScope) $ \(ref, targets) -> do
      case Set.elems targets of
        (_:_:_) -> throwError $
          "inherited schemas give multiple definitions for: " <> showRef ref
        _ -> return ()

  -- resolve type definitions
  types <- forM localTypes $
    \(name, ref, TypeDef{..}) -> do
      checkName name
      type' <- runResolve angleVersion scope (resolveType typeDefType)
      return (name, TypeDef
        { typeDefRef = ref
        , typeDefType = type'
        , typeDefSrcSpan = typeDefSrcSpan })

  -- resolve predicate definitions
  predicates <- forM localPreds $
    \(name, ref, PredicateDef{..}) -> do
      checkName name
      runResolve angleVersion scope $ do
        key <- resolveType predicateDefKeyType
        value <- resolveType predicateDefValueType
        return (name, PredicateDef
          { predicateDefRef = ref
          , predicateDefKeyType = key
          , predicateDefValueType = value
          , predicateDefDeriving = NoDeriving
          , predicateDefSrcSpan = predicateDefSrcSpan })

  let
    -- scope of predicates that we can specify queries for. Namely
    -- locally-defined predicates and inherited predicates.
    predScope = resolveRef $
      HashMap.union unqualLocalScope $
      HashMap.union unqualInheritedScope $
      HashMap.unionWith Set.union qualLocalScope
      qualInheritedScope

  -- resolve queries
  localDeriving <-
    forM [ (derivingDefRef,derive)
      | SourceDeriving derive@DerivingDef{..} <- schemaDecls ] $
    \(ref, DerivingDef{..}) -> do
      ty <- lookupResultToExcept ref $ predScope ref
      ref <- case ty of
        RefPred ref -> return ref
        _ -> throwError $ showRef ref <> " is not a predicate"
      resolvedDerInfo <- runResolve angleVersion scope $
        resolveDeriving derivingDefDeriveInfo
      return (ref, DerivingDef ref resolvedDerInfo derivingDefSrcSpan)

  let
    localTypeNames = HashSet.fromList $
      map (typeRef_name . typeDefRef . snd) types

    localTypes = HashMap.fromList
      [ (typeDefRef def, def) | (_, def) <- types ]

    -- The types we re-export from this schema are all the types that
    -- are inherited but not shadowed by a locally-defined type.
    reExportedTypes =
      HashMap.fromList
        [ (typeDefRef def, def)
        | schema <- inherits
        , (ref, def) <- HashMap.toList $
            resolvedSchemaTypes schema <>
            resolvedSchemaReExportedTypes schema
        , not (typeRef_name ref `HashSet.member` localTypeNames)
        ]

    localPredicateNames = HashSet.fromList $
      [ predicateRef_name (predicateDefRef def) | (_, def) <- predicates ]

    localPredicates = HashMap.fromList
      [ (predicateDefRef def, def) | (_, def) <- predicates ]

    -- Similarly for predicates.
    reExportedPredicates =
      HashMap.fromList
        [ (predicateDefRef def, def)
        | schema <- inherits
        , (ref, def) <- HashMap.toList $
            resolvedSchemaPredicates schema <>
            resolvedSchemaReExportedPredicates schema
        , not (predicateRef_name ref `HashSet.member` localPredicateNames)
        ]

    exportedUnqualScope = HashMap.union unqualLocalScope unqualInheritedScope
      -- Note: local names override inherited names

    -- Qualified exported names. The "all" schema is special: we don't
    -- re-export things qualified with "all.", only with the original
    -- schema name.
    exportedQualScope
      | namespace == "all" = qualInheritedScope
      | otherwise =
         HashMap.union
           (qualifyNameEnv exportedUnqualScope)
           qualInheritedScope -- NB. local overrides inherited

  schemaEvolves <- traverse schemaByName evolves

  return ResolvedSchema
    { resolvedSchemaName = namespace
    , resolvedSchemaVersion = version
    , resolvedSchemaAngleVersion = angleVersion
    , resolvedSchemaTypes = localTypes
    , resolvedSchemaReExportedTypes = reExportedTypes
    , resolvedSchemaPredicates = localPredicates
    , resolvedSchemaReExportedPredicates = reExportedPredicates
    , resolvedSchemaUnqualScope = exportedUnqualScope
    , resolvedSchemaQualScope = exportedQualScope
    , resolvedSchemaDeriving = HashMap.fromList localDeriving
    , resolvedSchemaEvolves = Set.fromList (schemaRef <$> schemaEvolves)
    }

resolveType :: (ShowRef t, ShowRef p) =>
  SourceType -> Resolve p t (Type_ SrcSpan p t)
resolveType typ = go typ
  where
  go typ = case typ of
    ByteTy -> return ByteTy
    NatTy -> return NatTy
    StringTy -> return StringTy
    ArrayTy ty -> ArrayTy <$> go ty
    RecordTy fields -> do checkFields fields; RecordTy <$> mapM goField fields
    SumTy fields -> do checkFields fields; SumTy <$> mapM goField fields
    SetTy ty -> SetTy <$> go ty
    PredicateTy s ref -> goRef ref s
    NamedTy s ref -> goRef ref s -- shouldn't happen, but handle it anyway
    MaybeTy ty -> MaybeTy <$> go ty
    EnumeratedTy names -> lift $ do
      mapM_ checkName names
      return (EnumeratedTy names)
    BooleanTy -> return BooleanTy
    _ -> error "resolveType"

  goRef ref s = do
    scope <- getScope
    target <- lift $ lookupResultToExcept ref $
      resolveRef scope ref
    case target of
      RefType ref -> return (NamedTy s ref)
      RefPred ref -> return (PredicateTy s ref)

  checkFields fields = do
    sequence_
      [ throwError $ "duplicate field: " <> x
        | x:_:_ <- group $ sort $ map fieldDefName fields ]
    lift $ do
      mapM_ (checkName . fieldDefName) fields
      mapM_ (checkFieldName . fieldDefName) fields

  goField (FieldDef name ty) = FieldDef name <$> go ty


lookupResultToExcept
  :: (ShowRef t, ShowRef p)
  => SourceRef
  -> LookupResult (RefTarget p t)
  -> Except Text (RefTarget p t)
lookupResultToExcept ref res =
  either throwError return (lookupResultToEither ref res)

checkAngleVersion :: AngleVersion -> Except Text ()
checkAngleVersion v =
  unless (v >= latestSupportedAngleVersion) $
    let ver = Text.pack $ show $ pretty v in
    throwError $ "Angle version " <> ver <> " is not supported"

checkFieldName :: Name -> Except Text ()
checkFieldName n =
  when (isUpper (Text.head n)) $
    throwError $ "field names must begin with a lowercase letter: " <> n

checkName :: Name -> Except Text ()
checkName n = do
  when (n `HashSet.member` reservedWords) $
    throwError $ n <> " is a reserved word, it cannot be used"

checkNameSpace :: Name -> Except Text ()
checkNameSpace n = mapM_ checkName (splitDot n)

reservedWords :: HashSet Text
reservedWords = HashSet.fromList [
    -- Thrift reserved words, seems like a good idea to avoid these
    "binary", "bool", "byte", "const", "cpp_include",
    "double", "enum", "exception", "extends", "false", "float",
    "hash_map", "hash_set", "hs_include", "i16", "i32", "i64", "include",
    "list", "map", "namespace", "oneway", "optional", "required", "senum",
    "service", "set", "stream", "string", "struct", "throws", "true",
    "typedef", "union", "view", "void",

    -- keywords that the fbthrift compiler rejects (see
    -- thrift/compiler/parse/thrift.ll)
    "abstract",
    "and",
    "args",
    "as",
    "assert",
    "auto",
    "break",
    "case",
    "char",
    "class",
    "continue",
    "declare",
    "def",
    "default",
    "del",
    "do",
    "elif",
    "else",
    "elseif",
    "except",
    "exec",
    "extern",
    "finally",
    "for",
    "foreach",
    "function",
    "global",
    "goto",
    "if",
    "implements",
    "import",
    "in",
    "int",
    "inline",
    "instanceof",
    "interface",
    "is",
    "lambda",
    "long",
    "native",
    "new",
    "not",
    "or",
    "pass",
    "public",
    "print",
    "private",
    "protected",
    "raise",
    "register",
    "return",
    "short",
    "signed",
    "sizeof",
    "static",
    "switch",
    "synchronized",
    "template",
    "this",
    "throw",
    "transient",
    "try",
    "unsigned",
    "var",
    "virtual",
    "volatile",
    "while",
    "with",
    "yield",
    "Object",
    "Client",
    "IFace",
    "Processor",

    -- Other words to avoid, because they lead to Thrift-generated code that
    -- does not compile for one or more languages.
    "None", "operator", {- TODO: "Enum" -}

    -- Reserved for temporary predicates
    "_tmp_"
  ]


-- -----------------------------------------------------------------------------
-- Resolving queries

runResolve
  :: AngleVersion
  -> NameEnv (RefTarget p t)
  -> Resolve p t a
  -> Except Text a
runResolve ver scope act = runReaderT act (ver,scope)

type Resolve p t a =
  ReaderT (AngleVersion, NameEnv (RefTarget p t)) (Except Text) a

getScope :: Resolve p t (NameEnv (RefTarget p t))
getScope = asks snd

resolveDeriving
  :: (ShowRef t, ShowRef p)
  => SourceDerivingInfo' SrcSpan
  -> Resolve p t (DerivingInfo (Query_ p t))
resolveDeriving NoDeriving = return NoDeriving
resolveDeriving (Derive when query) = Derive when <$> resolveQuery query

resolveQuery
  :: (ShowRef t, ShowRef p)
  => SourceQuery
  -> Resolve p t (Query_ p t)
resolveQuery (SourceQuery head stmts ord) =
  SourceQuery
    <$> mapM resolvePat head
    <*> mapM resolveStatement stmts
    <*> pure ord

resolvePat
  :: (ShowRef t, ShowRef p)
  => SourcePat
  -> Resolve p t (SourcePat_ SrcSpan SrcSpan p t)
resolvePat pat = case pat of
  Nat s i -> return (Nat s i)
  String s t -> return (String s t)
  StringPrefix s t -> return (StringPrefix s t)
  ByteArray s b -> return (ByteArray s b)
  Array s pats -> Array s <$> mapM resolvePat pats
  ArrayPrefix s pats -> ArrayPrefix s <$> mapM resolvePat pats
  Tuple s pats -> Tuple s <$> mapM resolvePat pats
  All s qs -> All s <$> resolvePat qs
  Elements s pat -> Elements s <$> resolvePat pat
  Wildcard s -> return (Wildcard s)
  TypeSignature s pat ty ->
    TypeSignature s
      <$> resolvePat pat
      <*> resolveType ty
  Variable s n -> return (Variable s n)
  FactId s Nothing id -> return (FactId s Nothing id)
  FactId s (Just pred) id -> do
    res <- resolveTypeOrPred s pred
    case res of
      RefPred ref ->
        return (TypeSignature s (FactId s Nothing id) (PredicateTy s ref))
      _other -> prettyErrorIn pat $ "not a predicate: " <> pretty pred
  OrPattern s l r -> OrPattern s <$> resolvePat l <*> resolvePat r
  Negation s pat -> Negation s <$> resolvePat pat
  Never s -> return (Never s)
  IfPattern s cond then_ else_ ->
    IfPattern s
      <$> resolvePat cond
      <*> resolvePat then_
      <*> resolvePat else_
  ElementsOfArray s pat -> ElementsOfArray s <$> resolvePat pat
  KeyValue s k v -> KeyValue s <$> resolvePat k <*> resolvePat v
  NestedQuery s q -> NestedQuery s <$> resolveQuery q
  Struct s fields -> Struct s <$> mapM resolveField fields
    where resolveField (Field n pat) = Field n <$> resolvePat pat
  App s (Variable svar txt) args
    | Just primOp <- HashMap.lookup txt primitives -> do
      Prim s primOp <$> mapM resolvePat args
    | otherwise ->
    case args of
      [arg] -> do
        arg' <- resolvePat arg
        let (range, txt') = if
              | Just rem <- Text.stripSuffix "#new" txt -> (SeekOnStacked, rem)
              | Just rem <- Text.stripSuffix "#old" txt -> (SeekOnBase, rem)
              | otherwise -> (SeekOnAllFacts, txt)
        res <- resolveTypeOrPred svar txt'
        case res of
          RefPred ref -> return (Clause s svar ref arg' range)
          RefType ref
            | SeekOnAllFacts <- range ->
              return (TypeSignature s arg' (NamedTy svar ref))
            | otherwise ->
              prettyErrorIn pat "cannot use #new or #old with types"
            -- The syntax "T pat" for "pat : T" is something we might
            -- consider deprecating later. For now it's just desugared
            -- here.
      _ -> prettyErrorIn pat "unexpected extra argument(s)"
  App s (StringPrefix a b) [pat] -> do
    pat' <- resolvePat pat
    return (App s (StringPrefix a b) [pat'])
  App _ f _ ->
    prettyErrorIn pat $ "invalid pattern: cannot apply " <>
    describe f <> " to arguments"
  FieldSelect s pat field q ->
    (\p -> FieldSelect s p field q)
      <$> resolvePat pat
  Deref s pat -> Deref s <$> resolvePat pat
  Enum s n -> return (Enum s n)
  Clause{} -> internal
  Prim{} -> internal
  where
  internal = throwError $ "internal: unexpected: " <>
    Text.pack (show (pretty pat))

resolveTypeOrPred
  :: (ShowRef p, ShowRef t)
  => SrcSpan
  -> Name
  -> Resolve p t (RefTarget p t)
resolveTypeOrPred span txt = do
  scope <- getScope
  let ref = parseRef txt
  case lookupResultToEither ref $ resolveRef scope ref of
    Left s -> prettyErrorAt span (pretty s)
    Right r -> return r

prettyError :: Doc ann -> Resolve p t a
prettyError = throwError . Text.pack . show

prettyErrorIn :: IsSrcSpan s => SourcePat' s st -> Doc ann -> Resolve p t a
prettyErrorIn pat doc = prettyErrorAt (sourcePatSpan pat) doc

prettyErrorAt :: IsSrcSpan span => span -> Doc ann -> Resolve p t a
prettyErrorAt span doc = prettyError $ vcat
  [ pretty span
  , doc
  ]

resolveStatement
  :: (ShowRef t, ShowRef p)
  => SourceStatement
  -> Resolve p t (Statement_ p t)
resolveStatement (SourceStatement l r) =
  SourceStatement <$> resolvePat l <*> resolvePat r

primitives :: HashMap Text PrimOp
primitives = HashMap.fromList
  [ ("prim.toLower", PrimOpToLower)
  , ("prim.length", PrimOpLength)
  , ("prim.relToAbsByteSpans", PrimOpRelToAbsByteSpans)
  , ("prim.unpackByteSpans", PrimOpUnpackByteSpans)
  , ("prim.zip", PrimOpZip)
  , ("prim.concat", PrimOpConcat)
  , ("prim.reverse", PrimOpReverse)
  , ("prim.size", PrimOpSize)
  , ("prim.gtNat", PrimOpGtNat)
  , ("prim.geNat", PrimOpGeNat)
  , ("prim.ltNat", PrimOpLtNat)
  , ("prim.leNat", PrimOpLeNat)
  , ("prim.neNat", PrimOpNeNat)
  , ("prim.addNat", PrimOpAddNat)
  , ("prim.neExpr", PrimOpNeExpr)
  ]