{-# LANGUAGE TypeFamilies         #-}  -- for type equality ~
{-# LANGUAGE UndecidableInstances #-}

{-| 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(..)
    , OldName(..)
    , TopLevel(..)
    , TopLevelInfo(..)
    , topLevelModuleName
    , AbstractRHS
    , NewModuleName, OldModuleName
    , NewName, OldQName
    , PatName, APatName
    ) where

import Prelude hiding ( mapM, null )

import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Reader hiding (mapM)

import Data.Foldable (Foldable, traverse_)
import Data.Traversable (mapM, traverse)
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
import Data.Void

import Agda.Syntax.Concrete as C hiding (topLevelModuleName)
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 ( patternVars, checkPatternLinearity )
import Agda.Syntax.Abstract.Pretty
import qualified Agda.Syntax.Internal as I
import Agda.Syntax.Position
import Agda.Syntax.Literal
import Agda.Syntax.Common
import Agda.Syntax.Info
import Agda.Syntax.Concrete.Definitions as C
import Agda.Syntax.Fixity
import Agda.Syntax.Concrete.Fixity (DoWarn(..))
import Agda.Syntax.Notation
import Agda.Syntax.Scope.Base as A
import Agda.Syntax.Scope.Monad
import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete)
import Agda.Syntax.DoNotation
import Agda.Syntax.IdiomBrackets

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
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.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.Either
import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.FileName
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Utils.Pretty as P
import Agda.Utils.Pretty (render, Pretty, pretty, prettyShow)
import Agda.Utils.Singleton
import Agda.Utils.Tuple

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

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

-- notAModuleExpr e = typeError $ NotAModuleExpr e

notAnExpression :: C.Expr -> ScopeM A.Expr
notAnExpression :: Expr -> ScopeM Expr
notAnExpression Expr
e = TypeError -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> ScopeM Expr) -> TypeError -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Expr -> TypeError
NotAnExpression Expr
e

nothingAppliedToHiddenArg :: C.Expr -> ScopeM A.Expr
nothingAppliedToHiddenArg :: Expr -> ScopeM Expr
nothingAppliedToHiddenArg Expr
e = TypeError -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> ScopeM Expr) -> TypeError -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Expr -> TypeError
NothingAppliedToHiddenArg Expr
e

nothingAppliedToInstanceArg :: C.Expr -> ScopeM A.Expr
nothingAppliedToInstanceArg :: Expr -> ScopeM Expr
nothingAppliedToInstanceArg Expr
e = TypeError -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> ScopeM Expr) -> TypeError -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Expr -> TypeError
NothingAppliedToInstanceArg Expr
e

notAValidLetBinding :: NiceDeclaration -> ScopeM a
notAValidLetBinding :: NiceDeclaration -> ScopeM a
notAValidLetBinding NiceDeclaration
d = TypeError -> ScopeM a
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> ScopeM a) -> TypeError -> ScopeM a
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> TypeError
NotAValidLetBinding NiceDeclaration
d

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

annotateDecls :: ScopeM [A.Declaration] -> ScopeM A.Declaration
annotateDecls :: ScopeM [Declaration] -> ScopeM Declaration
annotateDecls ScopeM [Declaration]
m = do
  [Declaration]
ds <- ScopeM [Declaration]
m
  ScopeInfo
s  <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  Declaration -> ScopeM Declaration
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> ScopeM Declaration)
-> Declaration -> ScopeM Declaration
forall a b. (a -> b) -> a -> b
$ ScopeInfo -> [Declaration] -> Declaration
ScopedDecl ScopeInfo
s [Declaration]
ds

annotateExpr :: ScopeM A.Expr -> ScopeM A.Expr
annotateExpr :: ScopeM Expr -> ScopeM Expr
annotateExpr ScopeM Expr
m = do
  Expr
e <- ScopeM Expr
m
  ScopeInfo
s <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ScopeInfo -> Expr -> Expr
ScopedExpr ScopeInfo
s Expr
e

-- | Make sure that there are no dot patterns (called on pattern synonyms).
noDotorEqPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)
noDotorEqPattern :: String -> Pattern' e -> ScopeM (Pattern' Void)
noDotorEqPattern String
err = Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot
  where
    dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)
    dot :: Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p = case Pattern' e
p of
      A.VarP BindName
