{-| 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
    , checkAttributes
    ) 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 qualified Data.HashSet as HashSet
import Data.Maybe
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 as 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.Opacity
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.Function ( applyWhen )
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.Syntax.Common.Pretty as P
import Agda.Syntax.Common.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 = (Expr -> TypeError) -> HasCallStack => Expr -> m a
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 = (Expr -> TypeError) -> HasCallStack => Expr -> m a
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 = (Expr -> TypeError) -> HasCallStack => Expr -> m a
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 = (NiceDeclaration -> TypeError)
-> HasCallStack => NiceDeclaration -> m a
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 = Pattern' e -> ScopeM (Pattern' Void)
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               -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern' Void
forall e. BindName -> Pattern' e
A.VarP BindName
x
      A.ConP ConPatInfo
i AmbiguousQName
c NAPs e
args        -> ConPatInfo -> AmbiguousQName -> NAPs Void -> Pattern' Void
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c (NAPs Void -> Pattern' Void)
-> TCMT IO (NAPs Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
 -> NAPs e -> TCMT IO (NAPs Void))
-> (NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
 -> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e)
-> TCMT IO (NamedArg (Pattern' Void))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
      A.ProjP PatInfo
i ProjOrigin
o AmbiguousQName
d          -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' Void
forall e. PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' e
A.ProjP PatInfo
i ProjOrigin
o AmbiguousQName
d
      A.WildP PatInfo
i              -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Void
forall e. PatInfo -> Pattern' e
A.WildP PatInfo
i
      A.AsP PatInfo
i BindName
x Pattern' e
p            -> PatInfo -> BindName -> Pattern' Void -> Pattern' Void
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i BindName
x (Pattern' Void -> Pattern' Void)
-> ScopeM (Pattern' Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p
      A.DotP{}               -> [Char] -> ScopeM (Pattern' Void)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
err
      A.EqualP{}             -> [Char] -> ScopeM (Pattern' Void)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
err   -- Andrea: so we also disallow = patterns, reasonable?
      A.AbsurdP PatInfo
i            -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Void
forall e. PatInfo -> Pattern' e
A.AbsurdP PatInfo
i
      A.LitP PatInfo
i Literal
l             -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Literal -> Pattern' Void
forall e. PatInfo -> Literal -> Pattern' e
A.LitP PatInfo
i Literal
l
      A.DefP PatInfo
i AmbiguousQName
f NAPs e
args        -> PatInfo -> AmbiguousQName -> NAPs Void -> Pattern' Void
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
f (NAPs Void -> Pattern' Void)
-> TCMT IO (NAPs Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
 -> NAPs e -> TCMT IO (NAPs Void))
-> (NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
 -> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e)
-> TCMT IO (NamedArg (Pattern' Void))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
      A.PatternSynP PatInfo
i AmbiguousQName
c NAPs e
args -> PatInfo -> AmbiguousQName -> NAPs Void -> Pattern' Void
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
c (NAPs Void -> Pattern' Void)
-> TCMT IO (NAPs Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
 -> NAPs e -> TCMT IO (NAPs Void))
-> (NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
 -> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e)
-> TCMT IO (NamedArg (Pattern' Void))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
      A.RecP PatInfo
i [FieldAssignment' (Pattern' e)]
fs            -> PatInfo -> [FieldAssignment' (Pattern' Void)] -> Pattern' Void
forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP PatInfo
i ([FieldAssignment' (Pattern' Void)] -> Pattern' Void)
-> TCMT IO [FieldAssignment' (Pattern' Void)]
-> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldAssignment' (Pattern' e)
 -> TCMT IO (FieldAssignment' (Pattern' Void)))
-> [FieldAssignment' (Pattern' e)]
-> TCMT IO [FieldAssignment' (Pattern' Void)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((FieldAssignment' (Pattern' e)
  -> TCMT IO (FieldAssignment' (Pattern' Void)))
 -> [FieldAssignment' (Pattern' e)]
 -> TCMT IO [FieldAssignment' (Pattern' Void)])
-> (FieldAssignment' (Pattern' e)
    -> TCMT IO (FieldAssignment' (Pattern' Void)))
-> [FieldAssignment' (Pattern' e)]
-> TCMT IO [FieldAssignment' (Pattern' Void)]
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> FieldAssignment' (Pattern' e)
-> TCMT IO (FieldAssignment' (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) [FieldAssignment' (Pattern' e)]
fs
      A.WithP PatInfo
i Pattern' e
p            -> PatInfo -> Pattern' Void -> Pattern' Void
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP PatInfo
i (Pattern' Void -> Pattern' Void)
-> ScopeM (Pattern' Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p
      A.AnnP PatInfo
i e
a Pattern' e
p           -> [Char] -> ScopeM (Pattern' Void)
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.
    DoWarn
-> [Declaration]
-> ([NiceDeclaration] -> ScopeM Expr)
-> ScopeM Expr
forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
NoWarn [Declaration]
decls (([NiceDeclaration] -> ScopeM Expr) -> ScopeM Expr)
-> ([NiceDeclaration] -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ [NiceDeclaration] -> ScopeM Expr
buildType ([NiceDeclaration] -> ScopeM Expr)
-> ([NiceDeclaration] -> [NiceDeclaration])
-> [NiceDeclaration]
-> ScopeM Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NiceDeclaration] -> [NiceDeclaration]
takeFields
  where
    takeFields :: [NiceDeclaration] -> [NiceDeclaration]
takeFields = (NiceDeclaration -> Bool) -> [NiceDeclaration] -> [NiceDeclaration]
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 ExprInfo
forall a. Null a => a
empty (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Literal
LitString Text
"TYPE"
      [TypedBinding]
tel   <- [Maybe TypedBinding] -> [TypedBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TypedBinding] -> [TypedBinding])
-> TCMT IO [Maybe TypedBinding] -> TCMT IO [TypedBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NiceDeclaration -> TCMT IO (Maybe TypedBinding))
-> [NiceDeclaration] -> TCMT IO [Maybe TypedBinding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NiceDeclaration -> TCMT IO (Maybe TypedBinding)
makeBinding [NiceDeclaration]
ds
      Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> [TypedBinding] -> Expr -> Expr
A.mkPi (Range -> ExprInfo
ExprRange ([NiceDeclaration] -> Range
forall a. HasRange a => a -> Range
getRange [NiceDeclaration]
ds)) [TypedBinding]
tel Expr
dummy

    makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)
    makeBinding :: NiceDeclaration -> TCMT IO (Maybe TypedBinding)
makeBinding NiceDeclaration
d = do
      let failure :: TCMT IO (Maybe TypedBinding)
failure = TypeError -> TCMT IO (Maybe TypedBinding)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (Maybe TypedBinding))
-> TypeError -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> TypeError
NotValidBeforeField NiceDeclaration
d
          r :: Range
r       = NiceDeclaration -> Range
forall a. HasRange a => a -> Range
getRange NiceDeclaration
d
          mkLet :: NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet NiceDeclaration
d = TypedBinding -> Maybe TypedBinding
forall a. a -> Maybe a
Just (TypedBinding -> Maybe TypedBinding)
-> (List1 LetBinding -> TypedBinding)
-> List1 LetBinding
-> Maybe TypedBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> List1 LetBinding -> TypedBinding
A.TLet Range
r (List1 LetBinding -> Maybe TypedBinding)
-> TCMT IO (List1 LetBinding) -> TCMT IO (Maybe TypedBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetDef -> ScopeM (AbsOfCon LetDef)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (NiceDeclaration -> LetDef
LetDef NiceDeclaration
d)
      Range
-> TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe TypedBinding)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe TypedBinding))
-> TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe TypedBinding)
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 = Binder -> Named NamedName Binder
forall a name. a -> Named name a
unnamed (BoundName -> Binder
forall a. a -> Binder' a
C.mkBinder (BoundName -> Binder) -> BoundName -> Binder
forall a b. (a -> b) -> a -> b
$ (Name -> Fixity' -> BoundName
C.mkBoundName Name
x Fixity'
fx) { bnameTactic = tac }) Named NamedName Binder -> Arg Expr -> NamedArg Binder
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Expr
a
          TypedBinding -> ScopeM (AbsOfCon TypedBinding)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (TypedBinding -> ScopeM (AbsOfCon TypedBinding))
-> TypedBinding -> ScopeM (AbsOfCon TypedBinding)
forall a b. (a -> b) -> a -> b
$ Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding
forall e. Range -> List1 (NamedArg Binder) -> e -> TypedBinding' e
C.TBind Range
r (NamedArg Binder -> List1 (NamedArg Binder)
forall el coll. Singleton el coll => el -> coll
singleton NamedArg Binder
bv) (Arg Expr -> Expr
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 -> TCMT IO (Maybe TypedBinding)
mkLet (NiceDeclaration -> TCMT IO (Maybe TypedBinding))
-> NiceDeclaration -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ Range -> QName -> ImportDirective -> NiceDeclaration
C.NiceOpen Range
r QName
m ImportDirective
dir{ publicOpen = Nothing }
        C.NiceModuleMacro Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
          NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet (NiceDeclaration -> TCMT IO (Maybe TypedBinding))
-> NiceDeclaration -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
C.NiceModuleMacro Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open
                    ImportDirective
dir{ publicOpen = 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 IsAbstract -> IsAbstract -> Bool
forall a. Eq a => a -> a -> Bool
/= IsAbstract
AbstractDef Bool -> Bool -> Bool
&& IsMacro
macro IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
/= IsMacro
MacroDef -> do
          NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet NiceDeclaration
d

        C.NiceLoneConstructor{} -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceMutual{}        -> TCMT IO (Maybe TypedBinding)
failure
        -- TODO: some of these cases might be __IMPOSSIBLE__
        C.Axiom{}             -> TCMT IO (Maybe TypedBinding)
failure
        C.PrimitiveFunction{} -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceModule{}        -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceImport{}        -> TCMT IO (Maybe TypedBinding)
failure
        C.NicePragma{}        -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceRecSig{}        -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceDataSig{}       -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceFunClause{}     -> TCMT IO (Maybe TypedBinding)
failure
        C.FunSig{}            -> TCMT IO (Maybe TypedBinding)
failure  -- Note: these are bundled with FunDef in NiceMutual
        C.FunDef{}            -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceDataDef{}       -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceRecDef{}        -> TCMT IO (Maybe TypedBinding)
failure
        C.NicePatternSyn{}    -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceGeneralize{}    -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceUnquoteDecl{}   -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceUnquoteDef{}    -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceUnquoteData{}   -> TCMT IO (Maybe TypedBinding)
failure
        C.NiceOpaque{}        -> TCMT IO (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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
    [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking ModuleApplication " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
    ]

  -- For the following, set the current module to be m0.
  ModuleName
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m0 (ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
 -> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective))
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
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' <- [Maybe TypedBinding] -> [TypedBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TypedBinding] -> [TypedBinding])
-> TCMT IO [Maybe TypedBinding] -> TCMT IO [TypedBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ScopeM (AbsOfCon Telescope)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel
    -- Scope check the old module name and the module args.
    ModuleName
m1    <- OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldModuleName -> ScopeM (AbsOfCon OldModuleName))
-> OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall a b. (a -> b) -> a -> b
$ QName -> OldModuleName
OldModuleName QName
m
    [NamedArg Expr]
args' <- Precedence -> [NamedArg Expr] -> ScopeM (AbsOfCon [NamedArg Expr])
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 -> ScopeM (ImportDirective, Scope)
applyImportDirectiveM (Name -> QName
C.QName Name
x) ImportDirective
dir' (Scope -> ScopeM (ImportDirective, Scope))
-> TCMT IO Scope -> ScopeM (ImportDirective, Scope)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModuleName -> TCMT IO 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 ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Scope -> Scope -> Scope
forall a b. a -> b -> a
const Scope
s'
    [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"mod.inst" Int
20 [Char]
"copied source module"
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.mod.inst" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> TCMT IO Doc
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> TCMT IO Doc) -> Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ ScopeCopyInfo -> Doc
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'
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
      [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked ModuleApplication " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ]
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
      [ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ ModuleApplication -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleApplication
amodapp
      ]
    (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
forall a. a -> TCMT IO a
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' =
  ModuleName
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m0 (ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
 -> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective))
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
forall a b. (a -> b) -> a -> b
$ do
    ModuleName
m1 <- OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldModuleName -> ScopeM (AbsOfCon OldModuleName))
-> OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall a b. (a -> b) -> a -> b
$ QName -> OldModuleName
OldModuleName QName
recN
    Scope
s <- ModuleName -> TCMT IO Scope
getNamedScope ModuleName
m1
    (ImportDirective
adir, Scope
s) <- QName
-> ImportDirective -> Scope -> ScopeM (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 ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Scope -> Scope -> Scope
forall a b. a -> b -> a
const Scope
s'

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

    ModuleName
m0 <- NewModuleName -> ScopeM (AbsOfCon NewModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> NewModuleName
NewModuleName Name
x)
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"NewModuleName: m0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCMT IO 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, Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
x) of
          (OpenShortHand
DoOpen,   Bool
False) -> (ImportDirective
forall n m. ImportDirective' n m
defaultImportDir, ImportDirective
dir)
          (OpenShortHand
DoOpen,   Bool
True)  -> ( ImportDirective
dir { publicOpen = Nothing }
                               , ImportDirective
forall n m. ImportDirective' n m
defaultImportDir { publicOpen = publicOpen dir }
                               )
          (OpenShortHand
DontOpen, Bool
_)     -> (ImportDirective
dir, ImportDirective
forall n m. ImportDirective' n m
defaultImportDir)

    -- Restore the locals after module application has been checked.
    (ModuleApplication
modapp', ScopeCopyInfo
copyInfo, ImportDirective
adir') <- ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
 -> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective))
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
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"

    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after mod app: trying to print m0 ..."
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after mod app: m0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCMT IO 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
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after bindMod: m0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCMT IO 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 -> ImportDirective -> TCMT IO ImportDirective
forall a. a -> TCMT IO a
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 (ModuleName -> Maybe ModuleName
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).
        ImportDirective -> TCMT IO ImportDirective
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportDirective -> TCMT IO ImportDirective)
-> ImportDirective -> TCMT IO ImportDirective
forall a b. (a -> b) -> a -> b
$ if Name -> Bool
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 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ OpenShortHand -> [Char]
forall a. Show a => a -> [Char]
show OpenShortHand
open
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after open   : m0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCMT IO 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 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"after stripping"
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"after stripNo: m0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCMT IO 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` Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
x
        adecl :: a
adecl  = ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a
apply ModuleInfo
info Erased
e ModuleName
m ModuleApplication
modapp' ScopeCopyInfo
copyInfo ImportDirective
adir

    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
      [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked ModuleMacro " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ]
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn  [Char]
"scope.decl" Int
90 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"info    = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> [Char]
forall a. Show a => a -> [Char]
show ModuleInfo
info
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn  [Char]
"scope.decl" Int
90 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"m       = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ModuleName
m
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn  [Char]
"scope.decl" Int
90 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"modapp' = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleApplication -> [Char]
forall a. Show a => a -> [Char]
show ModuleApplication
modapp'
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> TCMT IO Doc
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> TCMT IO Doc) -> Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ ScopeCopyInfo -> Doc
forall a. Pretty a => a -> Doc
pretty ScopeCopyInfo
copyInfo
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ a -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA a
adecl
    a -> ScopeM a
forall a. a -> TCMT IO a
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 = Maybe Name
forall a. Maybe a
Nothing
             , minfoAsTo :: Range
minfoAsTo   = ImportDirective -> Range
renamingRange ImportDirective
dir
             , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = OpenShortHand -> Maybe OpenShortHand
forall a. a -> Maybe a
Just OpenShortHand
open
             , minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
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 = ImportDirective -> ScopeM ImportDirective
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
dir
notPublicWithoutOpen OpenShortHand
DontOpen ImportDirective
dir = do
  Maybe Range -> (Range -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe Range
forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dir) ((Range -> TCMT IO ()) -> TCMT IO ())
-> (Range -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Range
r ->
    Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
  ImportDirective -> ScopeM ImportDirective
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportDirective -> ScopeM ImportDirective)
-> ImportDirective -> ScopeM ImportDirective
forall a b. (a -> b) -> a -> b
$ ImportDirective
dir { publicOpen = Nothing }

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

