{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,
    figuring out infix operator precedences and tidying up definitions.
-}
module Agda.Syntax.Translation.ConcreteToAbstract
    ( ToAbstract(..), localToAbstract
    , concreteToAbstract_
    , concreteToAbstract
    , NewModuleQName(..)
    , TopLevel(..)
    , TopLevelInfo(..)
    , topLevelModuleName
    , AbstractRHS
    , NewModuleName, OldModuleName
    , NewName, OldQName
    , PatName, APatName
    , importPrimitives
    , checkCohesionAttributes
    ) where

import Prelude hiding ( null )

import Control.Monad        ( (<=<), foldM, forM, forM_, zipWithM, zipWithM_ )
import Control.Applicative  ( liftA2, liftA3 )
import Control.Monad.Except ( MonadError(..) )

import Data.Bifunctor
import Data.Foldable (traverse_)
import Data.Set (Set)
import Data.Map (Map)
import Data.Functor (void)
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid (First(..))
import Data.Void

import Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Attribute
import Agda.Syntax.Concrete.Generic
import Agda.Syntax.Concrete.Operators
import Agda.Syntax.Concrete.Pattern
import Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Pattern as A ( patternVars, checkPatternLinearity, containsAsPattern, lhsCoreApp, lhsCoreWith )
import Agda.Syntax.Abstract.Pretty
import qualified Agda.Syntax.Internal as I
import Agda.Syntax.Position
import Agda.Syntax.Literal
import Agda.Syntax.Common
import Agda.Syntax.Info
import Agda.Syntax.Concrete.Definitions as C
import Agda.Syntax.Fixity
import Agda.Syntax.Concrete.Fixity (DoWarn(..))
import Agda.Syntax.Notation
import Agda.Syntax.Scope.Base as A
import Agda.Syntax.Scope.Monad
import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs)
import Agda.Syntax.DoNotation
import Agda.Syntax.IdiomBrackets
import Agda.Syntax.TopLevelModuleName

import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)
import Agda.TypeChecking.Monad.State hiding (topLevelModuleName)
import qualified Agda.TypeChecking.Monad.State as S
import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)
import Agda.TypeChecking.Monad.Debug
import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath)
import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin, builtinKindOfName)

import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)
import Agda.TypeChecking.Pretty hiding (pretty, prettyA)
import Agda.TypeChecking.Quote (quotedName)
import Agda.TypeChecking.Warnings

import Agda.Interaction.FindFile (checkModuleName, rootNameModule, SourceFile(SourceFile))
-- import Agda.Interaction.Imports  -- for type-checking in ghci
import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)
import Agda.Interaction.Options
import qualified Agda.Interaction.Options.Lenses as Lens
import Agda.Interaction.Options.Warnings

import qualified Agda.Utils.AssocList as AssocList
import Agda.Utils.CallStack ( HasCallStack, withCurrentCallStack )
import Agda.Utils.Char
import Agda.Utils.Either
import Agda.Utils.FileName
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 ( List1, pattern (:|) )
import Agda.Utils.List2 ( List2, pattern List2 )
import qualified Agda.Utils.List1 as List1
import qualified Agda.Utils.Map as Map
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Utils.Pretty as P
import Agda.Utils.Pretty (render, Pretty, pretty, prettyShow)
import Agda.Utils.Singleton
import Agda.Utils.Tuple

import Agda.Utils.Impossible
import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)

{--------------------------------------------------------------------------
    Exceptions
 --------------------------------------------------------------------------}

notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a
notAnExpression :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
notAnExpression = forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError Expr -> TypeError
NotAnExpression

nothingAppliedToHiddenArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a
nothingAppliedToHiddenArg :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToHiddenArg = forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError Expr -> TypeError
NothingAppliedToHiddenArg

nothingAppliedToInstanceArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a
nothingAppliedToInstanceArg :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToInstanceArg = forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError Expr -> TypeError
NothingAppliedToInstanceArg

notAValidLetBinding :: (HasCallStack, MonadTCError m) => C.NiceDeclaration -> m a
notAValidLetBinding :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding = forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError NiceDeclaration -> TypeError
NotAValidLetBinding

{--------------------------------------------------------------------------
    Helpers
 --------------------------------------------------------------------------}
--UNUSED Liang-Ting Chen 2019-07-16
--annotateDecl :: ScopeM A.Declaration -> ScopeM A.Declaration
--annotateDecl m = annotateDecls $ (:[]) <$> m

-- | Make sure that there are no dot patterns (called on pattern synonyms).
noDotorEqPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)
noDotorEqPattern :: forall e. [Char] -> Pattern' e -> ScopeM (Pattern' Void)
noDotorEqPattern [Char]
err = forall e. Pattern' e -> ScopeM (Pattern' Void)
dot
  where
    dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)
    dot :: forall e. Pattern' e -> ScopeM (Pattern' Void)
dot = \case
      A.VarP BindName
x               -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. BindName -> Pattern' e
A.VarP BindName
x
      A.ConP ConPatInfo
i AmbiguousQName
c NAPs e
args        -> forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
      A.ProjP PatInfo
i ProjOrigin
o AmbiguousQName
d          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' e
A.ProjP PatInfo
i ProjOrigin
o AmbiguousQName
d
      A.WildP PatInfo
i              -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.WildP PatInfo
i
      A.AsP PatInfo
i BindName
x Pattern' e
p            -> forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i BindName
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p
      A.DotP{}               -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
err
      A.EqualP{}             -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
err   -- Andrea: so we also disallow = patterns, reasonable?
      A.AbsurdP PatInfo
i            -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.AbsurdP PatInfo
i
      A.LitP PatInfo
i Literal
l             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Literal -> Pattern' e
A.LitP PatInfo
i Literal
l
      A.DefP PatInfo
i AmbiguousQName
f NAPs e
args        -> forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
      A.PatternSynP PatInfo
i AmbiguousQName
c NAPs e
args -> forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
      A.RecP PatInfo
i [FieldAssignment' (Pattern' e)]
fs            -> forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP PatInfo
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) [FieldAssignment' (Pattern' e)]
fs
      A.WithP PatInfo
i Pattern' e
p            -> forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP PatInfo
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p
      A.AnnP PatInfo
i e
a Pattern' e
p           -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
err   -- TODO: should this be allowed?
--UNUSED Liang-Ting Chen 2019-07-16
---- | Make sure that there are no dot patterns (WAS: called on pattern synonyms).
--noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)
--noDotPattern err = traverse $ const $ genericError err

newtype RecordConstructorType = RecordConstructorType [C.Declaration]

instance ToAbstract RecordConstructorType where
  type AbsOfCon RecordConstructorType = A.Expr
  toAbstract :: RecordConstructorType -> ScopeM (AbsOfCon RecordConstructorType)
toAbstract (RecordConstructorType [Declaration]
ds) = [Declaration] -> ScopeM Expr
recordConstructorType [Declaration]
ds

-- | Compute the type of the record constructor (with bogus target type)
recordConstructorType :: [C.Declaration] -> ScopeM A.Expr
recordConstructorType :: [Declaration] -> ScopeM Expr
recordConstructorType [Declaration]
decls =
    -- Nicify all declarations since there might be fixity declarations after
    -- the the last field. Use NoWarn to silence fixity warnings. We'll get
    -- them again when scope checking the declarations to build the record
    -- module.
    forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
NoWarn [Declaration]
decls forall a b. (a -> b) -> a -> b
$ [NiceDeclaration] -> ScopeM Expr
buildType forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NiceDeclaration] -> [NiceDeclaration]
takeFields
  where
    takeFields :: [NiceDeclaration] -> [NiceDeclaration]
takeFields = forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd NiceDeclaration -> Bool
notField

    notField :: NiceDeclaration -> Bool
notField NiceField{} = Bool
False
    notField NiceDeclaration
_           = Bool
True

    buildType :: [C.NiceDeclaration] -> ScopeM A.Expr
      -- TODO: Telescope instead of Expr in abstract RecDef
    buildType :: [NiceDeclaration] -> ScopeM Expr
buildType [NiceDeclaration]
ds = do
      -- The constructor target type is computed in the type checker.
      -- For now, we put a dummy expression there.
      -- Andreas, 2022-10-06, issue #6165:
      -- The dummy was builtinSet, but this might not be defined yet.
      let dummy :: Expr
dummy = ExprInfo -> Literal -> Expr
A.Lit forall a. Null a => a
empty forall a b. (a -> b) -> a -> b
$ Text -> Literal
LitString Text
"TYPE"
      [TypedBinding]
tel   <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NiceDeclaration -> ScopeM (Maybe TypedBinding)
makeBinding [NiceDeclaration]
ds
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> [TypedBinding] -> Expr -> Expr
A.mkPi (Range -> ExprInfo
ExprRange (forall a. HasRange a => a -> Range
getRange [NiceDeclaration]
ds)) [TypedBinding]
tel Expr
dummy

    makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)
    makeBinding :: NiceDeclaration -> ScopeM (Maybe TypedBinding)
makeBinding NiceDeclaration
d = do
      let failure :: ScopeM (Maybe TypedBinding)
failure = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> TypeError
NotValidBeforeField NiceDeclaration
d
          r :: Range
r       = forall a. HasRange a => a -> Range
getRange NiceDeclaration
d
          mkLet :: NiceDeclaration -> ScopeM (Maybe TypedBinding)
mkLet NiceDeclaration
d = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> List1 LetBinding -> TypedBinding
A.TLet Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (NiceDeclaration -> LetDef
LetDef NiceDeclaration
d)
      forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ case NiceDeclaration
d of

        C.NiceField Range
r Access
pr IsAbstract
ab IsInstance
inst TacticAttribute
tac Name
x Arg Expr
a -> do
          Fixity'
fx  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
          let bv :: NamedArg Binder
bv = forall a name. a -> Named name a
unnamed (forall a. a -> Binder' a
C.mkBinder forall a b. (a -> b) -> a -> b
$ (Name -> Fixity' -> BoundName
C.mkBoundName Name
x Fixity'
fx) { bnameTactic :: TacticAttribute
bnameTactic = TacticAttribute
tac }) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Expr
a
          forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ forall e. Range -> List1 (NamedArg Binder) -> e -> TypedBinding' e
C.TBind Range
r (forall el coll. Singleton el coll => el -> coll
singleton NamedArg Binder
bv) (forall e. Arg e -> e
unArg Arg Expr
a)

        -- Public open is allowed and will take effect when scope checking as
        -- proper declarations.
        C.NiceOpen Range
r QName
m ImportDirective
dir -> do
          NiceDeclaration -> ScopeM (Maybe TypedBinding)
mkLet forall a b. (a -> b) -> a -> b
$ Range -> QName -> ImportDirective -> NiceDeclaration
C.NiceOpen Range
r QName
m ImportDirective
dir{ publicOpen :: Maybe Range
publicOpen = forall a. Maybe a
Nothing }
        C.NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
          NiceDeclaration -> ScopeM (Maybe TypedBinding)
mkLet forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
C.NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir{ publicOpen :: Maybe Range
publicOpen = forall a. Maybe a
Nothing }

        -- Do some rudimentary matching here to get NotValidBeforeField instead
        -- of NotAValidLetDecl.
        C.NiceMutual Range
_ TerminationCheck
_ CoverageCheck
_ PositivityCheck
_
          [ C.FunSig Range
_ Access
_ IsAbstract
_ IsInstance
_ IsMacro
macro ArgInfo
_ TerminationCheck
_ CoverageCheck
_ Name
_ Expr
_
          , C.FunDef Range
_ [Declaration]
_ IsAbstract
abstract IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_
             [ C.Clause Name
_ Bool
_ (C.LHS Pattern
_p [] []) (C.RHS Expr
_) WhereClause' [Declaration]
NoWhere [] ]
          ] | IsAbstract
abstract forall a. Eq a => a -> a -> Bool
/= IsAbstract
AbstractDef Bool -> Bool -> Bool
&& IsMacro
macro forall a. Eq a => a -> a -> Bool
/= IsMacro
MacroDef -> do
          NiceDeclaration -> ScopeM (Maybe TypedBinding)
mkLet NiceDeclaration
d

        C.NiceLoneConstructor{} -> ScopeM (Maybe TypedBinding)
failure
        C.NiceMutual{}        -> ScopeM (Maybe TypedBinding)
failure
        -- TODO: some of these cases might be __IMPOSSIBLE__
        C.Axiom{}             -> ScopeM (Maybe TypedBinding)
failure
        C.PrimitiveFunction{} -> ScopeM (Maybe TypedBinding)
failure
        C.NiceModule{}        -> ScopeM (Maybe TypedBinding)
failure
        C.NiceImport{}        -> ScopeM (Maybe TypedBinding)
failure
        C.NicePragma{}        -> ScopeM (Maybe TypedBinding)
failure
        C.NiceRecSig{}        -> ScopeM (Maybe TypedBinding)
failure
        C.NiceDataSig{}       -> ScopeM (Maybe TypedBinding)
failure
        C.NiceFunClause{}     -> ScopeM (Maybe TypedBinding)
failure
        C.FunSig{}            -> ScopeM (Maybe TypedBinding)
failure  -- Note: these are bundled with FunDef in NiceMutual
        C.FunDef{}            -> ScopeM (Maybe TypedBinding)
failure
        C.NiceDataDef{}       -> ScopeM (Maybe TypedBinding)
failure
        C.NiceRecDef{}        -> ScopeM (Maybe TypedBinding)
failure
        C.NicePatternSyn{}    -> ScopeM (Maybe TypedBinding)
failure
        C.NiceGeneralize{}    -> ScopeM (Maybe TypedBinding)
failure
        C.NiceUnquoteDecl{}   -> ScopeM (Maybe TypedBinding)
failure
        C.NiceUnquoteDef{}    -> ScopeM (Maybe TypedBinding)
failure
        C.NiceUnquoteData{}   -> ScopeM (Maybe TypedBinding)
failure

checkModuleApplication
  :: C.ModuleApplication
  -> ModuleName
  -> C.Name
  -> C.ImportDirective
  -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)

checkModuleApplication :: ModuleApplication
-> ModuleName
-> Name
-> ImportDirective
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
checkModuleApplication (C.SectionApp Range
_ Telescope
tel Expr
e) ModuleName
m0 Name
x ImportDirective
dir' = do
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
    [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking ModuleApplication " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
    ]

  -- For the following, set the current module to be m0.
  forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m0 forall a b. (a -> b) -> a -> b
$ do
    -- Check that expression @e@ is of the form @m args@.
    (QName
m, [NamedArg Expr]
args) <- Expr -> ScopeM (QName, [NamedArg Expr])
parseModuleApplication Expr
e
    -- Scope check the telescope (introduces bindings!).
    [TypedBinding]
tel' <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel
    -- Scope check the old module name and the module args.
    ModuleName
m1    <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> OldModuleName
OldModuleName QName
m
    [NamedArg Expr]
args' <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx (ParenPreference -> Precedence
ArgumentCtx ParenPreference
PreferParen) [NamedArg Expr]
args
    -- Copy the scope associated with m and take the parts actually imported.
    (ImportDirective
adir, Scope
s) <- QName
-> ImportDirective -> Scope -> TCMT IO (ImportDirective, Scope)
applyImportDirectiveM (Name -> QName
C.QName Name
x) ImportDirective
dir' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModuleName -> ScopeM Scope
getNamedScope ModuleName
m1
    (Scope
s', ScopeCopyInfo
copyInfo) <- QName -> ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)
copyScope QName
m ModuleName
m0 Scope
s
    -- Set the current scope to @s'@
    (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Scope
s'
    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst" Int
20 [Char]
"copied source module"
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.mod.inst" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty ScopeCopyInfo
copyInfo
    let amodapp :: ModuleApplication
amodapp = [TypedBinding]
-> ModuleName -> [NamedArg Expr] -> ModuleApplication
A.SectionApp [TypedBinding]
tel' ModuleName
m1 [NamedArg Expr]
args'
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked ModuleApplication " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ]
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      [ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleApplication
amodapp
      ]
    forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleApplication
amodapp, ScopeCopyInfo
copyInfo, ImportDirective
adir)

checkModuleApplication (C.RecordModuleInstance Range
_ QName
recN) ModuleName
m0 Name
x ImportDirective
dir' =
  forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m0 forall a b. (a -> b) -> a -> b
$ do
    ModuleName
m1 <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> OldModuleName
OldModuleName QName
recN
    Scope
s <- ModuleName -> ScopeM Scope
getNamedScope ModuleName
m1
    (ImportDirective
adir, Scope
s) <- QName
-> ImportDirective -> Scope -> TCMT IO (ImportDirective, Scope)
applyImportDirectiveM QName
recN ImportDirective
dir' Scope
s
    (Scope
s', ScopeCopyInfo
copyInfo) <- QName -> ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)
copyScope QName
recN ModuleName
m0 Scope
s
    (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Scope
s'

    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst" Int
20 [Char]
"copied record module"
    forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> ModuleApplication
A.RecordModuleInstance ModuleName
m1, ScopeCopyInfo
copyInfo, ImportDirective
adir)

-- | @checkModuleMacro mkApply range access concreteName modapp open dir@
--
--   Preserves local variables.

checkModuleMacro
  :: (ToConcrete a, Pretty (ConOfAbs a))
  => (ModuleInfo
      -> ModuleName
      -> A.ModuleApplication
      -> ScopeCopyInfo
      -> A.ImportDirective
      -> a)
  -> OpenKind
  -> Range
  -> Access
  -> C.Name
  -> C.ModuleApplication
  -> OpenShortHand
  -> C.ImportDirective
  -> ScopeM a
checkModuleMacro :: forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a
apply OpenKind
kind Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir = do
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking ModuleMacro " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ]
    ImportDirective
dir <- OpenShortHand -> ImportDirective -> ScopeM ImportDirective
notPublicWithoutOpen OpenShortHand
open ImportDirective
dir

    ModuleName
m0 <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> NewModuleName
NewModuleName Name
x)
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"NewModuleName: m0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst" Int
20 [Char]
"module macro"

    -- If we're opening a /named/ module, the import directive is
    -- applied to the "open", otherwise to the module itself. However,
    -- "public" is always applied to the "open".
    let (ImportDirective
moduleDir, ImportDirective
openDir) = case (OpenShortHand
open, forall a. IsNoName a => a -> Bool
isNoName Name
x) of
          (OpenShortHand
DoOpen,   Bool
False) -> (forall n m. ImportDirective' n m
defaultImportDir, ImportDirective
dir)
          (OpenShortHand
DoOpen,   Bool
True)  -> ( ImportDirective
dir { publicOpen :: Maybe Range
publicOpen = forall a. Maybe a
Nothing }
                               , forall n m. ImportDirective' n m
defaultImportDir { publicOpen :: Maybe Range
publicOpen = forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dir }
                               )
          (OpenShortHand
DontOpen, Bool
_)     -> (ImportDirective
dir, forall n m. ImportDirective' n m
defaultImportDir)

    -- Restore the locals after module application has been checked.
    (ModuleApplication
modapp', ScopeCopyInfo
copyInfo, ImportDirective
adir') <- forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ ModuleApplication
-> ModuleName
-> Name
-> ImportDirective
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
checkModuleApplication ModuleApplication
modapp ModuleName
m0 Name
x ImportDirective
moduleDir
    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst.app" Int
20 [Char]
"checkModuleMacro, after checkModuleApplication"

    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after mod app: trying to print m0 ..."
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after mod app: m0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

    Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p Name
x ModuleName
m0
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after bindMod: m0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst.copy.after" Int
20 [Char]
"after copying"

    -- Open the module if DoOpen.
    -- Andreas, 2014-09-02: @openModule@ might shadow some locals!
    ImportDirective
adir <- case OpenShortHand
open of
      OpenShortHand
DontOpen -> forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
adir'
      OpenShortHand
DoOpen   -> do
        ImportDirective
adir'' <- OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> TCMT IO ImportDirective
openModule OpenKind
kind (forall a. a -> Maybe a
Just ModuleName
m0) (Name -> QName
C.QName Name
x) ImportDirective
openDir
        -- Andreas, 2020-05-14, issue #4656
        -- Keep the more meaningful import directive for highlighting
        -- (the other one is a defaultImportDir).
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall a. IsNoName a => a -> Bool
isNoName Name
x then ImportDirective
adir' else ImportDirective
adir''

    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst" Int
20 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show OpenShortHand
open
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after open   : m0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

    TCMT IO ()
stripNoNames
    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"after stripping"
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after stripNo: m0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

    let m :: ModuleName
m      = ModuleName
m0 ModuleName -> List1 Name -> ModuleName
`withRangesOf` forall el coll. Singleton el coll => el -> coll
singleton Name
x
        adecl :: a
adecl  = ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a
apply ModuleInfo
info ModuleName
m ModuleApplication
modapp' ScopeCopyInfo
copyInfo ImportDirective
adir

    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked ModuleMacro " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ]
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn  [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ [Char]
"info    = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ModuleInfo
info
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn  [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ [Char]
"m       = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow ModuleName
m
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn  [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ [Char]
"modapp' = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ModuleApplication
modapp'
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty ScopeCopyInfo
copyInfo
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA a
adecl
    forall (m :: * -> *) a. Monad m => a -> m a
return a
adecl
  where
    info :: ModuleInfo
info = ModuleInfo
             { minfoRange :: Range
minfoRange  = Range
r
             , minfoAsName :: Maybe Name
minfoAsName = forall a. Maybe a
Nothing
             , minfoAsTo :: Range
minfoAsTo   = ImportDirective -> Range
renamingRange ImportDirective
dir
             , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = forall a. a -> Maybe a
Just OpenShortHand
open
             , minfoDirective :: Maybe ImportDirective
minfoDirective = forall a. a -> Maybe a
Just ImportDirective
dir
             }

-- | The @public@ keyword must only be used together with @open@.

notPublicWithoutOpen :: OpenShortHand -> C.ImportDirective -> ScopeM C.ImportDirective
notPublicWithoutOpen :: OpenShortHand -> ImportDirective -> ScopeM ImportDirective
notPublicWithoutOpen OpenShortHand
DoOpen   ImportDirective
dir = forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
dir
notPublicWithoutOpen OpenShortHand
DontOpen ImportDirective
dir = do
  forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dir) forall a b. (a -> b) -> a -> b
$ \ Range
r ->
    forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ImportDirective
dir { publicOpen :: Maybe Range
publicOpen = forall a. Maybe a
Nothing }

-- | Computes the range of all the \"to\" keywords used in a renaming
-- directive.

renamingRange :: C.ImportDirective -> Range
renamingRange :: ImportDirective -> Range
renamingRange = forall a. HasRange a => a -> Range
getRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n m. Renaming' n m -> Range
renToRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n m. ImportDirective' n m -> RenamingDirective' n m
impRenaming

-- | Scope check a 'NiceOpen'.
checkOpen
  :: Range                -- ^ Range of @open@ statement.
  -> Maybe A.ModuleName   -- ^ Resolution of concrete module name (if already resolved).
  -> C.QName              -- ^ Module to open.
  -> C.ImportDirective    -- ^ Scope modifier.
  -> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective) -- ^ Arguments of 'A.Open'
checkOpen :: Range
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
checkOpen Range
r Maybe ModuleName
mam QName
x ImportDirective
dir = do
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ do
    ModuleName
cm <- forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"scope checking NiceOpen " forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Pretty a => a -> Doc
pretty QName
x)
      , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"  getCurrentModule       = " forall a. Semigroup a => a -> a -> a
<> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
cm
      , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"  getCurrentModule (raw) = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ModuleName
cm
      , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"  C.ImportDirective      = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow ImportDirective
dir
      ]
  -- Andreas, 2017-01-01, issue #2377: warn about useless `public`
  forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dir) forall a b. (a -> b) -> a -> b
$ \ Range
r -> do
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((ModuleName
A.noModuleName forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic

  ModuleName
m <- forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ModuleName
mam (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
x)) forall (m :: * -> *) a. Monad m => a -> m a
return
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"open" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"opening " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
  ImportDirective
adir <- OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> TCMT IO ImportDirective
openModule OpenKind
TopOpenModule (forall a. a -> Maybe a
Just ModuleName
m) QName
x ImportDirective
dir
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"open" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"result:"
  let minfo :: ModuleInfo
minfo = ModuleInfo
        { minfoRange :: Range
minfoRange     = Range
r
        , minfoAsName :: Maybe Name
minfoAsName    = forall a. Maybe a
Nothing
        , minfoAsTo :: Range
minfoAsTo      = ImportDirective -> Range
renamingRange ImportDirective
dir
        , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = forall a. Maybe a
Nothing
        , minfoDirective :: Maybe ImportDirective
minfoDirective = forall a. a -> Maybe a
Just ImportDirective
dir
        }
  let adecls :: [Declaration]
adecls = [ModuleInfo -> ModuleName -> ImportDirective -> Declaration
A.Open ModuleInfo
minfo ModuleName
m ImportDirective
adir]
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ( [Char]
"scope checked NiceOpen " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
         ) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA) [Declaration]
adecls
  forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo
minfo, ModuleName
m, ImportDirective
adir)

-- | Check a literal, issuing an error warning for bad literals.
checkLiteral :: Literal -> ScopeM ()
checkLiteral :: Literal -> TCMT IO ()
checkLiteral (LitChar Char
c)
  | Char -> Bool
isSurrogateCodePoint Char
c = forall (m :: * -> *). MonadWarning m => Doc -> m ()
genericNonFatalError forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
P.text forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid character literal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Char
c forall a. [a] -> [a] -> [a]
++
                                                             [Char]
" (surrogate code points are not supported)"
checkLiteral Literal
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

{--------------------------------------------------------------------------
    Translation
 --------------------------------------------------------------------------}

concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)
concreteToAbstract_ :: forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
concreteToAbstract_ = forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract

concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)
concreteToAbstract :: forall c. ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)
concreteToAbstract ScopeInfo
scope c
x = forall (m :: * -> *) a. ReadTCState m => ScopeInfo -> m a -> m a
withScope_ ScopeInfo
scope (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
x)

-- | Things that can be translated to abstract syntax are instances of this
--   class.
class ToAbstract c where
    type AbsOfCon c
    toAbstract :: c -> ScopeM (AbsOfCon c)

-- | This function should be used instead of 'toAbstract' for things that need
--   to keep track of precedences to make sure that we don't forget about it.
toAbstractCtx :: ToAbstract c => Precedence -> c-> ScopeM (AbsOfCon c)
toAbstractCtx :: forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
ctx c
c = forall (m :: * -> *) a. ReadTCState m => Precedence -> m a -> m a
withContextPrecedence Precedence
ctx forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
c

--UNUSED Liang-Ting Chen 2019-07-16
--toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a
--toAbstractTopCtx = toAbstractCtx TopCtx

toAbstractHiding :: (LensHiding h, ToAbstract c) => h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding :: forall h c.
(LensHiding h, ToAbstract c) =>
h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding h
h | forall a. LensHiding a => a -> Bool
visible h
h = forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract -- don't change precedence if visible
toAbstractHiding h
_             = forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx

--UNUSED Liang-Ting Chen 2019-07-16
--setContextCPS :: Precedence -> (a -> ScopeM b) ->
--                 ((a -> ScopeM b) -> ScopeM b) -> ScopeM b
--setContextCPS p ret f = do
--  old <- useScope scopePrecedence
--  withContextPrecedence p $ f $ \ x -> setContextPrecedence old >> ret x
--
--localToAbstractCtx :: ToAbstract c =>
--                     Precedence -> c -> (AbsOfCon -> ScopeM (AbsOfCon c)) -> ScopeM (AbsOfCon c)
--localToAbstractCtx ctx c ret = setContextCPS ctx ret (localToAbstract c)

-- | This operation does not affect the scope, i.e. the original scope
--   is restored upon completion.
localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract :: forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract c
x AbsOfCon c -> ScopeM b
ret = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' c
x AbsOfCon c -> ScopeM b
ret

-- | Like 'localToAbstract' but returns the scope after the completion of the
--   second argument.
localToAbstract' :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' :: forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' c
x AbsOfCon c -> ScopeM b
ret = do
  ScopeInfo
scope <- forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  forall (m :: * -> *) a.
ReadTCState m =>
ScopeInfo -> m a -> m (a, ScopeInfo)
withScope ScopeInfo
scope forall a b. (a -> b) -> a -> b
$ AbsOfCon c -> ScopeM b
ret forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
x

instance ToAbstract () where
  type AbsOfCon () = ()
  toAbstract :: () -> ScopeM (AbsOfCon ())
toAbstract = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (ToAbstract c1, ToAbstract c2) => ToAbstract (c1, c2) where
  type AbsOfCon (c1, c2) = (AbsOfCon c1, AbsOfCon c2)
  toAbstract :: (c1, c2) -> ScopeM (AbsOfCon (c1, c2))
toAbstract (c1
x,c2
y) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c1
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c2
y

instance (ToAbstract c1, ToAbstract c2, ToAbstract c3) => ToAbstract (c1, c2, c3) where
  type AbsOfCon (c1, c2, c3) = (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)
  toAbstract :: (c1, c2, c3) -> ScopeM (AbsOfCon (c1, c2, c3))
toAbstract (c1
x,c2
y,c3
z) = forall {a} {b} {c}. (a, (b, c)) -> (a, b, c)
flatten forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (c1
x,(c2
y,c3
z))
    where
      flatten :: (a, (b, c)) -> (a, b, c)
flatten (a
x,(b
y,c
z)) = (a
x,b
y,c
z)

instance ToAbstract c => ToAbstract [c] where
  type AbsOfCon [c] = [AbsOfCon c]
  toAbstract :: [c] -> ScopeM (AbsOfCon [c])
toAbstract = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract

instance ToAbstract c => ToAbstract (List1 c) where
  type AbsOfCon (List1 c) = List1 (AbsOfCon c)
  toAbstract :: List1 c -> ScopeM (AbsOfCon (List1 c))
toAbstract = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract

instance (ToAbstract c1, ToAbstract c2) => ToAbstract (Either c1 c2) where
  type AbsOfCon (Either c1 c2) = Either (AbsOfCon c1) (AbsOfCon c2)
  toAbstract :: Either c1 c2 -> ScopeM (AbsOfCon (Either c1 c2))
toAbstract = forall (f :: * -> *) a c b d.
Functor f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
traverseEither forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract

instance ToAbstract c => ToAbstract (Maybe c) where
  type AbsOfCon (Maybe c) = Maybe (AbsOfCon c)
  toAbstract :: Maybe c -> ScopeM (AbsOfCon (Maybe c))
toAbstract = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract

-- Names ------------------------------------------------------------------

data NewName a = NewName
  { forall a. NewName a -> BindingSource
newBinder   :: A.BindingSource -- what kind of binder?
  , forall a. NewName a -> a
newName     :: a
  } deriving (forall a b. a -> NewName b -> NewName a
forall a b. (a -> b) -> NewName a -> NewName b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NewName b -> NewName a
$c<$ :: forall a b. a -> NewName b -> NewName a
fmap :: forall a b. (a -> b) -> NewName a -> NewName b
$cfmap :: forall a b. (a -> b) -> NewName a -> NewName b
Functor)