x               -> Pattern' Void -> ScopeM (Pattern' Void)
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
<$> ((Arg (Named NamedName (Pattern' e))
 -> TCMT IO (Arg (Named NamedName (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)
traverse ((Arg (Named NamedName (Pattern' e))
  -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
 -> NAPs e -> TCMT IO (NAPs Void))
-> (Arg (Named NamedName (Pattern' e))
    -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named NamedName (Pattern' e)
 -> TCMT IO (Named NamedName (Pattern' Void)))
-> Arg (Named NamedName (Pattern' e))
-> TCMT IO (Arg (Named NamedName (Pattern' Void)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Named NamedName (Pattern' e)
  -> TCMT IO (Named NamedName (Pattern' Void)))
 -> Arg (Named NamedName (Pattern' e))
 -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
-> (Named NamedName (Pattern' e)
    -> TCMT IO (Named NamedName (Pattern' Void)))
-> Arg (Named NamedName (Pattern' e))
-> TCMT IO (Arg (Named NamedName (Pattern' Void)))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named NamedName (Pattern' e)
-> TCMT IO (Named NamedName (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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 (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 (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{}               -> String -> ScopeM (Pattern' Void)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
err
      A.EqualP{}             -> String -> ScopeM (Pattern' Void)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
err   -- Andrea: so we also disallow = patterns, reasonable?
      A.AbsurdP PatInfo
i            -> Pattern' Void -> ScopeM (Pattern' Void)
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 Literal
l               -> Pattern' Void -> ScopeM (Pattern' Void)
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
$ Literal -> Pattern' Void
forall e. Literal -> Pattern' e
A.LitP 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
<$> ((Arg (Named NamedName (Pattern' e))
 -> TCMT IO (Arg (Named NamedName (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)
traverse ((Arg (Named NamedName (Pattern' e))
  -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
 -> NAPs e -> TCMT IO (NAPs Void))
-> (Arg (Named NamedName (Pattern' e))
    -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named NamedName (Pattern' e)
 -> TCMT IO (Named NamedName (Pattern' Void)))
-> Arg (Named NamedName (Pattern' e))
-> TCMT IO (Arg (Named NamedName (Pattern' Void)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Named NamedName (Pattern' e)
  -> TCMT IO (Named NamedName (Pattern' Void)))
 -> Arg (Named NamedName (Pattern' e))
 -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
-> (Named NamedName (Pattern' e)
    -> TCMT IO (Named NamedName (Pattern' Void)))
-> Arg (Named NamedName (Pattern' e))
-> TCMT IO (Arg (Named NamedName (Pattern' Void)))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named NamedName (Pattern' e)
-> TCMT IO (Named NamedName (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
<$> ((Arg (Named NamedName (Pattern' e))
 -> TCMT IO (Arg (Named NamedName (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)
traverse ((Arg (Named NamedName (Pattern' e))
  -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
 -> NAPs e -> TCMT IO (NAPs Void))
-> (Arg (Named NamedName (Pattern' e))
    -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named NamedName (Pattern' e)
 -> TCMT IO (Named NamedName (Pattern' Void)))
-> Arg (Named NamedName (Pattern' e))
-> TCMT IO (Arg (Named NamedName (Pattern' Void)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Named NamedName (Pattern' e)
  -> TCMT IO (Named NamedName (Pattern' Void)))
 -> Arg (Named NamedName (Pattern' e))
 -> TCMT IO (Arg (Named NamedName (Pattern' Void))))
-> (Named NamedName (Pattern' e)
    -> TCMT IO (Named NamedName (Pattern' Void)))
-> Arg (Named NamedName (Pattern' e))
-> TCMT IO (Arg (Named NamedName (Pattern' Void)))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named NamedName (Pattern' e)
-> TCMT IO (Named NamedName (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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)
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)
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
--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 A.Expr where
  toAbstract :: RecordConstructorType -> ScopeM Expr
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
    buildType :: [NiceDeclaration] -> ScopeM Expr
buildType [NiceDeclaration]
ds = do
      [TypedBinding]
tel <- (NiceDeclaration -> TCMT IO TypedBinding)
-> [NiceDeclaration] -> TCMT IO [TypedBinding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NiceDeclaration -> TCMT IO TypedBinding
makeBinding [NiceDeclaration]
ds  -- TODO: Telescope instead of Expr in abstract RecDef
      Expr -> ScopeM Expr
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.Pi (Range -> ExprInfo
ExprRange ([NiceDeclaration] -> Range
forall t. HasRange t => t -> Range
getRange [NiceDeclaration]
ds)) [TypedBinding]
tel (ExprInfo -> Integer -> Expr
A.Set ExprInfo
exprNoRange Integer
0)

    makeBinding :: C.NiceDeclaration -> ScopeM A.TypedBinding
    makeBinding :: NiceDeclaration -> TCMT IO TypedBinding
makeBinding NiceDeclaration
d = do
      let failure :: TCMT IO TypedBinding
failure = TypeError -> TCMT IO TypedBinding
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO TypedBinding)
-> TypeError -> TCMT IO TypedBinding
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> TypeError
NotValidBeforeField NiceDeclaration
d
          r :: Range
r       = NiceDeclaration -> Range
forall t. HasRange t => t -> Range
getRange NiceDeclaration
d
          info :: ExprInfo
info    = Range -> ExprInfo
ExprRange Range
r
          mkLet :: NiceDeclaration -> TCMT IO TypedBinding
mkLet NiceDeclaration
d = Range -> [LetBinding] -> TypedBinding
A.TLet Range
r ([LetBinding] -> TypedBinding)
-> TCMT IO [LetBinding] -> TCMT IO TypedBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetDef -> TCMT IO [LetBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (NiceDeclaration -> LetDef
LetDef NiceDeclaration
d)
      Call -> TCMT IO TypedBinding -> TCMT IO TypedBinding
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (Range -> Call
SetRange Range
r) (TCMT IO TypedBinding -> TCMT IO TypedBinding)
-> TCMT IO TypedBinding -> TCMT IO 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 :: Arg (Named NamedName (Binder' BoundName))
bv = Binder' BoundName -> Named NamedName (Binder' BoundName)
forall a name. a -> Named name a
unnamed (BoundName -> Binder' BoundName
forall a. a -> Binder' a
C.mkBinder (BoundName -> Binder' BoundName) -> BoundName -> Binder' BoundName
forall a b. (a -> b) -> a -> b
$ (Name -> Fixity' -> BoundName
C.mkBoundName Name
x Fixity'
fx) { bnameTactic :: TacticAttribute
bnameTactic = TacticAttribute
tac }) Named NamedName (Binder' BoundName)
-> Arg Expr -> Arg (Named NamedName (Binder' BoundName))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Expr
a
          TypedBinding
tel <- TypedBinding' Expr -> TCMT IO TypedBinding
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (TypedBinding' Expr -> TCMT IO TypedBinding)
-> TypedBinding' Expr -> TCMT IO TypedBinding
forall a b. (a -> b) -> a -> b
$ Range
-> [Arg (Named NamedName (Binder' BoundName))]
-> Expr
-> TypedBinding' Expr
forall e.
Range
-> [Arg (Named NamedName (Binder' BoundName))]
-> e
-> TypedBinding' e
C.TBind Range
r [Arg (Named NamedName (Binder' BoundName))
bv] (Arg Expr -> Expr
forall e. Arg e -> e
unArg Arg Expr
a)
          TypedBinding -> TCMT IO TypedBinding
forall (m :: * -> *) a. Monad m => a -> m a
return TypedBinding
tel

        -- 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 TypedBinding
mkLet (NiceDeclaration -> TCMT IO TypedBinding)
-> NiceDeclaration -> TCMT IO TypedBinding
forall a b. (a -> b) -> a -> b
$ Range -> QName -> ImportDirective -> NiceDeclaration
C.NiceOpen Range
r QName
m ImportDirective
dir{ publicOpen :: Maybe Range
publicOpen = Maybe Range
forall a. Maybe a
Nothing }
        C.NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
          NiceDeclaration -> TCMT IO TypedBinding
mkLet (NiceDeclaration -> TCMT IO TypedBinding)
-> NiceDeclaration -> TCMT IO TypedBinding
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
C.NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir{ publicOpen :: Maybe Range
publicOpen = Maybe Range
forall a. Maybe a
Nothing }

        -- Do some rudimentary matching here to get NotValidBeforeField instead
        -- of NotAValidLetDecl.
        C.NiceMutual Range
_ TerminationCheck
_ CoverageCheck
_ PositivityCheck
_
          [ C.FunSig Range
_ Access
_ IsAbstract
_ IsInstance
_ IsMacro
macro ArgInfo
_ TerminationCheck
_ CoverageCheck
_ Name
_ Expr
_
          , C.FunDef Range
_ [Declaration]
_ IsAbstract
abstract IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_
             [ C.Clause Name
_ Bool
_ (C.LHS Pattern
_p [] [] ExpandedEllipsis
NoEllipsis) (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 TypedBinding
mkLet NiceDeclaration
d

        C.NiceMutual{}        -> TCMT IO TypedBinding
failure
        -- TODO: some of these cases might be __IMPOSSIBLE__
        C.Axiom{}             -> TCMT IO TypedBinding
failure
        C.PrimitiveFunction{} -> TCMT IO TypedBinding
failure
        C.NiceModule{}        -> TCMT IO TypedBinding
failure
        C.NiceImport{}        -> TCMT IO TypedBinding
failure
        C.NicePragma{}        -> TCMT IO TypedBinding
failure
        C.NiceRecSig{}        -> TCMT IO TypedBinding
failure
        C.NiceDataSig{}       -> TCMT IO TypedBinding
failure
        C.NiceFunClause{}     -> TCMT IO TypedBinding
failure
        C.FunSig{}            -> TCMT IO TypedBinding
failure  -- Note: these are bundled with FunDef in NiceMutual
        C.FunDef{}            -> TCMT IO TypedBinding
failure
        C.NiceDataDef{}       -> TCMT IO TypedBinding
failure
        C.NiceRecDef{}        -> TCMT IO TypedBinding
failure
        C.NicePatternSyn{}    -> TCMT IO TypedBinding
failure
        C.NiceGeneralize{}    -> TCMT IO TypedBinding
failure
        C.NiceUnquoteDecl{}   -> TCMT IO TypedBinding
failure
        C.NiceUnquoteDef{}    -> TCMT IO 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
  String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
    [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"scope checking ModuleApplication " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
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' <- Telescope -> TCMT IO [TypedBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Telescope
tel
    -- Scope check the old module name and the module args.
    ModuleName
m1    <- OldModuleName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldModuleName -> ScopeM ModuleName)
-> OldModuleName -> ScopeM ModuleName
forall a b. (a -> b) -> a -> b
$ QName -> OldModuleName
OldModuleName QName
m
    [NamedArg Expr]
args' <- Precedence -> [NamedArg Expr] -> ScopeM [NamedArg Expr]
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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'
    String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"mod.inst" VerboseLevel
20 String
"copied source module"
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.mod.inst" VerboseLevel
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> TCM Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> TCM Doc) -> Doc -> TCM 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'
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
      [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"scope checked ModuleApplication " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
      ]
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
      [ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ ModuleApplication -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleApplication
amodapp
      ]
    (ModuleApplication, ScopeCopyInfo, ImportDirective)
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
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 ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldModuleName -> ScopeM ModuleName)
-> OldModuleName -> ScopeM ModuleName
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'

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

    ModuleName
m0 <- NewModuleName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (Name -> NewModuleName
NewModuleName Name
x)
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
90 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"NewModuleName: m0 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

    String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"mod.inst" VerboseLevel
20 String
"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 :: Maybe Range
publicOpen = Maybe Range
forall a. Maybe a
Nothing }
                               , ImportDirective
forall n m. ImportDirective' n m
defaultImportDir { publicOpen :: Maybe Range
publicOpen = ImportDirective -> Maybe Range
forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
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
    String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"mod.inst.app" VerboseLevel
20 String
"checkModuleMacro, after checkModuleApplication"

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

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

    String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"mod.inst.copy.after" VerboseLevel
20 String
"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 (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
adir'
      OpenShortHand
DoOpen   -> 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
    String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"mod.inst" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ OpenShortHand -> String
forall a. Show a => a -> String
show OpenShortHand
open
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
90 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"after open   : m0 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ModuleName -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
m0

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

    let m :: ModuleName
m      = ModuleName
m0 ModuleName -> [Name] -> ModuleName
`withRangesOf` [Name
x]
        adecls :: [a]
adecls = [ ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a
apply ModuleInfo
info ModuleName
m ModuleApplication
modapp' ScopeCopyInfo
copyInfo ImportDirective
adir ]

    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
      [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"scope checked ModuleMacro " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
      ]
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn  String
"scope.decl" VerboseLevel
90 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"info    = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> String
forall a. Show a => a -> String
show ModuleInfo
info
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn  String
"scope.decl" VerboseLevel
90 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"m       = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn  String
"scope.decl" VerboseLevel
90 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"modapp' = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleApplication -> String
forall a. Show a => a -> String
show ModuleApplication
modapp'
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
90 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> TCM Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> TCM Doc) -> Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ ScopeCopyInfo -> Doc
forall a. Pretty a => a -> Doc
pretty ScopeCopyInfo
copyInfo
    String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
      (a -> TCM Doc) -> [a] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> (a -> TCM Doc) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA) [a]
adecls
    [a] -> ScopeM [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
adecls
  where
    info :: ModuleInfo
info = ModuleInfo :: Range
-> Range
-> Maybe Name
-> Maybe OpenShortHand
-> Maybe ImportDirective
-> ModuleInfo
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 (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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Warning -> m ()
warning Warning
UselessPublic
  ImportDirective -> ScopeM ImportDirective
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 :: Maybe Range
publicOpen = Maybe Range
forall a. Maybe a
Nothing }

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

renamingRange :: C.ImportDirective -> Range
renamingRange :: ImportDirective -> Range
renamingRange = [Range] -> Range
forall t. HasRange t => t -> 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 -> [Renaming' 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
  String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    ModuleName
cm <- ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
      [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text   String
"scope checking NiceOpen " TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> TCM Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x)
      , String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text   String
"  getCurrentModule       = " TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> ModuleName -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA ModuleName
cm
      , String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"  getCurrentModule (raw) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Show a => a -> String
show ModuleName
cm
      , String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"  C.ImportDirective      = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ImportDirective -> String
forall a. Pretty a => a -> String
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) -> ScopeM ModuleName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM 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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Warning -> m ()
warning Warning
UselessPublic

  ModuleName
m <- Maybe ModuleName
-> ScopeM ModuleName
-> (ModuleName -> ScopeM ModuleName)
-> ScopeM ModuleName
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ModuleName
mam (OldModuleName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> OldModuleName
OldModuleName QName
x)) ModuleName -> ScopeM ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return
  String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"open" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"opening " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
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
  String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"open" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"result:"
  let minfo :: ModuleInfo
minfo = ModuleInfo :: Range
-> Range
-> Maybe Name
-> Maybe OpenShortHand
-> Maybe ImportDirective
-> ModuleInfo
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]
  String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
    [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"scope checked NiceOpen " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x
    ] [TCM Doc] -> [TCM Doc] -> [TCM Doc]
forall a. [a] -> [a] -> [a]
++ (Declaration -> TCM Doc) -> [Declaration] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc)
-> (Declaration -> TCM Doc) -> Declaration -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA) [Declaration]
adecls
  (ModuleInfo, ModuleName, ImportDirective)
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo
minfo, ModuleName
m, ImportDirective
adir)

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

concreteToAbstract_ :: ToAbstract c a => c -> ScopeM a
concreteToAbstract_ :: c -> ScopeM a
concreteToAbstract_ = c -> ScopeM a
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract

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

-- | Things that can be translated to abstract syntax are instances of this
--   class.
class ToAbstract concrete abstract | concrete -> abstract where
    toAbstract :: concrete -> ScopeM abstract

-- | 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 concrete abstract =>
                 Precedence -> concrete -> ScopeM abstract
toAbstractCtx :: Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
ctx concrete
c = Precedence -> ScopeM abstract -> ScopeM abstract
forall (m :: * -> *) a. ReadTCState m => Precedence -> m a -> m a
withContextPrecedence Precedence
ctx (ScopeM abstract -> ScopeM abstract)
-> ScopeM abstract -> ScopeM abstract
forall a b. (a -> b) -> a -> b
$ concrete -> ScopeM abstract
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract concrete
c

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

toAbstractHiding :: (LensHiding h, ToAbstract c a) => h -> c -> ScopeM a
toAbstractHiding :: h -> c -> ScopeM a
toAbstractHiding h
h | h -> Bool
forall a. LensHiding a => a -> Bool
visible h
h = c -> ScopeM a
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract -- don't change precedence if visible
toAbstractHiding h
_             = Precedence -> c -> ScopeM a
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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 concrete abstract =>
--                     Precedence -> concrete -> (abstract -> ScopeM a) -> ScopeM a
--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 a => c -> (a -> ScopeM b) -> ScopeM b
localToAbstract :: c -> (a -> ScopeM b) -> ScopeM b
localToAbstract c
x a -> 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 -> (a -> ScopeM b) -> TCMT IO (b, ScopeInfo)
forall c a b.
ToAbstract c a =>
c -> (a -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' c
x a -> ScopeM b
ret

-- | Like 'localToAbstract' but returns the scope after the completion of the
--   second argument.
localToAbstract' :: ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' :: c -> (a -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' c
x a -> 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
$ a -> ScopeM b
ret (a -> ScopeM b) -> TCMT IO a -> ScopeM b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< c -> TCMT IO a
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract c
x

instance ToAbstract () () where
  toAbstract :: () -> TCMT IO ()
toAbstract = () -> TCMT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (ToAbstract c1 a1, ToAbstract c2 a2) => ToAbstract (c1,c2) (a1,a2) where
  toAbstract :: (c1, c2) -> ScopeM (a1, a2)
toAbstract (c1
x,c2
y) = (,) (a1 -> a2 -> (a1, a2)) -> TCMT IO a1 -> TCMT IO (a2 -> (a1, a2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c1 -> TCMT IO a1
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract c1
x TCMT IO (a2 -> (a1, a2)) -> TCMT IO a2 -> ScopeM (a1, a2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c2 -> TCMT IO a2
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract c2
y

instance (ToAbstract c1 a1, ToAbstract c2 a2, ToAbstract c3 a3) =>
         ToAbstract (c1,c2,c3) (a1,a2,a3) where
    toAbstract :: (c1, c2, c3) -> ScopeM (a1, a2, a3)
toAbstract (c1
x,c2
y,c3
z) = (a1, (a2, a3)) -> (a1, a2, a3)
forall a b c. (a, (b, c)) -> (a, b, c)
flatten ((a1, (a2, a3)) -> (a1, a2, a3))
-> TCMT IO (a1, (a2, a3)) -> ScopeM (a1, a2, a3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (c1, (c2, c3)) -> TCMT IO (a1, (a2, a3))
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 {-# OVERLAPPABLE #-} ToAbstract c a => ToAbstract [c] [a] where
  toAbstract :: [c] -> ScopeM [a]
toAbstract = (c -> TCMT IO a) -> [c] -> ScopeM [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM c -> TCMT IO a
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract

instance (ToAbstract c1 a1, ToAbstract c2 a2) =>
         ToAbstract (Either c1 c2) (Either a1 a2) where
    toAbstract :: Either c1 c2 -> ScopeM (Either a1 a2)
toAbstract = (c1 -> TCMT IO a1)
-> (c2 -> TCMT IO a2) -> Either c1 c2 -> ScopeM (Either a1 a2)
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 a1
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract c2 -> TCMT IO a2
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract

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

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

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

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

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

newtype OldName a = OldName a

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

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

instance ToAbstract (NewName C.Name) A.Name where
  toAbstract :: NewName Name -> ScopeM 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 (m :: * -> *) a. Monad m => a -> m a
return Name
y

instance ToAbstract (NewName C.BoundName) A.BindName where
  toAbstract :: NewName BoundName -> ScopeM BindName
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 -> ScopeM BindName
forall (m :: * -> *) a. Monad m => a -> m a
return (BindName -> ScopeM BindName) -> BindName -> ScopeM BindName
forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.BindName Name
y

instance ToAbstract OldQName A.Expr where
  toAbstract :: OldQName -> ScopeM Expr
toAbstract q :: OldQName
q@(OldQName QName
x Maybe (Set Name)
_) =
    ScopeM Expr -> TCMT IO (Maybe Expr) -> ScopeM Expr
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 Expr) -> ScopeM Expr)
-> TCMT IO (Maybe Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ MaybeOldQName -> TCMT IO (Maybe Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldQName -> MaybeOldQName
MaybeOldQName OldQName
q)

instance ToAbstract MaybeOldQName (Maybe A.Expr) where
  toAbstract :: MaybeOldQName -> TCMT IO (Maybe Expr)
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
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.name" VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"resolved " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ResolvedName -> String
forall a. Pretty a => a -> String
prettyShow ResolvedName
qx
    case ResolvedName
qx of
      VarName Name
x' BindingSource
_         -> Maybe Expr -> TCMT IO (Maybe Expr)
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      -> do
        -- In case we find a defined name, we start by checking whether there's
        -- a warning attached to it
        String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.warning" VerboseLevel
50 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"Checking usage of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AbstractName -> String
forall a. Pretty a => a -> String
prettyShow AbstractName
d
        Maybe String
mstr <- QName -> Map QName String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AbstractName -> QName
anameName AbstractName
d) (Map QName String -> Maybe String)
-> TCMT IO (Map QName String) -> TCMT IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO (Map QName String)
forall (m :: * -> *). ReadTCState m => m (Map QName String)
getUserWarnings
        Maybe String -> (String -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
mstr (Warning -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Warning -> m ()
warning (Warning -> TCMT IO ())
-> (String -> Warning) -> String -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Warning
UserWarning)
        -- then we take note of generalized names used
        case AbstractName -> KindOfName
anameKind AbstractName
d of
          KindOfName
GeneralizeName -> do
            Maybe (Set QName)
gvs <- Lens' (Maybe (Set QName)) TCState -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars
            case Maybe (Set QName)
gvs of   -- Subtle: Use (left-biased) union instead of insert to keep the old name if
                          -- already present. This way we can sort by source location when generalizing
                          -- (Issue 3354).
                Just Set QName
s -> Lens' (Maybe (Set QName)) TCState
stGeneralizedVars Lens' (Maybe (Set QName)) TCState
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 -> do
            TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ())
-> (Doc -> TypeError) -> Doc -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
              String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text String
"Cannot use generalized variable from let-opened module:" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (AbstractName -> QName
anameName AbstractName
d)
          KindOfName
_ -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- and then we return the name
        Maybe Expr -> TCMT IO (Maybe Expr)
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
$ AbstractName -> Expr
forall a. NameToExpr a => a -> Expr
nameToExpr AbstractName
d
      FieldName     NonEmpty AbstractName
ds     -> Maybe Expr -> TCMT IO (Maybe Expr)
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
$ ProjOrigin -> AmbiguousQName -> Expr
A.Proj ProjOrigin
ProjPrefix (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)
      ConstructorName NonEmpty AbstractName
ds   -> Maybe Expr -> TCMT IO (Maybe Expr)
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
A.Con (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)
      ResolvedName
UnknownName          -> Maybe Expr -> TCMT IO (Maybe Expr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Expr
forall a. Maybe a
Nothing
      PatternSynResName NonEmpty AbstractName
ds -> Maybe Expr -> TCMT IO (Maybe Expr)
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
A.PatternSyn (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)

instance ToAbstract ResolveQName ResolvedName where
  toAbstract :: ResolveQName -> ScopeM ResolvedName
toAbstract (ResolveQName QName
x) = QName -> ScopeM ResolvedName
resolveName QName
x ScopeM ResolvedName
-> (ResolvedName -> ScopeM ResolvedName) -> ScopeM ResolvedName
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 (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
q

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

instance ToAbstract PatName APatName where
  toAbstract :: PatName -> ScopeM APatName
toAbstract (PatName QName
x Maybe (Set Name)
ns) = do
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"checking pattern name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x
    ResolvedName
rx <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' ([KindOfName] -> KindsOfNames
someKindsOfNames [KindOfName
ConName, 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
    case (ResolvedName
rx, QName
x) of
      (VarName Name
y BindingSource
_,     C.QName Name
x)                          -> Name -> ScopeM APatName
bindPatVar Name
x
      (FieldName NonEmpty AbstractName
d,     C.QName Name
x)                          -> Name -> ScopeM APatName
bindPatVar Name
x
      (DefinedName Access
_ AbstractName
d, C.QName Name
x) | KindOfName -> Bool
isDefName (AbstractName -> KindOfName
anameKind AbstractName
d)-> Name -> ScopeM APatName
bindPatVar Name
x
      (ResolvedName
UnknownName,     C.QName Name
x)                          -> Name -> ScopeM APatName
bindPatVar Name
x
      (ConstructorName NonEmpty AbstractName
ds, QName
_)                               -> NonEmpty AbstractName -> ScopeM APatName
forall (m :: * -> *).
MonadDebug m =>
NonEmpty AbstractName -> m APatName
patCon NonEmpty AbstractName
ds
      (PatternSynResName NonEmpty AbstractName
d, QName
_)                              -> NonEmpty AbstractName -> ScopeM APatName
forall (m :: * -> *).
MonadDebug m =>
NonEmpty AbstractName -> m APatName
patSyn NonEmpty AbstractName
d
      (ResolvedName, QName)
_ -> String -> ScopeM APatName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM APatName) -> String -> ScopeM APatName
forall a b. (a -> b) -> a -> b
$ String
"Cannot pattern match on non-constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x
    where
      bindPatVar :: Name -> ScopeM APatName
bindPatVar = Name -> APatName
VarPatName (Name -> APatName)
-> (Name -> ScopeM Name) -> Name -> ScopeM APatName
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Name -> ScopeM Name
bindPatternVariable
      patCon :: NonEmpty AbstractName -> m APatName
patCon NonEmpty AbstractName
ds = do
        String -> VerboseLevel -> String -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
10 (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"it was a con: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)
        APatName -> m APatName
forall (m :: * -> *) a. Monad m => a -> m a
return (APatName -> m APatName) -> APatName -> m APatName
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> APatName
ConPatName NonEmpty AbstractName
ds
      patSyn :: NonEmpty AbstractName -> m APatName
patSyn NonEmpty AbstractName
ds = do
        String -> VerboseLevel -> String -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
10 (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"it was a pat syn: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)
        APatName -> m APatName
forall (m :: * -> *) a. Monad m => a -> m a
return (APatName -> m APatName) -> APatName -> m APatName
forall a b. (a -> b) -> a -> b
$ NonEmpty AbstractName -> APatName
PatternSynPatName NonEmpty 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
  String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"it was a var: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
  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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (LocalVar Name
y BindingSource
_ [AbstractName]
_) -> Name -> ScopeM Name
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 t. SetRange t => Range -> t -> t
setRange (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x) Name
y
    Maybe LocalVar
Nothing -> 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 (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 (Show a, ToQName a) => ToAbstract (OldName a) A.QName where
  toAbstract :: OldName a -> ScopeM QName
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      -> QName -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> ScopeM QName) -> QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
      -- We can get the cases below for DISPLAY pragmas
      ConstructorName NonEmpty AbstractName
ds   -> QName -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> ScopeM QName) -> QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty AbstractName
ds)   -- We'll throw out this one, so it doesn't matter which one we pick
      FieldName NonEmpty AbstractName
ds         -> QName -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> ScopeM QName) -> QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty AbstractName
ds)
      PatternSynResName NonEmpty AbstractName
ds -> QName -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> ScopeM QName) -> QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty AbstractName
ds)
      VarName Name
x BindingSource
_          -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM QName) -> String -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ String
"Not a defined name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
      ResolvedName
UnknownName          -> QName -> ScopeM QName
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 -> ScopeM 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
. [Name] -> ModuleName
mnameFromList ([Name] -> ModuleName) -> (Name -> [Name]) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[]) (Name -> ModuleName) -> ScopeM Name -> ScopeM 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
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.clash" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"clashing modules ms = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [AbstractModule] -> String
forall a. Pretty a => a -> String
prettyShow [AbstractModule]
ms
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.clash" VerboseLevel
60 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"clashing modules ms = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [AbstractModule] -> String
forall a. Show a => a -> String
show [AbstractModule]
ms
    Name -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 A.ModuleName where
  toAbstract :: NewModuleName -> ScopeM ModuleName
toAbstract (NewModuleName Name
x) = do
    Name -> TCMT IO ()
checkForModuleClash Name
x
    ModuleName
m <- ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    ModuleName
y <- ModuleName -> Name -> ScopeM ModuleName
freshQModule ModuleName
m Name
x
    Maybe DataOrRecord -> ModuleName -> TCMT IO ()
createModule Maybe DataOrRecord
forall a. Maybe a
Nothing ModuleName
y
    ModuleName -> ScopeM ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
y

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

instance ToAbstract OldModuleName A.ModuleName where
  toAbstract :: OldModuleName -> ScopeM ModuleName
toAbstract (OldModuleName QName
q) = QName -> ScopeM ModuleName -> ScopeM ModuleName
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange QName
q (ScopeM ModuleName -> ScopeM ModuleName)
-> ScopeM ModuleName -> ScopeM ModuleName
forall a b. (a -> b) -> a -> b
$ do
    AbstractModule -> ModuleName
amodName (AbstractModule -> ModuleName)
-> TCMT IO AbstractModule -> ScopeM 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_ 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_ Expr -> Expr
forall name a. Named name a -> a
namedThing Named_ Expr
e
mkArg' ArgInfo
info (C.InstanceArg Range
_ Named_ 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_ Expr -> Expr
forall name a. Named name a -> a
namedThing Named_ 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 @C.Expr@ as @A.Expr@, interpreting dots as relevance.
toAbstractDot :: Precedence -> C.Expr -> ScopeM (A.Expr, Relevance)
toAbstractDot :: Precedence -> Expr -> ScopeM (Expr, Relevance)
toAbstractDot Precedence
prec Expr
e = do
    String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.irrelevance" VerboseLevel
100 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"toAbstractDot: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e)
    Call -> ScopeM (Expr, Relevance) -> ScopeM (Expr, Relevance)
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) (ScopeM (Expr, Relevance) -> ScopeM (Expr, Relevance))
-> ScopeM (Expr, Relevance) -> ScopeM (Expr, Relevance)
forall a b. (a -> b) -> a -> b
$ case Expr
e of

      C.RawApp Range
_ [Expr]
es   -> Precedence -> Expr -> ScopeM (Expr, Relevance)
toAbstractDot Precedence
prec (Expr -> ScopeM (Expr, Relevance))
-> TCMT IO Expr -> ScopeM (Expr, Relevance)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Expr] -> TCMT IO Expr
parseApplication [Expr]
es
      C.Paren Range
_ Expr
e     -> Precedence -> Expr -> ScopeM (Expr, Relevance)
toAbstractDot Precedence
TopCtx Expr
e
      C.Dot Range
_ Expr
e       -> (,Relevance
Irrelevant) (Expr -> (Expr, Relevance))
-> ScopeM Expr -> ScopeM (Expr, Relevance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
prec Expr
e
      C.DoubleDot Range
_ Expr
e -> (,Relevance
NonStrict)  (Expr -> (Expr, Relevance))
-> ScopeM Expr -> ScopeM (Expr, Relevance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
prec Expr
e
      Expr
e               -> (,Relevance
Relevant)   (Expr -> (Expr, Relevance))
-> ScopeM Expr -> ScopeM (Expr, Relevance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
prec Expr
e

-- | Translate concrete expression under at least one binder into nested
--   lambda abstraction in abstract syntax.
toAbstractLam :: Range -> [C.LamBinding] -> C.Expr -> Precedence -> ScopeM A.Expr
toAbstractLam :: Range -> [LamBinding] -> Expr -> Precedence -> ScopeM Expr
toAbstractLam Range
r [LamBinding]
bs Expr
e Precedence
ctx = do
  -- Translate the binders
  [(Name, LocalVar)]
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
  [LamBinding] -> ([LamBinding] -> ScopeM Expr) -> ScopeM Expr
forall c a b. ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM b
localToAbstract ((LamBinding -> LamBinding) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> [a] -> [b]
map (TypedBinding' Expr -> LamBinding
forall a. a -> LamBinding' a
C.DomainFull (TypedBinding' Expr -> LamBinding)
-> (LamBinding -> TypedBinding' Expr) -> LamBinding -> LamBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LamBinding -> TypedBinding' Expr
makeDomainFull) [LamBinding]
bs) (([LamBinding] -> ScopeM Expr) -> ScopeM Expr)
-> ([LamBinding] -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \ [LamBinding]
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
ctx Expr
e
    -- We have at least one binder.  Get first @b@ and rest @bs@.
    [LamBinding]
-> ScopeM Expr
-> (LamBinding -> [LamBinding] -> ScopeM Expr)
-> ScopeM Expr
forall a b. [a] -> b -> (a -> [a] -> b) -> b
caseList [LamBinding]
bs ScopeM Expr
forall a. HasCallStack => a
__IMPOSSIBLE__ ((LamBinding -> [LamBinding] -> ScopeM Expr) -> ScopeM Expr)
-> (LamBinding -> [LamBinding] -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \ LamBinding
b [LamBinding]
bs -> do
      Expr -> ScopeM Expr
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 (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 (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 -> [C.LamClause] -> ScopeM A.Expr
scopeCheckExtendedLam :: Range -> [LamClause] -> ScopeM Expr
scopeCheckExtendedLam Range
r [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
$
    String -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Extended lambdas are not allowed in dot patterns"

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

  -- Compose a function definition and scope check it.
  let
    insertApp :: C.Pattern -> ScopeM C.Pattern
    insertApp :: Pattern -> ScopeM Pattern
insertApp (C.RawAppP Range
r [Pattern]
es) = Pattern -> ScopeM Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> ScopeM Pattern) -> Pattern -> ScopeM Pattern
forall a b. (a -> b) -> a -> b
$ Range -> [Pattern] -> Pattern
C.RawAppP Range
r ([Pattern] -> Pattern) -> [Pattern] -> Pattern
forall a b. (a -> b) -> a -> b
$ QName -> Pattern
IdentP (Name -> QName
C.QName Name
cname) Pattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
: [Pattern]
es
    insertApp (C.AppP Pattern
p1 NamedArg Pattern
p2)   = Pattern -> ScopeM Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> ScopeM Pattern) -> Pattern -> ScopeM Pattern
forall a b. (a -> b) -> a -> b
$ (QName -> Pattern
IdentP (Name -> QName
C.QName Name
cname) Pattern -> NamedArg Pattern -> Pattern
`C.AppP` Pattern -> NamedArg Pattern
forall a. a -> NamedArg a
defaultNamedArg Pattern
p1) Pattern -> NamedArg Pattern -> Pattern
`C.AppP` NamedArg Pattern
p2  -- Case occurs in issue #2785
    insertApp Pattern
p = Pattern -> ScopeM Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> ScopeM Pattern) -> Pattern -> ScopeM Pattern
forall a b. (a -> b) -> a -> b
$ Range -> [Pattern] -> Pattern
C.RawAppP Range
r ([Pattern] -> Pattern) -> [Pattern] -> Pattern
forall a b. (a -> b) -> a -> b
$ QName -> Pattern
IdentP (Name -> QName
C.QName Name
cname) Pattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
: [Pattern
p] -- Issue #2807: C.ParenP also possible
      where r :: Range
r = Pattern -> Range
forall t. HasRange t => t -> Range
getRange Pattern
p
      -- Andreas, 2017-10-17 issue #2807: do not raise IMPOSSSIBLE here
      -- since we are actually not sure what is possible and what not.

    -- insertApp (C.IdentP q    ) = return $ C.RawAppP r $ IdentP (C.QName cname) : [C.IdentP q]
    --   where r = getRange q
    -- insertApp p = do
    --   reportSLn "impossible" 10 $ "scopeCheckExtendedLam: unexpected pattern: " ++
    --     case p of
    --       C.QuoteP{}    -> "QuoteP"
    --       C.OpAppP{}    -> "OpAppP"
    --       C.HiddenP{}   -> "HiddenP"
    --       C.InstanceP{} -> "InstanceP"
    --       C.ParenP{}    -> "ParenP"
    --       C.WildP{}     -> "WildP"
    --       C.AbsurdP{}   -> "AbsurdP"
    --       C.AsP{}       -> "AsP"
    --       C.DotP{}      -> "DotP"
    --       C.LitP{}      -> "LitP"
    --       C.RecP{}      -> "RecP"
    --       _ -> __IMPOSSIBLE__
    --   __IMPOSSIBLE__

  -- 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)
-> TCMT IO [Clause] -> TCMT IO NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          [LamClause] -> (LamClause -> TCMT IO Clause) -> TCMT IO [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LamClause]
cs ((LamClause -> TCMT IO Clause) -> TCMT IO [Clause])
-> (LamClause -> TCMT IO Clause) -> TCMT IO [Clause]
forall a b. (a -> b) -> a -> b
$ \ (LamClause LHS
lhs RHS' Expr
rhs WhereClause' [Declaration]
wh Bool
ca) -> do -- wh == NoWhere, see parser for more info
            LHS
lhs' <- (Pattern -> ScopeM Pattern) -> LHS -> TCMT IO LHS
forall (m :: * -> *).
(Functor m, Applicative m) =>
(Pattern -> m Pattern) -> LHS -> m LHS
mapLhsOriginalPatternM Pattern -> ScopeM Pattern
insertApp LHS
lhs
            Clause -> TCMT IO Clause
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]
wh []
  Declaration
scdef <- NiceDeclaration -> ScopeM Declaration
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract NiceDeclaration
d

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

-- | Scope check an expression.

instance ToAbstract C.Expr A.Expr where
  toAbstract :: Expr -> ScopeM Expr
toAbstract Expr
e =
    Call -> ScopeM Expr -> ScopeM Expr
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ScopeM Expr -> ScopeM 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)

  -- Literals
      C.Lit Literal
l ->
        case Literal
l of
          LitNat Range
r 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
=<< String -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => String -> m (Maybe Term)
getBuiltin' String
builtinFromNat
                l' :: Literal
l'   = Range -> Integer -> Literal
LitNat Range
r (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n)
                info :: AppInfo
info = Range -> AppInfo
defaultAppInfo Range
r
            Maybe Term
conv <- TCMT IO (Maybe Term)
builtin
            case Maybe Term
conv of
              Just (I.Def QName
q Elims
_) -> Expr -> ScopeM Expr
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 (QName -> Expr
A.Def QName
q) (NamedArg Expr -> Expr) -> NamedArg Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg (Literal -> Expr
A.Lit Literal
l')
              Maybe Term
_                -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Literal -> Expr
A.Lit Literal
l

          LitString Range
r String
s -> do
            Maybe Term
conv <- 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
=<< String -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => String -> m (Maybe Term)
getBuiltin' String
builtinFromString
            let info :: AppInfo
info = Range -> AppInfo
defaultAppInfo Range
r
            case Maybe Term
conv of
              Just (I.Def QName
q Elims
_) -> Expr -> ScopeM Expr
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 (QName -> Expr
A.Def QName
q) (NamedArg Expr -> Expr) -> NamedArg Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg (Literal -> Expr
A.Lit Literal
l)
              Maybe Term
_                -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Literal -> Expr
A.Lit Literal
l

          Literal
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Literal -> Expr
A.Lit Literal
l
        where
          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
isNameInScope 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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
v) (Maybe Term -> TCMT IO (Maybe Term)
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing

  -- Meta variables
      C.QuestionMark Range
r Maybe VerboseLevel
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 VerboseLevel -> TCMT IO InteractionId
forall (m :: * -> *).
MonadInteractionPoints m =>
Bool -> Range -> Maybe VerboseLevel -> m InteractionId
registerInteractionPoint Bool
True Range
r Maybe VerboseLevel
n
        let info :: MetaInfo
info = MetaInfo :: Range -> ScopeInfo -> Maybe MetaId -> String -> MetaInfo
MetaInfo
             { metaRange :: Range
metaRange  = Range
r
             , metaScope :: ScopeInfo
metaScope  = ScopeInfo
scope
             , metaNumber :: Maybe MetaId
metaNumber = Maybe MetaId
forall a. Maybe a
Nothing
             , metaNameSuggestion :: String
metaNameSuggestion = String
""
             }
        Expr -> ScopeM Expr
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 String
n -> do
        ScopeInfo
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
        Expr -> ScopeM Expr
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 :: Range -> ScopeInfo -> Maybe MetaId -> String -> MetaInfo
MetaInfo
                    { metaRange :: Range
metaRange  = Range
r
                    , metaScope :: ScopeInfo
metaScope  = ScopeInfo
scope
                    , metaNumber :: Maybe MetaId
metaNumber = Maybe MetaId
-> (String -> Maybe MetaId) -> Maybe String -> Maybe MetaId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe MetaId
forall a. Maybe a
Nothing String -> Maybe MetaId
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe String
n
                    , metaNameSuggestion :: String
metaNameSuggestion = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
n
                    }

  -- Raw application
      C.RawApp Range
r [Expr]
es -> do
        Expr
e <- [Expr] -> TCMT IO Expr
parseApplication [Expr]
es
        Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
e

  -- Application
      C.App Range
r Expr
e1 NamedArg Expr
e2 -> do
        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 :: Origin
appOrigin = Origin
UserWritten, appParens :: ParenPreference
appParens = ParenPreference
parenPref }
        Expr
e1 <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
FunctionCtx Expr
e1
        NamedArg Expr
e2 <- Precedence -> NamedArg Expr -> ScopeM (NamedArg Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx (ParenPreference -> Precedence
ArgumentCtx ParenPreference
parenPref) NamedArg Expr
e2
        Expr -> ScopeM Expr
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 [NamedArg (MaybePlaceholder (OpApp Expr))]
es -> QName
-> Set Name
-> [NamedArg (MaybePlaceholder (OpApp Expr))]
-> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns [NamedArg (MaybePlaceholder (OpApp Expr))]
es

  -- With application
      C.WithApp Range
r Expr
e [Expr]
es -> do
        Expr
e  <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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)
mapM (Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
WithArgCtx) [Expr]
es
        Expr -> ScopeM Expr
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_ Expr
_ -> Expr -> ScopeM Expr
nothingAppliedToHiddenArg Expr
e
      C.InstanceArg Range
_ Named_ Expr
_ -> Expr -> ScopeM Expr
nothingAppliedToInstanceArg Expr
e

  -- Lambda
      C.AbsurdLam Range
r Hiding
h -> Expr -> ScopeM Expr
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 [LamBinding]
bs Expr
e -> Range -> [LamBinding] -> Expr -> Precedence -> ScopeM Expr
toAbstractLam Range
r [LamBinding]
bs Expr
e Precedence
TopCtx

  -- Extended Lambda
      C.ExtendedLam Range
r [LamClause]
cs -> Range -> [LamClause] -> ScopeM Expr
scopeCheckExtendedLam Range
r [LamClause]
cs

  -- Relevant and irrelevant non-dependent function type
      C.Fun Range
r (Arg ArgInfo
info1 Expr
e1) Expr
e2 -> do
        Arg ArgInfo
info (Expr
e1', Relevance
rel) <- (Expr -> ScopeM (Expr, Relevance))
-> Arg Expr -> TCMT IO (Arg (Expr, Relevance))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Precedence -> Expr -> ScopeM (Expr, Relevance)
toAbstractDot Precedence
FunctionSpaceDomainCtx) (Arg Expr -> TCMT IO (Arg (Expr, Relevance)))
-> Arg Expr -> TCMT IO (Arg (Expr, Relevance))
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Expr -> Arg Expr
mkArg' ArgInfo
info1 Expr
e1
        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
        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
info) Expr
e1') (Expr -> Expr) -> ScopeM Expr -> ScopeM Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx Expr
e2

  -- Dependent function type
      e0 :: Expr
e0@(C.Pi Telescope
tel Expr
e) -> do
        [(Name, LocalVar)]
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
        Telescope -> ([TypedBinding] -> ScopeM Expr) -> ScopeM Expr
forall c a b. ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM b
localToAbstract Telescope
tel (([TypedBinding] -> ScopeM Expr) -> ScopeM Expr)
-> ([TypedBinding] -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \[TypedBinding]
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx Expr
e
          let info :: ExprInfo
info = Range -> ExprInfo
ExprRange (Expr -> Range
forall t. HasRange t => t -> Range
getRange Expr
e0)
          Expr -> ScopeM Expr
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.Pi ExprInfo
info [TypedBinding]
tel Expr
e

  -- Sorts
      C.Set Range
_    -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Integer -> Expr
A.Set (Range -> ExprInfo
ExprRange (Range -> ExprInfo) -> Range -> ExprInfo
forall a b. (a -> b) -> a -> b
$ Expr -> Range
forall t. HasRange t => t -> Range
getRange Expr
e) Integer
0
      C.SetN Range
_ Integer
n -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Integer -> Expr
A.Set (Range -> ExprInfo
ExprRange (Range -> ExprInfo) -> Range -> ExprInfo
forall a b. (a -> b) -> a -> b
$ Expr -> Range
forall t. HasRange t => t -> Range
getRange Expr
e) Integer
n
      C.Prop Range
_   -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Integer -> Expr
A.Prop (Range -> ExprInfo
ExprRange (Range -> ExprInfo) -> Range -> ExprInfo
forall a b. (a -> b) -> a -> b
$ Expr -> Range
forall t. HasRange t => t -> Range
getRange Expr
e) Integer
0
      C.PropN Range
_ Integer
n -> Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Integer -> Expr
A.Prop (Range -> ExprInfo
ExprRange (Range -> ExprInfo) -> Range -> ExprInfo
forall a b. (a -> b) -> a -> b
$ Expr -> Range
forall t. HasRange t => t -> Range
getRange Expr
e) Integer
n

  -- Let
      e0 :: Expr
e0@(C.Let Range
_ [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 (String -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM Expr) -> String -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ String
"Let-expressions are not allowed in dot patterns") (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$
        LetDefs -> ([LetBinding] -> ScopeM Expr) -> ScopeM Expr
forall c a b. ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM b
localToAbstract ([Declaration] -> LetDefs
LetDefs [Declaration]
ds) (([LetBinding] -> ScopeM Expr) -> ScopeM Expr)
-> ([LetBinding] -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \[LetBinding]
ds' -> do
          Expr
e <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx Expr
e
          let info :: ExprInfo
info = Range -> ExprInfo
ExprRange (Expr -> Range
forall t. HasRange t => t -> Range
getRange Expr
e0)
          Expr -> ScopeM Expr
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.Let ExprInfo
info [LetBinding]
ds' Expr
e
      C.Let Range
_ [Declaration]
_ TacticAttribute
Nothing -> String -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Missing body in let-expression"

  -- Record construction
      C.Rec Range
r RecordAssignments
fs  -> do
        [Either Assign (ModuleName, [LetBinding])]
fs' <- Precedence
-> RecordAssignments
-> ScopeM [Either Assign (ModuleName, [LetBinding])]
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx RecordAssignments
fs
        let ds' :: [LetBinding]
ds'  = [ LetBinding
d | Right (ModuleName
_, [LetBinding]
ds) <- [Either Assign (ModuleName, [LetBinding])]
fs', LetBinding
d <- [LetBinding]
ds ]
            fs'' :: [Either Assign ModuleName]
fs'' = (Either Assign (ModuleName, [LetBinding])
 -> Either Assign ModuleName)
-> [Either Assign (ModuleName, [LetBinding])]
-> [Either Assign ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (((ModuleName, [LetBinding]) -> ModuleName)
-> Either Assign (ModuleName, [LetBinding])
-> Either Assign ModuleName
forall b d a. (b -> d) -> Either a b -> Either a d
mapRight (ModuleName, [LetBinding]) -> ModuleName
forall a b. (a, b) -> a
fst) [Either Assign (ModuleName, [LetBinding])]
fs'
            i :: ExprInfo
i    = Range -> ExprInfo
ExprRange Range
r
        Expr -> ScopeM Expr
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
e TCMT IO (Assigns -> Expr) -> TCMT IO Assigns -> ScopeM Expr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence -> [FieldAssignment] -> TCMT IO Assigns
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx [FieldAssignment]
fs

  -- Parenthesis
      C.Paren Range
_ Expr
e -> Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx Expr
e

  -- Idiom brackets
      C.IdiomBrackets Range
r [Expr]
es ->
        Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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 [DoStmt]
ss ->
        Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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 -> [DoStmt] -> TCMT IO Expr
desugarDoNotation Range
r [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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
e

  -- Pattern things
      C.As Range
_ Name
_ Expr
_ -> Expr -> ScopeM Expr
notAnExpression Expr
e
      C.Absurd Range
_ -> Expr -> ScopeM Expr
notAnExpression Expr
e

  -- Impossible things
      C.ETel Telescope
_  -> ScopeM Expr
forall a. HasCallStack => a
__IMPOSSIBLE__
      C.Equal{} -> String -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Parse error: unexpected '='"
      C.Ellipsis Range
_ -> String -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Parse error: unexpected '...'"
      C.DoubleDot Range
_ Expr
_ -> String -> ScopeM Expr
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Parse error: unexpected '..'"

  -- Quoting
      C.Quote Range
r -> Expr -> ScopeM Expr
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 (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 (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 -> do
        let AppView Expr
e' [NamedArg Expr]
args = Expr -> AppView
appView Expr
e
        Expr
e'   <- Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
e'
        [NamedArg Expr]
args <- [NamedArg Expr] -> ScopeM [NamedArg Expr]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [NamedArg Expr]
args
        Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr -> [NamedArg Expr] -> Expr
A.Tactic (Range -> ExprInfo
ExprRange Range
r) Expr
e' [NamedArg Expr]
args

  -- 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
e
        Expr -> ScopeM Expr
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 (A.ModuleName, [A.LetBinding]) where
  toAbstract :: ModuleAssignment -> ScopeM (ModuleName, [LetBinding])
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 = (, []) (ModuleName -> (ModuleName, [LetBinding]))
-> ScopeM ModuleName -> ScopeM (ModuleName, [LetBinding])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OldModuleName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> OldModuleName
OldModuleName QName
m)
    | Bool
otherwise = do
        Name
x <- Range -> NameId -> Name
C.NoName (QName -> Range
forall t. HasRange t => t -> 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
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> LetBinding)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> TCMT IO [LetBinding]
forall c a.
(Pretty c, ToConcrete a c) =>
(ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM [a]
checkModuleMacro ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding
LetApply OpenKind
LetOpenModule ((QName, [Expr], ImportDirective) -> Range
forall t. HasRange t => t -> Range
getRange (QName
m, [Expr]
es, ImportDirective
i)) Access
PublicAccess Name
x
                          (Range -> Telescope -> Expr -> ModuleApplication
C.SectionApp ((QName, [Expr]) -> Range
forall t. HasRange t => t -> Range
getRange (QName
m , [Expr]
es)) [] (Range -> [Expr] -> Expr
RawApp (QName -> [Expr] -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange QName
m [Expr]
es) (QName -> Expr
Ident QName
m Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr]
es)))
                          OpenShortHand
DontOpen ImportDirective
i
        case [LetBinding]
r of
          (LetApply ModuleInfo
_ ModuleName
m' ModuleApplication
_ ScopeCopyInfo
_ ImportDirective
_ : [LetBinding]
_) -> (ModuleName, [LetBinding]) -> ScopeM (ModuleName, [LetBinding])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m', [LetBinding]
r)
          [LetBinding]
_ -> ScopeM (ModuleName, [LetBinding])
forall a. HasCallStack => a
__IMPOSSIBLE__

instance ToAbstract c a => ToAbstract (FieldAssignment' c) (FieldAssignment' a) where
  toAbstract :: FieldAssignment' c -> ScopeM (FieldAssignment' a)
toAbstract = (c -> TCMT IO a)
-> FieldAssignment' c -> ScopeM (FieldAssignment' a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse c -> TCMT IO a
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract

instance ToAbstract (C.Binder' (NewName C.BoundName)) A.Binder where
  toAbstract :: Binder' (NewName BoundName) -> ScopeM Binder
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 (f :: * -> *) a. Applicative f => a -> f a
pure NewName BoundName
n else do
           Name
n' <- Range -> VerboseLevel -> String -> ScopeM Name
freshConcreteName (BoundName -> Range
forall t. HasRange t => t -> 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) VerboseLevel
0 String
patternInTeleName
           NewName BoundName -> TCMT IO (NewName BoundName)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ BoundName
n -> BoundName
n { boundName :: Name
C.boundName = Name
n' }) NewName BoundName
n
    BindName
n <- NewName BoundName -> ScopeM BindName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract NewName BoundName
n
    -- Actually parsing the pattern, checking it is linear,
    -- and bind its variables
    Maybe Pattern
p <- (Pattern -> ScopeM Pattern)
-> Maybe Pattern -> TCMT IO (Maybe Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Pattern -> ScopeM Pattern
parsePattern Maybe Pattern
p
    Maybe (Pattern' Expr)
p <- Maybe Pattern -> ScopeM (Maybe (Pattern' Expr))
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Maybe Pattern
p
    Maybe (Pattern' Expr) -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a p.
(Monad m, APatternLike a 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 (Maybe Pattern)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Maybe (Pattern' Expr)
p
    Binder -> ScopeM Binder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binder -> ScopeM Binder) -> Binder -> ScopeM Binder
forall a b. (a -> b) -> a -> b
$ Maybe Pattern -> BindName -> Binder
forall a. Maybe Pattern -> a -> Binder' a
A.Binder Maybe Pattern
p BindName
n

instance ToAbstract C.LamBinding A.LamBinding where
  toAbstract :: LamBinding -> ScopeM LamBinding
toAbstract (C.DomainFree Arg (Named NamedName (Binder' BoundName))
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)
traverse Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 -> BoundName
forall a. Binder' a -> a
C.binderName (Binder' BoundName -> BoundName) -> Binder' BoundName -> BoundName
forall a b. (a -> b) -> a -> b
$ Arg (Named NamedName (Binder' BoundName)) -> Binder' BoundName
forall a. NamedArg a -> a
namedArg Arg (Named NamedName (Binder' BoundName))
x
    Maybe Expr -> NamedArg Binder -> LamBinding
A.DomainFree Maybe Expr
tac (NamedArg Binder -> LamBinding)
-> TCMT IO (NamedArg Binder) -> ScopeM LamBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedArg (Binder' (NewName BoundName)) -> TCMT IO (NamedArg Binder)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ((Binder' BoundName -> Binder' (NewName BoundName))
-> Arg (Named NamedName (Binder' BoundName))
-> NamedArg (Binder' (NewName BoundName))
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> NewName BoundName)
-> Binder' BoundName -> Binder' (NewName BoundName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BoundName -> NewName BoundName)
 -> Binder' BoundName -> Binder' (NewName BoundName))
-> (BoundName -> NewName BoundName)
-> Binder' BoundName
-> Binder' (NewName BoundName)
forall a b. (a -> b) -> a -> b
$ BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
LambdaBound) Arg (Named NamedName (Binder' BoundName))
x)
  toAbstract (C.DomainFull TypedBinding' Expr
tb) = TypedBinding -> LamBinding
A.DomainFull (TypedBinding -> LamBinding)
-> TCMT IO TypedBinding -> ScopeM LamBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedBinding' Expr -> TCMT IO TypedBinding
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract TypedBinding' Expr
tb

makeDomainFull :: C.LamBinding -> C.TypedBinding
makeDomainFull :: LamBinding -> TypedBinding' Expr
makeDomainFull (C.DomainFull TypedBinding' Expr
b) = TypedBinding' Expr
b
makeDomainFull (C.DomainFree Arg (Named NamedName (Binder' BoundName))
x) = Range
-> [Arg (Named NamedName (Binder' BoundName))]
-> Expr
-> TypedBinding' Expr
forall e.
Range
-> [Arg (Named NamedName (Binder' BoundName))]
-> e
-> TypedBinding' e
C.TBind Range
r [Arg (Named NamedName (Binder' BoundName))
x] (Expr -> TypedBinding' Expr) -> Expr -> TypedBinding' Expr
forall a b. (a -> b) -> a -> b
$ Range -> Maybe String -> Expr
C.Underscore Range
r Maybe String
forall a. Maybe a
Nothing
  where r :: Range
r = Arg (Named NamedName (Binder' BoundName)) -> Range
forall t. HasRange t => t -> Range
getRange Arg (Named NamedName (Binder' BoundName))
x

instance ToAbstract C.TypedBinding A.TypedBinding where
  toAbstract :: TypedBinding' Expr -> TCMT IO TypedBinding
toAbstract (C.TBind Range
r [Arg (Named NamedName (Binder' BoundName))]
xs Expr
t) = do
    Expr
t' <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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)
traverse Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (TacticAttribute -> TCMT IO (Maybe Expr))
-> TacticAttribute -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$
             case (Arg (Named NamedName (Binder' BoundName)) -> TacticAttribute)
-> [Arg (Named NamedName (Binder' BoundName))] -> [Expr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (BoundName -> TacticAttribute
bnameTactic (BoundName -> TacticAttribute)
-> (Arg (Named NamedName (Binder' BoundName)) -> BoundName)
-> Arg (Named NamedName (Binder' BoundName))
-> TacticAttribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder' BoundName -> BoundName
forall a. Binder' a -> a
C.binderName (Binder' BoundName -> BoundName)
-> (Arg (Named NamedName (Binder' BoundName)) -> Binder' BoundName)
-> Arg (Named NamedName (Binder' BoundName))
-> BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg (Named NamedName (Binder' BoundName)) -> Binder' BoundName
forall a. NamedArg a -> a
namedArg) [Arg (Named NamedName (Binder' BoundName))]
xs of
               []      -> TacticAttribute
forall a. Maybe a
Nothing
               Expr
tac : [Expr]
_ -> Expr -> TacticAttribute
forall a. a -> Maybe a
Just Expr
tac
               -- Invariant: all tactics are the same
               -- (distributed in the parser, TODO: don't)
    [NamedArg Binder]
xs' <- [NamedArg (Binder' (NewName BoundName))]
-> ScopeM [NamedArg Binder]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ([NamedArg (Binder' (NewName BoundName))]
 -> ScopeM [NamedArg Binder])
-> [NamedArg (Binder' (NewName BoundName))]
-> ScopeM [NamedArg Binder]
forall a b. (a -> b) -> a -> b
$ (Arg (Named NamedName (Binder' BoundName))
 -> NamedArg (Binder' (NewName BoundName)))
-> [Arg (Named NamedName (Binder' BoundName))]
-> [NamedArg (Binder' (NewName BoundName))]
forall a b. (a -> b) -> [a] -> [b]
map ((Binder' BoundName -> Binder' (NewName BoundName))
-> Arg (Named NamedName (Binder' BoundName))
-> NamedArg (Binder' (NewName BoundName))
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> NewName BoundName)
-> Binder' BoundName -> Binder' (NewName BoundName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BoundName -> NewName BoundName)
 -> Binder' BoundName -> Binder' (NewName BoundName))
-> (BoundName -> NewName BoundName)
-> Binder' BoundName
-> Binder' (NewName BoundName)
forall a b. (a -> b) -> a -> b
$ BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
LambdaBound)) [Arg (Named NamedName (Binder' BoundName))]
xs
    TypedBinding -> TCMT IO TypedBinding
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedBinding -> TCMT IO TypedBinding)
-> TypedBinding -> TCMT IO TypedBinding
forall a b. (a -> b) -> a -> b
$ Range -> Maybe Expr -> [NamedArg Binder] -> Expr -> TypedBinding
A.TBind Range
r Maybe Expr
tac [NamedArg Binder]
xs' Expr
t'
  toAbstract (C.TLet Range
r [Declaration]
ds) = Range -> [LetBinding] -> TypedBinding
A.TLet Range
r ([LetBinding] -> TypedBinding)
-> TCMT IO [LetBinding] -> TCMT IO TypedBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetDefs -> TCMT IO [LetBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ([Declaration] -> LetDefs
LetDefs [Declaration]
ds)

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

  | Bool
otherwise = do
        ScopeM [Declaration]
scopeCheckNiceModule_
  where
    -- The actual workhorse:
    scopeCheckNiceModule_ :: ScopeM [Declaration]
scopeCheckNiceModule_ = 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 (m :: * -> *) a. Monad m => a -> m a
return (Range -> NameId -> Name
C.NoName (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
name) NameId
i, Origin -> Access
PrivateAccess Origin
Inserted, Bool
True)
         else (Name, Access, Bool) -> TCMT IO (Name, Access, Bool)
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 ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (Name -> NewModuleName
NewModuleName Name
name)
      [Declaration]
ds <- (ScopeInfo, [Declaration]) -> [Declaration]
forall a b. (a, b) -> b
snd ((ScopeInfo, [Declaration]) -> [Declaration])
-> TCMT IO (ScopeInfo, [Declaration]) -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, [Declaration])
scopeCheckModule Range
r (Name -> QName
C.QName Name
name) ModuleName
aname Telescope
tel ScopeM [Declaration]
checkDs
      Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p' Name
name ModuleName
aname

      -- If the module was anonymous open it public
      -- unless it's private, in which case we just open it (#2099)
      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 :: Maybe Range
publicOpen = Bool -> Range -> Maybe Range
forall a. Bool -> a -> Maybe a
boolToMaybe (Access
p Access -> Access -> Bool
forall a. Eq a => a -> a -> Bool
== Access
PublicAccess) Range
forall a. Range' a
noRange }
      [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds

-- | Check whether a telescope has open declarations or module macros.
telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool
telHasOpenStmsOrModuleMacros :: Telescope -> Bool
telHasOpenStmsOrModuleMacros = (TypedBinding' Expr -> Bool) -> Telescope -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypedBinding' Expr -> Bool
forall e. TypedBinding' e -> Bool
yesBind
  where
    yesBind :: TypedBinding' e -> Bool
yesBind C.TBind{}     = Bool
False
    yesBind (C.TLet Range
_ [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
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' BoundName -> TCMT IO ()
ensureNoLetStms arg :: Binder' BoundName
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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Binder' BoundName -> TypeError
IllegalPatternInTelescope Binder' BoundName
arg

instance EnsureNoLetStms C.TypedBinding where
  ensureNoLetStms :: TypedBinding' Expr -> TCMT IO ()
ensureNoLetStms = \case
    tb :: TypedBinding' Expr
tb@C.TLet{}    -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypedBinding' Expr -> TypeError
IllegalLetInTelescope TypedBinding' Expr
tb
    C.TBind Range
_ [Arg (Named NamedName (Binder' BoundName))]
xs Expr
_ -> (Arg (Named NamedName (Binder' BoundName)) -> TCMT IO ())
-> [Arg (Named NamedName (Binder' BoundName))] -> TCMT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Binder' BoundName -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms (Binder' BoundName -> TCMT IO ())
-> (Arg (Named NamedName (Binder' BoundName)) -> Binder' BoundName)
-> Arg (Named NamedName (Binder' BoundName))
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg (Named NamedName (Binder' BoundName)) -> Binder' BoundName
forall a. NamedArg a -> a
namedArg) [Arg (Named NamedName (Binder' BoundName))]
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 Arg (Named NamedName (Binder' BoundName))
a -> Arg (Named NamedName (Binder' BoundName)) -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms Arg (Named NamedName (Binder' BoundName))
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
  -> 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])
scopeCheckModule :: Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, [Declaration])
scopeCheckModule Range
r QName
x ModuleName
qm Telescope
tel ScopeM [Declaration]
checkDs = do
  String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"module" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"checking module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
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 GeneralizeTelescope
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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
      String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"module" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"inside module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
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 (m :: * -> *) a. Monad m => a -> m a
return (ScopeInfo
scope, [ ModuleInfo
-> ModuleName
-> GeneralizeTelescope
-> [Declaration]
-> Declaration
A.Section ModuleInfo
info (ModuleName
qm ModuleName -> QName -> ModuleName
`withRangesOfQ` QName
x) GeneralizeTelescope
tel [Declaration]
ds ])

  -- Binding is done by the caller
  String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"module" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"after module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x
  (ScopeInfo, [Declaration]) -> TCMT IO (ScopeInfo, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopeInfo, [Declaration])
res
  where
    info :: ModuleInfo
info = Range
-> Range
-> Maybe Name
-> Maybe OpenShortHand
-> Maybe ImportDirective
-> ModuleInfo
ModuleInfo Range
r Range
forall a. Range' a
noRange Maybe Name
forall a. Maybe a
Nothing Maybe OpenShortHand
forall a. Maybe a
Nothing Maybe ImportDirective
forall a. Maybe a
Nothing

-- | Temporary data type to scope check a file.
data TopLevel a = TopLevel
  { TopLevel a -> AbsolutePath
topLevelPath           :: AbsolutePath
    -- ^ The file path from which we loaded this module.
  , TopLevel a -> TopLevelModuleName
topLevelExpectedName   :: C.TopLevelModuleName
    -- ^ The expected module name
    --   (coming from the import statement that triggered scope checking this file).
  , 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' ModuleName ScopeInfo -> ModuleName
forall o i. o -> Lens' i o -> i
^. Lens' ModuleName ScopeInfo
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]) TopLevelInfo where
    toAbstract :: TopLevel [Declaration] -> ScopeM TopLevelInfo
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]
_) -> Call -> ScopeM TopLevelInfo -> ScopeM TopLevelInfo
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (Range -> Call
SetRange (Range -> Call) -> Range -> Call
forall a b. (a -> b) -> a -> b
$ Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
d) (ScopeM TopLevelInfo -> ScopeM TopLevelInfo)
-> ScopeM TopLevelInfo -> ScopeM TopLevelInfo
forall a b. (a -> b) -> a -> b
$
          String -> ScopeM TopLevelInfo
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM TopLevelInfo) -> String -> ScopeM TopLevelInfo
forall a b. (a -> b) -> a -> b
$ String
"No declarations allowed after top-level module."

        -- Otherwise, proceed.
        ([Declaration]
outsideDecls, [ C.Module Range
r QName
m0 Telescope
tel [Declaration]
insideDecls ]) -> do
          -- If the module name is _ compute the name from the file path
          QName
m <- 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
_ QName
m1 Telescope
_ [Declaration]
_ : [Declaration]
_))
                       | QName -> TopLevelModuleName
C.toTopLevelModuleName QName
m1 TopLevelModuleName -> TopLevelModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== 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 t. HasRange t => t -> Range
getRange [Declaration]
insideDecls) -> do

                         Call -> TCMT IO QName -> TCMT IO QName
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (Range -> Call
SetRange (Range -> Call) -> Range -> Call
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Range
forall t. HasRange t => t -> Range
getRange [Declaration]
ds0) (TCMT IO QName -> TCMT IO QName) -> TCMT IO QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError
                           String
"Illegal declaration(s) before top-level module"

                    -- Otherwise, reconstruct the top-level module name
                    ([Declaration], [Declaration])
_ -> QName -> TCMT IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ Range -> NameInScope -> [NamePart] -> Name
C.Name (QName -> Range
forall t. HasRange t => t -> Range
getRange QName
m0) NameInScope
C.InScope
                           [String -> NamePart
Id (String -> NamePart) -> String -> NamePart
forall a b. (a -> b) -> a -> b
$ String -> String
stringToRawName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> String
rootNameModule AbsolutePath
file]
                -- 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
-> SourceFile -> Maybe TopLevelModuleName -> TCMT IO ()
checkModuleName (QName -> TopLevelModuleName
C.toTopLevelModuleName QName
m0) (AbsolutePath -> SourceFile
SourceFile AbsolutePath
file) (Maybe TopLevelModuleName -> TCMT IO ())
-> Maybe TopLevelModuleName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> Maybe TopLevelModuleName
forall a. a -> Maybe a
Just TopLevelModuleName
expectedMName
                  QName -> TCMT IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
m0
          QName -> TCMT IO ()
setTopLevelModule QName
m
          ModuleName
am           <- NewModuleQName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> NewModuleQName
NewModuleQName QName
m)
          -- Scope check the declarations outside
          [Declaration]
outsideDecls <- [Declaration] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Declaration]
outsideDecls
          (ScopeInfo
insideScope, [Declaration]
insideDecls) <- Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, [Declaration])
scopeCheckModule Range
r 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
$
             [Declaration] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Declaration]
insideDecls
          let scope :: ScopeInfo
scope = Lens' (Map ModuleName Scope) ScopeInfo
-> LensMap (Map ModuleName Scope) ScopeInfo
forall i o. Lens' i o -> LensMap i o
over Lens' (Map ModuleName Scope) ScopeInfo
scopeModules ((Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope)
-> (Scope -> Scope) -> Map ModuleName Scope -> Map ModuleName Scope
forall a b. (a -> b) -> a -> b
$ ModuleName -> Scope -> Scope
restrictLocalPrivate ModuleName
am) ScopeInfo
insideScope
          ScopeInfo -> TCMT IO ()
setScope ScopeInfo
scope
          TopLevelInfo -> ScopeM TopLevelInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (TopLevelInfo -> ScopeM TopLevelInfo)
-> TopLevelInfo -> ScopeM TopLevelInfo
forall a b. (a -> b) -> a -> b
$ [Declaration] -> ScopeInfo -> TopLevelInfo
TopLevelInfo ([Declaration]
outsideDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
insideDecls) ScopeInfo
scope

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

-- | runs Syntax.Concrete.Definitions.niceDeclarations on main module
niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls :: DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
warn [Declaration]
ds [NiceDeclaration] -> ScopeM a
ret = [Declaration] -> ScopeM a -> ScopeM a
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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' Fixities ScopeInfo -> TCMT IO Fixities
forall (m :: * -> *) a. ReadTCState m => Lens' a ScopeInfo -> m a
useScope Lens' Fixities ScopeInfo
scopeFixities  -- We need to pass the fixities to the nicifier for clause grouping
  let (Either DeclarationException [NiceDeclaration]
result, NiceWarnings
warns') = 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 <- String -> TCMT IO Bool
Lens.isBuiltinModule (String -> TCMT IO Bool)
-> (AbsolutePath -> String) -> AbsolutePath -> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> String
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 :: * -> *). 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)
mapM Warning -> TCMT IO TCWarning
forall (m :: * -> *). 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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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
    [Warning] -> TCMT IO ()
forall (m :: * -> *). 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
warns
  case Either DeclarationException [NiceDeclaration]
result of
    Left DeclarationException
e   -> TCErr -> ScopeM 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 t. HasRange t => t -> 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

instance {-# OVERLAPPING #-} ToAbstract [C.Declaration] [A.Declaration] where
  toAbstract :: [Declaration] -> ScopeM [Declaration]
toAbstract [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)
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds)
               {- else -} ([Declaration] -> TCMT IO [Declaration]
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]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
ins [LamBinding]
lams [Declaration]
ds -> Range
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> [Declaration]
-> Declaration
C.RecordDef Range
r Name
n Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
ins [LamBinding]
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)
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       C.Record Range
r Name
n Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
ins [LamBinding]
lams Expr
e [Declaration]
ds  -> Range
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Name
n Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
ins [LamBinding]
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)
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)
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)
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)
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)
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)
mapM Declaration -> TCMT IO Declaration
noUnsafePragma [Declaration]
ds
       Declaration
d -> Declaration -> TCMT IO Declaration
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 (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 (String -> TCMT IO Bool
Lens.isBuiltinModuleWithSafePostulates (String -> TCMT IO Bool)
-> (AbsolutePath -> String) -> AbsolutePath -> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> String
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
         Just Warning
w  -> Pragma -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange Pragma
pr (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *). 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


newtype LetDefs = LetDefs [C.Declaration]
newtype LetDef = LetDef NiceDeclaration

instance ToAbstract LetDefs [A.LetBinding] where
  toAbstract :: LetDefs -> TCMT IO [LetBinding]
toAbstract (LetDefs [Declaration]
ds) =
    [[LetBinding]] -> [LetBinding]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[LetBinding]] -> [LetBinding])
-> TCMT IO [[LetBinding]] -> TCMT IO [LetBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DoWarn
-> [Declaration]
-> ([NiceDeclaration] -> TCMT IO [[LetBinding]])
-> TCMT IO [[LetBinding]]
forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn [Declaration]
ds (([NiceDeclaration] -> TCMT IO [[LetBinding]])
 -> TCMT IO [[LetBinding]])
-> ([NiceDeclaration] -> TCMT IO [[LetBinding]])
-> TCMT IO [[LetBinding]]
forall a b. (a -> b) -> a -> b
$ [LetDef] -> TCMT IO [[LetBinding]]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ([LetDef] -> TCMT IO [[LetBinding]])
-> ([NiceDeclaration] -> [LetDef])
-> [NiceDeclaration]
-> TCMT IO [[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 [A.LetBinding] where
  toAbstract :: LetDef -> TCMT IO [LetBinding]
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
                String -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"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
                String -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"Macros cannot be defined in a let expression."
              Expr
t <- Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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) -> ScopeM BindName -> ScopeM Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NewName BoundName -> ScopeM BindName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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).
              [LetBinding] -> TCMT IO [LetBinding]
forall (m :: * -> *) a. Monad m => a -> m a
return [ BindName -> LetBinding
A.LetDeclaredVariable (Name -> BindName
A.mkBindName (Range -> Name -> Name
forall t. SetRange t => Range -> t -> t
setRange (QName -> Range
forall t. HasRange t => t -> Range
getRange QName
x') Name
x))
                     , 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 t. HasRange t => t -> 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
p [] [] ExpandedEllipsis
NoEllipsis) (C.RHS Expr
rhs) WhereClause' [Declaration]
NoWhere Bool
ca) -> do
        Either TCErr Pattern
mp  <- Pattern
-> TCMT IO (Either TCErr Pattern) -> TCMT IO (Either TCErr Pattern)
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange Pattern
p (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)
-> ScopeM Pattern -> TCMT IO (Either TCErr Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM Pattern
parsePattern Pattern
p)
                   TCMT IO (Either TCErr Pattern)
-> (TCErr -> TCMT IO (Either TCErr Pattern))
-> TCMT IO (Either TCErr Pattern)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
                 (Either TCErr Pattern -> TCMT IO (Either TCErr Pattern)
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
rhs
            Pattern' Expr
p   <- Pattern -> ScopeM (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pattern
p
            Pattern' Expr -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a p.
(Monad m, APatternLike a 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 Pattern
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pattern' Expr
p
            [LetBinding] -> TCMT IO [LetBinding]
forall (m :: * -> *) a. Monad m => a -> m a
return [ 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
p of
              Maybe Name
Nothing -> TCErr -> TCMT IO [LetBinding]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
              Just Name
x  -> LetDef -> TCMT IO [LetBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (LetDef -> TCMT IO [LetBinding]) -> LetDef -> TCMT IO [LetBinding]
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 ArgInfo
defaultArgInfo TerminationCheck
tc CoverageCheck
cc Name
x (Range -> Maybe String -> Expr
C.Underscore (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x) Maybe String
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 (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
_ (Pattern
p : [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.RawAppP Range
_ [])       = Maybe Name
forall a. HasCallStack => a
__IMPOSSIBLE__
              definedName C.AppP{}               = Maybe Name
forall a. HasCallStack => a
__IMPOSSIBLE__
              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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Warning -> m ()
warning Warning
UselessPublic
        ModuleName
m    <- OldModuleName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 :: Range
-> Range
-> Maybe Name
-> Maybe OpenShortHand
-> Maybe ImportDirective
-> ModuleInfo
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
              }
        [LetBinding] -> TCMT IO [LetBinding]
forall (m :: * -> *) a. Monad m => a -> m a
return [ModuleInfo -> ModuleName -> ImportDirective -> LetBinding
A.LetOpen ModuleInfo
minfo ModuleName
m ImportDirective
adir]

      NiceModuleMacro Range
r Access
p Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
        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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Warning -> m ()
warning Warning
UselessPublic
        -- Andreas, 2014-10-09, Issue 1299: module macros in lets need
        -- to be private
        (ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> LetBinding)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> TCMT IO [LetBinding]
forall c a.
(Pretty c, ToConcrete a c) =>
(ModuleInfo
 -> ModuleName
 -> ModuleApplication
 -> ScopeCopyInfo
 -> ImportDirective
 -> a)
-> OpenKind
-> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM [a]
checkModuleMacro ModuleInfo
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding
LetApply OpenKind
LetOpenModule Range
r (Origin -> Access
PrivateAccess Origin
Inserted) Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir

      NiceDeclaration
_   -> NiceDeclaration -> TCMT IO [LetBinding]
forall a. NiceDeclaration -> ScopeM a
notAValidLetBinding NiceDeclaration
d
    where
        letToAbstract :: Clause -> TCMT IO (QName, Expr)
letToAbstract (C.Clause Name
top Bool
catchall clhs :: LHS
clhs@(C.LHS Pattern
p [] [] ExpandedEllipsis
NoEllipsis) (C.RHS Expr
rhs) WhereClause' [Declaration]
NoWhere []) = do
{-
            p    <- parseLHS top p
            localToAbstract (snd $ lhsArgs p) $ \args ->
-}
            (QName
x, [NamedArg Pattern]
args) <- do
              LHSCore
res <- Pattern -> TCMT IO LHSCore -> TCMT IO LHSCore
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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 (m :: * -> *) a. Monad m => a -> m a
return (QName
x, [NamedArg Pattern]
args)
                C.LHSProj{} -> String -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (QName, [NamedArg Pattern]))
-> String -> TCMT IO (QName, [NamedArg Pattern])
forall a b. (a -> b) -> a -> b
$ String
"copatterns not allowed in let bindings"
                C.LHSWith{} -> String -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (QName, [NamedArg Pattern]))
-> String -> TCMT IO (QName, [NamedArg Pattern])
forall a b. (a -> b) -> a -> b
$ String
"with-patterns not allowed in let bindings"

            Expr
e <- [NamedArg Pattern]
-> ([Arg (Named NamedName (Pattern' Expr))] -> ScopeM Expr)
-> ScopeM Expr
forall c a b. ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM b
localToAbstract [NamedArg Pattern]
args (([Arg (Named NamedName (Pattern' Expr))] -> ScopeM Expr)
 -> ScopeM Expr)
-> ([Arg (Named NamedName (Pattern' Expr))] -> ScopeM Expr)
-> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \[Arg (Named NamedName (Pattern' Expr))]
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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))]
args)  -- just reverse because these DomainFree
            (QName, Expr) -> TCMT IO (QName, Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, Expr
e)
        letToAbstract Clause
_ = NiceDeclaration -> TCMT IO (QName, Expr)
forall a. NiceDeclaration -> ScopeM 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 (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 -> LamBinding
A.mkDomainFree (NamedArg Binder -> LamBinding) -> NamedArg Binder -> LamBinding
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Binder -> NamedArg Binder
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info (Binder -> NamedArg Binder) -> Binder -> NamedArg Binder
forall a b. (a -> b) -> a -> b
$ BindName -> Binder
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 t. HasRange t => t -> Range
getRange PatInfo
i)
                Expr -> ScopeM Expr
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 -> LamBinding
A.mkDomainFree (NamedArg Binder -> LamBinding) -> NamedArg Binder -> LamBinding
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Binder -> NamedArg Binder
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info (Binder -> NamedArg Binder) -> Binder -> NamedArg Binder
forall a b. (a -> b) -> a -> b
$ Name -> Binder
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 a. NiceDeclaration -> ScopeM a
notAValidLetBinding NiceDeclaration
d

--UNUSED Liang-Ting Chen 2019-07-16
--newtype Blind a = Blind { unBlind :: a }
--
--instance ToAbstract (Blind a) (Blind a) where
--  toAbstract = return

instance ToAbstract NiceDeclaration A.Declaration where

  toAbstract :: NiceDeclaration -> ScopeM Declaration
toAbstract NiceDeclaration
d = ScopeM [Declaration] -> ScopeM Declaration
annotateDecls (ScopeM [Declaration] -> ScopeM Declaration)
-> ScopeM [Declaration] -> ScopeM Declaration
forall a b. (a -> b) -> a -> b
$
    String
-> VerboseLevel
-> [String]
-> ScopeM [Declaration]
-> ScopeM [Declaration]
forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
String -> VerboseLevel -> a -> m c -> m c
traceS String
"scope.decl.trace" VerboseLevel
50
      [ String
"scope checking declaration"
      , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++  NiceDeclaration -> String
forall a. Pretty a => a -> String
prettyShow NiceDeclaration
d
      ] (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
    String
-> VerboseLevel
-> [String]
-> ScopeM [Declaration]
-> ScopeM [Declaration]
forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
String -> VerboseLevel -> a -> m c -> m c
traceS String
"scope.decl.trace" VerboseLevel
80  -- keep this debug message for testing issue #4016
      [ String
"scope checking declaration (raw)"
      , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++  NiceDeclaration -> String
forall a. Show a => a -> String
show NiceDeclaration
d
      ] (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
    Call -> ScopeM [Declaration] -> ScopeM [Declaration]
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm 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 (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 :: AbstractMode
envAbstractMode = IsAbstract -> AbstractMode
aDefToMode IsAbstract
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 ((Bool -> TCMT IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> TCMT IO Bool)
-> (CommandLineOptions -> Bool)
-> CommandLineOptions
-> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOptions -> Bool
forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode (CommandLineOptions -> TCMT IO Bool)
-> TCMT IO CommandLineOptions -> TCMT IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m 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
<$> (String -> TCMT IO Bool
Lens.isBuiltinModuleWithSafePostulates (String -> TCMT IO Bool)
-> (AbsolutePath -> String) -> AbsolutePath -> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> String
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 :: * -> *). 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
      Axiom -> IsMacro -> NiceDeclaration -> ScopeM [Declaration]
toAbstractNiceAxiom Axiom
A.NoFunSig IsMacro
NotMacroDef NiceDeclaration
d

    C.NiceGeneralize Range
r Access
p ArgInfo
i TacticAttribute
tac Name
x Expr
t -> do
      String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.decl" VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"found nice generalize: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
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)
traverse (Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
      Expr
t_ <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx Expr
t
      let (Set QName
s, Expr
t) = Expr -> (Set QName, Expr)
unGeneralized Expr
t_
      String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.decl" VerboseLevel
50 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"generalizations: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([QName], Expr) -> String
forall a. Show a => a -> String
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 -> ScopeM 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 :: Maybe Expr
defTactic = Maybe Expr
tac }
      [Declaration] -> ScopeM [Declaration]
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
$ String -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"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 VerboseLevel
_) = Range -> Maybe String -> Expr
C.Underscore Range
r Maybe String
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)
traverse (Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
      Arg Expr
t' <- Precedence -> Arg Expr -> ScopeM (Arg Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx (Arg Expr -> ScopeM (Arg Expr)) -> Arg Expr -> ScopeM (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 -> ScopeM 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 :: Maybe Expr
defTactic = Maybe Expr
tac }
      [Declaration] -> ScopeM [Declaration]
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 Expr
t -> do
      Expr
t' <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx Expr
t
      Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
      QName
y  <- Fixity' -> Name -> ScopeM QName
freshAbstractQName Fixity'
f Name
x
      Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
PrimName Name
x QName
y
      [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> Expr -> Declaration
A.Primitive (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) QName
y Expr
t' ]

  -- Definitions (possibly mutual)
    NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds -> do
      [Declaration]
ds' <- [NiceDeclaration] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [NiceDeclaration]
ds
      -- We only termination check blocks that do not have a measure.
      [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ MutualInfo -> [Declaration] -> Declaration
A.Mutual (TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc Range
r) [Declaration]
ds' ]

    C.NiceRecSig Range
r Access
p IsAbstract
a PositivityCheck
_pc UniverseCheck
_uc Name
x [LamBinding]
ls Expr
t -> do
      [LamBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding]
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 (GeneralizeTelescope, Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (Telescope -> Expr -> GenTelAndType
GenTelAndType ((LamBinding -> TypedBinding' Expr) -> [LamBinding] -> Telescope
forall a b. (a -> b) -> [a] -> [b]
map LamBinding -> TypedBinding' Expr
makeDomainFull [LamBinding]
ls) Expr
t)
        Expr
t' <- Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
t
        Fixity'
f  <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        QName
x' <- Fixity' -> Name -> ScopeM 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 (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> 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) QName
x' GeneralizeTelescope
ls' Expr
t' ]

    C.NiceDataSig Range
r Access
p IsAbstract
a PositivityCheck
_pc UniverseCheck
_uc Name
x [LamBinding]
ls Expr
t -> do
        String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.data.sig" VerboseLevel
20 (String
"checking DataSig for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x)
        [LamBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding]
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' <- ScopeM GeneralizeTelescope -> ScopeM GeneralizeTelescope
forall a. ScopeM a -> ScopeM a
withCheckNoShadowing (ScopeM GeneralizeTelescope -> ScopeM GeneralizeTelescope)
-> ScopeM GeneralizeTelescope -> ScopeM GeneralizeTelescope
forall a b. (a -> b) -> a -> b
$
            GenTel -> ScopeM GeneralizeTelescope
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (GenTel -> ScopeM GeneralizeTelescope)
-> GenTel -> ScopeM GeneralizeTelescope
forall a b. (a -> b) -> a -> b
$ Telescope -> GenTel
GenTel (Telescope -> GenTel) -> Telescope -> GenTel
forall a b. (a -> b) -> a -> b
$ (LamBinding -> TypedBinding' Expr) -> [LamBinding] -> Telescope
forall a b. (a -> b) -> [a] -> [b]
map LamBinding -> TypedBinding' Expr
makeDomainFull [LamBinding]
ls
          Expr
t'  <- Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (Expr -> ScopeM Expr) -> Expr -> ScopeM 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 -> ScopeM QName
freshAbstractQName Fixity'
f Name
x
          Access -> KindOfName -> NameMetadata -> Name -> QName -> TCMT IO ()
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'
          [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> 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) 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 ->
        Axiom -> IsMacro -> NiceDeclaration -> ScopeM [Declaration]
toAbstractNiceAxiom Axiom
A.FunSig IsMacro
m (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
        VerboseLevel -> String -> TCMT IO ()
printLocals VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"checking def " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
        (QName
x',[Clause]
cs) <- (OldName Name, [Clause]) -> ScopeM (QName, [Clause])
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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) -> ScopeM ModuleName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM 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__
        let delayed :: Delayed
delayed = Delayed
NotDelayed
        -- (delayed, cs) <- translateCopatternClauses cs -- TODO
        Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo -> QName -> Delayed -> [Clause] -> Declaration
A.FunDef (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) QName
x' Delayed
delayed [Clause]
cs ]

  -- Uncategorized function clauses
    C.NiceFunClause Range
_ Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ Bool
_ (C.FunClause LHS
lhs RHS' Expr
_ WhereClause' [Declaration]
_ Bool
_) ->
      String -> ScopeM [Declaration]
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM [Declaration]) -> String -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
        String
"Missing type signature for left hand side " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHS -> String
forall a. Pretty a => a -> String
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]
pars [NiceDeclaration]
cons -> do
        String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.data.def" VerboseLevel
20 (String
"checking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Origin -> String
forall a. Show a => a -> String
show Origin
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" DataDef for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          DefinedName Access
p AbstractName
ax -> 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 (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
          ResolvedName
_ -> String -> TCMT IO (Access, AbstractName)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (Access, AbstractName))
-> String -> TCMT IO (Access, AbstractName)
forall a b. (a -> b) -> a -> b
$ String
"Missing type signature for data definition " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
        [LamBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding]
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)
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
cs
               [Name] -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 <- [LamBinding] -> ScopeM [LamBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [LamBinding]
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 = [Name] -> ModuleName
mnameFromList ([Name] -> ModuleName) -> [Name] -> ModuleName
forall a b. (a -> b) -> a -> b
$ QName -> [Name]
qnameToList QName
x'
          Maybe DataOrRecord -> ModuleName -> TCMT IO ()
createModule (DataOrRecord -> Maybe DataOrRecord
forall a. a -> Maybe a
Just DataOrRecord
IsData) ModuleName
m
          Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
p Name
x ModuleName
m  -- make it a proper module
          [Declaration]
cons <- [ConstrDecl] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ((NiceDeclaration -> ConstrDecl)
-> [NiceDeclaration] -> [ConstrDecl]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> IsAbstract -> Access -> NiceDeclaration -> ConstrDecl
ConstrDecl ModuleName
m IsAbstract
a Access
p) [NiceDeclaration]
cons)
          String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"data" VerboseLevel
20 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"Checked data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
          Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
          [Declaration] -> ScopeM [Declaration]
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 (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 Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
cm [LamBinding]
pars [Declaration]
fields -> do
      String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.rec.def" VerboseLevel
20 (String
"checking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Origin -> String
forall a. Show a => a -> String
show Origin
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" RecDef for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        DefinedName Access
p AbstractName
ax -> 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 (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
        ResolvedName
_ -> String -> TCMT IO (Access, AbstractName)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (Access, AbstractName))
-> String -> TCMT IO (Access, AbstractName)
forall a b. (a -> b) -> a -> b
$ String
"Missing type signature for record definition " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
      [LamBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding]
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   <- [LamBinding] -> ScopeM [LamBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [LamBinding]
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 -> (Expr -> ScopeM Expr) -> ScopeM Expr
forall c a b. ToAbstract c a => c -> (a -> ScopeM b) -> ScopeM b
localToAbstract ([Declaration] -> RecordConstructorType
RecordConstructorType [Declaration]
fields) Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => a -> m a
return
        ModuleName
m0     <- ScopeM 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
$ [Name] -> ModuleName
mnameFromList [ [Name] -> Name
forall a. [a] -> a
last ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ QName -> [Name]
qnameToList QName
x' ]
        String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"rec" VerboseLevel
15 String
"before record"
        Maybe DataOrRecord -> ModuleName -> TCMT IO ()
createModule (DataOrRecord -> Maybe DataOrRecord
forall a. a -> Maybe a
Just DataOrRecord
IsRecord) 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 <- [Declaration] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Declaration]
fields
          String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"rec" VerboseLevel
15 String
"checked fields"
          [Declaration] -> ScopeM [Declaration]
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
fs
             [Name] -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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
        -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.
        Maybe QName
cm' <- Maybe (Name, IsInstance)
-> ((Name, IsInstance) -> ScopeM 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) -> ScopeM QName) -> TCMT IO (Maybe QName))
-> ((Name, IsInstance) -> ScopeM QName) -> TCMT IO (Maybe QName)
forall a b. (a -> b) -> a -> b
$ \ (Name
c, IsInstance
_) -> Name -> IsAbstract -> Access -> ScopeM QName
bindRecordConstructorName Name
c 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
        String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"rec" VerboseLevel
15 String
"record complete"
        Fixity'
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
        let params :: DataDefParams
params = Set Name -> [LamBinding] -> DataDefParams
DataDefParams Set Name
gvars [LamBinding]
pars
        [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ DefInfo
-> QName
-> UniverseCheck
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe 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 Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe QName
cm' DataDefParams
params Expr
contel [Declaration]
afields ]

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

      [Declaration]
adecls <- Call -> ScopeM [Declaration] -> ScopeM [Declaration]
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (NiceDeclaration -> Call
ScopeCheckDeclaration (NiceDeclaration -> Call) -> NiceDeclaration -> Call
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> QName
-> Telescope
-> [Declaration]
-> NiceDeclaration
NiceModule Range
r Access
p IsAbstract
a QName
x Telescope
tel []) (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
        Range
-> Access
-> Name
-> Telescope
-> ScopeM [Declaration]
-> ScopeM [Declaration]
scopeCheckNiceModule Range
r Access
p Name
name Telescope
tel (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ [Declaration] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Declaration]
ds

      String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
        [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"scope checked NiceModule " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x
        ] [TCM Doc] -> [TCM Doc] -> [TCM Doc]
forall a. [a] -> [a] -> [a]
++ (Declaration -> TCM Doc) -> [Declaration] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc)
-> (Declaration -> TCM Doc) -> Declaration -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA) [Declaration]
adecls
      [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
adecls

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

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

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

      String -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m ()
reportSDoc String
"scope.decl" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
        [ String -> TCM Doc
forall (m :: * -> *). Monad m => String -> m Doc
text (String -> TCM Doc) -> String -> TCM Doc
forall a b. (a -> b) -> a -> b
$ String
"scope checked NiceModuleMacro " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x
        ] [TCM Doc] -> [TCM Doc] -> [TCM Doc]
forall a. [a] -> [a] -> [a]
++ (Declaration -> TCM Doc) -> [Declaration] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc)
-> (Declaration -> TCM Doc) -> Declaration -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA) [Declaration]
adecls
      [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
adecls

    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 (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 [Pragma]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pragma
p
      [Declaration] -> ScopeM [Declaration]
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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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 :: String -> TCMT IO (Maybe (AsName' Name))
illformedAs String
s = Call
-> TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name))
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (Range -> Call
SetRange (Range -> Call) -> Range -> Call
forall a b. (a -> b) -> a -> b
$ Maybe AsName -> Range
forall t. HasRange t => t -> Range
getRange 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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Warning -> TCMT IO ()
forall (m :: * -> *). MonadWarning m => Warning -> m ()
warning (String -> Warning
IllformedAsClause String
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 (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 (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 (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 (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) -> String -> TCMT IO (Maybe (AsName' Name))
illformedAs String
"; a qualified name is not allowed here"
        Just (AsName (Left Expr
e)                  Range
r) -> String -> TCMT IO (Maybe (AsName' Name))
illformedAs String
""

      -- 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
$ QName
-> TCMT IO (ModuleName, Map ModuleName Scope)
-> TCMT IO (ModuleName, Map ModuleName Scope)
forall a. QName -> TCM a -> TCM a
withTopLevelModule QName
x (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 ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (NewModuleQName -> ScopeM ModuleName)
-> NewModuleQName -> ScopeM ModuleName
forall a b. (a -> b) -> a -> b
$ QName -> NewModuleQName
NewModuleQName QName
x
        String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"import" VerboseLevel
10 String
"before import:"
        (ModuleName
m, Map ModuleName Scope
i) <- ModuleName -> TCMT IO (ModuleName, Map ModuleName Scope)
scopeCheckImport ModuleName
m
        String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"import" VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"scope checked import: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map ModuleName Scope -> String
forall a. Show a => a -> String
show 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 (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)

      -- Merge the imported scopes with the current scopes
      (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

      -- Bind the desired module name to the right abstract name.
      case Maybe (AsName' Name)
as of
        Maybe (AsName' Name)
Nothing -> Access -> QName -> ModuleName -> TCMT IO ()
bindQModule (Origin -> Access
PrivateAccess Origin
Inserted) QName
x ModuleName
m
        Just AsName' Name
y -> (Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> TCMT IO () -> TCMT IO ())
-> (Name -> Bool) -> Name -> TCMT IO () -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName) (AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
y) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          Access -> Name -> ModuleName -> TCMT IO ()
bindModule (Origin -> Access
PrivateAccess Origin
Inserted) (AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
y) ModuleName
m

      String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"import" VerboseLevel
10 String
"merged imported sig:"

      -- Open if specified, otherwise apply import directives
      let (QName
name, Range
theAsSymbol, Maybe Name
theAsName) = case Maybe (AsName' Name)
as of
            Just AsName' Name
a | (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName) (AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
a) -> (Name -> QName
C.QName (AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
a), AsName' Name -> Range
forall a. AsName' a -> Range
asRange AsName' Name
a, Name -> Maybe Name
forall a. a -> Maybe a
Just (AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
a))
            Maybe (AsName' Name)
_                                    -> (QName
x,                  Range
forall a. Range' a
noRange,   Maybe Name
forall a. Maybe a
Nothing)
      ImportDirective
adir <- case OpenShortHand
open of
        OpenShortHand
DoOpen   -> do
          -- 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 (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
adir
        -- If not opening, import directives are applied to the original scope.
        OpenShortHand
DontOpen -> ModuleName
-> (Scope -> ScopeM (ImportDirective, Scope))
-> TCMT IO ImportDirective
forall a. ModuleName -> (Scope -> ScopeM (a, Scope)) -> ScopeM a
modifyNamedScopeM ModuleName
m ((Scope -> ScopeM (ImportDirective, Scope))
 -> TCMT IO ImportDirective)
-> (Scope -> ScopeM (ImportDirective, Scope))
-> TCMT IO ImportDirective
forall a b. (a -> b) -> a -> b
$ QName
-> ImportDirective -> Scope -> ScopeM (ImportDirective, Scope)
applyImportDirectiveM QName
x ImportDirective
dir
      let minfo :: ModuleInfo
minfo = ModuleInfo :: Range
-> Range
-> Maybe Name
-> Maybe OpenShortHand
-> Maybe ImportDirective
-> ModuleInfo
ModuleInfo
            { minfoRange :: Range
minfoRange     = Range
r
            , minfoAsName :: Maybe Name
minfoAsName    = Maybe Name
theAsName
            , minfoAsTo :: Range
minfoAsTo      = (Range, Range) -> Range
forall t. HasRange t => t -> 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 (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)
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
      [QName]
ys <- (Fixity' -> Name -> ScopeM QName)
-> [Fixity'] -> [Name] -> TCMT IO [QName]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Fixity' -> Name -> ScopeM 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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
      [Declaration] -> ScopeM [Declaration]
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 | (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)
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
      [QName]
ys <- (Name -> ScopeM QName) -> [Name] -> TCMT IO [QName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (OldName Name -> ScopeM QName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldName Name -> ScopeM QName)
-> (Name -> OldName Name) -> Name -> ScopeM 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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
      [Declaration] -> ScopeM [Declaration]
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 | (Fixity'
fx, Name
x) <- [Fixity'] -> [Name] -> [(Fixity', Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Fixity']
fxs [Name]
xs ] [QName]
ys Expr
e ]

    NicePatternSyn Range
r Access
a Name
n [Arg Name]
as Pattern
p -> do
      String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
10 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"found nice pattern syn: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
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
         Pattern' Expr
p  <- Pattern -> ScopeM (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (Pattern -> ScopeM (Pattern' Expr))
-> ScopeM Pattern -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pattern -> ScopeM Pattern
parsePatternSyn Pattern
p
         Pattern' Expr -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a p.
(Monad m, APatternLike a 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 :: String
err = String
"Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead."
         Pattern' Void
p <- String -> Pattern' Expr -> ScopeM (Pattern' Void)
forall e. String -> Pattern' e -> ScopeM (Pattern' Void)
noDotorEqPattern String
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)
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)
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 a p. APatternLike a 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ())
-> (Doc -> TypeError) -> Doc -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
             TCM Doc
"Unbound variables in pattern synonym: " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
               [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep ((Name -> TCM Doc) -> [Name] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA [Name]
xs)
         ([Arg Name], Pattern' Void) -> ScopeM ([Arg Name], Pattern' Void)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Arg Name]
as, Pattern' Void
p)
      QName
y <- Name -> ScopeM 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 (m :: * -> *) a. Monad m => a -> m a
return [QName -> [Arg Name] -> Pattern' Void -> Declaration
A.PatternSynDef QName
y [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 (m :: * -> *) a. Monad m => a -> m a
return Name
a
            unVarName ResolvedName
_ = TypeError -> m Name
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> m Name) -> TypeError -> m Name
forall a b. (a -> b) -> a -> b
$ TypeError
UnusedVariableInPatternSynonym

    where
      -- checking postulate or type sig. without checking safe flag
      toAbstractNiceAxiom :: Axiom -> IsMacro -> NiceDeclaration -> ScopeM [Declaration]
toAbstractNiceAxiom Axiom
funSig IsMacro
isMacro (C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
info Name
x Expr
t) = do
        Expr
t' <- Precedence -> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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 -> ScopeM QName
freshAbstractQName Fixity'
f Name
x
        let kind :: KindOfName
kind | IsMacro
isMacro IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef = KindOfName
MacroName
                 | Bool
otherwise           = KindOfName
OtherDefName  -- could be a type signature
        Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p KindOfName
kind Name
x QName
y
        [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Axiom
-> DefInfo
-> ArgInfo
-> Maybe [Occurrence]
-> QName
-> Expr
-> Declaration
A.Axiom Axiom
funSig (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 Axiom
_ IsMacro
_ NiceDeclaration
_ = ScopeM [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__

unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr)
unGeneralized :: Expr -> (Set QName, Expr)
unGeneralized (A.Generalized Set QName
s Expr
t) = (Set QName
s, Expr
t)
unGeneralized (A.ScopedExpr ScopeInfo
si Expr
e) = ScopeInfo -> Expr -> Expr
A.ScopedExpr ScopeInfo
si (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)

collectGeneralizables :: ScopeM a -> ScopeM (Set I.QName, a)
collectGeneralizables :: ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables ScopeM a
m = TCMT IO (Maybe (Set QName))
-> (Maybe (Set QName) -> TCMT IO ())
-> ScopeM (Set QName, a)
-> ScopeM (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 (ScopeM (Set QName, a) -> ScopeM (Set QName, a))
-> ScopeM (Set QName, a) -> ScopeM (Set QName, a)
forall a b. (a -> b) -> a -> b
$ do
    a
a <- ScopeM a
m
    Maybe (Set QName)
s <- Lens' (Maybe (Set QName)) TCState -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars
    case Maybe (Set QName)
s of
        Maybe (Set QName)
Nothing -> ScopeM (Set QName, a)
forall a. HasCallStack => a
__IMPOSSIBLE__
        Just Set QName
s -> (Set QName, a) -> ScopeM (Set QName, 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' (Maybe (Set QName)) TCState -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useTC Lens' (Maybe (Set QName)) TCState
stGeneralizedVars
        Lens' (Maybe (Set QName)) TCState
stGeneralizedVars Lens' (Maybe (Set QName)) TCState
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set QName)
gvs
    close :: Maybe (Set QName) -> TCMT IO ()
close = (Lens' (Maybe (Set QName)) TCState
stGeneralizedVars Lens' (Maybe (Set QName)) TCState
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> a -> m ()
`setTCLens`)

createBoundNamesForGeneralizables :: Set I.QName -> ScopeM (Map I.QName I.Name)
createBoundNamesForGeneralizables :: Set QName -> ScopeM (Map QName Name)
createBoundNamesForGeneralizables Set QName
vs =
  ((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 :: ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables ScopeM a
m = do
  VerboseLevel
fvBefore <- [(Name, LocalVar)] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length ([(Name, LocalVar)] -> VerboseLevel)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO VerboseLevel
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
  VerboseLevel
fvAfter  <- [(Name, LocalVar)] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length ([(Name, LocalVar)] -> VerboseLevel)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO VerboseLevel
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`.
  VerboseLevel -> TCMT IO () -> TCMT IO ()
forall a. VerboseLevel -> ScopeM a -> ScopeM a
outsideLocalVars (VerboseLevel
fvAfter VerboseLevel -> VerboseLevel -> VerboseLevel
forall a. Num a => a -> a -> a
- VerboseLevel
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 (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 (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 (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 A.GeneralizeTelescope where
  toAbstract :: GenTel -> ScopeM GeneralizeTelescope
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])
-> ScopeM 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 (Telescope -> TCMT IO [TypedBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Telescope
tel)

instance ToAbstract GenTelAndType (A.GeneralizeTelescope, A.Expr) where
  toAbstract :: GenTelAndType -> ScopeM (GeneralizeTelescope, Expr)
toAbstract (GenTelAndType Telescope
tel Expr
t) = do
    (Map QName Name
binds, ([TypedBinding]
tel, Expr
t)) <- ScopeM ([TypedBinding], Expr)
-> ScopeM (Map QName Name, ([TypedBinding], Expr))
forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables (ScopeM ([TypedBinding], Expr)
 -> ScopeM (Map QName Name, ([TypedBinding], Expr)))
-> ScopeM ([TypedBinding], Expr)
-> ScopeM (Map QName Name, ([TypedBinding], Expr))
forall a b. (a -> b) -> a -> b
$
                          (,) ([TypedBinding] -> Expr -> ([TypedBinding], Expr))
-> TCMT IO [TypedBinding]
-> TCMT IO (Expr -> ([TypedBinding], Expr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> TCMT IO [TypedBinding]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Telescope
tel TCMT IO (Expr -> ([TypedBinding], Expr))
-> ScopeM Expr -> ScopeM ([TypedBinding], Expr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
t
    (GeneralizeTelescope, Expr) -> ScopeM (GeneralizeTelescope, Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map QName Name -> [TypedBinding] -> GeneralizeTelescope
A.GeneralizeTel Map QName Name
binds [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 <- ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
    String -> VerboseLevel -> [String] -> TCMT IO ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
String -> VerboseLevel -> a -> m ()
reportS String
"scope.data.def" VerboseLevel
30
      [ String
"  A.QName of data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
x
      , String
"  current module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Show a => a -> String
show 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
$
      String -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax)

-- | 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
  [DataOrRecord]
datRecMods <- [Maybe DataOrRecord] -> [DataOrRecord]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DataOrRecord] -> [DataOrRecord])
-> TCMT IO [Maybe DataOrRecord] -> TCMT IO [DataOrRecord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    (AbstractModule -> TCMT IO (Maybe DataOrRecord))
-> [AbstractModule] -> TCMT IO [Maybe DataOrRecord]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModuleName -> TCMT IO (Maybe DataOrRecord)
forall (m :: * -> *).
ReadTCState m =>
ModuleName -> m (Maybe DataOrRecord)
isDatatypeModule (ModuleName -> TCMT IO (Maybe DataOrRecord))
-> (AbstractModule -> ModuleName)
-> AbstractModule
-> TCMT IO (Maybe DataOrRecord)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName) ([AbstractModule] -> TCMT IO [Maybe DataOrRecord])
-> TCMT IO [AbstractModule] -> TCMT IO [Maybe DataOrRecord]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x
  [DataOrRecord] -> ([DataOrRecord] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
(Monad m, Null a) =>
a -> (a -> m ()) -> m ()
unlessNull [DataOrRecord]
datRecMods (([DataOrRecord] -> TCMT IO ()) -> TCMT IO ())
-> ([DataOrRecord] -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> [DataOrRecord] -> TCMT IO ()
forall a b. a -> b -> a
const (TCMT IO () -> [DataOrRecord] -> TCMT IO ())
-> TCMT IO () -> [DataOrRecord] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax)

lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]
lookupModuleInCurrentModule :: Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x =
  [AbstractModule] -> Maybe [AbstractModule] -> [AbstractModule]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [AbstractModule] -> [AbstractModule])
-> (Scope -> Maybe [AbstractModule]) -> Scope -> [AbstractModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name [AbstractModule] -> Maybe [AbstractModule]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (Map Name [AbstractModule] -> Maybe [AbstractModule])
-> (Scope -> Map Name [AbstractModule])
-> Scope
-> Maybe [AbstractModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> Map Name [AbstractModule]
nsModules (NameSpace -> Map Name [AbstractModule])
-> (Scope -> NameSpace) -> Scope -> Map Name [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 ConstrDecl = ConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration

bindConstructorName
  :: ModuleName      -- ^ Name of @data@/@record@ module.
  -> C.Name          -- ^ Constructor name.
  -> IsAbstract
  -> Access
  -> ScopeM A.QName
bindConstructorName :: ModuleName -> Name -> IsAbstract -> Access -> ScopeM 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 -> ScopeM QName -> ScopeM QName
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (ScopeM QName -> ScopeM QName) -> ScopeM QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ Fixity' -> Name -> ScopeM 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 -> ScopeM QName
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 -> IsAbstract -> Access -> ScopeM A.QName
bindRecordConstructorName :: Name -> IsAbstract -> Access -> ScopeM QName
bindRecordConstructorName Name
x IsAbstract
a Access
p = do
  QName
y <- Name -> ScopeM QName
freshAbstractQName' Name
x
  Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
p' KindOfName
ConName Name
x QName
y
  QName -> ScopeM QName
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

instance ToAbstract ConstrDecl A.Declaration where
  toAbstract :: ConstrDecl -> ScopeM Declaration
toAbstract (ConstrDecl 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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 -> ScopeM QName
bindConstructorName ModuleName
m Name
x IsAbstract
a Access
p
        String -> VerboseLevel -> String -> TCMT IO ()
printScope String
"con" VerboseLevel
15 String
"bound constructor"
        Declaration -> ScopeM Declaration
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> ScopeM Declaration)
-> Declaration -> ScopeM Declaration
forall a b. (a -> b) -> a -> b
$ Axiom
-> DefInfo
-> ArgInfo
-> Maybe [Occurrence]
-> QName
-> Expr
-> Declaration
A.Axiom Axiom
NoFunSig (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 -> ScopeM Declaration
forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d

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

instance ToAbstract C.Pragma [A.Pragma] where
  toAbstract :: Pragma -> ScopeM [Pragma]
toAbstract (C.ImpossiblePragma Range
_) = ScopeM [Pragma]
forall a. a
impossibleTest
  toAbstract (C.OptionsPragma Range
_ [String]
opts) = [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [ [String] -> Pragma
A.OptionsPragma [String]
opts ]
  toAbstract (C.RewritePragma Range
_ Range
_ []) = [] [Pragma] -> TCMT IO () -> ScopeM [Pragma]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Warning -> TCMT IO ()
forall (m :: * -> *). 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]] -> ScopeM [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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldQName -> ScopeM Expr) -> OldQName -> ScopeM Expr
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 (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 (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Proj ProjOrigin
_ AmbiguousQName
x       -> String -> TCMT IO [QName]
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO [QName]) -> String -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ String
"REWRITE used on ambiguous name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> String
forall a. Pretty a => a -> String
prettyShow AmbiguousQName
x
      A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> [QName] -> TCMT IO [QName]
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
      A.Con AmbiguousQName
x          -> String -> TCMT IO [QName]
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO [QName]) -> String -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ String
"REWRITE used on ambiguous name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> String
forall a. Pretty a => a -> String
prettyShow AmbiguousQName
x
      A.Var Name
x          -> String -> TCMT IO [QName]
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO [QName]) -> String -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ String
"REWRITE used on parameter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" instead of on a defined symbol"
      Expr
_       -> TCMT IO [QName]
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (C.ForeignPragma Range
_ RString
rb String
s) = [] [Pragma] -> TCMT IO () -> ScopeM [Pragma]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> String -> TCMT IO ()
addForeignCode (RString -> String
forall a. Ranged a -> a
rangedThing RString
rb) String
s
  toAbstract (C.CompilePragma Range
_ RString
rb QName
x String
s) = do
    let b :: String
b = RString -> String
forall a. Ranged a -> a
rangedThing RString
rb
    Maybe Expr
me <- MaybeOldQName -> TCMT IO (Maybe Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (MaybeOldQName -> TCMT IO (Maybe Expr))
-> MaybeOldQName -> TCMT IO (Maybe Expr)
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 () -> ScopeM [Pragma]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ QName -> TCMT IO ()
notInScopeWarning QName
x
      Just Expr
e  -> do
        let err :: String -> ScopeM QName
err String
what = String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM QName) -> String -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ String
"Cannot COMPILE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x
        QName
y <- case Expr
e of
          A.Def QName
x             -> QName -> ScopeM QName
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 -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x          -> String -> ScopeM QName
err String
"ambiguous projection"
          A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> QName -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Con AmbiguousQName
x             -> String -> ScopeM QName
err String
"ambiguous constructor"
          A.PatternSyn{}      -> String -> ScopeM QName
err String
"pattern synonym"
          A.Var{}             -> String -> ScopeM QName
err String
"local variable"
          Expr
_                   -> ScopeM QName
forall a. HasCallStack => a
__IMPOSSIBLE__
        [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> QName -> String -> Pragma
A.CompilePragma RString
rb QName
y String
s ]

  toAbstract (C.StaticPragma Range
_ QName
x) = do
      Expr
e <- OldQName -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldQName -> ScopeM Expr) -> OldQName -> ScopeM Expr
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 -> ScopeM QName
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 -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM QName) -> String -> ScopeM QName
forall a b. (a -> b) -> a -> b
$
            String
"STATIC used on ambiguous name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> String
forall a. Pretty a => a -> String
prettyShow AmbiguousQName
x
          Expr
_        -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Target of STATIC pragma should be a function"
      [Pragma] -> ScopeM [Pragma]
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldQName -> ScopeM Expr) -> OldQName -> ScopeM Expr
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 -> ScopeM QName
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 -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM QName) -> String -> ScopeM QName
forall a b. (a -> b) -> a -> b
$
            String
"INJECTIVE used on ambiguous name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> String
forall a. Pretty a => a -> String
prettyShow AmbiguousQName
x
          Expr
_        -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Target of INJECTIVE pragma should be a defined symbol"
      [Pragma] -> ScopeM [Pragma]
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldQName -> ScopeM Expr) -> OldQName -> ScopeM Expr
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 :: String
sINLINE = if Bool
b then String
"INLINE" else String
"NOINLINE"
      QName
y <- case Expr
e of
          A.Def  QName
x -> QName -> ScopeM QName
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 -> ScopeM QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          A.Proj ProjOrigin
_ AmbiguousQName
x -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM QName) -> String -> ScopeM QName
forall a b. (a -> b) -> a -> b
$
            String
sINLINE String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" used on ambiguous name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> String
forall a. Pretty a => a -> String
prettyShow AmbiguousQName
x
          Expr
_        -> String -> ScopeM QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM QName) -> String -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ String
"Target of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sINLINE String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" pragma should be a function"
      [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> QName -> Pragma
A.InlinePragma Bool
b QName
y ]
  toAbstract (C.BuiltinPragma Range
_ RString
rb QName
q)
    | String -> Bool
isUntypedBuiltin String
b = do
        String -> ResolvedName -> TCMT IO ()
bindUntypedBuiltin String
b (ResolvedName -> TCMT IO ()) -> ScopeM ResolvedName -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ResolveQName -> ScopeM ResolvedName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> ResolveQName
ResolveQName QName
q)
        [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
        -- Andreas, 2015-02-14
        -- Some builtins cannot be given a valid Agda type,
        -- thus, they do not come with accompanying postulate or definition.
        if String
b String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
builtinsNoDef then do
          case QName
q 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
q) (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
$ String -> Doc
P.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
                   String
"BUILTIN " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" declares an identifier " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String
"(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 -> ScopeM 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
$ String -> Maybe KindOfName
builtinKindOfName String
b
              Access -> KindOfName -> Name -> QName -> TCMT IO ()
bindName Access
PublicAccess KindOfName
kind Name
x QName
y
              [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> QName -> Pragma
A.BuiltinNoDefPragma RString
rb QName
y ]
            QName
_ -> String -> ScopeM [Pragma]
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM [Pragma]) -> String -> ScopeM [Pragma]
forall a b. (a -> b) -> a -> b
$
              String
"Pragma BUILTIN " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": expected unqualified identifier, " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"but found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
q
        else do
          ResolvedName
q <- ResolveQName -> ScopeM ResolvedName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (ResolveQName -> ScopeM ResolvedName)
-> ResolveQName -> ScopeM ResolvedName
forall a b. (a -> b) -> a -> b
$ QName -> ResolveQName
ResolveQName QName
q
          [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [ RString -> ResolvedName -> Pragma
A.BuiltinPragma RString
rb ResolvedName
q ]
    where b :: String
b = RString -> String
forall a. Ranged a -> a
rangedThing RString
rb
  toAbstract (C.EtaPragma Range
_ QName
x) = do
    Expr
e <- OldQName -> ScopeM Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldQName -> ScopeM Expr) -> OldQName -> ScopeM Expr
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] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.EtaPragma QName
x ]
      Expr
_       -> do
       String
e <- Expr -> TCMT IO String
forall c a (m :: * -> *).
(Show c, ToConcrete a c, MonadAbsToCon m) =>
a -> m String
showA Expr
e
       String -> ScopeM [Pragma]
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> ScopeM [Pragma]) -> String -> ScopeM [Pragma]
forall a b. (a -> b) -> a -> b
$ String
"Pragma ETA: expected identifier, " String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
"but found expression " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
  toAbstract (C.DisplayPragma Range
_ Pattern
lhs Expr
rhs) = ScopeM [Pragma] -> ScopeM [Pragma]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Pragma] -> ScopeM [Pragma])
-> ScopeM [Pragma] -> ScopeM [Pragma]
forall a b. (a -> b) -> a -> b
$ do
    let err :: TCMT IO a
err = String -> TCMT IO a
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"DISPLAY pragma left-hand side must have form 'f e1 .. en'"
        getHead :: Pattern -> TCMT IO QName
getHead (C.IdentP QName
x)          = QName -> TCMT IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
        getHead (C.RawAppP Range
_ (Pattern
p : [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 (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
$ [Name] -> QName
A.qnameFromList [Name
x']
        DefinedName Access
_ AbstractName
d             -> (Bool, QName) -> TCMT IO (Bool, QName)
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     (AbstractName
d :| [])     -> (Bool, QName) -> TCMT IO (Bool, QName)
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 NonEmpty AbstractName
ds                -> String -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (Bool, QName))
-> String -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous projection " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
top String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)
        ConstructorName (AbstractName
d :| [])   -> (Bool, QName) -> TCMT IO (Bool, QName)
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 NonEmpty AbstractName
ds          -> String -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (Bool, QName))
-> String -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
top String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty 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 (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 NonEmpty AbstractName
ds        -> String -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (Bool, QName))
-> String -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous pattern synonym" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
top String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow ((AbstractName -> QName) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)

    LHS
lhs <- LeftHandSide -> ScopeM LHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (LeftHandSide -> ScopeM LHS) -> LeftHandSide -> ScopeM LHS
forall a b. (a -> b) -> a -> b
$ QName -> Pattern -> ExpandedEllipsis -> LeftHandSide
LeftHandSide QName
top Pattern
lhs ExpandedEllipsis
NoEllipsis
    [NamedArg Pattern]
ps  <- case LHS
lhs of
             A.LHS LHSInfo
_ (A.LHSHead QName
_ [NamedArg Pattern]
ps) -> [NamedArg Pattern] -> TCMT IO [NamedArg Pattern]
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 t. HasRange t => t -> 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 t. HasRange t => t -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
      Pattern
p <- Pattern -> ScopeM Pattern
forall a. ExpandPatternSynonyms a => a -> TCM a
expandPatternSynonyms (Pattern -> ScopeM Pattern) -> Pattern -> ScopeM 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 (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 (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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
rhs
    [Pragma] -> ScopeM [Pragma]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> [NamedArg Pattern] -> Expr -> Pragma
A.DisplayPragma QName
hd [NamedArg Pattern]
ps Expr
rhs]

  toAbstract (C.WarningOnUsage Range
_ QName
oqn String
str) = do
    QName
qn <- OldName QName -> ScopeM QName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (OldName QName -> ScopeM QName) -> OldName QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ QName -> OldName QName
forall a. a -> OldName a
OldName QName
oqn
    Lens' (Map QName String) TCState
stLocalUserWarnings Lens' (Map QName String) TCState
-> (Map QName String -> Map QName String) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> (a -> a) -> m ()
`modifyTCLens` QName -> String -> Map QName String -> Map QName String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QName
qn String
str
    [Pragma] -> ScopeM [Pragma]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

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

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

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

instance ToAbstract C.Clause A.Clause where
  toAbstract :: Clause -> ScopeM Clause
toAbstract (C.Clause Name
top Bool
catchall lhs :: LHS
lhs@(C.LHS Pattern
p [RewriteEqn]
eqs [WithHiding Expr]
with ExpandedEllipsis
ell) RHS' Expr
rhs WhereClause' [Declaration]
wh [Clause]
wcs) = ScopeM Clause -> ScopeM Clause
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM Clause -> ScopeM Clause) -> ScopeM Clause -> ScopeM 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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, 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 LHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (LeftHandSide -> ScopeM LHS) -> LeftHandSide -> ScopeM LHS
forall a b. (a -> b) -> a -> b
$ QName -> Pattern -> ExpandedEllipsis -> LeftHandSide
LeftHandSide (Name -> QName
C.QName Name
top) Pattern
p ExpandedEllipsis
ell
    VerboseLevel -> String -> TCMT IO ()
printLocals VerboseLevel
10 String
"after lhs:"
    [(Name, LocalVar)]
vars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
    [RewriteEqn' () Pattern Expr]
eqs <- (RewriteEqn -> TCMT IO (RewriteEqn' () Pattern Expr))
-> [RewriteEqn] -> TCMT IO [RewriteEqn' () Pattern Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Precedence -> RewriteEqn -> TCMT IO (RewriteEqn' () Pattern Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
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 = VerboseLevel -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. VerboseLevel -> [a] -> [a]
dropEnd ([(Name, LocalVar)] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length [(Name, LocalVar)]
vars1) [(Name, LocalVar)]
vars2 [(Name, LocalVar)] -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, LocalVar)]
vars0
    let wcs' :: [TCMT IO Clause]
wcs' = [Clause] -> (Clause -> TCMT IO Clause) -> [TCMT IO Clause]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [Clause]
wcs ((Clause -> TCMT IO Clause) -> [TCMT IO Clause])
-> (Clause -> TCMT IO Clause) -> [TCMT IO Clause]
forall a b. (a -> b) -> a -> b
$ \ Clause
c -> [(Name, LocalVar)] -> TCMT IO ()
setLocalVars [(Name, LocalVar)]
vars TCMT IO () -> Clause -> TCMT IO Clause
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Clause
c
    let (Maybe (Name, Access)
whname, [Declaration]
whds) = case WhereClause' [Declaration]
wh of
          WhereClause' [Declaration]
NoWhere        -> (Maybe (Name, Access)
forall a. Maybe a
Nothing, [])
          -- Andreas, 2016-07-17 issues #2081 and #2101
          -- where-declarations are automatically private.
          -- This allows their type signature to be checked InAbstractMode.
          AnyWhere [Declaration]
ds    -> (Maybe (Name, Access)
forall a. Maybe a
Nothing, [Range -> Origin -> [Declaration] -> Declaration
C.Private Range
forall a. Range' a
noRange Origin
Inserted [Declaration]
ds])
          -- Named where-modules do not default to private.
          SomeWhere Name
m Access
a [Declaration]
ds -> ((Name, Access) -> Maybe (Name, Access)
forall a. a -> Maybe a
Just (Name
m, Access
a), [Declaration]
ds)

    let isTerminationPragma :: C.Declaration -> Bool
        isTerminationPragma :: Declaration -> Bool
isTerminationPragma (C.Private Range
_ Origin
_ [Declaration]
ds) = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
isTerminationPragma [Declaration]
ds
        isTerminationPragma (C.Pragma (TerminationCheckPragma Range
_ TerminationCheck
_)) = Bool
True
        isTerminationPragma Declaration
_                                       = Bool
False

    if Bool -> Bool
not ([RewriteEqn' () Pattern Expr] -> Bool
forall a. Null a => a -> Bool
null [RewriteEqn' () Pattern Expr]
eqs)
      then do
        RHS
rhs <- AbstractRHS -> ScopeM RHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (AbstractRHS -> ScopeM RHS) -> TCMT IO AbstractRHS -> ScopeM RHS
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Precedence -> RightHandSide -> TCMT IO AbstractRHS
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx ([RewriteEqn' () Pattern Expr]
-> [WithHiding Expr]
-> [TCMT IO Clause]
-> RHS' Expr
-> Maybe (Name, Access)
-> [Declaration]
-> RightHandSide
RightHandSide [RewriteEqn' () Pattern Expr]
eqs [WithHiding Expr]
with [TCMT IO Clause]
wcs' RHS' Expr
rhs Maybe (Name, Access)
whname [Declaration]
whds)
        Clause -> ScopeM Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ScopeM Clause) -> Clause -> ScopeM 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
        -- ASR (16 November 2015) Issue 1137: We ban termination
        -- pragmas inside `where` clause.
        Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
isTerminationPragma [Declaration]
whds) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
             String -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"Termination pragmas are not allowed inside where clauses"

        -- the right hand side is checked with the module of the local definitions opened
        (AbstractRHS
rhs, WhereDeclarations
ds) <- Range
-> Maybe (Name, Access)
-> [Declaration]
-> TCMT IO AbstractRHS
-> ScopeM (AbstractRHS, WhereDeclarations)
forall a.
Range
-> Maybe (Name, Access)
-> [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract (WhereClause' [Declaration] -> Range
forall t. HasRange t => t -> Range
getRange WhereClause' [Declaration]
wh) Maybe (Name, Access)
whname [Declaration]
whds (TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations))
-> TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
                      Precedence -> RightHandSide -> TCMT IO AbstractRHS
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx ([RewriteEqn' () Pattern Expr]
-> [WithHiding Expr]
-> [TCMT IO Clause]
-> RHS' Expr
-> Maybe (Name, Access)
-> [Declaration]
-> RightHandSide
RightHandSide [RewriteEqn' () Pattern Expr]
eqs [WithHiding Expr]
with [TCMT IO Clause]
wcs' RHS' Expr
rhs Maybe (Name, Access)
forall a. Maybe a
Nothing [])
        RHS
rhs <- AbstractRHS -> ScopeM RHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract AbstractRHS
rhs
                 -- #2897: we need to restrict named where modules in refined contexts,
                 --        so remember whether it was named here
        Clause -> ScopeM Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ScopeM Clause) -> Clause -> ScopeM 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.
  -> Maybe (C.Name, Access)           -- ^ The name of the @where@ module (if any).
  -> [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.
whereToAbstract :: Range
-> Maybe (Name, Access)
-> [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract Range
_ Maybe (Name, Access)
whname []   ScopeM a
inner = (, 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
whereToAbstract Range
r Maybe (Name, Access)
whname [Declaration]
whds ScopeM a
inner = do
  -- 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 (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 t. HasRange t => t -> Range
getRange Maybe (Name, Access)
whname) NameId
x, Origin -> Access
PrivateAccess Origin
Inserted)
           -- unnamed where's are private
  let tel :: [a]
tel = []
  ModuleName
old <- ScopeM ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
  ModuleName
am  <- NewModuleName -> ScopeM ModuleName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (Name -> NewModuleName
NewModuleName Name
m)
  (ScopeInfo
scope, [Declaration]
ds) <- Range
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, [Declaration])
scopeCheckModule Range
r (Name -> QName
C.QName Name
m) ModuleName
am Telescope
forall a. [a]
tel (ScopeM [Declaration] -> TCMT IO (ScopeInfo, [Declaration]))
-> ScopeM [Declaration] -> TCMT IO (ScopeInfo, [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> ScopeM [Declaration]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [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 :: Maybe Range
publicOpen = Range -> Maybe Range
forall a. a -> Maybe a
Just Range
forall a. Range' a
noRange }
  (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Maybe ModuleName -> [Declaration] -> WhereDeclarations
A.WhereDecls (ModuleName
am ModuleName -> Maybe (Name, Access) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Name, Access)
whname) [Declaration]
ds)

data RightHandSide = RightHandSide
  { RightHandSide -> [RewriteEqn' () Pattern Expr]
_rhsRewriteEqn :: [RewriteEqn' () A.Pattern A.Expr]
    -- ^ @rewrite e | with p <- e@ (many)
  , RightHandSide -> [WithHiding Expr]
_rhsWithExpr   :: [WithHiding C.WithExpr]
    -- ^ @with e@ (many)
  , RightHandSide -> [TCMT IO Clause]
_rhsSubclauses :: [ScopeM 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 -> Maybe (Name, Access)
_rhsWhereName  :: Maybe (C.Name, Access)
    -- ^ The name of the @where@ module (if any).
  , RightHandSide -> [Declaration]
_rhsWhereDecls :: [C.Declaration]
    -- ^ The contents of the @where@ module.
  }

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

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

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

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

instance ToAbstract C.RewriteEqn (RewriteEqn' () A.Pattern A.Expr) where
  toAbstract :: RewriteEqn -> TCMT IO (RewriteEqn' () Pattern Expr)
toAbstract = \case
    Rewrite [((), Expr)]
es   -> [((), Expr)] -> RewriteEqn' () Pattern Expr
forall qn p e. [(qn, e)] -> RewriteEqn' qn p e
Rewrite ([((), Expr)] -> RewriteEqn' () Pattern Expr)
-> TCMT IO [((), Expr)] -> TCMT IO (RewriteEqn' () Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((), Expr) -> TCMT IO ((), Expr))
-> [((), Expr)] -> TCMT IO [((), Expr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((), Expr) -> TCMT IO ((), Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [((), Expr)]
es
    Invert ()
_ [(Pattern, Expr)]
pes -> () -> [(Pattern, Expr)] -> RewriteEqn' () Pattern Expr
forall qn p e. qn -> [(p, e)] -> RewriteEqn' qn p e
Invert () ([(Pattern, Expr)] -> RewriteEqn' () Pattern Expr)
-> TCMT IO [(Pattern, Expr)]
-> TCMT IO (RewriteEqn' () Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      let ([Pattern]
ps, [Expr]
es) = [(Pattern, Expr)] -> ([Pattern], [Expr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Pattern, Expr)]
pes
      -- first check the expressions: the patterns may shadow some of the variables
      -- mentioned in them!
      [Expr]
es <- [Expr] -> TCMT IO [Expr]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Expr]
es
      -- then parse the patterns and go through the motions of converting them,
      -- checking them for linearity, binding the variable introduced in them
      -- and finally producing an abstract pattern.
      [Pattern]
ps <- [Pattern] -> (Pattern -> ScopeM Pattern) -> TCMT IO [Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Pattern]
ps ((Pattern -> ScopeM Pattern) -> TCMT IO [Pattern])
-> (Pattern -> ScopeM Pattern) -> TCMT IO [Pattern]
forall a b. (a -> b) -> a -> b
$ \ Pattern
p -> do
        Pattern
p <- Pattern -> ScopeM Pattern
parsePattern Pattern
p
        Pattern' Expr
p <- Pattern -> ScopeM (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pattern
p
        Pattern' Expr -> ([Name] -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a p.
(Monad m, APatternLike a p) =>
p -> ([Name] -> m ()) -> m ()
checkPatternLinearity Pattern' Expr
p (TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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' Expr -> ScopeM Pattern
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pattern' Expr
p
      [(Pattern, Expr)] -> TCMT IO [(Pattern, Expr)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Pattern, Expr)] -> TCMT IO [(Pattern, Expr)])
-> [(Pattern, Expr)] -> TCMT IO [(Pattern, Expr)]
forall a b. (a -> b) -> a -> b
$ [Pattern] -> [Expr] -> [(Pattern, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pattern]
ps [Expr]
es

instance ToAbstract AbstractRHS A.RHS where
  toAbstract :: AbstractRHS -> ScopeM RHS
toAbstract AbstractRHS
AbsurdRHS'            = RHS -> ScopeM RHS
forall (m :: * -> *) a. Monad m => a -> m a
return RHS
A.AbsurdRHS
  toAbstract (RHS' Expr
e Expr
c)            = RHS -> ScopeM RHS
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS -> ScopeM RHS) -> RHS -> ScopeM RHS
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' () Pattern Expr]
eqs AbstractRHS
rhs WhereDeclarations
wh) = do
    [RewriteEqn]
eqs <- [RewriteEqn' () Pattern Expr] -> ScopeM [RewriteEqn]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [RewriteEqn' () Pattern Expr]
eqs
    RHS
rhs <- AbstractRHS -> ScopeM RHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract AbstractRHS
rhs
    RHS -> ScopeM RHS
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS -> ScopeM RHS) -> RHS -> ScopeM RHS
forall a b. (a -> b) -> a -> b
$ [RewriteEqn] -> [ProblemEq] -> RHS -> WhereDeclarations -> RHS
RewriteRHS [RewriteEqn]
eqs [] RHS
rhs WhereDeclarations
wh
  toAbstract (WithRHS' [WithHiding Expr]
es [TCMT IO Clause]
cs) = do
    QName
aux <- String -> ScopeM QName
withFunctionName String
"with-"
    QName -> [WithHiding Expr] -> [Clause] -> RHS
A.WithRHS QName
aux [WithHiding Expr]
es ([Clause] -> RHS) -> TCMT IO [Clause] -> ScopeM RHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do [Clause] -> TCMT IO [Clause]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ([Clause] -> TCMT IO [Clause])
-> TCMT IO [Clause] -> TCMT IO [Clause]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCMT IO Clause] -> TCMT IO [Clause]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TCMT IO Clause]
cs

instance ToAbstract RightHandSide AbstractRHS where
  toAbstract :: RightHandSide -> TCMT IO AbstractRHS
toAbstract (RightHandSide eqs :: [RewriteEqn' () Pattern Expr]
eqs@(RewriteEqn' () Pattern Expr
_:[RewriteEqn' () Pattern Expr]
_) [WithHiding Expr]
es [TCMT IO Clause]
cs RHS' Expr
rhs Maybe (Name, Access)
whname [Declaration]
wh) = do
    (AbstractRHS
rhs, WhereDeclarations
ds) <- Range
-> Maybe (Name, Access)
-> [Declaration]
-> TCMT IO AbstractRHS
-> ScopeM (AbstractRHS, WhereDeclarations)
forall a.
Range
-> Maybe (Name, Access)
-> [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract ([Declaration] -> Range
forall t. HasRange t => t -> Range
getRange [Declaration]
wh) Maybe (Name, Access)
whname [Declaration]
wh (TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations))
-> TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
                  RightHandSide -> TCMT IO AbstractRHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract ([RewriteEqn' () Pattern Expr]
-> [WithHiding Expr]
-> [TCMT IO Clause]
-> RHS' Expr
-> Maybe (Name, Access)
-> [Declaration]
-> RightHandSide
RightHandSide [] [WithHiding Expr]
es [TCMT IO Clause]
cs RHS' Expr
rhs Maybe (Name, Access)
forall a. Maybe a
Nothing [])
    AbstractRHS -> TCMT IO AbstractRHS
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' () Pattern Expr]
-> AbstractRHS -> WhereDeclarations -> AbstractRHS
RewriteRHS' [RewriteEqn' () Pattern Expr]
eqs AbstractRHS
rhs WhereDeclarations
ds
  toAbstract (RightHandSide [] [] (TCMT IO Clause
_ : [TCMT IO Clause]
_) RHS' Expr
_ Maybe (Name, Access)
_ [Declaration]
_)        = TCMT IO AbstractRHS
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] (WithHiding Expr
_ : [WithHiding Expr]
_) [TCMT IO Clause]
_ (C.RHS Expr
_) Maybe (Name, Access)
_ [Declaration]
_) = TypeError -> TCMT IO AbstractRHS
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO AbstractRHS)
-> TypeError -> TCMT IO AbstractRHS
forall a b. (a -> b) -> a -> b
$ TypeError
BothWithAndRHS
  toAbstract (RightHandSide [] [] [] RHS' Expr
rhs Maybe (Name, Access)
_ [])          = RHS' Expr -> TCMT IO AbstractRHS
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract RHS' Expr
rhs
  toAbstract (RightHandSide [] [WithHiding Expr]
es [TCMT IO Clause]
cs RHS' Expr
C.AbsurdRHS Maybe (Name, Access)
_ [])  = do
    [WithHiding Expr]
es <- Precedence -> [WithHiding Expr] -> ScopeM [WithHiding Expr]
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
TopCtx [WithHiding Expr]
es
    AbstractRHS -> TCMT IO AbstractRHS
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractRHS -> TCMT IO AbstractRHS)
-> AbstractRHS -> TCMT IO AbstractRHS
forall a b. (a -> b) -> a -> b
$ [WithHiding Expr] -> [TCMT IO Clause] -> AbstractRHS
WithRHS' [WithHiding Expr]
es [TCMT IO Clause]
cs
  -- TODO: some of these might be possible
  toAbstract (RightHandSide [] (WithHiding Expr
_ : [WithHiding Expr]
_) [TCMT IO Clause]
_ RHS' Expr
C.AbsurdRHS Maybe (Name, Access)
_ (Declaration
_ : [Declaration]
_)) = TCMT IO AbstractRHS
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] [] [] (C.RHS Expr
_) Maybe (Name, Access)
_ (Declaration
_ : [Declaration]
_))       = TCMT IO AbstractRHS
forall a. HasCallStack => a
__IMPOSSIBLE__
  toAbstract (RightHandSide [] [] [] RHS' Expr
C.AbsurdRHS Maybe (Name, Access)
_ (Declaration
_ : [Declaration]
_))     = TCMT IO AbstractRHS
forall a. HasCallStack => a
__IMPOSSIBLE__

instance ToAbstract C.RHS AbstractRHS where
    toAbstract :: RHS' Expr -> TCMT IO AbstractRHS
toAbstract RHS' Expr
C.AbsurdRHS = AbstractRHS -> TCMT IO AbstractRHS
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Expr
e TCMT IO (Expr -> AbstractRHS)
-> TCMT IO Expr -> TCMT IO AbstractRHS
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> TCMT IO Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
e

data LeftHandSide = LeftHandSide C.QName C.Pattern ExpandedEllipsis

instance ToAbstract LeftHandSide A.LHS where
    toAbstract :: LeftHandSide -> ScopeM LHS
toAbstract (LeftHandSide QName
top Pattern
lhs ExpandedEllipsis
ell) =
      Call -> ScopeM LHS -> ScopeM LHS
forall (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm a
traceCall (QName -> Pattern -> Call
ScopeCheckLHS QName
top Pattern
lhs) (ScopeM LHS -> ScopeM LHS) -> ScopeM LHS -> ScopeM LHS
forall a b. (a -> b) -> a -> b
$ do
        LHSCore
lhscore <- QName -> Pattern -> TCMT IO LHSCore
parseLHS QName
top Pattern
lhs
        String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.lhs" VerboseLevel
5 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"parsed lhs: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHSCore -> String
forall a. Show a => a -> String
show LHSCore
lhscore
        VerboseLevel -> String -> TCMT IO ()
printLocals VerboseLevel
10 String
"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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 (LHSCore' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract LHSCore
lhscore
        TCMT IO ()
bindVarsToBind
        String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.lhs" VerboseLevel
5 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"parsed lhs patterns: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHSCore' Expr -> String
forall a. Show a => a -> String
show LHSCore' Expr
lhscore
        VerboseLevel -> String -> TCMT IO ()
printLocals VerboseLevel
10 String
"checked pattern:"
        -- scope check dot patterns
        LHSCore' Expr
lhscore <- LHSCore' Expr -> ScopeM (LHSCore' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract LHSCore' Expr
lhscore
        String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.lhs" VerboseLevel
5 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"parsed lhs dot patterns: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LHSCore' Expr -> String
forall a. Show a => a -> String
show LHSCore' Expr
lhscore
        VerboseLevel -> String -> TCMT IO ()
printLocals VerboseLevel
10 String
"checked dots:"
        LHS -> ScopeM LHS
forall (m :: * -> *) a. Monad m => a -> m a
return (LHS -> ScopeM LHS) -> LHS -> ScopeM LHS
forall a b. (a -> b) -> a -> b
$ LHSInfo -> LHSCore' Expr -> LHS
A.LHS (Range -> ExpandedEllipsis -> LHSInfo
LHSInfo (Pattern -> Range
forall t. HasRange t => t -> Range
getRange Pattern
lhs) ExpandedEllipsis
ell) LHSCore' Expr
lhscore

-- Merges adjacent EqualP patterns into one: typecheking expects only one pattern for each domain in the telescope.
mergeEqualPs :: [NamedArg (Pattern' e)] -> [NamedArg (Pattern' e)]
mergeEqualPs :: [NamedArg (Pattern' e)] -> [NamedArg (Pattern' e)]
mergeEqualPs = Maybe ((ArgInfo, Maybe NamedName, PatInfo), [(e, e)])
-> [NamedArg (Pattern' e)] -> [NamedArg (Pattern' e)]
forall name e.
Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
go Maybe ((ArgInfo, Maybe NamedName, PatInfo), [(e, e)])
forall a. Maybe a
Nothing
  where
    go :: Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
go Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
acc (Arg ArgInfo
i (Named Maybe name
n (A.EqualP PatInfo
r [(e, e)]
es)) : [Arg (Named name (Pattern' e))]
ps) = Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
go ((((ArgInfo, Maybe name, PatInfo), [(e, e)])
 -> ((ArgInfo, Maybe name, PatInfo), [(e, e)]))
-> Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(e, e)] -> [(e, e)])
-> ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> ((ArgInfo, Maybe name, PatInfo), [(e, e)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(e, e)] -> [(e, e)] -> [(e, e)]
forall a. [a] -> [a] -> [a]
++[(e, e)]
es)) Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
acc Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
forall a. a -> Maybe a
Just ((ArgInfo
i,Maybe name
n,PatInfo
r),[(e, e)]
es)) [Arg (Named name (Pattern' e))]
ps
    go Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
Nothing [] = []
    go Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
Nothing (Arg (Named name (Pattern' e))
p : [Arg (Named name (Pattern' e))]
ps) = Arg (Named name (Pattern' e))
p Arg (Named name (Pattern' e))
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
forall a. a -> [a] -> [a]
: Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
go Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
forall a. Maybe a
Nothing [Arg (Named name (Pattern' e))]
ps
    go (Just ((ArgInfo
i,Maybe name
n,PatInfo
r),[(e, e)]
es)) [Arg (Named name (Pattern' e))]
ps = ArgInfo -> Named name (Pattern' e) -> Arg (Named name (Pattern' e))
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (Maybe name -> Pattern' e -> Named name (Pattern' e)
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n (PatInfo -> [(e, e)] -> Pattern' e
forall e. PatInfo -> [(e, e)] -> Pattern' e
A.EqualP PatInfo
r [(e, e)]
es)) Arg (Named name (Pattern' e))
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
forall a. a -> [a] -> [a]
:
      case [Arg (Named name (Pattern' e))]
ps of
        (Arg (Named name (Pattern' e))
p : [Arg (Named name (Pattern' e))]
ps) -> Arg (Named name (Pattern' e))
p Arg (Named name (Pattern' e))
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
forall a. a -> [a] -> [a]
: Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
-> [Arg (Named name (Pattern' e))]
-> [Arg (Named name (Pattern' e))]
go Maybe ((ArgInfo, Maybe name, PatInfo), [(e, e)])
forall a. Maybe a
Nothing [Arg (Named name (Pattern' e))]
ps
        []     -> []

-- does not check pattern linearity
instance ToAbstract C.LHSCore (A.LHSCore' C.Expr) where
    toAbstract :: LHSCore -> ScopeM (LHSCore' Expr)
toAbstract (C.LHSHead QName
x [NamedArg Pattern]
ps) = do
        QName
x <- ScopeM QName -> ScopeM QName
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM QName -> ScopeM QName) -> ScopeM QName -> ScopeM QName
forall a b. (a -> b) -> a -> b
$ do
          [(Name, LocalVar)] -> TCMT IO ()
setLocalVars []
          OldName QName -> ScopeM QName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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)
-> ([Arg (Named NamedName (Pattern' Expr))]
    -> [Arg (Named NamedName (Pattern' Expr))])
-> [Arg (Named NamedName (Pattern' Expr))]
-> LHSCore' Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall e. [NamedArg (Pattern' e)] -> [NamedArg (Pattern' e)]
mergeEqualPs ([Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg Pattern]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError (Doc -> TypeError) -> Doc -> TypeError
forall a b. (a -> b) -> a -> b
$
          Doc
"Ill-formed projection pattern" Doc -> Doc -> Doc
P.<+> Pattern -> Doc
forall a. Pretty a => a -> Doc
P.pretty ((Pattern -> NamedArg Pattern -> Pattern)
-> Pattern -> [NamedArg Pattern] -> Pattern
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pattern -> NamedArg Pattern -> Pattern
C.AppP (QName -> Pattern
C.IdentP QName
d) [NamedArg Pattern]
ps1)
        ResolvedName
qx <- QName -> ScopeM ResolvedName
resolveName QName
d
        NonEmpty QName
ds <- case ResolvedName
qx of
                FieldName NonEmpty AbstractName
ds -> NonEmpty QName -> TCMT IO (NonEmpty QName)
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) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds
                ResolvedName
UnknownName -> QName -> TCMT IO (NonEmpty QName)
forall a. QName -> TCM a
notInScopeError QName
d
                ResolvedName
_           -> String -> TCMT IO (NonEmpty QName)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> TCMT IO (NonEmpty QName))
-> String -> TCMT IO (NonEmpty QName)
forall a b. (a -> b) -> a -> b
$
                  String
"head of copattern needs to be a field identifier, but "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 -> TCMT IO (NamedArg (LHSCore' Expr))
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract NamedArg LHSCore
l TCMT IO ([Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (LHSCore' Expr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall e. [NamedArg (Pattern' e)] -> [NamedArg (Pattern' e)]
mergeEqualPs ([Arg (Named NamedName (Pattern' Expr))]
 -> [Arg (Named NamedName (Pattern' Expr))])
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg Pattern]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [NamedArg Pattern]
ps2)
    toAbstract (C.LHSWith LHSCore
core [Pattern]
wps [NamedArg Pattern]
ps) = do
      (LHSCore' Expr
 -> [Pattern' Expr]
 -> [Arg (Named NamedName (Pattern' Expr))]
 -> LHSCore' Expr)
-> ScopeM (LHSCore' Expr)
-> TCMT IO [Pattern' Expr]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (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
-> [Pattern' Expr]
-> [Arg (Named NamedName (Pattern' Expr))]
-> LHSCore' Expr
forall e.
LHSCore' e -> [Pattern' e] -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSWith
        (LHSCore -> ScopeM (LHSCore' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract LHSCore
core)
        ([Pattern] -> TCMT IO [Pattern' Expr]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Pattern]
wps)
        ([NamedArg Pattern]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [NamedArg Pattern]
ps)

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

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

instance ToAbstract c a => ToAbstract (Named name c) (Named name a) where
    toAbstract :: Named name c -> ScopeM (Named name a)
toAbstract (Named Maybe name
n c
e) = Maybe name -> a -> Named name a
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n (a -> Named name a) -> TCMT IO a -> ScopeM (Named name a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> TCMT IO a
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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) (A.LHSCore' A.Expr) where
    toAbstract :: LHSCore' Expr -> ScopeM (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] -> ScopeM (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)
mapM Arg (Named NamedName (Pattern' Expr)) -> TCMT IO (NamedArg Pattern)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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)
mapM Named_ (LHSCore' Expr) -> TCMT IO (Named_ (LHSCore' Expr))
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract NamedArg (LHSCore' Expr)
lhscore TCMT IO ([NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO [NamedArg Pattern] -> ScopeM (LHSCore' Expr)
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)
mapM Arg (Named NamedName (Pattern' Expr)) -> TCMT IO (NamedArg Pattern)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps
    toAbstract (A.LHSWith LHSCore' Expr
core [Pattern' Expr]
wps [Arg (Named NamedName (Pattern' Expr))]
ps)  = (LHSCore' Expr -> [Pattern] -> [NamedArg Pattern] -> LHSCore' Expr)
-> ScopeM (LHSCore' Expr)
-> TCMT IO [Pattern]
-> TCMT IO [NamedArg Pattern]
-> ScopeM (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 -> [Pattern] -> [NamedArg Pattern] -> LHSCore' Expr
forall e.
LHSCore' e -> [Pattern' e] -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSWith (LHSCore' Expr -> ScopeM (LHSCore' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract LHSCore' Expr
core) ([Pattern' Expr] -> TCMT IO [Pattern]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [Pattern' Expr]
wps) ([Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [NamedArg Pattern]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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) (A.Pattern' A.Expr) where
  toAbstract :: Pattern' Expr -> ScopeM Pattern
toAbstract = (Expr -> ScopeM Expr) -> Pattern' Expr -> ScopeM Pattern
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr -> ScopeM Expr) -> Pattern' Expr -> ScopeM Pattern)
-> (Expr -> ScopeM Expr) -> Pattern' Expr -> ScopeM 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
DotPatternCtx  -- Issue #3033

resolvePatternIdentifier ::
  Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)
resolvePatternIdentifier :: Range -> QName -> Maybe (Set Name) -> ScopeM (Pattern' Expr)
resolvePatternIdentifier Range
r QName
x Maybe (Set Name)
ns = do
  String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
60 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"resolvePatternIdentifier " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at source position " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Range -> String
forall a. Show a => a -> String
show Range
r
  APatName
px <- PatName -> ScopeM APatName
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> Maybe (Set Name) -> PatName
PatName QName
x Maybe (Set Name)
ns)
  case APatName
px of
    VarPatName Name
y         -> do
      String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
60 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"  resolved to VarPatName " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with range " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Range -> String
forall a. Show a => a -> String
show (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
y)
      Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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 NonEmpty AbstractName
ds        -> Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds) []
    PatternSynPatName NonEmpty AbstractName
ds -> Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds) []

-- | Apply an abstract syntax pattern head to pattern arguments.
--
--   Fails with 'InvalidPattern' if head is not a constructor pattern
--   (or similar) that can accept arguments.
--
applyAPattern
  :: C.Pattern            -- ^ The application pattern in concrete syntax.
  -> A.Pattern' C.Expr    -- ^ Head of application.
  -> NAPs C.Expr          -- ^ Arguments of application.
  -> ScopeM (A.Pattern' C.Expr)
applyAPattern :: Pattern
-> Pattern' Expr
-> [Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (Pattern' Expr)
applyAPattern Pattern
p0 Pattern' Expr
p [Arg (Named NamedName (Pattern' Expr))]
ps = do
  Range -> Pattern' Expr -> Pattern' Expr
forall t. SetRange t => Range -> t -> t
setRange (Pattern -> Range
forall t. HasRange t => t -> Range
getRange Pattern
p0) (Pattern' Expr -> Pattern' Expr)
-> ScopeM (Pattern' Expr) -> ScopeM (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 -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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 -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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 -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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 -> ScopeM (Pattern' Expr))
-> ScopeM (Pattern' Expr)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ConstructorName NonEmpty 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) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
ds)
          Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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
_ -> ScopeM (Pattern' Expr)
failure
      A.DotP{}    -> ScopeM (Pattern' Expr)
failure
      A.VarP{}    -> ScopeM (Pattern' Expr)
failure
      A.ProjP{}   -> ScopeM (Pattern' Expr)
failure
      A.WildP{}   -> ScopeM (Pattern' Expr)
failure
      A.AsP{}     -> ScopeM (Pattern' Expr)
failure
      A.AbsurdP{} -> ScopeM (Pattern' Expr)
failure
      A.LitP{}    -> ScopeM (Pattern' Expr)
failure
      A.RecP{}    -> ScopeM (Pattern' Expr)
failure
      A.EqualP{}  -> ScopeM (Pattern' Expr)
failure
      A.WithP{}   -> ScopeM (Pattern' Expr)
failure
  where
    failure :: ScopeM (Pattern' Expr)
failure = TypeError -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> ScopeM (Pattern' Expr))
-> TypeError -> ScopeM (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
InvalidPattern Pattern
p0

instance ToAbstract C.Pattern (A.Pattern' C.Expr) where

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

    toAbstract (AppP (QuoteP Range
_) NamedArg Pattern
p)
      | IdentP 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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)
      let quoted :: Expr -> m QName
quoted (A.Def QName
x) = QName -> m QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          quoted (A.Macro QName
x) = QName -> m QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
          quoted (A.Proj ProjOrigin
_ AmbiguousQName
p)
            | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p = QName -> m QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
            | Bool
otherwise                  = String -> m QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> m QName) -> String -> m QName
forall a b. (a -> b) -> a -> b
$ String
"quote: Ambigous name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow (AmbiguousQName -> NonEmpty QName
unAmbQ AmbiguousQName
p)
          quoted (A.Con AmbiguousQName
c)
            | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c = QName -> m QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
            | Bool
otherwise                  = String -> m QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> m QName) -> String -> m QName
forall a b. (a -> b) -> a -> b
$ String
"quote: Ambigous name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> String
forall a. Pretty a => a -> String
prettyShow (AmbiguousQName -> NonEmpty QName
unAmbQ AmbiguousQName
c)
          quoted (A.ScopedExpr ScopeInfo
_ Expr
e) = Expr -> m QName
quoted Expr
e
          quoted Expr
_                  = String -> m QName
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError (String -> m QName) -> String -> m QName
forall a b. (a -> b) -> a -> b
$ String
"quote: not a defined name"
      Literal -> Pattern' Expr
forall e. Literal -> Pattern' e
A.LitP (Literal -> Pattern' Expr)
-> (QName -> Literal) -> QName -> Pattern' Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> QName -> Literal
LitQName (QName -> Range
forall t. HasRange t => t -> Range
getRange QName
x) (QName -> Pattern' Expr) -> ScopeM QName -> ScopeM (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM QName
forall (m :: * -> *).
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
Expr -> m QName
quoted Expr
e

    toAbstract (QuoteP Range
r) =
      String -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
String -> m a
genericError String
"quote must be applied to an identifier"

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

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

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

            fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a
            fromNoPlaceholder :: 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 [Expr]
es) = [Expr] -> TCMT IO Expr
parseApplication [Expr]
es
            parseRawApp Expr
e             = Expr -> TCMT IO Expr
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
        String -> VerboseLevel -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.pat" VerboseLevel
60 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String
"ConcreteToAbstract.toAbstract OpAppP{}: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p0
        Pattern' Expr
p  <- Range -> QName -> Maybe (Set Name) -> ScopeM (Pattern' Expr)
resolvePatternIdentifier (QName -> Range
forall t. HasRange t => t -> 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]
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract [NamedArg Pattern]
ps
        Pattern
-> Pattern' Expr
-> [Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (Pattern' Expr)
applyAPattern Pattern
p0 Pattern' Expr
p [Arg (Named NamedName (Pattern' Expr))]
ps

    -- Removed when parsing
    toAbstract (HiddenP Range
_ Named NamedName Pattern
_)   = ScopeM (Pattern' Expr)
forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (InstanceP Range
_ Named NamedName Pattern
_) = ScopeM (Pattern' Expr)
forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (RawAppP Range
_ [Pattern]
_)   = ScopeM (Pattern' Expr)
forall a. HasCallStack => a
__IMPOSSIBLE__
    toAbstract (EllipsisP Range
_)   = ScopeM (Pattern' Expr)
forall a. HasCallStack => a
__IMPOSSIBLE__

    toAbstract p :: Pattern
p@(C.WildP Range
r)    = Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (Pattern' Expr)
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 (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pattern
p
    toAbstract (C.LitP Literal
l)       = Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ Literal -> Pattern' Expr
forall e. Literal -> Pattern' e
A.LitP 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)
        Name
x <- Name -> ScopeM Name
bindPatternVariable Name
x
        Pattern' Expr
p <- Pattern -> ScopeM (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
toAbstract Pattern
p
        Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ 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
p
    toAbstract p0 :: Pattern
p0@(C.EqualP Range
r [(Expr, Expr)]
es)  = Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (Pattern' Expr)
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 :: ScopeM (Pattern' Expr)
fallback = Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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 -> ScopeM (Pattern' Expr))
-> ScopeM (Pattern' Expr)
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 NonEmpty AbstractName
xs -> Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (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) -> NonEmpty AbstractName -> NonEmpty QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName NonEmpty AbstractName
xs
          ResolvedName
_ -> ScopeM (Pattern' Expr)
fallback
        Expr
_ -> ScopeM (Pattern' Expr)
fallback

    toAbstract p0 :: Pattern
p0@(C.AbsurdP Range
r)    = Pattern' Expr -> ScopeM (Pattern' Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> ScopeM (Pattern' Expr))
-> Pattern' Expr -> ScopeM (Pattern' Expr)
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)]
-> ScopeM (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)
mapM ((Pattern -> ScopeM (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)
traverse Pattern -> ScopeM (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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)
-> ScopeM (Pattern' Expr) -> ScopeM (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM (Pattern' Expr)
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
Precedence -> concrete -> ScopeM abstract
toAbstractCtx Precedence
ctx Expr
e
toAbstractOpArg Precedence
ctx (SyntaxBindingLambda Range
r [LamBinding]
bs Expr
e) = Range -> [LamBinding] -> Expr -> Precedence -> ScopeM Expr
toAbstractLam Range
r [LamBinding]
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 ->
                   [NamedArg (MaybePlaceholder (OpApp C.Expr))] ->
                   ScopeM A.Expr
toAbstractOpApp :: QName
-> Set Name
-> [NamedArg (MaybePlaceholder (OpApp Expr))]
-> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns [NamedArg (MaybePlaceholder (OpApp Expr))]
es = do
    -- Replace placeholders with bound variables.
    ([LamBinding]
binders, [NamedArg (Either Expr (OpApp Expr))]
es) <- [NamedArg (MaybePlaceholder (OpApp Expr))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp Expr))])
forall e.
[NamedArg (MaybePlaceholder (OpApp e))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp Expr))]
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 @BindingHoles@, since binders
    -- have been preprocessed into @OpApp C.Expr@.
    let nonBindingParts :: Notation
nonBindingParts = (GenPart -> Bool) -> Notation -> Notation
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (GenPart -> Bool) -> GenPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenPart -> Bool
isBindingHole) 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 -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length ((GenPart -> Bool) -> Notation -> Notation
forall a. (a -> Bool) -> [a] -> [a]
filter GenPart -> Bool
isAHole Notation
nonBindingParts) VerboseLevel -> VerboseLevel -> Bool
forall a. Eq a => a -> a -> Bool
== [NamedArg (Either Expr (OpApp Expr))] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
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 Expr
forall concrete abstract.
ToAbstract concrete abstract =>
concrete -> ScopeM abstract
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 (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 (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 (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 t. HasRange t => t -> Range
getRange Expr
body))) Expr
body [LamBinding]
binders
  where
    -- Build an application in the abstract syntax, with correct Range.
    app :: Expr -> (ParenPreference, NamedArg Expr) -> Expr
app Expr
e (ParenPreference
pref, NamedArg Expr
arg) = AppInfo -> Expr -> NamedArg Expr -> Expr
A.App AppInfo
info Expr
e NamedArg Expr
arg
      where info :: AppInfo
info = (Range -> AppInfo
defaultAppInfo Range
r) { appOrigin :: Origin
appOrigin = NamedArg Expr -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Expr
arg
                                      , appParens :: ParenPreference
appParens = ParenPreference
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))
-> ScopeM (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)) -> ScopeM (NamedArg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Named NamedName (Either Expr (OpApp Expr))
  -> TCMT IO (Named NamedName Expr))
 -> NamedArg (Either Expr (OpApp Expr)) -> ScopeM (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))
-> ScopeM (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)
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 (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 (GenPart
_ : 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 (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 (GenPart
_  : 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 [GenPart
x]          [NamedArg (Either Expr (OpApp Expr))]
es    = Fixity
-> GenPart
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
right Fixity
f GenPart
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 (GenPart
_  : 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 (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
_ (GenPart
_ : 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
-> GenPart
-> [NamedArg (Either Expr (OpApp Expr))]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
right Fixity
_ (IdPart RString
_)  [] = [(ParenPreference, NamedArg Expr)]
-> TCMT IO [(ParenPreference, NamedArg Expr)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    right Fixity
f GenPart
_          [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 (m :: * -> *) a. Monad m => a -> m a
return [(ParenPreference, NamedArg Expr)
e]
    right Fixity
_ GenPart
_     [NamedArg (Either Expr (OpApp Expr))]
_  = TCMT IO [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__

    replacePlaceholders ::
      [NamedArg (MaybePlaceholder (OpApp e))] ->
      ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])
    replacePlaceholders :: [NamedArg (MaybePlaceholder (OpApp e))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders []       = ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
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 d a. (b -> d) -> (a, b) -> (a, d)
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))]))
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             [NamedArg (MaybePlaceholder (OpApp e))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall e.
[NamedArg (MaybePlaceholder (OpApp e))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
      Placeholder PositionInName
_     -> do
        Name
x <- Range -> String -> ScopeM Name
forall (m :: * -> *).
MonadFresh NameId m =>
Range -> String -> m Name
freshName Range
forall a. Range' a
noRange String
"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))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall e.
[NamedArg (MaybePlaceholder (OpApp e))]
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
        ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamedArg Binder -> LamBinding
A.mkDomainFree (ArgInfo -> Binder -> NamedArg Binder
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
i (Binder -> NamedArg Binder) -> Binder -> NamedArg Binder
forall a b. (a -> b) -> a -> b
$ Name -> Binder
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 :: a -> NamedArg b -> NamedArg a
set a
x NamedArg b
arg = (Named NamedName b -> Named NamedName a)
-> NamedArg b -> NamedArg a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> a) -> Named NamedName b -> Named NamedName a
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


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

-- | Content of interaction hole.

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