renamingRange :: C.ImportDirective -> Range
renamingRange :: ImportDirective -> Range
renamingRange = [Range] -> Range
forall a. HasRange a => a -> Range
getRange ([Range] -> Range)
-> (ImportDirective -> [Range]) -> ImportDirective -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Renaming' Name Name -> Range) -> [Renaming' Name Name] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Renaming' Name Name -> Range
forall n m. Renaming' n m -> Range
renToRange ([Renaming' Name Name] -> [Range])
-> (ImportDirective -> [Renaming' Name Name])
-> ImportDirective
-> [Range]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDirective -> [Renaming' Name Name]
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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    ModuleName
cm <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
      [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"scope checking NiceOpen " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> TCMT IO Doc
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x)
      , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"  getCurrentModule       = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> ModuleName -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
cm
      , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"  getCurrentModule (raw) = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Show a => a -> [Char]
show ModuleName
cm
      , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"  C.ImportDirective      = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ImportDirective -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ImportDirective
dir
      ]
  -- Andreas, 2017-01-01, issue #2377: warn about useless `public`
  Maybe Range -> (Range -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe Range
forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dir) ((Range -> TCMT IO ()) -> TCMT IO ())
-> (Range -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Range
r -> do
    TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((ModuleName
A.noModuleName ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModuleName -> Bool) -> TCMT IO ModuleName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
      Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic

  ModuleName
m <- Maybe ModuleName
-> TCMT IO ModuleName
-> (ModuleName -> TCMT IO ModuleName)
-> TCMT IO ModuleName
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ModuleName
mam (OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
x)) ModuleName -> TCMT IO ModuleName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"open" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"opening " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
  ImportDirective
adir <- OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> TCMT IO ImportDirective
openModule OpenKind
TopOpenModule (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m) QName
x ImportDirective
dir
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"open" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"result:"
  let minfo :: ModuleInfo
minfo = ModuleInfo
        { minfoRange :: Range
minfoRange     = Range
r
        , minfoAsName :: Maybe Name
minfoAsName    = Maybe Name
forall a. Maybe a
Nothing
        , minfoAsTo :: Range
minfoAsTo      = ImportDirective -> Range
renamingRange ImportDirective
dir
        , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = Maybe OpenShortHand
forall a. Maybe a
Nothing
        , minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dir
        }
  let adecls :: [Declaration]
adecls = [ModuleInfo -> ModuleName -> ImportDirective -> Declaration
A.Open ModuleInfo
minfo ModuleName
m ImportDirective
adir]
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
    [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ( [Char]
"scope checked NiceOpen " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
         ) TCMT IO Doc -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. a -> [a] -> [a]
: (Declaration -> TCMT IO Doc) -> [Declaration] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc)
-> (Declaration -> TCMT IO Doc) -> Declaration -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA) [Declaration]
adecls
  (ModuleInfo, ModuleName, ImportDirective)
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
forall a. a -> TCMT IO a
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 = Doc -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Doc -> m ()
genericNonFatalError (Doc -> TCMT IO ()) -> Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
forall a. [Char] -> Doc a
P.text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid character literal " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                                             [Char]
" (surrogate code points are not supported)"
checkLiteral Literal
_ = () -> TCMT IO ()
forall a. a -> TCMT IO a
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_ = c -> ScopeM (AbsOfCon c)
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 = ScopeInfo -> TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c)
forall (m :: * -> *) a. ReadTCState m => ScopeInfo -> m a -> m a
withScope_ ScopeInfo
scope (c -> TCMT IO (AbsOfCon c)
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 = Precedence -> TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c)
forall (m :: * -> *) a. ReadTCState m => Precedence -> m a -> m a
withContextPrecedence Precedence
ctx (TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c)
forall a b. (a -> b) -> a -> b
$ c -> TCMT IO (AbsOfCon c)
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 | h -> Bool
forall a. LensHiding a => a -> Bool
visible h
h = c -> ScopeM (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract -- don't change precedence if visible
toAbstractHiding h
_             = Precedence -> c -> ScopeM (AbsOfCon c)
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 = (b, ScopeInfo) -> b
forall a b. (a, b) -> a
fst ((b, ScopeInfo) -> b) -> TCMT IO (b, ScopeInfo) -> ScopeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> (AbsOfCon c -> ScopeM b) -> TCMT IO (b, ScopeInfo)
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 <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  ScopeInfo -> ScopeM b -> ScopeM (b, ScopeInfo)
forall (m :: * -> *) a.
ReadTCState m =>
ScopeInfo -> m a -> m (a, ScopeInfo)
withScope ScopeInfo
scope (ScopeM b -> ScopeM (b, ScopeInfo))
-> ScopeM b -> ScopeM (b, ScopeInfo)
forall a b. (a -> b) -> a -> b
$ AbsOfCon c -> ScopeM b
ret (AbsOfCon c -> ScopeM b) -> TCMT IO (AbsOfCon c) -> ScopeM b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
x

instance ToAbstract () where
  type AbsOfCon () = ()
  toAbstract :: () -> ScopeM (AbsOfCon ())
toAbstract = () -> TCMT IO ()
() -> ScopeM (AbsOfCon ())
forall a. a -> TCMT IO a
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) = (,) (AbsOfCon c1 -> AbsOfCon c2 -> (AbsOfCon c1, AbsOfCon c2))
-> TCMT IO (AbsOfCon c1)
-> TCMT IO (AbsOfCon c2 -> (AbsOfCon c1, AbsOfCon c2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c1 -> TCMT IO (AbsOfCon c1)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c1
x TCMT IO (AbsOfCon c2 -> (AbsOfCon c1, AbsOfCon c2))
-> TCMT IO (AbsOfCon c2) -> TCMT IO (AbsOfCon c1, AbsOfCon c2)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c2 -> TCMT IO (AbsOfCon c2)
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) = (AbsOfCon c1, (AbsOfCon c2, AbsOfCon c3))
-> (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)
forall {a} {b} {c}. (a, (b, c)) -> (a, b, c)
flatten ((AbsOfCon c1, (AbsOfCon c2, AbsOfCon c3))
 -> (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3))
-> TCMT IO (AbsOfCon c1, (AbsOfCon c2, AbsOfCon c3))
-> TCMT IO (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (c1, (c2, c3)) -> ScopeM (AbsOfCon (c1, (c2, c3)))
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 = (c -> TCMT IO (AbsOfCon c)) -> [c] -> TCMT IO [AbsOfCon c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM c -> TCMT IO (AbsOfCon c)
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 = (c -> TCMT IO (AbsOfCon c))
-> List1 c -> TCMT IO (NonEmpty (AbsOfCon c))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM c -> TCMT IO (AbsOfCon c)
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 = (c1 -> TCMT IO (AbsOfCon c1))
-> (c2 -> TCMT IO (AbsOfCon c2))
-> Either c1 c2
-> TCMT IO (Either (AbsOfCon c1) (AbsOfCon c2))
forall (f :: * -> *) a c b d.
Functor f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
traverseEither c1 -> TCMT IO (AbsOfCon c1)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c2 -> TCMT IO (AbsOfCon c2)
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 = (c -> TCMT IO (AbsOfCon c))
-> Maybe c -> TCMT IO (Maybe (AbsOfCon c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse c -> TCMT IO (AbsOfCon c)
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 -> b) -> NewName a -> NewName b)
-> (forall a b. a -> NewName b -> NewName a) -> Functor NewName
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
$cfmap :: forall a b. (a -> b) -> NewName a -> NewName b
fmap :: forall a b. (a -> b) -> NewName a -> NewName b
$c<$ :: forall a b. a -> NewName b -> NewName a
<$ :: forall a b. a -> NewName b -> NewName a
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
    Name -> ScopeM Name
forall a. a -> TCMT IO a
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
    BindName -> TCMT IO BindName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BindName -> TCMT IO BindName) -> BindName -> TCMT IO BindName
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)
_) =
    ScopeM (AbsOfCon OldQName)
-> TCMT IO (Maybe (AbsOfCon OldQName))
-> ScopeM (AbsOfCon OldQName)
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM (QName -> ScopeM Expr
forall a. QName -> TCM a
notInScopeError QName
x) (TCMT IO (Maybe (AbsOfCon OldQName)) -> ScopeM (AbsOfCon OldQName))
-> TCMT IO (Maybe (AbsOfCon OldQName))
-> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
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
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.name" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"resolved " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ResolvedName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ResolvedName
qx
    case ResolvedName
qx of
      VarName Name
x' BindingSource
_         -> Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> TCMT IO (Maybe Expr))
-> Maybe Expr -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Name -> Expr
A.Var Name
x'
      DefinedName Access
_ AbstractName
d Suffix
suffix -> do
        QName -> TCMT IO ()
forall (m :: * -> *).
(MonadWarning m, ReadTCState m) =>
QName -> m ()
raiseWarningsOnUsage (QName -> TCMT IO ()) -> QName -> TCMT IO ()
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 <- Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
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 -> (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars Lens' TCState (Maybe (Set QName))
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> a -> m ()
`setTCLens` Set QName -> Maybe (Set QName)
forall a. a -> Maybe a
Just (Set QName
s Set QName -> Set QName -> Set QName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` QName -> Set QName
forall a. a -> Set a
Set.singleton (AbstractName -> QName
anameName AbstractName
d))
                Maybe (Set QName)
Nothing -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
GeneralizeNotSupportedHere (QName -> TypeError) -> QName -> TypeError
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
          KindOfName
DisallowedGeneralizeName -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
GeneralizedVarInLetOpenedModule (QName -> TypeError) -> QName -> TypeError
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
          KindOfName
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- and then we return the name
        Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> TCMT IO (Maybe Expr))
-> Maybe Expr -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Suffix -> Expr -> Maybe Expr
withSuffix Suffix
suffix (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ AbstractName -> Expr
forall a. NameToExpr a => a -> Expr
nameToExpr AbstractName
d
        where
          withSuffix :: Suffix -> Expr -> Maybe Expr
withSuffix Suffix
NoSuffix   Expr
e         = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
          withSuffix s :: Suffix
s@Suffix{} (A.Def QName
x) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ QName -> Suffix -> Expr
A.Def' QName
x Suffix
s
          withSuffix Suffix
_          Expr
_         = Maybe 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          -> Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Expr
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 = (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
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
        Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> TCMT IO (Maybe Expr))
-> Maybe Expr -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> Expr
f (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
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 :| [] -> QName -> TCMT IO ()
forall (m :: * -> *).
(MonadWarning m, ReadTCState m) =>
QName -> m ()
raiseWarningsOnUsage QName
x
        NonEmpty QName
_       -> () -> TCMT IO ()
forall a. a -> TCMT IO a
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 ScopeM ResolvedName
-> (ResolvedName -> ScopeM ResolvedName) -> ScopeM ResolvedName
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ResolvedName
UnknownName -> QName -> ScopeM ResolvedName
forall a. QName -> TCM a
notInScopeError QName
x
    ResolvedName
q -> ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
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
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"checking pattern name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
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
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"resolved as " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ResolvedName -> [Char]
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
_)                                -> List1 AbstractName -> TCMT IO APatName
forall {m :: * -> *}.
MonadDebug m =>
List1 AbstractName -> m APatName
patCon List1 AbstractName
ds
      (PatternSynResName List1 AbstractName
d, QName
_)                                 -> List1 AbstractName -> TCMT IO APatName
forall {m :: * -> *}.
MonadDebug m =>
List1 AbstractName -> m APatName
patSyn List1 AbstractName
d
      (ResolvedName, QName)
_ -> [Char] -> TCMT IO APatName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO APatName) -> [Char] -> TCMT IO APatName
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot pattern match on non-constructor " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
    where
      bindPatVar :: Name -> TCMT IO APatName
bindPatVar = Name -> APatName
VarPatName (Name -> APatName)
-> (Name -> ScopeM Name) -> Name -> TCMT IO APatName
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
        [Char] -> Int -> [Char] -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a con: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        APatName -> m APatName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (APatName -> m APatName) -> APatName -> m APatName
forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> APatName
ConPatName List1 AbstractName
ds
      patSyn :: List1 AbstractName -> m APatName
patSyn List1 AbstractName
ds = do
        [Char] -> Int -> [Char] -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a pat syn: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        APatName -> m APatName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (APatName -> m APatName) -> APatName -> m APatName
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 <- (Name -> [(Name, LocalVar)] -> Maybe LocalVar
forall a b. Eq a => a -> [(a, b)] -> Maybe b
AssocList.lookup Name
x ([(Name, LocalVar)] -> Maybe LocalVar)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO (Maybe LocalVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [(Name, LocalVar)]
getVarsToBind) TCMT IO (Maybe LocalVar)
-> (Maybe LocalVar -> ScopeM Name) -> ScopeM Name
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (LocalVar Name
y BindingSource
_ [AbstractName]
_) -> do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a old var: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      Name -> ScopeM Name
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> ScopeM Name) -> Name -> ScopeM Name
forall a b. (a -> b) -> a -> b
$ Range -> Name -> Name
forall a. SetRange a => Range -> a -> a
setRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Name
y
    Maybe LocalVar
Nothing -> do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a new var: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      Name -> ScopeM Name
freshAbstractName_ Name
x
  Name -> LocalVar -> TCMT IO ()
addVarToBind Name
x (LocalVar -> TCMT IO ()) -> LocalVar -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> BindingSource -> [AbstractName] -> LocalVar
LocalVar Name
y BindingSource
PatternBound []
  Name -> ScopeM Name
forall a. a -> TCMT IO a
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 = QName -> QName
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 (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
    case ResolvedName
rx of
      DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
      DefinedName Access
_ AbstractName
d Suffix{} -> QName -> TCMT IO QName
forall a. QName -> TCM a
notInScopeError (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
      -- We can get the cases below for DISPLAY pragmas
      ConstructorName Set Induction
_ List1 AbstractName
ds -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (List1 AbstractName -> AbstractName
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         -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
      PatternSynResName List1 AbstractName
ds -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
      VarName Name
x BindingSource
_          -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Not a defined name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      ResolvedName
UnknownName          -> QName -> TCMT IO QName
forall a. QName -> TCM a
notInScopeError (a -> QName
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 (a -> QName
forall a. ToQName a => a -> QName
toQName a
x) ScopeM ResolvedName
-> (ResolvedName -> ScopeM (List1 AbstractName))
-> ScopeM (List1 AbstractName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List1 AbstractName -> ScopeM (List1 AbstractName))
-> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> List1 AbstractName
forall el coll. Singleton el coll => el -> coll
singleton AbstractName
d
    DefinedName Access
_ AbstractName
d Suffix{} -> QName -> ScopeM (List1 AbstractName)
forall a. QName -> TCM a
notInScopeError (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
    ConstructorName Set Induction
_ List1 AbstractName
ds     -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
    FieldName List1 AbstractName
ds             -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
    PatternSynResName List1 AbstractName
ds     -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
    VarName Name
x BindingSource
_              -> [Char] -> ScopeM (List1 AbstractName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM (List1 AbstractName))
-> [Char] -> ScopeM (List1 AbstractName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Not a defined name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
    ResolvedName
UnknownName              -> QName -> ScopeM (List1 AbstractName)
forall a. QName -> TCM a
notInScopeError (a -> QName
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 -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x = ModuleName -> ModuleName -> ModuleName
A.qualifyM ModuleName
m (ModuleName -> ModuleName)
-> (Name -> ModuleName) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Name -> ModuleName
mnameFromList1 (List1 Name -> ModuleName)
-> (Name -> List1 Name) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton (Name -> ModuleName) -> ScopeM Name -> TCMT IO ModuleName
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] <- QName -> ScopeInfo -> [AbstractModule]
forall a. InScope a => QName -> ScopeInfo -> [a]
scopeLookup (Name -> QName
C.QName Name
x) (ScopeInfo -> [AbstractModule])
-> TCMT IO ScopeInfo -> TCMT IO [AbstractModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AbstractModule] -> Bool
forall a. Null a => a -> Bool
null [AbstractModule]
ms) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.clash" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"clashing modules ms = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [AbstractModule] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [AbstractModule]
ms
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.clash" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"clashing modules ms = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [AbstractModule] -> [Char]
forall a. Show a => a -> [Char]
show [AbstractModule]
ms
    Name -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> [ModuleName] -> TypeError
ShadowedModule Name
x ([ModuleName] -> TypeError) -> [ModuleName] -> TypeError
forall a b. (a -> b) -> a -> b
$
                (AbstractModule -> ModuleName) -> [AbstractModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ((ModuleName -> Name -> ModuleName
forall t u. (SetRange t, HasRange u) => t -> u -> t
`withRangeOf` Name
x) (ModuleName -> ModuleName)
-> (AbstractModule -> ModuleName) -> AbstractModule -> ModuleName
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 <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    ModuleName
y <- ModuleName -> Name -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x
    Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule Maybe DataOrRecordModule
forall a. Maybe a
Nothing ModuleName
y
    ModuleName -> TCMT IO ModuleName
forall a. a -> TCMT IO a
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 -> TCMT IO ModuleName
toAbs ModuleName
noModuleName QName
m
    where
      toAbs :: ModuleName -> QName -> TCMT IO ModuleName
toAbs ModuleName
m (C.QName Name
x)  = do
        ModuleName
y <- ModuleName -> Name -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x
        Maybe DataOrRecordModule -> ModuleName -> TCMT IO ()
createModule Maybe DataOrRecordModule
forall a. Maybe a
Nothing ModuleName
y
        ModuleName -> TCMT IO ModuleName
forall a. a -> TCMT IO a
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 -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x
        ModuleName -> QName -> TCMT IO ModuleName
toAbs ModuleName
m' QName
q

instance ToAbstract OldModuleName where
  type AbsOfCon OldModuleName = A.ModuleName

  toAbstract :: OldModuleName -> ScopeM (AbsOfCon OldModuleName)
toAbstract (OldModuleName QName
q) = QName
-> ScopeM (AbsOfCon OldModuleName)
-> ScopeM (AbsOfCon OldModuleName)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
q (ScopeM (AbsOfCon OldModuleName)
 -> ScopeM (AbsOfCon OldModuleName))
-> ScopeM (AbsOfCon OldModuleName)
-> ScopeM (AbsOfCon OldModuleName)
forall a b. (a -> b) -> a -> b
$ do
    AbstractModule -> ModuleName
amodName (AbstractModule -> ModuleName)
-> TCMT IO AbstractModule -> TCMT IO ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO 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) = ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (ArgInfo -> ArgInfo
forall a. LensHiding a => a -> a
hide         ArgInfo
info) (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Named NamedName Expr -> Expr
forall name a. Named name a -> a
namedThing Named NamedName Expr
e
mkArg' ArgInfo
info (C.InstanceArg Range
_ Named NamedName Expr
e) = ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (ArgInfo -> ArgInfo
forall a. LensHiding a => a -> a
makeInstance ArgInfo
info) (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Named NamedName Expr -> Expr
forall name a. Named name a -> a
namedThing Named NamedName Expr
e
mkArg' ArgInfo
info Expr
e                   = ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (Hiding -> ArgInfo -> ArgInfo
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
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.irrelevance" Int
100 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"toAbstractDotHiding: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Doc a -> [Char]
render (Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e)
    Call
-> ScopeM (Expr, Relevance, Hiding)
-> ScopeM (Expr, Relevance, Hiding)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) (ScopeM (Expr, Relevance, Hiding)
 -> ScopeM (Expr, Relevance, Hiding))
-> ScopeM (Expr, Relevance, Hiding)
-> ScopeM (Expr, Relevance, Hiding)
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 (Expr -> ScopeM (Expr, Relevance, Hiding))
-> TCMT IO Expr -> ScopeM (Expr, Relevance, Hiding)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< List2 Expr -> TCMT IO 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 (Relevance -> Maybe Relevance
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 (Relevance -> Maybe Relevance
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 (Hiding -> Maybe Hiding
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 (Hiding -> Maybe Hiding
forall a. a -> Maybe a
Just (Hiding -> Maybe Hiding) -> Hiding -> Maybe Hiding
forall a b. (a -> b) -> a -> b
$ Overlappable -> Hiding
Instance Overlappable
NoOverlap) Precedence
TopCtx Expr
e

      Expr
e                 -> (, Relevance -> Maybe Relevance -> Relevance
forall a. a -> Maybe a -> a
fromMaybe Relevance
Relevant Maybe Relevance
mr, Hiding -> Maybe Hiding -> Hiding
forall a. a -> Maybe a -> a
fromMaybe Hiding
NotHidden Maybe Hiding
mh) (Expr -> (Expr, Relevance, Hiding))
-> ScopeM Expr -> ScopeM (Expr, Relevance, Hiding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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
  [(Name, LocalVar)]
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
  NonEmpty (LamBinding' TypedBinding)
-> (AbsOfCon (NonEmpty (LamBinding' TypedBinding)) -> ScopeM Expr)
-> ScopeM Expr
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract ((LamBinding' TypedBinding -> LamBinding' TypedBinding)
-> NonEmpty (LamBinding' TypedBinding)
-> NonEmpty (LamBinding' TypedBinding)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypedBinding -> LamBinding' TypedBinding
forall a. a -> LamBinding' a
C.DomainFull (TypedBinding -> LamBinding' TypedBinding)
-> (LamBinding' TypedBinding -> TypedBinding)
-> LamBinding' TypedBinding
-> LamBinding' TypedBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LamBinding' TypedBinding -> TypedBinding
makeDomainFull) NonEmpty (LamBinding' TypedBinding)
bs) ((AbsOfCon (NonEmpty (LamBinding' TypedBinding)) -> ScopeM Expr)
 -> ScopeM Expr)
-> (AbsOfCon (NonEmpty (LamBinding' TypedBinding)) -> ScopeM Expr)
-> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \ AbsOfCon (NonEmpty (LamBinding' TypedBinding))
bs -> do
    [(Name, LocalVar)]
lvars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    [(Name, LocalVar)] -> [(Name, LocalVar)] -> TCMT IO ()
checkNoShadowing [(Name, LocalVar)]
lvars0 [(Name, LocalVar)]
lvars1
    -- Translate the body
    Expr
e <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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@.
    Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ case List1 (Maybe LamBinding) -> [LamBinding]
forall a. List1 (Maybe a) -> [a]
List1.catMaybes List1 (Maybe LamBinding)
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 (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (LamBinding -> Expr -> Expr) -> Expr -> [LamBinding] -> Expr
forall a b. (a -> b -> b) -> 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 (Range -> ExprInfo) -> Range -> ExprInfo
forall a b. (a -> b) -> a -> b
$ LamBinding -> Expr -> Range
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
e List1 LamClause
cs = do
  TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM TCMT IO Bool
isInsideDotPattern (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> TCMT IO ()
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 <- (TCEnv -> IsAbstract) -> TCMT IO IsAbstract
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC (TCEnv -> Lens' TCEnv IsAbstract -> IsAbstract
forall o i. o -> Lens' o i -> i
^. (IsAbstract -> f IsAbstract) -> TCEnv -> f TCEnv
forall a. LensIsAbstract a => Lens' a IsAbstract
Lens' TCEnv IsAbstract
lensIsAbstract)
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.extendedLambda" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"new extended lambda name (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IsAbstract -> [Char]
forall a. Show a => a -> [Char]
show IsAbstract
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
name
    ]
  [Char] -> Int -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => [Char] -> Int -> m () -> m ()
verboseS [Char]
"scope.extendedLambda" Int
60 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    List1 LamClause -> (LamClause -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ List1 LamClause
cs ((LamClause -> TCMT IO ()) -> TCMT IO ())
-> (LamClause -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ LamClause
c -> do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.extendedLambda" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"extended lambda lhs: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Pattern] -> [Char]
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 TerminationCheck
forall a. HasCallStack => a
__IMPOSSIBLE__ CoverageCheck
forall a. HasCallStack => a
__IMPOSSIBLE__ Name
cname ([Clause] -> NiceDeclaration)
-> (NonEmpty Clause -> [Clause])
-> NonEmpty Clause
-> NiceDeclaration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Clause -> [Item (NonEmpty Clause)]
NonEmpty Clause -> [Clause]
forall l. IsList l => l -> [Item l]
List1.toList (NonEmpty Clause -> NiceDeclaration)
-> TCMT IO (NonEmpty Clause) -> TCMT IO NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          List1 LamClause
-> (LamClause -> TCMT IO Clause) -> TCMT IO (NonEmpty Clause)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 LamClause
cs ((LamClause -> TCMT IO Clause) -> TCMT IO (NonEmpty Clause))
-> (LamClause -> TCMT IO Clause) -> TCMT IO (NonEmpty Clause)
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 (List1 Pattern -> Pattern) -> List1 Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$
                        (KillRangeT Pattern
forall a. KillRange a => KillRangeT a
killRange KillRangeT Pattern -> KillRangeT Pattern
forall a b. (a -> b) -> a -> b
$ Bool -> QName -> Pattern
IdentP Bool
True (QName -> Pattern) -> QName -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName Name
cname) Pattern -> [Pattern] -> List1 Pattern
forall a. a -> [a] -> NonEmpty a
:| [Pattern]
ps
            let lhs :: LHS
lhs = Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS Pattern
p [] []
            Clause -> TCMT IO Clause
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> TCMT IO Clause) -> Clause -> TCMT IO Clause
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 WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere []
  Declaration
scdef <- NiceDeclaration -> ScopeM (AbsOfCon NiceDeclaration)
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' [Clause]
cs] -> do
      ScopeInfo -> TCMT IO ()
setScope ScopeInfo
si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...
      Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$
        ExprInfo -> DefInfo -> Erased -> QName -> List1 Clause -> Expr
A.ExtendedLam (Range -> ExprInfo
ExprRange Range
r) DefInfo
di Erased
e QName
qname' (List1 Clause -> Expr) -> List1 Clause -> Expr
forall a b. (a -> b) -> a -> b
$
        List1 Clause -> [Clause] -> List1 Clause
forall a. List1 a -> [a] -> List1 a
List1.fromListSafe List1 Clause
forall a. HasCallStack => a
__IMPOSSIBLE__ [Clause]
cs
    Declaration
_ -> ScopeM Expr
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Scope check an expression.

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

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

  -- Names
      Ident QName
x -> OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)
      KnownIdent NameKind
_ QName
x -> OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)
      -- Just discard the syntax highlighting information.

  -- 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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> TCMT IO Term -> TCMT IO (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO Term
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 (Maybe Term -> TCMT IO (Maybe Term))
-> TCMT IO (Maybe Term) -> TCMT IO (Maybe Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinFromNat
            TCMT IO (Maybe Term)
builtin TCMT IO (Maybe Term) -> (Maybe Term -> ScopeM Expr) -> ScopeM Expr
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just (I.Def QName
q Elims
_) -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr -> Expr
mkApp QName
q (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Literal -> Expr
A.Lit ExprInfo
i (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
LitNat (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
abs Integer
n
              Maybe Term
_                -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit

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

          Literal
_ -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
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) (NamedArg Expr -> Expr) -> (Expr -> NamedArg Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NamedArg Expr
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
_)) =
          TCMT IO Bool
-> TCMT IO (Maybe Term)
-> TCMT IO (Maybe Term)
-> TCMT IO (Maybe Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (QName -> ScopeInfo -> Bool
isNameInScopeUnqualified QName
q (ScopeInfo -> Bool) -> TCMT IO ScopeInfo -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope) (Maybe Term -> TCMT IO (Maybe Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
v) (Maybe Term -> TCMT IO (Maybe Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing)
        ensureInScope Maybe Term
_ = Maybe Term -> TCMT IO (Maybe Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing

  -- Meta variables
      C.QuestionMark Range
r Maybe Int
n -> do
        ScopeInfo
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
        -- Andreas, 2014-04-06 create interaction point.
        InteractionId
ii <- Bool -> Range -> Maybe Int -> TCMT IO InteractionId
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 = Maybe MetaId
forall a. Maybe a
Nothing
             , metaNameSuggestion :: [Char]
metaNameSuggestion = [Char]
""
             }
        Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
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 <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
        Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ MetaInfo -> Expr
A.Underscore (MetaInfo -> Expr) -> MetaInfo -> Expr
forall a b. (a -> b) -> a -> b
$ MetaInfo
                    { metaRange :: Range
metaRange  = Range
r
                    , metaScope :: ScopeInfo
metaScope  = ScopeInfo
scope
                    , metaNumber :: Maybe MetaId
metaNumber = [Char] -> Maybe MetaId
forall a. HasCallStack => a
__IMPOSSIBLE__ ([Char] -> Maybe MetaId) -> Maybe [Char] -> Maybe MetaId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Char]
n
                    , metaNameSuggestion :: [Char]
metaNameSuggestion = [Char] -> Maybe [Char] -> [Char]
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 -> TCMT IO Expr
parseApplication List2 Expr
es
        Expr -> ScopeM (AbsOfCon Expr)
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 ⦄@.

        -- Raise an error if argument is a C.Dot with Hiding info.
        case NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
e2 of
          C.Dot{} | NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
notVisible NamedArg Expr
e2 -> NamedArg Expr -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Expr
e2 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> TypeError
IllegalHidingInPostfixProjection NamedArg Expr
e2
          Expr
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        let parenPref :: ParenPreference
parenPref = Expr -> ParenPreference
inferParenPreference (NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
e2)
            info :: AppInfo
info = (Range -> AppInfo
defaultAppInfo Range
r) { appOrigin = UserWritten, appParens = parenPref }
        Expr
e1 <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
FunctionCtx Expr
e1
        NamedArg Expr
e2 <- Precedence -> NamedArg Expr -> ScopeM (AbsOfCon (NamedArg Expr))
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx (ParenPreference -> Precedence
ArgumentCtx ParenPreference
parenPref) NamedArg Expr
e2
        Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
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
      C.KnownOpApp NameKind
_ 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  <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
WithFunCtx Expr
e
        [Expr]
es <- (Expr -> ScopeM Expr) -> [Expr] -> TCMT IO [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
WithArgCtx) [Expr]
es
        Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
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
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToHiddenArg Expr
e
      C.InstanceArg Range
_ Named NamedName Expr
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToInstanceArg Expr
e

  -- Lambda
      C.AbsurdLam Range
r Hiding
h -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
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 Arg Expr -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Arg Expr
arg of
              Relevance
Relevant  -> Maybe Relevance
forall a. Maybe a
Nothing
              Relevance
r         -> Relevance -> Maybe Relevance
forall a. a -> Maybe a
Just Relevance
r
        let mh :: Maybe Hiding
mh = case Arg Expr -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg Expr
arg of
              Hiding
NotHidden -> Maybe Hiding
forall a. Maybe a
Nothing
              Hiding
h         -> Hiding -> Maybe Hiding
forall a. a -> Maybe a
Just Hiding
h
        Arg ArgInfo
info (Expr
e1', Relevance
rel, Hiding
hid) <- (Expr -> ScopeM (Expr, Relevance, Hiding))
-> Arg Expr -> TCMT IO (Arg (Expr, Relevance, Hiding))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg 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 -> ArgInfo -> ArgInfo
forall a. a -> a
id
              Relevance
rel      -> Relevance -> ArgInfo -> ArgInfo
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
rel
        let updHid :: ArgInfo -> ArgInfo
updHid = case Hiding
hid of
              Hiding
NotHidden -> ArgInfo -> ArgInfo
forall a. a -> a
id
              Hiding
hid       -> Hiding -> ArgInfo -> ArgInfo
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
hid
        ExprInfo -> Arg Expr -> Expr -> Expr
A.Fun (Range -> ExprInfo
ExprRange Range
r) (ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (ArgInfo -> ArgInfo
updRel (ArgInfo -> ArgInfo) -> ArgInfo -> ArgInfo
forall a b. (a -> b) -> a -> b
$ ArgInfo -> ArgInfo
updHid ArgInfo
info) Expr
e1') (Expr -> Expr) -> ScopeM Expr -> ScopeM Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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
        [(Name, LocalVar)]
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
        Telescope1 -> (AbsOfCon Telescope1 -> ScopeM Expr) -> ScopeM Expr
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract Telescope1
tel ((AbsOfCon Telescope1 -> ScopeM Expr) -> ScopeM Expr)
-> (AbsOfCon Telescope1 -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \AbsOfCon Telescope1
tel -> do
          [(Name, LocalVar)]
lvars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
          [(Name, LocalVar)] -> [(Name, LocalVar)] -> TCMT IO ()
checkNoShadowing [(Name, LocalVar)]
lvars0 [(Name, LocalVar)]
lvars1
          Expr
e <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e
          let info :: ExprInfo
info = Range -> ExprInfo
ExprRange (Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e0)
          Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> [TypedBinding] -> Expr -> Expr
A.mkPi ExprInfo
info (List1 (Maybe TypedBinding) -> [TypedBinding]
forall a. List1 (Maybe a) -> [a]
List1.catMaybes List1 (Maybe TypedBinding)
AbsOfCon Telescope1
tel) Expr
e

  -- Let
      e0 :: Expr
e0@(C.Let Range
_ List1 Declaration
ds (Just Expr
e)) ->
        TCMT IO Bool -> ScopeM Expr -> ScopeM Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM TCMT IO Bool
isInsideDotPattern ([Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM Expr) -> [Char] -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ [Char]
"Let-expressions are not allowed in dot patterns") (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$
        LetDefs -> (AbsOfCon LetDefs -> ScopeM Expr) -> ScopeM Expr
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract (List1 Declaration -> LetDefs
LetDefs List1 Declaration
ds) ((AbsOfCon LetDefs -> ScopeM Expr) -> ScopeM Expr)
-> (AbsOfCon LetDefs -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \AbsOfCon LetDefs
ds' -> do
          Expr
e <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e
          let info :: ExprInfo
info = Range -> ExprInfo
ExprRange (Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e0)
          Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> [LetBinding] -> Expr -> Expr
A.mkLet ExprInfo
info [LetBinding]
AbsOfCon LetDefs
ds' Expr
e
      C.Let Range
_ List1 Declaration
_ TacticAttribute
Nothing -> [Char] -> ScopeM Expr
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' <- Precedence
-> RecordAssignments -> ScopeM (AbsOfCon RecordAssignments)
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'' = (Either Assign (ModuleName, Maybe LetBinding)
 -> Either Assign ModuleName)
-> [Either Assign (ModuleName, Maybe LetBinding)]
-> [Either Assign ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (((ModuleName, Maybe LetBinding) -> ModuleName)
-> Either Assign (ModuleName, Maybe LetBinding)
-> Either Assign ModuleName
forall b d a. (b -> d) -> Either a b -> Either a d
mapRight (ModuleName, Maybe LetBinding) -> ModuleName
forall a b. (a, b) -> a
fst) [Either Assign (ModuleName, Maybe LetBinding)]
fs'
            i :: ExprInfo
i    = Range -> ExprInfo
ExprRange Range
r
        Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
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) (Expr -> Assigns -> Expr)
-> ScopeM Expr -> TCMT IO (Assigns -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e TCMT IO (Assigns -> Expr) -> TCMT IO Assigns -> ScopeM Expr
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence
-> [FieldAssignment] -> ScopeM (AbsOfCon [FieldAssignment])
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx [FieldAssignment]
fs

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

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

  -- Do notation
      C.DoBlock Range
r List1 DoStmt
ss ->
        Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx (Expr -> ScopeM Expr) -> TCMT IO Expr -> ScopeM Expr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Range -> List1 DoStmt -> TCMT IO 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) (Expr -> Expr) -> ScopeM Expr -> ScopeM Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e

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

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

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

      C.Tactic Range
r Expr
e -> [Char] -> ScopeM Expr
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 (Expr -> Expr) -> ScopeM Expr -> ScopeM Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e

  -- forall-generalize
      C.Generalized Expr
e -> do
        (Set QName
s, Expr
e) <- ScopeM Expr -> ScopeM (Set QName, Expr)
forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables (ScopeM Expr -> ScopeM (Set QName, Expr))
-> ScopeM Expr -> ScopeM (Set QName, Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
        Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
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)
    | [Expr] -> Bool
forall a. Null a => a -> Bool
null [Expr]
es Bool -> Bool -> Bool
&& ImportDirective -> Bool
forall n m. ImportDirective' n m -> Bool
isDefaultImportDir ImportDirective
i = (, Maybe LetBinding
forall a. Maybe a
Nothing) (ModuleName -> (ModuleName, Maybe LetBinding))
-> TCMT IO ModuleName -> TCMT IO (ModuleName, Maybe LetBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
m)
    | Bool
otherwise = do
        Name
x <- Range -> NameId -> Name
C.NoName (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
m) (NameId -> Name) -> TCMT IO NameId -> ScopeM Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
        LetBinding
r <- (ModuleInfo
 -> Erased
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> LetBinding)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM LetBinding
forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
 -> Erased
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding
LetApply OpenKind
LetOpenModule
               ((QName, [Expr], ImportDirective) -> Range
forall a. HasRange a => a -> Range
getRange (QName
m, [Expr]
es, ImportDirective
i)) Access
PublicAccess Erased
defaultErased Name
x
               (Range -> Telescope -> Expr -> ModuleApplication
C.SectionApp ((QName, [Expr]) -> Range
forall a. HasRange a => a -> Range
getRange (QName
m , [Expr]
es)) [] (List1 Expr -> Expr
rawApp (QName -> Expr
Ident QName
m Expr -> [Expr] -> List1 Expr
forall a. a -> [a] -> NonEmpty a
:| [Expr]
es)))
               OpenShortHand
DontOpen ImportDirective
i
        case LetBinding
r of
          LetApply ModuleInfo
_ Erased
_ ModuleName
m' ModuleApplication
_ ScopeCopyInfo
_ ImportDirective
_ -> (ModuleName, Maybe LetBinding)
-> TCMT IO (ModuleName, Maybe LetBinding)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m', LetBinding -> Maybe LetBinding
forall a. a -> Maybe a
Just LetBinding
r)
          LetBinding
_ -> TCMT IO (ModuleName, Maybe 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 = (c -> TCMT IO (AbsOfCon c))
-> FieldAssignment' c -> TCMT IO (FieldAssignment' (AbsOfCon c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse c -> TCMT IO (AbsOfCon c)
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 (BoundName -> Name) -> BoundName -> Name
forall a b. (a -> b) -> a -> b
$ NewName BoundName -> BoundName
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 (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
name Bool -> Bool -> Bool
&& Maybe Pattern -> Bool
forall a. Maybe a -> Bool
isJust Maybe Pattern
p) then NewName BoundName -> TCMT IO (NewName BoundName)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewName BoundName
n else do
           Name
n' <- Range -> Int -> [Char] -> ScopeM Name
freshConcreteName (BoundName -> Range
forall a. HasRange a => a -> Range
getRange (BoundName -> Range) -> BoundName -> Range
forall a b. (a -> b) -> a -> b
$ NewName BoundName -> BoundName
forall a. NewName a -> a
newName NewName BoundName
n) Int
0 [Char]
patternInTeleName
           NewName BoundName -> TCMT IO (NewName BoundName)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewName BoundName -> TCMT IO (NewName BoundName))
-> NewName BoundName -> TCMT IO (NewName BoundName)
forall a b. (a -> b) -> a -> b
$ (BoundName -> BoundName) -> NewName BoundName -> NewName BoundName
forall a b. (a -> b) -> NewName a -> NewName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ BoundName
n -> BoundName
n { C.boundName = n' }) NewName BoundName
n
    BindName
n <- NewName BoundName -> ScopeM (AbsOfCon (NewName BoundName))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NewName BoundName
n
    -- Expand puns if optHiddenArgumentPuns is True.
    Bool
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
    Maybe Pattern
p <- Maybe Pattern -> TCMT IO (Maybe Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pattern -> TCMT IO (Maybe Pattern))
-> Maybe Pattern -> TCMT IO (Maybe Pattern)
forall a b. (a -> b) -> a -> b
$ if Bool
puns then KillRangeT Pattern -> Maybe Pattern -> Maybe Pattern
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Maybe Pattern
p else Maybe Pattern
p
    -- Actually parsing the pattern, checking it is linear,
    -- and bind its variables
    Maybe Pattern
p <- (Pattern -> TCMT IO Pattern)
-> Maybe Pattern -> TCMT IO (Maybe Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Pattern -> TCMT IO Pattern
parsePattern Maybe Pattern
p
    Maybe (Pattern' Expr)
p <- Maybe Pattern -> ScopeM (AbsOfCon (Maybe Pattern))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe Pattern
p
    Maybe (Pattern' Expr) -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Maybe (Pattern' Expr)
p (([Name] -> TCMT IO ()) -> TCMT IO ())
-> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \[Name]
ys ->
      TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
    TCMT IO ()
bindVarsToBind
    Maybe Pattern
p <- Maybe (Pattern' Expr) -> ScopeM (AbsOfCon (Maybe (Pattern' Expr)))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe (Pattern' Expr)
p
    Binder' BindName -> TCMT IO (Binder' BindName)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binder' BindName -> TCMT IO (Binder' BindName))
-> Binder' BindName -> TCMT IO (Binder' BindName)
forall a b. (a -> b) -> a -> b
$ Maybe Pattern -> BindName -> Binder' BindName
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 <- (Expr -> ScopeM Expr) -> TacticAttribute -> TCMT IO (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Expr -> ScopeM Expr
Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (TacticAttribute -> TCMT IO (Maybe Expr))
-> TacticAttribute -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ BoundName -> TacticAttribute
bnameTactic (BoundName -> TacticAttribute) -> BoundName -> TacticAttribute
forall a b. (a -> b) -> a -> b
$ Binder -> BoundName
forall a. Binder' a -> a
C.binderName (Binder -> BoundName) -> Binder -> BoundName
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg NamedArg Binder
x
    LamBinding -> Maybe LamBinding
forall a. a -> Maybe a
Just (LamBinding -> Maybe LamBinding)
-> (NamedArg (Binder' BindName) -> LamBinding)
-> NamedArg (Binder' BindName)
-> Maybe LamBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Expr -> NamedArg (Binder' BindName) -> LamBinding
A.DomainFree Maybe Expr
tac (NamedArg (Binder' BindName) -> Maybe LamBinding)
-> TCMT IO (NamedArg (Binder' BindName))
-> TCMT IO (Maybe LamBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedArg (Binder' (NewName BoundName))
-> ScopeM (AbsOfCon (NamedArg (Binder' (NewName BoundName))))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ((Binder -> Binder' (NewName BoundName))
-> NamedArg Binder -> NamedArg (Binder' (NewName BoundName))
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> NewName BoundName)
-> Binder -> Binder' (NewName BoundName)
forall a b. (a -> b) -> Binder' a -> Binder' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BoundName -> NewName BoundName)
 -> Binder -> Binder' (NewName BoundName))
-> (BoundName -> NewName BoundName)
-> Binder
-> Binder' (NewName BoundName)
forall a b. (a -> b) -> a -> b
$ BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
LambdaBound) NamedArg Binder
x)
  toAbstract (C.DomainFull TypedBinding
tb) = (TypedBinding -> LamBinding)
-> Maybe TypedBinding -> Maybe LamBinding
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypedBinding -> LamBinding
A.DomainFull (Maybe TypedBinding -> Maybe LamBinding)
-> TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe LamBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedBinding -> ScopeM (AbsOfCon TypedBinding)
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) = Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding
forall e. Range -> List1 (NamedArg Binder) -> e -> TypedBinding' e
C.TBind Range
r (NamedArg Binder -> List1 (NamedArg Binder)
forall el coll. Singleton el coll => el -> coll
singleton NamedArg Binder
x) (Expr -> TypedBinding) -> Expr -> TypedBinding
forall a b. (a -> b) -> a -> b
$ Range -> Maybe [Char] -> Expr
C.Underscore Range
r Maybe [Char]
forall a. Maybe a
Nothing
  where r :: Range
r = NamedArg Binder -> Range
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' <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
    Maybe Expr
tac <- (Expr -> ScopeM Expr) -> TacticAttribute -> TCMT IO (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Expr -> ScopeM Expr
Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (TacticAttribute -> TCMT IO (Maybe Expr))
-> TacticAttribute -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$
      -- Invariant: all tactics are the same
      -- (distributed in the parser, TODO: don't)
      case (NamedArg Binder -> TacticAttribute)
-> List1 (NamedArg Binder) -> [Expr]
forall a b. (a -> Maybe b) -> List1 a -> [b]
List1.mapMaybe (BoundName -> TacticAttribute
bnameTactic (BoundName -> TacticAttribute)
-> (NamedArg Binder -> BoundName)
-> NamedArg Binder
-> TacticAttribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder -> BoundName
forall a. Binder' a -> a
C.binderName (Binder -> BoundName)
-> (NamedArg Binder -> Binder) -> NamedArg Binder -> BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg) List1 (NamedArg Binder)
xs of
        []      -> TacticAttribute
forall a. Maybe a
Nothing
        Expr
tac : [Expr]
_ -> Expr -> TacticAttribute
forall a. a -> Maybe a
Just Expr
tac

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

    Maybe TypedBinding -> TCMT IO (Maybe TypedBinding)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TypedBinding -> TCMT IO (Maybe TypedBinding))
-> Maybe TypedBinding -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ TypedBinding -> Maybe TypedBinding
forall a. a -> Maybe a
Just (TypedBinding -> Maybe TypedBinding)
-> TypedBinding -> Maybe TypedBinding
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 ([LetBinding] -> Maybe TypedBinding)
-> TCMT IO [LetBinding] -> TCMT IO (Maybe TypedBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetDefs -> ScopeM (AbsOfCon LetDefs)
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
  -> Erased
  -> C.Name
  -> C.Telescope
  -> ScopeM [A.Declaration]
  -> ScopeM A.Declaration
       -- ^ The returned declaration is an 'A.Section'.
scopeCheckNiceModule :: Range
-> Access
-> Erased
-> Name
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO Declaration
scopeCheckNiceModule Range
r Access
p Erased
e 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
-> Erased
-> Name
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO Declaration
scopeCheckNiceModule Range
forall a. Range' a
noRange Access
p Erased
e Name
noName_ [] (ScopeM [Declaration] -> TCMT IO Declaration)
-> ScopeM [Declaration] -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$ Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> TCMT IO Declaration -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Access -> TCMT IO Declaration
scopeCheckNiceModule_ Access
PublicAccess  -- See #4350

  | Bool
otherwise = do
        Access -> TCMT IO Declaration
scopeCheckNiceModule_ Access
p
  where
    -- The actual workhorse:
    scopeCheckNiceModule_ :: Access -> ScopeM A.Declaration
    scopeCheckNiceModule_ :: Access -> TCMT IO 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 Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
name then do
          (NameId
i :: NameId) <- TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
          (Name, Access, Bool) -> TCMT IO (Name, Access, Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> NameId -> Name
C.NoName (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
name) NameId
i, Origin -> Access
PrivateAccess Origin
Inserted, Bool
True)
         else (Name, Access, Bool) -> TCMT IO (Name, Access, Bool)
forall a. a -> TCMT IO a
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 <- NewModuleName -> ScopeM (AbsOfCon NewModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> NewModuleName
NewModuleName Name
name)
      Declaration
d <- (ScopeInfo, Declaration) -> Declaration
forall a b. (a, b) -> b
snd ((ScopeInfo, Declaration) -> Declaration)
-> TCMT IO (ScopeInfo, Declaration) -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Range
-> Erased
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r Erased
e (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)
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
open (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
       TCMT IO ImportDirective -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TCMT IO ImportDirective -> TCMT IO ())
-> TCMT IO ImportDirective -> TCMT IO ()
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 (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
aname) (Name -> QName
C.QName Name
name) (ImportDirective -> TCMT IO ImportDirective)
-> ImportDirective -> TCMT IO ImportDirective
forall a b. (a -> b) -> a -> b
$
          ImportDirective
forall n m. ImportDirective' n m
defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) noRange }
      Declaration -> TCMT IO Declaration
forall a. a -> TCMT IO a
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 = (TypedBinding -> Bool) -> Telescope -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypedBinding -> Bool
forall {e}. TypedBinding' e -> Bool
yesBind
  where
    yesBind :: TypedBinding' e -> Bool
yesBind C.TBind{}     = Bool
False
    yesBind (C.TLet Range
_ List1 Declaration
ds) = (Declaration -> Bool) -> List1 Declaration -> Bool
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) = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes [Declaration]
ds
    yes (C.Abstract Range
_ [Declaration]
ds) = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes [Declaration]
ds
    yes (C.Private Range
_ Origin
_ [Declaration]
ds) = (Declaration -> Bool) -> [Declaration] -> Bool
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 = (b -> TCMT IO ()) -> t b -> TCMT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ b -> TCMT IO ()
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) =
    Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Pattern -> Bool
forall a. Maybe a -> Bool
isJust Maybe Pattern
p) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
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{}    -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypedBinding -> TypeError
IllegalLetInTelescope TypedBinding
tb
    C.TBind Range
_ List1 (NamedArg Binder)
xs Expr
_ -> (NamedArg Binder -> TCMT IO ())
-> List1 (NamedArg Binder) -> TCMT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Binder -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms (Binder -> TCMT IO ())
-> (NamedArg Binder -> Binder) -> NamedArg Binder -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Binder -> Binder
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 -> NamedArg Binder -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms NamedArg Binder
a
    C.DomainFull a
a -> a -> TCMT IO ()
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.
  -> Erased                  -- ^ Is the module erased?
  -> 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
-> Erased
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r Erased
e QName
x ModuleName
qm Telescope
tel ScopeM [Declaration]
checkDs = do
  [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"module" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"checking module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
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 <- TCMT IO (ScopeInfo, Declaration)
-> TCMT IO (ScopeInfo, Declaration)
forall a. ScopeM a -> ScopeM a
withLocalVars (TCMT IO (ScopeInfo, Declaration)
 -> TCMT IO (ScopeInfo, Declaration))
-> TCMT IO (ScopeInfo, Declaration)
-> TCMT IO (ScopeInfo, Declaration)
forall a b. (a -> b) -> a -> b
$ do
    GeneralizeTelescope
tel <- GenTel -> ScopeM (AbsOfCon GenTel)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Telescope -> GenTel
GenTel Telescope
tel)
    ModuleName
-> TCMT IO (ScopeInfo, Declaration)
-> TCMT IO (ScopeInfo, Declaration)
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
qm (TCMT IO (ScopeInfo, Declaration)
 -> TCMT IO (ScopeInfo, Declaration))
-> TCMT IO (ScopeInfo, Declaration)
-> TCMT IO (ScopeInfo, Declaration)
forall a b. (a -> b) -> a -> b
$ do
      -- pushScope m
      -- qm <- getCurrentModule
      [Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"module" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"inside module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
      [Declaration]
ds    <- ScopeM [Declaration]
checkDs
      ScopeInfo
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
      (ScopeInfo, Declaration) -> TCMT IO (ScopeInfo, Declaration)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopeInfo
scope, Range
-> Erased
-> ModuleName
-> GeneralizeTelescope
-> [Declaration]
-> Declaration
A.Section Range
r Erased
e (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 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"after module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
  (ScopeInfo, Declaration) -> TCMT IO (ScopeInfo, Declaration)
forall a. a -> TCMT IO a
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 = (ScopeInfo -> Lens' ScopeInfo ModuleName -> ModuleName
forall o i. o -> Lens' o i -> i
^. (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo ModuleName
scopeCurrent) (ScopeInfo -> ModuleName)
-> (TopLevelInfo -> ScopeInfo) -> TopLevelInfo -> ModuleName
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]
_) -> Declaration
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Declaration
d (ScopeM (AbsOfCon (TopLevel [Declaration]))
 -> ScopeM (AbsOfCon (TopLevel [Declaration])))
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall a b. (a -> b) -> a -> b
$
          [Char] -> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM (AbsOfCon (TopLevel [Declaration])))
-> [Char] -> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall a b. (a -> b) -> a -> b
$ [Char]
"No declarations allowed after top-level module."

        -- Otherwise, proceed.
        ([Declaration]
outsideDecls, [ C.Module Range
r Erased
e QName
m0 Telescope
tel [Declaration]
insideDecls ]) -> do
          -- If the module name is _ compute the name from the file path
          (QName
m, TopLevelModuleName
top) <- if QName -> Bool
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 ((Declaration -> Bool)
 -> [Declaration] -> ([Declaration], [Declaration]))
-> [Declaration]
-> (Declaration -> Bool)
-> ([Declaration], [Declaration])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span [Declaration]
insideDecls ((Declaration -> Bool) -> ([Declaration], [Declaration]))
-> (Declaration -> Bool) -> ([Declaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ \case { C.Module{} -> Bool
False; Declaration
_ -> Bool
True } of
                    ([Declaration]
ds0, (C.Module Range
_ Erased
_ QName
m1 Telescope
_ [Declaration]
_ : [Declaration]
_))
                       | QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m1 RawTopLevelModuleName -> RawTopLevelModuleName -> Bool
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 Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
== Range -> Range
beginningOfFile ([Declaration] -> Range
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.
                         ScopeM [Declaration] -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ScopeM [Declaration]
importPrimitives
                         ScopeM [Declaration] -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScopeM [Declaration] -> TCMT IO ())
-> ScopeM [Declaration] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
outsideDecls)
                         ScopeM [Declaration] -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScopeM [Declaration] -> TCMT IO ())
-> ScopeM [Declaration] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
ds0)
                         -- Fail with a crude error otherwise
                         [Declaration]
-> TCMT IO (QName, TopLevelModuleName)
-> TCMT IO (QName, TopLevelModuleName)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Declaration]
ds0 (TCMT IO (QName, TopLevelModuleName)
 -> TCMT IO (QName, TopLevelModuleName))
-> TCMT IO (QName, TopLevelModuleName)
-> TCMT IO (QName, TopLevelModuleName)
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO (QName, TopLevelModuleName)
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 (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ Range -> Name -> Name
forall a. SetRange a => Range -> a -> a
setRange (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
m0) (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
                              [Char] -> Name
C.simpleName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stringToRawName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
                              AbsolutePath -> [Char]
rootNameModule AbsolutePath
file
                      TopLevelModuleName
top <- RawTopLevelModuleName -> TCM TopLevelModuleName
S.topLevelModuleName
                               (QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m)
                      (QName, TopLevelModuleName) -> TCMT IO (QName, TopLevelModuleName)
forall a. a -> TCMT IO a
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) (TopLevelModuleName -> Maybe TopLevelModuleName
forall a. a -> Maybe a
Just TopLevelModuleName
expectedMName)
                  (QName, TopLevelModuleName) -> TCMT IO (QName, TopLevelModuleName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
m0, TopLevelModuleName
top)
          TopLevelModuleName -> TCMT IO ()
setTopLevelModule TopLevelModuleName
top
          ModuleName
am <- NewModuleQName -> ScopeM (AbsOfCon NewModuleQName)
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 <- Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
outsideDecls)
          (ScopeInfo
insideScope, Declaration
insideDecl) <- Range
-> Erased
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r Erased
e QName
m ModuleName
am Telescope
tel (ScopeM [Declaration] -> TCMT IO (ScopeInfo, Declaration))
-> ScopeM [Declaration] -> TCMT IO (ScopeInfo, Declaration)
forall a b. (a -> b) -> a -> b
$
             Declarations -> ScopeM (AbsOfCon Declarations)
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

          -- While scope-checking the top-level module we might have
          -- encountered several (possibly nested) opaque blocks. We
          -- must now ensure that these have transitively-closed
          -- unfolding sets.
          [Declaration] -> TCMT IO ()
forall (m :: * -> *).
(MonadTCState m, ReadTCState m, MonadFresh OpaqueId m,
 MonadDebug m, MonadTrace m, MonadWarning m, MonadIO m) =>
[Declaration] -> m ()
saturateOpaqueBlocks ([Declaration]
outsideDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [ Declaration
insideDecl ])

          TopLevelInfo -> TCMT IO TopLevelInfo
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TopLevelInfo -> TCMT IO TopLevelInfo)
-> TopLevelInfo -> TCMT IO TopLevelInfo
forall a b. (a -> b) -> a -> b
$ [Declaration] -> ScopeInfo -> TopLevelInfo
TopLevelInfo ([Declaration]
primitiveImport [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
outsideDecls [Declaration] -> [Declaration] -> [Declaration]
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])
_ -> TCMT IO TopLevelInfo
ScopeM (AbsOfCon (TopLevel [Declaration]))
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Declaration @open import Agda.Primitive using (Set)@ when 'optImportSorts'.
--   @Prop@ is added when 'optProp', and @SSet@ when 'optTwoLevel'.
importPrimitives :: ScopeM [A.Declaration]
importPrimitives :: ScopeM [Declaration]
importPrimitives = do
  TCMT IO Bool
-> ScopeM [Declaration]
-> ScopeM [Declaration]
-> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (PragmaOptions -> Bool
optImportSorts (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) ([Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) {- else -} do
    Bool
prop     <- PragmaOptions -> Bool
optProp     (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
    Bool
twoLevel <- PragmaOptions -> Bool
optTwoLevel (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
    -- Add implicit `open import Agda.Primitive using (Prop; Set; SSet)`
    let agdaPrimitiveName :: QName
agdaPrimitiveName   = Name -> QName -> QName
Qual ([Char] -> Name
C.simpleName [Char]
"Agda") (QName -> QName) -> QName -> QName
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
C.simpleName [Char]
"Primitive"
        usingDirective :: [ImportedName' Name Name]
usingDirective      = ([Char] -> ImportedName' Name Name)
-> [[Char]] -> [ImportedName' Name Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ImportedName' Name Name
forall n m. n -> ImportedName' n m
ImportedName (Name -> ImportedName' Name Name)
-> ([Char] -> Name) -> [Char] -> ImportedName' Name Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
C.simpleName) ([[Char]] -> [ImportedName' Name Name])
-> [[Char]] -> [ImportedName' Name Name]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [ [Char]
"Prop" | Bool
prop     ]
          , [ [Char]
"Set"  | Bool
True     ]
          , [ [Char]
"SSet" | Bool
twoLevel ]
          ]
        directives :: ImportDirective
directives          = Range
-> Using' Name Name
-> [ImportedName' Name Name]
-> [Renaming' Name Name]
-> Maybe Range
-> ImportDirective
forall n m.
Range
-> Using' n m
-> HidingDirective' n m
-> RenamingDirective' n m
-> Maybe Range
-> ImportDirective' n m
ImportDirective Range
forall a. Range' a
noRange ([ImportedName' Name Name] -> Using' Name Name
forall n m. [ImportedName' n m] -> Using' n m
Using [ImportedName' Name Name]
usingDirective) [] [] Maybe Range
forall a. Maybe a
Nothing
        importAgdaPrimitive :: [Declaration]
importAgdaPrimitive = [Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> Declaration
C.Import Range
forall a. Range' a
noRange QName
agdaPrimitiveName Maybe AsName
forall a. Maybe a
Nothing OpenShortHand
C.DoOpen ImportDirective
directives]
    Declarations -> ScopeM (AbsOfCon Declarations)
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 = [Declaration] -> ScopeM a -> ScopeM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Declaration]
ds (ScopeM a -> ScopeM a) -> ScopeM a -> ScopeM a
forall a b. (a -> b) -> a -> b
$ DoWarn -> [Declaration] -> ScopeM a -> ScopeM a
forall a. DoWarn -> [Declaration] -> ScopeM a -> ScopeM a
computeFixitiesAndPolarities DoWarn
warn [Declaration]
ds (ScopeM a -> ScopeM a) -> ScopeM a -> ScopeM a
forall a b. (a -> b) -> a -> b
$ do
  Fixities
fixs <- Lens' ScopeInfo Fixities -> TCMT IO Fixities
forall (m :: * -> *) a. ReadTCState m => Lens' ScopeInfo a -> m a
useScope (Fixities -> f Fixities) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo Fixities
scopeFixities  -- We need to pass the fixities to the nicifier for clause grouping
  let (Either DeclarationException [NiceDeclaration]
result, NiceWarnings
warns') = Nice [NiceDeclaration]
-> (Either DeclarationException [NiceDeclaration], NiceWarnings)
forall a. Nice a -> (Either DeclarationException a, NiceWarnings)
runNice (Nice [NiceDeclaration]
 -> (Either DeclarationException [NiceDeclaration], NiceWarnings))
-> Nice [NiceDeclaration]
-> (Either DeclarationException [NiceDeclaration], NiceWarnings)
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    <- PragmaOptions -> Bool
forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  Bool
isBuiltin <- [Char] -> TCMT IO Bool
forall (m :: * -> *). MonadIO m => [Char] -> m Bool
Lens.isBuiltinModule ([Char] -> TCMT IO Bool)
-> (AbsolutePath -> [Char]) -> AbsolutePath -> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> [Char]
filePath (AbsolutePath -> TCMT IO Bool)
-> TCMT IO AbsolutePath -> TCMT IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO AbsolutePath
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 (DeclarationWarning -> Bool) -> NiceWarnings -> NiceWarnings
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@.
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DoWarn
warn DoWarn -> DoWarn -> Bool
forall a. Eq a => a -> a -> Bool
== DoWarn
NoWarn Bool -> Bool -> Bool
|| NiceWarnings -> Bool
forall a. Null a => a -> Bool
null NiceWarnings
warns) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
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
    Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSafe (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
      let (NiceWarnings
errs, NiceWarnings
ws) = (DeclarationWarning -> Bool)
-> NiceWarnings -> (NiceWarnings, NiceWarnings)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition DeclarationWarning -> Bool
unsafeDeclarationWarning NiceWarnings
warns
      -- If some of them are, we fail
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NiceWarnings -> Bool
forall a. Null a => a -> Bool
null NiceWarnings
errs) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
        [Warning] -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
[Warning] -> m ()
warnings ([Warning] -> TCMT IO ()) -> [Warning] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue (DeclarationWarning -> Warning) -> NiceWarnings -> [Warning]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NiceWarnings
ws
        [TCWarning]
tcerrs <- (Warning -> TCMT IO TCWarning) -> [Warning] -> TCMT IO [TCWarning]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Warning -> TCMT IO TCWarning
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m TCWarning
warning_ ([Warning] -> TCMT IO [TCWarning])
-> [Warning] -> TCMT IO [TCWarning]
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue (DeclarationWarning -> Warning) -> NiceWarnings -> [Warning]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NiceWarnings
errs
        NiceWarnings -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NiceWarnings
errs (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCWarning] -> TypeError
NonFatalErrors [TCWarning]
tcerrs
    -- Otherwise we simply record the warnings
    (DeclarationWarning -> TCMT IO ()) -> NiceWarnings -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ DeclarationWarning
w -> CallStack -> Warning -> TCMT IO ()
forall (m :: * -> *).
MonadWarning m =>
CallStack -> Warning -> m ()
warning' (DeclarationWarning -> CallStack
dwLocation DeclarationWarning
w) (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
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
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"error" Int
2 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error raised at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallStack -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow CallStack
loc
      TCErr -> ScopeM a
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TCErr -> ScopeM a) -> TCErr -> ScopeM a
forall a b. (a -> b) -> a -> b
$ Range -> Doc -> TCErr
Exception (DeclarationException' -> Range
forall a. HasRange a => a -> Range
getRange DeclarationException'
e) (Doc -> TCErr) -> Doc -> TCErr
forall a b. (a -> b) -> a -> b
$ DeclarationException' -> Doc
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_ WarningName -> WarningName -> Bool
forall a. Eq a => a -> a -> Bool
/=) (WarningName -> Bool)
-> (DeclarationWarning -> WarningName)
-> DeclarationWarning
-> 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 <- TCMT IO Bool
-> TCMT IO [Declaration]
-> TCMT IO [Declaration]
-> TCMT IO [Declaration]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PragmaOptions -> Bool
forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions)
               {- then -} ((Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds)
               {- else -} ([Declaration] -> TCMT IO [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds)

    DoWarn
-> [Declaration]
-> ([NiceDeclaration] -> ScopeM [Declaration])
-> ScopeM [Declaration]
forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn [Declaration]
ds [NiceDeclaration] -> ScopeM [Declaration]
[NiceDeclaration] -> ScopeM (AbsOfCon [NiceDeclaration])
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 -> TCMT IO Declaration
noUnsafePragma = \case
       C.Pragma Pragma
pr                 -> Pragma -> TCMT IO 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 ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.Record Range
r Erased
er Name
n RecordDirectives
dir [LamBinding' TypedBinding]
lams Expr
e [Declaration]
ds
                                   -> Range
-> Erased
-> Name
-> RecordDirectives
-> [LamBinding' TypedBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Erased
er Name
n RecordDirectives
dir [LamBinding' TypedBinding]
lams Expr
e ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                      (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.Mutual Range
r [Declaration]
ds               -> Range -> [Declaration] -> Declaration
C.Mutual Range
r ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.Abstract Range
r [Declaration]
ds             -> Range -> [Declaration] -> Declaration
C.Abstract Range
r ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.Private Range
r Origin
o [Declaration]
ds            -> Range -> Origin -> [Declaration] -> Declaration
C.Private Range
r Origin
o ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.InstanceB Range
r [Declaration]
ds            -> Range -> [Declaration] -> Declaration
C.InstanceB Range
r ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.Macro Range
r [Declaration]
ds                -> Range -> [Declaration] -> Declaration
C.Macro Range
r ([Declaration] -> Declaration)
-> TCMT IO [Declaration] -> TCMT IO Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> TCMT IO Declaration)
-> [Declaration] -> TCMT IO [Declaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       Declaration
d -> Declaration -> TCMT IO Declaration
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration
d

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

     unsafePragma :: C.Pragma -> Maybe Warning
     unsafePragma :: Pragma -> Maybe Warning
unsafePragma = \case
       C.NoCoverageCheckPragma{}    -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagNoCoverageCheck
       C.NoPositivityCheckPragma{}  -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagNoPositivityCheck
       C.PolarityPragma{}           -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagPolarity
       C.NoUniverseCheckPragma{}    -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagNoUniverseCheck
       C.InjectivePragma{}          -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagInjective
       C.TerminationCheckPragma Range
_ TerminationCheck
m -> case TerminationCheck
m of
         TerminationCheck
NonTerminating       -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagNonTerminating
         TerminationCheck
Terminating          -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagTerminating
         TerminationCheck
TerminationCheck     -> Maybe Warning
forall a. Maybe a
Nothing
         TerminationMeasure{} -> Maybe Warning
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 -> Maybe Warning
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{}    -> Maybe Warning
forall a. Maybe a
Nothing
       C.BuiltinPragma{}    -> Maybe Warning
forall a. Maybe a
Nothing
       C.ForeignPragma{}    -> Maybe Warning
forall a. Maybe a
Nothing
       C.StaticPragma{}     -> Maybe Warning
forall a. Maybe a
Nothing
       C.InlinePragma{}     -> Maybe Warning
forall a. Maybe a
Nothing
       C.ImpossiblePragma{} -> Maybe Warning
forall a. Maybe a
Nothing
       C.EtaPragma{}        -> Warning -> Maybe Warning
forall a. a -> Maybe a
Just Warning
SafeFlagEta
       C.WarningOnUsage{}   -> Maybe Warning
forall a. Maybe a
Nothing
       C.WarningOnImport{}  -> Maybe Warning
forall a. Maybe a
Nothing
       C.DisplayPragma{}    -> Maybe Warning
forall a. Maybe a
Nothing
       C.CatchallPragma{}   -> Maybe Warning
forall a. Maybe a
Nothing
       -- @RewritePragma@ already requires --rewriting which is incompatible with --safe
       C.RewritePragma{}    -> Maybe Warning
forall a. Maybe a
Nothing
       -- @CompilePragma@ already handled in the nicifier
       C.CompilePragma{}    -> Maybe Warning
forall a. Maybe a
Nothing
       C.NotProjectionLikePragma{} -> Maybe Warning
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) =
    [List1 LetBinding] -> [LetBinding]
forall a. [List1 a] -> [a]
List1.concat ([List1 LetBinding] -> [LetBinding])
-> TCMT IO [List1 LetBinding] -> TCMT IO [LetBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DoWarn
-> [Declaration]
-> ([NiceDeclaration] -> TCMT IO [List1 LetBinding])
-> TCMT IO [List1 LetBinding]
forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn (List1 Declaration -> [Item (List1 Declaration)]
forall l. IsList l => l -> [Item l]
List1.toList List1 Declaration
ds) ([LetDef] -> TCMT IO [List1 LetBinding]
[LetDef] -> ScopeM (AbsOfCon [LetDef])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([LetDef] -> TCMT IO [List1 LetBinding])
-> ([NiceDeclaration] -> [LetDef])
-> [NiceDeclaration]
-> TCMT IO [List1 LetBinding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NiceDeclaration -> LetDef) -> [NiceDeclaration] -> [LetDef]
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  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsAbstract
abstract IsAbstract -> IsAbstract -> Bool
forall a. Eq a => a -> a -> Bool
== IsAbstract
AbstractDef) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
                [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"`abstract` not allowed in let expressions"
              Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsMacro
macro IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
                [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Macros cannot be defined in a let expression"
              Expr
t <- Expr -> ScopeM (AbsOfCon Expr)
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 (BindName -> Name) -> TCMT IO BindName -> ScopeM Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NewName BoundName -> ScopeM (AbsOfCon (NewName BoundName))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
LetBound (BoundName -> NewName BoundName) -> BoundName -> NewName BoundName
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
_  -> ArgInfo -> ArgInfo
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).
              List1 LetBinding -> TCMT IO (List1 LetBinding)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List1 LetBinding -> TCMT IO (List1 LetBinding))
-> List1 LetBinding -> TCMT IO (List1 LetBinding)
forall a b. (a -> b) -> a -> b
$ BindName -> LetBinding
A.LetDeclaredVariable (Name -> BindName
A.mkBindName (Range -> Name -> Name
forall a. SetRange a => Range -> a -> a
setRange (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
x') Name
x)) LetBinding -> [LetBinding] -> List1 LetBinding
forall a. a -> [a] -> NonEmpty a
:|
                     [ LetInfo -> ArgInfo -> BindName -> Expr -> Expr -> LetBinding
A.LetBind (Range -> LetInfo
LetRange (Range -> LetInfo) -> Range -> LetInfo
forall a b. (a -> b) -> a -> b
$ [NiceDeclaration] -> Range
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 -> TCMT IO Expr
letBindingMustHaveRHS RHS' Expr
rhs0
        -- Expand puns if optHiddenArgumentPuns is True.
        Bool
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
        Pattern
p0   <- Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ if Bool
puns then KillRangeT Pattern
expandPuns Pattern
p0 else Pattern
p0
        Either TCErr Pattern
mp   <- Pattern
-> TCMT IO (Either TCErr Pattern) -> TCMT IO (Either TCErr Pattern)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pattern
p0 (TCMT IO (Either TCErr Pattern) -> TCMT IO (Either TCErr Pattern))
-> TCMT IO (Either TCErr Pattern) -> TCMT IO (Either TCErr Pattern)
forall a b. (a -> b) -> a -> b
$
                  (Pattern -> Either TCErr Pattern
forall a b. b -> Either a b
Right (Pattern -> Either TCErr Pattern)
-> TCMT IO Pattern -> TCMT IO (Either TCErr Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> TCMT IO Pattern
parsePattern Pattern
p0)
                    TCMT IO (Either TCErr Pattern)
-> (TCErr -> TCMT IO (Either TCErr Pattern))
-> TCMT IO (Either TCErr Pattern)
forall a. TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
                  (Either TCErr Pattern -> TCMT IO (Either TCErr Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TCErr Pattern -> TCMT IO (Either TCErr Pattern))
-> (TCErr -> Either TCErr Pattern)
-> TCErr
-> TCMT IO (Either TCErr Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCErr -> Either TCErr Pattern
forall a b. a -> Either a b
Left)
        case Either TCErr Pattern
mp of
          Right Pattern
p -> do
            Expr
rhs <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
            Pattern -> TCMT IO (List1 LetBinding) -> TCMT IO (List1 LetBinding)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pattern
p0 (TCMT IO (List1 LetBinding) -> TCMT IO (List1 LetBinding))
-> TCMT IO (List1 LetBinding) -> TCMT IO (List1 LetBinding)
forall a b. (a -> b) -> a -> b
$ do
              Pattern' Expr
p   <- Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
              Pattern' Expr -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' Expr
p
              Pattern' Expr -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p (([Name] -> TCMT IO ()) -> TCMT IO ())
-> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \[Name]
ys ->
                TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
              TCMT IO ()
bindVarsToBind
              Pattern
p   <- Pattern' Expr -> ScopeM (AbsOfCon (Pattern' Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern' Expr
p
              List1 LetBinding -> TCMT IO (List1 LetBinding)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List1 LetBinding -> TCMT IO (List1 LetBinding))
-> List1 LetBinding -> TCMT IO (List1 LetBinding)
forall a b. (a -> b) -> a -> b
$ LetBinding -> List1 LetBinding
forall el coll. Singleton el coll => el -> coll
singleton (LetBinding -> List1 LetBinding) -> LetBinding -> List1 LetBinding
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 -> TCErr -> TCMT IO (List1 LetBinding)
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
              Just Name
x  -> LetDef -> ScopeM (AbsOfCon LetDef)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (LetDef -> ScopeM (AbsOfCon LetDef))
-> LetDef -> ScopeM (AbsOfCon LetDef)
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> LetDef
LetDef (NiceDeclaration -> LetDef) -> NiceDeclaration -> 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 (Origin -> ArgInfo -> ArgInfo
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted ArgInfo
defaultArgInfo) TerminationCheck
tc CoverageCheck
cc Name
x (Range -> Maybe [Char] -> Expr
C.Underscore (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Maybe [Char]
forall a. Maybe a
Nothing)
                , Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
C.FunDef Range
r [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__ IsAbstract
ConcreteDef IsInstance
NotInstanceDef TerminationCheck
forall a. HasCallStack => a
__IMPOSSIBLE__ CoverageCheck
forall a. HasCallStack => a
__IMPOSSIBLE__ Name
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 (Expr -> RHS' Expr
forall e. e -> RHS' e
C.RHS Expr
rhs) WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere []]
                ]
            where
              definedName :: Pattern -> Maybe Name
definedName (C.IdentP Bool
_ (C.QName Name
x)) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x
              definedName C.IdentP{}             = Maybe Name
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{}              = Maybe Name
forall a. Maybe a
Nothing   -- for instance let _ + x = x in ... (not allowed)
              definedName C.AbsurdP{}            = Maybe Name
forall a. Maybe a
Nothing
              definedName C.AsP{}                = Maybe Name
forall a. Maybe a
Nothing
              definedName C.DotP{}               = Maybe Name
forall a. Maybe a
Nothing
              definedName C.EqualP{}             = Maybe Name
forall a. Maybe a
Nothing
              definedName C.LitP{}               = Maybe Name
forall a. Maybe a
Nothing
              definedName C.RecP{}               = Maybe Name
forall a. Maybe a
Nothing
              definedName C.QuoteP{}             = Maybe Name
forall a. Maybe a
Nothing
              definedName C.HiddenP{}            = Maybe Name
forall a. Maybe a
Nothing -- Not impossible, see issue #2291
              definedName C.InstanceP{}          = Maybe Name
forall a. Maybe a
Nothing
              definedName C.WithP{}              = Maybe Name
forall a. Maybe a
Nothing
              definedName C.AppP{}               = Maybe Name
forall a. Maybe a
Nothing -- Not impossible, see issue #4586
              definedName C.OpAppP{}             = Maybe Name
forall a. HasCallStack => a
__IMPOSSIBLE__
              definedName C.EllipsisP{}          = Maybe Name
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
        Maybe Range -> (Range -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe Range
forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
dirs) ((Range -> TCMT IO ()) -> TCMT IO ())
-> (Range -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \Range
r -> Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
        ModuleName
m    <- OldModuleName -> ScopeM (AbsOfCon OldModuleName)
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 = Maybe Name
forall a. Maybe a
Nothing
              , minfoAsTo :: Range
minfoAsTo   = ImportDirective -> Range
renamingRange ImportDirective
dirs
              , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = Maybe OpenShortHand
forall a. Maybe a
Nothing
              , minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dirs
              }
        List1 LetBinding -> TCMT IO (List1 LetBinding)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List1 LetBinding -> TCMT IO (List1 LetBinding))
-> List1 LetBinding -> TCMT IO (List1 LetBinding)
forall a b. (a -> b) -> a -> b
$ LetBinding -> List1 LetBinding
forall el coll. Singleton el coll => el -> coll
singleton (LetBinding -> List1 LetBinding) -> LetBinding -> List1 LetBinding
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModuleName -> ImportDirective -> LetBinding
A.LetOpen ModuleInfo
minfo ModuleName
m ImportDirective
adir

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

      NiceDeclaration
_   -> NiceDeclaration -> TCMT IO (List1 LetBinding)
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 -> TCMT IO Expr
letBindingMustHaveRHS RHS' Expr
rhs0
            (QName
x, [NamedArg Pattern]
args) <- do
              LHSCore
res <- Pattern -> TCMT IO LHSCore -> TCMT IO LHSCore
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Pattern
p (TCMT IO LHSCore -> TCMT IO LHSCore)
-> TCMT IO LHSCore -> TCMT IO LHSCore
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 -> (QName, [NamedArg Pattern]) -> TCMT IO (QName, [NamedArg Pattern])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, [NamedArg Pattern]
args)
                C.LHSProj{} -> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (QName, [NamedArg Pattern]))
-> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall a b. (a -> b) -> a -> b
$ [Char]
"Copatterns not allowed in let bindings"
                C.LHSWith{} -> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (QName, [NamedArg Pattern]))
-> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall a b. (a -> b) -> a -> b
$ [Char]
"`with` patterns not allowed in let bindings"
                C.LHSEllipsis{} -> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"`...` not allowed in let bindings"

            Expr
e <- [NamedArg Pattern]
-> (AbsOfCon [NamedArg Pattern] -> ScopeM Expr) -> ScopeM Expr
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract [NamedArg Pattern]
args ((AbsOfCon [NamedArg Pattern] -> ScopeM Expr) -> ScopeM Expr)
-> (AbsOfCon [NamedArg Pattern] -> ScopeM Expr) -> ScopeM Expr
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 <- Name -> ScopeM Expr -> ScopeM Expr
forall a. Name -> ScopeM a -> ScopeM a
unbindVariable Name
top (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
                (Expr -> Arg (Named NamedName (Pattern' Expr)) -> ScopeM Expr)
-> Expr -> [Arg (Named NamedName (Pattern' Expr))] -> ScopeM Expr
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 ([Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall a. [a] -> [a]
reverse [Arg (Named NamedName (Pattern' Expr))]
AbsOfCon [NamedArg Pattern]
args)  -- just reverse because these are DomainFree
            (QName, Expr) -> TCMT IO (QName, Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, Expr
e)
        letToAbstract Clause
_ = NiceDeclaration -> TCMT IO (QName, Expr)
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))) =
                Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> LamBinding -> Expr -> Expr
A.Lam ExprInfo
i (NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree (NamedArg (Binder' BindName) -> LamBinding)
-> NamedArg (Binder' BindName) -> LamBinding
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Binder' BindName -> NamedArg (Binder' BindName)
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info (Binder' BindName -> NamedArg (Binder' BindName))
-> Binder' BindName -> NamedArg (Binder' BindName)
forall a b. (a -> b) -> a -> b
$ BindName -> Binder' BindName
forall a. a -> Binder' a
A.mkBinder BindName
x) Expr
e
            where i :: ExprInfo
i = Range -> ExprInfo
ExprRange (BindName -> Expr -> Range
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 <- Range -> ScopeM Name
forall (m :: * -> *). MonadFresh NameId m => Range -> m Name
freshNoName (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i)
                Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> LamBinding -> Expr -> Expr
A.Lam ExprInfo
i' (NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree (NamedArg (Binder' BindName) -> LamBinding)
-> NamedArg (Binder' BindName) -> LamBinding
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Binder' BindName -> NamedArg (Binder' BindName)
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info (Binder' BindName -> NamedArg (Binder' BindName))
-> Binder' BindName -> NamedArg (Binder' BindName)
forall a b. (a -> b) -> a -> b
$ Name -> Binder' BindName
A.mkBinder_ Name
x) Expr
e
            where i' :: ExprInfo
i' = Range -> ExprInfo
ExprRange (PatInfo -> Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange PatInfo
i Expr
e)
        lambda Expr
_ Arg (Named NamedName (Pattern' Expr))
_ = NiceDeclaration -> ScopeM 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 -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          WhereClause' [Declaration]
wh -> WhereClause' [Declaration] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange WhereClause' [Declaration]
wh (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"`where` clauses not allowed in let bindings"
        letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr
        letBindingMustHaveRHS :: RHS' Expr -> TCMT IO Expr
letBindingMustHaveRHS = \case
          C.RHS Expr
e -> Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
          RHS' Expr
C.AbsurdRHS -> [Char] -> TCMT IO Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO Expr) -> [Char] -> TCMT IO Expr
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        -> (NamedArg (Pattern' e) -> TCMT IO ()) -> NAPs e -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern (Pattern' e -> TCMT IO ())
-> (NamedArg (Pattern' e) -> Pattern' e)
-> NamedArg (Pattern' e)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Pattern' e) -> Pattern' e
forall a. NamedArg a -> a
namedArg) NAPs e
ps
            A.ProjP{}            -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.DefP{}             -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.WildP{}            -> TCMT IO ()
yes
            A.AsP PatInfo
_ BindName
_ Pattern' e
p          -> Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' e
p
            A.DotP{}             -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.AbsurdP{}          -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.LitP{}             -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.PatternSynP PatInfo
_ AmbiguousQName
_ NAPs e
ps -> (NamedArg (Pattern' e) -> TCMT IO ()) -> NAPs e -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern (Pattern' e -> TCMT IO ())
-> (NamedArg (Pattern' e) -> Pattern' e)
-> NamedArg (Pattern' e)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Pattern' e) -> Pattern' e
forall a. NamedArg a -> a
namedArg) NAPs e
ps
            A.RecP PatInfo
_ [FieldAssignment' (Pattern' e)]
fs          -> (FieldAssignment' (Pattern' e) -> TCMT IO ())
-> [FieldAssignment' (Pattern' e)] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern (Pattern' e -> TCMT IO ())
-> (FieldAssignment' (Pattern' e) -> Pattern' e)
-> FieldAssignment' (Pattern' e)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldAssignment' (Pattern' e) -> Pattern' e
forall a. FieldAssignment' a -> a
_exprFieldA) [FieldAssignment' (Pattern' e)]
fs
            A.EqualP{}           -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.WithP{}            -> TCMT IO ()
forall {a}. TCMT IO a
no
            A.AnnP PatInfo
_ e
_ Pattern' e
p         -> Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' e
p
          where
          yes :: TCMT IO ()
yes = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          no :: TCMT IO a
no  = [Char] -> TCMT IO a
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 = ScopeM [Declaration] -> TCMT IO Declaration
forall (m :: * -> *).
ReadTCState m =>
m [Declaration] -> m Declaration
annotateDecls (ScopeM [Declaration] -> TCMT IO Declaration)
-> ScopeM [Declaration] -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$
    [Char]
-> Int -> [[Char]] -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
[Char] -> Int -> a -> m c -> m c
forall (m :: * -> *) c.
MonadDebug m =>
[Char] -> Int -> [[Char]] -> m c -> m c
traceS [Char]
"scope.decl.trace" Int
50
      [ [Char]
"scope checking declaration"
      , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  NiceDeclaration -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow NiceDeclaration
d
      ] (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
    [Char]
-> Int -> [[Char]] -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
[Char] -> Int -> a -> m c -> m c
forall (m :: * -> *) c.
MonadDebug m =>
[Char] -> Int -> [[Char]] -> 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]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  NiceDeclaration -> [Char]
forall a. Show a => a -> [Char]
show NiceDeclaration
d
      ] (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
    Call -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (NiceDeclaration -> Call
ScopeCheckDeclaration NiceDeclaration
d) (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
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.
    Maybe IsAbstract
-> (ScopeM [Declaration] -> ScopeM [Declaration])
-> (IsAbstract -> ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration]
-> ScopeM [Declaration]
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (NiceDeclaration -> Maybe IsAbstract
niceHasAbstract NiceDeclaration
d) ScopeM [Declaration] -> ScopeM [Declaration]
forall a. a -> a
id (\ IsAbstract
a -> (TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC ((TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration])
-> (TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ \ TCEnv
e -> TCEnv
e { envAbstractMode = aDefToMode a }) (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
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
      TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((CommandLineOptions -> Bool
forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode (CommandLineOptions -> Bool)
-> TCMT IO CommandLineOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions) TCMT IO Bool -> TCMT IO Bool -> TCMT IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M`
             (Bool -> Bool
not (Bool -> Bool) -> TCMT IO Bool -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> TCMT IO Bool
forall (m :: * -> *). MonadIO m => [Char] -> m Bool
Lens.isBuiltinModuleWithSafePostulates ([Char] -> TCMT IO Bool)
-> (AbsolutePath -> [Char]) -> AbsolutePath -> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> [Char]
filePath (AbsolutePath -> TCMT IO Bool)
-> TCMT IO AbsolutePath -> TCMT IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO AbsolutePath
forall (m :: * -> *). MonadTCEnv m => m AbsolutePath
getCurrentPath)))
            (Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> Warning
SafeFlagPostulate Name
x)
      -- check the postulate
      Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> TCMT IO Declaration -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfName -> NiceDeclaration -> TCMT IO Declaration
toAbstractNiceAxiom KindOfName
AxiomName NiceDeclaration
d

    C.NiceGeneralize Range
r Access
p ArgInfo
i TacticAttribute
tac Name
x Expr
t -> do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.decl" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"found nice generalize: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      Maybe Expr
tac <- (Expr -> ScopeM Expr) -> TacticAttribute -> TCMT IO (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
      Expr
t_ <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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_
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.decl" Int
50 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"generalizations: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([QName], Expr) -> [Char]
forall a. Show a => a -> [Char]
show (Set QName -> [QName]
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 = (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' Any
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
ConcreteDef Range
r) { defTactic = tac }
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Access
p Access -> Access -> Bool
forall a. Eq a => a -> a -> Bool
== Access
PublicAccess) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
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 Maybe [Char]
forall a. Maybe a
Nothing
          maskIP Expr
e                     = Expr
e
      Maybe Expr
tac <- (Expr -> ScopeM Expr) -> TacticAttribute -> TCMT IO (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
      Arg Expr
t' <- Precedence -> Arg Expr -> ScopeM (AbsOfCon (Arg Expr))
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx (Arg Expr -> ScopeM (AbsOfCon (Arg Expr)))
-> Arg Expr -> ScopeM (AbsOfCon (Arg Expr))
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> Arg Expr -> Arg Expr
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 = (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' Any
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 = tac }
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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' <- (Expr -> ScopeM Expr) -> Arg Expr -> TCMT IO (Arg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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
      QName -> TCMT IO ()
unfoldFunction QName
y
      DefInfo
di <- DefInfo -> ScopeM DefInfo
updateDefInfoOpacity (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
a Range
r)
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> Arg Expr -> Declaration
A.Primitive DefInfo
di QName
y Arg Expr
t' ]

  -- Definitions (possibly mutual)
    NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds -> do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.mutual" Int
20 ([Char]
"starting checking mutual definitions: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [NiceDeclaration] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [NiceDeclaration]
ds)
      [Declaration]
ds' <- [NiceDeclaration] -> ScopeM (AbsOfCon [NiceDeclaration])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NiceDeclaration]
ds
      [Char] -> Int -> [Char] -> TCMT IO ()
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.
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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 Erased
er Access
p IsAbstract
a PositivityCheck
_pc UniverseCheck
_uc Name
x [LamBinding' TypedBinding]
ls Expr
t -> do
      [LamBinding' TypedBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
ls
      ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
        (GeneralizeTelescope
ls', Expr
_) <- ScopeM (GeneralizeTelescope, Expr)
-> ScopeM (GeneralizeTelescope, Expr)
forall a. ScopeM a -> ScopeM a
withCheckNoShadowing (ScopeM (GeneralizeTelescope, Expr)
 -> ScopeM (GeneralizeTelescope, Expr))
-> ScopeM (GeneralizeTelescope, Expr)
-> ScopeM (GeneralizeTelescope, Expr)
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.
          GenTelAndType -> ScopeM (AbsOfCon GenTelAndType)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Telescope -> Expr -> GenTelAndType
GenTelAndType ((LamBinding' TypedBinding -> TypedBinding)
-> [LamBinding' TypedBinding] -> Telescope
forall a b. (a -> b) -> [a] -> [b]
map LamBinding' TypedBinding -> TypedBinding
makeDomainFull [LamBinding' TypedBinding]
ls) Expr
t)
        Expr
t' <- Expr -> ScopeM (AbsOfCon Expr)
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 (Map QName Name -> NameMetadata) -> Map QName Name -> NameMetadata
forall a b. (a -> b) -> a -> b
$ GeneralizeTelescope -> Map QName Name
generalizeTelVars GeneralizeTelescope
ls') Name
x QName
x'
        [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> Erased -> QName -> GeneralizeTelescope -> Expr -> Declaration
A.RecSig (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
a Range
r) Erased
er QName
x' GeneralizeTelescope
ls' Expr
t' ]

    C.NiceDataSig Range
r Erased
er Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding' TypedBinding]
ls Expr
t -> do
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.data.sig" Int
20 ([Char]
"checking DataSig for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
        [LamBinding' TypedBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
ls
        ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
          GeneralizeTelescope
ls' <- TCMT IO GeneralizeTelescope -> TCMT IO GeneralizeTelescope
forall a. ScopeM a -> ScopeM a
withCheckNoShadowing (TCMT IO GeneralizeTelescope -> TCMT IO GeneralizeTelescope)
-> TCMT IO GeneralizeTelescope -> TCMT IO GeneralizeTelescope
forall a b. (a -> b) -> a -> b
$
            GenTel -> ScopeM (AbsOfCon GenTel)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (GenTel -> ScopeM (AbsOfCon GenTel))
-> GenTel -> ScopeM (AbsOfCon GenTel)
forall a b. (a -> b) -> a -> b
$ Telescope -> GenTel
GenTel (Telescope -> GenTel) -> Telescope -> GenTel
forall a b. (a -> b) -> a -> b
$ (LamBinding' TypedBinding -> TypedBinding)
-> [LamBinding' TypedBinding] -> Telescope
forall a b. (a -> b) -> [a] -> [b]
map LamBinding' TypedBinding -> TypedBinding
makeDomainFull [LamBinding' TypedBinding]
ls
          Expr
t'  <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Expr -> ScopeM (AbsOfCon Expr)) -> Expr -> ScopeM (AbsOfCon Expr)
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 (Map QName Name -> NameMetadata) -> Map QName Name -> NameMetadata
forall a b. (a -> b) -> a -> b
$ GeneralizeTelescope -> Map QName Name
generalizeTelVars GeneralizeTelescope
ls') Name
x QName
x'
          Maybe TypeError -> (TypeError -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TypeError
mErr ((TypeError -> TCMT IO ()) -> TCMT IO ())
-> (TypeError -> TCMT IO ()) -> TCMT IO ()
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) ScopeM ResolvedName -> (ResolvedName -> TCMT IO ()) -> TCMT IO ()
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
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 KindOfName -> KindOfName -> Bool
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 []
                  TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition QName
cn QName
an (NiceDeclaration -> Maybe NiceDeclaration
forall a. a -> Maybe a
Just NiceDeclaration
suggestion)
                ResolvedName
_ -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
err
            TypeError
otherErr -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
otherErr
          [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> Erased -> QName -> GeneralizeTelescope -> Expr -> Declaration
A.DataSig (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
a Range
r) Erased
er 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 IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef then KindOfName
MacroName else KindOfName
FunName
        Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> TCMT IO Declaration -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfName -> NiceDeclaration -> TCMT IO 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 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"checking def " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
        (QName
x',[Clause]
cs) <- (OldName Name, [Clause])
-> ScopeM (AbsOfCon (OldName Name, [Clause]))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> OldName Name
forall a. a -> OldName a
OldName Name
x,[Clause]
cs)
        -- Andreas, 2017-12-04 the name must reside in the current module
        TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((QName -> ModuleName
A.qnameModule QName
x' ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModuleName -> Bool) -> TCMT IO ModuleName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
        Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x

        QName -> TCMT IO ()
unfoldFunction QName
x'
        DefInfo
di <- DefInfo -> ScopeM DefInfo
updateDefInfoOpacity (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo
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)
        [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> [Clause] -> Declaration
A.FunDef DefInfo
di QName
x' [Clause]
cs ]

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

        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.data.def" Int
20 ([Char]
"checking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Origin -> [Char]
forall a. Show a => a -> [Char]
show Origin
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" DataDef for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
        (Access
p, AbstractName
ax) <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Access, AbstractName))
-> TCMT IO (Access, AbstractName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
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
            AbstractName -> TCMT IO ()
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
            (Access, AbstractName) -> TCMT IO (Access, AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
          ResolvedName
_ -> [Char] -> TCMT IO (Access, AbstractName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Access, AbstractName))
-> [Char] -> TCMT IO (Access, AbstractName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing type signature for data definition " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
        [LamBinding' TypedBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
pars
        ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
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 <- (NiceDeclaration -> ScopeM Name)
-> [NiceDeclaration] -> TCMT IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NiceDeclaration -> ScopeM Name
conName [NiceDeclaration]
cons
             [Name] -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull ([Name] -> [Name]
forall a. Ord a => [a] -> [a]
duplicates [Name]
cs) (([Name] -> TCMT IO ()) -> TCMT IO ())
-> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ [Name]
dups -> do
               let bad :: [Name]
bad = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
cs
               [Name] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Name]
bad (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                 TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
DuplicateConstructors [Name]
dups

          [LamBinding]
pars <- [Maybe LamBinding] -> [LamBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe LamBinding] -> [LamBinding])
-> TCMT IO [Maybe LamBinding] -> TCMT IO [LamBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LamBinding' TypedBinding]
-> ScopeM (AbsOfCon [LamBinding' TypedBinding])
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 (DataOrRecordModule -> Maybe DataOrRecordModule
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 <- [DataConstrDecl] -> ScopeM (AbsOfCon [DataConstrDecl])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ((NiceDeclaration -> DataConstrDecl)
-> [NiceDeclaration] -> [DataConstrDecl]
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 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Checked data " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
          Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
          [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> QName
-> UniverseCheck
-> DataDefParams
-> [Declaration]
-> Declaration
A.DataDef (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
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
_) = Name -> ScopeM Name
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
c
        conName NiceDeclaration
d = NiceDeclaration -> ScopeM Name
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
      TCMT IO ()
notAffectedByOpaque

      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.rec.def" Int
20 ([Char]
"checking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Origin -> [Char]
forall a. Show a => a -> [Char]
show Origin
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" RecDef for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
      -- #3008: Termination pragmas are ignored in records
      WhereOrRecord -> [Declaration] -> TCMT IO ()
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'.
      Maybe Range
pat <- case Maybe Range
pat of
        Just Range
r
          | Just (Ranged Range
_ Induction
CoInductive) <- Maybe (Ranged Induction)
ind -> Maybe Range
forall a. Maybe a
Nothing Maybe Range -> TCMT IO () -> TCMT IO (Maybe Range)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> TCMT IO ()
warn [Char]
"coinductive"
          | Just HasEta0
YesEta                 <- Maybe HasEta0
eta -> Maybe Range
forall a. Maybe a
Nothing Maybe Range -> TCMT IO () -> TCMT IO (Maybe Range)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> TCMT IO ()
warn [Char]
"eta"
          | Bool
otherwise -> Maybe Range -> TCMT IO (Maybe Range)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Range
pat
          where warn :: [Char] -> TCMT IO ()
warn = Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ())
-> ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ())
-> ([Char] -> Warning) -> [Char] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Warning
UselessPatternDeclarationForRecord
        Maybe Range
Nothing -> Maybe Range -> TCMT IO (Maybe Range)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Range
pat

      (Access
p, AbstractName
ax) <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Access, AbstractName))
-> TCMT IO (Access, AbstractName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
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
          AbstractName -> TCMT IO ()
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
          (Access, AbstractName) -> TCMT IO (Access, AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
        ResolvedName
_ -> [Char] -> TCMT IO (Access, AbstractName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Access, AbstractName))
-> [Char] -> TCMT IO (Access, AbstractName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing type signature for record definition " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
      [LamBinding' TypedBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
pars
      ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
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   <- [Maybe LamBinding] -> [LamBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe LamBinding] -> [LamBinding])
-> TCMT IO [Maybe LamBinding] -> TCMT IO [LamBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LamBinding' TypedBinding]
-> ScopeM (AbsOfCon [LamBinding' TypedBinding])
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 <- RecordConstructorType
-> (AbsOfCon RecordConstructorType -> ScopeM Expr) -> ScopeM Expr
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract ([Declaration] -> RecordConstructorType
RecordConstructorType [Declaration]
fields) Expr -> ScopeM Expr
AbsOfCon RecordConstructorType -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ModuleName
m0     <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
        let m :: ModuleName
m = ModuleName -> ModuleName -> ModuleName
A.qualifyM ModuleName
m0 (ModuleName -> ModuleName) -> ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ List1 Name -> ModuleName
mnameFromList1 (List1 Name -> ModuleName) -> List1 Name -> ModuleName
forall a b. (a -> b) -> a -> b
$ Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton (Name -> List1 Name) -> Name -> List1 Name
forall a b. (a -> b) -> a -> b
$ List1 Name -> Name
forall a. NonEmpty a -> a
List1.last (List1 Name -> Name) -> List1 Name -> Name
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 (DataOrRecordModule -> Maybe DataOrRecordModule
forall a. a -> Maybe a
Just DataOrRecordModule
IsRecordModule) ModuleName
m
        -- We scope check the fields a second time, as actual fields.
        [Declaration]
afields <- ModuleName -> ScopeM [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
          [Declaration]
afields <- Declarations -> ScopeM (AbsOfCon Declarations)
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"
          [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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 = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> [[Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Declaration] -> (Declaration -> Maybe [Name]) -> [[Name]]
forall a b. [a] -> (a -> Maybe b) -> [b]
forMaybe [Declaration]
fields ((Declaration -> Maybe [Name]) -> [[Name]])
-> (Declaration -> Maybe [Name]) -> [[Name]]
forall a b. (a -> b) -> a -> b
$ \case
                 C.Field Range
_ [Declaration]
fs -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name]) -> [Name] -> Maybe [Name]
forall a b. (a -> b) -> a -> b
$ [Declaration]
fs [Declaration] -> (Declaration -> Name) -> [Name]
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
_ -> Name
forall a. HasCallStack => a
__IMPOSSIBLE__
                 Declaration
_ -> Maybe [Name]
forall a. Maybe a
Nothing
           [Name] -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull ([Name] -> [Name]
forall a. Ord a => [a] -> [a]
duplicates [Name]
fs) (([Name] -> TCMT IO ()) -> TCMT IO ())
-> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ [Name]
dups -> do
             let bad :: [Name]
bad = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
fs
             [Name] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Name]
bad (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
               TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
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 = KindOfName
-> (Ranged Induction -> KindOfName)
-> Maybe (Ranged Induction)
-> KindOfName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe KindOfName
ConName (Induction -> KindOfName
conKindOfName (Induction -> KindOfName)
-> (Ranged Induction -> Induction)
-> Ranged Induction
-> KindOfName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged Induction -> Induction
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' <- Maybe (Name, IsInstance)
-> ((Name, IsInstance) -> TCMT IO QName) -> TCMT IO (Maybe QName)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Name, IsInstance)
cm (((Name, IsInstance) -> TCMT IO QName) -> TCMT IO (Maybe QName))
-> ((Name, IsInstance) -> TCMT IO QName) -> TCMT IO (Maybe QName)
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 = Maybe (Name, IsInstance)
-> IsInstance -> ((Name, IsInstance) -> IsInstance) -> IsInstance
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Name, IsInstance)
cm IsInstance
NotInstanceDef (Name, IsInstance) -> IsInstance
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' = Maybe (Ranged Induction)
-> Maybe HasEta0
-> Maybe Range
-> Maybe QName
-> RecordDirectives' QName
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'
        [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> QName
-> UniverseCheck
-> RecordDirectives' QName
-> DataDefParams
-> Expr
-> [Declaration]
-> Declaration
A.RecDef (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo
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 Erased
e x :: QName
x@(C.QName Name
name) Telescope
tel [Declaration]
ds -> do
      TCMT IO ()
notAffectedByOpaque

      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking NiceModule " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
        ]

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

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

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

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

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

      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked NiceModuleMacro " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Declaration -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Declaration
adecl
        ]
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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 Maybe ModuleName
forall a. Maybe a
Nothing QName
x ImportDirective
dir
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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 <- Pragma -> ScopeM (AbsOfCon Pragma)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pragma
p  -- could result in empty list of pragmas
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> ScopeM [Declaration])
-> [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ (Pragma -> Declaration) -> [Pragma] -> [Declaration]
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 -> Range -> ScopeM [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
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 = Maybe AsName
-> TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name))
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Maybe AsName
as (TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name)))
-> TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name))
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.
            Maybe (AsName' Name)
forall a. Maybe a
Nothing Maybe (AsName' Name)
-> TCMT IO () -> TCMT IO (Maybe (AsName' Name))
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Warning -> TCMT IO ()
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 -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AsName' Name)
forall a. Maybe a
Nothing
        Just (AsName (Right Name
asName) Range
r)                    -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name)))
-> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ AsName' Name -> Maybe (AsName' Name)
forall a. a -> Maybe a
Just (AsName' Name -> Maybe (AsName' Name))
-> AsName' Name -> Maybe (AsName' Name)
forall a b. (a -> b) -> a -> b
$ Name -> Range -> AsName' Name
forall a. a -> Range -> AsName' a
AsName Name
asName Range
r
        Just (AsName (Left (C.Ident (C.QName Name
asName))) Range
r) -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name)))
-> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ AsName' Name -> Maybe (AsName' Name)
forall a. a -> Maybe a
Just (AsName' Name -> Maybe (AsName' Name))
-> AsName' Name -> Maybe (AsName' Name)
forall a b. (a -> b) -> a -> b
$ Name -> Range -> AsName' Name
forall a. a -> Range -> AsName' a
AsName Name
asName Range
r
        Just (AsName (Left C.Underscore{})     Range
r)         -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name)))
-> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ AsName' Name -> Maybe (AsName' Name)
forall a. a -> Maybe a
Just (AsName' Name -> Maybe (AsName' Name))
-> AsName' Name -> Maybe (AsName' Name)
forall a b. (a -> b) -> a -> b
$ Name -> Range -> AsName' Name
forall a. a -> Range -> AsName' a
AsName Name
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) <- ModuleName
-> TCMT IO (ModuleName, Map ModuleName Scope)
-> TCMT IO (ModuleName, Map ModuleName Scope)
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
noModuleName (TCMT IO (ModuleName, Map ModuleName Scope)
 -> TCMT IO (ModuleName, Map ModuleName Scope))
-> TCMT IO (ModuleName, Map ModuleName Scope)
-> TCMT IO (ModuleName, Map ModuleName Scope)
forall a b. (a -> b) -> a -> b
$
                TopLevelModuleName
-> TCMT IO (ModuleName, Map ModuleName Scope)
-> TCMT IO (ModuleName, Map ModuleName Scope)
forall a. TopLevelModuleName -> TCM a -> TCM a
withTopLevelModule TopLevelModuleName
top (TCMT IO (ModuleName, Map ModuleName Scope)
 -> TCMT IO (ModuleName, Map ModuleName Scope))
-> TCMT IO (ModuleName, Map ModuleName Scope)
-> TCMT IO (ModuleName, Map ModuleName Scope)
forall a b. (a -> b) -> a -> b
$ do
        ModuleName
m <- NewModuleQName -> ScopeM (AbsOfCon NewModuleQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (NewModuleQName -> ScopeM (AbsOfCon NewModuleQName))
-> NewModuleQName -> ScopeM (AbsOfCon NewModuleQName)
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 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checked import: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Map ModuleName Scope -> [Char]
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)
        (ModuleName, Map ModuleName Scope)
-> TCMT IO (ModuleName, Map ModuleName Scope)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m, ModuleName -> Map ModuleName Scope -> Map ModuleName Scope
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 = AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
a, Bool -> Bool
not (Name -> Bool
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
           (QName, Range, Maybe Name) -> TCMT IO (QName, Range, Maybe Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> QName
C.QName Name
y, AsName' Name -> Range
forall a. AsName' a -> Range
asRange AsName' Name
a, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
y)

         Maybe (AsName' Name)
_ -> do
           -- Don't bind if @import ... as _@ with "no name"
           Maybe (AsName' Name) -> TCMT IO () -> TCMT IO ()
forall m a. Monoid m => Maybe a -> m -> m
whenNothing Maybe (AsName' Name)
as (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Access -> QName -> ModuleName -> TCMT IO ()
bindQModule (Origin -> Access
PrivateAccess Origin
Inserted) QName
x ModuleName
m
           (QName, Range, Maybe Name) -> TCMT IO (QName, Range, Maybe Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, Range
forall a. Range' a
noRange, Maybe Name
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 ((Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ())
-> (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Map ModuleName Scope
ms -> (Scope -> Scope -> Scope)
-> Map ModuleName Scope
-> Map ModuleName Scope
-> Map ModuleName Scope
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Scope -> Scope -> Scope
mergeScope (ModuleName -> Map ModuleName Scope -> Map ModuleName Scope
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 (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m) QName
name ImportDirective
dir
          ImportDirective -> TCMT IO ImportDirective
forall a. a -> TCMT IO a
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') <- (Scope -> ScopeM (ImportDirective, Scope))
-> ModuleName
-> Map ModuleName Scope
-> TCMT IO (ImportDirective, Map ModuleName Scope)
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 -> ScopeM (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 ((Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ())
-> (Map ModuleName Scope -> Map ModuleName Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Map ModuleName Scope
ms -> (Scope -> Scope -> Scope)
-> Map ModuleName Scope
-> Map ModuleName Scope
-> Map ModuleName Scope
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'
          ImportDirective -> TCMT IO ImportDirective
forall a. a -> TCMT IO a
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      = (Range, Range) -> Range
forall a. HasRange a => a -> Range
getRange (Range
theAsSymbol, ImportDirective -> Range
renamingRange ImportDirective
dir)
            , minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = OpenShortHand -> Maybe OpenShortHand
forall a. a -> Maybe a
Just OpenShortHand
open
            , minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dir
            }
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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 <- (Name -> ScopeM Fixity') -> [Name] -> TCMT IO [Fixity']
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
      [QName]
ys <- (Fixity' -> Name -> TCMT IO QName)
-> [Fixity'] -> [Name] -> TCMT IO [QName]
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
      (Name -> QName -> TCMT IO ()) -> [Name] -> [QName] -> TCMT IO ()
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 <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
      (Name -> QName -> TCMT IO ()) -> [Name] -> [QName] -> TCMT IO ()
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
      (QName -> TCMT IO ()) -> [QName] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ QName -> TCMT IO ()
unfoldFunction [QName]
ys
      IsOpaque
opaque <- ScopeM IsOpaque
contextIsOpaque
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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
            [ (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo
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) { Info.defOpaque = opaque } | (Fixity'
fx, Name
x) <- [Fixity'] -> [Name] -> [(Fixity', Name)]
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 <- (Name -> ScopeM Fixity') -> [Name] -> TCMT IO [Fixity']
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
      [QName]
ys <- (Name -> TCMT IO QName) -> [Name] -> TCMT IO [QName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (OldName Name -> TCMT IO QName
OldName Name -> ScopeM (AbsOfCon (OldName Name))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldName Name -> TCMT IO QName)
-> (Name -> OldName Name) -> Name -> TCMT IO QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OldName Name
forall a. a -> OldName a
OldName) [Name]
xs
      (Name -> QName -> TCMT IO ()) -> [Name] -> [QName] -> TCMT IO ()
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 <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
      (Name -> QName -> TCMT IO ()) -> [Name] -> [QName] -> TCMT IO ()
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
      (QName -> TCMT IO ()) -> [QName] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ QName -> TCMT IO ()
unfoldFunction [QName]
ys
      IsOpaque
opaque <- ScopeM IsOpaque
contextIsOpaque
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ [DefInfo] -> [QName] -> Expr -> Declaration
A.UnquoteDef [ (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
fx Access
PublicAccess IsAbstract
a Range
r) { Info.defOpaque = opaque } | (Fixity'
fx, Name
x) <- [Fixity'] -> [Name] -> [(Fixity', Name)]
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
      TCMT IO ()
notAffectedByOpaque

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

      Expr
e <- ModuleName -> ScopeM Expr -> ScopeM Expr
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeM (AbsOfCon Expr)
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'
      (Name -> QName -> TCMT IO ()) -> [Name] -> [QName] -> TCMT IO ()
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'
      ModuleName -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ (Name -> QName -> TCMT IO ()) -> [Name] -> [QName] -> TCMT IO ()
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 <- (Name -> ScopeM Fixity') -> [Name] -> TCMT IO [Fixity']
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
cs
      let mi :: MutualInfo
mi = TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo TerminationCheck
forall m. TerminationCheck m
TerminationCheck CoverageCheck
YesCoverageCheck PositivityCheck
pc Range
r
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
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
            [ Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
fx Access
p IsAbstract
a Range
r ] QName
x' UniverseCheck
uc
            [ Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
c Fixity'
fc Access
p IsAbstract
a Range
r | (Fixity'
fc, Name
c) <- [Fixity'] -> [Name] -> [(Fixity', Name)]
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
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"found nice pattern syn: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
n
      ([Arg Name]
as, Pattern' Void
p) <- ScopeM ([Arg Name], Pattern' Void)
-> ScopeM ([Arg Name], Pattern' Void)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM ([Arg Name], Pattern' Void)
 -> ScopeM ([Arg Name], Pattern' Void))
-> ScopeM ([Arg Name], Pattern' Void)
-> ScopeM ([Arg Name], Pattern' Void)
forall a b. (a -> b) -> a -> b
$ do
         -- Expand puns if optHiddenArgumentPuns is True.
         Bool
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
         Pattern
p <- Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ if Bool
puns then KillRangeT Pattern
expandPuns Pattern
p else Pattern
p
         Pattern' Expr
p <- Pattern -> TCMT IO (Pattern' Expr)
Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Pattern -> TCMT IO (Pattern' Expr))
-> TCMT IO Pattern -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pattern -> TCMT IO Pattern
parsePatternSyn Pattern
p
         Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pattern' Expr -> Bool
forall p. APatternLike p => p -> Bool
containsAsPattern Pattern' Expr
p) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
           TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$
             [Char]
"@-patterns are not allowed in pattern synonyms"
         Pattern' Expr -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p (([Name] -> TCMT IO ()) -> TCMT IO ())
-> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \[Name]
ys ->
           TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
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 <- [Char] -> Pattern' Expr -> ScopeM (Pattern' Void)
forall e. [Char] -> Pattern' e -> ScopeM (Pattern' Void)
noDotorEqPattern [Char]
err Pattern' Expr
p
         [Arg Name]
as <- ((Arg Name -> TCMT IO (Arg Name))
-> [Arg Name] -> TCMT IO [Arg Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Arg Name -> TCMT IO (Arg Name))
 -> [Arg Name] -> TCMT IO [Arg Name])
-> ((Name -> ScopeM Name) -> Arg Name -> TCMT IO (Arg Name))
-> (Name -> ScopeM Name)
-> [Arg Name]
-> TCMT IO [Arg Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> ScopeM Name) -> Arg Name -> TCMT IO (Arg Name)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Arg a -> m (Arg b)
mapM) (ResolvedName -> ScopeM Name
forall {m :: * -> *}.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
ResolvedName -> m Name
unVarName (ResolvedName -> ScopeM Name)
-> (Name -> ScopeM ResolvedName) -> Name -> ScopeM Name
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< QName -> ScopeM ResolvedName
resolveName (QName -> ScopeM ResolvedName)
-> (Name -> QName) -> Name -> ScopeM ResolvedName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName) [Arg Name]
as
         [Name] -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull (Pattern' Void -> [Name]
forall p. APatternLike p => p -> [Name]
patternVars Pattern' Void
p [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ (Arg Name -> Name) -> [Arg Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Arg Name -> Name
forall e. Arg e -> e
unArg [Arg Name]
as) (([Name] -> TCMT IO ()) -> TCMT IO ())
-> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ [Name]
xs -> do
           TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
UnboundVariablesInPatternSynonym [Name]
xs
         ([Arg Name], Pattern' Void) -> ScopeM ([Arg Name], Pattern' Void)
forall a. a -> TCMT IO a
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 <- Pattern' Void -> ScopeM (Pattern' Void)
forall a. ExpandPatternSynonyms a => a -> TCM a
expandPatternSynonyms Pattern' Void
p
      (PatternSynDefns -> PatternSynDefns) -> TCMT IO ()
modifyPatternSyns (QName
-> ([Arg Name], Pattern' Void)
-> PatternSynDefns
-> PatternSynDefns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QName
y ([Arg Name]
as, Pattern' Void
ep))
      [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> [Arg BindName] -> Pattern' Void -> Declaration
A.PatternSynDef QName
y ((Arg Name -> Arg BindName) -> [Arg Name] -> [Arg BindName]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> BindName) -> Arg Name -> Arg BindName
forall a b. (a -> b) -> Arg a -> Arg b
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
_) = Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
a
            unVarName ResolvedName
_ = TypeError -> m Name
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m Name) -> TypeError -> m Name
forall a b. (a -> b) -> a -> b
$ TypeError
UnusedVariableInPatternSynonym

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

    NiceOpaque Range
r [QName]
names [NiceDeclaration]
decls -> do
      -- The names in an 'unfolding' clause must be unambiguous names of
      -- definitions:
      let
        findName :: QName -> TCMT IO QName
findName QName
c = QName -> ScopeM ResolvedName
resolveName QName
c ScopeM ResolvedName
-> (ResolvedName -> TCMT IO QName) -> TCMT IO QName
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          A.DefinedName Access
_ AbstractName
an Suffix
_           -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractName -> QName
anameName AbstractName
an)
          A.FieldName (AbstractName
an :| [])         -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractName -> QName
anameName AbstractName
an)
          A.ConstructorName Set Induction
_ (AbstractName
an :| []) -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractName -> QName
anameName AbstractName
an)

          ResolvedName
A.UnknownName -> QName -> TCMT IO QName
forall a. QName -> TCM a
notInScopeError QName
c
          ResolvedName
_ -> TypeError -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO QName)
-> (Doc -> TypeError) -> Doc -> TCMT IO QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO QName) -> TCMT IO Doc -> TCMT IO QName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            TCMT IO Doc
"Name in unfolding clause should be unambiguous defined name:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
c

      -- Resolve all the names, and use them as an initial unfolding
      -- set:
      [QName]
names  <- (QName -> TCMT IO QName) -> [QName] -> TCMT IO [QName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse QName -> TCMT IO QName
findName [QName]
names
      -- Generate the identifier for this block:
      OpaqueId
oid    <- TCMT IO OpaqueId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
      -- Record the parent unfolding block, if any:
      Maybe OpaqueId
parent <- (TCEnv -> Maybe OpaqueId) -> TCMT IO (Maybe OpaqueId)
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe OpaqueId
envCurrentOpaqueId

      (Map OpaqueId OpaqueBlock -> f (Map OpaqueId OpaqueBlock))
-> TCState -> f TCState
Lens' TCState (Map OpaqueId OpaqueBlock)
stOpaqueBlocks Lens' TCState (Map OpaqueId OpaqueBlock)
-> (Map OpaqueId OpaqueBlock -> Map OpaqueId OpaqueBlock)
-> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> (a -> a) -> m ()
`modifyTCLens` OpaqueId
-> OpaqueBlock
-> Map OpaqueId OpaqueBlock
-> Map OpaqueId OpaqueBlock
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert OpaqueId
oid OpaqueBlock
        { opaqueId :: OpaqueId
opaqueId        = OpaqueId
oid
        , opaqueUnfolding :: HashSet QName
opaqueUnfolding = [QName] -> HashSet QName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [QName]
names
        , opaqueDecls :: HashSet QName
opaqueDecls     = HashSet QName
forall a. Monoid a => a
mempty
        , opaqueParent :: Maybe OpaqueId
opaqueParent    = Maybe OpaqueId
parent
        , opaqueRange :: Range
opaqueRange     = Range
r
        }

      -- Keep going!
      (TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC (\TCEnv
e -> TCEnv
e { envCurrentOpaqueId = Just oid }) (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
        [Declaration]
out <- (NiceDeclaration -> TCMT IO Declaration)
-> [NiceDeclaration] -> ScopeM [Declaration]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse NiceDeclaration -> TCMT IO Declaration
NiceDeclaration -> ScopeM (AbsOfCon NiceDeclaration)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NiceDeclaration]
decls
        Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
interestingOpaqueDecl [Declaration]
out) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessOpaque
        [Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Declaration] -> ScopeM [Declaration])
-> [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ Range -> [QName] -> Declaration
UnfoldingDecl Range
r [QName]
namesDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
out
    where
      -- checking postulate or type sig. without checking safe flag
      toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM A.Declaration
      toAbstractNiceAxiom :: KindOfName -> NiceDeclaration -> TCMT IO Declaration
toAbstractNiceAxiom KindOfName
kind (C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
info Name
x Expr
t) = do
        Expr
t' <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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 KindOfName -> KindOfName -> Bool
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
        Declaration -> TCMT IO Declaration
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> TCMT IO Declaration)
-> Declaration -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$ KindOfName
-> DefInfo
-> ArgInfo
-> Maybe [Occurrence]
-> QName
-> Expr
-> Declaration
A.Axiom KindOfName
kind (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo
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
_ = TCMT IO Declaration
forall a. HasCallStack => a
__IMPOSSIBLE__

      interestingOpaqueDecl :: A.Declaration -> Bool
      interestingOpaqueDecl :: Declaration -> Bool
interestingOpaqueDecl (A.Mutual MutualInfo
_ [Declaration]
ds)     = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
interestingOpaqueDecl [Declaration]
ds
      interestingOpaqueDecl (A.ScopedDecl ScopeInfo
_ [Declaration]
ds) = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
interestingOpaqueDecl [Declaration]
ds

      interestingOpaqueDecl A.FunDef{} = Bool
True
      interestingOpaqueDecl A.UnquoteDecl{} = Bool
True
      interestingOpaqueDecl A.UnquoteDef{} = Bool
True
      interestingOpaqueDecl A.Primitive{} = Bool
True

      interestingOpaqueDecl Declaration
_ = Bool
False

-- | Add a 'QName' to the set of declarations /contained in/ the current
-- opaque block.
unfoldFunction :: A.QName -> ScopeM ()
unfoldFunction :: QName -> TCMT IO ()
unfoldFunction QName
qn = (TCEnv -> Maybe OpaqueId) -> TCMT IO (Maybe OpaqueId)
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe OpaqueId
envCurrentOpaqueId TCMT IO (Maybe OpaqueId)
-> (Maybe OpaqueId -> TCMT IO ()) -> TCMT IO ()
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just OpaqueId
id -> do
    let go :: Maybe OpaqueBlock -> Maybe OpaqueBlock
go Maybe OpaqueBlock
Nothing   = Maybe OpaqueBlock
forall a. HasCallStack => a
__IMPOSSIBLE__
        go (Just OpaqueBlock
ob) = OpaqueBlock -> Maybe OpaqueBlock
forall a. a -> Maybe a
Just OpaqueBlock
ob{ opaqueDecls = qn `HashSet.insert` opaqueDecls ob }
    (Map OpaqueId OpaqueBlock -> f (Map OpaqueId OpaqueBlock))
-> TCState -> f TCState
Lens' TCState (Map OpaqueId OpaqueBlock)
stOpaqueBlocks Lens' TCState (Map OpaqueId OpaqueBlock)
-> (Map OpaqueId OpaqueBlock -> Map OpaqueId OpaqueBlock)
-> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> (a -> a) -> m ()
`modifyTCLens` (Maybe OpaqueBlock -> Maybe OpaqueBlock)
-> OpaqueId -> Map OpaqueId OpaqueBlock -> Map OpaqueId OpaqueBlock
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe OpaqueBlock -> Maybe OpaqueBlock
go OpaqueId
id
  Maybe OpaqueId
Nothing -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Look up the current opaque identifier as a value in 'IsOpaque'.
contextIsOpaque :: ScopeM IsOpaque
contextIsOpaque :: ScopeM IsOpaque
contextIsOpaque =  IsOpaque -> (OpaqueId -> IsOpaque) -> Maybe OpaqueId -> IsOpaque
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IsOpaque
TransparentDef OpaqueId -> IsOpaque
OpaqueDef (Maybe OpaqueId -> IsOpaque)
-> TCMT IO (Maybe OpaqueId) -> ScopeM IsOpaque
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> Maybe OpaqueId) -> TCMT IO (Maybe OpaqueId)
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe OpaqueId
envCurrentOpaqueId

updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo
updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo
updateDefInfoOpacity DefInfo
di = (\IsOpaque
a -> DefInfo
di { Info.defOpaque = a }) (IsOpaque -> DefInfo) -> ScopeM IsOpaque -> ScopeM DefInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM IsOpaque
contextIsOpaque

-- | Raise a warning indicating that the current Declaration is not
-- affected by opacity, but only if we are actually in an Opaque block.
notAffectedByOpaque :: ScopeM ()
notAffectedByOpaque :: TCMT IO ()
notAffectedByOpaque = do
  Bool
t <- (TCEnv -> Bool) -> TCMT IO Bool
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
envCheckingWhere
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
t (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    TCMT IO ()
-> (OpaqueId -> TCMT IO ()) -> Maybe OpaqueId -> TCMT IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (TCMT IO () -> OpaqueId -> TCMT IO ()
forall a b. a -> b -> a
const (Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
NotAffectedByOpaque)) (Maybe OpaqueId -> TCMT IO ())
-> TCMT IO (Maybe OpaqueId) -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TCEnv -> Maybe OpaqueId) -> TCMT IO (Maybe OpaqueId)
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe OpaqueId
envCurrentOpaqueId

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 (Expr -> Expr) -> (Set QName, Expr) -> (Set QName, Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> (Set QName, Expr)
unGeneralized Expr
e
unGeneralized Expr
t = (Set QName
forall a. Monoid a => a
mempty, Expr
t)

alreadyGeneralizing :: ScopeM Bool
alreadyGeneralizing :: TCMT IO Bool
alreadyGeneralizing = Maybe (Set QName) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Set QName) -> Bool)
-> TCMT IO (Maybe (Set QName)) -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
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
  TCMT IO Bool
-> TCMT IO (Set QName, a)
-> TCMT IO (Set QName, a)
-> TCMT IO (Set QName, a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM TCMT IO Bool
alreadyGeneralizing ((Set QName
forall a. Set a
Set.empty,) (a -> (Set QName, a)) -> ScopeM a -> TCMT IO (Set QName, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM a
m) (TCMT IO (Set QName, a) -> TCMT IO (Set QName, a))
-> TCMT IO (Set QName, a) -> TCMT IO (Set QName, a)
forall a b. (a -> b) -> a -> b
$
  {-else-} TCMT IO (Maybe (Set QName))
-> (Maybe (Set QName) -> TCMT IO ())
-> TCMT IO (Set QName, a)
-> TCMT IO (Set QName, a)
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 (TCMT IO (Set QName, a) -> TCMT IO (Set QName, a))
-> TCMT IO (Set QName, a) -> TCMT IO (Set QName, a)
forall a b. (a -> b) -> a -> b
$ do
      a
a <- ScopeM a
m
      Maybe (Set QName)
s <- Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars
      case Maybe (Set QName)
s of
          Maybe (Set QName)
Nothing -> TCMT IO (Set QName, a)
forall a. HasCallStack => a
__IMPOSSIBLE__
          Just Set QName
s -> (Set QName, a) -> TCMT IO (Set QName, a)
forall a. a -> TCMT IO a
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 <- Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars
        (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars Lens' TCState (Maybe (Set QName))
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> a -> m ()
`setTCLens` Set QName -> Maybe (Set QName)
forall a. a -> Maybe a
Just Set QName
forall a. Monoid a => a
mempty
        Maybe (Set QName) -> TCMT IO (Maybe (Set QName))
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set QName)
gvs
    close :: Maybe (Set QName) -> TCMT IO ()
close = ((Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars Lens' TCState (Maybe (Set QName))
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> a -> m ()
`setTCLens`)

createBoundNamesForGeneralizables :: Set I.QName -> ScopeM (Map I.QName I.Name)
createBoundNamesForGeneralizables :: Set QName -> ScopeM (Map QName Name)
createBoundNamesForGeneralizables Set QName
vs =
  ((QName -> () -> ScopeM Name)
 -> Map QName () -> ScopeM (Map QName Name))
-> Map QName ()
-> (QName -> () -> ScopeM Name)
-> ScopeM (Map QName Name)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QName -> () -> ScopeM Name)
-> Map QName () -> ScopeM (Map QName Name)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey ((QName -> ()) -> Set QName -> Map QName ()
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (() -> QName -> ()
forall a b. a -> b -> a
const ()) Set QName
vs) ((QName -> () -> ScopeM Name) -> ScopeM (Map QName Name))
-> (QName -> () -> ScopeM Name) -> ScopeM (Map QName Name)
forall a b. (a -> b) -> a -> b
$ \ QName
q ()
_ -> do
    let x :: Name
x  = Name -> Name
nameConcrete (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ QName -> Name
qnameName QName
q
        fx :: Fixity'
fx = Name -> Fixity'
nameFixity   (Name -> Fixity') -> Name -> Fixity'
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 <- [(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Name, LocalVar)] -> Int)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
  (Set QName
s, a
res) <- ScopeM a -> ScopeM (Set QName, a)
forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables ScopeM a
m
  Int
fvAfter  <- [(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Name, LocalVar)] -> Int)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
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`.
  Int -> TCMT IO () -> TCMT IO ()
forall a. Int -> ScopeM a -> ScopeM a
outsideLocalVars (Int
fvAfter Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fvBefore) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Map QName Name -> TCMT IO ()
bindGeneralizables Map QName Name
binds
  (Map QName Name, a) -> ScopeM (Map QName Name, a)
forall a. a -> TCMT IO a
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 =
  [(QName, Name)] -> ((QName, Name) -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map QName Name -> [(QName, Name)]
forall k a. Map k a -> [(k, a)]
Map.toList Map QName Name
vars) (((QName, Name) -> TCMT IO ()) -> TCMT IO ())
-> ((QName, Name) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ (QName
q, Name
y) ->
    BindingSource -> Name -> Name -> TCMT IO ()
bindVariable BindingSource
LambdaBound (Name -> Name
nameConcrete (Name -> Name) -> Name -> Name
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 Set Name -> TCMT IO () -> ScopeM (Set Name)
forall a b. a -> TCMT IO b -> TCMT IO a
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                    -> Map QName Name
forall k a. Map k a
Map.empty
        bound :: Set Name
bound = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Map QName Name -> [Name]
forall k a. Map k a -> [a]
Map.elems Map QName Name
gvars)
bindGeneralizablesIfInserted Origin
UserWritten AbstractName
_ = Set Name -> ScopeM (Set Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Set Name
forall a. Set a
Set.empty
bindGeneralizablesIfInserted Origin
_ AbstractName
_           = ScopeM (Set Name)
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) =
    (Map QName Name -> [TypedBinding] -> GeneralizeTelescope)
-> (Map QName Name, [TypedBinding]) -> GeneralizeTelescope
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map QName Name -> [TypedBinding] -> GeneralizeTelescope
A.GeneralizeTel ((Map QName Name, [TypedBinding]) -> GeneralizeTelescope)
-> TCMT IO (Map QName Name, [TypedBinding])
-> TCMT IO GeneralizeTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [TypedBinding] -> TCMT IO (Map QName Name, [TypedBinding])
forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables ([Maybe TypedBinding] -> [TypedBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TypedBinding] -> [TypedBinding])
-> TCMT IO [Maybe TypedBinding] -> TCMT IO [TypedBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ScopeM (AbsOfCon Telescope)
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)) <- ScopeM ([Maybe TypedBinding], Expr)
-> ScopeM (Map QName Name, ([Maybe TypedBinding], Expr))
forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables (ScopeM ([Maybe TypedBinding], Expr)
 -> ScopeM (Map QName Name, ([Maybe TypedBinding], Expr)))
-> ScopeM ([Maybe TypedBinding], Expr)
-> ScopeM (Map QName Name, ([Maybe TypedBinding], Expr))
forall a b. (a -> b) -> a -> b
$
                          (,) ([Maybe TypedBinding] -> Expr -> ([Maybe TypedBinding], Expr))
-> TCMT IO [Maybe TypedBinding]
-> TCMT IO (Expr -> ([Maybe TypedBinding], Expr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ScopeM (AbsOfCon Telescope)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel TCMT IO (Expr -> ([Maybe TypedBinding], Expr))
-> ScopeM Expr -> ScopeM ([Maybe TypedBinding], Expr)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
t
    (GeneralizeTelescope, Expr) -> ScopeM (GeneralizeTelescope, Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map QName Name -> [TypedBinding] -> GeneralizeTelescope
A.GeneralizeTel Map QName Name
binds ([Maybe TypedBinding] -> [TypedBinding]
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 = QName -> TCMT IO ()
forall a. LivesInCurrentModule a => a -> TCMT IO ()
livesInCurrentModule (QName -> TCMT IO ())
-> (AbstractName -> QName) -> AbstractName -> TCMT IO ()
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 <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    [Char] -> Int -> [[Char]] -> TCMT IO ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
[Char] -> Int -> a -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [[Char]] -> m ()
reportS [Char]
"scope.data.def" Int
30
      [ [Char]
"  A.QName of data type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
      , [Char]
"  current module: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ModuleName
m
      ]
    Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QName -> ModuleName
A.qnameModule QName
x ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
m) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
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 = Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AbstractName -> KindOfName
anameKind AbstractName
ax KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
k) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
  TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax) Maybe NiceDeclaration
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 <- [Maybe DataOrRecordModule] -> [DataOrRecordModule]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DataOrRecordModule] -> [DataOrRecordModule])
-> TCMT IO [Maybe DataOrRecordModule]
-> TCMT IO [DataOrRecordModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    (AbstractModule -> TCMT IO (Maybe DataOrRecordModule))
-> [AbstractModule] -> TCMT IO [Maybe DataOrRecordModule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ModuleName -> TCMT IO (Maybe DataOrRecordModule)
forall (m :: * -> *).
ReadTCState m =>
ModuleName -> m (Maybe DataOrRecordModule)
isDatatypeModule (ModuleName -> TCMT IO (Maybe DataOrRecordModule))
-> (AbstractModule -> ModuleName)
-> AbstractModule
-> TCMT IO (Maybe DataOrRecordModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName) ([AbstractModule] -> TCMT IO [Maybe DataOrRecordModule])
-> TCMT IO [AbstractModule] -> TCMT IO [Maybe DataOrRecordModule]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x
  [DataOrRecordModule]
-> ([DataOrRecordModule] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull [DataOrRecordModule]
datRecMods (([DataOrRecordModule] -> TCMT IO ()) -> TCMT IO ())
-> ([DataOrRecordModule] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> [DataOrRecordModule] -> TCMT IO ()
forall a b. a -> b -> a
const (TCMT IO () -> [DataOrRecordModule] -> TCMT IO ())
-> TCMT IO () -> [DataOrRecordModule] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax) Maybe NiceDeclaration
forall a. Maybe a
Nothing

lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]
lookupModuleInCurrentModule :: Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x =
  Maybe (List1 AbstractModule) -> [AbstractModule]
forall a. Maybe (List1 a) -> [a]
List1.toList' (Maybe (List1 AbstractModule) -> [AbstractModule])
-> (Scope -> Maybe (List1 AbstractModule))
-> Scope
-> [AbstractModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name
-> Map Name (List1 AbstractModule) -> Maybe (List1 AbstractModule)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (Map Name (List1 AbstractModule) -> Maybe (List1 AbstractModule))
-> (Scope -> Map Name (List1 AbstractModule))
-> Scope
-> Maybe (List1 AbstractModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> Map Name (List1 AbstractModule)
nsModules (NameSpace -> Map Name (List1 AbstractModule))
-> (Scope -> NameSpace) -> Scope -> Map Name (List1 AbstractModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSpaceId] -> Scope -> NameSpace
thingsInScope [NameSpaceId
PublicNS, NameSpaceId
PrivateNS] (Scope -> [AbstractModule])
-> TCMT IO Scope -> TCMT IO [AbstractModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO 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 <- ModuleName -> TCMT IO QName -> TCMT IO QName
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (TCMT IO QName -> TCMT IO QName) -> TCMT IO QName -> TCMT IO QName
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
  ModuleName -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p'' KindOfName
ConName Name
x QName
y
  QName -> TCMT IO QName
forall a. a -> TCMT IO a
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
  QName -> TCMT IO QName
forall a. a -> TCMT IO a
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' <- ModuleName -> TCMT IO QName -> TCMT IO QName
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (TCMT IO QName -> TCMT IO QName) -> TCMT IO QName -> TCMT IO QName
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 ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NameSpaceId -> Name -> AbstractName -> Scope -> Scope
addNameToScope (Access -> NameSpaceId
localNameSpace Access
p) Name
c (AbstractName -> Scope -> Scope) -> AbstractName -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ QName -> AbstractName
aname QName
c'
      success :: TCMT IO ()
success = TCMT IO ()
addName TCMT IO () -> TCMT IO () -> TCMT IO ()
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ModuleName -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO ()
addName)
  case ResolvedName
r of
    ResolvedName
_ | Name -> Bool
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 (AbstractName -> Bool) -> List1 AbstractName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Induction -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Induction -> Bool)
-> (AbstractName -> Maybe Induction) -> AbstractName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindOfName -> Maybe Induction
isConName (KindOfName -> Maybe Induction)
-> (AbstractName -> KindOfName) -> AbstractName -> Maybe Induction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind) List1 AbstractName
ds
      then TCMT IO ()
success
      else TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
c) (AbstractName -> QName
anameName (AbstractName -> QName) -> AbstractName -> QName
forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds) Maybe NiceDeclaration
forall a. Maybe a
Nothing
    ResolvedName
_ -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$
       [Char]
"The name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" already has non-constructor definitions"
  QName -> TCMT IO QName
forall a. a -> TCMT IO a
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
        Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IsAbstract
a1 IsAbstract -> IsAbstract -> Bool
forall a. Eq a => a -> a -> Bool
== IsAbstract
a) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
        Expr
t' <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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"
        Declaration -> TCMT IO Declaration
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> TCMT IO Declaration)
-> Declaration -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$ KindOfName
-> DefInfo
-> ArgInfo
-> Maybe [Occurrence]
-> QName
-> Expr
-> Declaration
A.Axiom KindOfName
ConName (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo
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 Maybe [Occurrence]
forall a. Maybe a
Nothing QName
y Expr
t'
      NiceDeclaration
_ -> NiceDeclaration -> TCMT IO Declaration
forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d

errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a
errorNotConstrDecl :: forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d = NiceDeclaration -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NiceDeclaration
d (TCMT IO a -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$
  TypeError -> TCMT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO a) -> TypeError -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ [Declaration] -> TypeError
IllegalDeclarationInDataDefinition ([Declaration] -> TypeError) -> [Declaration] -> TypeError
forall a b. (a -> b) -> a -> b
$ 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]]
_ -> [[Char]] -> TCMT IO [Pragma]
forall a. HasCallStack => [[Char]] -> TCM a
impossibleTestReduceM [[Char]]
strs
      [[Char]]
_ -> [[Char]] -> TCMT IO [Pragma]
forall (m :: * -> *) a.
(MonadDebug m, HasCallStack) =>
[[Char]] -> m a
impossibleTest [[Char]]
strs
  toAbstract (C.OptionsPragma Range
_ [[Char]]
opts) = [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ [[Char]] -> Pragma
A.OptionsPragma [[Char]]
opts ]
  toAbstract (C.RewritePragma Range
_ Range
_ []) = [] [Pragma] -> TCMT IO () -> TCMT IO [Pragma]
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
EmptyRewritePragma
  toAbstract (C.RewritePragma Range
_ Range
r [QName]
xs) = Pragma -> [Pragma]
forall el coll. Singleton el coll => el -> coll
singleton (Pragma -> [Pragma])
-> ([[QName]] -> Pragma) -> [[QName]] -> [Pragma]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [QName] -> Pragma
A.RewritePragma Range
r ([QName] -> Pragma)
-> ([[QName]] -> [QName]) -> [[QName]] -> Pragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[QName]] -> [QName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[QName]] -> [Pragma]) -> TCMT IO [[QName]] -> TCMT IO [Pragma]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
   [QName] -> (QName -> TCMT IO [QName]) -> TCMT IO [[QName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QName]
xs ((QName -> TCMT IO [QName]) -> TCMT IO [[QName]])
-> (QName -> TCMT IO [QName]) -> TCMT IO [[QName]]
forall a b. (a -> b) -> a -> b
$ \ QName
x -> do
    Expr
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
    case Expr
e of
      A.Def QName
x          -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
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 -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Proj ProjOrigin
_ AmbiguousQName
x       -> [Char] -> TCMT IO [QName]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [QName]) -> [Char] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
      A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Con AmbiguousQName
x          -> [Char] -> TCMT IO [QName]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [QName]) -> [Char] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
      A.Var Name
x          -> [Char] -> TCMT IO [QName]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [QName]) -> [Char] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on parameter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" instead of on a defined symbol"
      Expr
_       -> TCMT IO [QName]
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (C.ForeignPragma Range
_ RString
rb [Char]
s) = [] [Pragma] -> TCMT IO () -> TCMT IO [Pragma]
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> [Char] -> TCMT IO ()
addForeignCode (RString -> [Char]
forall a. Ranged a -> a
rangedThing RString
rb) [Char]
s
  toAbstract (C.CompilePragma Range
_ RString
rb QName
x [Char]
s) = do
    Maybe Expr
me <- MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName))
-> MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
forall a b. (a -> b) -> a -> b
$ OldQName -> MaybeOldQName
MaybeOldQName (OldQName -> MaybeOldQName) -> OldQName -> MaybeOldQName
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
    case Maybe Expr
me of
      Maybe Expr
Nothing -> [] [Pragma] -> TCMT IO () -> TCMT IO [Pragma]
forall a b. a -> TCMT IO b -> TCMT IO a
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 = [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot COMPILE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
        QName
y <- case Expr
e of
          A.Def QName
x             -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
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 -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
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 -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
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
_                   -> TCMT IO QName
forall a. HasCallStack => a
__IMPOSSIBLE__
        [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
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 <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
      QName
y <- case Expr
e of
          A.Def  QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
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 -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
            [Char]
"STATIC used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of STATIC pragma should be a function"
      [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.StaticPragma QName
y ]
  toAbstract (C.InjectivePragma Range
_ QName
x) = do
      Expr
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
      QName
y <- case Expr
e of
          A.Def  QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
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 -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
            [Char]
"INJECTIVE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of INJECTIVE pragma should be a defined symbol"
      [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
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 <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
      let sINLINE :: [Char]
sINLINE = if Bool
b then [Char]
"INLINE" else [Char]
"NOINLINE"
      let ret :: QName -> TCMT IO [Pragma]
ret QName
y = [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> QName -> Pragma
A.InlinePragma Bool
b QName
y ]
      case Expr
e of
          A.Con (AmbQ NonEmpty QName
xs) -> (QName -> TCMT IO [Pragma]) -> [QName] -> TCMT IO [Pragma]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM QName -> TCMT IO [Pragma]
ret ([QName] -> TCMT IO [Pragma]) -> [QName] -> TCMT IO [Pragma]
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> [Item (NonEmpty QName)]
forall l. IsList l => l -> [Item l]
List1.toList NonEmpty QName
xs
          A.Def  QName
x -> QName -> TCMT IO [Pragma]
ret QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO [Pragma]
ret QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO [Pragma]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [Pragma]) -> [Char] -> TCMT IO [Pragma]
forall a b. (a -> b) -> a -> b
$
            [Char]
sINLINE [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_ -> [Char] -> TCMT IO [Pragma]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [Pragma]) -> [Char] -> TCMT IO [Pragma]
forall a b. (a -> b) -> a -> b
$ ([Char]
"Target of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Bool -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen Bool
b ([Char]
"NO" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [Char]
"INLINE pragma should be a function or constructor"
  toAbstract (C.NotProjectionLikePragma Range
_ QName
x) = do
      Expr
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
      QName
y <- case Expr
e of
          A.Def  QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
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 -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
            [Char]
"NOT_PROJECTION_LIKE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
          Expr
_        -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Target of NOT_PROJECTION_LIKE pragma should be a function"
      [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.NotProjectionLikePragma QName
y ]
  toAbstract (C.BuiltinPragma Range
_ RString
rb QName
qx)
    | Just BuiltinId
b' <- Maybe BuiltinId
b, BuiltinId -> Bool
isUntypedBuiltin BuiltinId
b' = do
        ResolvedName
q <- ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (ResolveQName -> ScopeM (AbsOfCon ResolveQName))
-> ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall a b. (a -> b) -> a -> b
$ QName -> ResolveQName
ResolveQName QName
qx
        BuiltinId -> ResolvedName -> TCMT IO ()
bindUntypedBuiltin BuiltinId
b' ResolvedName
q
        [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
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.
    | Just BuiltinId
b' <- Maybe BuiltinId
b, BuiltinId -> Bool
isBuiltinNoDef BuiltinId
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.
              TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((ResolvedName
UnknownName ResolvedName -> ResolvedName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ResolvedName -> Bool) -> ScopeM ResolvedName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ScopeM ResolvedName
resolveName QName
qx) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
                Doc -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Doc -> m ()
genericWarning (Doc -> TCMT IO ()) -> Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
forall a. [Char] -> Doc a
P.text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$
                   [Char]
"BUILTIN " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuiltinId -> [Char]
forall a. IsBuiltin a => a -> [Char]
getBuiltinId BuiltinId
b' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" declares an identifier " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                   [Char]
"(no longer expects an already defined identifier)"
                (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
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 = KindOfName -> Maybe KindOfName -> KindOfName
forall a. a -> Maybe a -> a
fromMaybe KindOfName
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe KindOfName -> KindOfName) -> Maybe KindOfName -> KindOfName
forall a b. (a -> b) -> a -> b
$ BuiltinId -> Maybe KindOfName
builtinKindOfName BuiltinId
b'
              Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
PublicAccess KindOfName
kind Name
x QName
y
              [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> KindOfName -> QName -> Pragma
A.BuiltinNoDefPragma RString
rb KindOfName
kind QName
y ]
            QName
_ -> [Char] -> ScopeM (AbsOfCon Pragma)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM (AbsOfCon Pragma))
-> [Char] -> ScopeM (AbsOfCon Pragma)
forall a b. (a -> b) -> a -> b
$
              [Char]
"Pragma BUILTIN " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuiltinId -> [Char]
forall a. IsBuiltin a => a -> [Char]
getBuiltinId BuiltinId
b' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": expected unqualified identifier, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              [Char]
"but found " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
qx
    | Bool
otherwise = do
          ResolvedName
q0 <- ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (ResolveQName -> ScopeM (AbsOfCon ResolveQName))
-> ResolveQName -> ScopeM (AbsOfCon ResolveQName)
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, Maybe BuiltinId
b Maybe BuiltinId
-> (BuiltinId -> Maybe KindOfName) -> Maybe KindOfName
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuiltinId -> Maybe KindOfName
builtinKindOfName, QName
qx) of
            (DefinedName Access
acc AbstractName
y Suffix
suffix, Just KindOfName
kind, C.QName Name
x)
              | AbstractName -> KindOfName
anameKind AbstractName
y KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
/= KindOfName
kind
              , KindOfName
kind KindOfName -> [KindOfName] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
y
                  ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> ScopeM ResolvedName)
-> ResolvedName -> ScopeM ResolvedName
forall a b. (a -> b) -> a -> b
$ Access -> AbstractName -> Suffix -> ResolvedName
DefinedName Access
acc AbstractName
y{ anameKind = kind } Suffix
suffix
            (ResolvedName, Maybe KindOfName, QName)
_ -> ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
q0

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

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

  toAbstract (C.DisplayPragma Range
_ Pattern
lhs Expr
rhs) = ScopeM (AbsOfCon Pragma) -> ScopeM (AbsOfCon Pragma)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM (AbsOfCon Pragma) -> ScopeM (AbsOfCon Pragma))
-> ScopeM (AbsOfCon Pragma) -> ScopeM (AbsOfCon Pragma)
forall a b. (a -> b) -> a -> b
$ do
    let err :: TCMT IO a
err = [Char] -> TCMT IO a
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 Bool
_ QName
x)        = QName -> TCMT IO QName
forall a. a -> TCMT IO a
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
_                     = TCMT IO QName
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 Maybe (Set Name)
forall a. Maybe a
Nothing QName
top
      case ResolvedName
qx of
        VarName Name
x' BindingSource
_                -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ List1 Name -> QName
A.qnameFromList (List1 Name -> QName) -> List1 Name -> QName
forall a b. (a -> b) -> a -> b
$ Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
x'
        DefinedName Access
_ AbstractName
d Suffix
NoSuffix    -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        DefinedName Access
_ AbstractName
d Suffix{}    -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid pattern " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top
        FieldName     (AbstractName
d :| [])     -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        FieldName List1 AbstractName
ds                -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous projection " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        ConstructorName Set Induction
_ (AbstractName
d :| []) -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        ConstructorName Set Induction
_ List1 AbstractName
ds        -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous constructor " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
        ResolvedName
UnknownName                 -> QName -> TCMT IO (Bool, QName)
forall a. QName -> TCM a
notInScopeError QName
top
        PatternSynResName (AbstractName
d :| []) -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
True,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
        PatternSynResName List1 AbstractName
ds        -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous pattern synonym" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)

    LHS
lhs <- LeftHandSide -> ScopeM (AbsOfCon LeftHandSide)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (LeftHandSide -> ScopeM (AbsOfCon LeftHandSide))
-> LeftHandSide -> ScopeM (AbsOfCon LeftHandSide)
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) -> [NamedArg Pattern] -> TCMT IO [NamedArg Pattern]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [NamedArg Pattern]
ps
             LHS
_ -> TCMT IO [NamedArg Pattern]
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  = PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP (Range -> PatInfo
PatRange (Range -> PatInfo) -> Range -> PatInfo
forall a b. (a -> b) -> a -> b
$ LHS -> Range
forall a. HasRange a => a -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
              | Bool
otherwise = PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP (Range -> PatInfo
PatRange (Range -> PatInfo) -> Range -> PatInfo
forall a b. (a -> b) -> a -> b
$ LHS -> Range
forall a. HasRange a => a -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
      Pattern
p <- Pattern -> TCMT IO Pattern
forall a. ExpandPatternSynonyms a => a -> TCM a
expandPatternSynonyms (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
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 -> (QName, [NamedArg Pattern]) -> TCMT IO (QName, [NamedArg Pattern])
forall a. a -> TCMT IO a
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 -> (QName, [NamedArg Pattern]) -> TCMT IO (QName, [NamedArg Pattern])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
hd, [NamedArg Pattern]
ps)
        A.PatternSynP{} -> TCMT IO (QName, [NamedArg Pattern])
forall a. HasCallStack => a
__IMPOSSIBLE__
        Pattern
_ -> TCMT IO (QName, [NamedArg Pattern])
forall {a}. TCMT IO a
err

    Expr
rhs <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
    [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
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 <- (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName (List1 AbstractName -> NonEmpty QName)
-> ScopeM (List1 AbstractName) -> TCMT IO (NonEmpty QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ScopeM (List1 AbstractName)
forall a. ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName QName
x
    NonEmpty QName -> (QName -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty QName
ys ((QName -> TCMT IO ()) -> TCMT IO ())
-> (QName -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ QName
qn -> (Map QName Text -> f (Map QName Text)) -> TCState -> f TCState
Lens' TCState (Map QName Text)
stLocalUserWarnings Lens' TCState (Map QName Text)
-> (Map QName Text -> Map QName Text) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> (a -> a) -> m ()
`modifyTCLens` QName -> Text -> Map QName Text -> Map QName Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QName
qn Text
str
    [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

  -- Termination, Coverage, Positivity, Universe, and Catchall
  -- pragmes are handled by the nicifier
  toAbstract C.TerminationCheckPragma{}  = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.NoCoverageCheckPragma{}   = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.NoPositivityCheckPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.NoUniverseCheckPragma{}   = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract C.CatchallPragma{}          = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__

  -- Polarity pragmas are handled by the niceifier.
  toAbstract C.PolarityPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
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) = ScopeM (AbsOfCon Clause) -> ScopeM (AbsOfCon Clause)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM (AbsOfCon Clause) -> ScopeM (AbsOfCon Clause))
-> ScopeM (AbsOfCon Clause) -> ScopeM (AbsOfCon Clause)
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
    (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope_ ((ScopeInfo -> ScopeInfo) -> TCMT IO ())
-> (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ([(Name, LocalVar)] -> [(Name, LocalVar)])
-> ScopeInfo -> ScopeInfo
updateScopeLocals (([(Name, LocalVar)] -> [(Name, LocalVar)])
 -> ScopeInfo -> ScopeInfo)
-> ([(Name, LocalVar)] -> [(Name, LocalVar)])
-> ScopeInfo
-> ScopeInfo
forall a b. (a -> b) -> a -> b
$ ((Name, LocalVar) -> (Name, LocalVar))
-> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a b. (a -> b) -> [a] -> [b]
map (((Name, LocalVar) -> (Name, LocalVar))
 -> [(Name, LocalVar)] -> [(Name, LocalVar)])
-> ((Name, LocalVar) -> (Name, LocalVar))
-> [(Name, LocalVar)]
-> [(Name, LocalVar)]
forall a b. (a -> b) -> a -> b
$ (LocalVar -> LocalVar) -> (Name, LocalVar) -> (Name, LocalVar)
forall b c a. (b -> c) -> (a, b) -> (a, c)
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
    [(Name, LocalVar)]
vars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    LHS
lhs' <- LeftHandSide -> ScopeM (AbsOfCon LeftHandSide)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (LeftHandSide -> ScopeM (AbsOfCon LeftHandSide))
-> LeftHandSide -> ScopeM (AbsOfCon LeftHandSide)
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:"
    [(Name, LocalVar)]
vars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    [RewriteEqn' () BindName Pattern Expr]
eqs <- (RewriteEqn -> TCMT IO (RewriteEqn' () BindName Pattern Expr))
-> [RewriteEqn] -> TCMT IO [RewriteEqn' () BindName Pattern Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Precedence -> RewriteEqn -> ScopeM (AbsOfCon RewriteEqn)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) [RewriteEqn]
eqs
    [(Name, LocalVar)]
vars2 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    let vars :: [(Name, LocalVar)]
vars = Int -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. Int -> [a] -> [a]
dropEnd ([(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, LocalVar)]
vars1) [(Name, LocalVar)]
vars2 [(Name, LocalVar)] -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, LocalVar)]
vars0
    let wcs' :: ([(Name, LocalVar)], [Clause])
wcs' = ([(Name, LocalVar)]
vars, [Clause]
wcs)

    -- Handle rewrite equations first.
    if Bool -> Bool
not ([RewriteEqn' () BindName Pattern Expr] -> Bool
forall a. Null a => a -> Bool
null [RewriteEqn' () BindName Pattern Expr]
eqs)
      then do
        AbstractRHS
rhs <- Precedence -> RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx (RightHandSide -> TCMT IO (AbsOfCon RightHandSide))
-> RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
forall a b. (a -> b) -> a -> b
$ [RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> ([(Name, LocalVar)], [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [RewriteEqn' () BindName Pattern Expr]
eqs [WithExpr]
with ([(Name, LocalVar)], [Clause])
wcs' RHS' Expr
rhs WhereClause' [Declaration]
wh
        RHS
rhs <- AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract AbstractRHS
rhs
        Clause -> TCMT IO Clause
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> TCMT IO Clause) -> Clause -> TCMT IO Clause
forall a b. (a -> b) -> a -> b
$ LHS -> [ProblemEq] -> RHS -> WhereDeclarations -> Bool -> Clause
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) <- Range
-> WhereClause' [Declaration]
-> TCMT IO AbstractRHS
-> ScopeM (AbstractRHS, WhereDeclarations)
forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract (WhereClause' [Declaration] -> Range
forall a. HasRange a => a -> Range
getRange WhereClause' [Declaration]
wh) WhereClause' [Declaration]
wh (TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations))
-> TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
                       Precedence -> RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx (RightHandSide -> TCMT IO (AbsOfCon RightHandSide))
-> RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
forall a b. (a -> b) -> a -> b
$ [RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> ([(Name, LocalVar)], [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [] [WithExpr]
with ([(Name, LocalVar)], [Clause])
wcs' RHS' Expr
rhs WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere
        RHS
rhs <- AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract AbstractRHS
rhs
        Clause -> TCMT IO Clause
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> TCMT IO Clause) -> Clause -> TCMT IO Clause
forall a b. (a -> b) -> a -> b
$ LHS -> [ProblemEq] -> RHS -> WhereDeclarations -> Bool -> Clause
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 -> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a. ScopeM a -> ScopeM a
enter (ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$ do
      -- Andreas, 2016-07-17 issues #2081 and #2101
      -- where-declarations are automatically private.
      -- This allows their type signature to be checked InAbstractMode.
      Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
forall a.
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Erased
defaultErased Maybe (Name, Access)
forall a. Maybe a
Nothing
        (Declaration -> List1 Declaration
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> List1 Declaration)
-> Declaration -> List1 Declaration
forall a b. (a -> b) -> a -> b
$ Range -> Origin -> [Declaration] -> Declaration
C.Private Range
forall a. Range' a
noRange Origin
Inserted [Declaration]
ds) ScopeM a
inner
    SomeWhere Range
_ Erased
e Name
m Access
a [Declaration]
ds0 -> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a. ScopeM a -> ScopeM a
enter (ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
      [Declaration]
-> ScopeM (a, WhereDeclarations)
-> (List1 Declaration -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations)
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [Declaration]
ds0 ScopeM (a, WhereDeclarations)
warnEmptyWhere {-else-} ((List1 Declaration -> ScopeM (a, WhereDeclarations))
 -> ScopeM (a, WhereDeclarations))
-> (List1 Declaration -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$ \List1 Declaration
ds -> do
      -- Named where-modules do not default to private.
      Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
forall a.
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Erased
e ((Name, Access) -> Maybe (Name, Access)
forall a. a -> Maybe a
Just (Name
m, Access
a)) List1 Declaration
ds ScopeM a
inner
  where
  enter :: TCMT IO a -> TCMT IO a
enter = (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall a. (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC ((TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a)
-> (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ \TCEnv
env -> TCEnv
env { envCheckingWhere = True }
  ret :: ScopeM (a, WhereDeclarations)
ret = (,WhereDeclarations
A.noWhereDecls) (a -> (a, WhereDeclarations))
-> ScopeM a -> ScopeM (a, WhereDeclarations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM a
inner
  warnEmptyWhere :: ScopeM (a, WhereDeclarations)
warnEmptyWhere = do
    Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
EmptyWhere
    ScopeM (a, WhereDeclarations)
ret

whereToAbstract1
  :: Range                            -- ^ The range of the @where@-block.
  -> Erased                           -- ^ Is the where module erased?
  -> 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
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Erased
e Maybe (Name, Access)
whname List1 Declaration
whds ScopeM a
inner = do
  -- ASR (16 November 2015) Issue 1137: We ban termination
  -- pragmas inside `where` clause.
  WhereOrRecord -> List1 Declaration -> TCMT IO ()
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 (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
m) -> (Name, Access) -> TCMT IO (Name, Access)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
m, Access
acc)
      Maybe (Name, Access)
_ -> TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh TCMT IO NameId
-> (NameId -> (Name, Access)) -> TCMT IO (Name, Access)
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ NameId
x -> (Range -> NameId -> Name
C.NoName (Maybe (Name, Access) -> Range
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 <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
  ModuleName
am  <- NewModuleName -> ScopeM (AbsOfCon NewModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> NewModuleName
NewModuleName Name
m)
  (ScopeInfo
scope, Declaration
d) <- Range
-> Erased
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r Erased
e (Name -> QName
C.QName Name
m) ModuleName
am [] (ScopeM [Declaration] -> TCMT IO (ScopeInfo, Declaration))
-> ScopeM [Declaration] -> TCMT IO (ScopeInfo, Declaration)
forall a b. (a -> b) -> a -> b
$
                Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Declarations -> ScopeM (AbsOfCon Declarations))
-> Declarations -> ScopeM (AbsOfCon Declarations)
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Declarations
Declarations ([Declaration] -> Declarations) -> [Declaration] -> Declarations
forall a b. (a -> b) -> a -> b
$ List1 Declaration -> [Item (List1 Declaration)]
forall l. IsList l => l -> [Item l]
List1.toList List1 Declaration
whds
  ScopeInfo -> TCMT IO ()
setScope ScopeInfo
scope
  a
x <- ScopeM a
inner
  ModuleName -> TCMT IO ()
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 = Bool -> ((Name, Access) -> Bool) -> Maybe (Name, Access) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName (Name -> Bool)
-> ((Name, Access) -> Name) -> (Name, Access) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Access) -> Name
forall a b. (a, b) -> a
fst) Maybe (Name, Access)
whname
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
anonymousSomeWhere (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
   TCMT IO ImportDirective -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TCMT IO ImportDirective -> TCMT IO ())
-> TCMT IO ImportDirective -> TCMT IO ()
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 (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
am) (Name -> QName
C.QName Name
m) (ImportDirective -> TCMT IO ImportDirective)
-> ImportDirective -> TCMT IO ImportDirective
forall a b. (a -> b) -> a -> b
$
      ImportDirective
forall n m. ImportDirective' n m
defaultImportDir { publicOpen = Just noRange }
  (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Maybe ModuleName -> Bool -> Maybe Declaration -> WhereDeclarations
A.WhereDecls (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
am) (Maybe (Name, Access) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Name, Access)
whname) (Maybe Declaration -> WhereDeclarations)
-> Maybe Declaration -> WhereDeclarations
forall a b. (a -> b) -> a -> b
$ Declaration -> Maybe Declaration
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]
(Int -> TerminationOrPositivity -> [Char] -> [Char])
-> (TerminationOrPositivity -> [Char])
-> ([TerminationOrPositivity] -> [Char] -> [Char])
-> Show TerminationOrPositivity
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TerminationOrPositivity -> [Char] -> [Char]
showsPrec :: Int -> TerminationOrPositivity -> [Char] -> [Char]
$cshow :: TerminationOrPositivity -> [Char]
show :: TerminationOrPositivity -> [Char]
$cshowList :: [TerminationOrPositivity] -> [Char] -> [Char]
showList :: [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 =
  ((TerminationOrPositivity, Range) -> TCMT IO ())
-> [(TerminationOrPositivity, Range)] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (TerminationOrPositivity
p, Range
r) -> Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Range -> Doc -> Warning
GenericUseless Range
r (Doc -> Warning) -> Doc -> Warning
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
P.vcat [ [Char] -> Doc
forall a. [Char] -> Doc a
P.text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ TerminationOrPositivity -> [Char]
forall a. Show a => a -> [Char]
show TerminationOrPositivity
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" pragmas are ignored in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WhereOrRecord -> [Char]
forall {a}. IsString a => WhereOrRecord -> a
what WhereOrRecord
b
                                                         , [Char] -> Doc
forall a. [Char] -> Doc a
P.text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"(see " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WhereOrRecord -> [Char]
issue WhereOrRecord
b [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" ])
        ((Declaration -> [(TerminationOrPositivity, Range)])
-> f Declaration -> [(TerminationOrPositivity, Range)]
forall m a. Monoid m => (a -> m) -> f a -> m
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/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
n
    issue :: WhereOrRecord -> [Char]
issue WhereOrRecord
InWhereBlock = Integer -> [Char]
forall a. Show a => a -> [Char]
github Integer
3355
    issue WhereOrRecord
InRecordDef  = Integer -> [Char]
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) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Abstract Range
_        [Declaration]
ds) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.InstanceB Range
_       [Declaration]
ds) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Mutual Range
_          [Declaration]
ds) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Module Range
_ Erased
_ QName
_ Telescope
_    [Declaration]
ds) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Macro Range
_           [Declaration]
ds) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [(TerminationOrPositivity, Range)]
terminationPragmas [Declaration]
ds
terminationPragmas (C.Record Range
_ Erased
_ Name
_ RecordDirectives
_ [LamBinding' TypedBinding]
_ Expr
_
                                        [Declaration]
ds) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
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) = (Declaration -> [(TerminationOrPositivity, Range)])
-> [Declaration] -> [(TerminationOrPositivity, Range)]
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 -> ([(Name, LocalVar)], [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] (List1 (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 <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
  QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
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
_ <- TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
  Name -> TCMT IO QName
qualifyName_ (Name -> TCMT IO QName) -> ScopeM Name -> TCMT IO QName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> ScopeM Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => [Char] -> m Name
freshName_ ([Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
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 -> (List1 (QName, Expr)
 -> AbsOfCon (RewriteEqn' () BindName Pattern Expr))
-> TCMT IO (List1 (QName, Expr))
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap List1 (QName, Expr) -> RewriteEqn' QName BindName Pattern Expr
List1 (QName, Expr)
-> AbsOfCon (RewriteEqn' () BindName Pattern Expr)
forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite (TCMT IO (List1 (QName, Expr))
 -> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr)))
-> TCMT IO (List1 (QName, Expr))
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
forall a b. (a -> b) -> a -> b
$ List1 ((), Expr)
-> (((), Expr) -> TCMT IO (QName, Expr))
-> TCMT IO (List1 (QName, Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 ((), Expr)
es ((((), Expr) -> TCMT IO (QName, Expr))
 -> TCMT IO (List1 (QName, Expr)))
-> (((), Expr) -> TCMT IO (QName, Expr))
-> TCMT IO (List1 (QName, Expr))
forall a b. (a -> b) -> a -> b
$ \ (()
_, Expr
e) -> do
      QName
qn <- [Char] -> TCMT IO QName
withFunctionName [Char]
"-rewrite"
      (QName, Expr) -> TCMT IO (QName, Expr)
forall a. a -> TCMT IO a
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"
      RewriteEqn' QName BindName Pattern Expr
-> TCMT IO (RewriteEqn' QName BindName Pattern Expr)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewriteEqn' QName BindName Pattern Expr
 -> TCMT IO (RewriteEqn' QName BindName Pattern Expr))
-> RewriteEqn' QName BindName Pattern Expr
-> TCMT IO (RewriteEqn' QName BindName Pattern Expr)
forall a b. (a -> b) -> a -> b
$ QName
-> List1 (Named BindName (Pattern, Expr))
-> RewriteEqn' QName BindName Pattern Expr
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   -> List1 ((), Expr) -> RewriteEqn' () BindName Pattern Expr
forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite (List1 ((), Expr) -> RewriteEqn' () BindName Pattern Expr)
-> TCMT IO (List1 ((), Expr))
-> TCMT IO (RewriteEqn' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((), Expr) -> TCMT IO ((), Expr))
-> List1 ((), Expr) -> TCMT IO (List1 ((), Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((), Expr) -> TCMT IO ((), Expr)
((), Expr) -> ScopeM (AbsOfCon ((), Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract List1 ((), Expr)
es
    Invert ()
_ List1 (Named Name (Pattern, Expr))
npes -> ()
-> List1 (Named BindName (Pattern, Expr))
-> RewriteEqn' () BindName Pattern Expr
forall qn nm p e.
qn -> List1 (Named nm (p, e)) -> RewriteEqn' qn nm p e
Invert () (List1 (Named BindName (Pattern, Expr))
 -> RewriteEqn' () BindName Pattern Expr)
-> TCMT IO (List1 (Named BindName (Pattern, Expr)))
-> TCMT IO (RewriteEqn' () BindName Pattern Expr)
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) = NonEmpty ((Maybe Name, Pattern), Expr)
-> (NonEmpty (Maybe Name, Pattern), List1 Expr)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
List1.unzip
                    (NonEmpty ((Maybe Name, Pattern), Expr)
 -> (NonEmpty (Maybe Name, Pattern), List1 Expr))
-> NonEmpty ((Maybe Name, Pattern), Expr)
-> (NonEmpty (Maybe Name, Pattern), List1 Expr)
forall a b. (a -> b) -> a -> b
$ (Named Name (Pattern, Expr) -> ((Maybe Name, Pattern), Expr))
-> List1 (Named Name (Pattern, Expr))
-> NonEmpty ((Maybe Name, Pattern), Expr)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty 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 <- List1 Expr -> ScopeM (AbsOfCon (List1 Expr))
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 <- NonEmpty (Maybe Name, Pattern)
-> ((Maybe Name, Pattern) -> TCMT IO (Maybe BindName, Pattern))
-> TCMT IO (NonEmpty (Maybe BindName, Pattern))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Maybe Name, Pattern)
nps (((Maybe Name, Pattern) -> TCMT IO (Maybe BindName, Pattern))
 -> TCMT IO (NonEmpty (Maybe BindName, Pattern)))
-> ((Maybe Name, Pattern) -> TCMT IO (Maybe BindName, Pattern))
-> TCMT IO (NonEmpty (Maybe BindName, Pattern))
forall a b. (a -> b) -> a -> b
$ \ (Maybe Name
n, Pattern
p) -> do
        -- first the pattern
        -- Expand puns if optHiddenArgumentPuns is True.
        Bool
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
        Pattern
p <- Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ if Bool
puns then KillRangeT Pattern
expandPuns Pattern
p else Pattern
p
        Pattern
p <- Pattern -> TCMT IO Pattern
parsePattern Pattern
p
        Pattern' Expr
p <- Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
        Pattern' Expr -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) p.
(Monad m, APatternLike p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p (TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ())
-> ([Name] -> TypeError) -> [Name] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> TypeError
RepeatedVariablesInPattern)
        TCMT IO ()
bindVarsToBind
        Pattern
p <- Pattern' Expr -> ScopeM (AbsOfCon (Pattern' Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern' Expr
p
        -- and then the name
        Maybe BindName
n <- Maybe (NewName BoundName)
-> ScopeM (AbsOfCon (Maybe (NewName BoundName)))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Maybe (NewName BoundName)
 -> ScopeM (AbsOfCon (Maybe (NewName BoundName))))
-> Maybe (NewName BoundName)
-> ScopeM (AbsOfCon (Maybe (NewName BoundName)))
forall a b. (a -> b) -> a -> b
$ (Name -> NewName BoundName)
-> Maybe Name -> Maybe (NewName BoundName)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
WithBound (BoundName -> NewName BoundName)
-> (Name -> BoundName) -> Name -> NewName BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BoundName
C.mkBoundName_) Maybe Name
n
        (Maybe BindName, Pattern) -> TCMT IO (Maybe BindName, Pattern)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe BindName
n, Pattern
p)
      -- we finally reassemble the telescope
      List1 (Named BindName (Pattern, Expr))
-> TCMT IO (List1 (Named BindName (Pattern, Expr)))
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (List1 (Named BindName (Pattern, Expr))
 -> TCMT IO (List1 (Named BindName (Pattern, Expr))))
-> List1 (Named BindName (Pattern, Expr))
-> TCMT IO (List1 (Named BindName (Pattern, Expr)))
forall a b. (a -> b) -> a -> b
$ ((Maybe BindName, Pattern)
 -> Expr -> Named BindName (Pattern, Expr))
-> NonEmpty (Maybe BindName, Pattern)
-> NonEmpty Expr
-> List1 (Named BindName (Pattern, Expr))
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
List1.zipWith (\ (Maybe BindName
n,Pattern
p) Expr
e -> Maybe BindName -> (Pattern, Expr) -> Named BindName (Pattern, Expr)
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'            = RHS -> TCMT IO RHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RHS
A.AbsurdRHS
  toAbstract (RHS' Expr
e Expr
c)            = AbsOfCon AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon AbstractRHS -> ScopeM (AbsOfCon AbstractRHS))
-> AbsOfCon AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall a b. (a -> b) -> a -> b
$ Expr -> TacticAttribute -> RHS
A.RHS Expr
e (TacticAttribute -> RHS) -> TacticAttribute -> RHS
forall a b. (a -> b) -> a -> b
$ Expr -> TacticAttribute
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 <- [RewriteEqn' () BindName Pattern Expr]
-> ScopeM (AbsOfCon [RewriteEqn' () BindName Pattern Expr])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [RewriteEqn' () BindName Pattern Expr]
eqs
    RHS
rhs <- AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract AbstractRHS
rhs
    RHS -> TCMT IO RHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS -> TCMT IO RHS) -> RHS -> TCMT IO RHS
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 List1 (TCMT IO Clause)
cs) = do
    QName
aux <- [Char] -> TCMT IO QName
withFunctionName [Char]
"with-"
    QName -> [WithExpr] -> List1 Clause -> RHS
A.WithRHS QName
aux [WithExpr]
es (List1 Clause -> RHS) -> TCMT IO (List1 Clause) -> TCMT IO RHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do NonEmpty Clause -> TCMT IO (List1 Clause)
NonEmpty Clause -> ScopeM (AbsOfCon (NonEmpty Clause))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (NonEmpty Clause -> TCMT IO (List1 Clause))
-> TCMT IO (NonEmpty Clause) -> TCMT IO (List1 Clause)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< List1 (TCMT IO Clause) -> TCMT IO (NonEmpty Clause)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
sequence List1 (TCMT IO Clause)
cs

instance ToAbstract RightHandSide where
  type AbsOfCon RightHandSide = AbstractRHS
  toAbstract :: RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
toAbstract (RightHandSide eqs :: [RewriteEqn' () BindName Pattern Expr]
eqs@(RewriteEqn' () BindName Pattern Expr
_:[RewriteEqn' () BindName Pattern Expr]
_) [WithExpr]
es ([(Name, LocalVar)], [Clause])
cs RHS' Expr
rhs WhereClause' [Declaration]
wh)               = do
    (AbstractRHS
rhs, WhereDeclarations
ds) <- Range
-> WhereClause' [Declaration]
-> TCMT IO AbstractRHS
-> ScopeM (AbstractRHS, WhereDeclarations)
forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract (WhereClause' [Declaration] -> Range
forall a. HasRange a => a -> Range
getRange WhereClause' [Declaration]
wh) WhereClause' [Declaration]
wh (TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations))
-> TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
                   RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> ([(Name, LocalVar)], [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [] [WithExpr]
es ([(Name, LocalVar)], [Clause])
cs RHS' Expr
rhs WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere)
    AbstractRHS -> TCMT IO AbstractRHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractRHS -> TCMT IO AbstractRHS)
-> AbstractRHS -> TCMT IO AbstractRHS
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 [] []    ([(Name, LocalVar)]
_  , Clause
_:[Clause]
_) RHS' Expr
_          WhereClause' [Declaration]
_)  = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] (WithExpr
_:[WithExpr]
_) ([(Name, LocalVar)], [Clause])
_         (C.RHS Expr
_)   WhereClause' [Declaration]
_)  = TypeError -> TCMT IO (AbsOfCon RightHandSide)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (AbsOfCon RightHandSide))
-> TypeError -> TCMT IO (AbsOfCon RightHandSide)
forall a b. (a -> b) -> a -> b
$ TypeError
BothWithAndRHS
  toAbstract (RightHandSide [] []    ([(Name, LocalVar)]
_  , []) RHS' Expr
rhs         WhereClause' [Declaration]
NoWhere) = RHS' Expr -> ScopeM (AbsOfCon (RHS' Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract RHS' Expr
rhs
  toAbstract (RightHandSide [] [WithExpr]
nes   ([(Name, LocalVar)]
lv , Clause
c:[Clause]
cs) RHS' Expr
C.AbsurdRHS WhereClause' [Declaration]
NoWhere) = do
    let ([Maybe (NewName BoundName)]
ns , [Arg Expr]
es) = (WithExpr -> (Maybe (NewName BoundName), Arg Expr))
-> [WithExpr] -> ([Maybe (NewName BoundName)], [Arg Expr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
unzipWith (\ (Named Maybe Name
nm Arg Expr
e) -> (BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
WithBound (BoundName -> NewName BoundName)
-> (Name -> BoundName) -> Name -> NewName BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BoundName
C.mkBoundName_ (Name -> NewName BoundName)
-> Maybe Name -> Maybe (NewName BoundName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
nm, Arg Expr
e)) [WithExpr]
nes
    [Arg Expr]
es <- Precedence -> [Arg Expr] -> ScopeM (AbsOfCon [Arg Expr])
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx [Arg Expr]
es
    [(Name, LocalVar)]
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    [Maybe BindName]
ns <- [Maybe (NewName BoundName)]
-> ScopeM (AbsOfCon [Maybe (NewName BoundName)])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Maybe (NewName BoundName)]
ns
    [(Name, LocalVar)]
lvars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    let lv' :: [(Name, LocalVar)]
lv' = Int -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. Int -> [a] -> [a]
dropEnd ([(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, LocalVar)]
lvars0) [(Name, LocalVar)]
lvars1 [(Name, LocalVar)] -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, LocalVar)]
lv
    let cs' :: List1 (TCMT IO Clause)
cs' = NonEmpty Clause
-> (Clause -> TCMT IO Clause) -> List1 (TCMT IO Clause)
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for (Clause
cClause -> [Clause] -> NonEmpty Clause
forall a. a -> [a] -> NonEmpty a
:|[Clause]
cs) ((Clause -> TCMT IO Clause) -> List1 (TCMT IO Clause))
-> (Clause -> TCMT IO Clause) -> List1 (TCMT IO Clause)
forall a b. (a -> b) -> a -> b
$ \ Clause
c -> [(Name, LocalVar)] -> TCMT IO ()
setLocalVars [(Name, LocalVar)]
lv' TCMT IO () -> Clause -> TCMT IO Clause
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Clause
c
    let nes :: [WithExpr]
nes = (Maybe BindName -> Arg Expr -> WithExpr)
-> [Maybe BindName] -> [Arg Expr] -> [WithExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe BindName -> Arg Expr -> WithExpr
forall name a. Maybe name -> a -> Named name a
Named [Maybe BindName]
ns [Arg Expr]
es
    AbstractRHS -> TCMT IO AbstractRHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractRHS -> TCMT IO AbstractRHS)
-> AbstractRHS -> TCMT IO AbstractRHS
forall a b. (a -> b) -> a -> b
$ [WithExpr] -> List1 (TCMT IO Clause) -> AbstractRHS
WithRHS' [WithExpr]
nes List1 (TCMT IO Clause)
cs'
  -- TODO: some of these might be possible
  toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ RHS' Expr
C.AbsurdRHS  AnyWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ RHS' Expr
C.AbsurdRHS SomeWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ RHS' Expr
C.AbsurdRHS   NoWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     ([(Name, LocalVar)]
_, []) RHS' Expr
C.AbsurdRHS  AnyWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     ([(Name, LocalVar)]
_, []) RHS' Expr
C.AbsurdRHS SomeWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     ([(Name, LocalVar)]
_, []) C.RHS{}      AnyWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] []     ([(Name, LocalVar)]
_, []) C.RHS{}     SomeWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
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 = AbstractRHS -> TCMT IO AbstractRHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractRHS -> TCMT IO AbstractRHS)
-> AbstractRHS -> TCMT IO AbstractRHS
forall a b. (a -> b) -> a -> b
$ AbstractRHS
AbsurdRHS'
    toAbstract (C.RHS Expr
e)   = Expr -> Expr -> AbstractRHS
RHS' (Expr -> Expr -> AbstractRHS)
-> ScopeM Expr -> TCMT IO (Expr -> AbstractRHS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e TCMT IO (Expr -> AbstractRHS)
-> TCMT IO Expr -> TCMT IO AbstractRHS
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
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) =
      Call
-> ScopeM (AbsOfCon LeftHandSide) -> ScopeM (AbsOfCon LeftHandSide)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (QName -> Pattern -> Call
ScopeCheckLHS QName
top Pattern
lhs) (ScopeM (AbsOfCon LeftHandSide) -> ScopeM (AbsOfCon LeftHandSide))
-> ScopeM (AbsOfCon LeftHandSide) -> ScopeM (AbsOfCon LeftHandSide)
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
5 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"original lhs: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Pattern
lhs
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"patternQNames: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [QName] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Pattern -> [QName]
forall p. CPatternLike p => p -> [QName]
patternQNames Pattern
lhs)
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"original lhs (raw): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
lhs

        -- Expand puns if optHiddenArgumentPuns is True. Note that pun
        -- expansion should happen before the left-hand side is
        -- parsed, because {(x)} is not treated as a pun, whereas {x}
        -- is.
        Bool
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
        Pattern
lhs  <- Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ if Bool
puns then KillRangeT Pattern
expandPuns Pattern
lhs else Pattern
lhs
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
5 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"lhs with expanded puns: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Pattern
lhs
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"lhs with expanded puns (raw): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
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
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
5 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LHSCore -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow LHSCore
lhscore
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs (raw): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LHSCore -> [Char]
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
        TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optCopatterns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LHSCore -> Bool
hasCopatterns LHSCore
lhscore) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError
NeedOptionCopatterns
        -- scope check patterns except for dot patterns
        LHSCore' Expr
lhscore <- LHSCore -> ScopeM (AbsOfCon 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'
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs patterns: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LHSCore' Expr -> [Char]
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 <- LHSCore' Expr -> ScopeM (AbsOfCon (LHSCore' Expr))
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'
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parsed lhs dot patterns: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LHSCore' Expr -> [Char]
forall a. Show a => a -> [Char]
show LHSCore' Expr
lhscore
        Int -> [Char] -> TCMT IO ()
printLocals Int
10 [Char]
"checked dots:"
        LHS -> TCMT IO LHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHS -> TCMT IO LHS) -> LHS -> TCMT IO LHS
forall a b. (a -> b) -> a -> b
$ LHSInfo -> LHSCore' Expr -> LHS
A.LHS (Range -> ExpandedEllipsis -> LHSInfo
LHSInfo (Pattern -> Range
forall a. HasRange a => a -> Range
getRange Pattern
lhs) ExpandedEllipsis
ell) LHSCore' Expr
lhscore

-- | Expands hidden argument puns.

expandPuns :: C.Pattern -> C.Pattern
expandPuns :: KillRangeT Pattern
expandPuns Pattern
p = case Pattern
p of
  C.AppP Pattern
p1 NamedArg Pattern
p2       -> Pattern -> NamedArg Pattern -> Pattern
C.AppP (KillRangeT Pattern
expandPuns Pattern
p1)
                          (((Named NamedName Pattern -> Named NamedName Pattern)
-> NamedArg Pattern -> NamedArg Pattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named NamedName Pattern -> Named NamedName Pattern)
 -> NamedArg Pattern -> NamedArg Pattern)
-> (KillRangeT Pattern
    -> Named NamedName Pattern -> Named NamedName Pattern)
-> KillRangeT Pattern
-> NamedArg Pattern
-> NamedArg Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KillRangeT Pattern
expandPuns NamedArg Pattern
p2)
  C.RawAppP Range
r List2 Pattern
ps     -> Range -> List2 Pattern -> Pattern
C.RawAppP Range
r (KillRangeT Pattern -> List2 Pattern -> List2 Pattern
forall a b. (a -> b) -> List2 a -> List2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns List2 Pattern
ps)
  C.OpAppP Range
r QName
q Set Name
xs [NamedArg Pattern]
ps -> Range -> QName -> Set Name -> [NamedArg Pattern] -> Pattern
C.OpAppP Range
r QName
q Set Name
xs
                          (((NamedArg Pattern -> NamedArg Pattern)
-> [NamedArg Pattern] -> [NamedArg Pattern]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NamedArg Pattern -> NamedArg Pattern)
 -> [NamedArg Pattern] -> [NamedArg Pattern])
-> (KillRangeT Pattern -> NamedArg Pattern -> NamedArg Pattern)
-> KillRangeT Pattern
-> [NamedArg Pattern]
-> [NamedArg Pattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Pattern -> Named NamedName Pattern)
-> NamedArg Pattern -> NamedArg Pattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named NamedName Pattern -> Named NamedName Pattern)
 -> NamedArg Pattern -> NamedArg Pattern)
-> (KillRangeT Pattern
    -> Named NamedName Pattern -> Named NamedName Pattern)
-> KillRangeT Pattern
-> NamedArg Pattern
-> NamedArg Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KillRangeT Pattern
expandPuns [NamedArg Pattern]
ps)
  C.ParenP Range
r Pattern
p       -> Range -> KillRangeT Pattern
C.ParenP Range
r (KillRangeT Pattern
expandPuns Pattern
p)
  C.AsP Range
r Name
x Pattern
p        -> Range -> Name -> KillRangeT Pattern
C.AsP Range
r Name
x (KillRangeT Pattern
expandPuns Pattern
p)
  C.RecP Range
r [FieldAssignment' Pattern]
ps        -> Range -> [FieldAssignment' Pattern] -> Pattern
C.RecP Range
r ((FieldAssignment' Pattern -> FieldAssignment' Pattern)
-> [FieldAssignment' Pattern] -> [FieldAssignment' Pattern]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KillRangeT Pattern
-> FieldAssignment' Pattern -> FieldAssignment' Pattern
forall a b. (a -> b) -> FieldAssignment' a -> FieldAssignment' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns) [FieldAssignment' Pattern]
ps)
  C.WithP Range
r Pattern
p        -> Range -> KillRangeT Pattern
C.WithP Range
r (KillRangeT Pattern
expandPuns Pattern
p)
  C.EllipsisP Range
r Maybe Pattern
mp   -> Range -> Maybe Pattern -> Pattern
C.EllipsisP Range
r (KillRangeT Pattern -> Maybe Pattern -> Maybe Pattern
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Maybe Pattern
mp)
  C.IdentP{}         -> Pattern
p
  C.QuoteP{}         -> Pattern
p
  C.WildP{}          -> Pattern
p
  C.AbsurdP{}        -> Pattern
p
  C.DotP{}           -> Pattern
p
  C.LitP{}           -> Pattern
p
  C.EqualP{}         -> Pattern
p

  C.HiddenP Range
r Named NamedName Pattern
p   -> Range -> Named NamedName Pattern -> Pattern
C.HiddenP Range
r (Named NamedName Pattern -> Named NamedName Pattern
expand (KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Named NamedName Pattern
p))
  C.InstanceP Range
r Named NamedName Pattern
p -> Range -> Named NamedName Pattern -> Pattern
C.InstanceP Range
r (Named NamedName Pattern -> Named NamedName Pattern
expand (KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Named NamedName Pattern
p))
  where
  -- Only patterns of the form {x} or ⦃ x ⦄, where x is an unqualified
  -- name (not @_@), are interpreted as puns.
  expand :: Named_ C.Pattern -> Named_ C.Pattern
  expand :: Named NamedName Pattern -> Named NamedName Pattern
expand (Named { nameOf :: forall name a. Named name a -> Maybe name
nameOf     = Maybe NamedName
Nothing
                , namedThing :: forall name a. Named name a -> a
namedThing = C.IdentP Bool
_ q :: QName
q@(C.QName x :: Name
x@C.Name{})
                }) =
    Named { namedThing :: Pattern
namedThing = Bool -> QName -> Pattern
C.IdentP Bool
False QName
q
          , nameOf :: Maybe NamedName
nameOf     = NamedName -> Maybe NamedName
forall a. a -> Maybe a
Just (NamedName -> Maybe NamedName) -> NamedName -> Maybe NamedName
forall a b. (a -> b) -> a -> b
$
                         WithOrigin
                           { woOrigin :: Origin
woOrigin = Origin
ExpandedPun
                           , woThing :: RString
woThing  = [Char] -> RString
forall a. a -> Ranged a
unranged (Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
                           }
          }
  expand Named NamedName Pattern
p = Named NamedName Pattern
p

hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis
hasExpandedEllipsis :: LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
core = case LHSCore
core of
  C.LHSHead{}       -> ExpandedEllipsis
NoEllipsis
  C.LHSProj{}       -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis (LHSCore -> ExpandedEllipsis) -> LHSCore -> ExpandedEllipsis
forall a b. (a -> b) -> a -> b
$ NamedArg LHSCore -> LHSCore
forall a. NamedArg a -> a
namedArg (NamedArg LHSCore -> LHSCore) -> NamedArg LHSCore -> LHSCore
forall a b. (a -> b) -> a -> b
$ LHSCore -> NamedArg LHSCore
C.lhsFocus LHSCore
core -- can this ever be ExpandedEllipsis?
  C.LHSWith{}       -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis (LHSCore -> ExpandedEllipsis) -> LHSCore -> ExpandedEllipsis
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 ExpandedEllipsis -> ExpandedEllipsis -> ExpandedEllipsis
forall a. Semigroup a => a -> a -> a
<> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r ([Pattern] -> Int
forall a. [a] -> Int
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{}   -> ExpandedEllipsis
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 = (PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall {e}.
(PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go (PatInfo
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) = Arg (Named NamedName (Pattern' e))
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Arg (Named NamedName (Pattern' e))
p (TCMT IO [Arg (Named NamedName (Pattern' e))]
 -> TCMT IO [Arg (Named NamedName (Pattern' e))])
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall a b. (a -> b) -> a -> b
$ do
      -- Face constraint patterns must be defaultNamedArg; check this:
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality ArgInfo
i Modality -> Modality -> Bool
forall a. Eq a => a -> a -> Bool
== Modality
defaultModality) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
hidden     ArgInfo
i) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Doc -> TCMT IO ()
forall {m :: * -> *} {a}.
(MonadWarning m, HasRange a) =>
a -> Doc -> m ()
warn ArgInfo
i (Doc -> TCMT IO ()) -> Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Face constraint patterns cannot be hidden arguments"
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
isInstance ArgInfo
i) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Doc -> TCMT IO ()
forall {m :: * -> *} {a}.
(MonadWarning m, HasRange a) =>
a -> Doc -> m ()
warn ArgInfo
i (Doc -> TCMT IO ()) -> Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Face constraint patterns cannot be instance arguments"
      Maybe NamedName -> (NamedName -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe NamedName
mn ((NamedName -> TCMT IO ()) -> TCMT IO ())
-> (NamedName -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ NamedName
x -> NamedName -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedName
x (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NamedName -> Doc -> TCMT IO ()
forall {m :: * -> *} {a}.
(MonadWarning m, HasRange a) =>
a -> Doc -> m ()
warn NamedName
x (Doc -> TCMT IO ()) -> Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
P.hcat
          [ Doc
"Ignoring name `", NamedName -> Doc
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 (PatInfo, [(e, e)]) -> (PatInfo, [(e, e)]) -> (PatInfo, [(e, e)])
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 = (Pattern' e -> Arg (Named NamedName (Pattern' e))
forall a. a -> NamedArg a
defaultNamedArg (PatInfo -> [(e, e)] -> Pattern' e
forall e. PatInfo -> [(e, e)] -> Pattern' e
A.EqualP PatInfo
r [(e, e)]
es) Arg (Named NamedName (Pattern' e))
-> [Arg (Named NamedName (Pattern' e))]
-> [Arg (Named NamedName (Pattern' e))]
forall a. a -> [a] -> [a]
:) ([Arg (Named NamedName (Pattern' e))]
 -> [Arg (Named NamedName (Pattern' e))])
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs [Arg (Named NamedName (Pattern' e))]
ps
    go (PatInfo
_, []) []       = [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall a. a -> TCMT IO a
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 Arg (Named NamedName (Pattern' e))
-> [Arg (Named NamedName (Pattern' e))]
-> [Arg (Named NamedName (Pattern' e))]
forall a. a -> [a] -> [a]
:) ([Arg (Named NamedName (Pattern' e))]
 -> [Arg (Named NamedName (Pattern' e))])
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
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 = Warning -> m ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> m ()) -> Warning -> m ()
forall a b. (a -> b) -> a -> b
$ Range -> Doc -> Warning
GenericUseless (a -> Range
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 <- TCMT IO QName -> TCMT IO QName
forall a. ScopeM a -> ScopeM a
withLocalVars (TCMT IO QName -> TCMT IO QName) -> TCMT IO QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ do
          [(Name, LocalVar)] -> TCMT IO ()
setLocalVars []
          OldName QName -> ScopeM (AbsOfCon (OldName QName))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldName QName
forall a. a -> OldName a
OldName QName
x)
        QName -> [Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr
forall e. QName -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSHead QName
x ([Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs ([Arg (Named NamedName (Pattern' Expr))]
 -> TCMT IO [Arg (Named NamedName (Pattern' Expr))])
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NamedArg Pattern] -> ScopeM (AbsOfCon [NamedArg Pattern])
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
        Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null [NamedArg Pattern]
ps1) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
IllformedProjectionPatternConcrete ((Pattern -> NamedArg Pattern -> Pattern)
-> Pattern -> [NamedArg Pattern] -> Pattern
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pattern -> NamedArg Pattern -> Pattern
C.AppP (Bool -> QName -> Pattern
C.IdentP Bool
True QName
d) [NamedArg Pattern]
ps1)
        ResolvedName
qx <- QName -> ScopeM ResolvedName
resolveName QName
d
        NonEmpty QName
ds <- case ResolvedName
qx of
                FieldName List1 AbstractName
ds -> NonEmpty QName -> TCMT IO (NonEmpty QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty QName -> TCMT IO (NonEmpty QName))
-> NonEmpty QName -> TCMT IO (NonEmpty QName)
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds
                ResolvedName
UnknownName -> QName -> TCMT IO (NonEmpty QName)
forall a. QName -> TCM a
notInScopeError QName
d
                ResolvedName
_           -> [Char] -> TCMT IO (NonEmpty QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (NonEmpty QName))
-> [Char] -> TCMT IO (NonEmpty QName)
forall a b. (a -> b) -> a -> b
$
                  [Char]
"head of copattern needs to be a field identifier, but "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
d [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" isn't one"
        AmbiguousQName
-> NamedArg (LHSCore' Expr)
-> [Arg (Named NamedName (Pattern' Expr))]
-> LHSCore' Expr
forall e.
AmbiguousQName
-> NamedArg (LHSCore' e) -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSProj (NonEmpty QName -> AmbiguousQName
AmbQ NonEmpty QName
ds) (NamedArg (LHSCore' Expr)
 -> [Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO (NamedArg (LHSCore' Expr))
-> TCMT
     IO ([Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedArg LHSCore -> ScopeM (AbsOfCon (NamedArg LHSCore))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NamedArg LHSCore
l TCMT IO ([Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (LHSCore' Expr)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs ([Arg (Named NamedName (Pattern' Expr))]
 -> TCMT IO [Arg (Named NamedName (Pattern' Expr))])
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NamedArg Pattern] -> ScopeM (AbsOfCon [NamedArg Pattern])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NamedArg Pattern]
ps2)
    toAbstract (C.LHSWith LHSCore
core [Pattern]
wps [NamedArg Pattern]
ps) = do
      (LHSCore' Expr
 -> [Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO (LHSCore' Expr)
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (LHSCore' Expr)
forall a b c. (a -> b -> c) -> TCMT IO a -> TCMT IO b -> TCMT IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 LHSCore' Expr
-> [Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr
forall e. LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
A.lhsCoreApp
        ((LHSCore' Expr -> [Arg (Pattern' Expr)] -> LHSCore' Expr)
-> TCMT IO (LHSCore' Expr)
-> TCMT IO [Arg (Pattern' Expr)]
-> TCMT IO (LHSCore' Expr)
forall a b c. (a -> b -> c) -> TCMT IO a -> TCMT IO b -> TCMT IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 LHSCore' Expr -> [Arg (Pattern' Expr)] -> LHSCore' Expr
forall e. LHSCore' e -> [Arg (Pattern' e)] -> LHSCore' e
A.lhsCoreWith
          (LHSCore -> ScopeM (AbsOfCon LHSCore)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
core)
          ((Pattern' Expr -> Arg (Pattern' Expr))
-> [Pattern' Expr] -> [Arg (Pattern' Expr)]
forall a b. (a -> b) -> [a] -> [b]
map Pattern' Expr -> Arg (Pattern' Expr)
forall a. a -> Arg a
defaultArg ([Pattern' Expr] -> [Arg (Pattern' Expr)])
-> TCMT IO [Pattern' Expr] -> TCMT IO [Arg (Pattern' Expr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern] -> ScopeM (AbsOfCon [Pattern])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Pattern]
wps))
        ([NamedArg Pattern] -> ScopeM (AbsOfCon [NamedArg Pattern])
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 <- LHSCore -> ScopeM (AbsOfCon LHSCore)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
p
      TCMT IO ()
bindVarsToBind
      LHSCore' Expr -> TCMT IO (LHSCore' Expr)
forall a. a -> TCMT IO a
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) = Hiding -> AbsOfCon c -> WithHiding (AbsOfCon c)
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h (AbsOfCon c -> WithHiding (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (WithHiding (AbsOfCon c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hiding -> c -> TCMT IO (AbsOfCon c)
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) =
        ArgInfo -> AbsOfCon c -> Arg (AbsOfCon c)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info (AbsOfCon c -> Arg (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (Arg (AbsOfCon c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgInfo -> c -> TCMT IO (AbsOfCon c)
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) = Maybe name -> AbsOfCon c -> Named name (AbsOfCon c)
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n (AbsOfCon c -> Named name (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (Named name (AbsOfCon c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> TCMT IO (AbsOfCon c)
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)         = QName -> [NamedArg Pattern] -> LHSCore' Expr
forall e. QName -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSHead QName
f ([NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO [NamedArg Pattern] -> TCMT IO (LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Arg (Named NamedName (Pattern' Expr))
 -> TCMT IO (NamedArg Pattern))
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [NamedArg Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Arg (Named NamedName (Pattern' Expr)) -> TCMT IO (NamedArg Pattern)
Arg (Named NamedName (Pattern' Expr))
-> ScopeM (AbsOfCon (Arg (Named NamedName (Pattern' Expr))))
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) = AmbiguousQName
-> NamedArg (LHSCore' Expr) -> [NamedArg Pattern] -> LHSCore' Expr
forall e.
AmbiguousQName
-> NamedArg (LHSCore' e) -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSProj AmbiguousQName
d (NamedArg (LHSCore' Expr) -> [NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO (NamedArg (LHSCore' Expr))
-> TCMT IO ([NamedArg Pattern] -> LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Named_ (LHSCore' Expr) -> TCMT IO (Named_ (LHSCore' Expr)))
-> NamedArg (LHSCore' Expr) -> TCMT IO (NamedArg (LHSCore' Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Arg a -> m (Arg b)
mapM Named_ (LHSCore' Expr) -> TCMT IO (Named_ (LHSCore' Expr))
Named_ (LHSCore' Expr)
-> ScopeM (AbsOfCon (Named_ (LHSCore' Expr)))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NamedArg (LHSCore' Expr)
lhscore TCMT IO ([NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO [NamedArg Pattern] -> TCMT IO (LHSCore' Expr)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Arg (Named NamedName (Pattern' Expr))
 -> TCMT IO (NamedArg Pattern))
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [NamedArg Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Arg (Named NamedName (Pattern' Expr)) -> TCMT IO (NamedArg Pattern)
Arg (Named NamedName (Pattern' Expr))
-> ScopeM (AbsOfCon (Arg (Named NamedName (Pattern' Expr))))
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)  = (LHSCore' Expr
 -> [Arg Pattern] -> [NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO (LHSCore' Expr)
-> TCMT IO [Arg Pattern]
-> TCMT IO [NamedArg Pattern]
-> TCMT IO (LHSCore' Expr)
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 LHSCore' Expr
-> [Arg Pattern] -> [NamedArg Pattern] -> LHSCore' Expr
forall e.
LHSCore' e
-> [Arg (Pattern' e)] -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSWith (LHSCore' Expr -> ScopeM (AbsOfCon (LHSCore' Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore' Expr
core) ([Arg (Pattern' Expr)] -> ScopeM (AbsOfCon [Arg (Pattern' Expr)])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Pattern' Expr)]
wps) ([Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (AbsOfCon [Arg (Named NamedName (Pattern' Expr))])
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 = (Expr -> ScopeM Expr) -> Pattern' Expr -> TCMT IO Pattern
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Pattern' a -> f (Pattern' b)
traverse ((Expr -> ScopeM Expr) -> Pattern' Expr -> TCMT IO Pattern)
-> (Expr -> ScopeM Expr) -> Pattern' Expr -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ ScopeM Expr -> ScopeM Expr
forall a. ScopeM a -> ScopeM a
insideDotPattern (ScopeM Expr -> ScopeM Expr)
-> (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
DotPatternCtx  -- Issue #3033

resolvePatternIdentifier
  :: Bool -- ^ Is the identifier allowed to refer to a constructor (or
          --   a pattern synonym)?
  -> Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)
resolvePatternIdentifier :: Bool
-> Range -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
canBeConstructor Range
r QName
x Maybe (Set Name)
ns = do
  [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"resolvePatternIdentifier " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at source position " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Range -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Range
r
  APatName
px <- PatName -> ScopeM (AbsOfCon PatName)
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
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  resolved to VarPatName " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with range " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Range -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
y)
      Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern' Expr
forall e. BindName -> Pattern' e
VarP (BindName -> Pattern' Expr) -> BindName -> Pattern' Expr
forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.mkBindName Name
y
    ConPatName List1 AbstractName
ds ->
      if Bool
canBeConstructor
      then Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ ConPatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
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 (NonEmpty QName -> AmbiguousQName)
-> NonEmpty QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds) []
      else [Char] -> TCMT IO (Pattern' Expr)
err [Char]
"constructor"
    PatternSynPatName List1 AbstractName
ds ->
      if Bool
canBeConstructor
      then Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
PatternSynP (Range -> PatInfo
PatRange Range
r)
                                (NonEmpty QName -> AmbiguousQName
AmbQ (NonEmpty QName -> AmbiguousQName)
-> NonEmpty QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds) []
      else [Char] -> TCMT IO (Pattern' Expr)
err [Char]
"pattern synonym"
  where
  err :: [Char] -> TCMT IO (Pattern' Expr)
err [Char]
s =
    Range -> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr))
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$
    TypeError -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (Pattern' Expr))
-> TypeError -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$
      [Char]
"A pun must not use the " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x

-- | 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
  Range -> Pattern' Expr -> Pattern' Expr
forall a. SetRange a => Range -> a -> a
setRange (Pattern -> Range
forall a. HasRange a => a -> Range
getRange Pattern
p0) (Pattern' Expr -> Pattern' Expr)
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
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        -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ ConPatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP        ConPatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
      A.DefP PatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as        -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP        PatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
      A.PatternSynP PatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
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 ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Pattern' Expr))
-> TCMT IO (Pattern' Expr)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
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 ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
          Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ ConPatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
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 = TypeError -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (Pattern' Expr))
-> TypeError -> TCMT IO (Pattern' Expr)
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 Bool
canBeConstructor QName
x) =
      Bool
-> Range -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
canBeConstructor (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
x) QName
x Maybe (Set Name)
forall a. Maybe a
Nothing

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

    toAbstract (QuoteP Range
r) =
      [Char] -> TCMT IO (Pattern' Expr)
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
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
50 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"distributeDots before = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
p
        Pattern
p <- Pattern -> TCMT IO Pattern
distributeDots Pattern
p
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
50 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"distributeDots after  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
p
        (Pattern' Expr
p', Arg (Named NamedName (Pattern' Expr))
q') <- (Pattern, NamedArg Pattern)
-> ScopeM (AbsOfCon (Pattern, NamedArg Pattern))
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' ([Arg (Named NamedName (Pattern' Expr))]
 -> TCMT IO (Pattern' Expr))
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ Arg (Named NamedName (Pattern' Expr))
-> [Arg (Named NamedName (Pattern' Expr))]
forall el coll. Singleton el coll => el -> coll
singleton Arg (Named NamedName (Pattern' Expr))
q'

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

            distributeDotsExpr :: Range -> C.Expr -> ScopeM C.Pattern
            distributeDotsExpr :: Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e = Expr -> TCMT IO Expr
parseRawApp Expr
e TCMT IO Expr -> (Expr -> TCMT IO Pattern) -> TCMT IO Pattern
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
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 (Pattern -> NamedArg Pattern -> Pattern)
-> TCMT IO Pattern -> TCMT IO (NamedArg Pattern -> Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e
                     TCMT IO (NamedArg Pattern -> Pattern)
-> TCMT IO (NamedArg Pattern) -> TCMT IO Pattern
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> NamedArg Expr -> TCMT IO (NamedArg Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
 -> NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> ((Expr -> TCMT IO Pattern)
    -> Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> (Expr -> TCMT IO Pattern)
-> NamedArg Expr
-> TCMT IO (NamedArg Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> TCMT IO Pattern)
-> Named NamedName Expr -> TCMT IO (Named NamedName Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) (Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r) NamedArg Expr
a
              OpApp Range
r QName
q Set Name
ns OpAppArgs
as ->
                case ((Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
 -> Maybe (NamedArg Expr))
-> OpAppArgs -> Maybe [NamedArg Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
  -> Maybe (NamedArg Expr))
 -> OpAppArgs -> Maybe [NamedArg Expr])
-> ((MaybePlaceholder (OpApp Expr) -> TacticAttribute)
    -> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
    -> Maybe (NamedArg Expr))
-> (MaybePlaceholder (OpApp Expr) -> TacticAttribute)
-> OpAppArgs
-> Maybe [NamedArg Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName (MaybePlaceholder (OpApp Expr))
 -> Maybe (Named NamedName Expr))
-> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName (MaybePlaceholder (OpApp Expr))
  -> Maybe (Named NamedName Expr))
 -> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
 -> Maybe (NamedArg Expr))
-> ((MaybePlaceholder (OpApp Expr) -> TacticAttribute)
    -> Named NamedName (MaybePlaceholder (OpApp Expr))
    -> Maybe (Named NamedName Expr))
-> (MaybePlaceholder (OpApp Expr) -> TacticAttribute)
-> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaybePlaceholder (OpApp Expr) -> TacticAttribute)
-> Named NamedName (MaybePlaceholder (OpApp Expr))
-> Maybe (Named NamedName Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) MaybePlaceholder (OpApp Expr) -> TacticAttribute
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 ([NamedArg Pattern] -> Pattern)
-> TCMT IO [NamedArg Pattern] -> TCMT IO Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    ((NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> [NamedArg Expr] -> TCMT IO [NamedArg Pattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg Expr -> TCMT IO (NamedArg Pattern))
 -> [NamedArg Expr] -> TCMT IO [NamedArg Pattern])
-> ((Expr -> TCMT IO Pattern)
    -> NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> (Expr -> TCMT IO Pattern)
-> [NamedArg Expr]
-> TCMT IO [NamedArg Pattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> NamedArg Expr -> TCMT IO (NamedArg Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
 -> NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> ((Expr -> TCMT IO Pattern)
    -> Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> (Expr -> TCMT IO Pattern)
-> NamedArg Expr
-> TCMT IO (NamedArg Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> TCMT IO Pattern)
-> Named NamedName Expr -> TCMT IO (Named NamedName Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) (Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r) [NamedArg Expr]
as
                  Maybe [NamedArg Expr]
Nothing -> Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Expr -> Pattern
C.DotP Range
r Expr
e
              Paren Range
r Expr
e -> Range -> KillRangeT Pattern
ParenP Range
r KillRangeT Pattern -> TCMT IO Pattern -> TCMT IO Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e
              Expr
_ -> Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
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)) = a -> Maybe a
forall a. a -> Maybe a
Just a
e
            fromNoPlaceholder MaybePlaceholder (OpApp a)
_ = Maybe a
forall a. Maybe a
Nothing

            parseRawApp :: C.Expr -> ScopeM C.Expr
            parseRawApp :: Expr -> TCMT IO Expr
parseRawApp (RawApp Range
r List2 Expr
es) = List2 Expr -> TCMT IO Expr
parseApplication List2 Expr
es
            parseRawApp Expr
e             = Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
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
        [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ConcreteToAbstract.toAbstract OpAppP{}: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
p0
        Pattern' Expr
p  <- Bool
-> Range -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
True (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
op) QName
op (Set Name -> Maybe (Set Name)
forall a. a -> Maybe a
Just Set Name
ns)
        [Arg (Named NamedName (Pattern' Expr))]
ps <- [NamedArg Pattern] -> ScopeM (AbsOfCon [NamedArg Pattern])
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) = TCMT IO (Pattern' Expr)
-> (Pattern -> TCMT IO (Pattern' Expr))
-> Maybe Pattern
-> TCMT IO (Pattern' Expr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO (Pattern' Expr)
forall a. HasCallStack => a
__IMPOSSIBLE__ Pattern -> TCMT IO (Pattern' Expr)
Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe Pattern
mp

    -- Removed when parsing
    toAbstract (HiddenP Range
_ Named NamedName Pattern
_)   = TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (InstanceP Range
_ Named NamedName Pattern
_) = TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (RawAppP Range
_ List2 Pattern
_)   = TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
forall a. HasCallStack => a
__IMPOSSIBLE__

    toAbstract p :: Pattern
p@(C.WildP Range
r)    = AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern))
-> AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Expr
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)   = Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
    toAbstract (C.LitP Range
r Literal
l)     = Range -> ScopeM (AbsOfCon Pattern) -> ScopeM (AbsOfCon Pattern)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (ScopeM (AbsOfCon Pattern) -> ScopeM (AbsOfCon Pattern))
-> ScopeM (AbsOfCon Pattern) -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Literal -> Pattern' Expr
forall e. PatInfo -> Literal -> Pattern' e
A.LitP (Range -> PatInfo
PatRange Range
r) Literal
l Pattern' Expr -> TCMT IO () -> TCMT IO (Pattern' Expr)
forall a b. a -> TCMT IO b -> TCMT IO a
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
      PatName -> ScopeM (AbsOfCon PatName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> PatName
PatName (Name -> QName
C.QName Name
x) Maybe (Set Name)
forall a. Maybe a
Nothing) TCMT IO APatName
-> (APatName -> TCMT IO (Pattern' Expr)) -> TCMT IO (Pattern' Expr)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        VarPatName Name
x        -> PatInfo -> BindName -> Pattern' Expr -> Pattern' Expr
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP (Range -> PatInfo
PatRange Range
r) (Name -> BindName
A.mkBindName Name
x) (Pattern' Expr -> Pattern' Expr)
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM (AbsOfCon Pattern)
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
        Name -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Warning
AsPatternShadowsConstructorOrPatternSynonym Bool
b
        Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p

    toAbstract p0 :: Pattern
p0@(C.EqualP Range
r [(Expr, Expr)]
es)  = AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern))
-> AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> [(Expr, Expr)] -> Pattern' Expr
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 = Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Expr -> Pattern' Expr
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 ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Pattern' Expr))
-> TCMT IO (Pattern' Expr)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
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 -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' Expr
forall e. PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' e
A.ProjP (Range -> PatInfo
PatRange Range
r) ProjOrigin
ProjPostfix (AmbiguousQName -> Pattern' Expr)
-> AmbiguousQName -> Pattern' Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ (NonEmpty QName -> AmbiguousQName)
-> NonEmpty QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$
            (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty 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)
ScopeM (AbsOfCon Pattern)
fallback

    toAbstract p0 :: Pattern
p0@(C.AbsurdP Range
r)    = AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern))
-> AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Expr
forall e. PatInfo -> Pattern' e
A.AbsurdP (Range -> PatInfo
PatRange Range
r)
    toAbstract (C.RecP Range
r [FieldAssignment' Pattern]
fs)       = PatInfo -> [FieldAssignment' (Pattern' Expr)] -> Pattern' Expr
forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP (Range -> PatInfo
PatRange Range
r) ([FieldAssignment' (Pattern' Expr)] -> Pattern' Expr)
-> TCMT IO [FieldAssignment' (Pattern' Expr)]
-> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldAssignment' Pattern
 -> TCMT IO (FieldAssignment' (Pattern' Expr)))
-> [FieldAssignment' Pattern]
-> TCMT IO [FieldAssignment' (Pattern' Expr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Pattern -> TCMT IO (Pattern' Expr))
-> FieldAssignment' Pattern
-> TCMT IO (FieldAssignment' (Pattern' Expr))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse Pattern -> TCMT IO (Pattern' Expr)
Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract) [FieldAssignment' Pattern]
fs
    toAbstract (C.WithP Range
r Pattern
p)       = PatInfo -> Pattern' Expr -> Pattern' Expr
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP (Range -> PatInfo
PatRange Range
r) (Pattern' Expr -> Pattern' Expr)
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM (AbsOfCon Pattern)
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)                 = Precedence -> Expr -> ScopeM (AbsOfCon Expr)
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) <- OpAppArgs
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp Expr))])
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 = (NotationPart -> Bool) -> Notation -> Notation
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (NotationPart -> Bool) -> NotationPart -> Bool
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.
    Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Notation -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((NotationPart -> Bool) -> Notation -> Notation
forall a. (a -> Bool) -> [a] -> [a]
filter NotationPart -> Bool
isAHole Notation
nonBindingParts) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [NamedArg (Either Expr (OpApp Expr))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg (Either Expr (OpApp Expr))]
es) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
    -- Translate operator and its arguments (each in the right context).
    Expr
op <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
op (Set Name -> Maybe (Set Name)
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 = (Expr -> (ParenPreference, NamedArg Expr) -> Expr)
-> Expr -> [(ParenPreference, NamedArg Expr)] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
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
    Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ (LamBinding -> Expr -> Expr) -> Expr -> [LamBinding] -> Expr
forall a b. (a -> b -> b) -> 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 (Expr -> Range
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 = getOrigin arg
                                      , appParens = pref }
            r :: Range
r = Expr -> NamedArg Expr -> Range
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 NamedArg (Either Expr (OpApp Expr)) -> Either Expr (OpApp Expr)
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,) (NamedArg Expr -> (ParenPreference, NamedArg Expr))
-> TCMT IO (NamedArg Expr)
-> ScopeM (ParenPreference, NamedArg Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Named NamedName (Either Expr (OpApp Expr))
 -> TCMT IO (Named NamedName Expr))
-> NamedArg (Either Expr (OpApp Expr)) -> TCMT IO (NamedArg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName (Either Expr (OpApp Expr))
  -> TCMT IO (Named NamedName Expr))
 -> NamedArg (Either Expr (OpApp Expr)) -> TCMT IO (NamedArg Expr))
-> ((Either Expr (OpApp Expr) -> ScopeM Expr)
    -> Named NamedName (Either Expr (OpApp Expr))
    -> TCMT IO (Named NamedName Expr))
-> (Either Expr (OpApp Expr) -> ScopeM Expr)
-> NamedArg (Either Expr (OpApp Expr))
-> TCMT IO (NamedArg Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Expr (OpApp Expr) -> ScopeM Expr)
-> Named NamedName (Either Expr (OpApp Expr))
-> TCMT IO (Named NamedName Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) ((Expr -> ScopeM Expr)
-> (OpApp Expr -> ScopeM Expr)
-> Either Expr (OpApp Expr)
-> ScopeM Expr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Expr -> ScopeM Expr
forall a. a -> TCMT IO a
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
        [(ParenPreference, NamedArg Expr)]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ParenPreference, NamedArg Expr)
e (ParenPreference, NamedArg Expr)
-> [(ParenPreference, NamedArg Expr)]
-> [(ParenPreference, NamedArg Expr)]
forall a. a -> [a] -> [a]
: [(ParenPreference, NamedArg Expr)]
es)
    left Fixity
f (NotationPart
_  : Notation
_)  [] = TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
    left Fixity
f []        [NamedArg (Either Expr (OpApp Expr))]
_  = TCMT IO [(ParenPreference, NamedArg 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
        [(ParenPreference, NamedArg Expr)]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ParenPreference, NamedArg Expr)
e (ParenPreference, NamedArg Expr)
-> [(ParenPreference, NamedArg Expr)]
-> [(ParenPreference, NamedArg Expr)]
forall a. a -> [a] -> [a]
: [(ParenPreference, NamedArg Expr)]
es)
    inside Fixity
_ (NotationPart
_ : Notation
_) [] = TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
    inside Fixity
_ []         [NamedArg (Either Expr (OpApp Expr))]
_  = TCMT IO [(ParenPreference, NamedArg 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
_)  [] = [(ParenPreference, NamedArg Expr)]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. a -> TCMT IO a
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
        [(ParenPreference, NamedArg Expr)]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(ParenPreference, NamedArg Expr)
e]
    right Fixity
_ NotationPart
_     [NamedArg (Either Expr (OpApp Expr))]
_  = TCMT IO [(ParenPreference, NamedArg 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 []       = ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    replacePlaceholders (NamedArg (MaybePlaceholder (OpApp e))
a : [NamedArg (MaybePlaceholder (OpApp e))]
as) = case NamedArg (MaybePlaceholder (OpApp e)) -> MaybePlaceholder (OpApp e)
forall a. NamedArg a -> a
namedArg NamedArg (MaybePlaceholder (OpApp e))
a of
      NoPlaceholder Maybe PositionInName
_ OpApp e
x -> ([NamedArg (Either Expr (OpApp e))]
 -> [NamedArg (Either Expr (OpApp e))])
-> ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (Either Expr (OpApp e)
-> NamedArg (MaybePlaceholder (OpApp e))
-> NamedArg (Either Expr (OpApp e))
forall a b. a -> NamedArg b -> NamedArg a
set (OpApp e -> Either Expr (OpApp e)
forall a b. b -> Either a b
Right OpApp e
x) NamedArg (MaybePlaceholder (OpApp e))
a NamedArg (Either Expr (OpApp e))
-> [NamedArg (Either Expr (OpApp e))]
-> [NamedArg (Either Expr (OpApp e))]
forall a. a -> [a] -> [a]
:) (([LamBinding], [NamedArg (Either Expr (OpApp e))])
 -> ([LamBinding], [NamedArg (Either Expr (OpApp e))]))
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             [NamedArg (MaybePlaceholder (OpApp e))]
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
      Placeholder PositionInName
_     -> do
        Name
x <- Range -> [Char] -> ScopeM Name
forall (m :: * -> *).
MonadFresh NameId m =>
Range -> [Char] -> m Name
freshName Range
forall a. Range' a
noRange [Char]
"section"
        let i :: ArgInfo
i = Origin -> ArgInfo -> ArgInfo
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted (ArgInfo -> ArgInfo) -> ArgInfo -> ArgInfo
forall a b. (a -> b) -> a -> b
$ NamedArg (MaybePlaceholder (OpApp e)) -> ArgInfo
forall e. Arg e -> ArgInfo
argInfo NamedArg (MaybePlaceholder (OpApp e))
a
        ([LamBinding]
ls, [NamedArg (Either Expr (OpApp e))]
ns) <- [NamedArg (MaybePlaceholder (OpApp e))]
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
        ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree (ArgInfo -> Binder' BindName -> NamedArg (Binder' BindName)
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
i (Binder' BindName -> NamedArg (Binder' BindName))
-> Binder' BindName -> NamedArg (Binder' BindName)
forall a b. (a -> b) -> a -> b
$ Name -> Binder' BindName
A.mkBinder_ Name
x) LamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
: [LamBinding]
ls
               , Either Expr (OpApp e)
-> NamedArg (MaybePlaceholder (OpApp e))
-> NamedArg (Either Expr (OpApp e))
forall a b. a -> NamedArg b -> NamedArg a
set (Expr -> Either Expr (OpApp e)
forall a b. a -> Either a b
Left (Name -> Expr
Var Name
x)) NamedArg (MaybePlaceholder (OpApp e))
a NamedArg (Either Expr (OpApp e))
-> [NamedArg (Either Expr (OpApp e))]
-> [NamedArg (Either Expr (OpApp e))]
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 = (Named NamedName b -> Named_ a) -> NamedArg b -> Arg (Named_ a)
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> a) -> Named NamedName b -> Named_ a
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> a
forall a b. a -> b -> a
const a
x)) NamedArg b
arg

-- | Raises an error if the list of attributes contains an unsupported
-- attribute.

checkAttributes :: Attributes -> ScopeM ()
checkAttributes :: Attributes -> TCMT IO ()
checkAttributes []                     = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAttributes ((Attribute
attr, Range
r, [Char]
s) : Attributes
attrs) =
  case Attribute
attr of
    RelevanceAttribute{}    -> TCMT IO ()
cont
    TacticAttribute{}       -> TCMT IO ()
cont
    LockAttribute Lock
IsNotLock -> TCMT IO ()
cont
    LockAttribute IsLock{}  -> do
      TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optGuarded (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> TypeError
AttributeKindNotEnabled [Char]
"Lock" [Char]
"--guarded" [Char]
s
      TCMT IO ()
cont
    QuantityAttribute Quantityω{} -> TCMT IO ()
cont
    QuantityAttribute Quantity1{} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
    QuantityAttribute Quantity0{} -> do
      TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optErasure (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> TypeError
AttributeKindNotEnabled [Char]
"Erasure" [Char]
"--erasure" [Char]
s
      TCMT IO ()
cont
    CohesionAttribute{} -> do
      TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optCohesion (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> TypeError
AttributeKindNotEnabled [Char]
"Cohesion" [Char]
"--cohesion" [Char]
s
      TCMT IO ()
cont
  where
  cont :: TCMT IO ()
cont = Attributes -> TCMT IO ()
checkAttributes Attributes
attrs

{--------------------------------------------------------------------------
    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     -> Expr -> HoleContent' () BindName Pattern Expr
forall qn nm p e. e -> HoleContent' qn nm p e
HoleContentExpr (Expr -> HoleContent' () BindName Pattern Expr)
-> ScopeM Expr -> TCMT IO (HoleContent' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
    HoleContentRewrite [RewriteEqn]
es -> [RewriteEqn' () BindName Pattern Expr]
-> HoleContent' () BindName Pattern Expr
forall qn nm p e. [RewriteEqn' qn nm p e] -> HoleContent' qn nm p e
HoleContentRewrite ([RewriteEqn' () BindName Pattern Expr]
 -> HoleContent' () BindName Pattern Expr)
-> TCMT IO [RewriteEqn' () BindName Pattern Expr]
-> TCMT IO (HoleContent' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RewriteEqn] -> ScopeM (AbsOfCon [RewriteEqn])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [RewriteEqn]
es