data OldQName = OldQName
  C.QName              -- ^ Concrete name to be resolved
  (Maybe (Set A.Name)) -- ^ If a set is given, then the first name must
                       --   correspond to one of the names in the set.

-- | We sometimes do not want to fail hard if the name is not actually
--   in scope because we have a strategy to recover from this problem
--   (e.g. drop the offending COMPILE pragma)
data MaybeOldQName = MaybeOldQName OldQName

newtype OldName a = OldName a

-- | Wrapper to resolve a name to a 'ResolvedName' (rather than an 'A.Expr').
data ResolveQName = ResolveQName C.QName

data PatName      = PatName C.QName (Maybe (Set A.Name))
  -- ^ If a set is given, then the first name must correspond to one
  -- of the names in the set.

instance ToAbstract (NewName C.Name) where
  type AbsOfCon (NewName C.Name) = A.Name
  toAbstract :: NewName Name -> ScopeM (AbsOfCon (NewName Name))
toAbstract (NewName BindingSource
b Name
x) = do
    Name
y <- Name -> ScopeM Name
freshAbstractName_ Name
x
    BindingSource -> Name -> Name -> TCMT IO ()
bindVariable BindingSource
b Name
x Name
y
    forall (m :: * -> *) a. Monad m => a -> m a
return Name
y

instance ToAbstract (NewName C.BoundName) where
  type AbsOfCon (NewName C.BoundName) = A.BindName
  toAbstract :: NewName BoundName -> ScopeM (AbsOfCon (NewName BoundName))
toAbstract NewName{ newBinder :: forall a. NewName a -> BindingSource
newBinder = BindingSource
b, newName :: forall a. NewName a -> a
newName = BName{ boundName :: BoundName -> Name
boundName = Name
x, bnameFixity :: BoundName -> Fixity'
bnameFixity = Fixity'
fx }} = do
    Name
y <- Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
fx Name
x
    BindingSource -> Name -> Name -> TCMT IO ()
bindVariable BindingSource
b Name
x Name
y
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.BindName Name
y

instance ToAbstract OldQName where
  type AbsOfCon OldQName = A.Expr
  toAbstract :: OldQName -> ScopeM (AbsOfCon OldQName)
toAbstract q :: OldQName
q@(OldQName QName
x Maybe (Set Name)
_) =
    forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM (forall a. QName -> TCM a
notInScopeError QName
x) forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> MaybeOldQName
MaybeOldQName OldQName
q)

instance ToAbstract MaybeOldQName where
  type AbsOfCon MaybeOldQName = Maybe A.Expr
  toAbstract :: MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
toAbstract (MaybeOldQName (OldQName QName
x Maybe (Set Name)
ns)) = do
    ResolvedName
qx <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' KindsOfNames
allKindsOfNames Maybe (Set Name)
ns QName
x
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.name" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"resolved " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow ResolvedName
qx
    case ResolvedName
qx of
      VarName Name
x' BindingSource
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Expr
A.Var Name
x'
      DefinedName Access
_ AbstractName
d Suffix
suffix -> do
        forall (m :: * -> *).
(MonadWarning m, ReadTCState m) =>
QName -> m ()
raiseWarningsOnUsage forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        -- then we take note of generalized names used
        case AbstractName -> KindOfName
anameKind AbstractName
d of
          KindOfName
GeneralizeName -> do
            Maybe (Set QName)
gvs <- forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars
            case Maybe (Set QName)
gvs of   -- Subtle: Use (left-biased) union instead of insert to keep the old name if
                          -- already present. This way we can sort by source location when generalizing
                          -- (Issue 3354).
                Just Set QName
s -> Lens' (Maybe (Set QName)) TCState
stGeneralizedVars forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> a -> m ()
`setTCLens` forall a. a -> Maybe a
Just (Set QName
s forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a. a -> Set a
Set.singleton (AbstractName -> QName
anameName AbstractName
d))
                Maybe (Set QName)
Nothing -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> TypeError
GeneralizeNotSupportedHere forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
          KindOfName
DisallowedGeneralizeName -> do
            forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
              forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"Cannot use generalized variable from let-opened module:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (AbstractName -> QName
anameName AbstractName
d)
          KindOfName
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- and then we return the name
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Suffix -> Expr -> Maybe Expr
withSuffix Suffix
suffix forall a b. (a -> b) -> a -> b
$ forall a. NameToExpr a => a -> Expr
nameToExpr AbstractName
d
        where
          withSuffix :: Suffix -> Expr -> Maybe Expr
withSuffix Suffix
NoSuffix   Expr
e         = forall a. a -> Maybe a
Just Expr
e
          withSuffix s :: Suffix
s@Suffix{} (A.Def QName
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ QName -> Suffix -> Expr
A.Def' QName
x Suffix
s
          withSuffix Suffix
_          Expr
_         = forall a. Maybe a
Nothing

      FieldName     List1 AbstractName
ds     -> (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous (ProjOrigin -> AmbiguousQName -> Expr
A.Proj ProjOrigin
ProjPrefix) List1 AbstractName
ds
      ConstructorName Set Induction
_ List1 AbstractName
ds -> (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous AmbiguousQName -> Expr
A.Con List1 AbstractName
ds
      PatternSynResName List1 AbstractName
ds -> (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous AmbiguousQName -> Expr
A.PatternSyn List1 AbstractName
ds
      ResolvedName
UnknownName          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    where
      ambiguous :: (AmbiguousQName -> A.Expr) -> List1 AbstractName -> ScopeM (Maybe A.Expr)
      ambiguous :: (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous AmbiguousQName -> Expr
f List1 AbstractName
ds = do
        let xs :: NonEmpty QName
xs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds
        NonEmpty QName -> TCMT IO ()
raiseWarningsOnUsageIfUnambiguous NonEmpty QName
xs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> Expr
f forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ NonEmpty QName
xs

      -- Note: user warnings on ambiguous names will be raised by the type checker,
      -- see storeDiamsbiguatedName.
      raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM ()
      raiseWarningsOnUsageIfUnambiguous :: NonEmpty QName -> TCMT IO ()
raiseWarningsOnUsageIfUnambiguous = \case
        QName
x :| [] -> forall (m :: * -> *).
(MonadWarning m, ReadTCState m) =>
QName -> m ()
raiseWarningsOnUsage QName
x
        NonEmpty QName
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return ()


instance ToAbstract ResolveQName where
  type AbsOfCon ResolveQName = ResolvedName
  toAbstract :: ResolveQName -> ScopeM (AbsOfCon ResolveQName)
toAbstract (ResolveQName QName
x) = QName -> ScopeM ResolvedName
resolveName QName
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ResolvedName
UnknownName -> forall a. QName -> TCM a
notInScopeError QName
x
    ResolvedName
q -> forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
q

data APatName = VarPatName A.Name
              | ConPatName (List1 AbstractName)
              | PatternSynPatName (List1 AbstractName)

instance ToAbstract PatName where
  type AbsOfCon PatName = APatName
  toAbstract :: PatName -> ScopeM (AbsOfCon PatName)
toAbstract (PatName QName
x Maybe (Set Name)
ns) = do
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"checking pattern name: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
    ResolvedName
rx <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' ([KindOfName] -> KindsOfNames
someKindsOfNames [KindOfName
ConName, KindOfName
CoConName, KindOfName
PatternSynName]) Maybe (Set Name)
ns QName
x
          -- Andreas, 2013-03-21 ignore conflicting names which cannot
          -- be meant since we are in a pattern
          -- Andreas, 2020-04-11 CoConName:
          -- coinductive constructors will be rejected later, in the type checker
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"resolved as " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow ResolvedName
rx
    case (ResolvedName
rx, QName
x) of
      (VarName Name
y BindingSource
_,       C.QName Name
x)                           -> Name -> TCMT IO APatName
bindPatVar Name
x
      (FieldName List1 AbstractName
d,       C.QName Name
x)                           -> Name -> TCMT IO APatName
bindPatVar Name
x
      (DefinedName Access
_ AbstractName
d Suffix
_, C.QName Name
x) | KindOfName -> Bool
isDefName (AbstractName -> KindOfName
anameKind AbstractName
d) -> Name -> TCMT IO APatName
bindPatVar Name
x
      (ResolvedName
UnknownName,       C.QName Name
x)                           -> Name -> TCMT IO APatName
bindPatVar Name
x
      (ConstructorName Set Induction
_ List1 AbstractName
ds, QName
_)                                -> forall {m :: * -> *}.
MonadDebug m =>
List1 AbstractName -> m APatName
patCon List1 AbstractName
ds
      (PatternSynResName List1 AbstractName
d, QName
_)                                 -> forall {m :: * -> *}.
MonadDebug m =>
List1 AbstractName -> m APatName
patSyn List1 AbstractName
d
      (ResolvedName, QName)
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot pattern match on non-constructor " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
    where
      bindPatVar :: Name -> TCMT IO APatName
bindPatVar = Name -> APatName
VarPatName forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Name -> ScopeM Name
bindPatternVariable
      patCon :: List1 AbstractName -> m APatName
patCon List1 AbstractName
ds = do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"it was a con: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> APatName
ConPatName List1 AbstractName
ds
      patSyn :: List1 AbstractName -> m APatName
patSyn List1 AbstractName
ds = do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"it was a pat syn: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> APatName
PatternSynPatName List1 AbstractName
ds

-- | Translate and possibly bind a pattern variable
--   (which could have been bound before due to non-linearity).
bindPatternVariable :: C.Name -> ScopeM A.Name
bindPatternVariable :: Name -> ScopeM Name
bindPatternVariable Name
x = do
  Name
y <- (forall a b. Eq a => a -> [(a, b)] -> Maybe b
AssocList.lookup Name
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM LocalVars
getVarsToBind) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (LocalVar Name
y BindingSource
_ [AbstractName]
_) -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"it was a old var: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. SetRange a => Range -> a -> a
setRange (forall a. HasRange a => a -> Range
getRange Name
x) Name
y
    Maybe LocalVar
Nothing -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"it was a new var: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      Name -> ScopeM Name
freshAbstractName_ Name
x
  Name -> LocalVar -> TCMT IO ()
addVarToBind Name
x forall a b. (a -> b) -> a -> b
$ Name -> BindingSource -> [AbstractName] -> LocalVar
LocalVar Name
y BindingSource
PatternBound []
  forall (m :: * -> *) a. Monad m => a -> m a
return Name
y

class ToQName a where
  toQName :: a -> C.QName

instance ToQName C.Name  where toQName :: Name -> QName
toQName = Name -> QName
C.QName
instance ToQName C.QName where toQName :: QName -> QName
toQName = forall a. a -> a
id

-- Should be a defined name.
instance ToQName a => ToAbstract (OldName a) where
  type AbsOfCon (OldName a) = A.QName
  toAbstract :: OldName a -> ScopeM (AbsOfCon (OldName a))
toAbstract (OldName a
x) = do
    ResolvedName
rx <- QName -> ScopeM ResolvedName
resolveName (forall a. ToQName a => a -> QName
toQName a
x)
    case ResolvedName
rx of
      DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
      DefinedName Access
_ AbstractName
d Suffix{} -> forall a. QName -> TCM a
notInScopeError (forall a. ToQName a => a -> QName
toQName a
x)
      -- We can get the cases below for DISPLAY pragmas
      ConstructorName Set Induction
_ List1 AbstractName
ds -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)   -- We'll throw out this one, so it doesn't matter which one we pick
      FieldName List1 AbstractName
ds         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
      PatternSynResName List1 AbstractName
ds -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
      VarName Name
x BindingSource
_          -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Not a defined name: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ResolvedName
UnknownName          -> forall a. QName -> TCM a
notInScopeError (forall a. ToQName a => a -> QName
toQName a
x)

-- | Resolve a non-local name and return its possibly ambiguous abstract name.
toAbstractExistingName :: ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName :: forall a. ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName a
x = QName -> ScopeM ResolvedName
resolveName (forall a. ToQName a => a -> QName
toQName a
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton AbstractName
d
    DefinedName Access
_ AbstractName
d Suffix{} -> forall a. QName -> TCM a
notInScopeError (forall a. ToQName a => a -> QName
toQName a
x)
    ConstructorName Set Induction
_ List1 AbstractName
ds     -> forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
    FieldName List1 AbstractName
ds             -> forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
    PatternSynResName List1 AbstractName
ds     -> forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
    VarName Name
x BindingSource
_              -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Not a defined name: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
    ResolvedName
UnknownName              -> forall a. QName -> TCM a
notInScopeError (forall a. ToQName a => a -> QName
toQName a
x)

newtype NewModuleName      = NewModuleName      C.Name
newtype NewModuleQName     = NewModuleQName     C.QName
newtype OldModuleName      = OldModuleName      C.QName

freshQModule :: A.ModuleName -> C.Name -> ScopeM A.ModuleName
freshQModule :: ModuleName -> Name -> ScopeM ModuleName
freshQModule ModuleName
m Name
x = ModuleName -> ModuleName -> ModuleName
A.qualifyM ModuleName
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Name -> ModuleName
mnameFromList1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall el coll. Singleton el coll => el -> coll
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ScopeM Name
freshAbstractName_ Name
x

checkForModuleClash :: C.Name -> ScopeM ()
checkForModuleClash :: Name -> TCMT IO ()
checkForModuleClash Name
x = do
  [AbstractModule]
ms :: [AbstractModule] <- forall a. InScope a => QName -> ScopeInfo -> [a]
scopeLookup (Name -> QName
C.QName Name
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null [AbstractModule]
ms) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.clash" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"clashing modules ms = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow [AbstractModule]
ms
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.clash" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"clashing modules ms = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [AbstractModule]
ms
    forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Name -> [ModuleName] -> TypeError
ShadowedModule Name
x forall a b. (a -> b) -> a -> b
$
                forall a b. (a -> b) -> [a] -> [b]
map ((forall t u. (SetRange t, HasRange u) => t -> u -> t
`withRangeOf` Name
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName) [AbstractModule]
ms

instance ToAbstract NewModuleName where
  type AbsOfCon NewModuleName = A.ModuleName
  toAbstract :: NewModuleName -> ScopeM (AbsOfCon NewModuleName)
toAbstract (NewModuleName Name
x) = do
    Name -> TCMT IO ()
checkForModuleClash Name
x
    ModuleName
m <- forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    ModuleName
y <- ModuleName -> Name -> ScopeM ModuleName
freshQModule ModuleName
m Name
x
    Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule forall a. Maybe a
Nothing ModuleName
y
    forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
y

instance ToAbstract NewModuleQName where
  type AbsOfCon NewModuleQName = A.ModuleName
  toAbstract :: NewModuleQName -> ScopeM (AbsOfCon NewModuleQName)
toAbstract (NewModuleQName QName
m) = ModuleName -> QName -> ScopeM ModuleName
toAbs ModuleName
noModuleName QName
m
    where
      toAbs :: ModuleName -> QName -> ScopeM ModuleName
toAbs ModuleName
m (C.QName Name
x)  = do
        ModuleName
y <- ModuleName -> Name -> ScopeM ModuleName
freshQModule ModuleName
m Name
x
        Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule forall a. Maybe a
Nothing ModuleName
y
        forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
y
      toAbs ModuleName
m (C.Qual Name
x QName
q) = do
        ModuleName
m' <- ModuleName -> Name -> ScopeM ModuleName
freshQModule ModuleName
m Name
x
        ModuleName -> QName -> ScopeM ModuleName
toAbs ModuleName
m' QName
q

instance ToAbstract OldModuleName where
  type AbsOfCon OldModuleName = A.ModuleName

  toAbstract :: OldModuleName -> ScopeM (AbsOfCon OldModuleName)
toAbstract (OldModuleName QName
q) = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
q forall a b. (a -> b) -> a -> b
$ do
    AbstractModule -> ModuleName
amodName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ScopeM AbstractModule
resolveModule QName
q

-- Expressions ------------------------------------------------------------
--UNUSED Liang-Ting Chen 2019-07-16
---- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.
--mkNamedArg :: C.Expr -> NamedArg C.Expr
--mkNamedArg (C.HiddenArg   _ e) = Arg (hide         defaultArgInfo) e
--mkNamedArg (C.InstanceArg _ e) = Arg (makeInstance defaultArgInfo) e
--mkNamedArg e                   = Arg defaultArgInfo $ unnamed e

-- | Peel off 'C.HiddenArg' and represent it as an 'Arg', throwing away any name.
mkArg' :: ArgInfo -> C.Expr -> Arg C.Expr
mkArg' :: ArgInfo -> Expr -> Arg Expr
mkArg' ArgInfo
info (C.HiddenArg   Range
_ Named NamedName Expr
e) = forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensHiding a => a -> a
hide         ArgInfo
info) forall a b. (a -> b) -> a -> b
$ forall name a. Named name a -> a
namedThing Named NamedName Expr
e
mkArg' ArgInfo
info (C.InstanceArg Range
_ Named NamedName Expr
e) = forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensHiding a => a -> a
makeInstance ArgInfo
info) forall a b. (a -> b) -> a -> b
$ forall name a. Named name a -> a
namedThing Named NamedName Expr
e
mkArg' ArgInfo
info Expr
e                   = forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
NotHidden ArgInfo
info) Expr
e
--UNUSED Liang-Ting 2019-07-16
---- | By default, arguments are @Relevant@.
--mkArg :: C.Expr -> Arg C.Expr
--mkArg e = mkArg' defaultArgInfo e

inferParenPreference :: C.Expr -> ParenPreference
inferParenPreference :: Expr -> ParenPreference
inferParenPreference C.Paren{} = ParenPreference
PreferParen
inferParenPreference Expr
_         = ParenPreference
PreferParenless

-- | Parse a possibly dotted and braced @C.Expr@ as @A.Expr@,
--   interpreting dots as relevance and braces as hiding.
--   Only accept a layer of dotting/bracing if the respective accumulator is @Nothing@.
toAbstractDotHiding :: Maybe Relevance -> Maybe Hiding -> Precedence -> C.Expr -> ScopeM (A.Expr, Relevance, Hiding)
toAbstractDotHiding :: Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
prec Expr
e = do
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.irrelevance" Int
100 forall a b. (a -> b) -> a -> b
$ [Char]
"toAbstractDotHiding: " forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
render (forall a. Pretty a => a -> Doc
pretty Expr
e)
    forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) forall a b. (a -> b) -> a -> b
$ case Expr
e of

      C.RawApp Range
_ List2 Expr
es     -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
prec forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< List2 Expr -> ScopeM Expr
parseApplication List2 Expr
es
      C.Paren Range
_ Expr
e       -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
TopCtx Expr
e

      C.Dot Range
_ Expr
e
        | Maybe Relevance
Nothing <- Maybe Relevance
mr -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding (forall a. a -> Maybe a
Just Relevance
Irrelevant) Maybe Hiding
mh Precedence
prec Expr
e

      C.DoubleDot Range
_ Expr
e
        | Maybe Relevance
Nothing <- Maybe Relevance
mr -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding (forall a. a -> Maybe a
Just Relevance
NonStrict) Maybe Hiding
mh Precedence
prec Expr
e

      C.HiddenArg Range
_ (Named Maybe NamedName
Nothing Expr
e)
        | Maybe Hiding
Nothing <- Maybe Hiding
mh -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr (forall a. a -> Maybe a
Just Hiding
Hidden) Precedence
TopCtx Expr
e

      C.InstanceArg Range
_ (Named Maybe NamedName
Nothing Expr
e)
        | Maybe Hiding
Nothing <- Maybe Hiding
mh -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Overlappable -> Hiding
Instance Overlappable
NoOverlap) Precedence
TopCtx Expr
e

      Expr
e                 -> (, forall a. a -> Maybe a -> a
fromMaybe Relevance
Relevant Maybe Relevance
mr, forall a. a -> Maybe a -> a
fromMaybe Hiding
NotHidden Maybe Hiding
mh) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
prec Expr
e

-- | Translate concrete expression under at least one binder into nested
--   lambda abstraction in abstract syntax.
toAbstractLam :: Range -> List1 C.LamBinding -> C.Expr -> Precedence -> ScopeM A.Expr
toAbstractLam :: Range
-> NonEmpty (LamBinding' TypedBinding)
-> Expr
-> Precedence
-> ScopeM Expr
toAbstractLam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e Precedence
ctx = do
  -- Translate the binders
  LocalVars
lvars0 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
  forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> LamBinding' a
C.DomainFull forall b c a. (b -> c) -> (a -> b) -> a -> c
. LamBinding' TypedBinding -> TypedBinding
makeDomainFull) NonEmpty (LamBinding' TypedBinding)
bs) forall a b. (a -> b) -> a -> b
$ \ AbsOfCon (NonEmpty (LamBinding' TypedBinding))
bs -> do
    LocalVars
lvars1 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
    LocalVars -> LocalVars -> TCMT IO ()
checkNoShadowing LocalVars
lvars0 LocalVars
lvars1
    -- Translate the body
    Expr
e <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
ctx Expr
e
    -- We have at least one binder.  Get first @b@ and rest @bs@.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a. List1 (Maybe a) -> [a]
List1.catMaybes AbsOfCon (NonEmpty (LamBinding' TypedBinding))
bs of
      -- Andreas, 2020-06-18
      -- There is a pathological case in which we end up without binder:
      --   λ (let
      --        mutual -- warning: empty mutual block
      --     ) -> Set
      []   -> Expr
e
      LamBinding
b:[LamBinding]
bs -> ExprInfo -> LamBinding -> Expr -> Expr
A.Lam (Range -> ExprInfo
ExprRange Range
r) LamBinding
b forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LamBinding -> Expr -> Expr
mkLam Expr
e [LamBinding]
bs
  where
    mkLam :: LamBinding -> Expr -> Expr
mkLam LamBinding
b Expr
e = ExprInfo -> LamBinding -> Expr -> Expr
A.Lam (Range -> ExprInfo
ExprRange forall a b. (a -> b) -> a -> b
$ forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange LamBinding
b Expr
e) LamBinding
b Expr
e

-- | Scope check extended lambda expression.
scopeCheckExtendedLam ::
  Range -> Erased -> List1 C.LamClause -> ScopeM A.Expr
scopeCheckExtendedLam :: Range -> Erased -> List1 LamClause -> ScopeM Expr
scopeCheckExtendedLam Range
r Erased
erased List1 LamClause
cs = do
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM TCMT IO Bool
isInsideDotPattern forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Extended lambdas are not allowed in dot patterns"

  -- Find an unused name for the extended lambda definition.
  Name
cname <- Range -> Int -> [Char] -> ScopeM Name
freshConcreteName Range
r Int
0 [Char]
extendedLambdaName
  Name
name  <- Name -> ScopeM Name
freshAbstractName_ Name
cname
  IsAbstract
a <- forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC (forall o i. o -> Lens' i o -> i
^. forall a. LensIsAbstract a => Lens' IsAbstract a
lensIsAbstract)
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.extendedLambda" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"new extended lambda name (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show IsAbstract
a forall a. [a] -> [a] -> [a]
++ [Char]
"): " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
name
    ]
  forall (m :: * -> *). MonadDebug m => [Char] -> Int -> m () -> m ()
verboseS [Char]
"scope.extendedLambda" Int
60 forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ List1 LamClause
cs forall a b. (a -> b) -> a -> b
$ \ LamClause
c -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.extendedLambda" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"extended lambda lhs: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (LamClause -> [Pattern]
C.lamLHS LamClause
c)
  QName
qname <- Name -> TCMT IO QName
qualifyName_ Name
name
  Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName (Origin -> Access
PrivateAccess Origin
Inserted) KindOfName
FunName Name
cname QName
qname

  -- Andreas, 2019-08-20
  -- Keep the following __IMPOSSIBLE__, which is triggered by -v scope.decl.trace:80,
  -- for testing issue #4016.
  NiceDeclaration
d <- Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
C.FunDef Range
r [] IsAbstract
a IsInstance
NotInstanceDef forall a. HasCallStack => a
__IMPOSSIBLE__ forall a. HasCallStack => a
__IMPOSSIBLE__ Name
cname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
List1.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 LamClause
cs forall a b. (a -> b) -> a -> b
$ \ (LamClause [Pattern]
ps RHS' Expr
rhs Bool
ca) -> do
            let p :: Pattern
p   = List1 Pattern -> Pattern
C.rawAppP forall a b. (a -> b) -> a -> b
$ (forall a. KillRange a => KillRangeT a
killRange forall a b. (a -> b) -> a -> b
$ QName -> Pattern
IdentP forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName Name
cname) forall a. a -> [a] -> NonEmpty a
:| [Pattern]
ps
            let lhs :: LHS
lhs = Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS Pattern
p [] []
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
-> Bool
-> LHS
-> RHS' Expr
-> WhereClause' [Declaration]
-> [Clause]
-> Clause
C.Clause Name
cname Bool
ca LHS
lhs RHS' Expr
rhs forall decls. WhereClause' decls
NoWhere []
  Declaration
scdef <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NiceDeclaration
d

  -- Create the abstract syntax for the extended lambda.
  case Declaration
scdef of
    A.ScopedDecl ScopeInfo
si [A.FunDef DefInfo
di QName
qname' Delayed
NotDelayed [Clause]
cs] -> do
      ScopeInfo -> TCMT IO ()
setScope ScopeInfo
si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        ExprInfo -> DefInfo -> Erased -> QName -> List1 Clause -> Expr
A.ExtendedLam (Range -> ExprInfo
ExprRange Range
r) DefInfo
di Erased
erased QName
qname' forall a b. (a -> b) -> a -> b
$
        forall a. List1 a -> [a] -> List1 a
List1.fromListSafe forall a. HasCallStack => a
__IMPOSSIBLE__ [Clause]
cs
    Declaration
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Raise an error if argument is a C.Dot with Hiding info.

rejectPostfixProjectionWithHiding :: NamedArg C.Expr -> ScopeM ()
rejectPostfixProjectionWithHiding :: NamedArg Expr -> TCMT IO ()
rejectPostfixProjectionWithHiding NamedArg Expr
arg =
  case forall a. NamedArg a -> a
namedArg NamedArg Expr
arg of
    C.Dot{} | forall a. LensHiding a => a -> Bool
notVisible NamedArg Expr
arg -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Expr
arg forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Doc -> m a
genericDocError forall a b. (a -> b) -> a -> b
$
      Doc
"Illegal hiding in postfix projection " Doc -> Doc -> Doc
P.<+> forall a. Pretty a => a -> Doc
P.pretty NamedArg Expr
arg
    Expr
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Scope check an expression.

instance ToAbstract C.Expr where
  type AbsOfCon C.Expr = A.Expr

  toAbstract :: Expr -> ScopeM (AbsOfCon Expr)
toAbstract Expr
e =
    forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ReadTCState m => m Expr -> m Expr
annotateExpr forall a b. (a -> b) -> a -> b
$ case Expr
e of

  -- Names
      Ident QName
x -> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing)

  -- Literals
      C.Lit Range
r Literal
l -> do
        Literal -> TCMT IO ()
checkLiteral Literal
l
        case Literal
l of
          LitNat Integer
n -> do
            let builtin :: TCMT IO (Maybe Term)
builtin | Integer
n forall a. Ord a => a -> a -> Bool
< Integer
0     = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primFromNeg    -- negative literals are only allowed if FROMNEG is defined
                        | Bool
otherwise = Maybe Term -> TCMT IO (Maybe Term)
ensureInScope forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getBuiltin' [Char]
builtinFromNat
            TCMT IO (Maybe Term)
builtin forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just (I.Def QName
q Elims
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ QName -> Expr -> Expr
mkApp QName
q forall a b. (a -> b) -> a -> b
$ ExprInfo -> Literal -> Expr
A.Lit ExprInfo
i forall a b. (a -> b) -> a -> b
$ Integer -> Literal
LitNat forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs Integer
n
              Maybe Term
_                -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit

          LitString Text
s -> do
            forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getBuiltin' [Char]
builtinFromString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Term -> TCMT IO (Maybe Term)
ensureInScope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just (I.Def QName
q Elims
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ QName -> Expr -> Expr
mkApp QName
q Expr
alit
              Maybe Term
_                -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit

          Literal
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit
        where
        i :: ExprInfo
i       = Range -> ExprInfo
ExprRange Range
r
        alit :: Expr
alit    = ExprInfo -> Literal -> Expr
A.Lit ExprInfo
i Literal
l
        mkApp :: QName -> Expr -> Expr
mkApp QName
q = AppInfo -> Expr -> NamedArg Expr -> Expr
A.App (Range -> AppInfo
defaultAppInfo Range
r) (QName -> Expr
A.Def QName
q) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NamedArg a
defaultNamedArg

        -- #4925: Require fromNat/fromNeg to be in scope *unqualified* for literal overloading to
        -- apply.
        ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)
        ensureInScope :: Maybe Term -> TCMT IO (Maybe Term)
ensureInScope v :: Maybe Term
v@(Just (I.Def QName
q Elims
_)) =
          forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (QName -> ScopeInfo -> Bool
isNameInScopeUnqualified QName
q forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope) (forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
v) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
        ensureInScope Maybe Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  -- Meta variables
      C.QuestionMark Range
r Maybe Int
n -> do
        ScopeInfo
scope <- forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
        -- Andreas, 2014-04-06 create interaction point.
        InteractionId
ii <- forall (m :: * -> *).
MonadInteractionPoints m =>
Bool -> Range -> Maybe Int -> m InteractionId
registerInteractionPoint Bool
True Range
r Maybe Int
n
        let info :: MetaInfo
info = MetaInfo
             { metaRange :: Range
metaRange  = Range
r
             , metaScope :: ScopeInfo
metaScope  = ScopeInfo
scope
             , metaNumber :: Maybe MetaId
metaNumber = forall a. Maybe a
Nothing
             , metaNameSuggestion :: [Char]
metaNameSuggestion = [Char]
""
             }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MetaInfo -> InteractionId -> Expr
A.QuestionMark MetaInfo
info InteractionId
ii
      C.Underscore Range
r Maybe [Char]
n -> do
        ScopeInfo
scope <- forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MetaInfo -> Expr
A.Underscore forall a b. (a -> b) -> a -> b
$ MetaInfo
                    { metaRange :: Range
metaRange  = Range
r
                    , metaScope :: ScopeInfo
metaScope  = ScopeInfo
scope
                    , metaNumber :: Maybe MetaId
metaNumber = forall a. HasCallStack => a
__IMPOSSIBLE__ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Char]
n
                    , metaNameSuggestion :: [Char]
metaNameSuggestion = forall a. a -> Maybe a -> a
fromMaybe [Char]
"" Maybe [Char]
n
                    }

  -- Raw application
      C.RawApp Range
r List2 Expr
es -> do
        Expr
e <- List2 Expr -> ScopeM Expr
parseApplication List2 Expr
es
        forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e

  -- Application
      C.App Range
r Expr
e1 NamedArg Expr
e2 -> do
        -- Andreas, 2021-02-10, issue #3289: reject @e {.p}@ and @e ⦃ .p ⦄@.
        NamedArg Expr -> TCMT IO ()
rejectPostfixProjectionWithHiding NamedArg Expr
e2

        let parenPref :: ParenPreference
parenPref = Expr -> ParenPreference
inferParenPreference (forall a. NamedArg a -> a
namedArg NamedArg Expr
e2)
            info :: AppInfo
info = (Range -> AppInfo
defaultAppInfo Range
r) { appOrigin :: Origin
appOrigin = Origin
UserWritten, appParens :: ParenPreference
appParens = ParenPreference
parenPref }
        Expr
e1 <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
FunctionCtx Expr
e1
        NamedArg Expr
e2 <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx (ParenPreference -> Precedence
ArgumentCtx ParenPreference
parenPref) NamedArg Expr
e2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AppInfo -> Expr -> NamedArg Expr -> Expr
A.App AppInfo
info Expr
e1 NamedArg Expr
e2

  -- Operator application
      C.OpApp Range
r QName
op Set Name
ns OpAppArgs
es -> QName -> Set Name -> OpAppArgs -> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns OpAppArgs
es

  -- With application
      C.WithApp Range
r Expr
e [Expr]
es -> do
        Expr
e  <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
WithFunCtx Expr
e
        [Expr]
es <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
WithArgCtx) [Expr]
es
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr -> [Expr] -> Expr
A.WithApp (Range -> ExprInfo
ExprRange Range
r) Expr
e [Expr]
es

  -- Misplaced hidden argument
      C.HiddenArg Range
_ Named NamedName Expr
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToHiddenArg Expr
e
      C.InstanceArg Range
_ Named NamedName Expr
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToInstanceArg Expr
e

  -- Lambda
      C.AbsurdLam Range
r Hiding
h -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> Hiding -> Expr
A.AbsurdLam (Range -> ExprInfo
ExprRange Range
r) Hiding
h

      C.Lam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e -> Range
-> NonEmpty (LamBinding' TypedBinding)
-> Expr
-> Precedence
-> ScopeM Expr
toAbstractLam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e Precedence
TopCtx

  -- Extended Lambda
      C.ExtendedLam Range
r Erased
e List1 LamClause
cs -> Range -> Erased -> List1 LamClause -> ScopeM Expr
scopeCheckExtendedLam Range
r Erased
e List1 LamClause
cs

  -- Relevant and irrelevant non-dependent function type
      C.Fun Range
r (Arg ArgInfo
info1 Expr
e1) Expr
e2 -> do
        let arg :: Arg Expr
arg = ArgInfo -> Expr -> Arg Expr
mkArg' ArgInfo
info1 Expr
e1
        let mr :: Maybe Relevance
mr = case forall a. LensRelevance a => a -> Relevance
getRelevance Arg Expr
arg of
              Relevance
Relevant  -> forall a. Maybe a
Nothing
              Relevance
r         -> forall a. a -> Maybe a
Just Relevance
r
        let mh :: Maybe Hiding
mh = case forall a. LensHiding a => a -> Hiding
getHiding Arg Expr
arg of
              Hiding
NotHidden -> forall a. Maybe a
Nothing
              Hiding
h         -> forall a. a -> Maybe a
Just Hiding
h
        Arg ArgInfo
info (Expr
e1', Relevance
rel, Hiding
hid) <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
FunctionSpaceDomainCtx) Arg Expr
arg
        let updRel :: ArgInfo -> ArgInfo
updRel = case Relevance
rel of
              Relevance
Relevant -> forall a. a -> a
id
              Relevance
rel      -> forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
rel
        let updHid :: ArgInfo -> ArgInfo
updHid = case Hiding
hid of
              Hiding
NotHidden -> forall a. a -> a
id
              Hiding
hid       -> forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
hid
        ExprInfo -> Arg Expr -> Expr -> Expr
A.Fun (Range -> ExprInfo
ExprRange Range
r) (forall e. ArgInfo -> e -> Arg e
Arg (ArgInfo -> ArgInfo
updRel forall a b. (a -> b) -> a -> b
$ ArgInfo -> ArgInfo
updHid ArgInfo
info) Expr
e1') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e2

  -- Dependent function type
      e0 :: Expr
e0@(C.Pi Telescope1
tel Expr
e) -> do
        LocalVars
lvars0 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
        forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract Telescope1
tel forall a b. (a -> b) -> a -> b
$ \AbsOfCon Telescope1
tel -> do
          LocalVars
lvars1 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
          LocalVars -> LocalVars -> TCMT IO ()
checkNoShadowing LocalVars
lvars0 LocalVars
lvars1
          Expr
e <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e
          let info :: ExprInfo
info = Range -> ExprInfo
ExprRange (forall a. HasRange a => a -> Range
getRange Expr
e0)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> [TypedBinding] -> Expr -> Expr
A.mkPi ExprInfo
info (forall a. List1 (Maybe a) -> [a]
List1.catMaybes AbsOfCon Telescope1
tel) Expr
e

  -- Let
      e0 :: Expr
e0@(C.Let Range
_ List1 Declaration
ds (Just Expr
e)) ->
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM TCMT IO Bool
isInsideDotPattern (forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Let-expressions are not allowed in dot patterns") forall a b. (a -> b) -> a -> b
$
        forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract (List1 Declaration -> LetDefs
LetDefs List1 Declaration
ds) forall a b. (a -> b) -> a -> b
$ \AbsOfCon LetDefs
ds' -> do
          Expr
e <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e
          let info :: ExprInfo
info = Range -> ExprInfo
ExprRange (forall a. HasRange a => a -> Range
getRange Expr
e0)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> [LetBinding] -> Expr -> Expr
A.mkLet ExprInfo
info AbsOfCon LetDefs
ds' Expr
e
      C.Let Range
_ List1 Declaration
_ TacticAttribute
Nothing -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Missing body in let-expression"

  -- Record construction
      C.Rec Range
r RecordAssignments
fs  -> do
        [Either Assign (ModuleName, Maybe LetBinding)]
fs' <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx RecordAssignments
fs
        let ds' :: [LetBinding]
ds'  = [ LetBinding
d | Right (ModuleName
_, Just LetBinding
d) <- [Either Assign (ModuleName, Maybe LetBinding)]
fs' ]
            fs'' :: [Either Assign ModuleName]
fs'' = forall a b. (a -> b) -> [a] -> [b]
map (forall b d a. (b -> d) -> Either a b -> Either a d
mapRight forall a b. (a, b) -> a
fst) [Either Assign (ModuleName, Maybe LetBinding)]
fs'
            i :: ExprInfo
i    = Range -> ExprInfo
ExprRange Range
r
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> [LetBinding] -> Expr -> Expr
A.mkLet ExprInfo
i [LetBinding]
ds' (ExprInfo -> [Either Assign ModuleName] -> Expr
A.Rec ExprInfo
i [Either Assign ModuleName]
fs'')

  -- Record update
      C.RecUpdate Range
r Expr
e [FieldAssignment]
fs -> do
        ExprInfo -> Expr -> Assigns -> Expr
A.RecUpdate (Range -> ExprInfo
ExprRange Range
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx [FieldAssignment]
fs

  -- Parenthesis
      C.Paren Range
_ Expr
e -> forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e

  -- Idiom brackets
      C.IdiomBrackets Range
r [Expr]
es ->
        forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Range -> [Expr] -> ScopeM Expr
parseIdiomBracketsSeq Range
r [Expr]
es

  -- Do notation
      C.DoBlock Range
r List1 DoStmt
ss ->
        forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Range -> List1 DoStmt -> ScopeM Expr
desugarDoNotation Range
r List1 DoStmt
ss

  -- Post-fix projections
      C.Dot Range
r Expr
e  -> ExprInfo -> Expr -> Expr
A.Dot (Range -> ExprInfo
ExprRange Range
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e

  -- Pattern things
      C.As Range
_ Name
_ Expr
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
notAnExpression Expr
e
      C.Absurd Range
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
notAnExpression Expr
e

  -- Impossible things
      C.Equal{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Parse error: unexpected '='"
      C.Ellipsis Range
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Parse error: unexpected '...'"
      C.DoubleDot Range
_ Expr
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Parse error: unexpected '..'"

  -- Quoting
      C.Quote Range
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr
A.Quote (Range -> ExprInfo
ExprRange Range
r)
      C.QuoteTerm Range
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr
A.QuoteTerm (Range -> ExprInfo
ExprRange Range
r)
      C.Unquote Range
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr
A.Unquote (Range -> ExprInfo
ExprRange Range
r)

      C.Tactic Range
r Expr
e -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Syntax error: 'tactic' can only appear in attributes"

  -- DontCare
      C.DontCare Expr
e -> Expr -> Expr
A.DontCare forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e

  -- forall-generalize
      C.Generalized Expr
e -> do
        (Set QName
s, Expr
e) <- forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Set QName -> Expr -> Expr
A.generalized Set QName
s Expr
e

instance ToAbstract C.ModuleAssignment where
  type AbsOfCon C.ModuleAssignment = (A.ModuleName, Maybe A.LetBinding)
  toAbstract :: ModuleAssignment -> ScopeM (AbsOfCon ModuleAssignment)
toAbstract (C.ModuleAssignment QName
m [Expr]
es ImportDirective
i)
    | forall a. Null a => a -> Bool
null [Expr]
es Bool -> Bool -> Bool
&& forall n m. ImportDirective' n m -> Bool
isDefaultImportDir ImportDirective
i = (, forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
m)
    | Bool
otherwise = do
        Name
x <- Range -> NameId -> Name
C.NoName (forall a. HasRange a => a -> Range
getRange QName
m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (m :: * -> *). MonadFresh i m => m i
fresh
        LetBinding
r <- forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding
LetApply OpenKind
LetOpenModule (forall a. HasRange a => a -> Range
getRange (QName
m, [Expr]
es, ImportDirective
i)) Access
PublicAccess Name
x
               (Range -> Telescope -> Expr -> ModuleApplication
C.SectionApp (forall a. HasRange a => a -> Range
getRange (QName
m , [Expr]
es)) [] (List1 Expr -> Expr
rawApp (QName -> Expr
Ident QName
m forall a. a -> [a] -> NonEmpty a
:| [Expr]
es)))
               OpenShortHand
DontOpen ImportDirective
i
        case LetBinding
r of
          LetApply ModuleInfo
_ ModuleName
m' ModuleApplication
_ ScopeCopyInfo
_ ImportDirective
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m', forall a. a -> Maybe a
Just LetBinding
r)
          LetBinding
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__

instance ToAbstract c => ToAbstract (FieldAssignment' c) where
  type AbsOfCon (FieldAssignment' c) = FieldAssignment' (AbsOfCon c)

  toAbstract :: FieldAssignment' c -> ScopeM (AbsOfCon (FieldAssignment' c))
toAbstract = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract

instance ToAbstract (C.Binder' (NewName C.BoundName)) where
  type AbsOfCon (C.Binder' (NewName C.BoundName)) = A.Binder

  toAbstract :: Binder' (NewName BoundName)
-> ScopeM (AbsOfCon (Binder' (NewName BoundName)))
toAbstract (C.Binder Maybe Pattern
p NewName BoundName
n) = do
    let name :: Name
name = BoundName -> Name
C.boundName forall a b. (a -> b) -> a -> b
$ forall a. NewName a -> a
newName NewName BoundName
n
    -- If we do have a pattern then the variable needs to be inserted
    -- so we do need a proper internal name for it.
    NewName BoundName
n <- if Bool -> Bool
not (forall a. IsNoName a => a -> Bool
isNoName Name
name Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe Pattern
p) then forall (f :: * -> *) a. Applicative f => a -> f a
pure NewName BoundName
n else do
           Name
n' <- Range -> Int -> [Char] -> ScopeM Name
freshConcreteName (forall a. HasRange a => a -> Range
getRange forall a b. (a -> b) -> a -> b
$ forall a. NewName a -> a
newName NewName BoundName
n) Int
0 [Char]
patternInTeleName
           forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ BoundName
n -> BoundName
n { boundName :: Name
C.boundName = Name
n' }) NewName BoundName
n
    BindName
n <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NewName BoundName
n
    -- Actually parsing the pattern, checking it is linear,
    -- and bind its variables
    Maybe Pattern
p <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Pattern -> ScopeM Pattern
parsePattern Maybe Pattern
p
    Maybe (Pattern' Expr)
p <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe Pattern
p
    forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Maybe (Pattern' Expr)
p forall a b. (a -> b) -> a -> b
$ \[Name]
ys ->
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
    TCMT IO ()
bindVarsToBind
    Maybe Pattern
p <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe (Pattern' Expr)
p
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Maybe Pattern -> a -> Binder' a
A.Binder Maybe Pattern
p BindName
n

instance ToAbstract C.LamBinding where
  type AbsOfCon C.LamBinding = Maybe A.LamBinding

  toAbstract :: LamBinding' TypedBinding
-> ScopeM (AbsOfCon (LamBinding' TypedBinding))
toAbstract (C.DomainFree NamedArg Binder
x)  = do
    Maybe Expr
tac <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ BoundName -> TacticAttribute
bnameTactic forall a b. (a -> b) -> a -> b
$ forall a. Binder' a -> a
C.binderName forall a b. (a -> b) -> a -> b
$ forall a. NamedArg a -> a
namedArg NamedArg Binder
x
    forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Expr -> NamedArg (Binder' BindName) -> LamBinding
A.DomainFree Maybe Expr
tac forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a. BindingSource -> a -> NewName a
NewName BindingSource
LambdaBound) NamedArg Binder
x)
  toAbstract (C.DomainFull TypedBinding
tb) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypedBinding -> LamBinding
A.DomainFull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract TypedBinding
tb

makeDomainFull :: C.LamBinding -> C.TypedBinding
makeDomainFull :: LamBinding' TypedBinding -> TypedBinding
makeDomainFull (C.DomainFull TypedBinding
b) = TypedBinding
b
makeDomainFull (C.DomainFree NamedArg Binder
x) = forall e. Range -> List1 (NamedArg Binder) -> e -> TypedBinding' e
C.TBind Range
r (forall el coll. Singleton el coll => el -> coll
singleton NamedArg Binder
x) forall a b. (a -> b) -> a -> b
$ Range -> Maybe [Char] -> Expr
C.Underscore Range
r forall a. Maybe a
Nothing
  where r :: Range
r = forall a. HasRange a => a -> Range
getRange NamedArg Binder
x

instance ToAbstract C.TypedBinding where
  type AbsOfCon C.TypedBinding = Maybe A.TypedBinding

  toAbstract :: TypedBinding -> ScopeM (AbsOfCon TypedBinding)
toAbstract (C.TBind Range
r List1 (NamedArg Binder)
xs Expr
t) = do
    Expr
t' <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
    Maybe Expr
tac <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$
      -- Invariant: all tactics are the same
      -- (distributed in the parser, TODO: don't)
      case forall a b. (a -> Maybe b) -> List1 a -> [b]
List1.mapMaybe (BoundName -> TacticAttribute
bnameTactic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binder' a -> a
C.binderName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) List1 (NamedArg Binder)
xs of
        []      -> forall a. Maybe a
Nothing
        Expr
tac : [Expr]
_ -> forall a. a -> Maybe a
Just Expr
tac

    let fin :: Bool
fin = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (BoundName -> Bool
bnameIsFinite forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binder' a -> a
C.binderName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) List1 (NamedArg Binder)
xs
    List1 (NamedArg (Binder' BindName))
xs' <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a. BindingSource -> a -> NewName a
NewName BindingSource
LambdaBound)) List1 (NamedArg Binder)
xs

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Range
-> TypedBindingInfo
-> List1 (NamedArg (Binder' BindName))
-> Expr
-> TypedBinding
A.TBind Range
r (Maybe Expr -> Bool -> TypedBindingInfo
TypedBindingInfo Maybe Expr
tac Bool
fin) List1 (NamedArg (Binder' BindName))
xs' Expr
t'
  toAbstract (C.TLet Range
r List1 Declaration
ds) = Range -> [LetBinding] -> Maybe TypedBinding
A.mkTLet Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (List1 Declaration -> LetDefs
LetDefs List1 Declaration
ds)

-- | Scope check a module (top level function).
--
scopeCheckNiceModule
  :: Range
  -> Access
  -> C.Name
  -> C.Telescope
  -> ScopeM [A.Declaration]
  -> ScopeM A.Declaration
       -- ^ The returned declaration is an 'A.Section'.
scopeCheckNiceModule :: Range
-> Access
-> Name
-> Telescope
-> ScopeM [Declaration]
-> ScopeM Declaration
scopeCheckNiceModule Range
r Access
p Name
name Telescope
tel ScopeM [Declaration]
checkDs
  | Telescope -> Bool
telHasOpenStmsOrModuleMacros Telescope
tel = do
      -- Andreas, 2013-12-10:
      -- If the module telescope contains open statements
      -- or module macros (Issue 1299),
      -- add an extra anonymous module around the current one.
      -- Otherwise, the open statements would create
      -- identifiers in the parent scope of the current module.
      -- But open statements in the module telescope should
      -- only affect the current module!
      Range
-> Access
-> Name
-> Telescope
-> ScopeM [Declaration]
-> ScopeM Declaration
scopeCheckNiceModule forall a. Range' a
noRange Access
p Name
noName_ [] forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Access -> ScopeM Declaration
scopeCheckNiceModule_ Access
PublicAccess  -- See #4350

  | Bool
otherwise = do
        Access -> ScopeM Declaration
scopeCheckNiceModule_ Access
p
  where
    -- The actual workhorse:
    scopeCheckNiceModule_ :: Access -> ScopeM A.Declaration
    scopeCheckNiceModule_ :: Access -> ScopeM Declaration
scopeCheckNiceModule_ Access
p = do

      -- Check whether we are dealing with an anonymous module.
      -- This corresponds to a Coq/LEGO section.
      (Name
name, Access
p', Bool
open) <- do
        if forall a. IsNoName a => a -> Bool
isNoName Name
name then do
          (NameId
i :: NameId) <- forall i (m :: * -> *). MonadFresh i m => m i
fresh
          forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> NameId -> Name
C.NoName (forall a. HasRange a => a -> Range
getRange Name
name) NameId
i, Origin -> Access
PrivateAccess Origin
Inserted, Bool
True)
         else forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Access
p, Bool
False)

      -- Check and bind the module, using the supplied check for its contents.
      ModuleName
aname <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> NewModuleName
NewModuleName Name
name)
      Declaration
d <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r (Name -> QName
C.QName Name
name) ModuleName
aname Telescope
tel ScopeM [Declaration]
checkDs
      Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p' Name
name ModuleName
aname

      -- If the module was anonymous open it public
      -- unless it's private, in which case we just open it (#2099)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
open forall a b. (a -> b) -> a -> b
$
       forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ -- We can discard the returned default A.ImportDirective.
        OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> TCMT IO ImportDirective
openModule OpenKind
TopOpenModule (forall a. a -> Maybe a
Just ModuleName
aname) (Name -> QName
C.QName Name
name) forall a b. (a -> b) -> a -> b
$
          forall n m. ImportDirective' n m
defaultImportDir { publicOpen :: Maybe Range
publicOpen = forall a. Bool -> a -> Maybe a
boolToMaybe (Access
p forall a. Eq a => a -> a -> Bool
== Access
PublicAccess) forall a. Range' a
noRange }
      forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
d

-- | Check whether a telescope has open declarations or module macros.
telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool
telHasOpenStmsOrModuleMacros :: Telescope -> Bool
telHasOpenStmsOrModuleMacros = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {e}. TypedBinding' e -> Bool
yesBind
  where
    yesBind :: TypedBinding' e -> Bool
yesBind C.TBind{}     = Bool
False
    yesBind (C.TLet Range
_ List1 Declaration
ds) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes List1 Declaration
ds
    yes :: Declaration -> Bool
yes C.ModuleMacro{}   = Bool
True
    yes C.Open{}          = Bool
True
    yes C.Import{}        = Bool
True -- not __IMPOSSIBLE__, see Issue #1718
      -- However, it does not matter what we return here, as this will
      -- become an error later: "Not a valid let-declaration".
      -- (Andreas, 2015-11-17)
    yes (C.Mutual   Range
_ [Declaration]
ds) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes [Declaration]
ds
    yes (C.Abstract Range
_ [Declaration]
ds) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes [Declaration]
ds
    yes (C.Private Range
_ Origin
_ [Declaration]
ds) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes [Declaration]
ds
    yes Declaration
_                 = Bool
False

{- UNUSED
telHasLetStms :: C.Telescope -> Bool
telHasLetStms = any isLetBind
  where
    isLetBind C.TBind{} = False
    isLetBind C.TLet{}  = True
-}

-- | We for now disallow let-bindings in @data@ and @record@ telescopes.
--   This due "nested datatypes"; there is no easy interpretation of
--   @
--      data D (A : Set) (open M A) (b : B) : Set where
--        c : D (A × A) b → D A b
--   @
--   where @B@ is brought in scope by @open M A@.

class EnsureNoLetStms a where
  ensureNoLetStms :: a -> ScopeM ()

  default ensureNoLetStms :: (Foldable t, EnsureNoLetStms b, t b ~ a) => a -> ScopeM ()
  ensureNoLetStms = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms

instance EnsureNoLetStms C.Binder where
  ensureNoLetStms :: Binder -> TCMT IO ()
ensureNoLetStms arg :: Binder
arg@(C.Binder Maybe Pattern
p BoundName
n) =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Pattern
p) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Binder -> TypeError
IllegalPatternInTelescope Binder
arg

instance EnsureNoLetStms C.TypedBinding where
  ensureNoLetStms :: TypedBinding -> TCMT IO ()
ensureNoLetStms = \case
    tb :: TypedBinding
tb@C.TLet{}    -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ TypedBinding -> TypeError
IllegalLetInTelescope TypedBinding
tb
    C.TBind Range
_ List1 (NamedArg Binder)
xs Expr
_ -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) List1 (NamedArg Binder)
xs

instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where
  ensureNoLetStms :: LamBinding' a -> TCMT IO ()
ensureNoLetStms = \case
    -- GA: DO NOT use traverse here: `LamBinding'` only uses its parameter in
    --     the DomainFull constructor so we would miss out on some potentially
    --     illegal lets! Cf. #4402
    C.DomainFree NamedArg Binder
a -> forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms NamedArg Binder
a
    C.DomainFull a
a -> forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms a
a

instance EnsureNoLetStms a => EnsureNoLetStms (Named_ a) where
instance EnsureNoLetStms a => EnsureNoLetStms (NamedArg a) where
instance EnsureNoLetStms a => EnsureNoLetStms [a] where


-- | Returns the scope inside the checked module.
scopeCheckModule
  :: Range                   -- ^ The range of the module.
  -> C.QName                 -- ^ The concrete name of the module.
  -> A.ModuleName            -- ^ The abstract name of the module.
  -> C.Telescope             -- ^ The module telescope.
  -> ScopeM [A.Declaration]  -- ^ The code for checking the module contents.
  -> ScopeM (ScopeInfo, A.Declaration)
       -- ^ The returned declaration is an 'A.Section'.
scopeCheckModule :: Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r QName
x ModuleName
qm Telescope
tel ScopeM [Declaration]
checkDs = do
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"module" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"checking module " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
  -- Andreas, 2013-12-10: Telescope does not live in the new module
  -- but its parent, so check it before entering the new module.
  -- This is important for Nicolas Pouillard's open parametrized modules
  -- statements inside telescopes.
  (ScopeInfo, Declaration)
res <- forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
    GeneralizeTelescope
tel <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Telescope -> GenTel
GenTel Telescope
tel)
    forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
qm forall a b. (a -> b) -> a -> b
$ do
      -- pushScope m
      -- qm <- getCurrentModule
      [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"module" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"inside module " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
      [Declaration]
ds    <- ScopeM [Declaration]
checkDs
      ScopeInfo
scope <- forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
      forall (m :: * -> *) a. Monad m => a -> m a
return (ScopeInfo
scope, Range
-> ModuleName
-> GeneralizeTelescope
-> [Declaration]
-> Declaration
A.Section Range
r (ModuleName
qm ModuleName -> QName -> ModuleName
`withRangesOfQ` QName
x) GeneralizeTelescope
tel [Declaration]
ds)

  -- Binding is done by the caller
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"module" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"after module " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
  forall (m :: * -> *) a. Monad m => a -> m a
return (ScopeInfo, Declaration)
res

-- | Temporary data type to scope check a file.
data TopLevel a = TopLevel
  { forall a. TopLevel a -> AbsolutePath
topLevelPath           :: AbsolutePath
    -- ^ The file path from which we loaded this module.
  , forall a. TopLevel a -> TopLevelModuleName
topLevelExpectedName   :: TopLevelModuleName
    -- ^ The expected module name
    --   (coming from the import statement that triggered scope checking this file).
  , forall a. TopLevel a -> a
topLevelTheThing       :: a
    -- ^ The file content.
  }

data TopLevelInfo = TopLevelInfo
        { TopLevelInfo -> [Declaration]
topLevelDecls :: [A.Declaration]
        , TopLevelInfo -> ScopeInfo
topLevelScope :: ScopeInfo  -- ^ as seen from inside the module
        }

-- | The top-level module name.

topLevelModuleName :: TopLevelInfo -> A.ModuleName
topLevelModuleName :: TopLevelInfo -> ModuleName
topLevelModuleName = (forall o i. o -> Lens' i o -> i
^. Lens' ModuleName ScopeInfo
scopeCurrent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelInfo -> ScopeInfo
topLevelScope

-- | Top-level declarations are always
--   @
--     (import|open)*         -- a bunch of possibly opened imports
--     module ThisModule ...  -- the top-level module of this file
--   @
instance ToAbstract (TopLevel [C.Declaration]) where
    type AbsOfCon (TopLevel [C.Declaration]) = TopLevelInfo

    toAbstract :: TopLevel [Declaration]
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
toAbstract (TopLevel AbsolutePath
file TopLevelModuleName
expectedMName [Declaration]
ds) =
      -- A file is a bunch of preliminary decls (imports etc.)
      -- plus a single module decl.
      case [Declaration] -> ([Declaration], [Declaration])
C.spanAllowedBeforeModule [Declaration]
ds of

        -- If there are declarations after the top-level module
        -- we have to report a parse error here.
        ([Declaration]
_, C.Module{} : Declaration
d : [Declaration]
_) -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Declaration
d forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"No declarations allowed after top-level module."

        -- Otherwise, proceed.
        ([Declaration]
outsideDecls, [ C.Module Range
r QName
m0 Telescope
tel [Declaration]
insideDecls ]) -> do
          -- If the module name is _ compute the name from the file path
          (QName
m, TopLevelModuleName
top) <- if forall a. IsNoName a => a -> Bool
isNoName QName
m0
                then do
                  -- Andreas, 2017-07-28, issue #1077
                  -- Check if the insideDecls end in a single module which has the same
                  -- name as the file.  In this case, it is highly likely that the user
                  -- put some non-allowed declarations before the top-level module in error.
                  -- Andreas, 2017-10-19, issue #2808
                  -- Widen this check to:
                  -- If the first module of the insideDecls has the same name as the file,
                  -- report an error.
                  case forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> [a] -> ([a], [a])
span [Declaration]
insideDecls forall a b. (a -> b) -> a -> b
$ \case { C.Module{} -> Bool
False; Declaration
_ -> Bool
True } of
                    ([Declaration]
ds0, (C.Module Range
_ QName
m1 Telescope
_ [Declaration]
_ : [Declaration]
_))
                       | QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m1 forall a. Eq a => a -> a -> Bool
==
                         TopLevelModuleName -> RawTopLevelModuleName
rawTopLevelModuleName TopLevelModuleName
expectedMName
                         -- If the anonymous module comes from the user,
                         -- the range cannot be the beginningOfFile.
                         -- That is the range if the parser inserted the anon. module.
                       , Range
r forall a. Eq a => a -> a -> Bool
== Range -> Range
beginningOfFile (forall a. HasRange a => a -> Range
getRange [Declaration]
insideDecls) -> do

                         -- GA #4888: We know we are in a bad place. But we still scopecheck
                         -- the initial segment on the off chance we generate a better error
                         -- message.
                         forall (f :: * -> *) a. Functor f => f a -> f ()
void ScopeM [Declaration]
importPrimitives
                         forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
outsideDecls)
                         forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
ds0)
                         -- Fail with a crude error otherwise
                         forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Declaration]
ds0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError
                           [Char]
"Illegal declaration(s) before top-level module"

                    -- Otherwise, reconstruct the top-level module name
                    ([Declaration], [Declaration])
_ -> do
                      let m :: QName
m = Name -> QName
C.QName forall a b. (a -> b) -> a -> b
$ forall a. SetRange a => Range -> a -> a
setRange (forall a. HasRange a => a -> Range
getRange QName
m0) forall a b. (a -> b) -> a -> b
$
                              [Char] -> Name
C.simpleName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stringToRawName forall a b. (a -> b) -> a -> b
$
                              AbsolutePath -> [Char]
rootNameModule AbsolutePath
file
                      TopLevelModuleName
top <- RawTopLevelModuleName -> TCM TopLevelModuleName
S.topLevelModuleName
                               (QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m)
                      forall (m :: * -> *) a. Monad m => a -> m a
return (QName
m, TopLevelModuleName
top)
                -- Andreas, 2017-05-17, issue #2574, keep name as jump target!
                -- Andreas, 2016-07-12, ALTERNATIVE:
                -- -- We assign an anonymous file module the name expected from
                -- -- its import.  For flat file structures, this is the same.
                -- -- For hierarchical file structures, this reverses the behavior:
                -- -- Loading the file by itself will fail, but it can be imported.
                -- -- The previous behavior is: it can be loaded by itself, but not
                -- -- be imported
                -- then return $ C.fromTopLevelModuleName expectedMName
                else do
                -- Andreas, 2014-03-28  Issue 1078
                -- We need to check the module name against the file name here.
                -- Otherwise one could sneak in a lie and confuse the scope
                -- checker.
                  TopLevelModuleName
top <- RawTopLevelModuleName -> TCM TopLevelModuleName
S.topLevelModuleName
                           (QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m0)
                  TopLevelModuleName
-> SourceFile -> Maybe TopLevelModuleName -> TCMT IO ()
checkModuleName TopLevelModuleName
top (AbsolutePath -> SourceFile
SourceFile AbsolutePath
file) (forall a. a -> Maybe a
Just TopLevelModuleName
expectedMName)
                  forall (m :: * -> *) a. Monad m => a -> m a
return (QName
m0, TopLevelModuleName
top)
          TopLevelModuleName -> TCMT IO ()
setTopLevelModule TopLevelModuleName
top
          ModuleName
am <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> NewModuleQName
NewModuleQName QName
m)
          [Declaration]
primitiveImport <- ScopeM [Declaration]
importPrimitives
          -- Scope check the declarations outside
          [Declaration]
outsideDecls <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
outsideDecls)
          (ScopeInfo
insideScope, Declaration
insideDecl) <- Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r QName
m ModuleName
am Telescope
tel forall a b. (a -> b) -> a -> b
$
             forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
insideDecls)
          -- Andreas, 2020-05-13, issue #1804, #4647
          -- Do not eagerly remove private definitions, only when serializing
          -- let scope = over scopeModules (fmap $ restrictLocalPrivate am) insideScope
          let scope :: ScopeInfo
scope = ScopeInfo
insideScope
          ScopeInfo -> TCMT IO ()
setScope ScopeInfo
scope
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Declaration] -> ScopeInfo -> TopLevelInfo
TopLevelInfo ([Declaration]
primitiveImport forall a. [a] -> [a] -> [a]
++ [Declaration]
outsideDecls forall a. [a] -> [a] -> [a]
++ [ Declaration
insideDecl ]) ScopeInfo
scope

        -- We already inserted the missing top-level module, see
        -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',
        -- thus, this case is impossible:
        ([Declaration], [Declaration])
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Declaration @open import Agda.Primitive using (Set; Prop)@ when 'optImportSorts'.
importPrimitives :: ScopeM [A.Declaration]
importPrimitives :: ScopeM [Declaration]
importPrimitives = do
    Bool
noImportSorts <- Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PragmaOptions -> Bool
optImportSorts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
    -- Add implicit `open import Agda.Primitive using (Set; Prop)`
    let agdaPrimitiveName :: QName
agdaPrimitiveName   = Name -> QName -> QName
Qual ([Char] -> Name
C.simpleName [Char]
"Agda") forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName forall a b. (a -> b) -> a -> b
$ [Char] -> Name
C.simpleName [Char]
"Primitive"
        agdaSetName :: Name
agdaSetName         = [Char] -> Name
C.simpleName [Char]
"Set"
        agdaPropName :: Name
agdaPropName        = [Char] -> Name
C.simpleName [Char]
"Prop"
        usingDirective :: Using' Name m
usingDirective      = forall n m. [ImportedName' n m] -> Using' n m
Using [forall n m. n -> ImportedName' n m
ImportedName Name
agdaSetName, forall n m. n -> ImportedName' n m
ImportedName Name
agdaPropName]
        directives :: ImportDirective' Name m
directives          = forall n m.
Range
-> Using' n m
-> HidingDirective' n m
-> RenamingDirective' n m
-> Maybe Range
-> ImportDirective' n m
ImportDirective forall a. Range' a
noRange forall {m}. Using' Name m
usingDirective [] [] forall a. Maybe a
Nothing
        importAgdaPrimitive :: [Declaration]
importAgdaPrimitive = [Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> Declaration
C.Import forall a. Range' a
noRange QName
agdaPrimitiveName forall a. Maybe a
Nothing OpenShortHand
C.DoOpen forall {m}. ImportDirective' Name m
directives]
    if Bool
noImportSorts
      then forall (m :: * -> *) a. Monad m => a -> m a
return []
      else forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
importAgdaPrimitive)

-- | runs Syntax.Concrete.Definitions.niceDeclarations on main module
niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls :: forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
warn [Declaration]
ds [NiceDeclaration] -> ScopeM a
ret = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Declaration]
ds forall a b. (a -> b) -> a -> b
$ forall a. DoWarn -> [Declaration] -> ScopeM a -> ScopeM a
computeFixitiesAndPolarities DoWarn
warn [Declaration]
ds forall a b. (a -> b) -> a -> b
$ do
  Fixities
fixs <- forall (m :: * -> *) a. ReadTCState m => Lens' a ScopeInfo -> m a
useScope Lens' Fixities ScopeInfo
scopeFixities  -- We need to pass the fixities to the nicifier for clause grouping
  let (Either DeclarationException [NiceDeclaration]
result, NiceWarnings
warns') = forall a. Nice a -> (Either DeclarationException a, NiceWarnings)
runNice forall a b. (a -> b) -> a -> b
$ Fixities -> [Declaration] -> Nice [NiceDeclaration]
niceDeclarations Fixities
fixs [Declaration]
ds

  -- COMPILED pragmas are not allowed in safe mode unless we are in a builtin module.
  -- So we start by filtering out all the PragmaCompiled warnings if one of these two
  -- conditions is not met.
  Bool
isSafe    <- forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  Bool
isBuiltin <- forall (m :: * -> *). MonadIO m => [Char] -> m Bool
Lens.isBuiltinModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> [Char]
filePath forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadTCEnv m => m AbsolutePath
getCurrentPath
  let warns :: NiceWarnings
warns = if Bool
isSafe Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isBuiltin then NiceWarnings
warns' else forall a. (a -> Bool) -> [a] -> [a]
filter DeclarationWarning -> Bool
notOnlyInSafeMode NiceWarnings
warns'

  -- Respect the @DoWarn@ directive. For this to be sound, we need to know for
  -- sure that each @Declaration@ is checked at least once with @DoWarn@.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DoWarn
warn forall a. Eq a => a -> a -> Bool
== DoWarn
NoWarn Bool -> Bool -> Bool
|| forall a. Null a => a -> Bool
null NiceWarnings
warns) forall a b. (a -> b) -> a -> b
$ do
    -- If there are some warnings and the --safe flag is set,
    -- we check that none of the NiceWarnings are fatal
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSafe forall a b. (a -> b) -> a -> b
$ do
      let (NiceWarnings
errs, NiceWarnings
ws) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition DeclarationWarning -> Bool
unsafeDeclarationWarning NiceWarnings
warns
      -- If some of them are, we fail
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null NiceWarnings
errs) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
[Warning] -> m ()
warnings forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NiceWarnings
ws
        [TCWarning]
tcerrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m TCWarning
warning_ forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NiceWarnings
errs
        forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NiceWarnings
errs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [TCWarning] -> TypeError
NonFatalErrors [TCWarning]
tcerrs
    -- Otherwise we simply record the warnings
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ DeclarationWarning
w -> forall (m :: * -> *).
MonadWarning m =>
CallStack -> Warning -> m ()
warning' (DeclarationWarning -> CallStack
dwLocation DeclarationWarning
w) forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue DeclarationWarning
w) NiceWarnings
warns
  case Either DeclarationException [NiceDeclaration]
result of
    Left (DeclarationException CallStack
loc DeclarationException'
e) -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"error" Int
2 forall a b. (a -> b) -> a -> b
$ [Char]
"Error raised at " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow CallStack
loc
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Range -> Doc -> TCErr
Exception (forall a. HasRange a => a -> Range
getRange DeclarationException'
e) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty DeclarationException'
e
    Right [NiceDeclaration]
ds -> [NiceDeclaration] -> ScopeM a
ret [NiceDeclaration]
ds

  where notOnlyInSafeMode :: DeclarationWarning -> Bool
notOnlyInSafeMode = (WarningName
PragmaCompiled_ forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationWarning -> WarningName
declarationWarningName

-- | Wrapper to avoid instance conflict with generic list instance.
newtype Declarations = Declarations [C.Declaration]

instance ToAbstract Declarations where
  type AbsOfCon Declarations = [A.Declaration]

  toAbstract :: Declarations -> ScopeM (AbsOfCon Declarations)
toAbstract (Declarations [Declaration]
ds) = do
    -- When --safe is active the termination checker (Issue 586),
    -- positivity checker (Issue 1614) and the coverage checker
    -- may not be switched off, and polarities may not be assigned.
    [Declaration]
ds <- forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions)
               {- then -} (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds)
               {- else -} (forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds)

    forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn [Declaration]
ds forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
   where

     -- We need to dig deep into a declaration, otherwise it is possible
     -- to hide an illegal pragma in a block. Cf. Issue #3983
     noUnsafePragma :: C.Declaration -> TCM C.Declaration
     noUnsafePragma :: Declaration -> TCM Declaration
noUnsafePragma = \case
       C.Pragma Pragma
pr                 -> Pragma -> TCM Declaration
warnUnsafePragma Pragma
pr
       C.RecordDef Range
r Name
n RecordDirectives
dir [LamBinding' TypedBinding]
lams [Declaration]
ds -> Range
-> Name
-> RecordDirectives
-> [LamBinding' TypedBinding]
-> [Declaration]
-> Declaration
C.RecordDef Range
r Name
n RecordDirectives
dir [LamBinding' TypedBinding]
lams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       C.Record Range
r Name
n RecordDirectives
dir [LamBinding' TypedBinding]
lams Expr
e [Declaration]
ds  -> Range
-> Name
-> RecordDirectives
-> [LamBinding' TypedBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Name
n RecordDirectives
dir [LamBinding' TypedBinding]
lams Expr
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       C.Mutual Range
r [Declaration]
ds               -> Range -> [Declaration] -> Declaration
C.Mutual Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       C.Abstract Range
r [Declaration]
ds             -> Range -> [Declaration] -> Declaration
C.Abstract Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       C.Private Range
r Origin
o [Declaration]
ds            -> Range -> Origin -> [Declaration] -> Declaration
C.Private Range
r Origin
o forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       C.InstanceB Range
r [Declaration]
ds            -> Range -> [Declaration] -> Declaration
C.InstanceB Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       C.Macro Range
r [Declaration]
ds                -> Range -> [Declaration] -> Declaration
C.Macro Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> TCM Declaration
noUnsafePragma [Declaration]
ds
       Declaration
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration
d

     warnUnsafePragma :: C.Pragma -> TCM C.Declaration
     warnUnsafePragma :: Pragma -> TCM Declaration
warnUnsafePragma Pragma
pr = Pragma -> Declaration
C.Pragma Pragma
pr forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
       forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). MonadIO m => [Char] -> m Bool
Lens.isBuiltinModuleWithSafePostulates forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> [Char]
filePath forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadTCEnv m => m AbsolutePath
getCurrentPath)
         {- then -} (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
         {- else -} forall a b. (a -> b) -> a -> b
$ case Pragma -> Maybe Warning
unsafePragma Pragma
pr of
         Maybe Warning
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         Just Warning
w  -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pragma
pr forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
w

     unsafePragma :: C.Pragma -> Maybe Warning
     unsafePragma :: Pragma -> Maybe Warning
unsafePragma = \case
       C.NoCoverageCheckPragma{}    -> forall a. a -> Maybe a
Just Warning
SafeFlagNoCoverageCheck
       C.NoPositivityCheckPragma{}  -> forall a. a -> Maybe a
Just Warning
SafeFlagNoPositivityCheck
       C.PolarityPragma{}           -> forall a. a -> Maybe a
Just Warning
SafeFlagPolarity
       C.NoUniverseCheckPragma{}    -> forall a. a -> Maybe a
Just Warning
SafeFlagNoUniverseCheck
       C.InjectivePragma{}          -> forall a. a -> Maybe a
Just Warning
SafeFlagInjective
       C.TerminationCheckPragma Range
_ TerminationCheck
m -> case TerminationCheck
m of
         TerminationCheck
NonTerminating       -> forall a. a -> Maybe a
Just Warning
SafeFlagNonTerminating
         TerminationCheck
Terminating          -> forall a. a -> Maybe a
Just Warning
SafeFlagTerminating
         TerminationCheck
TerminationCheck     -> forall a. Maybe a
Nothing
         TerminationMeasure{} -> forall a. Maybe a
Nothing
         -- ASR (31 December 2015). We don't pattern-match on
         -- @NoTerminationCheck@ because the @NO_TERMINATION_CHECK@ pragma
         -- was removed. See Issue #1763.
         TerminationCheck
NoTerminationCheck -> forall a. Maybe a
Nothing
       -- exhaustive match to get told by ghc we should have a look at this
       -- when we add new pragmas.
       C.OptionsPragma{}    -> forall a. Maybe a
Nothing
       C.BuiltinPragma{}    -> forall a. Maybe a
Nothing
       C.ForeignPragma{}    -> forall a. Maybe a
Nothing
       C.StaticPragma{}     -> forall a. Maybe a
Nothing
       C.InlinePragma{}     -> forall a. Maybe a
Nothing
       C.ImpossiblePragma{} -> forall a. Maybe a
Nothing
       C.EtaPragma{}        -> forall a. a -> Maybe a
Just Warning
SafeFlagEta
       C.WarningOnUsage{}   -> forall a. Maybe a
Nothing
       C.WarningOnImport{}  -> forall a. Maybe a
Nothing
       C.DisplayPragma{}    -> forall a. Maybe a
Nothing
       C.CatchallPragma{}   -> forall a. Maybe a
Nothing
       -- @RewritePragma@ already requires --rewriting which is incompatible with --safe
       C.RewritePragma{}    -> forall a. Maybe a
Nothing
       -- @CompilePragma@ already handled in the nicifier
       C.CompilePragma{}    -> forall a. Maybe a
Nothing
       C.NotProjectionLikePragma{} -> forall a. Maybe a
Nothing


newtype LetDefs = LetDefs (List1 C.Declaration)
newtype LetDef = LetDef NiceDeclaration

instance ToAbstract LetDefs where
  type AbsOfCon LetDefs = [A.LetBinding]

  toAbstract :: LetDefs -> ScopeM (AbsOfCon LetDefs)
toAbstract (LetDefs List1 Declaration
ds) =
    forall a. [List1 a] -> [a]
List1.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn (forall l. IsList l => l -> [Item l]
List1.toList List1 Declaration
ds) (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> LetDef
LetDef)

instance ToAbstract LetDef where
  type AbsOfCon LetDef = List1 A.LetBinding
  toAbstract :: LetDef -> ScopeM (AbsOfCon LetDef)
toAbstract (LetDef NiceDeclaration
d) =
    case NiceDeclaration
d of
      NiceMutual Range
_ TerminationCheck
_ CoverageCheck
_ PositivityCheck
_ d :: [NiceDeclaration]
d@[C.FunSig Range
_ Access
_ IsAbstract
_ IsInstance
instanc IsMacro
macro ArgInfo
info TerminationCheck
_ CoverageCheck
_ Name
x Expr
t, C.FunDef Range
_ [Declaration]
_ IsAbstract
abstract IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_ [Clause
cl]] ->
          do  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsAbstract
abstract forall a. Eq a => a -> a -> Bool
== IsAbstract
AbstractDef) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"`abstract` not allowed in let expressions"
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsMacro
macro forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Macros cannot be defined in a let expression"
              Expr
t <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
t
              -- We bind the name here to make sure it's in scope for the LHS (#917).
              -- It's unbound for the RHS in letToAbstract.
              Fixity'
fx <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
              Name
x  <- BindName -> Name
A.unBind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (forall a. BindingSource -> a -> NewName a
NewName BindingSource
LetBound forall a b. (a -> b) -> a -> b
$ Name -> Fixity' -> BoundName
mkBoundName Name
x Fixity'
fx)
              (QName
x', Expr
e) <- Clause -> TCMT IO (QName, Expr)
letToAbstract Clause
cl
              -- If InstanceDef set info to Instance
              let info' :: ArgInfo
info' = case IsInstance
instanc of
                    InstanceDef Range
_  -> forall a. LensHiding a => a -> a
makeInstance ArgInfo
info
                    IsInstance
NotInstanceDef -> ArgInfo
info
              -- There are sometimes two instances of the
              -- let-bound variable, one declaration and one
              -- definition. The first list element below is
              -- used to highlight the declared instance in the
              -- right way (see Issue 1618).
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BindName -> LetBinding
A.LetDeclaredVariable (Name -> BindName
A.mkBindName (forall a. SetRange a => Range -> a -> a
setRange (forall a. HasRange a => a -> Range
getRange QName
x') Name
x)) forall a. a -> [a] -> NonEmpty a
:|
                     [ LetInfo -> ArgInfo -> BindName -> Expr -> Expr -> LetBinding
A.LetBind (Range -> LetInfo
LetRange forall a b. (a -> b) -> a -> b
$ forall a. HasRange a => a -> Range
getRange [NiceDeclaration]
d) ArgInfo
info' (Name -> BindName
A.mkBindName Name
x) Expr
t Expr
e
                     ]

      -- irrefutable let binding, like  (x , y) = rhs
      NiceFunClause Range
r Access
PublicAccess IsAbstract
ConcreteDef TerminationCheck
tc CoverageCheck
cc Bool
catchall d :: Declaration
d@(C.FunClause lhs :: LHS
lhs@(C.LHS Pattern
p0 [] []) RHS' Expr
rhs0 WhereClause' [Declaration]
wh Bool
ca) -> do
        WhereClause' [Declaration] -> TCMT IO ()
noWhereInLetBinding WhereClause' [Declaration]
wh
        Expr
rhs <- RHS' Expr -> ScopeM Expr
letBindingMustHaveRHS RHS' Expr
rhs0
        Either TCErr Pattern
mp  <- forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pattern
p0 forall a b. (a -> b) -> a -> b
$
                 (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM Pattern
parsePattern Pattern
p0)
                   forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
                 (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
        case Either TCErr Pattern
mp of
          Right Pattern
p -> do
            Expr
rhs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
            forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pattern
p0 forall a b. (a -> b) -> a -> b
$ do
              Pattern' Expr
p   <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
              forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' Expr
p
              forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p forall a b. (a -> b) -> a -> b
$ \[Name]
ys ->
                forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
              TCMT IO ()
bindVarsToBind
              Pattern
p   <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern' Expr
p
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton forall a b. (a -> b) -> a -> b
$ LetInfo -> Pattern -> Expr -> LetBinding
A.LetPatBind (Range -> LetInfo
LetRange Range
r) Pattern
p Expr
rhs
          -- It's not a record pattern, so it should be a prefix left-hand side
          Left TCErr
err ->
            case Pattern -> Maybe Name
definedName Pattern
p0 of
              Maybe Name
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
              Just Name
x  -> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> LetDef
LetDef forall a b. (a -> b) -> a -> b
$ Range
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
YesPositivityCheck
                [ Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
C.FunSig Range
r Access
PublicAccess IsAbstract
ConcreteDef IsInstance
NotInstanceDef IsMacro
NotMacroDef (forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted ArgInfo
defaultArgInfo) TerminationCheck
tc CoverageCheck
cc Name
x (Range -> Maybe [Char] -> Expr
C.Underscore (forall a. HasRange a => a -> Range
getRange Name
x) forall a. Maybe a
Nothing)
                , Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
C.FunDef Range
r forall a. HasCallStack => a
__IMPOSSIBLE__ IsAbstract
ConcreteDef IsInstance
NotInstanceDef forall a. HasCallStack => a
__IMPOSSIBLE__ forall a. HasCallStack => a
__IMPOSSIBLE__ forall a. HasCallStack => a
__IMPOSSIBLE__
                  [Name
-> Bool
-> LHS
-> RHS' Expr
-> WhereClause' [Declaration]
-> [Clause]
-> Clause
C.Clause Name
x (Bool
ca Bool -> Bool -> Bool
|| Bool
catchall) LHS
lhs (forall e. e -> RHS' e
C.RHS Expr
rhs) forall decls. WhereClause' decls
NoWhere []]
                ]
            where
              definedName :: Pattern -> Maybe Name
definedName (C.IdentP (C.QName Name
x)) = forall a. a -> Maybe a
Just Name
x
              definedName C.IdentP{}             = forall a. Maybe a
Nothing
              definedName (C.RawAppP Range
_ (List2 Pattern
p Pattern
_ [Pattern]
_)) = Pattern -> Maybe Name
definedName Pattern
p
              definedName (C.ParenP Range
_ Pattern
p)         = Pattern -> Maybe Name
definedName Pattern
p
              definedName C.WildP{}              = forall a. Maybe a
Nothing   -- for instance let _ + x = x in ... (not allowed)
              definedName C.AbsurdP{}            = forall a. Maybe a
Nothing
              definedName C.AsP{}                = forall a. Maybe a
Nothing
              definedName C.DotP{}               = forall a. Maybe a
Nothing
              definedName C.EqualP{}             = forall a. Maybe a
Nothing
              definedName C.LitP{}               = forall a. Maybe a
Nothing
              definedName C.RecP{}               = forall a. Maybe a
Nothing
              definedName C.QuoteP{}             = forall a. Maybe a
Nothing
              definedName C.HiddenP{}            = forall a. Maybe a
Nothing -- Not impossible, see issue #2291
              definedName C.InstanceP{}          = forall a. Maybe a
Nothing
              definedName C.WithP{}              = forall a. Maybe a
Nothing
              definedName C.AppP{}               = forall a. Maybe a
Nothing -- Not impossible, see issue #4586
              definedName C.OpAppP{}             = forall a. HasCallStack => a
__IMPOSSIBLE__
              definedName C.EllipsisP{}          = forall a. Maybe a
Nothing -- Not impossible, see issue #3937

      -- You can't open public in a let
      NiceOpen Range
r QName
x ImportDirective
dirs -> do
        forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dirs) forall a b. (a -> b) -> a -> b
$ \Range
r -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
        ModuleName
m    <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
x)
        ImportDirective
adir <- OpenKind -> QName -> ImportDirective -> TCMT IO ImportDirective
openModule_ OpenKind
LetOpenModule QName
x ImportDirective
dirs
        let minfo :: ModuleInfo
minfo = ModuleInfo
              { minfoRange :: Range
minfoRange  = Range
r
              , minfoAsName :: Maybe Name
minfoAsName = forall a. Maybe a
Nothing
              , minfoAsTo :: Range
minfoAsTo   = ImportDirective -> Range
renamingRange ImportDirective
dirs
              , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = forall a. Maybe a
Nothing
              , minfoDirective :: Maybe ImportDirective
minfoDirective = forall a. a -> Maybe a
Just ImportDirective
dirs
              }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModuleName -> ImportDirective -> LetBinding
A.LetOpen ModuleInfo
minfo ModuleName
m ImportDirective
adir

      NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
        forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dir) forall a b. (a -> b) -> a -> b
$ \ Range
r -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
        -- Andreas, 2014-10-09, Issue 1299: module macros in lets need
        -- to be private
        forall el coll. Singleton el coll => el -> coll
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding
LetApply OpenKind
LetOpenModule Range
r (Origin -> Access
PrivateAccess Origin
Inserted) Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir

      NiceDeclaration
_   -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding NiceDeclaration
d
    where
        letToAbstract :: Clause -> TCMT IO (QName, Expr)
letToAbstract (C.Clause Name
top Bool
_catchall (C.LHS Pattern
p [] []) RHS' Expr
rhs0 WhereClause' [Declaration]
wh []) = do
            WhereClause' [Declaration] -> TCMT IO ()
noWhereInLetBinding WhereClause' [Declaration]
wh
            Expr
rhs <- RHS' Expr -> ScopeM Expr
letBindingMustHaveRHS RHS' Expr
rhs0
            (QName
x, [NamedArg Pattern]
args) <- do
              LHSCore
res <- forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pattern
p forall a b. (a -> b) -> a -> b
$ QName -> Pattern -> TCMT IO LHSCore
parseLHS (Name -> QName
C.QName Name
top) Pattern
p
              case LHSCore
res of
                C.LHSHead QName
x [NamedArg Pattern]
args -> forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, [NamedArg Pattern]
args)
                C.LHSProj{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Copatterns not allowed in let bindings"
                C.LHSWith{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"`with` patterns not allowed in let bindings"
                C.LHSEllipsis{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"`...` not allowed in let bindings"

            Expr
e <- forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract [NamedArg Pattern]
args forall a b. (a -> b) -> a -> b
$ \AbsOfCon [NamedArg Pattern]
args -> do
                TCMT IO ()
bindVarsToBind
                -- Make sure to unbind the function name in the RHS, since lets are non-recursive.
                Expr
rhs <- forall a. Name -> ScopeM a -> ScopeM a
unbindVariable Name
top forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
                forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Expr -> Arg (Named NamedName (Pattern' Expr)) -> ScopeM Expr
lambda Expr
rhs (forall a. [a] -> [a]
reverse AbsOfCon [NamedArg Pattern]
args)  -- just reverse because these are DomainFree
            forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, Expr
e)
        letToAbstract Clause
_ = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding NiceDeclaration
d

        -- Named patterns not allowed in let definitions
        lambda :: Expr -> Arg (Named NamedName (Pattern' Expr)) -> ScopeM Expr
lambda Expr
e (Arg ArgInfo
info (Named Maybe NamedName
Nothing (A.VarP BindName
x))) =
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> LamBinding -> Expr -> Expr
A.Lam ExprInfo
i (NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree forall a b. (a -> b) -> a -> b
$ forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info forall a b. (a -> b) -> a -> b
$ forall a. a -> Binder' a
A.mkBinder BindName
x) Expr
e
            where i :: ExprInfo
i = Range -> ExprInfo
ExprRange (forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange BindName
x Expr
e)
        lambda Expr
e (Arg ArgInfo
info (Named Maybe NamedName
Nothing (A.WildP PatInfo
i))) =
            do  Name
x <- forall (m :: * -> *). MonadFresh NameId m => Range -> m Name
freshNoName (forall a. HasRange a => a -> Range
getRange PatInfo
i)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExprInfo -> LamBinding -> Expr -> Expr
A.Lam ExprInfo
i' (NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree forall a b. (a -> b) -> a -> b
$ forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info forall a b. (a -> b) -> a -> b
$ Name -> Binder' BindName
A.mkBinder_ Name
x) Expr
e
            where i' :: ExprInfo
i' = Range -> ExprInfo
ExprRange (forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange PatInfo
i Expr
e)
        lambda Expr
_ Arg (Named NamedName (Pattern' Expr))
_ = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding NiceDeclaration
d

        noWhereInLetBinding :: C.WhereClause -> ScopeM ()
        noWhereInLetBinding :: WhereClause' [Declaration] -> TCMT IO ()
noWhereInLetBinding = \case
          WhereClause' [Declaration]
NoWhere -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          WhereClause' [Declaration]
wh -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange WhereClause' [Declaration]
wh forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"`where` clauses not allowed in let bindings"
        letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr
        letBindingMustHaveRHS :: RHS' Expr -> ScopeM Expr
letBindingMustHaveRHS = \case
          C.RHS Expr
e -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
          RHS' Expr
C.AbsurdRHS -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Missing right hand side in let binding"

        -- Only record patterns allowed, but we do not exclude data constructors here.
        -- They will fail in the type checker.
        checkValidLetPattern :: A.Pattern' e -> ScopeM ()
        checkValidLetPattern :: forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern = \case
            A.VarP{}             -> TCMT IO ()
yes
            A.ConP ConPatInfo
_ AmbiguousQName
_ NAPs e
ps        -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) NAPs e
ps
            A.ProjP{}            -> forall {a}. TCMT IO a
no
            A.DefP{}             -> forall {a}. TCMT IO a
no
            A.WildP{}            -> TCMT IO ()
yes
            A.AsP PatInfo
_ BindName
_ Pattern' e
p          -> forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' e
p
            A.DotP{}             -> forall {a}. TCMT IO a
no
            A.AbsurdP{}          -> forall {a}. TCMT IO a
no
            A.LitP{}             -> forall {a}. TCMT IO a
no
            A.PatternSynP PatInfo
_ AmbiguousQName
_ NAPs e
ps -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) NAPs e
ps
            A.RecP PatInfo
_ [FieldAssignment' (Pattern' e)]
fs          -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FieldAssignment' a -> a
_exprFieldA) [FieldAssignment' (Pattern' e)]
fs
            A.EqualP{}           -> forall {a}. TCMT IO a
no
            A.WithP{}            -> forall {a}. TCMT IO a
no
            A.AnnP PatInfo
_ e
_ Pattern' e
p         -> forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' e
p
          where
          yes :: TCMT IO ()
yes = forall (m :: * -> *) a. Monad m => a -> m a
return ()
          no :: TCMT IO a
no  = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Not a valid let pattern"


instance ToAbstract NiceDeclaration where
  type AbsOfCon NiceDeclaration = A.Declaration

  toAbstract :: NiceDeclaration -> ScopeM (AbsOfCon NiceDeclaration)
toAbstract NiceDeclaration
d = forall (m :: * -> *).
ReadTCState m =>
m [Declaration] -> m Declaration
annotateDecls forall a b. (a -> b) -> a -> b
$
    forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
[Char] -> Int -> a -> m c -> m c
traceS [Char]
"scope.decl.trace" Int
50
      [ [Char]
"scope checking declaration"
      , [Char]
"  " forall a. [a] -> [a] -> [a]
++  forall a. Pretty a => a -> [Char]
prettyShow NiceDeclaration
d
      ] forall a b. (a -> b) -> a -> b
$
    forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
[Char] -> Int -> a -> m c -> m c
traceS [Char]
"scope.decl.trace" Int
80  -- keep this debug message for testing issue #4016
      [ [Char]
"scope checking declaration (raw)"
      , [Char]
"  " forall a. [a] -> [a] -> [a]
++  forall a. Show a => a -> [Char]
show NiceDeclaration
d
      ] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (NiceDeclaration -> Call
ScopeCheckDeclaration NiceDeclaration
d) forall a b. (a -> b) -> a -> b
$
    -- Andreas, 2015-10-05, Issue 1677:
    -- We record in the environment whether we are scope checking an
    -- abstract definition.  This way, we can propagate this attribute
    -- the extended lambdas.
    forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (NiceDeclaration -> Maybe IsAbstract
niceHasAbstract NiceDeclaration
d) forall a. a -> a
id (\ IsAbstract
a -> forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC forall a b. (a -> b) -> a -> b
$ \ TCEnv
e -> TCEnv
e { envAbstractMode :: AbstractMode
envAbstractMode = IsAbstract -> AbstractMode
aDefToMode IsAbstract
a }) forall a b. (a -> b) -> a -> b
$
    case NiceDeclaration
d of

  -- Axiom (actual postulate)
    C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
t -> do
      -- check that we do not postulate in --safe mode, unless it is a
      -- builtin module with safe postulates
      forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions) forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M`
             (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). MonadIO m => [Char] -> m Bool
Lens.isBuiltinModuleWithSafePostulates forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> [Char]
filePath forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadTCEnv m => m AbsolutePath
getCurrentPath)))
            (forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall a b. (a -> b) -> a -> b
$ Name -> Warning
SafeFlagPostulate Name
x)
      -- check the postulate
      forall el coll. Singleton el coll => el -> coll
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfName -> NiceDeclaration -> ScopeM Declaration
toAbstractNiceAxiom KindOfName
AxiomName NiceDeclaration
d

    C.NiceGeneralize Range
r Access
p ArgInfo
i TacticAttribute
tac Name
x Expr
t -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.decl" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"found nice generalize: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      Maybe Expr
tac <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
      Expr
t_ <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
      let (Set QName
s, Expr
t) = Expr -> (Set QName, Expr)
unGeneralized Expr
t_
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.decl" Int
50 forall a b. (a -> b) -> a -> b
$ [Char]
"generalizations: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Set a -> [a]
Set.toList Set QName
s, Expr
t)
      Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
      QName
y <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
      Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
GeneralizeName Name
x QName
y
      let info :: DefInfo
info = (forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
ConcreteDef Range
r) { defTactic :: Maybe Expr
defTactic = Maybe Expr
tac }
      forall (m :: * -> *) a. Monad m => a -> m a
return [Set QName -> DefInfo -> ArgInfo -> QName -> Expr -> Declaration
A.Generalize Set QName
s DefInfo
info ArgInfo
i QName
y Expr
t]

  -- Fields
    C.NiceField Range
r Access
p IsAbstract
a IsInstance
i TacticAttribute
tac Name
x Arg Expr
t -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Access
p forall a. Eq a => a -> a -> Bool
== Access
PublicAccess) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Record fields can not be private"
      -- Interaction points for record fields have already been introduced
      -- when checking the type of the record constructor.
      -- To avoid introducing interaction points (IP) twice, we turn
      -- all question marks to underscores.  (See issue 1138.)
      let maskIP :: Expr -> Expr
maskIP (C.QuestionMark Range
r Maybe Int
_) = Range -> Maybe [Char] -> Expr
C.Underscore Range
r forall a. Maybe a
Nothing
          maskIP Expr
e                     = Expr
e
      Maybe Expr
tac <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
      Arg Expr
t' <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx forall a b. (a -> b) -> a -> b
$ forall a. ExprLike a => (Expr -> Expr) -> a -> a
mapExpr Expr -> Expr
maskIP Arg Expr
t
      Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
      QName
y  <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
      -- Andreas, 2018-06-09 issue #2170
      -- We want dependent irrelevance without irrelevant projections,
      -- thus, do not disable irrelevant projections via the scope checker.
      -- irrProj <- optIrrelevantProjections <$> pragmaOptions
      -- unless (isIrrelevant t && not irrProj) $
      --   -- Andreas, 2010-09-24: irrelevant fields are not in scope
      --   -- this ensures that projections out of irrelevant fields cannot occur
      --   -- Ulf: unless you turn on --irrelevant-projections
      Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
FldName Name
x QName
y
      let info :: DefInfo
info = (forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
f Access
p IsAbstract
a IsInstance
i IsMacro
NotMacroDef Range
r) { defTactic :: Maybe Expr
defTactic = Maybe Expr
tac }
      forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> Arg Expr -> Declaration
A.Field DefInfo
info QName
y Arg Expr
t' ]

  -- Primitive function
    PrimitiveFunction Range
r Access
p IsAbstract
a Name
x Arg Expr
t -> do
      Arg Expr
t' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) Arg Expr
t
      Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
      QName
y  <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
      Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
PrimName Name
x QName
y
      forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> Arg Expr -> Declaration
A.Primitive (forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
a Range
r) QName
y Arg Expr
t' ]

  -- Definitions (possibly mutual)
    NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.mutual" Int
20 ([Char]
"starting checking mutual definitions: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow [NiceDeclaration]
ds)
      [Declaration]
ds' <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NiceDeclaration]
ds
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.mutual" Int
20 ([Char]
"finishing checking mutual definitions")
      -- We only termination check blocks that do not have a measure.
      forall (m :: * -> *) a. Monad m => a -> m a
return [ MutualInfo -> [Declaration] -> Declaration
A.Mutual (TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc Range
r) [Declaration]
ds' ]

    C.NiceRecSig Range
r Access
p IsAbstract
a PositivityCheck
_pc UniverseCheck
_uc Name
x [LamBinding' TypedBinding]
ls Expr
t -> do
      forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
ls
      forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
        (GeneralizeTelescope
ls', Expr
_) <- forall a. ScopeM a -> ScopeM a
withCheckNoShadowing forall a b. (a -> b) -> a -> b
$
          -- Minor hack: record types don't have indices so we include t when
          -- computing generalised parameters, but in the type checker any named
          -- generalizable arguments in the sort should be bound variables.
          forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Telescope -> Expr -> GenTelAndType
GenTelAndType (forall a b. (a -> b) -> [a] -> [b]
map LamBinding' TypedBinding -> TypedBinding
makeDomainFull [LamBinding' TypedBinding]
ls) Expr
t)
        Expr
t' <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
t
        Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        QName
x' <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
        Access -> KindOfName -> NameMetadata -> Name -> QName -> TCMT IO ()
bindName' Access
p KindOfName
RecName (Map QName Name -> NameMetadata
GeneralizedVarsMetadata forall a b. (a -> b) -> a -> b
$ GeneralizeTelescope -> Map QName Name
generalizeTelVars GeneralizeTelescope
ls') Name
x QName
x'
        forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> GeneralizeTelescope -> Expr -> Declaration
A.RecSig (forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
a Range
r) QName
x' GeneralizeTelescope
ls' Expr
t' ]

    C.NiceDataSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding' TypedBinding]
ls Expr
t -> do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.data.sig" Int
20 ([Char]
"checking DataSig for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x)
        forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
ls
        forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
          GeneralizeTelescope
ls' <- forall a. ScopeM a -> ScopeM a
withCheckNoShadowing forall a b. (a -> b) -> a -> b
$
            forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ Telescope -> GenTel
GenTel forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LamBinding' TypedBinding -> TypedBinding
makeDomainFull [LamBinding' TypedBinding]
ls
          Expr
t'  <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ Expr -> Expr
C.Generalized Expr
t
          Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
          QName
x' <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
          Maybe TypeError
mErr <- Access
-> KindOfName
-> NameMetadata
-> Name
-> QName
-> ScopeM (Maybe TypeError)
bindName'' Access
p KindOfName
DataName (Map QName Name -> NameMetadata
GeneralizedVarsMetadata forall a b. (a -> b) -> a -> b
$ GeneralizeTelescope -> Map QName Name
generalizeTelVars GeneralizeTelescope
ls') Name
x QName
x'
          forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TypeError
mErr forall a b. (a -> b) -> a -> b
$ \case
            err :: TypeError
err@(ClashingDefinition QName
cn QName
an Maybe NiceDeclaration
_) -> do
              QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                -- #4435: if a data type signature causes a ClashingDefinition error, and if
                -- the data type name is bound to an Axiom, then the error may be caused by
                -- the illegal type signature. Convert the NiceDataSig into a NiceDataDef
                -- (which removes the type signature) and suggest it as a possible fix.
                DefinedName Access
p AbstractName
ax Suffix
NoSuffix | AbstractName -> KindOfName
anameKind AbstractName
ax forall a. Eq a => a -> a -> Bool
== KindOfName
AxiomName -> do
                  let suggestion :: NiceDeclaration
suggestion = Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding' TypedBinding]
-> [NiceDeclaration]
-> NiceDeclaration
NiceDataDef Range
r Origin
Inserted IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding' TypedBinding]
ls []
                  forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition QName
cn QName
an (forall a. a -> Maybe a
Just NiceDeclaration
suggestion)
                ResolvedName
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
err
            TypeError
otherErr -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
otherErr
          forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> GeneralizeTelescope -> Expr -> Declaration
A.DataSig (forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
a Range
r) QName
x' GeneralizeTelescope
ls' Expr
t' ]

  -- Type signatures
    C.FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
_ CoverageCheck
_ Name
x Expr
t -> do
        let kind :: KindOfName
kind = if IsMacro
m forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef then KindOfName
MacroName else KindOfName
FunName
        forall el coll. Singleton el coll => el -> coll
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfName -> NiceDeclaration -> ScopeM Declaration
toAbstractNiceAxiom KindOfName
kind (Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
t)

  -- Function definitions
    C.FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
_ CoverageCheck
_ Name
x [Clause]
cs -> do
        Int -> [Char] -> TCMT IO ()
printLocals Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"checking def " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
        (QName
x',[Clause]
cs) <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (forall a. a -> OldName a
OldName Name
x,[Clause]
cs)
        -- Andreas, 2017-12-04 the name must reside in the current module
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((QName -> ModuleName
A.qnameModule QName
x' forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule) forall a b. (a -> b) -> a -> b
$
          forall a. HasCallStack => a
__IMPOSSIBLE__
        let delayed :: Delayed
delayed = Delayed
NotDelayed
        -- (delayed, cs) <- translateCopatternClauses cs -- TODO
        Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> Delayed -> [Clause] -> Declaration
A.FunDef (forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
f Access
PublicAccess IsAbstract
a IsInstance
i IsMacro
NotMacroDef Range
r) QName
x' Delayed
delayed [Clause]
cs ]

  -- Uncategorized function clauses
    C.NiceFunClause Range
_ Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ Bool
_ (C.FunClause LHS
lhs RHS' Expr
_ WhereClause' [Declaration]
_ Bool
_) ->
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
        [Char]
"Missing type signature for left hand side " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow LHS
lhs
    C.NiceFunClause{} -> forall a. HasCallStack => a
__IMPOSSIBLE__

  -- Data definitions
    C.NiceDataDef Range
r Origin
o IsAbstract
a PositivityCheck
_ UniverseCheck
uc Name
x [LamBinding' TypedBinding]
pars [NiceDeclaration]
cons -> do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.data.def" Int
20 ([Char]
"checking " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Origin
o forall a. [a] -> [a] -> [a]
++ [Char]
" DataDef for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x)
        (Access
p, AbstractName
ax) <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          DefinedName Access
p AbstractName
ax Suffix
NoSuffix -> do
            Name -> KindOfName -> AbstractName -> TCMT IO ()
clashUnless Name
x KindOfName
DataName AbstractName
ax  -- Andreas 2019-07-07, issue #3892
            forall a. LivesInCurrentModule a => a -> TCMT IO ()
livesInCurrentModule AbstractName
ax  -- Andreas, 2017-12-04, issue #2862
            Name -> AbstractName -> TCMT IO ()
clashIfModuleAlreadyDefinedInCurrentModule Name
x AbstractName
ax
            forall (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
          ResolvedName
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Missing type signature for data definition " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
        forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
pars
        forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
          Set Name
gvars <- Origin -> AbstractName -> ScopeM (Set Name)
bindGeneralizablesIfInserted Origin
o AbstractName
ax
          -- Check for duplicate constructors
          do [Name]
cs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NiceDeclaration -> ScopeM Name
conName [NiceDeclaration]
cons
             forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull (forall a. Ord a => [a] -> [a]
duplicates [Name]
cs) forall a b. (a -> b) -> a -> b
$ \ [Name]
dups -> do
               let bad :: [Name]
bad = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
cs
               forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Name]
bad forall a b. (a -> b) -> a -> b
$
                 forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
DuplicateConstructors [Name]
dups

          [LamBinding]
pars <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [LamBinding' TypedBinding]
pars
          let x' :: QName
x' = AbstractName -> QName
anameName AbstractName
ax
          -- Create the module for the qualified constructors
          Name -> TCMT IO ()
checkForModuleClash Name
x -- disallow shadowing previously defined modules
          let m :: ModuleName
m = QName -> ModuleName
qnameToMName QName
x'
          Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule (forall a. a -> Maybe a
Just DataOrRecordModule
IsDataModule) ModuleName
m
          Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p Name
x ModuleName
m  -- make it a proper module
          [Declaration]
cons <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (forall a b. (a -> b) -> [a] -> [b]
map (ModuleName
-> IsAbstract -> Access -> NiceDeclaration -> DataConstrDecl
DataConstrDecl ModuleName
m IsAbstract
a Access
p) [NiceDeclaration]
cons)
          [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"data" Int
20 forall a b. (a -> b) -> a -> b
$ [Char]
"Checked data " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
          Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
          forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> QName
-> UniverseCheck
-> DataDefParams
-> [Declaration]
-> Declaration
A.DataDef (forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
PublicAccess IsAbstract
a Range
r) QName
x' UniverseCheck
uc (Set Name -> [LamBinding] -> DataDefParams
DataDefParams Set Name
gvars [LamBinding]
pars) [Declaration]
cons ]
      where
        conName :: NiceDeclaration -> ScopeM Name
conName (C.Axiom Range
_ Access
_ IsAbstract
_ IsInstance
_ ArgInfo
_ Name
c Expr
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
c
        conName NiceDeclaration
d = forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d

  -- Record definitions (mucho interesting)
    C.NiceRecDef Range
r Origin
o IsAbstract
a PositivityCheck
_ UniverseCheck
uc Name
x (RecordDirectives Maybe (Ranged Induction)
ind Maybe HasEta0
eta Maybe Range
pat Maybe (Name, IsInstance)
cm) [LamBinding' TypedBinding]
pars [Declaration]
fields -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.rec.def" Int
20 ([Char]
"checking " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Origin
o forall a. [a] -> [a] -> [a]
++ [Char]
" RecDef for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x)
      -- #3008: Termination pragmas are ignored in records
      forall (f :: * -> *).
Foldable f =>
WhereOrRecord -> f Declaration -> TCMT IO ()
checkNoTerminationPragma WhereOrRecord
InRecordDef [Declaration]
fields
      -- Andreas, 2020-04-19, issue #4560
      -- 'pattern' declaration is incompatible with 'coinductive' or 'eta-equality'.
      forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Range
pat forall a b. (a -> b) -> a -> b
$ \ Range
r -> do
        let warn :: [Char] -> TCMT IO ()
warn = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Warning
UselessPatternDeclarationForRecord
        if | Just (Ranged Range
_ Induction
CoInductive) <- Maybe (Ranged Induction)
ind -> [Char] -> TCMT IO ()
warn [Char]
"coinductive"
           | Just HasEta0
YesEta                 <- Maybe HasEta0
eta -> [Char] -> TCMT IO ()
warn [Char]
"eta"
           | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      (Access
p, AbstractName
ax) <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        DefinedName Access
p AbstractName
ax Suffix
NoSuffix -> do
          Name -> KindOfName -> AbstractName -> TCMT IO ()
clashUnless Name
x KindOfName
RecName AbstractName
ax  -- Andreas 2019-07-07, issue #3892
          forall a. LivesInCurrentModule a => a -> TCMT IO ()
livesInCurrentModule AbstractName
ax  -- Andreas, 2017-12-04, issue #2862
          Name -> AbstractName -> TCMT IO ()
clashIfModuleAlreadyDefinedInCurrentModule Name
x AbstractName
ax
          forall (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
        ResolvedName
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Missing type signature for record definition " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
      forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
pars
      forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
        Set Name
gvars <- Origin -> AbstractName -> ScopeM (Set Name)
bindGeneralizablesIfInserted Origin
o AbstractName
ax
        -- Check that the generated module doesn't clash with a previously
        -- defined module
        Name -> TCMT IO ()
checkForModuleClash Name
x
        [LamBinding]
pars   <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [LamBinding' TypedBinding]
pars
        let x' :: QName
x' = AbstractName -> QName
anameName AbstractName
ax
        -- We scope check the fields a first time when putting together
        -- the type of the constructor.
        Expr
contel <- forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract ([Declaration] -> RecordConstructorType
RecordConstructorType [Declaration]
fields) forall (m :: * -> *) a. Monad m => a -> m a
return
        ModuleName
m0     <- forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
        let m :: ModuleName
m = ModuleName -> ModuleName -> ModuleName
A.qualifyM ModuleName
m0 forall a b. (a -> b) -> a -> b
$ List1 Name -> ModuleName
mnameFromList1 forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
List1.last forall a b. (a -> b) -> a -> b
$ QName -> List1 Name
qnameToList QName
x'
        [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"rec" Int
15 [Char]
"before record"
        Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule (forall a. a -> Maybe a
Just DataOrRecordModule
IsRecordModule) ModuleName
m
        -- We scope check the fields a second time, as actual fields.
        [Declaration]
afields <- forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ do
          [Declaration]
afields <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
fields)
          [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"rec" Int
15 [Char]
"checked fields"
          forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
afields
        -- Andreas, 2017-07-13 issue #2642 disallow duplicate fields
        -- Check for duplicate fields. (See "Check for duplicate constructors")
        do let fs :: [C.Name]
               fs :: [Name]
fs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> (a -> Maybe b) -> [b]
forMaybe [Declaration]
fields forall a b. (a -> b) -> a -> b
$ \case
                 C.Field Range
_ [Declaration]
fs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Declaration]
fs forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \case
                   -- a Field block only contains field signatures
                   C.FieldSig IsInstance
_ TacticAttribute
_ Name
f Arg Expr
_ -> Name
f
                   Declaration
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
                 Declaration
_ -> forall a. Maybe a
Nothing
           forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull (forall a. Ord a => [a] -> [a]
duplicates [Name]
fs) forall a b. (a -> b) -> a -> b
$ \ [Name]
dups -> do
             let bad :: [Name]
bad = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
fs
             forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Name]
bad forall a b. (a -> b) -> a -> b
$
               forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
DuplicateFields [Name]
dups
        Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p Name
x ModuleName
m
        let kind :: KindOfName
kind = forall b a. b -> (a -> b) -> Maybe a -> b
maybe KindOfName
ConName (Induction -> KindOfName
conKindOfName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ranged a -> a
rangedThing) Maybe (Ranged Induction)
ind
        -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.
        Maybe QName
cm' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Name, IsInstance)
cm forall a b. (a -> b) -> a -> b
$ \ (Name
c, IsInstance
_) -> Name -> KindOfName -> IsAbstract -> Access -> TCMT IO QName
bindRecordConstructorName Name
c KindOfName
kind IsAbstract
a Access
p
        let inst :: IsInstance
inst = forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Name, IsInstance)
cm IsInstance
NotInstanceDef forall a b. (a, b) -> b
snd
        [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"rec" Int
15 [Char]
"record complete"
        Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        let params :: DataDefParams
params = Set Name -> [LamBinding] -> DataDefParams
DataDefParams Set Name
gvars [LamBinding]
pars
        let dir' :: RecordDirectives' QName
dir' = forall a.
Maybe (Ranged Induction)
-> Maybe HasEta0 -> Maybe Range -> Maybe a -> RecordDirectives' a
RecordDirectives Maybe (Ranged Induction)
ind Maybe HasEta0
eta Maybe Range
pat Maybe QName
cm'
        forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> QName
-> UniverseCheck
-> RecordDirectives' QName
-> DataDefParams
-> Expr
-> [Declaration]
-> Declaration
A.RecDef (forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
f Access
PublicAccess IsAbstract
a IsInstance
inst IsMacro
NotMacroDef Range
r) QName
x' UniverseCheck
uc RecordDirectives' QName
dir' DataDefParams
params Expr
contel [Declaration]
afields ]

    NiceModule Range
r Access
p IsAbstract
a x :: QName
x@(C.QName Name
name) Telescope
tel [Declaration]
ds -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
        [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking NiceModule " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
        ]

      Declaration
adecl <- forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (NiceDeclaration -> Call
ScopeCheckDeclaration forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> QName
-> Telescope
-> [Declaration]
-> NiceDeclaration
NiceModule Range
r Access
p IsAbstract
a QName
x Telescope
tel []) forall a b. (a -> b) -> a -> b
$ do
        Range
-> Access
-> Name
-> Telescope
-> ScopeM [Declaration]
-> ScopeM Declaration
scopeCheckNiceModule Range
r Access
p Name
name Telescope
tel forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
ds)

      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
        [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked NiceModule " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
        , forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Declaration
adecl
        ]
      forall (m :: * -> *) a. Monad m => a -> m a
return [ Declaration
adecl ]

    NiceModule Range
_ Access
_ IsAbstract
_ m :: QName
m@C.Qual{} Telescope
_ [Declaration]
_ ->
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Local modules cannot have qualified names"

    NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
        [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking NiceModuleMacro " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
        ]

      Declaration
adecl <- forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> Declaration
Apply OpenKind
TopOpenModule Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir

      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
        [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked NiceModuleMacro " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x
        , forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Declaration
adecl
        ]
      forall (m :: * -> *) a. Monad m => a -> m a
return [ Declaration
adecl ]

    NiceOpen Range
r QName
x ImportDirective
dir -> do
      (ModuleInfo
minfo, ModuleName
m, ImportDirective
adir) <- Range
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
checkOpen Range
r forall a. Maybe a
Nothing QName
x ImportDirective
dir
      forall (m :: * -> *) a. Monad m => a -> m a
return [ModuleInfo -> ModuleName -> ImportDirective -> Declaration
A.Open ModuleInfo
minfo ModuleName
m ImportDirective
adir]

    NicePragma Range
r Pragma
p -> do
      [Pragma]
ps <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pragma
p  -- could result in empty list of pragmas
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Range -> Pragma -> Declaration
A.Pragma Range
r) [Pragma]
ps

    NiceImport Range
r QName
x Maybe AsName
as OpenShortHand
open ImportDirective
dir -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ do
      ImportDirective
dir <- OpenShortHand -> ImportDirective -> ScopeM ImportDirective
notPublicWithoutOpen OpenShortHand
open ImportDirective
dir

      -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name.
      let illformedAs :: [Char] -> TCMT IO (Maybe (AsName' Name))
illformedAs [Char]
s = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Maybe AsName
as forall a b. (a -> b) -> a -> b
$ do
            -- If @as@ is followed by something that is not a simple name,
            -- throw a warning and discard the as-clause.
            forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning ([Char] -> Warning
IllformedAsClause [Char]
s)
      Maybe (AsName' Name)
as <- case Maybe AsName
as of
        -- Ok if no as-clause or it (already) contains a Name.
        Maybe AsName
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (AsName (Right Name
asName) Range
r)                    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Range -> AsName' a
AsName Name
asName Range
r
        Just (AsName (Left (C.Ident (C.QName Name
asName))) Range
r) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Range -> AsName' a
AsName Name
asName Range
r
        Just (AsName (Left C.Underscore{})     Range
r)         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Range -> AsName' a
AsName forall a. Underscore a => a
underscore Range
r
        Just (AsName (Left (C.Ident C.Qual{})) Range
r) -> [Char] -> TCMT IO (Maybe (AsName' Name))
illformedAs [Char]
"; a qualified name is not allowed here"
        Just (AsName (Left Expr
e)                  Range
r) -> [Char] -> TCMT IO (Maybe (AsName' Name))
illformedAs [Char]
""

      TopLevelModuleName
top <- RawTopLevelModuleName -> TCM TopLevelModuleName
S.topLevelModuleName (QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
x)
      -- First scope check the imported module and return its name and
      -- interface. This is done with that module as the top-level module.
      -- This is quite subtle. We rely on the fact that when setting the
      -- top-level module and generating a fresh module name, the generated
      -- name will be exactly the same as the name generated when checking
      -- the imported module.
      (ModuleName
m, Map ModuleName Scope
i) <- forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
noModuleName forall a b. (a -> b) -> a -> b
$
                forall a. TopLevelModuleName -> TCM a -> TCM a
withTopLevelModule TopLevelModuleName
top forall a b. (a -> b) -> a -> b
$ do
        ModuleName
m <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> NewModuleQName
NewModuleQName QName
x  -- (No longer erases the contents of @m@.)
        [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"import" Int
10 [Char]
"before import:"
        (ModuleName
m, Map ModuleName Scope
i) <- TopLevelModuleName
-> ModuleName -> TCMT IO (ModuleName, Map ModuleName Scope)
scopeCheckImport TopLevelModuleName
top ModuleName
m
        [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"import" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked import: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Map ModuleName Scope
i
        -- We don't want the top scope of the imported module (things happening
        -- before the module declaration)
        forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m, forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ModuleName
noModuleName Map ModuleName Scope
i)

      -- Bind the desired module name to the right abstract name.
      (QName
name, Range
theAsSymbol, Maybe Name
theAsName) <- case Maybe (AsName' Name)
as of

         Just AsName' Name
a | let y :: Name
y = forall a. AsName' a -> a
asName AsName' Name
a, Bool -> Bool
not (forall a. IsNoName a => a -> Bool
isNoName Name
y) -> do
           Access -> Name -> ModuleName -> TCMT IO ()
bindModule (Origin -> Access
PrivateAccess Origin
Inserted) Name
y ModuleName
m
           forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> QName
C.QName Name
y, forall a. AsName' a -> Range
asRange AsName' Name
a, forall a. a -> Maybe a
Just Name
y)

         Maybe (AsName' Name)
_ -> do
           -- Don't bind if @import ... as _@ with "no name"
           forall m a. Monoid m => Maybe a -> m -> m
whenNothing Maybe (AsName' Name)
as forall a b. (a -> b) -> a -> b
$ Access -> QName -> ModuleName -> TCMT IO ()
bindQModule (Origin -> Access
PrivateAccess Origin
Inserted) QName
x ModuleName
m
           forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, forall a. Range' a
noRange, forall a. Maybe a
Nothing)

      -- Open if specified, otherwise apply import directives
      ImportDirective
adir <- case OpenShortHand
open of

        -- With @open@ import directives apply to the opening.
        -- The module is thus present in its qualified form without restrictions.
        OpenShortHand
DoOpen   -> do

          -- Merge the imported scopes with the current scopes.
          -- This might override a previous import of @m@, but monotonously (add stuff).
          (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
modifyScopes forall a b. (a -> b) -> a -> b
$ \ Map ModuleName Scope
ms -> forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Scope -> Scope -> Scope
mergeScope (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ModuleName
m Map ModuleName Scope
ms) Map ModuleName Scope
i

          -- Andreas, 2019-05-29, issue #3818.
          -- Pass the resolved name to open instead triggering another resolution.
          -- This helps in situations like
          -- @
          --    module Top where
          --    module M where
          --    open import M
          -- @
          -- It is clear than in @open import M@, name @M@ must refer to a file
          -- rather than the above defined local module @M@.
          -- This already worked in the situation
          -- @
          --    module Top where
          --    module M where
          --    import M
          -- @
          -- Note that the manual desugaring of @open import@ as
          -- @
          --    module Top where
          --    module M where
          --    import M
          --    open M
          -- @
          -- will not work, as @M@ is now ambiguous in @open M@;
          -- the information that @M@ is external is lost here.
          (ModuleInfo
_minfo, ModuleName
_m, ImportDirective
adir) <- Range
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
checkOpen Range
r (forall a. a -> Maybe a
Just ModuleName
m) QName
name ImportDirective
dir
          forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
adir

        -- If not opening, import directives are applied to the original scope.
        OpenShortHand
DontOpen -> do
          (ImportDirective
adir, Map ModuleName Scope
i') <- forall (f :: * -> *) k v a.
(Functor f, Ord k) =>
(v -> f (a, v)) -> k -> Map k v -> f (a, Map k v)
Map.adjustM' (QName
-> ImportDirective -> Scope -> TCMT IO (ImportDirective, Scope)
applyImportDirectiveM QName
x ImportDirective
dir) ModuleName
m Map ModuleName Scope
i
          -- Andreas, 2020-05-18, issue #3933
          -- We merge the new imports without deleting old imports, to be monotone.
          (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
modifyScopes forall a b. (a -> b) -> a -> b
$ \ Map ModuleName Scope
ms -> forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Scope -> Scope -> Scope
mergeScope Map ModuleName Scope
ms Map ModuleName Scope
i'
          forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
adir

      [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"import" Int
10 [Char]
"merged imported sig:"
      let minfo :: ModuleInfo
minfo = ModuleInfo
            { minfoRange :: Range
minfoRange     = Range
r
            , minfoAsName :: Maybe Name
minfoAsName    = Maybe Name
theAsName
            , minfoAsTo :: Range
minfoAsTo      = forall a. HasRange a => a -> Range
getRange (Range
theAsSymbol, ImportDirective -> Range
renamingRange ImportDirective
dir)
            , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = forall a. a -> Maybe a
Just OpenShortHand
open
            , minfoDirective :: Maybe ImportDirective
minfoDirective = forall a. a -> Maybe a
Just ImportDirective
dir
            }
      forall (m :: * -> *) a. Monad m => a -> m a
return [ ModuleInfo -> ModuleName -> ImportDirective -> Declaration
A.Import ModuleInfo
minfo ModuleName
m ImportDirective
adir ]

    NiceUnquoteDecl Range
r Access
p IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
xs Expr
e -> do
      [Fixity']
fxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
      [QName]
ys <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Fixity' -> Name -> TCMT IO QName
freshAbstractQName [Fixity']
fxs [Name]
xs
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
QuotableName) [Name]
xs [QName]
ys
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
p KindOfName
OtherDefName) [Name]
xs [QName]
ys
      let mi :: MutualInfo
mi = TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo TerminationCheck
tc CoverageCheck
cc PositivityCheck
YesPositivityCheck Range
r
      forall (m :: * -> *) a. Monad m => a -> m a
return [ MutualInfo -> [Declaration] -> Declaration
A.Mutual MutualInfo
mi [MutualInfo -> [DefInfo] -> [QName] -> Expr -> Declaration
A.UnquoteDecl MutualInfo
mi [ forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
fx Access
p IsAbstract
a IsInstance
i IsMacro
NotMacroDef Range
r | (Fixity'
fx, Name
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Fixity']
fxs [Name]
xs ] [QName]
ys Expr
e] ]

    NiceUnquoteDef Range
r Access
p IsAbstract
a TerminationCheck
_ CoverageCheck
_ [Name]
xs Expr
e -> do
      [Fixity']
fxs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
      [QName]
ys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> OldName a
OldName) [Name]
xs
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
p KindOfName
QuotableName) [Name]
xs [QName]
ys
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
p KindOfName
OtherDefName) [Name]
xs [QName]
ys
      forall (m :: * -> *) a. Monad m => a -> m a
return [ [DefInfo] -> [QName] -> Expr -> Declaration
A.UnquoteDef [ forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
fx Access
PublicAccess IsAbstract
a Range
r | (Fixity'
fx, Name
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Fixity']
fxs [Name]
xs ] [QName]
ys Expr
e ]

    NiceUnquoteData Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [Name]
cs Expr
e -> do
      Fixity'
fx <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
      QName
x' <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
fx Name
x
      Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
QuotableName Name
x QName
x'

      -- Create the module for the qualified constructors
      Name -> TCMT IO ()
checkForModuleClash Name
x
      let m :: ModuleName
m = QName -> ModuleName
qnameToMName QName
x'
      Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule (forall a. a -> Maybe a
Just DataOrRecordModule
IsDataModule) ModuleName
m
      Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p Name
x ModuleName
m  -- make it a proper module

      [QName]
cs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModuleName -> Access -> Name -> TCMT IO QName
bindUnquoteConstructorName ModuleName
m Access
p) [Name]
cs

      Expr
e <- forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e

      Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
p KindOfName
DataName Name
x QName
x'
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
p KindOfName
ConName) [Name]
cs [QName]
cs'
      forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
p KindOfName
ConName) [Name]
cs [QName]
cs'

      [Fixity']
fcs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
cs
      let mi :: MutualInfo
mi = TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo forall m. TerminationCheck m
TerminationCheck CoverageCheck
YesCoverageCheck PositivityCheck
pc Range
r
      forall (m :: * -> *) a. Monad m => a -> m a
return
        [ MutualInfo -> [Declaration] -> Declaration
A.Mutual
          MutualInfo
mi [[DefInfo]
-> QName
-> UniverseCheck
-> [DefInfo]
-> [QName]
-> Expr
-> Declaration
A.UnquoteData
            [ forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
fx Access
p IsAbstract
a Range
r ] QName
x' UniverseCheck
uc
            [ forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
c Fixity'
fc Access
p IsAbstract
a Range
r | (Fixity'
fc, Name
c) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Fixity']
fcs [Name]
cs] [QName]
cs' Expr
e ]
        ]

    NicePatternSyn Range
r Access
a Name
n [Arg Name]
as Pattern
p -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 forall a b. (a -> b) -> a -> b
$ [Char]
"found nice pattern syn: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
n
      ([Arg Name]
as, Pattern' Void
p) <- forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
         Pattern' Expr
p  <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pattern -> ScopeM Pattern
parsePatternSyn Pattern
p
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall p. APatternLike p => p -> Bool
containsAsPattern Pattern' Expr
p) forall a b. (a -> b) -> a -> b
$
           forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$
             [Char]
"@-patterns are not allowed in pattern synonyms"
         forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p forall a b. (a -> b) -> a -> b
$ \[Name]
ys ->
           forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
         TCMT IO ()
bindVarsToBind
         let err :: [Char]
err = [Char]
"Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead."
         Pattern' Void
p <- forall e. [Char] -> Pattern' e -> ScopeM (Pattern' Void)
noDotorEqPattern [Char]
err Pattern' Expr
p
         [Arg Name]
as <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM) (forall {m :: * -> *}.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
ResolvedName -> m Name
unVarName forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< QName -> ScopeM ResolvedName
resolveName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName) [Arg Name]
as
         forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull (forall p. APatternLike p => p -> [Name]
patternVars Pattern' Void
p forall a. Eq a => [a] -> [a] -> [a]
List.\\ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg Name]
as) forall a b. (a -> b) -> a -> b
$ \ [Name]
xs -> do
           forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
             TCMT IO Doc
"Unbound variables in pattern synonym: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
               forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [Name]
xs)
         forall (m :: * -> *) a. Monad m => a -> m a
return ([Arg Name]
as, Pattern' Void
p)
      QName
y <- Name -> TCMT IO QName
freshAbstractQName' Name
n
      Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
a KindOfName
PatternSynName Name
n QName
y
      -- Expanding pattern synonyms already at definition makes it easier to
      -- fold them back when printing (issue #2762).
      Pattern' Void
ep <- forall a. ExpandPatternSynonyms a => a -> TCM a
expandPatternSynonyms Pattern' Void
p
      (PatternSynDefns -> PatternSynDefns) -> TCMT IO ()
modifyPatternSyns (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QName
y ([Arg Name]
as, Pattern' Void
ep))
      forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> [Arg BindName] -> Pattern' Void -> Declaration
A.PatternSynDef QName
y (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> BindName
BindName) [Arg Name]
as) Pattern' Void
p]   -- only for highlighting, so use unexpanded version
      where unVarName :: ResolvedName -> m Name
unVarName (VarName Name
a BindingSource
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
a
            unVarName ResolvedName
_ = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ TypeError
UnusedVariableInPatternSynonym

    d :: NiceDeclaration
d@NiceLoneConstructor{} -> forall b. HasCallStack => (CallStack -> b) -> b
withCurrentCallStack forall a b. (a -> b) -> a -> b
$ \ CallStack
stk -> do
      forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue (CallStack -> DeclarationWarning' -> DeclarationWarning
DeclarationWarning CallStack
stk (Range -> DeclarationWarning'
InvalidConstructorBlock (forall a. HasRange a => a -> Range
getRange NiceDeclaration
d)))
      forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    where
      -- checking postulate or type sig. without checking safe flag
      toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM A.Declaration
      toAbstractNiceAxiom :: KindOfName -> NiceDeclaration -> ScopeM Declaration
toAbstractNiceAxiom KindOfName
kind (C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
info Name
x Expr
t) = do
        Expr
t' <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
        Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        Maybe [Occurrence]
mp <- Name -> ScopeM (Maybe [Occurrence])
getConcretePolarity Name
x
        QName
y  <- Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
        let isMacro :: IsMacro
isMacro | KindOfName
kind forall a. Eq a => a -> a -> Bool
== KindOfName
MacroName = IsMacro
MacroDef
                    | Bool
otherwise         = IsMacro
NotMacroDef
        Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
kind Name
x QName
y
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KindOfName
-> DefInfo
-> ArgInfo
-> Maybe [Occurrence]
-> QName
-> Expr
-> Declaration
A.Axiom KindOfName
kind (forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
f Access
p IsAbstract
a IsInstance
i IsMacro
isMacro Range
r) ArgInfo
info Maybe [Occurrence]
mp QName
y Expr
t'
      toAbstractNiceAxiom KindOfName
_ NiceDeclaration
_ = forall a. HasCallStack => a
__IMPOSSIBLE__

unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr)
unGeneralized :: Expr -> (Set QName, Expr)
unGeneralized (A.Generalized Set QName
s Expr
t) = (Set QName
s, Expr
t)
unGeneralized (A.ScopedExpr ScopeInfo
si Expr
e) = ScopeInfo -> Expr -> Expr
A.ScopedExpr ScopeInfo
si forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> (Set QName, Expr)
unGeneralized Expr
e
unGeneralized Expr
t = (forall a. Monoid a => a
mempty, Expr
t)

alreadyGeneralizing :: ScopeM Bool
alreadyGeneralizing :: TCMT IO Bool
alreadyGeneralizing = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars

collectGeneralizables :: ScopeM a -> ScopeM (Set I.QName, a)
collectGeneralizables :: forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables ScopeM a
m =
  -- #5683: No nested generalization
  forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM TCMT IO Bool
alreadyGeneralizing ((forall a. Set a
Set.empty,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM a
m) forall a b. (a -> b) -> a -> b
$
  {-else-} forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ TCMT IO (Maybe (Set QName))
open Maybe (Set QName) -> TCMT IO ()
close forall a b. (a -> b) -> a -> b
$ do
      a
a <- ScopeM a
m
      Maybe (Set QName)
s <- forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars
      case Maybe (Set QName)
s of
          Maybe (Set QName)
Nothing -> forall a. HasCallStack => a
__IMPOSSIBLE__
          Just Set QName
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Set QName
s, a
a)
  where
    open :: TCMT IO (Maybe (Set QName))
open = do
        Maybe (Set QName)
gvs <- forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars
        Lens' (Maybe (Set QName)) TCState
stGeneralizedVars forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> a -> m ()
`setTCLens` forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set QName)
gvs
    close :: Maybe (Set QName) -> TCMT IO ()
close = (Lens' (Maybe (Set QName)) TCState
stGeneralizedVars forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> a -> m ()
`setTCLens`)

createBoundNamesForGeneralizables :: Set I.QName -> ScopeM (Map I.QName I.Name)
createBoundNamesForGeneralizables :: Set QName -> ScopeM (Map QName Name)
createBoundNamesForGeneralizables Set QName
vs =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set QName
vs) forall a b. (a -> b) -> a -> b
$ \ QName
q ()
_ -> do
    let x :: Name
x  = Name -> Name
nameConcrete forall a b. (a -> b) -> a -> b
$ QName -> Name
qnameName QName
q
        fx :: Fixity'
fx = Name -> Fixity'
nameFixity   forall a b. (a -> b) -> a -> b
$ QName -> Name
qnameName QName
q
    Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
fx Name
x

collectAndBindGeneralizables :: ScopeM a -> ScopeM (Map I.QName I.Name, a)
collectAndBindGeneralizables :: forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables ScopeM a
m = do
  Int
fvBefore <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
  (Set QName
s, a
res) <- forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables ScopeM a
m
  Int
fvAfter  <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
  -- We should bind the named generalizable variables as fresh variables
  Map QName Name
binds <- Set QName -> ScopeM (Map QName Name)
createBoundNamesForGeneralizables Set QName
s
  -- Issue #3735: We need to bind the generalizable variables outside any variables bound by `m`.
  forall a. Int -> ScopeM a -> ScopeM a
outsideLocalVars (Int
fvAfter forall a. Num a => a -> a -> a
- Int
fvBefore) forall a b. (a -> b) -> a -> b
$ Map QName Name -> TCMT IO ()
bindGeneralizables Map QName Name
binds
  forall (m :: * -> *) a. Monad m => a -> m a
return (Map QName Name
binds, a
res)

bindGeneralizables :: Map A.QName A.Name -> ScopeM ()
bindGeneralizables :: Map QName Name -> TCMT IO ()
bindGeneralizables Map QName Name
vars =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map QName Name
vars) forall a b. (a -> b) -> a -> b
$ \ (QName
q, Name
y) ->
    BindingSource -> Name -> Name -> TCMT IO ()
bindVariable BindingSource
LambdaBound (Name -> Name
nameConcrete forall a b. (a -> b) -> a -> b
$ QName -> Name
qnameName QName
q) Name
y

-- | Bind generalizable variables if data or record decl was split by the system
--   (origin == Inserted)
bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set A.Name)
bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set Name)
bindGeneralizablesIfInserted Origin
Inserted AbstractName
y = Set Name
bound forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map QName Name -> TCMT IO ()
bindGeneralizables Map QName Name
gvars
  where gvars :: Map QName Name
gvars = case AbstractName -> NameMetadata
anameMetadata AbstractName
y of
          GeneralizedVarsMetadata Map QName Name
gvars -> Map QName Name
gvars
          NameMetadata
NoMetadata                    -> forall k a. Map k a
Map.empty
        bound :: Set Name
bound = forall a. Ord a => [a] -> Set a
Set.fromList (forall k a. Map k a -> [a]
Map.elems Map QName Name
gvars)
bindGeneralizablesIfInserted Origin
UserWritten AbstractName
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty
bindGeneralizablesIfInserted Origin
_ AbstractName
_           = forall a. HasCallStack => a
__IMPOSSIBLE__

newtype GenTel = GenTel C.Telescope
data GenTelAndType = GenTelAndType C.Telescope C.Expr

instance ToAbstract GenTel where
  type AbsOfCon GenTel = A.GeneralizeTelescope
  toAbstract :: GenTel -> ScopeM (AbsOfCon GenTel)
toAbstract (GenTel Telescope
tel) =
    forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map QName Name -> [TypedBinding] -> GeneralizeTelescope
A.GeneralizeTel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables (forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel)

instance ToAbstract GenTelAndType where
  type AbsOfCon GenTelAndType = (A.GeneralizeTelescope, A.Expr)

  toAbstract :: GenTelAndType -> ScopeM (AbsOfCon GenTelAndType)
toAbstract (GenTelAndType Telescope
tel Expr
t) = do
    (Map QName Name
binds, ([Maybe TypedBinding]
tel, Expr
t)) <- forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables forall a b. (a -> b) -> a -> b
$
                          (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
t
    forall (m :: * -> *) a. Monad m => a -> m a
return (Map QName Name -> [TypedBinding] -> GeneralizeTelescope
A.GeneralizeTel Map QName Name
binds (forall a. [Maybe a] -> [a]
catMaybes [Maybe TypedBinding]
tel), Expr
t)

-- | Make sure definition is in same module as signature.
class LivesInCurrentModule a where
  livesInCurrentModule :: a -> ScopeM ()

instance LivesInCurrentModule AbstractName where
  livesInCurrentModule :: AbstractName -> TCMT IO ()
livesInCurrentModule = forall a. LivesInCurrentModule a => a -> TCMT IO ()
livesInCurrentModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName

instance LivesInCurrentModule A.QName where
  livesInCurrentModule :: QName -> TCMT IO ()
livesInCurrentModule QName
x = do
    ModuleName
m <- forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
[Char] -> Int -> a -> m ()
reportS [Char]
"scope.data.def" Int
30
      [ [Char]
"  A.QName of data type: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
      , [Char]
"  current module: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow ModuleName
m
      ]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QName -> ModuleName
A.qnameModule QName
x forall a. Eq a => a -> a -> Bool
== ModuleName
m) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Definition in different module than its type signature"

-- | Unless the resolved 'AbstractName' has the given 'KindOfName',
--   report a 'ClashingDefinition' for the 'C.Name'.
clashUnless :: C.Name -> KindOfName -> AbstractName -> ScopeM ()
clashUnless :: Name -> KindOfName -> AbstractName -> TCMT IO ()
clashUnless Name
x KindOfName
k AbstractName
ax = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AbstractName -> KindOfName
anameKind AbstractName
ax forall a. Eq a => a -> a -> Bool
== KindOfName
k) forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax) forall a. Maybe a
Nothing

-- | If a (data/record) module with the given name is already present in the current module,
--   we take this as evidence that a data/record with that name is already defined.
clashIfModuleAlreadyDefinedInCurrentModule :: C.Name -> AbstractName -> ScopeM ()
clashIfModuleAlreadyDefinedInCurrentModule :: Name -> AbstractName -> TCMT IO ()
clashIfModuleAlreadyDefinedInCurrentModule Name
x AbstractName
ax = do
  [DataOrRecordModule]
datRecMods <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
ReadTCState m =>
ModuleName -> m (Maybe DataOrRecordModule)
isDatatypeModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x
  forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull [DataOrRecordModule]
datRecMods forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax) forall a. Maybe a
Nothing

lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]
lookupModuleInCurrentModule :: Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x =
  forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> Map Name [AbstractModule]
nsModules forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSpaceId] -> Scope -> NameSpace
thingsInScope [NameSpaceId
PublicNS, NameSpaceId
PrivateNS] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM Scope
getCurrentScope

data DataConstrDecl = DataConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration

-- | Bind a @data@ constructor.
bindConstructorName
  :: ModuleName      -- ^ Name of @data@/@record@ module.
  -> C.Name          -- ^ Constructor name.
  -> IsAbstract
  -> Access
  -> ScopeM A.QName
bindConstructorName :: ModuleName -> Name -> IsAbstract -> Access -> TCMT IO QName
bindConstructorName ModuleName
m Name
x IsAbstract
a Access
p = do
  Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
  -- The abstract name is the qualified one
  QName
y <- forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
f Name
x
  -- Bind it twice, once unqualified and once qualified
  Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p' KindOfName
ConName Name
x QName
y
  forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p'' KindOfName
ConName Name
x QName
y
  forall (m :: * -> *) a. Monad m => a -> m a
return QName
y
  where
    -- An abstract constructor is private (abstract constructor means
    -- abstract datatype, so the constructor should not be exported).
    p' :: Access
p' = case IsAbstract
a of
           IsAbstract
AbstractDef -> Origin -> Access
PrivateAccess Origin
Inserted
           IsAbstract
_           -> Access
p
    p'' :: Access
p'' = case IsAbstract
a of
            IsAbstract
AbstractDef -> Origin -> Access
PrivateAccess Origin
Inserted
            IsAbstract
_           -> Access
PublicAccess

-- | Record constructors do not live in the record module (as it is parameterized).
--   Abstract constructors are bound privately, so that they are not exported.
bindRecordConstructorName :: C.Name -> KindOfName -> IsAbstract -> Access -> ScopeM A.QName
bindRecordConstructorName :: Name -> KindOfName -> IsAbstract -> Access -> TCMT IO QName
bindRecordConstructorName Name
x KindOfName
kind IsAbstract
a Access
p = do
  QName
y <- Name -> TCMT IO QName
freshAbstractQName' Name
x
  Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p' KindOfName
kind Name
x QName
y
  forall (m :: * -> *) a. Monad m => a -> m a
return QName
y
  where
    -- An abstract constructor is private (abstract constructor means
    -- abstract datatype, so the constructor should not be exported).
    p' :: Access
p' = case IsAbstract
a of
           IsAbstract
AbstractDef -> Origin -> Access
PrivateAccess Origin
Inserted
           IsAbstract
_           -> Access
p

bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> TCM A.QName
bindUnquoteConstructorName :: ModuleName -> Access -> Name -> TCMT IO QName
bindUnquoteConstructorName ModuleName
m Access
p Name
c = do

  ResolvedName
r <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
c)
  Fixity'
fc <- Name -> ScopeM Fixity'
getConcreteFixity Name
c
  QName
c' <- forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
fc Name
c
  let aname :: QName -> AbstractName
aname QName
qn = QName -> KindOfName -> WhyInScope -> NameMetadata -> AbstractName
AbsName QName
qn KindOfName
QuotableName WhyInScope
Defined NameMetadata
NoMetadata
      addName :: TCMT IO ()
addName = (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope forall a b. (a -> b) -> a -> b
$ NameSpaceId -> Name -> AbstractName -> Scope -> Scope
addNameToScope (Access -> NameSpaceId
localNameSpace Access
p) Name
c forall a b. (a -> b) -> a -> b
$ QName -> AbstractName
aname QName
c'
      success :: TCMT IO ()
success = TCMT IO ()
addName forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m forall a b. (a -> b) -> a -> b
$ TCMT IO ()
addName)
  case ResolvedName
r of
    ResolvedName
_ | forall a. IsNoName a => a -> Bool
isNoName Name
c       -> TCMT IO ()
success
    ResolvedName
UnknownName          -> TCMT IO ()
success
    ConstructorName Set Induction
i List1 AbstractName
ds -> if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindOfName -> Maybe Induction
isConName forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind) List1 AbstractName
ds
      then TCMT IO ()
success
      else forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
c) (AbstractName -> QName
anameName forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds) forall a. Maybe a
Nothing
    ResolvedName
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$
       [Char]
"The name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
c forall a. [a] -> [a] -> [a]
++ [Char]
" already has non-constructor definitions"
  forall (m :: * -> *) a. Monad m => a -> m a
return QName
c'

instance ToAbstract DataConstrDecl where
  type AbsOfCon DataConstrDecl = A.Declaration

  toAbstract :: DataConstrDecl -> ScopeM (AbsOfCon DataConstrDecl)
toAbstract (DataConstrDecl ModuleName
m IsAbstract
a Access
p NiceDeclaration
d) = do
    case NiceDeclaration
d of
      C.Axiom Range
r Access
p1 IsAbstract
a1 IsInstance
i ArgInfo
info Name
x Expr
t -> do -- rel==Relevant
        -- unless (p1 == p) __IMPOSSIBLE__  -- This invariant is currently violated by test/Succeed/Issue282.agda
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IsAbstract
a1 forall a. Eq a => a -> a -> Bool
== IsAbstract
a) forall a. HasCallStack => a
__IMPOSSIBLE__
        Expr
t' <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
        -- The abstract name is the qualified one
        -- Bind it twice, once unqualified and once qualified
        Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        QName
y <- ModuleName -> Name -> IsAbstract -> Access -> TCMT IO QName
bindConstructorName ModuleName
m Name
x IsAbstract
a Access
p
        [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"con" Int
15 [Char]
"bound constructor"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KindOfName
-> DefInfo
-> ArgInfo
-> Maybe [Occurrence]
-> QName
-> Expr
-> Declaration
A.Axiom KindOfName
ConName (forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
f Access
p IsAbstract
a IsInstance
i IsMacro
NotMacroDef Range
r)
                         ArgInfo
info forall a. Maybe a
Nothing QName
y Expr
t'
      NiceDeclaration
_ -> forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d

errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a
errorNotConstrDecl :: forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall a b. (a -> b) -> a -> b
$
        Doc
"Illegal declaration in data type definition " Doc -> Doc -> Doc
P.$$
        Int -> Doc -> Doc
P.nest Int
2 (forall (t :: * -> *). Foldable t => t Doc -> Doc
P.vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty (NiceDeclaration -> [Declaration]
notSoNiceDeclarations NiceDeclaration
d))

instance ToAbstract C.Pragma where
  type AbsOfCon C.Pragma = [A.Pragma]

  toAbstract :: Pragma -> ScopeM (AbsOfCon Pragma)
toAbstract (C.ImpossiblePragma Range
_ [[Char]]
strs) =
    case [[Char]]
strs of
      [Char]
"ReduceM" : [[Char]]
_ -> forall a. HasCallStack => [[Char]] -> TCM a
impossibleTestReduceM [[Char]]
strs
      [[Char]]
_ -> forall (m :: * -> *) a.
(MonadDebug m, HasCallStack) =>
[[Char]] -> m a
impossibleTest [[Char]]
strs
  toAbstract (C.OptionsPragma Range
_ [[Char]]
opts) = forall (m :: * -> *) a. Monad m => a -> m a
return [ [[Char]] -> Pragma
A.OptionsPragma [[Char]]
opts ]
  toAbstract (C.RewritePragma Range
_ Range
_ []) = [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
EmptyRewritePragma
  toAbstract (C.RewritePragma Range
_ Range
r [QName]
xs) = forall el coll. Singleton el coll => el -> coll
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [QName] -> Pragma
A.RewritePragma Range
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
   forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QName]
xs forall a b. (a -> b) -> a -> b
$ \ QName
x -> do
    Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
    case Expr
e of
      A.Def QName
x          -> forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Proj ProjOrigin
_ AmbiguousQName
x       -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on ambiguous name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
      A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Con AmbiguousQName
x          -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on ambiguous name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
      A.Var Name
x          -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on parameter " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x forall a. [a] -> [a] -> [a]
++ [Char]
" instead of on a defined symbol"
      Expr
_       -> forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (C.ForeignPragma Range
_ RString
rb [Char]
s) = [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> [Char] -> TCMT IO ()
addForeignCode (forall a. Ranged a -> a
rangedThing RString
rb) [Char]
s
  toAbstract (C.CompilePragma Range
_ RString
rb QName
x [Char]
s) = do
    Maybe Expr
me <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ OldQName -> MaybeOldQName
MaybeOldQName forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
    case Maybe Expr
me of
      Maybe Expr
Nothing -> [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ QName -> TCMT IO ()
notInScopeWarning QName
x
      Just Expr
e  -> do
        let err :: [Char] -> TCMT IO QName
err [Char]
what = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot COMPILE " forall a. [a] -> [a] -> [a]
++ [Char]
what forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x
        QName
y <- case Expr
e of
          A.Def QName
x             -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x          -> [Char] -> TCMT IO QName
err [Char]
"ambiguous projection"
          A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Con AmbiguousQName
x             -> [Char] -> TCMT IO QName
err [Char]
"ambiguous constructor"
          A.PatternSyn{}      -> [Char] -> TCMT IO QName
err [Char]
"pattern synonym"
          A.Var{}             -> [Char] -> TCMT IO QName
err [Char]
"local variable"
          Expr
_                   -> forall a. HasCallStack => a
__IMPOSSIBLE__
        forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> QName -> [Char] -> Pragma
A.CompilePragma RString
rb QName
y [Char]
s ]

  toAbstract (C.StaticPragma Range
_ QName
x) = do
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
      QName
y <- case Expr
e of
          A.Def  QName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
            [Char]
"STATIC used on ambiguous name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of STATIC pragma should be a function"
      forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.StaticPragma QName
y ]
  toAbstract (C.InjectivePragma Range
_ QName
x) = do
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
      QName
y <- case Expr
e of
          A.Def  QName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
            [Char]
"INJECTIVE used on ambiguous name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of INJECTIVE pragma should be a defined symbol"
      forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.InjectivePragma QName
y ]
  toAbstract (C.InlinePragma Range
_ Bool
b QName
x) = do
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
      let sINLINE :: [Char]
sINLINE = if Bool
b then [Char]
"INLINE" else [Char]
"NOINLINE"
      QName
y <- case Expr
e of
          A.Def  QName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
            [Char]
sINLINE forall a. [a] -> [a] -> [a]
++ [Char]
" used on ambiguous name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Target of " forall a. [a] -> [a] -> [a]
++ [Char]
sINLINE forall a. [a] -> [a] -> [a]
++ [Char]
" pragma should be a function"
      forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> QName -> Pragma
A.InlinePragma Bool
b QName
y ]
  toAbstract (C.NotProjectionLikePragma Range
_ QName
x) = do
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
      QName
y <- case Expr
e of
          A.Def  QName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
            [Char]
"NOT_PROJECTION_LIKE used on ambiguous name " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Target of NOT_PROJECTION_LIKE pragma should be a function"
      forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.NotProjectionLikePragma QName
y ]
  toAbstract (C.BuiltinPragma Range
_ RString
rb QName
qx)
    | [Char] -> Bool
isUntypedBuiltin [Char]
b = do
        ResolvedName
q <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> ResolveQName
ResolveQName QName
qx
        [Char] -> ResolvedName -> TCMT IO ()
bindUntypedBuiltin [Char]
b ResolvedName
q
        forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> ResolvedName -> Pragma
A.BuiltinPragma RString
rb ResolvedName
q ]
        -- Andreas, 2015-02-14
        -- Some builtins cannot be given a valid Agda type,
        -- thus, they do not come with accompanying postulate or definition.
    | [Char] -> Bool
isBuiltinNoDef [Char]
b = do
          case QName
qx of
            C.QName Name
x -> do
              -- The name shouldn't exist yet. If it does, we raise a warning
              -- and drop the existing definition.
              forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((ResolvedName
UnknownName forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ScopeM ResolvedName
resolveName QName
qx) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *). MonadWarning m => Doc -> m ()
genericWarning forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
P.text forall a b. (a -> b) -> a -> b
$
                   [Char]
"BUILTIN " forall a. [a] -> [a] -> [a]
++ [Char]
b forall a. [a] -> [a] -> [a]
++ [Char]
" declares an identifier " forall a. [a] -> [a] -> [a]
++
                   [Char]
"(no longer expects an already defined identifier)"
                (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope forall a b. (a -> b) -> a -> b
$ NameSpaceId -> Name -> Scope -> Scope
removeNameFromScope NameSpaceId
PublicNS Name
x
              -- We then happily bind the name
              QName
y <- Name -> TCMT IO QName
freshAbstractQName' Name
x
              let kind :: KindOfName
kind = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe KindOfName
builtinKindOfName [Char]
b
              Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
PublicAccess KindOfName
kind Name
x QName
y
              forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> KindOfName -> QName -> Pragma
A.BuiltinNoDefPragma RString
rb KindOfName
kind QName
y ]
            QName
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
              [Char]
"Pragma BUILTIN " forall a. [a] -> [a] -> [a]
++ [Char]
b forall a. [a] -> [a] -> [a]
++ [Char]
": expected unqualified identifier, " forall a. [a] -> [a] -> [a]
++
              [Char]
"but found " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
qx
    | Bool
otherwise = do
          ResolvedName
q0 <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> ResolveQName
ResolveQName QName
qx

          -- Andreas, 2020-04-12, pr #4574.  For highlighting purposes:
          -- Rebind 'BuiltinPrim' as 'PrimName' and similar.
          ResolvedName
q <- case (ResolvedName
q0, [Char] -> Maybe KindOfName
builtinKindOfName [Char]
b, QName
qx) of
            (DefinedName Access
acc AbstractName
y Suffix
suffix, Just KindOfName
kind, C.QName Name
x)
              | AbstractName -> KindOfName
anameKind AbstractName
y forall a. Eq a => a -> a -> Bool
/= KindOfName
kind
              , KindOfName
kind forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ KindOfName
PrimName, KindOfName
AxiomName ] -> do
                  Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
acc KindOfName
kind Name
x forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
y
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Access -> AbstractName -> Suffix -> ResolvedName
DefinedName Access
acc AbstractName
y{ anameKind :: KindOfName
anameKind = KindOfName
kind } Suffix
suffix
            (ResolvedName, Maybe KindOfName, QName)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
q0

          forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> ResolvedName -> Pragma
A.BuiltinPragma RString
rb ResolvedName
q ]
    where b :: [Char]
b = forall a. Ranged a -> a
rangedThing RString
rb

  toAbstract (C.EtaPragma Range
_ QName
x) = do
    Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing
    case Expr
e of
      A.Def QName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.EtaPragma QName
x ]
      Expr
_       -> do
       [Char]
e <- forall a (m :: * -> *).
(ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) =>
a -> m [Char]
showA Expr
e
       forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Pragma ETA: expected identifier, " forall a. [a] -> [a] -> [a]
++
         [Char]
"but found expression " forall a. [a] -> [a] -> [a]
++ [Char]
e

  toAbstract (C.DisplayPragma Range
_ Pattern
lhs Expr
rhs) = forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
    let err :: TCMT IO a
err = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"DISPLAY pragma left-hand side must have form 'f e1 .. en'"
        getHead :: Pattern -> TCMT IO QName
getHead (C.IdentP QName
x)          = forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
        getHead (C.RawAppP Range
_ (List2 Pattern
p Pattern
_ [Pattern]
_)) = Pattern -> TCMT IO QName
getHead Pattern
p
        getHead Pattern
_                     = forall {a}. TCMT IO a
err

    QName
top <- Pattern -> TCMT IO QName
getHead Pattern
lhs

    (Bool
isPatSyn, QName
hd) <- do
      ResolvedName
qx <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' KindsOfNames
allKindsOfNames forall a. Maybe a
Nothing QName
top
      case ResolvedName
qx of
        VarName Name
x' BindingSource
_                -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) forall a b. (a -> b) -> a -> b
$ List1 Name -> QName
A.qnameFromList forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton Name
x'
        DefinedName Access
_ AbstractName
d Suffix
NoSuffix    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        DefinedName Access
_ AbstractName
d Suffix{}    -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid pattern " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
top
        FieldName     (AbstractName
d :| [])     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        FieldName List1 AbstractName
ds                -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous projection " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
top forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        ConstructorName Set Induction
_ (AbstractName
d :| []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        ConstructorName Set Induction
_ List1 AbstractName
ds        -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous constructor " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
top forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        ResolvedName
UnknownName                 -> forall a. QName -> TCM a
notInScopeError QName
top
        PatternSynResName (AbstractName
d :| []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
True,) forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        PatternSynResName List1 AbstractName
ds        -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous pattern synonym" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
top forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)

    LHS
lhs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Pattern -> LeftHandSide
LeftHandSide QName
top Pattern
lhs
    [NamedArg Pattern]
ps  <- case LHS
lhs of
             A.LHS LHSInfo
_ (A.LHSHead QName
_ [NamedArg Pattern]
ps) -> forall (m :: * -> *) a. Monad m => a -> m a
return [NamedArg Pattern]
ps
             LHS
_ -> forall {a}. TCMT IO a
err

    -- Andreas, 2016-08-08, issue #2132
    -- Remove pattern synonyms on lhs
    (QName
hd, [NamedArg Pattern]
ps) <- do
      let mkP :: [NamedArg Pattern] -> Pattern
mkP | Bool
isPatSyn  = forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP (Range -> PatInfo
PatRange forall a b. (a -> b) -> a -> b
$ forall a. HasRange a => a -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
              | Bool
otherwise = forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP (Range -> PatInfo
PatRange forall a b. (a -> b) -> a -> b
$ forall a. HasRange a => a -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
      Pattern
p <- forall a. ExpandPatternSynonyms a => a -> TCM a
expandPatternSynonyms forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Pattern
mkP [NamedArg Pattern]
ps
      case Pattern
p of
        A.DefP PatInfo
_ AmbiguousQName
f [NamedArg Pattern]
ps | Just QName
hd <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
f -> forall (m :: * -> *) a. Monad m => a -> m a
return (QName
hd, [NamedArg Pattern]
ps)
        A.ConP ConPatInfo
_ AmbiguousQName
c [NamedArg Pattern]
ps | Just QName
hd <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> forall (m :: * -> *) a. Monad m => a -> m a
return (QName
hd, [NamedArg Pattern]
ps)
        A.PatternSynP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
        Pattern
_ -> forall {a}. TCMT IO a
err

    Expr
rhs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
    forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> [NamedArg Pattern] -> Expr -> Pragma
A.DisplayPragma QName
hd [NamedArg Pattern]
ps Expr
rhs]

  -- A warning attached to an ambiguous name shall apply to all disambiguations.
  toAbstract (C.WarningOnUsage Range
_ QName
x Text
str) = do
    NonEmpty QName
ys <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName QName
x
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty QName
ys forall a b. (a -> b) -> a -> b
$ \ QName
qn -> Lens' (Map QName Text) TCState
stLocalUserWarnings forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> (a -> a) -> m ()
`modifyTCLens` forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QName
qn Text
str
    forall (m :: * -> *) a. Monad m => a -> m a
return []

  toAbstract (C.WarningOnImport Range
_ Text
str) = do
    Lens' (Maybe Text) TCState
stWarningOnImport forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> a -> m ()
`setTCLens` forall a. a -> Maybe a
Just Text
str
    forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  -- Termination, Coverage, Positivity, Universe, and Catchall
  -- pragmes are handled by the nicifier
  toAbstract C.TerminationCheckPragma{}  = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.NoCoverageCheckPragma{}   = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.NoPositivityCheckPragma{} = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.NoUniverseCheckPragma{}   = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.CatchallPragma{}          = forall a. HasCallStack => a
__IMPOSSIBLE__

  -- Polarity pragmas are handled by the niceifier.
  toAbstract C.PolarityPragma{} = forall a. HasCallStack => a
__IMPOSSIBLE__

instance ToAbstract C.Clause where
  type AbsOfCon C.Clause = A.Clause

  toAbstract :: Clause -> ScopeM (AbsOfCon Clause)
toAbstract (C.Clause Name
top Bool
catchall lhs :: LHS
lhs@(C.LHS Pattern
p [RewriteEqn]
eqs [WithExpr]
with) RHS' Expr
rhs WhereClause' [Declaration]
wh [Clause]
wcs) = forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
    -- Jesper, 2018-12-10, #3095: pattern variables bound outside the
    -- module are locally treated as module parameters
    forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope_ forall a b. (a -> b) -> a -> b
$ (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
updateScopeLocals forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second LocalVar -> LocalVar
patternToModuleBound
    -- Andreas, 2012-02-14: need to reset local vars before checking subclauses
    LocalVars
vars0 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
    LHS
lhs' <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ QName -> Pattern -> LeftHandSide
LeftHandSide (Name -> QName
C.QName Name
top) Pattern
p
    Int -> [Char] -> TCMT IO ()
printLocals Int
10 [Char]
"after lhs:"
    LocalVars
vars1 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
    [RewriteEqn' () BindName Pattern Expr]
eqs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) [RewriteEqn]
eqs
    LocalVars
vars2 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
    let vars :: LocalVars
vars = forall a. Int -> [a] -> [a]
dropEnd (forall (t :: * -> *) a. Foldable t => t a -> Int
length LocalVars
vars1) LocalVars
vars2 forall a. [a] -> [a] -> [a]
++ LocalVars
vars0
    let wcs' :: (LocalVars, [Clause])
wcs' = (LocalVars
vars, [Clause]
wcs)

    -- Handle rewrite equations first.
    if Bool -> Bool
not (forall a. Null a => a -> Bool
null [RewriteEqn' () BindName Pattern Expr]
eqs)
      then do
        AbstractRHS
rhs <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx forall a b. (a -> b) -> a -> b
$ [RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> (LocalVars, [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [RewriteEqn' () BindName Pattern Expr]
eqs [WithExpr]
with (LocalVars, [Clause])
wcs' RHS' Expr
rhs WhereClause' [Declaration]
wh
        RHS
rhs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract AbstractRHS
rhs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall lhs.
lhs
-> [ProblemEq] -> RHS -> WhereDeclarations -> Bool -> Clause' lhs
A.Clause LHS
lhs' [] RHS
rhs WhereDeclarations
A.noWhereDecls Bool
catchall
      else do
        -- the right hand side is checked with the module of the local definitions opened
        (AbstractRHS
rhs, WhereDeclarations
ds) <- forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract (forall a. HasRange a => a -> Range
getRange WhereClause' [Declaration]
wh) WhereClause' [Declaration]
wh forall a b. (a -> b) -> a -> b
$
                       forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx forall a b. (a -> b) -> a -> b
$ [RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> (LocalVars, [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [] [WithExpr]
with (LocalVars, [Clause])
wcs' RHS' Expr
rhs forall decls. WhereClause' decls
NoWhere
        RHS
rhs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract AbstractRHS
rhs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall lhs.
lhs
-> [ProblemEq] -> RHS -> WhereDeclarations -> Bool -> Clause' lhs
A.Clause LHS
lhs' [] RHS
rhs WhereDeclarations
ds Bool
catchall


whereToAbstract
  :: Range                            -- ^ The range of the @where@ block.
  -> C.WhereClause                    -- ^ The @where@ block.
  -> ScopeM a                         -- ^ The scope-checking task to be run in the context of the @where@ module.
  -> ScopeM (a, A.WhereDeclarations)  -- ^ Additionally return the scope-checked contents of the @where@ module.
whereToAbstract :: forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract Range
r WhereClause' [Declaration]
wh ScopeM a
inner = do
  case WhereClause' [Declaration]
wh of
    WhereClause' [Declaration]
NoWhere       -> ScopeM (a, WhereDeclarations)
ret
    AnyWhere Range
_ [] -> ScopeM (a, WhereDeclarations)
warnEmptyWhere
    AnyWhere Range
_ [Declaration]
ds -> do
      -- Andreas, 2016-07-17 issues #2081 and #2101
      -- where-declarations are automatically private.
      -- This allows their type signature to be checked InAbstractMode.
      forall a.
Range
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r forall a. Maybe a
Nothing (forall el coll. Singleton el coll => el -> coll
singleton forall a b. (a -> b) -> a -> b
$ Range -> Origin -> [Declaration] -> Declaration
C.Private forall a. Range' a
noRange Origin
Inserted [Declaration]
ds) ScopeM a
inner
    SomeWhere Range
_ Name
m Access
a [Declaration]
ds0 -> forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [Declaration]
ds0 ScopeM (a, WhereDeclarations)
warnEmptyWhere {-else-} forall a b. (a -> b) -> a -> b
$ \ List1 Declaration
ds -> do
      -- Named where-modules do not default to private.
      forall a.
Range
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r (forall a. a -> Maybe a
Just (Name
m, Access
a)) List1 Declaration
ds ScopeM a
inner
  where
  ret :: ScopeM (a, WhereDeclarations)
ret = (,WhereDeclarations
A.noWhereDecls) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM a
inner
  warnEmptyWhere :: ScopeM (a, WhereDeclarations)
warnEmptyWhere = do
    forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
EmptyWhere
    ScopeM (a, WhereDeclarations)
ret

whereToAbstract1
  :: Range                            -- ^ The range of the @where@-block.
  -> Maybe (C.Name, Access)           -- ^ The name of the @where@ module (if any).
  -> List1 C.Declaration              -- ^ The contents of the @where@ module.
  -> ScopeM a                         -- ^ The scope-checking task to be run in the context of the @where@ module.
  -> ScopeM (a, A.WhereDeclarations)  -- ^ Additionally return the scope-checked contents of the @where@ module.
whereToAbstract1 :: forall a.
Range
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Maybe (Name, Access)
whname List1 Declaration
whds ScopeM a
inner = do
  -- ASR (16 November 2015) Issue 1137: We ban termination
  -- pragmas inside `where` clause.
  forall (f :: * -> *).
Foldable f =>
WhereOrRecord -> f Declaration -> TCMT IO ()
checkNoTerminationPragma WhereOrRecord
InWhereBlock List1 Declaration
whds

  -- Create a fresh concrete name if there isn't (a proper) one.
  (Name
m, Access
acc) <- do
    case Maybe (Name, Access)
whname of
      Just (Name
m, Access
acc) | Bool -> Bool
not (forall a. IsNoName a => a -> Bool
isNoName Name
m) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
m, Access
acc)
      Maybe (Name, Access)
_ -> forall i (m :: * -> *). MonadFresh i m => m i
fresh forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ NameId
x -> (Range -> NameId -> Name
C.NoName (forall a. HasRange a => a -> Range
getRange Maybe (Name, Access)
whname) NameId
x, Origin -> Access
PrivateAccess Origin
Inserted)
           -- unnamed where's are private
  ModuleName
old <- forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
  ModuleName
am  <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> NewModuleName
NewModuleName Name
m)
  (ScopeInfo
scope, Declaration
d) <- Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r (Name -> QName
C.QName Name
m) ModuleName
am [] forall a b. (a -> b) -> a -> b
$ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ [Declaration] -> Declarations
Declarations forall a b. (a -> b) -> a -> b
$ forall l. IsList l => l -> [Item l]
List1.toList List1 Declaration
whds
  ScopeInfo -> TCMT IO ()
setScope ScopeInfo
scope
  a
x <- ScopeM a
inner
  forall (m :: * -> *). MonadTCState m => ModuleName -> m ()
setCurrentModule ModuleName
old
  Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
acc Name
m ModuleName
am
  -- Issue 848: if the module was anonymous (module _ where) open it public
  let anonymousSomeWhere :: Bool
anonymousSomeWhere = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. IsNoName a => a -> Bool
isNoName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Maybe (Name, Access)
whname
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
anonymousSomeWhere forall a b. (a -> b) -> a -> b
$
   forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ -- We can ignore the returned default A.ImportDirective.
    OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> TCMT IO ImportDirective
openModule OpenKind
TopOpenModule (forall a. a -> Maybe a
Just ModuleName
am) (Name -> QName
C.QName Name
m) forall a b. (a -> b) -> a -> b
$
      forall n m. ImportDirective' n m
defaultImportDir { publicOpen :: Maybe Range
publicOpen = forall a. a -> Maybe a
Just forall a. Range' a
noRange }
  forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Maybe ModuleName -> Bool -> Maybe Declaration -> WhereDeclarations
A.WhereDecls (forall a. a -> Maybe a
Just ModuleName
am) (forall a. Maybe a -> Bool
isNothing Maybe (Name, Access)
whname) forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton Declaration
d)

data TerminationOrPositivity = Termination | Positivity
  deriving (Int -> TerminationOrPositivity -> [Char] -> [Char]
[TerminationOrPositivity] -> [Char] -> [Char]
TerminationOrPositivity -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [TerminationOrPositivity] -> [Char] -> [Char]
$cshowList :: [TerminationOrPositivity] -> [Char] -> [Char]
show :: TerminationOrPositivity -> [Char]
$cshow :: TerminationOrPositivity -> [Char]
showsPrec :: Int -> TerminationOrPositivity -> [Char] -> [Char]
$cshowsPrec :: Int -> TerminationOrPositivity -> [Char] -> [Char]
Show)

data WhereOrRecord = InWhereBlock | InRecordDef

checkNoTerminationPragma :: Foldable f => WhereOrRecord -> f C.Declaration -> ScopeM ()
checkNoTerminationPragma :: forall (f :: * -> *).
Foldable f =>
WhereOrRecord -> f Declaration -> TCMT IO ()
checkNoTerminationPragma WhereOrRecord
b f Declaration
ds =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (TerminationOrPositivity
p, Range
r) -> forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall a b. (a -> b) -> a -> b
$ Range -> Doc -> Warning
GenericUseless Range
r forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
P.vcat [ [Char] -> Doc
P.text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show TerminationOrPositivity
p forall a. [a] -> [a] -> [a]
++ [Char]
" pragmas are ignored in " forall a. [a] -> [a] -> [a]
++ forall {a}. IsString a => WhereOrRecord -> a
what WhereOrRecord
b
                                                         , [Char] -> Doc
P.text forall a b. (a -> b) -> a -> b
$ [Char]
"(see " forall a. [a] -> [a] -> [a]
++ WhereOrRecord -> [Char]
issue WhereOrRecord
b forall a. [a] -> [a] -> [a]
++ [Char]
")" ])
        (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas f Declaration
ds)
  where
    what :: WhereOrRecord -> a
what WhereOrRecord
InWhereBlock = a
"where clauses"
    what WhereOrRecord
InRecordDef  = a
"record definitions"
    github :: a -> [Char]
github a
n = [Char]
"https://github.com/agda/agda/issues/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
n
    issue :: WhereOrRecord -> [Char]
issue WhereOrRecord
InWhereBlock = forall a. Show a => a -> [Char]
github Integer
3355
    issue WhereOrRecord
InRecordDef  = forall a. Show a => a -> [Char]
github Integer
3008

terminationPragmas :: C.Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas :: Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas (C.Private  Range
_ Origin
_      [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Abstract Range
_        [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.InstanceB Range
_       [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Mutual Range
_          [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Module Range
_ QName
_ Telescope
_      [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Macro Range
_           [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Record Range
_ Name
_ RecordDirectives
_ [LamBinding' TypedBinding]
_ Expr
_  [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.RecordDef Range
_ Name
_ RecordDirectives
_ [LamBinding' TypedBinding]
_ [Declaration]
ds) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Pragma (TerminationCheckPragma Range
r TerminationCheck
_)) = [(TerminationOrPositivity
Termination, Range
r)]
terminationPragmas (C.Pragma (NoPositivityCheckPragma Range
r))  = [(TerminationOrPositivity
Positivity, Range
r)]
terminationPragmas Declaration
_                                       = []

data RightHandSide = RightHandSide
  { RightHandSide -> [RewriteEqn' () BindName Pattern Expr]
_rhsRewriteEqn :: [RewriteEqn' () A.BindName A.Pattern A.Expr]
    -- ^ @rewrite e | with p <- e in eq@ (many)
  , RightHandSide -> [WithExpr]
_rhsWithExpr   :: [C.WithExpr]
    -- ^ @with e@ (many)
  , RightHandSide -> (LocalVars, [Clause])
_rhsSubclauses :: (LocalVars, [C.Clause])
    -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)
  , RightHandSide -> RHS' Expr
_rhs           :: C.RHS
  , RightHandSide -> WhereClause' [Declaration]
_rhsWhere      :: WhereClause
      -- ^ @where@ module.
  }

data AbstractRHS
  = AbsurdRHS'
  | WithRHS' [A.WithExpr] [ScopeM C.Clause]
    -- ^ The with clauses haven't been translated yet
  | RHS' A.Expr C.Expr
  | RewriteRHS' [RewriteEqn' () A.BindName A.Pattern A.Expr] AbstractRHS A.WhereDeclarations

qualifyName_ :: A.Name -> ScopeM A.QName
qualifyName_ :: Name -> TCMT IO QName
qualifyName_ Name
x = do
  ModuleName
m <- forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModuleName -> Name -> QName
A.qualify ModuleName
m Name
x

withFunctionName :: String -> ScopeM A.QName
withFunctionName :: [Char] -> TCMT IO QName
withFunctionName [Char]
s = do
  NameId Word64
i ModuleNameHash
_ <- forall i (m :: * -> *). MonadFresh i m => m i
fresh
  Name -> TCMT IO QName
qualifyName_ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
freshName_ ([Char]
s forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word64
i)

instance ToAbstract (RewriteEqn' () A.BindName A.Pattern A.Expr) where
  type AbsOfCon (RewriteEqn' () A.BindName A.Pattern A.Expr) = A.RewriteEqn
  toAbstract :: RewriteEqn' () BindName Pattern Expr
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
toAbstract = \case
    Rewrite List1 ((), Expr)
es -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 ((), Expr)
es forall a b. (a -> b) -> a -> b
$ \ (()
_, Expr
e) -> do
      QName
qn <- [Char] -> TCMT IO QName
withFunctionName [Char]
"-rewrite"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName
qn, Expr
e)
    Invert ()
_ List1 (Named BindName (Pattern, Expr))
pes -> do
      QName
qn <- [Char] -> TCMT IO QName
withFunctionName [Char]
"-invert"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall qn nm p e.
qn -> List1 (Named nm (p, e)) -> RewriteEqn' qn nm p e
Invert QName
qn List1 (Named BindName (Pattern, Expr))
pes

instance ToAbstract C.RewriteEqn where
  type AbsOfCon C.RewriteEqn = RewriteEqn' () A.BindName A.Pattern A.Expr
  toAbstract :: RewriteEqn -> ScopeM (AbsOfCon RewriteEqn)
toAbstract = \case
    Rewrite List1 ((), Expr)
es   -> forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract List1 ((), Expr)
es
    Invert ()
_ List1 (Named Name (Pattern, Expr))
npes -> forall qn nm p e.
qn -> List1 (Named nm (p, e)) -> RewriteEqn' qn nm p e
Invert () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      -- Given a list of irrefutable with expressions of the form @p <- e in q@
      let (NonEmpty (Maybe Name, Pattern)
nps, List1 Expr
es) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
List1.unzip
                    forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Named Maybe Name
nm (Pattern
p, Expr
e)) -> ((Maybe Name
nm, Pattern
p), Expr
e)) List1 (Named Name (Pattern, Expr))
npes
      -- we first check the expressions @e@: the patterns may shadow some of the
      -- variables mentioned in them!
      NonEmpty Expr
es <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract List1 Expr
es
      -- we then parse the pairs of patterns @p@ and names @q@ for the equality
      -- constraints of the form @p ≡ e@.
      NonEmpty (Maybe BindName, Pattern)
nps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Maybe Name, Pattern)
nps forall a b. (a -> b) -> a -> b
$ \ (Maybe Name
n, Pattern
p) -> do
        -- first the pattern
        Pattern
p <- Pattern -> ScopeM Pattern
parsePattern Pattern
p
        Pattern' Expr
p <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
        forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p (forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> TypeError
RepeatedVariablesInPattern)
        TCMT IO ()
bindVarsToBind
        Pattern
p <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern' Expr
p
        -- and then the name
        Maybe BindName
n <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. BindingSource -> a -> NewName a
NewName BindingSource
WithBound forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BoundName
C.mkBoundName_) Maybe Name
n
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe BindName
n, Pattern
p)
      -- we finally reassemble the telescope
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
List1.zipWith (\ (Maybe BindName
n,Pattern
p) Expr
e -> forall name a. Maybe name -> a -> Named name a
Named Maybe BindName
n (Pattern
p, Expr
e)) NonEmpty (Maybe BindName, Pattern)
nps NonEmpty Expr
es

instance ToAbstract AbstractRHS where
  type AbsOfCon AbstractRHS = A.RHS

  toAbstract :: AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
toAbstract AbstractRHS
AbsurdRHS'            = forall (m :: * -> *) a. Monad m => a -> m a
return RHS
A.AbsurdRHS
  toAbstract (RHS' Expr
e Expr
c)            = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> TacticAttribute -> RHS
A.RHS Expr
e forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Expr
c
  toAbstract (RewriteRHS' [RewriteEqn' () BindName Pattern Expr]
eqs AbstractRHS
rhs WhereDeclarations
wh) = do
    [RewriteEqn' QName BindName Pattern Expr]
eqs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [RewriteEqn' () BindName Pattern Expr]
eqs
    RHS
rhs <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract AbstractRHS
rhs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [RewriteEqn' QName BindName Pattern Expr]
-> [ProblemEq] -> RHS -> WhereDeclarations -> RHS
RewriteRHS [RewriteEqn' QName BindName Pattern Expr]
eqs [] RHS
rhs WhereDeclarations
wh
  toAbstract (WithRHS' [WithExpr]
es [TCMT IO Clause]
cs) = do
    QName
aux <- [Char] -> TCMT IO QName
withFunctionName [Char]
"with-"
    QName -> [WithExpr] -> [Clause] -> RHS
A.WithRHS QName
aux [WithExpr]
es forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TCMT IO Clause]
cs

instance ToAbstract RightHandSide where
  type AbsOfCon RightHandSide = AbstractRHS
  toAbstract :: RightHandSide -> ScopeM (AbsOfCon RightHandSide)
toAbstract (RightHandSide eqs :: [RewriteEqn' () BindName Pattern Expr]
eqs@(RewriteEqn' () BindName Pattern Expr
_:[RewriteEqn' () BindName Pattern Expr]
_) [WithExpr]
es (LocalVars, [Clause])
cs RHS' Expr
rhs WhereClause' [Declaration]
wh)               = do
    (AbstractRHS
rhs, WhereDeclarations
ds) <- forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract (forall a. HasRange a => a -> Range
getRange WhereClause' [Declaration]
wh) WhereClause' [Declaration]
wh forall a b. (a -> b) -> a -> b
$
                   forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> (LocalVars, [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [] [WithExpr]
es (LocalVars, [Clause])
cs RHS' Expr
rhs forall decls. WhereClause' decls
NoWhere)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [RewriteEqn' () BindName Pattern Expr]
-> AbstractRHS -> WhereDeclarations -> AbstractRHS
RewriteRHS' [RewriteEqn' () BindName Pattern Expr]
eqs AbstractRHS
rhs WhereDeclarations
ds
  toAbstract (RightHandSide [] []    (LocalVars
_  , Clause
_:[Clause]
_) RHS' Expr
_          WhereClause' [Declaration]
_)  = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] (WithExpr
_:[WithExpr]
_) (LocalVars, [Clause])
_         (C.RHS Expr
_)   WhereClause' [Declaration]
_)  = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ TypeError
BothWithAndRHS
  toAbstract (RightHandSide [] []    (LocalVars
_  , []) RHS' Expr
rhs         WhereClause' [Declaration]
NoWhere) = forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract RHS' Expr
rhs
  toAbstract (RightHandSide [] [WithExpr]
nes   (LocalVars
lv , [Clause]
cs) RHS' Expr
C.AbsurdRHS WhereClause' [Declaration]
NoWhere) = do
    let ([Maybe (NewName BoundName)]
ns , [Arg Expr]
es) = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
unzipWith (\ (Named Maybe Name
nm Arg Expr
e) -> (forall a. BindingSource -> a -> NewName a
NewName BindingSource
WithBound forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BoundName
C.mkBoundName_ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
nm, Arg Expr
e)) [WithExpr]
nes
    [Arg Expr]
es <- forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx [Arg Expr]
es
    LocalVars
lvars0 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
    [Maybe BindName]
ns <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Maybe (NewName BoundName)]
ns
    LocalVars
lvars1 <- forall (m :: * -> *). ReadTCState m => m LocalVars
getLocalVars
    let lv' :: LocalVars
lv' = forall a. Int -> [a] -> [a]
dropEnd (forall (t :: * -> *) a. Foldable t => t a -> Int
length LocalVars
lvars0) LocalVars
lvars1 forall a. [a] -> [a] -> [a]
++ LocalVars
lv
    let cs' :: [TCMT IO Clause]
cs' = forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [Clause]
cs forall a b. (a -> b) -> a -> b
$ \ Clause
c -> LocalVars -> TCMT IO ()
setLocalVars LocalVars
lv' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Clause
c
    let nes :: [WithExpr]
nes = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall name a. Maybe name -> a -> Named name a
Named [Maybe BindName]
ns [Arg Expr]
es
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [WithExpr] -> [TCMT IO Clause] -> AbstractRHS
WithRHS' [WithExpr]
nes [TCMT IO Clause]
cs'
  -- TODO: some of these might be possible
  toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) (LocalVars, [Clause])
_ RHS' Expr
C.AbsurdRHS  AnyWhere{}) = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) (LocalVars, [Clause])
_ RHS' Expr
C.AbsurdRHS SomeWhere{}) = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     (LocalVars
_, []) RHS' Expr
C.AbsurdRHS  AnyWhere{}) = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     (LocalVars
_, []) RHS' Expr
C.AbsurdRHS SomeWhere{}) = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     (LocalVars
_, []) C.RHS{}      AnyWhere{}) = forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     (LocalVars
_, []) C.RHS{}     SomeWhere{}) = forall a. HasCallStack => a
__IMPOSSIBLE__

instance ToAbstract C.RHS where
    type AbsOfCon C.RHS = AbstractRHS

    toAbstract :: RHS' Expr -> ScopeM (AbsOfCon (RHS' Expr))
toAbstract RHS' Expr
C.AbsurdRHS = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AbstractRHS
AbsurdRHS'
    toAbstract (C.RHS Expr
e)   = Expr -> Expr -> AbstractRHS
RHS' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
e

data LeftHandSide = LeftHandSide C.QName C.Pattern

instance ToAbstract LeftHandSide where
    type AbsOfCon LeftHandSide = A.LHS

    toAbstract :: LeftHandSide -> ScopeM (AbsOfCon LeftHandSide)
toAbstract (LeftHandSide QName
top Pattern
lhs) =
      forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (QName -> Pattern -> Call
ScopeCheckLHS QName
top Pattern
lhs) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
5 forall a b. (a -> b) -> a -> b
$ [Char]
"original lhs: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Pattern
lhs
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"patternQNames: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall p. CPatternLike p => p -> [QName]
patternQNames Pattern
lhs)
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"original lhs (raw): " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pattern
lhs
        LHSCore
lhscore <- QName -> Pattern -> TCMT IO LHSCore
parseLHS QName
top Pattern
lhs
        let ell :: ExpandedEllipsis
ell = LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
lhscore
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
5 forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow LHSCore
lhscore
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs (raw): " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show LHSCore
lhscore
        Int -> [Char] -> TCMT IO ()
printLocals Int
10 [Char]
"before lhs:"
        -- error if copattern parsed but --no-copatterns option
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optCopatterns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LHSCore -> Bool
hasCopatterns LHSCore
lhscore) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ TypeError
NeedOptionCopatterns
        -- scope check patterns except for dot patterns
        LHSCore' Expr
lhscore <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
lhscore
        TCMT IO ()
bindVarsToBind
        -- reportSLn "scope.lhs" 5 $ "parsed lhs patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs patterns: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show LHSCore' Expr
lhscore
        Int -> [Char] -> TCMT IO ()
printLocals Int
10 [Char]
"checked pattern:"
        -- scope check dot patterns
        LHSCore' Expr
lhscore <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore' Expr
lhscore
        -- reportSLn "scope.lhs" 5 $ "parsed lhs dot patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs dot patterns: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show LHSCore' Expr
lhscore
        Int -> [Char] -> TCMT IO ()
printLocals Int
10 [Char]
"checked dots:"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LHSInfo -> LHSCore' Expr -> LHS
A.LHS (Range -> ExpandedEllipsis -> LHSInfo
LHSInfo (forall a. HasRange a => a -> Range
getRange Pattern
lhs) ExpandedEllipsis
ell) LHSCore' Expr
lhscore

hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis
hasExpandedEllipsis :: LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
core = case LHSCore
core of
  C.LHSHead{}       -> ExpandedEllipsis
NoEllipsis
  C.LHSProj{}       -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis forall a b. (a -> b) -> a -> b
$ forall a. NamedArg a -> a
namedArg forall a b. (a -> b) -> a -> b
$ LHSCore -> NamedArg LHSCore
C.lhsFocus LHSCore
core -- can this ever be ExpandedEllipsis?
  C.LHSWith{}       -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis forall a b. (a -> b) -> a -> b
$ LHSCore -> LHSCore
C.lhsHead LHSCore
core
  C.LHSEllipsis Range
r LHSCore
p -> case LHSCore
p of
    C.LHSWith LHSCore
p [Pattern]
wps [NamedArg Pattern]
_ -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
p forall a. Semigroup a => a -> a -> a
<> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern]
wps)
    C.LHSHead{}       -> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r Int
0
    C.LHSProj{}       -> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r Int
0
    C.LHSEllipsis{}   -> forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Merges adjacent EqualP patterns into one:
-- type checking expects only one pattern for each domain in the telescope.
mergeEqualPs :: [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs :: forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs = forall {e}.
(PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go (forall a. Null a => a
empty, [])
  where
    go :: (PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go (PatInfo, [(e, e)])
acc (p :: Arg (Named NamedName (Pattern' e))
p@(Arg ArgInfo
i (Named Maybe NamedName
mn (A.EqualP PatInfo
r [(e, e)]
es))) : [Arg (Named NamedName (Pattern' e))]
ps) = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Arg (Named NamedName (Pattern' e))
p forall a b. (a -> b) -> a -> b
$ do
      -- Face constraint patterns must be defaultNamedArg; check this:
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. LensModality a => a -> Modality
getModality ArgInfo
i forall a. Eq a => a -> a -> Bool
== Modality
defaultModality) forall a. HasCallStack => a
__IMPOSSIBLE__
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. LensHiding a => a -> Bool
hidden     ArgInfo
i) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(MonadWarning m, HasRange a) =>
a -> Doc -> m ()
warn ArgInfo
i forall a b. (a -> b) -> a -> b
$ Doc
"Face constraint patterns cannot be hidden arguments"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. LensHiding a => a -> Bool
isInstance ArgInfo
i) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(MonadWarning m, HasRange a) =>
a -> Doc -> m ()
warn ArgInfo
i forall a b. (a -> b) -> a -> b
$ Doc
"Face constraint patterns cannot be instance arguments"
      forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe NamedName
mn forall a b. (a -> b) -> a -> b
$ \ NamedName
x -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedName
x forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(MonadWarning m, HasRange a) =>
a -> Doc -> m ()
warn NamedName
x forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
P.hcat
          [ Doc
"Ignoring name `", forall a. Pretty a => a -> Doc
P.pretty NamedName
x, Doc
"` given to face constraint pattern" ]
      (PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go ((PatInfo, [(e, e)])
acc forall a. Monoid a => a -> a -> a
`mappend` (PatInfo
r, [(e, e)]
es)) [Arg (Named NamedName (Pattern' e))]
ps
    go (PatInfo
r, es :: [(e, e)]
es@((e, e)
_:[(e, e)]
_)) [Arg (Named NamedName (Pattern' e))]
ps = (forall a. a -> NamedArg a
defaultNamedArg (forall e. PatInfo -> [(e, e)] -> Pattern' e
A.EqualP PatInfo
r [(e, e)]
es) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs [Arg (Named NamedName (Pattern' e))]
ps
    go (PatInfo
_, []) []       = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (PatInfo
_, []) (Arg (Named NamedName (Pattern' e))
p : [Arg (Named NamedName (Pattern' e))]
ps) = (Arg (Named NamedName (Pattern' e))
p forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs [Arg (Named NamedName (Pattern' e))]
ps

    warn :: a -> Doc -> m ()
warn a
r Doc
d = forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall a b. (a -> b) -> a -> b
$ Range -> Doc -> Warning
GenericUseless (forall a. HasRange a => a -> Range
getRange a
r) Doc
d

-- does not check pattern linearity
instance ToAbstract C.LHSCore where
    type AbsOfCon C.LHSCore = (A.LHSCore' C.Expr)

    toAbstract :: LHSCore -> ScopeM (AbsOfCon LHSCore)
toAbstract (C.LHSHead QName
x [NamedArg Pattern]
ps) = do
        QName
x <- forall a. ScopeM a -> ScopeM a
withLocalVars forall a b. (a -> b) -> a -> b
$ do
          LocalVars -> TCMT IO ()
setLocalVars []
          forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (forall a. a -> OldName a
OldName QName
x)
        forall e. QName -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSHead QName
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NamedArg Pattern]
ps
    toAbstract (C.LHSProj QName
d [NamedArg Pattern]
ps1 NamedArg LHSCore
l [NamedArg Pattern]
ps2) = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null [NamedArg Pattern]
ps1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError forall a b. (a -> b) -> a -> b
$
          Doc
"Ill-formed projection pattern" Doc -> Doc -> Doc
P.<+> forall a. Pretty a => a -> Doc
P.pretty (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pattern -> NamedArg Pattern -> Pattern
C.AppP (QName -> Pattern
C.IdentP QName
d) [NamedArg Pattern]
ps1)
        ResolvedName
qx <- QName -> ScopeM ResolvedName
resolveName QName
d
        NonEmpty QName
ds <- case ResolvedName
qx of
                FieldName List1 AbstractName
ds -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds
                ResolvedName
UnknownName -> forall a. QName -> TCM a
notInScopeError QName
d
                ResolvedName
_           -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError forall a b. (a -> b) -> a -> b
$
                  [Char]
"head of copattern needs to be a field identifier, but "
                  forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
d forall a. [a] -> [a] -> [a]
++ [Char]
" isn't one"
        forall e.
AmbiguousQName
-> NamedArg (LHSCore' e) -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSProj (NonEmpty QName -> AmbiguousQName
AmbQ NonEmpty QName
ds) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NamedArg LHSCore
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NamedArg Pattern]
ps2)
    toAbstract (C.LHSWith LHSCore
core [Pattern]
wps [NamedArg Pattern]
ps) = do
      forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall e. LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
A.lhsCoreApp
        (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall e. LHSCore' e -> [Arg (Pattern' e)] -> LHSCore' e
A.lhsCoreWith
          (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
core)
          (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Arg a
defaultArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Pattern]
wps))
        (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NamedArg Pattern]
ps)
    -- In case of a part of the LHS which was expanded from an ellipsis,
    -- we flush the @scopeVarsToBind@ in order to allow variables bound
    -- in the ellipsis to be shadowed.
    toAbstract (C.LHSEllipsis Range
_ LHSCore
p) = do
      LHSCore' Expr
ap <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
p
      TCMT IO ()
bindVarsToBind
      forall (m :: * -> *) a. Monad m => a -> m a
return LHSCore' Expr
ap

instance ToAbstract c => ToAbstract (WithHiding c) where
  type AbsOfCon (WithHiding c) = WithHiding (AbsOfCon c)
  toAbstract :: WithHiding c -> ScopeM (AbsOfCon (WithHiding c))
toAbstract (WithHiding Hiding
h c
a) = forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h c.
(LensHiding h, ToAbstract c) =>
h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding Hiding
h c
a

instance ToAbstract c => ToAbstract (Arg c) where
    type AbsOfCon (Arg c) = Arg (AbsOfCon c)
    toAbstract :: Arg c -> ScopeM (AbsOfCon (Arg c))
toAbstract (Arg ArgInfo
info c
e) =
        forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h c.
(LensHiding h, ToAbstract c) =>
h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding ArgInfo
info c
e

instance ToAbstract c => ToAbstract (Named name c) where
    type AbsOfCon (Named name c) = Named name (AbsOfCon c)
    toAbstract :: Named name c -> ScopeM (AbsOfCon (Named name c))
toAbstract (Named Maybe name
n c
e) = forall name a. Maybe name -> a -> Named name a
Named Maybe name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
e

{- DOES NOT WORK ANYMORE with pattern synonyms
instance ToAbstract c a => ToAbstract (A.LHSCore' c) (A.LHSCore' a) where
    toAbstract = mapM toAbstract
-}

instance ToAbstract (A.LHSCore' C.Expr) where
    type AbsOfCon (A.LHSCore' C.Expr) = A.LHSCore' A.Expr
    toAbstract :: LHSCore' Expr -> ScopeM (AbsOfCon (LHSCore' Expr))
toAbstract (A.LHSHead QName
f [Arg (Named NamedName (Pattern' Expr))]
ps)         = forall e. QName -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSHead QName
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps
    toAbstract (A.LHSProj AmbiguousQName
d NamedArg (LHSCore' Expr)
lhscore [Arg (Named NamedName (Pattern' Expr))]
ps) = forall e.
AmbiguousQName
-> NamedArg (LHSCore' e) -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSProj AmbiguousQName
d forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NamedArg (LHSCore' Expr)
lhscore forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps
    toAbstract (A.LHSWith LHSCore' Expr
core [Arg (Pattern' Expr)]
wps [Arg (Named NamedName (Pattern' Expr))]
ps)  = forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 forall e.
LHSCore' e
-> [Arg (Pattern' e)] -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSWith (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore' Expr
core) (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Pattern' Expr)]
wps) (forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps)

-- Patterns are done in two phases. First everything but the dot patterns, and
-- then the dot patterns. This is because dot patterns can refer to variables
-- bound anywhere in the pattern.

instance ToAbstract (A.Pattern' C.Expr) where
  type AbsOfCon (A.Pattern' C.Expr) = A.Pattern' A.Expr
  toAbstract :: Pattern' Expr -> ScopeM (AbsOfCon (Pattern' Expr))
toAbstract = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall a. ScopeM a -> ScopeM a
insideDotPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
DotPatternCtx  -- Issue #3033

resolvePatternIdentifier ::
  Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)
resolvePatternIdentifier :: Range -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Range
r QName
x Maybe (Set Name)
ns = do
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"resolvePatternIdentifier " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
x forall a. [a] -> [a] -> [a]
++ [Char]
" at source position " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Range
r
  APatName
px <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> PatName
PatName QName
x Maybe (Set Name)
ns)
  case APatName
px of
    VarPatName Name
y         -> do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"  resolved to VarPatName " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
y forall a. [a] -> [a] -> [a]
++ [Char]
" with range " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall a. HasRange a => a -> Range
getRange Name
y)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. BindName -> Pattern' e
VarP forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.mkBindName Name
y
    ConPatName List1 AbstractName
ds        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
ConP (ConOrigin -> PatInfo -> ConPatLazy -> ConPatInfo
ConPatInfo ConOrigin
ConOCon (Range -> PatInfo
PatRange Range
r) ConPatLazy
ConPatEager)
                                          (NonEmpty QName -> AmbiguousQName
AmbQ forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds) []
    PatternSynPatName List1 AbstractName
ds -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
PatternSynP (Range -> PatInfo
PatRange Range
r)
                                                 (NonEmpty QName -> AmbiguousQName
AmbQ forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds) []

-- | Apply an abstract syntax pattern head to pattern arguments.
--
--   Fails with 'InvalidPattern' if head is not a constructor pattern
--   (or similar) that can accept arguments.
--
applyAPattern
  :: C.Pattern            -- ^ The application pattern in concrete syntax.
  -> A.Pattern' C.Expr    -- ^ Head of application.
  -> NAPs C.Expr          -- ^ Arguments of application.
  -> ScopeM (A.Pattern' C.Expr)
applyAPattern :: Pattern
-> Pattern' Expr
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (Pattern' Expr)
applyAPattern Pattern
p0 Pattern' Expr
p [Arg (Named NamedName (Pattern' Expr))]
ps = do
  forall a. SetRange a => Range -> a -> a
setRange (forall a. HasRange a => a -> Range
getRange Pattern
p0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    case Pattern' Expr
p of
      A.ConP ConPatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP        ConPatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
      A.DefP PatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP        PatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
      A.PatternSynP PatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
      -- Dotted constructors are turned into "lazy" constructor patterns.
      A.DotP PatInfo
i (Ident QName
x)   -> QName -> ScopeM ResolvedName
resolveName QName
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ConstructorName Set Induction
_ List1 AbstractName
ds -> do
          let cpi :: ConPatInfo
cpi = ConOrigin -> PatInfo -> ConPatLazy -> ConPatInfo
ConPatInfo ConOrigin
ConOCon PatInfo
i ConPatLazy
ConPatLazy
              c :: AmbiguousQName
c   = NonEmpty QName -> AmbiguousQName
AmbQ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
cpi AmbiguousQName
c [Arg (Named NamedName (Pattern' Expr))]
ps
        ResolvedName
_ -> TCMT IO (Pattern' Expr)
failure
      A.DotP{}    -> TCMT IO (Pattern' Expr)
failure
      A.VarP{}    -> TCMT IO (Pattern' Expr)
failure
      A.ProjP{}   -> TCMT IO (Pattern' Expr)
failure
      A.WildP{}   -> TCMT IO (Pattern' Expr)
failure
      A.AsP{}     -> TCMT IO (Pattern' Expr)
failure
      A.AbsurdP{} -> TCMT IO (Pattern' Expr)
failure
      A.LitP{}    -> TCMT IO (Pattern' Expr)
failure
      A.RecP{}    -> TCMT IO (Pattern' Expr)
failure
      A.EqualP{}  -> TCMT IO (Pattern' Expr)
failure
      A.WithP{}   -> TCMT IO (Pattern' Expr)
failure
      A.AnnP{}    -> TCMT IO (Pattern' Expr)
failure
  where
    failure :: TCMT IO (Pattern' Expr)
failure = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
InvalidPattern Pattern
p0

instance ToAbstract C.Pattern where
    type AbsOfCon C.Pattern = A.Pattern' C.Expr

    toAbstract :: Pattern -> ScopeM (AbsOfCon Pattern)
toAbstract (C.IdentP QName
x) =
      Range -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier (forall a. HasRange a => a -> Range
getRange QName
x) QName
x forall a. Maybe a
Nothing

    toAbstract (AppP (QuoteP Range
_) NamedArg Pattern
p)
      | IdentP QName
x <- forall a. NamedArg a -> a
namedArg NamedArg Pattern
p,
        forall a. LensHiding a => a -> Bool
visible NamedArg Pattern
p = do
      Expr
e <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x forall a. Maybe a
Nothing)
      forall e. PatInfo -> Literal -> Pattern' e
A.LitP (Range -> PatInfo
PatRange forall a b. (a -> b) -> a -> b
$ forall a. HasRange a => a -> Range
getRange QName
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Literal
LitQName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadTCError m, MonadAbsToCon m) =>
Expr -> m QName
quotedName Expr
e

    toAbstract (QuoteP Range
r) =
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"quote must be applied to an identifier"

    toAbstract p0 :: Pattern
p0@(AppP Pattern
p NamedArg Pattern
q) = do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
50 forall a b. (a -> b) -> a -> b
$ [Char]
"distributeDots before = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pattern
p
        Pattern
p <- Pattern -> ScopeM Pattern
distributeDots Pattern
p
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
50 forall a b. (a -> b) -> a -> b
$ [Char]
"distributeDots after  = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pattern
p
        (Pattern' Expr
p', Arg (Named NamedName (Pattern' Expr))
q') <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Pattern
p, NamedArg Pattern
q)
        Pattern
-> Pattern' Expr
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (Pattern' Expr)
applyAPattern Pattern
p0 Pattern' Expr
p' forall a b. (a -> b) -> a -> b
$ forall el coll. Singleton el coll => el -> coll
singleton Arg (Named NamedName (Pattern' Expr))
q'

        where
            distributeDots :: C.Pattern -> ScopeM C.Pattern
            distributeDots :: Pattern -> ScopeM Pattern
distributeDots p :: Pattern
p@(C.DotP Range
r Expr
e) = Range -> Expr -> ScopeM Pattern
distributeDotsExpr Range
r Expr
e
            distributeDots Pattern
p = forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p

            distributeDotsExpr :: Range -> C.Expr -> ScopeM C.Pattern
            distributeDotsExpr :: Range -> Expr -> ScopeM Pattern
distributeDotsExpr Range
r Expr
e = Expr -> ScopeM Expr
parseRawApp Expr
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              C.App Range
r Expr
e NamedArg Expr
a     ->
                Pattern -> NamedArg Pattern -> Pattern
AppP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr -> ScopeM Pattern
distributeDotsExpr Range
r Expr
e
                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (Range -> Expr -> ScopeM Pattern
distributeDotsExpr Range
r) NamedArg Expr
a
              OpApp Range
r QName
q Set Name
ns OpAppArgs
as ->
                case (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) forall a. MaybePlaceholder (OpApp a) -> Maybe a
fromNoPlaceholder OpAppArgs
as of
                  Just [NamedArg Expr]
as -> Range -> QName -> Set Name -> [NamedArg Pattern] -> Pattern
OpAppP Range
r QName
q Set Name
ns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (Range -> Expr -> ScopeM Pattern
distributeDotsExpr Range
r) [NamedArg Expr]
as
                  Maybe [NamedArg Expr]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Range -> Expr -> Pattern
C.DotP Range
r Expr
e
              Paren Range
r Expr
e -> Range -> Pattern -> Pattern
ParenP Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr -> ScopeM Pattern
distributeDotsExpr Range
r Expr
e
              Expr
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Range -> Expr -> Pattern
C.DotP Range
r Expr
e

            fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a
            fromNoPlaceholder :: forall a. MaybePlaceholder (OpApp a) -> Maybe a
fromNoPlaceholder (NoPlaceholder Maybe PositionInName
_ (Ordinary a
e)) = forall a. a -> Maybe a
Just a
e
            fromNoPlaceholder MaybePlaceholder (OpApp a)
_ = forall a. Maybe a
Nothing

            parseRawApp :: C.Expr -> ScopeM C.Expr
            parseRawApp :: Expr -> ScopeM Expr
parseRawApp (RawApp Range
r List2 Expr
es) = List2 Expr -> ScopeM Expr
parseApplication List2 Expr
es
            parseRawApp Expr
e             = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e

    toAbstract p0 :: Pattern
p0@(OpAppP Range
r QName
op Set Name
ns [NamedArg Pattern]
ps) = do
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 forall a b. (a -> b) -> a -> b
$ [Char]
"ConcreteToAbstract.toAbstract OpAppP{}: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pattern
p0
        Pattern' Expr
p  <- Range -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier (forall a. HasRange a => a -> Range
getRange QName
op) QName
op (forall a. a -> Maybe a
Just Set Name
ns)
        [Arg (Named NamedName (Pattern' Expr))]
ps <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NamedArg Pattern]
ps
        Pattern
-> Pattern' Expr
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (Pattern' Expr)
applyAPattern Pattern
p0 Pattern' Expr
p [Arg (Named NamedName (Pattern' Expr))]
ps

    toAbstract (EllipsisP Range
_ Maybe Pattern
mp) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe Pattern
mp

    -- Removed when parsing
    toAbstract (HiddenP Range
_ Named NamedName Pattern
_)   = forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (InstanceP Range
_ Named NamedName Pattern
_) = forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (RawAppP Range
_ List2 Pattern
_)   = forall a. HasCallStack => a
__IMPOSSIBLE__

    toAbstract p :: Pattern
p@(C.WildP Range
r)    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.WildP (Range -> PatInfo
PatRange Range
r)
    -- Andreas, 2015-05-28 futile attempt to fix issue 819: repeated variable on lhs "_"
    -- toAbstract p@(C.WildP r)    = A.VarP <$> freshName r "_"
    toAbstract (C.ParenP Range
_ Pattern
p)   = forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
    toAbstract (C.LitP Range
r Literal
l)     = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Literal -> Pattern' e
A.LitP (Range -> PatInfo
PatRange Range
r) Literal
l forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Literal -> TCMT IO ()
checkLiteral Literal
l

    toAbstract p0 :: Pattern
p0@(C.AsP Range
r Name
x Pattern
p) = do
        -- Andreas, 2018-06-30, issue #3147: as-variables can be non-linear a priori!
        -- x <- toAbstract (NewName PatternBound x)
        -- Andreas, 2020-05-01, issue #4631: as-variables should not shadow constructors.
        -- x <- bindPatternVariable x
      forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> PatName
PatName (Name -> QName
C.QName Name
x) forall a. Maybe a
Nothing) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        VarPatName Name
x        -> forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP (Range -> PatInfo
PatRange Range
r) (Name -> BindName
A.mkBindName Name
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
        ConPatName{}        -> Bool -> TCMT IO (Pattern' Expr)
ignoreAsPat Bool
False
        PatternSynPatName{} -> Bool -> TCMT IO (Pattern' Expr)
ignoreAsPat Bool
True
      where
      -- An @-bound name which shadows a constructor is illegal and becomes dead code.
      ignoreAsPat :: Bool -> TCMT IO (Pattern' Expr)
ignoreAsPat Bool
b = do
        forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall a b. (a -> b) -> a -> b
$ Bool -> Warning
AsPatternShadowsConstructorOrPatternSynonym Bool
b
        forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p

    toAbstract p0 :: Pattern
p0@(C.EqualP Range
r [(Expr, Expr)]
es)  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> [(e, e)] -> Pattern' e
A.EqualP (Range -> PatInfo
PatRange Range
r) [(Expr, Expr)]
es

    -- We have to do dot patterns at the end since they can
    -- refer to the variables bound by the other patterns.
    toAbstract p0 :: Pattern
p0@(C.DotP Range
r Expr
e) = do
      let fallback :: TCMT IO (Pattern' Expr)
fallback = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> e -> Pattern' e
A.DotP (Range -> PatInfo
PatRange Range
r) Expr
e
      case Expr
e of
        C.Ident QName
x -> QName -> ScopeM ResolvedName
resolveName QName
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          -- Andreas, 2018-06-19, #3130
          -- We interpret .x as postfix projection if x is a field name in scope
          FieldName List1 AbstractName
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' e
A.ProjP (Range -> PatInfo
PatRange Range
r) ProjOrigin
ProjPostfix forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
xs
          ResolvedName
_ -> TCMT IO (Pattern' Expr)
fallback
        Expr
_ -> TCMT IO (Pattern' Expr)
fallback

    toAbstract p0 :: Pattern
p0@(C.AbsurdP Range
r)    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.AbsurdP (Range -> PatInfo
PatRange Range
r)
    toAbstract (C.RecP Range
r [FieldAssignment' Pattern]
fs)       = forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP (Range -> PatInfo
PatRange Range
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract) [FieldAssignment' Pattern]
fs
    toAbstract (C.WithP Range
r Pattern
p)       = forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP (Range -> PatInfo
PatRange Range
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p

-- | An argument @OpApp C.Expr@ to an operator can have binders,
--   in case the operator is some @syntax@-notation.
--   For these binders, we have to create lambda-abstractions.
toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM A.Expr
toAbstractOpArg :: Precedence -> OpApp Expr -> ScopeM Expr
toAbstractOpArg Precedence
ctx (Ordinary Expr
e)                 = forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
ctx Expr
e
toAbstractOpArg Precedence
ctx (SyntaxBindingLambda Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e) = Range
-> NonEmpty (LamBinding' TypedBinding)
-> Expr
-> Precedence
-> ScopeM Expr
toAbstractLam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e Precedence
ctx

-- | Turn an operator application into abstract syntax. Make sure to
-- record the right precedences for the various arguments.
toAbstractOpApp :: C.QName -> Set A.Name -> OpAppArgs -> ScopeM A.Expr
toAbstractOpApp :: QName -> Set Name -> OpAppArgs -> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns OpAppArgs
es = do
    -- Replace placeholders with bound variables.
    ([LamBinding]
binders, [NamedArg (Either Expr (OpApp Expr))]
es) <- forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders OpAppArgs
es
    -- Get the notation for the operator.
    NewNotation
nota <- QName -> Set Name -> ScopeM NewNotation
getNotation QName
op Set Name
ns
    let parts :: Notation
parts = NewNotation -> Notation
notation NewNotation
nota
    -- We can throw away the @VarPart@s, since binders
    -- have been preprocessed into @OpApp C.Expr@.
    let nonBindingParts :: Notation
nonBindingParts = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotationPart -> Bool
isBinder) Notation
parts
    -- We should be left with as many holes as we have been given args @es@.
    -- If not, crash.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter NotationPart -> Bool
isAHole Notation
nonBindingParts) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg (Either Expr (OpApp Expr))]
es) forall a. HasCallStack => a
__IMPOSSIBLE__
    -- Translate operator and its arguments (each in the right context).
    Expr
op <- forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
op (forall a. a -> Maybe a
Just Set Name
ns))
    [(ParenPreference, NamedArg Expr)]
es <- Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
left (NewNotation -> Fixity
notaFixity NewNotation
nota) Notation
nonBindingParts [NamedArg (Either Expr (OpApp Expr))]
es
    -- Prepend the generated section binders (if any).
    let body :: Expr
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Expr -> (ParenPreference, NamedArg Expr) -> Expr
app Expr
op [(ParenPreference, NamedArg Expr)]
es
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ExprInfo -> LamBinding -> Expr -> Expr
A.Lam (Range -> ExprInfo
ExprRange (forall a. HasRange a => a -> Range
getRange Expr
body))) Expr
body [LamBinding]
binders
  where
    -- Build an application in the abstract syntax, with correct Range.
    app :: Expr -> (ParenPreference, NamedArg Expr) -> Expr
app Expr
e (ParenPreference
pref, NamedArg Expr
arg) = AppInfo -> Expr -> NamedArg Expr -> Expr
A.App AppInfo
info Expr
e NamedArg Expr
arg
      where info :: AppInfo
info = (Range -> AppInfo
defaultAppInfo Range
r) { appOrigin :: Origin
appOrigin = forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Expr
arg
                                      , appParens :: ParenPreference
appParens = ParenPreference
pref }
            r :: Range
r = forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange Expr
e NamedArg Expr
arg

    inferParenPref :: NamedArg (Either A.Expr (OpApp C.Expr)) -> ParenPreference
    inferParenPref :: NamedArg (Either Expr (OpApp Expr)) -> ParenPreference
inferParenPref NamedArg (Either Expr (OpApp Expr))
e =
      case forall a. NamedArg a -> a
namedArg NamedArg (Either Expr (OpApp Expr))
e of
        Right (Ordinary Expr
e) -> Expr -> ParenPreference
inferParenPreference Expr
e
        Left{}             -> ParenPreference
PreferParenless  -- variable inserted by section expansion
        Right{}            -> ParenPreference
PreferParenless  -- syntax lambda

    -- Translate an argument. Returns the paren preference for the argument, so
    -- we can build the correct info for the A.App node.
    toAbsOpArg :: Precedence ->
                  NamedArg (Either A.Expr (OpApp C.Expr)) ->
                  ScopeM (ParenPreference, NamedArg A.Expr)
    toAbsOpArg :: Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg Precedence
cxt NamedArg (Either Expr (OpApp Expr))
e = (ParenPreference
pref,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return (Precedence -> OpApp Expr -> ScopeM Expr
toAbstractOpArg Precedence
cxt)) NamedArg (Either Expr (OpApp Expr))
e
      where pref :: ParenPreference
pref = NamedArg (Either Expr (OpApp Expr)) -> ParenPreference
inferParenPref NamedArg (Either Expr (OpApp Expr))
e

    -- The hole left to the first @IdPart@ is filled with an expression in @LeftOperandCtx@.
    left :: Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
left Fixity
f (IdPart RString
_ : Notation
xs) [NamedArg (Either Expr (OpApp Expr))]
es = Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
inside Fixity
f Notation
xs [NamedArg (Either Expr (OpApp Expr))]
es
    left Fixity
f (NotationPart
_ : Notation
xs) (NamedArg (Either Expr (OpApp Expr))
e : [NamedArg (Either Expr (OpApp Expr))]
es) = do
        (ParenPreference, NamedArg Expr)
e  <- Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg (Fixity -> Precedence
LeftOperandCtx Fixity
f) NamedArg (Either Expr (OpApp Expr))
e
        [(ParenPreference, NamedArg Expr)]
es <- Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
inside Fixity
f Notation
xs [NamedArg (Either Expr (OpApp Expr))]
es
        forall (m :: * -> *) a. Monad m => a -> m a
return ((ParenPreference, NamedArg Expr)
e forall a. a -> [a] -> [a]
: [(ParenPreference, NamedArg Expr)]
es)
    left Fixity
f (NotationPart
_  : Notation
_)  [] = forall a. HasCallStack => a
__IMPOSSIBLE__
    left Fixity
f []        [NamedArg (Either Expr (OpApp Expr))]
_  = forall a. HasCallStack => a
__IMPOSSIBLE__

    -- The holes in between the @IdPart@s is filled with an expression in @InsideOperandCtx@.
    inside :: Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
inside Fixity
f [NotationPart
x]          [NamedArg (Either Expr (OpApp Expr))]
es    = Fixity
-> NotationPart
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
right Fixity
f NotationPart
x [NamedArg (Either Expr (OpApp Expr))]
es
    inside Fixity
f (IdPart RString
_ : Notation
xs) [NamedArg (Either Expr (OpApp Expr))]
es = Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
inside Fixity
f Notation
xs [NamedArg (Either Expr (OpApp Expr))]
es
    inside Fixity
f (NotationPart
_  : Notation
xs) (NamedArg (Either Expr (OpApp Expr))
e : [NamedArg (Either Expr (OpApp Expr))]
es) = do
        (ParenPreference, NamedArg Expr)
e  <- Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg Precedence
InsideOperandCtx NamedArg (Either Expr (OpApp Expr))
e
        [(ParenPreference, NamedArg Expr)]
es <- Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
inside Fixity
f Notation
xs [NamedArg (Either Expr (OpApp Expr))]
es
        forall (m :: * -> *) a. Monad m => a -> m a
return ((ParenPreference, NamedArg Expr)
e forall a. a -> [a] -> [a]
: [(ParenPreference, NamedArg Expr)]
es)
    inside Fixity
_ (NotationPart
_ : Notation
_) [] = forall a. HasCallStack => a
__IMPOSSIBLE__
    inside Fixity
_ []         [NamedArg (Either Expr (OpApp Expr))]
_  = forall a. HasCallStack => a
__IMPOSSIBLE__

    -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.
    right :: Fixity
-> NotationPart
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
right Fixity
_ (IdPart RString
_)  [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    right Fixity
f NotationPart
_          [NamedArg (Either Expr (OpApp Expr))
e] = do
        let pref :: ParenPreference
pref = NamedArg (Either Expr (OpApp Expr)) -> ParenPreference
inferParenPref NamedArg (Either Expr (OpApp Expr))
e
        (ParenPreference, NamedArg Expr)
e <- Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg (Fixity -> ParenPreference -> Precedence
RightOperandCtx Fixity
f ParenPreference
pref) NamedArg (Either Expr (OpApp Expr))
e
        forall (m :: * -> *) a. Monad m => a -> m a
return [(ParenPreference, NamedArg Expr)
e]
    right Fixity
_ NotationPart
_     [NamedArg (Either Expr (OpApp Expr))]
_  = forall a. HasCallStack => a
__IMPOSSIBLE__

    replacePlaceholders ::
      OpAppArgs' e ->
      ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])
    replacePlaceholders :: forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders []       = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    replacePlaceholders (NamedArg (MaybePlaceholder (OpApp e))
a : [NamedArg (MaybePlaceholder (OpApp e))]
as) = case forall a. NamedArg a -> a
namedArg NamedArg (MaybePlaceholder (OpApp e))
a of
      NoPlaceholder Maybe PositionInName
_ OpApp e
x -> forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd (forall a b. a -> NamedArg b -> NamedArg a
set (forall a b. b -> Either a b
Right OpApp e
x) NamedArg (MaybePlaceholder (OpApp e))
a forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
      Placeholder PositionInName
_     -> do
        Name
x <- forall (m :: * -> *).
MonadFresh NameId m =>
Range -> [Char] -> m Name
freshName forall a. Range' a
noRange [Char]
"section"
        let i :: ArgInfo
i = forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> ArgInfo
argInfo NamedArg (MaybePlaceholder (OpApp e))
a
        ([LamBinding]
ls, [NamedArg (Either Expr (OpApp e))]
ns) <- forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
        forall (m :: * -> *) a. Monad m => a -> m a
return ( NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree (forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
i forall a b. (a -> b) -> a -> b
$ Name -> Binder' BindName
A.mkBinder_ Name
x) forall a. a -> [a] -> [a]
: [LamBinding]
ls
               , forall a b. a -> NamedArg b -> NamedArg a
set (forall a b. a -> Either a b
Left (Name -> Expr
Var Name
x)) NamedArg (MaybePlaceholder (OpApp e))
a forall a. a -> [a] -> [a]
: [NamedArg (Either Expr (OpApp e))]
ns
               )
      where
      set :: a -> NamedArg b -> NamedArg a
      set :: forall a b. a -> NamedArg b -> NamedArg a
set a
x NamedArg b
arg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const a
x)) NamedArg b
arg

-- | Raises an error if the list of cohesion attributes is non-empty
-- and cohesion modalities are not supported.

checkCohesionAttributes :: CohesionAttributes -> ScopeM ()
checkCohesionAttributes :: CohesionAttributes -> TCMT IO ()
checkCohesionAttributes CohesionAttributes
attrs =
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optCohesion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) forall a b. (a -> b) -> a -> b
$
  case CohesionAttributes
attrs of
    []         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ([Char]
s, Range
r) : CohesionAttributes
_ ->
      forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
P.fsep forall a b. (a -> b) -> a -> b
$
      [Char] -> [Doc]
P.pwords [Char]
"Cohesion modalities have not been enabled" forall a. [a] -> [a] -> [a]
++
      [Char] -> [Doc]
P.pwords [Char]
"(use --cohesion to enable them):" forall a. [a] -> [a] -> [a]
++
      [[Char] -> Doc
P.text [Char]
s]

{--------------------------------------------------------------------------
    Things we parse but are not part of the Agda file syntax
 --------------------------------------------------------------------------}

-- | Content of interaction hole.

instance ToAbstract C.HoleContent where
  type AbsOfCon C.HoleContent = A.HoleContent
  toAbstract :: HoleContent -> ScopeM (AbsOfCon HoleContent)
toAbstract = \case
    HoleContentExpr Expr
e     -> forall qn nm p e. e -> HoleContent' qn nm p e
HoleContentExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
    HoleContentRewrite [RewriteEqn]
es -> forall qn nm p e. [RewriteEqn' qn nm p e] -> HoleContent' qn nm p e
HoleContentRewrite forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [RewriteEqn]
es