module Agda.Syntax.Translation.ConcreteToAbstract
( ToAbstract(..), localToAbstract
, concreteToAbstract_
, concreteToAbstract
, NewModuleQName(..)
, TopLevel(..)
, TopLevelInfo(..)
, topLevelModuleName
, AbstractRHS
, NewModuleName, OldModuleName
, NewName, OldQName
, PatName, APatName
, importPrimitives
, checkAttributes
) where
import Prelude hiding ( null )
import Control.Monad ( (>=>), (<=<), foldM, forM, forM_, zipWithM, zipWithM_ )
import Control.Applicative ( liftA2, liftA3 )
import Control.Monad.Except ( MonadError(..) )
import Control.Monad.State ( StateT, execStateT, get, put )
import Control.Monad.Trans ( lift )
import Data.Bifunctor
import Data.Foldable (traverse_)
import Data.Set (Set)
import Data.Map (Map)
import Data.Functor (void)
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.HashSet as HashSet
import Data.Maybe
import Data.Void
import Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Attribute as CA
import Agda.Syntax.Concrete.Generic
import Agda.Syntax.Concrete.Operators
import Agda.Syntax.Concrete.Pattern
import Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Pattern as A ( patternVars, checkPatternLinearity, containsAsPattern, lhsCoreApp, lhsCoreWith )
import Agda.Syntax.Abstract.Pretty
import qualified Agda.Syntax.Internal as I
import Agda.Syntax.Position
import Agda.Syntax.Literal
import Agda.Syntax.Common
import Agda.Syntax.Info as Info
import Agda.Syntax.Concrete.Definitions as C
import Agda.Syntax.Fixity
import Agda.Syntax.Concrete.Fixity (DoWarn(..))
import Agda.Syntax.Notation
import Agda.Syntax.Scope.Base as A
import Agda.Syntax.Scope.Monad
import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs)
import Agda.Syntax.DoNotation
import Agda.Syntax.IdiomBrackets
import Agda.Syntax.TopLevelModuleName
import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)
import Agda.TypeChecking.Monad.State hiding (topLevelModuleName)
import qualified Agda.TypeChecking.Monad.State as S
import Agda.TypeChecking.Monad.Signature (notUnderOpaque)
import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)
import Agda.TypeChecking.Monad.Debug
import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath)
import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin, builtinKindOfName)
import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)
import Agda.TypeChecking.Pretty hiding (pretty, prettyA)
import Agda.TypeChecking.Quote (quotedName)
import Agda.TypeChecking.Opacity
import Agda.TypeChecking.Warnings
import Agda.Interaction.FindFile (checkModuleName, rootNameModule, SourceFile(SourceFile))
import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)
import Agda.Interaction.Options
import qualified Agda.Interaction.Options.Lenses as Lens
import Agda.Interaction.Options.Warnings
import qualified Agda.Utils.AssocList as AssocList
import Agda.Utils.CallStack ( HasCallStack, withCurrentCallStack )
import Agda.Utils.Char
import Agda.Utils.Either
import Agda.Utils.FileName
import Agda.Utils.Function ( applyWhen, applyWhenM )
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 ( List1, pattern (:|) )
import Agda.Utils.List2 ( List2, pattern List2 )
import qualified Agda.Utils.List1 as List1
import qualified Agda.Utils.Map as Map
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Syntax.Common.Pretty as P
import Agda.Syntax.Common.Pretty (render, Pretty, pretty, prettyShow)
import Agda.Utils.Singleton
import Agda.Utils.Tuple
import Agda.Utils.Impossible
import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)
import qualified Agda.Syntax.Common as A
notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a
notAnExpression :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
notAnExpression = (Expr -> TypeError) -> HasCallStack => Expr -> m a
forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError Expr -> TypeError
NotAnExpression
nothingAppliedToHiddenArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a
nothingAppliedToHiddenArg :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToHiddenArg = (Expr -> TypeError) -> HasCallStack => Expr -> m a
forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError Expr -> TypeError
NothingAppliedToHiddenArg
nothingAppliedToInstanceArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a
nothingAppliedToInstanceArg :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToInstanceArg = (Expr -> TypeError) -> HasCallStack => Expr -> m a
forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError Expr -> TypeError
NothingAppliedToInstanceArg
notAValidLetBinding :: (HasCallStack, MonadTCError m) => C.NiceDeclaration -> m a
notAValidLetBinding :: forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding = (NiceDeclaration -> TypeError)
-> HasCallStack => NiceDeclaration -> m a
forall (m :: * -> *) a b.
MonadTCError m =>
(a -> TypeError) -> HasCallStack => a -> m b
locatedTypeError NiceDeclaration -> TypeError
NotAValidLetBinding
noDotorEqPattern :: A.Pattern' e -> ScopeM (A.Pattern' Void)
noDotorEqPattern :: forall e. Pattern' e -> ScopeM (Pattern' Void)
noDotorEqPattern = Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot
where
dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)
dot :: forall e. Pattern' e -> ScopeM (Pattern' Void)
dot = \case
A.VarP BindName
x -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern' Void
forall e. BindName -> Pattern' e
A.VarP BindName
x
A.ConP ConPatInfo
i AmbiguousQName
c NAPs e
args -> ConPatInfo -> AmbiguousQName -> NAPs Void -> Pattern' Void
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c (NAPs Void -> Pattern' Void)
-> TCMT IO (NAPs Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void))
-> (NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e)
-> TCMT IO (NamedArg (Pattern' Void))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
A.ProjP PatInfo
i ProjOrigin
o AmbiguousQName
d -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' Void
forall e. PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' e
A.ProjP PatInfo
i ProjOrigin
o AmbiguousQName
d
A.WildP PatInfo
i -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Void
forall e. PatInfo -> Pattern' e
A.WildP PatInfo
i
A.AsP PatInfo
i BindName
x Pattern' e
p -> PatInfo -> BindName -> Pattern' Void -> Pattern' Void
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i BindName
x (Pattern' Void -> Pattern' Void)
-> ScopeM (Pattern' Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p
A.DotP{} -> ScopeM (Pattern' Void)
forall {a}. TCMT IO a
err
A.EqualP{} -> ScopeM (Pattern' Void)
forall {a}. TCMT IO a
err
A.AbsurdP PatInfo
i -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Void
forall e. PatInfo -> Pattern' e
A.AbsurdP PatInfo
i
A.LitP PatInfo
i Literal
l -> Pattern' Void -> ScopeM (Pattern' Void)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' Void -> ScopeM (Pattern' Void))
-> Pattern' Void -> ScopeM (Pattern' Void)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Literal -> Pattern' Void
forall e. PatInfo -> Literal -> Pattern' e
A.LitP PatInfo
i Literal
l
A.DefP PatInfo
i AmbiguousQName
f NAPs e
args -> PatInfo -> AmbiguousQName -> NAPs Void -> Pattern' Void
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
f (NAPs Void -> Pattern' Void)
-> TCMT IO (NAPs Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void))
-> (NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e)
-> TCMT IO (NamedArg (Pattern' Void))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
A.PatternSynP PatInfo
i AmbiguousQName
c NAPs e
args -> PatInfo -> AmbiguousQName -> NAPs Void -> Pattern' Void
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
c (NAPs Void -> Pattern' Void)
-> TCMT IO (NAPs Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e -> TCMT IO (NAPs Void))
-> (NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> NAPs e
-> TCMT IO (NAPs Void)
forall a b. (a -> b) -> a -> b
$ (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e) -> TCMT IO (NamedArg (Pattern' Void)))
-> (Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void)))
-> NamedArg (Pattern' e)
-> TCMT IO (NamedArg (Pattern' Void))
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> Named_ (Pattern' e) -> TCMT IO (Named_ (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) NAPs e
args
A.RecP ConPatInfo
i [FieldAssignment' (Pattern' e)]
fs -> ConPatInfo -> [FieldAssignment' (Pattern' Void)] -> Pattern' Void
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i ([FieldAssignment' (Pattern' Void)] -> Pattern' Void)
-> TCMT IO [FieldAssignment' (Pattern' Void)]
-> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldAssignment' (Pattern' e)
-> TCMT IO (FieldAssignment' (Pattern' Void)))
-> [FieldAssignment' (Pattern' e)]
-> TCMT IO [FieldAssignment' (Pattern' Void)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((FieldAssignment' (Pattern' e)
-> TCMT IO (FieldAssignment' (Pattern' Void)))
-> [FieldAssignment' (Pattern' e)]
-> TCMT IO [FieldAssignment' (Pattern' Void)])
-> (FieldAssignment' (Pattern' e)
-> TCMT IO (FieldAssignment' (Pattern' Void)))
-> [FieldAssignment' (Pattern' e)]
-> TCMT IO [FieldAssignment' (Pattern' Void)]
forall a b. (a -> b) -> a -> b
$ (Pattern' e -> ScopeM (Pattern' Void))
-> FieldAssignment' (Pattern' e)
-> TCMT IO (FieldAssignment' (Pattern' Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot) [FieldAssignment' (Pattern' e)]
fs
A.WithP PatInfo
i Pattern' e
p -> PatInfo -> Pattern' Void -> Pattern' Void
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP PatInfo
i (Pattern' Void -> Pattern' Void)
-> ScopeM (Pattern' Void) -> ScopeM (Pattern' Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern' e -> ScopeM (Pattern' Void)
forall e. Pattern' e -> ScopeM (Pattern' Void)
dot Pattern' e
p
A.AnnP PatInfo
i e
a Pattern' e
p -> ScopeM (Pattern' Void)
forall {a}. TCMT IO a
err
err :: TCMT IO a
err = TypeError -> TCMT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
DotPatternInPatternSynonym
newtype RecordConstructorType = RecordConstructorType [C.Declaration]
instance ToAbstract RecordConstructorType where
type AbsOfCon RecordConstructorType = A.Expr
toAbstract :: RecordConstructorType -> ScopeM (AbsOfCon RecordConstructorType)
toAbstract (RecordConstructorType [Declaration]
ds) = [Declaration] -> ScopeM Expr
recordConstructorType [Declaration]
ds
recordConstructorType :: [C.Declaration] -> ScopeM A.Expr
recordConstructorType :: [Declaration] -> ScopeM Expr
recordConstructorType [Declaration]
decls =
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
let dummy :: Expr
dummy = ExprInfo -> Literal -> Expr
A.Lit ExprInfo
forall a. Null a => a
empty (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Literal
LitString Text
"TYPE"
tel <- [Maybe TypedBinding] -> [TypedBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TypedBinding] -> [TypedBinding])
-> TCMT IO [Maybe TypedBinding] -> TCMT IO [TypedBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NiceDeclaration -> TCMT IO (Maybe TypedBinding))
-> [NiceDeclaration] -> TCMT IO [Maybe TypedBinding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NiceDeclaration -> TCMT IO (Maybe TypedBinding)
makeBinding [NiceDeclaration]
ds
return $ A.mkPi (ExprRange (getRange ds)) tel dummy
makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)
makeBinding :: NiceDeclaration -> TCMT IO (Maybe TypedBinding)
makeBinding NiceDeclaration
d = do
let failure :: TCMT IO (Maybe TypedBinding)
failure = TypeError -> TCMT IO (Maybe TypedBinding)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (Maybe TypedBinding))
-> TypeError -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> TypeError
NotValidBeforeField NiceDeclaration
d
r :: Range
r = NiceDeclaration -> Range
forall a. HasRange a => a -> Range
getRange NiceDeclaration
d
mkLet :: NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet NiceDeclaration
d = TypedBinding -> Maybe TypedBinding
forall a. a -> Maybe a
Just (TypedBinding -> Maybe TypedBinding)
-> (List1 LetBinding -> TypedBinding)
-> List1 LetBinding
-> Maybe TypedBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> List1 LetBinding -> TypedBinding
A.TLet Range
r (List1 LetBinding -> Maybe TypedBinding)
-> TCMT IO (List1 LetBinding) -> TCMT IO (Maybe TypedBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetDef -> ScopeM (AbsOfCon LetDef)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (NiceDeclaration -> LetDef
LetDef NiceDeclaration
d)
Range
-> TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe TypedBinding)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe TypedBinding))
-> TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ case NiceDeclaration
d of
C.NiceField Range
r Access
pr IsAbstract
ab IsInstance
inst TacticAttribute
tac Name
x Arg Expr
a -> do
fx <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
let bv = Binder -> Named NamedName Binder
forall a name. a -> Named name a
unnamed (BoundName -> Binder
forall a. a -> Binder' a
C.mkBinder (BoundName -> Binder) -> BoundName -> Binder
forall a b. (a -> b) -> a -> b
$ (Name -> Fixity' -> BoundName
C.mkBoundName Name
x Fixity'
fx) { bnameTactic = tac }) Named NamedName Binder -> Arg Expr -> NamedArg Binder
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Expr
a
toAbstract $ C.TBind r (singleton bv) (unArg a)
C.NiceOpen Range
r QName
m ImportDirective
dir -> do
NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet (NiceDeclaration -> TCMT IO (Maybe TypedBinding))
-> NiceDeclaration -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ Range -> QName -> ImportDirective -> NiceDeclaration
C.NiceOpen Range
r QName
m ImportDirective
dir{ publicOpen = Nothing }
C.NiceModuleMacro Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet (NiceDeclaration -> TCMT IO (Maybe TypedBinding))
-> NiceDeclaration -> TCMT IO (Maybe TypedBinding)
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
C.NiceModuleMacro Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open
ImportDirective
dir{ publicOpen = Nothing }
C.NiceMutual KwRange
_ TerminationCheck
_ CoverageCheck
_ PositivityCheck
_
[ C.FunSig Range
_ Access
_ IsAbstract
_ IsInstance
_ IsMacro
macro ArgInfo
_ TerminationCheck
_ CoverageCheck
_ Name
_ Expr
_
, C.FunDef Range
_ [Declaration]
_ IsAbstract
abstract IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_
[ C.Clause Name
_ Bool
_ (C.LHS Pattern
_p [] []) (C.RHS Expr
_) WhereClause' [Declaration]
NoWhere [] ]
] | IsAbstract
abstract IsAbstract -> IsAbstract -> Bool
forall a. Eq a => a -> a -> Bool
/= IsAbstract
AbstractDef Bool -> Bool -> Bool
&& IsMacro
macro IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
/= IsMacro
MacroDef -> do
NiceDeclaration -> TCMT IO (Maybe TypedBinding)
mkLet NiceDeclaration
d
C.NiceLoneConstructor{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceMutual{} -> TCMT IO (Maybe TypedBinding)
failure
C.Axiom{} -> TCMT IO (Maybe TypedBinding)
failure
C.PrimitiveFunction{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceModule{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceImport{} -> TCMT IO (Maybe TypedBinding)
failure
C.NicePragma{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceRecSig{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceDataSig{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceFunClause{} -> TCMT IO (Maybe TypedBinding)
failure
C.FunSig{} -> TCMT IO (Maybe TypedBinding)
failure
C.FunDef{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceDataDef{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceRecDef{} -> TCMT IO (Maybe TypedBinding)
failure
C.NicePatternSyn{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceGeneralize{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceUnquoteDecl{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceUnquoteDef{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceUnquoteData{} -> TCMT IO (Maybe TypedBinding)
failure
C.NiceOpaque{} -> TCMT IO (Maybe TypedBinding)
failure
checkModuleApplication
:: C.ModuleApplication
-> ModuleName
-> C.Name
-> C.ImportDirective
-> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)
checkModuleApplication :: ModuleApplication
-> ModuleName
-> Name
-> ImportDirective
-> ScopeM (ModuleApplication, ScopeCopyInfo, ImportDirective)
checkModuleApplication (C.SectionApp Range
_ Telescope
tel Expr
e) ModuleName
m0 Name
x ImportDirective
dir' = do
[Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking ModuleApplication " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
]
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
(m, args) <- Expr -> ScopeM (QName, [NamedArg Expr])
parseModuleApplication Expr
e
tel' <- catMaybes <$> toAbstract tel
m1 <- toAbstract $ OldModuleName m
args' <- toAbstractCtx (ArgumentCtx PreferParen) args
(adir, s) <- applyImportDirectiveM (C.QName x) dir' =<< getNamedScope m1
(s', copyInfo) <- copyScope m m0 s
modifyCurrentScope $ const s'
printScope "mod.inst" 20 "copied source module"
reportSDoc "scope.mod.inst" 30 $ return $ pretty copyInfo
let amodapp = [TypedBinding]
-> ModuleName -> [NamedArg Expr] -> ModuleApplication
A.SectionApp [TypedBinding]
tel' ModuleName
m1 [NamedArg Expr]
args'
reportSDoc "scope.decl" 70 $ vcat $
[ text $ "scope checked ModuleApplication " ++ prettyShow x
]
reportSDoc "scope.decl" 70 $ vcat $
[ nest 2 $ prettyA amodapp
]
return (amodapp, copyInfo, 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
m1 <- OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldModuleName -> ScopeM (AbsOfCon OldModuleName))
-> OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall a b. (a -> b) -> a -> b
$ QName -> OldModuleName
OldModuleName QName
recN
s <- getNamedScope m1
(adir, s) <- applyImportDirectiveM recN dir' s
(s', copyInfo) <- copyScope recN m0 s
modifyCurrentScope $ const s'
printScope "mod.inst" 20 "copied record module"
return (A.RecordModuleInstance m1, copyInfo, adir)
checkModuleMacro
:: (ToConcrete a, Pretty (ConOfAbs a))
=> (ModuleInfo
-> Erased
-> ModuleName
-> A.ModuleApplication
-> ScopeCopyInfo
-> A.ImportDirective
-> a)
-> OpenKind
-> Range
-> Access
-> Erased
-> C.Name
-> C.ModuleApplication
-> OpenShortHand
-> C.ImportDirective
-> ScopeM a
checkModuleMacro :: forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a
apply OpenKind
kind Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir = do
[Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking ModuleMacro " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
]
dir <- OpenShortHand -> ImportDirective -> ScopeM ImportDirective
notPublicWithoutOpen OpenShortHand
open ImportDirective
dir
m0 <- toAbstract (NewModuleName x)
reportSDoc "scope.decl" 90 $ "NewModuleName: m0 =" <+> prettyA m0
printScope "mod.inst" 20 "module macro"
let (moduleDir, openDir) = case (open, isNoName x) of
(OpenShortHand
DoOpen, Bool
False) -> (ImportDirective
forall n m. ImportDirective' n m
defaultImportDir, ImportDirective
dir)
(OpenShortHand
DoOpen, Bool
True) -> ( ImportDirective
dir { publicOpen = Nothing }
, ImportDirective
forall n m. ImportDirective' n m
defaultImportDir { publicOpen = publicOpen dir }
)
(OpenShortHand
DontOpen, Bool
_) -> (ImportDirective
dir, ImportDirective
forall n m. ImportDirective' n m
defaultImportDir)
(modapp', copyInfo, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir
printScope "mod.inst.app" 20 "checkModuleMacro, after checkModuleApplication"
reportSDoc "scope.decl" 90 $ "after mod app: trying to print m0 ..."
reportSDoc "scope.decl" 90 $ "after mod app: m0 =" <+> prettyA m0
bindModule p x m0
reportSDoc "scope.decl" 90 $ "after bindMod: m0 =" <+> prettyA m0
printScope "mod.inst.copy.after" 20 "after copying"
adir <- case open of
OpenShortHand
DontOpen -> ImportDirective -> TCMT IO ImportDirective
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
adir'
OpenShortHand
DoOpen -> do
adir'' <- OpenKind
-> Maybe ModuleName
-> QName
-> ImportDirective
-> TCMT IO ImportDirective
openModule OpenKind
kind (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m0) (Name -> QName
C.QName Name
x) ImportDirective
openDir
return $ if isNoName x then adir' else adir''
printScope "mod.inst" 20 $ show open
reportSDoc "scope.decl" 90 $ "after open : m0 =" <+> prettyA m0
stripNoNames
printScope "mod.inst" 10 $ "after stripping"
reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0
let m = ModuleName
m0 ModuleName -> List1 Name -> ModuleName
`withRangesOf` Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
x
adecl = ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a
apply ModuleInfo
info Erased
e ModuleName
m ModuleApplication
modapp' ScopeCopyInfo
copyInfo ImportDirective
adir
reportSDoc "scope.decl" 70 $ vcat $
[ text $ "scope checked ModuleMacro " ++ prettyShow x
]
reportSLn "scope.decl" 90 $ "info = " ++ show info
reportSLn "scope.decl" 90 $ "m = " ++ prettyShow m
reportSLn "scope.decl" 90 $ "modapp' = " ++ show modapp'
reportSDoc "scope.decl" 90 $ return $ pretty copyInfo
reportSDoc "scope.decl" 70 $ nest 2 $ prettyA adecl
return adecl
where
info :: ModuleInfo
info = ModuleInfo
{ minfoRange :: Range
minfoRange = Range
r
, minfoAsName :: Maybe Name
minfoAsName = Maybe Name
forall a. Maybe a
Nothing
, minfoAsTo :: Range
minfoAsTo = ImportDirective -> Range
renamingRange ImportDirective
dir
, minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = OpenShortHand -> Maybe OpenShortHand
forall a. a -> Maybe a
Just OpenShortHand
open
, minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dir
}
notPublicWithoutOpen :: OpenShortHand -> C.ImportDirective -> ScopeM C.ImportDirective
notPublicWithoutOpen :: OpenShortHand -> ImportDirective -> ScopeM ImportDirective
notPublicWithoutOpen OpenShortHand
DoOpen ImportDirective
dir = ImportDirective -> ScopeM ImportDirective
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDirective
dir
notPublicWithoutOpen OpenShortHand
DontOpen ImportDirective
dir = do
Maybe KwRange -> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe KwRange
forall n m. ImportDirective' n m -> Maybe KwRange
publicOpen ImportDirective
dir) ((KwRange -> TCMT IO ()) -> TCMT IO ())
-> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ KwRange
r ->
KwRange -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange KwRange
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
ImportDirective -> ScopeM ImportDirective
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportDirective -> ScopeM ImportDirective)
-> ImportDirective -> ScopeM ImportDirective
forall a b. (a -> b) -> a -> b
$ ImportDirective
dir { publicOpen = Nothing }
renamingRange :: C.ImportDirective -> Range
renamingRange :: ImportDirective -> Range
renamingRange = [Range] -> Range
forall a. HasRange a => a -> Range
getRange ([Range] -> Range)
-> (ImportDirective -> [Range]) -> ImportDirective -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Renaming' Name Name -> Range) -> [Renaming' Name Name] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Renaming' Name Name -> Range
forall n m. Renaming' n m -> Range
renToRange ([Renaming' Name Name] -> [Range])
-> (ImportDirective -> [Renaming' Name Name])
-> ImportDirective
-> [Range]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDirective -> [Renaming' Name Name]
forall n m. ImportDirective' n m -> RenamingDirective' n m
impRenaming
checkOpen
:: Range
-> Maybe A.ModuleName
-> C.QName
-> C.ImportDirective
-> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective)
checkOpen :: Range
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
checkOpen Range
r Maybe ModuleName
mam QName
x ImportDirective
dir = do
[Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
cm <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
vcat $
[ text "scope checking NiceOpen " <> return (pretty x)
, text " getCurrentModule = " <> prettyA cm
, text $ " getCurrentModule (raw) = " ++ show cm
, text $ " C.ImportDirective = " ++ prettyShow dir
]
Maybe KwRange -> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe KwRange
forall n m. ImportDirective' n m -> Maybe KwRange
publicOpen ImportDirective
dir) ((KwRange -> TCMT IO ()) -> TCMT IO ())
-> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ KwRange
r -> do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((ModuleName
A.noModuleName ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ModuleName -> Bool) -> TCMT IO ModuleName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
KwRange -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange KwRange
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
m <- Maybe ModuleName
-> TCMT IO ModuleName
-> (ModuleName -> TCMT IO ModuleName)
-> TCMT IO ModuleName
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ModuleName
mam (OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
x)) ModuleName -> TCMT IO ModuleName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
printScope "open" 20 $ "opening " ++ prettyShow x
adir <- openModule TopOpenModule (Just m) x dir
printScope "open" 20 $ "result:"
let minfo = ModuleInfo
{ minfoRange :: Range
minfoRange = Range
r
, minfoAsName :: Maybe Name
minfoAsName = Maybe Name
forall a. Maybe a
Nothing
, minfoAsTo :: Range
minfoAsTo = ImportDirective -> Range
renamingRange ImportDirective
dir
, minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = Maybe OpenShortHand
forall a. Maybe a
Nothing
, minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dir
}
let adecls = [ModuleInfo -> ModuleName -> ImportDirective -> Declaration
A.Open ModuleInfo
minfo ModuleName
m ImportDirective
adir]
reportSDoc "scope.decl" 70 $ vcat $
text ( "scope checked NiceOpen " ++ prettyShow x
) : map (nest 2 . prettyA) adecls
return (minfo, m, adir)
checkLiteral :: Literal -> ScopeM ()
checkLiteral :: Literal -> TCMT IO ()
checkLiteral = \case
LitChar Char
c -> Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> Bool
isSurrogateCodePoint Char
c) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Warning
InvalidCharacterLiteral Char
c
LitNat Integer
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LitWord64 Word64
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LitFloat Double
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LitString Text
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LitQName QName
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LitMeta TopLevelModuleName' Range
_ MetaId
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)
concreteToAbstract_ :: forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
concreteToAbstract_ = c -> ScopeM (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)
concreteToAbstract :: forall c. ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)
concreteToAbstract ScopeInfo
scope c
x = ScopeInfo -> TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c)
forall (m :: * -> *) a. ReadTCState m => ScopeInfo -> m a -> m a
withScope_ ScopeInfo
scope (c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
x)
class ToAbstract c where
type AbsOfCon c
toAbstract :: c -> ScopeM (AbsOfCon c)
toAbstractCtx :: ToAbstract c => Precedence -> c-> ScopeM (AbsOfCon c)
toAbstractCtx :: forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
ctx c
c = Precedence -> TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c)
forall (m :: * -> *) a. ReadTCState m => Precedence -> m a -> m a
withContextPrecedence Precedence
ctx (TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (AbsOfCon c)
forall a b. (a -> b) -> a -> b
$ c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c
c
toAbstractHiding :: (LensHiding h, ToAbstract c) => h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding :: forall h c.
(LensHiding h, ToAbstract c) =>
h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding h
h | h -> Bool
forall a. LensHiding a => a -> Bool
visible h
h = c -> ScopeM (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
toAbstractHiding h
_ = Precedence -> c -> ScopeM (AbsOfCon c)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx
localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract :: forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract c
x AbsOfCon c -> ScopeM b
ret = (b, ScopeInfo) -> b
forall a b. (a, b) -> a
fst ((b, ScopeInfo) -> b) -> TCMT IO (b, ScopeInfo) -> ScopeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> (AbsOfCon c -> ScopeM b) -> TCMT IO (b, ScopeInfo)
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' c
x AbsOfCon c -> ScopeM b
ret
localToAbstract' :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' :: forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)
localToAbstract' c
x AbsOfCon c -> ScopeM b
ret = do
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
withScope scope $ ret =<< toAbstract x
instance ToAbstract () where
type AbsOfCon () = ()
toAbstract :: () -> ScopeM (AbsOfCon ())
toAbstract = () -> TCMT IO ()
() -> ScopeM (AbsOfCon ())
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance (ToAbstract c1, ToAbstract c2) => ToAbstract (c1, c2) where
type AbsOfCon (c1, c2) = (AbsOfCon c1, AbsOfCon c2)
toAbstract :: (c1, c2) -> ScopeM (AbsOfCon (c1, c2))
toAbstract (c1
x,c2
y) = (,) (AbsOfCon c1 -> AbsOfCon c2 -> (AbsOfCon c1, AbsOfCon c2))
-> TCMT IO (AbsOfCon c1)
-> TCMT IO (AbsOfCon c2 -> (AbsOfCon c1, AbsOfCon c2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c1 -> TCMT IO (AbsOfCon c1)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c1
x TCMT IO (AbsOfCon c2 -> (AbsOfCon c1, AbsOfCon c2))
-> TCMT IO (AbsOfCon c2) -> TCMT IO (AbsOfCon c1, AbsOfCon c2)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c2 -> TCMT IO (AbsOfCon c2)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c2
y
instance (ToAbstract c1, ToAbstract c2, ToAbstract c3) => ToAbstract (c1, c2, c3) where
type AbsOfCon (c1, c2, c3) = (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)
toAbstract :: (c1, c2, c3) -> ScopeM (AbsOfCon (c1, c2, c3))
toAbstract (c1
x,c2
y,c3
z) = (AbsOfCon c1, (AbsOfCon c2, AbsOfCon c3))
-> (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)
forall {a} {b} {c}. (a, (b, c)) -> (a, b, c)
flatten ((AbsOfCon c1, (AbsOfCon c2, AbsOfCon c3))
-> (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3))
-> TCMT IO (AbsOfCon c1, (AbsOfCon c2, AbsOfCon c3))
-> TCMT IO (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (c1, (c2, c3)) -> ScopeM (AbsOfCon (c1, (c2, c3)))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (c1
x,(c2
y,c3
z))
where
flatten :: (a, (b, c)) -> (a, b, c)
flatten (a
x,(b
y,c
z)) = (a
x,b
y,c
z)
instance ToAbstract c => ToAbstract [c] where
type AbsOfCon [c] = [AbsOfCon c]
toAbstract :: [c] -> ScopeM (AbsOfCon [c])
toAbstract = (c -> TCMT IO (AbsOfCon c)) -> [c] -> TCMT IO [AbsOfCon c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
instance ToAbstract c => ToAbstract (List1 c) where
type AbsOfCon (List1 c) = List1 (AbsOfCon c)
toAbstract :: List1 c -> ScopeM (AbsOfCon (List1 c))
toAbstract = (c -> TCMT IO (AbsOfCon c))
-> List1 c -> TCMT IO (NonEmpty (AbsOfCon c))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
instance (ToAbstract c1, ToAbstract c2) => ToAbstract (Either c1 c2) where
type AbsOfCon (Either c1 c2) = Either (AbsOfCon c1) (AbsOfCon c2)
toAbstract :: Either c1 c2 -> ScopeM (AbsOfCon (Either c1 c2))
toAbstract = (c1 -> TCMT IO (AbsOfCon c1))
-> (c2 -> TCMT IO (AbsOfCon c2))
-> Either c1 c2
-> TCMT IO (Either (AbsOfCon c1) (AbsOfCon c2))
forall (f :: * -> *) a c b d.
Functor f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
traverseEither c1 -> TCMT IO (AbsOfCon c1)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract c2 -> TCMT IO (AbsOfCon c2)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
instance ToAbstract c => ToAbstract (Maybe c) where
type AbsOfCon (Maybe c) = Maybe (AbsOfCon c)
toAbstract :: Maybe c -> ScopeM (AbsOfCon (Maybe c))
toAbstract = (c -> TCMT IO (AbsOfCon c))
-> Maybe c -> TCMT IO (Maybe (AbsOfCon c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
data NewName a = NewName
{ forall a. NewName a -> BindingSource
newBinder :: A.BindingSource
, forall a. NewName a -> a
newName :: a
} deriving ((forall a b. (a -> b) -> NewName a -> NewName b)
-> (forall a b. a -> NewName b -> NewName a) -> Functor NewName
forall a b. a -> NewName b -> NewName a
forall a b. (a -> b) -> NewName a -> NewName b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NewName a -> NewName b
fmap :: forall a b. (a -> b) -> NewName a -> NewName b
$c<$ :: forall a b. a -> NewName b -> NewName a
<$ :: forall a b. a -> NewName b -> NewName a
Functor)
data OldQName = OldQName
C.QName
(Maybe (Set A.Name))
data MaybeOldQName = MaybeOldQName OldQName
newtype OldName a = OldName a
data ResolveQName = ResolveQName C.QName
data PatName = PatName C.QName (Maybe (Set A.Name)) Hiding
instance ToAbstract (NewName C.Name) where
type AbsOfCon (NewName C.Name) = A.Name
toAbstract :: NewName Name -> ScopeM (AbsOfCon (NewName Name))
toAbstract (NewName BindingSource
b Name
x) = do
y <- Name -> ScopeM Name
freshAbstractName_ Name
x
bindVariable b x y
return y
instance ToAbstract (NewName C.BoundName) where
type AbsOfCon (NewName C.BoundName) = A.BindName
toAbstract :: NewName BoundName -> ScopeM (AbsOfCon (NewName BoundName))
toAbstract NewName{ newBinder :: forall a. NewName a -> BindingSource
newBinder = BindingSource
b, newName :: forall a. NewName a -> a
newName = BName{ boundName :: BoundName -> Name
boundName = Name
x, bnameFixity :: BoundName -> Fixity'
bnameFixity = Fixity'
fx }} = do
y <- Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
fx Name
x
bindVariable b x y
return $ A.BindName y
instance ToAbstract OldQName where
type AbsOfCon OldQName = A.Expr
toAbstract :: OldQName -> ScopeM (AbsOfCon OldQName)
toAbstract q :: OldQName
q@(OldQName QName
x Maybe (Set Name)
_) =
ScopeM (AbsOfCon OldQName)
-> TCMT IO (Maybe (AbsOfCon OldQName))
-> ScopeM (AbsOfCon OldQName)
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM (QName -> ScopeM Expr
forall a. QName -> TCM a
notInScopeError QName
x) (TCMT IO (Maybe (AbsOfCon OldQName)) -> ScopeM (AbsOfCon OldQName))
-> TCMT IO (Maybe (AbsOfCon OldQName))
-> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> MaybeOldQName
MaybeOldQName OldQName
q)
instance ToAbstract MaybeOldQName where
type AbsOfCon MaybeOldQName = Maybe A.Expr
toAbstract :: MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
toAbstract (MaybeOldQName (OldQName QName
x Maybe (Set Name)
ns)) = do
qx <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' KindsOfNames
allKindsOfNames Maybe (Set Name)
ns QName
x
reportSLn "scope.name" 10 $ "resolved " ++ prettyShow x ++ ": " ++ prettyShow qx
case qx of
VarName Name
x' BindingSource
_ -> Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> TCMT IO (Maybe Expr))
-> Maybe Expr -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Name -> Expr
A.Var Name
x'
DefinedName Access
_ AbstractName
d Suffix
suffix -> do
QName -> TCMT IO ()
forall (m :: * -> *).
(MonadWarning m, ReadTCState m) =>
QName -> m ()
raiseWarningsOnUsage (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
case AbstractName -> KindOfName
anameKind AbstractName
d of
KindOfName
GeneralizeName -> do
gvs <- Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars
case gvs of
Just Set QName
s -> (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars Lens' TCState (Maybe (Set QName))
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> a -> m ()
`setTCLens` Set QName -> Maybe (Set QName)
forall a. a -> Maybe a
Just (Set QName
s Set QName -> Set QName -> Set QName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` QName -> Set QName
forall a. a -> Set a
Set.singleton (AbstractName -> QName
anameName AbstractName
d))
Maybe (Set QName)
Nothing -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
GeneralizeNotSupportedHere (QName -> TypeError) -> QName -> TypeError
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
KindOfName
DisallowedGeneralizeName -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
GeneralizedVarInLetOpenedModule (QName -> TypeError) -> QName -> TypeError
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
KindOfName
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> TCMT IO (Maybe Expr))
-> Maybe Expr -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Suffix -> Expr -> Maybe Expr
withSuffix Suffix
suffix (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ AbstractName -> Expr
forall a. NameToExpr a => a -> Expr
nameToExpr AbstractName
d
where
withSuffix :: Suffix -> Expr -> Maybe Expr
withSuffix Suffix
NoSuffix Expr
e = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
withSuffix s :: Suffix
s@Suffix{} (A.Def QName
x) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ QName -> Suffix -> Expr
A.Def' QName
x Suffix
s
withSuffix Suffix
_ Expr
_ = Maybe Expr
forall a. Maybe a
Nothing
FieldName List1 AbstractName
ds -> (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous (ProjOrigin -> AmbiguousQName -> Expr
A.Proj ProjOrigin
ProjPrefix) List1 AbstractName
ds
ConstructorName Set Induction
_ List1 AbstractName
ds -> (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous AmbiguousQName -> Expr
A.Con List1 AbstractName
ds
PatternSynResName List1 AbstractName
ds -> (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous AmbiguousQName -> Expr
A.PatternSyn List1 AbstractName
ds
ResolvedName
UnknownName -> Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Expr
forall a. Maybe a
Nothing
where
ambiguous :: (AmbiguousQName -> A.Expr) -> List1 AbstractName -> ScopeM (Maybe A.Expr)
ambiguous :: (AmbiguousQName -> Expr)
-> List1 AbstractName -> TCMT IO (Maybe Expr)
ambiguous AmbiguousQName -> Expr
f List1 AbstractName
ds = do
let xs :: NonEmpty QName
xs = (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds
NonEmpty QName -> TCMT IO ()
raiseWarningsOnUsageIfUnambiguous NonEmpty QName
xs
Maybe Expr -> TCMT IO (Maybe Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Expr -> TCMT IO (Maybe Expr))
-> Maybe Expr -> TCMT IO (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> Expr
f (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ NonEmpty QName
xs
raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM ()
raiseWarningsOnUsageIfUnambiguous :: NonEmpty QName -> TCMT IO ()
raiseWarningsOnUsageIfUnambiguous = \case
QName
x :| [] -> QName -> TCMT IO ()
forall (m :: * -> *).
(MonadWarning m, ReadTCState m) =>
QName -> m ()
raiseWarningsOnUsage QName
x
NonEmpty QName
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance ToAbstract ResolveQName where
type AbsOfCon ResolveQName = ResolvedName
toAbstract :: ResolveQName -> ScopeM (AbsOfCon ResolveQName)
toAbstract (ResolveQName QName
x) = QName -> ScopeM ResolvedName
resolveName QName
x ScopeM ResolvedName
-> (ResolvedName -> ScopeM ResolvedName) -> ScopeM ResolvedName
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ResolvedName
UnknownName -> QName -> ScopeM ResolvedName
forall a. QName -> TCM a
notInScopeError QName
x
ResolvedName
q -> ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
q
data APatName = VarPatName A.Name
| ConPatName (List1 AbstractName)
| PatternSynPatName (List1 AbstractName)
instance ToAbstract PatName where
type AbsOfCon PatName = APatName
toAbstract :: PatName -> ScopeM (AbsOfCon PatName)
toAbstract (PatName QName
x Maybe (Set Name)
ns Hiding
h) = do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"checking pattern name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
rx <- KindsOfNames -> Maybe (Set Name) -> QName -> ScopeM ResolvedName
resolveName' ([KindOfName] -> KindsOfNames
someKindsOfNames [KindOfName
ConName, KindOfName
CoConName, KindOfName
PatternSynName]) Maybe (Set Name)
ns QName
x
reportSLn "scope.pat" 20 $ "resolved as " ++ prettyShow rx
case rx of
ConstructorName Set Induction
_ List1 AbstractName
ds -> List1 AbstractName -> APatName
ConPatName List1 AbstractName
ds APatName -> TCMT IO () -> TCMT IO APatName
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a con: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
PatternSynResName List1 AbstractName
ds -> List1 AbstractName -> APatName
PatternSynPatName List1 AbstractName
ds APatName -> TCMT IO () -> TCMT IO APatName
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a pat syn: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
ResolvedName
_ -> case QName
x of
C.QName Name
y -> Name -> APatName
VarPatName (Name -> APatName) -> ScopeM Name -> TCMT IO APatName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hiding -> Name -> ScopeM Name
bindPatternVariable Hiding
h Name
y
C.Qual{} -> TypeError -> TCMT IO APatName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO APatName) -> TypeError -> TCMT IO APatName
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
InvalidPattern (Pattern -> TypeError) -> Pattern -> TypeError
forall a b. (a -> b) -> a -> b
$ Bool -> QName -> Pattern
C.IdentP Bool
True QName
x
bindPatternVariable :: Hiding -> C.Name -> ScopeM A.Name
bindPatternVariable :: Hiding -> Name -> ScopeM Name
bindPatternVariable Hiding
h Name
x = do
y <- (Name -> [(Name, LocalVar)] -> Maybe LocalVar
forall a b. Eq a => a -> [(a, b)] -> Maybe b
AssocList.lookup Name
x ([(Name, LocalVar)] -> Maybe LocalVar)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO (Maybe LocalVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [(Name, LocalVar)]
getVarsToBind) TCMT IO (Maybe LocalVar)
-> (Maybe LocalVar -> ScopeM Name) -> ScopeM Name
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (LocalVar Name
y BindingSource
_ [AbstractName]
_) -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a old var: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
Name -> ScopeM Name
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> ScopeM Name) -> Name -> ScopeM Name
forall a b. (a -> b) -> a -> b
$ Range -> Name -> Name
forall a. SetRange a => Range -> a -> a
setRange (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Name
y
Maybe LocalVar
Nothing -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"it was a new var: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
Name -> ScopeM Name
freshAbstractName_ Name
x
addVarToBind x $ LocalVar y (PatternBound h) []
return 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
instance ToQName a => ToAbstract (OldName a) where
type AbsOfCon (OldName a) = A.QName
toAbstract :: OldName a -> ScopeM (AbsOfCon (OldName a))
toAbstract (OldName a
x) = do
rx <- QName -> ScopeM ResolvedName
resolveName (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
case rx of
DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
DefinedName Access
_ AbstractName
d Suffix{} -> QName -> TCMT IO QName
forall a. QName -> TCM a
notInScopeError (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
ConstructorName Set Induction
_ List1 AbstractName
ds -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
FieldName List1 AbstractName
ds -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
PatternSynResName List1 AbstractName
ds -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> TCMT IO QName) -> QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds)
VarName Name
x BindingSource
_ -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Not a defined name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
ResolvedName
UnknownName -> QName -> TCMT IO QName
forall a. QName -> TCM a
notInScopeError (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
toAbstractExistingName :: ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName :: forall a. ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName a
x = QName -> ScopeM ResolvedName
resolveName (a -> QName
forall a. ToQName a => a -> QName
toQName a
x) ScopeM ResolvedName
-> (ResolvedName -> ScopeM (List1 AbstractName))
-> ScopeM (List1 AbstractName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (List1 AbstractName -> ScopeM (List1 AbstractName))
-> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> List1 AbstractName
forall el coll. Singleton el coll => el -> coll
singleton AbstractName
d
DefinedName Access
_ AbstractName
d Suffix{} -> QName -> ScopeM (List1 AbstractName)
forall a. QName -> TCM a
notInScopeError (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
ConstructorName Set Induction
_ List1 AbstractName
ds -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
FieldName List1 AbstractName
ds -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
PatternSynResName List1 AbstractName
ds -> List1 AbstractName -> ScopeM (List1 AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return List1 AbstractName
ds
VarName Name
x BindingSource
_ -> [Char] -> ScopeM (List1 AbstractName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM (List1 AbstractName))
-> [Char] -> ScopeM (List1 AbstractName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Not a defined name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
ResolvedName
UnknownName -> QName -> ScopeM (List1 AbstractName)
forall a. QName -> TCM a
notInScopeError (a -> QName
forall a. ToQName a => a -> QName
toQName a
x)
newtype NewModuleName = NewModuleName C.Name
newtype NewModuleQName = NewModuleQName C.QName
newtype OldModuleName = OldModuleName C.QName
freshQModule :: A.ModuleName -> C.Name -> ScopeM A.ModuleName
freshQModule :: ModuleName -> Name -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x = ModuleName -> ModuleName -> ModuleName
A.qualifyM ModuleName
m (ModuleName -> ModuleName)
-> (Name -> ModuleName) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Name -> ModuleName
mnameFromList1 (List1 Name -> ModuleName)
-> (Name -> List1 Name) -> Name -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton (Name -> ModuleName) -> ScopeM Name -> TCMT IO ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ScopeM Name
freshAbstractName_ Name
x
checkForModuleClash :: C.Name -> ScopeM ()
checkForModuleClash :: Name -> TCMT IO ()
checkForModuleClash Name
x = do
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
unless (null ms) $ do
reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ prettyShow ms
reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms
setCurrentRange x $
typeError $ ShadowedModule x $
map ((`withRangeOf` x) . amodName) ms
instance ToAbstract NewModuleName where
type AbsOfCon NewModuleName = A.ModuleName
toAbstract :: NewModuleName -> ScopeM (AbsOfCon NewModuleName)
toAbstract (NewModuleName Name
x) = do
Name -> TCMT IO ()
checkForModuleClash Name
x
m <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
y <- freshQModule m x
createModule Nothing y
return y
instance ToAbstract NewModuleQName where
type AbsOfCon NewModuleQName = A.ModuleName
toAbstract :: NewModuleQName -> ScopeM (AbsOfCon NewModuleQName)
toAbstract (NewModuleQName QName
m) = ModuleName -> QName -> TCMT IO ModuleName
toAbs ModuleName
noModuleName QName
m
where
toAbs :: ModuleName -> QName -> TCMT IO ModuleName
toAbs ModuleName
m (C.QName Name
x) = do
y <- ModuleName -> Name -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x
createModule Nothing y
return y
toAbs ModuleName
m (C.Qual Name
x QName
q) = do
m' <- ModuleName -> Name -> TCMT IO ModuleName
freshQModule ModuleName
m Name
x
toAbs m' q
instance ToAbstract OldModuleName where
type AbsOfCon OldModuleName = A.ModuleName
toAbstract :: OldModuleName -> ScopeM (AbsOfCon OldModuleName)
toAbstract (OldModuleName QName
q) = QName
-> ScopeM (AbsOfCon OldModuleName)
-> ScopeM (AbsOfCon OldModuleName)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
q (ScopeM (AbsOfCon OldModuleName)
-> ScopeM (AbsOfCon OldModuleName))
-> ScopeM (AbsOfCon OldModuleName)
-> ScopeM (AbsOfCon OldModuleName)
forall a b. (a -> b) -> a -> b
$ do
AbstractModule -> ModuleName
amodName (AbstractModule -> ModuleName)
-> TCMT IO AbstractModule -> TCMT IO ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO AbstractModule
resolveModule QName
q
mkArg' :: ArgInfo -> C.Expr -> Arg C.Expr
mkArg' :: ArgInfo -> Expr -> Arg Expr
mkArg' ArgInfo
info (C.HiddenArg Range
_ Named NamedName Expr
e) = ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (ArgInfo -> ArgInfo
forall a. LensHiding a => a -> a
hide ArgInfo
info) (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Named NamedName Expr -> Expr
forall name a. Named name a -> a
namedThing Named NamedName Expr
e
mkArg' ArgInfo
info (C.InstanceArg Range
_ Named NamedName Expr
e) = ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (ArgInfo -> ArgInfo
forall a. LensHiding a => a -> a
makeInstance ArgInfo
info) (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Named NamedName Expr -> Expr
forall name a. Named name a -> a
namedThing Named NamedName Expr
e
mkArg' ArgInfo
info Expr
e = ArgInfo -> Expr -> Arg Expr
forall e. ArgInfo -> e -> Arg e
Arg (Hiding -> ArgInfo -> ArgInfo
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
NotHidden ArgInfo
info) Expr
e
inferParenPreference :: C.Expr -> ParenPreference
inferParenPreference :: Expr -> ParenPreference
inferParenPreference C.Paren{} = ParenPreference
PreferParen
inferParenPreference Expr
_ = ParenPreference
PreferParenless
toAbstractDotHiding :: Maybe Relevance -> Maybe Hiding -> Precedence -> C.Expr -> ScopeM (A.Expr, Relevance, Hiding)
toAbstractDotHiding :: Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
prec Expr
e = do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.irrelevance" Int
100 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"toAbstractDotHiding: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Doc a -> [Char]
render (Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e)
Call
-> ScopeM (Expr, Relevance, Hiding)
-> ScopeM (Expr, Relevance, Hiding)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) (ScopeM (Expr, Relevance, Hiding)
-> ScopeM (Expr, Relevance, Hiding))
-> ScopeM (Expr, Relevance, Hiding)
-> ScopeM (Expr, Relevance, Hiding)
forall a b. (a -> b) -> a -> b
$ case Expr
e of
C.RawApp Range
_ List2 Expr
es -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
prec (Expr -> ScopeM (Expr, Relevance, Hiding))
-> TCMT IO Expr -> ScopeM (Expr, Relevance, Hiding)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< List2 Expr -> TCMT IO Expr
parseApplication List2 Expr
es
C.Paren Range
_ Expr
e -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
TopCtx Expr
e
C.Dot Range
_ Expr
e
| Maybe Relevance
Nothing <- Maybe Relevance
mr -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding (Relevance -> Maybe Relevance
forall a. a -> Maybe a
Just Relevance
Irrelevant) Maybe Hiding
mh Precedence
prec Expr
e
C.DoubleDot Range
_ Expr
e
| Maybe Relevance
Nothing <- Maybe Relevance
mr -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding (Relevance -> Maybe Relevance
forall a. a -> Maybe a
Just Relevance
NonStrict) Maybe Hiding
mh Precedence
prec Expr
e
C.HiddenArg Range
_ (Named Maybe NamedName
Nothing Expr
e)
| Maybe Hiding
Nothing <- Maybe Hiding
mh -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr (Hiding -> Maybe Hiding
forall a. a -> Maybe a
Just Hiding
Hidden) Precedence
TopCtx Expr
e
C.InstanceArg Range
_ (Named Maybe NamedName
Nothing Expr
e)
| Maybe Hiding
Nothing <- Maybe Hiding
mh -> Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr (Hiding -> Maybe Hiding
forall a. a -> Maybe a
Just (Hiding -> Maybe Hiding) -> Hiding -> Maybe Hiding
forall a b. (a -> b) -> a -> b
$ Overlappable -> Hiding
Instance Overlappable
NoOverlap) Precedence
TopCtx Expr
e
Expr
e -> (, Relevance -> Maybe Relevance -> Relevance
forall a. a -> Maybe a -> a
fromMaybe Relevance
Relevant Maybe Relevance
mr, Hiding -> Maybe Hiding -> Hiding
forall a. a -> Maybe a -> a
fromMaybe Hiding
NotHidden Maybe Hiding
mh) (Expr -> (Expr, Relevance, Hiding))
-> ScopeM Expr -> ScopeM (Expr, Relevance, Hiding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
prec Expr
e
toAbstractLam :: Range -> List1 C.LamBinding -> C.Expr -> Precedence -> ScopeM A.Expr
toAbstractLam :: Range
-> NonEmpty (LamBinding' TypedBinding)
-> Expr
-> Precedence
-> ScopeM Expr
toAbstractLam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e Precedence
ctx = do
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
localToAbstract (fmap (C.DomainFull . makeDomainFull) bs) $ \ AbsOfCon (NonEmpty (LamBinding' TypedBinding))
bs -> do
lvars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
checkNoShadowing lvars0 lvars1
e <- toAbstractCtx ctx e
return $ case List1.catMaybes bs of
[] -> Expr
e
LamBinding
b:[LamBinding]
bs -> ExprInfo -> LamBinding -> Expr -> Expr
A.Lam (Range -> ExprInfo
ExprRange Range
r) LamBinding
b (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (LamBinding -> Expr -> Expr) -> Expr -> [LamBinding] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LamBinding -> Expr -> Expr
mkLam Expr
e [LamBinding]
bs
where
mkLam :: LamBinding -> Expr -> Expr
mkLam LamBinding
b Expr
e = ExprInfo -> LamBinding -> Expr -> Expr
A.Lam (Range -> ExprInfo
ExprRange (Range -> ExprInfo) -> Range -> ExprInfo
forall a b. (a -> b) -> a -> b
$ LamBinding -> Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange LamBinding
b Expr
e) LamBinding
b Expr
e
scopeCheckExtendedLam ::
Range -> Erased -> List1 C.LamClause -> ScopeM A.Expr
scopeCheckExtendedLam :: Range -> Erased -> List1 LamClause -> ScopeM Expr
scopeCheckExtendedLam Range
r Erased
e List1 LamClause
cs = do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM TCMT IO Bool
isInsideDotPattern (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Extended lambdas are not allowed in dot patterns"
cname <- Range -> Int -> [Char] -> ScopeM Name
freshConcreteName Range
r Int
0 [Char]
extendedLambdaName
name <- freshAbstractName_ cname
a <- asksTC (^. lensIsAbstract)
reportSDoc "scope.extendedLambda" 10 $ vcat
[ text $ "new extended lambda name (" ++ show a ++ "): " ++ prettyShow name
]
verboseS "scope.extendedLambda" 60 $ do
forM_ cs $ \ LamClause
c -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.extendedLambda" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"extended lambda lhs: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Pattern] -> [Char]
forall a. Show a => a -> [Char]
show (LamClause -> [Pattern]
C.lamLHS LamClause
c)
qname <- qualifyName_ name
bindName privateAccessInserted FunName cname qname
d <- C.FunDef r [] a NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ cname . List1.toList <$> do
forM cs $ \ (LamClause [Pattern]
ps RHS' Expr
rhs Bool
ca) -> do
let p :: Pattern
p = List1 Pattern -> Pattern
C.rawAppP (List1 Pattern -> Pattern) -> List1 Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$
KillRangeT Pattern
forall a. KillRange a => KillRangeT a
killRange (Bool -> QName -> Pattern
IdentP Bool
True (QName -> Pattern) -> QName -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName Name
cname) Pattern -> [Pattern] -> List1 Pattern
forall a. a -> [a] -> NonEmpty a
:| [Pattern]
ps
let lhs :: LHS
lhs = Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS Pattern
p [] []
Clause -> TCMT IO Clause
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> TCMT IO Clause) -> Clause -> TCMT IO Clause
forall a b. (a -> b) -> a -> b
$ Name
-> Bool
-> LHS
-> RHS' Expr
-> WhereClause' [Declaration]
-> [Clause]
-> Clause
C.Clause Name
cname Bool
ca LHS
lhs RHS' Expr
rhs WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere []
scdef <- toAbstract d
case scdef of
A.ScopedDecl ScopeInfo
si [A.FunDef DefInfo
di QName
qname' [Clause]
cs] -> do
ScopeInfo -> TCMT IO ()
setScope ScopeInfo
si
Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$
ExprInfo -> DefInfo -> Erased -> QName -> List1 Clause -> Expr
A.ExtendedLam (Range -> ExprInfo
ExprRange Range
r) DefInfo
di Erased
e QName
qname' (List1 Clause -> Expr) -> List1 Clause -> Expr
forall a b. (a -> b) -> a -> b
$
List1 Clause -> [Clause] -> List1 Clause
forall a. List1 a -> [a] -> List1 a
List1.fromListSafe List1 Clause
forall a. HasCallStack => a
__IMPOSSIBLE__ [Clause]
cs
Declaration
_ -> ScopeM Expr
forall a. HasCallStack => a
__IMPOSSIBLE__
instance ToAbstract C.Expr where
type AbsOfCon C.Expr = A.Expr
toAbstract :: Expr -> ScopeM (AbsOfCon Expr)
toAbstract Expr
e =
Call -> ScopeM (AbsOfCon Expr) -> ScopeM (AbsOfCon Expr)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Call
ScopeCheckExpr Expr
e) (ScopeM (AbsOfCon Expr) -> ScopeM (AbsOfCon Expr))
-> ScopeM (AbsOfCon Expr) -> ScopeM (AbsOfCon Expr)
forall a b. (a -> b) -> a -> b
$ ScopeM Expr -> ScopeM Expr
forall (m :: * -> *). ReadTCState m => m Expr -> m Expr
annotateExpr (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ case Expr
e of
Ident QName
x -> OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)
KnownIdent NameKind
_ QName
x -> OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)
C.Lit Range
r Literal
l -> do
Literal -> TCMT IO ()
checkLiteral Literal
l
case Literal
l of
LitNat Integer
n -> do
let builtin :: TCMT IO (Maybe Term)
builtin | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> TCMT IO Term -> TCMT IO (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primFromNeg
| Bool
otherwise = Maybe Term -> TCMT IO (Maybe Term)
ensureInScope (Maybe Term -> TCMT IO (Maybe Term))
-> TCMT IO (Maybe Term) -> TCMT IO (Maybe Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinFromNat
TCMT IO (Maybe Term)
builtin TCMT IO (Maybe Term) -> (Maybe Term -> ScopeM Expr) -> ScopeM Expr
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (I.Def QName
q Elims
_) -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr -> Expr
mkApp QName
q (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Literal -> Expr
A.Lit ExprInfo
i (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
LitNat (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
abs Integer
n
Maybe Term
_ -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit
LitString Text
s -> do
BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinFromString TCMT IO (Maybe Term)
-> (Maybe Term -> TCMT IO (Maybe Term)) -> TCMT IO (Maybe Term)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Term -> TCMT IO (Maybe Term)
ensureInScope TCMT IO (Maybe Term) -> (Maybe Term -> ScopeM Expr) -> ScopeM Expr
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (I.Def QName
q Elims
_) -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr -> Expr
mkApp QName
q Expr
alit
Maybe Term
_ -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit
Literal
_ -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
alit
where
i :: ExprInfo
i = Range -> ExprInfo
ExprRange Range
r
alit :: Expr
alit = ExprInfo -> Literal -> Expr
A.Lit ExprInfo
i Literal
l
mkApp :: QName -> Expr -> Expr
mkApp QName
q = AppInfo -> Expr -> NamedArg Expr -> Expr
A.App (Range -> AppInfo
defaultAppInfo Range
r) (QName -> Expr
A.Def QName
q) (NamedArg Expr -> Expr) -> (Expr -> NamedArg Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg
ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)
ensureInScope :: Maybe Term -> TCMT IO (Maybe Term)
ensureInScope v :: Maybe Term
v@(Just (I.Def QName
q Elims
_)) =
TCMT IO Bool
-> TCMT IO (Maybe Term)
-> TCMT IO (Maybe Term)
-> TCMT IO (Maybe Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (QName -> ScopeInfo -> Bool
isNameInScopeUnqualified QName
q (ScopeInfo -> Bool) -> TCMT IO ScopeInfo -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope) (Maybe Term -> TCMT IO (Maybe Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
v) (Maybe Term -> TCMT IO (Maybe Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing)
ensureInScope Maybe Term
_ = Maybe Term -> TCMT IO (Maybe Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing
C.QuestionMark Range
r Maybe Int
n -> do
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
ii <- registerInteractionPoint True r n
let info = MetaInfo
{ metaRange :: Range
metaRange = Range
r
, metaScope :: ScopeInfo
metaScope = ScopeInfo
scope
, metaNumber :: Maybe MetaId
metaNumber = Maybe MetaId
forall a. Maybe a
Nothing
, metaNameSuggestion :: [Char]
metaNameSuggestion = [Char]
""
, metaKind :: MetaKind
metaKind = MetaKind
UnificationMeta
}
return $ A.QuestionMark info ii
C.Underscore Range
r Maybe [Char]
n -> do
scope <- TCMT IO ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
return $ A.Underscore $ MetaInfo
{ metaRange = r
, metaScope = scope
, metaNumber = __IMPOSSIBLE__ =<< n
, metaNameSuggestion = fromMaybe "" n
, metaKind = UnificationMeta
}
C.RawApp Range
r List2 Expr
es -> do
e <- List2 Expr -> TCMT IO Expr
parseApplication List2 Expr
es
toAbstract e
C.App Range
r Expr
e1 NamedArg Expr
e2 -> do
case NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
e2 of
C.Dot{} | NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
notVisible NamedArg Expr
e2 -> NamedArg Expr -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Expr
e2 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> TypeError
IllegalHidingInPostfixProjection NamedArg Expr
e2
Expr
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let parenPref :: ParenPreference
parenPref = Expr -> ParenPreference
inferParenPreference (NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
e2)
info :: AppInfo
info = (Range -> AppInfo
defaultAppInfo Range
r) { appOrigin = UserWritten, appParens = parenPref }
e1 <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
FunctionCtx Expr
e1
e2 <- toAbstractCtx (ArgumentCtx parenPref) e2
return $ A.App info e1 e2
C.OpApp Range
r QName
op Set Name
ns OpAppArgs
es -> QName -> Set Name -> OpAppArgs -> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns OpAppArgs
es
C.KnownOpApp NameKind
_ Range
r QName
op Set Name
ns OpAppArgs
es -> QName -> Set Name -> OpAppArgs -> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns OpAppArgs
es
C.WithApp Range
r Expr
e [Expr]
es -> do
e <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
WithFunCtx Expr
e
es <- mapM (toAbstractCtx WithArgCtx) es
return $ A.WithApp (ExprRange r) e es
C.HiddenArg Range
_ Named NamedName Expr
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToHiddenArg Expr
e
C.InstanceArg Range
_ Named NamedName Expr
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
nothingAppliedToInstanceArg Expr
e
C.AbsurdLam Range
r Hiding
h -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Hiding -> Expr
A.AbsurdLam (Range -> ExprInfo
ExprRange Range
r) Hiding
h
C.Lam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e -> Range
-> NonEmpty (LamBinding' TypedBinding)
-> Expr
-> Precedence
-> ScopeM Expr
toAbstractLam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e Precedence
TopCtx
C.ExtendedLam Range
r Erased
e List1 LamClause
cs -> Range -> Erased -> List1 LamClause -> ScopeM Expr
scopeCheckExtendedLam Range
r Erased
e List1 LamClause
cs
C.Fun Range
r (Arg ArgInfo
info1 Expr
e1) Expr
e2 -> do
let arg :: Arg Expr
arg = ArgInfo -> Expr -> Arg Expr
mkArg' ArgInfo
info1 Expr
e1
let mr :: Maybe Relevance
mr = case Arg Expr -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Arg Expr
arg of
Relevance
Relevant -> Maybe Relevance
forall a. Maybe a
Nothing
Relevance
r -> Relevance -> Maybe Relevance
forall a. a -> Maybe a
Just Relevance
r
let mh :: Maybe Hiding
mh = case Arg Expr -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg Expr
arg of
Hiding
NotHidden -> Maybe Hiding
forall a. Maybe a
Nothing
Hiding
h -> Hiding -> Maybe Hiding
forall a. a -> Maybe a
Just Hiding
h
Arg info (e1', rel, hid) <- (Expr -> ScopeM (Expr, Relevance, Hiding))
-> Arg Expr -> TCMT IO (Arg (Expr, Relevance, Hiding))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse (Maybe Relevance
-> Maybe Hiding
-> Precedence
-> Expr
-> ScopeM (Expr, Relevance, Hiding)
toAbstractDotHiding Maybe Relevance
mr Maybe Hiding
mh Precedence
FunctionSpaceDomainCtx) Arg Expr
arg
let updRel = case Relevance
rel of
Relevance
Relevant -> ArgInfo -> ArgInfo
forall a. a -> a
id
Relevance
rel -> Relevance -> ArgInfo -> ArgInfo
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
rel
let updHid = case Hiding
hid of
Hiding
NotHidden -> ArgInfo -> ArgInfo
forall a. a -> a
id
Hiding
hid -> Hiding -> ArgInfo -> ArgInfo
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
hid
A.Fun (ExprRange r) (Arg (updRel $ updHid info) e1') <$> toAbstractCtx TopCtx e2
e0 :: Expr
e0@(C.Pi Telescope1
tel Expr
e) -> do
lvars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
localToAbstract tel $ \AbsOfCon Telescope1
tel -> do
lvars1 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
checkNoShadowing lvars0 lvars1
e <- toAbstractCtx TopCtx e
let info = Range -> ExprInfo
ExprRange (Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e0)
return $ A.mkPi info (List1.catMaybes tel) e
e0 :: Expr
e0@(C.Let Range
_ List1 Declaration
ds (Just Expr
e)) ->
TCMT IO Bool -> ScopeM Expr -> ScopeM Expr -> ScopeM Expr
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM TCMT IO Bool
isInsideDotPattern ([Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM Expr) -> [Char] -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ [Char]
"Let-expressions are not allowed in dot patterns") (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$
LetDefs -> (AbsOfCon LetDefs -> ScopeM Expr) -> ScopeM Expr
forall c b.
ToAbstract c =>
c -> (AbsOfCon c -> ScopeM b) -> ScopeM b
localToAbstract (List1 Declaration -> LetDefs
LetDefs List1 Declaration
ds) ((AbsOfCon LetDefs -> ScopeM Expr) -> ScopeM Expr)
-> (AbsOfCon LetDefs -> ScopeM Expr) -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ \AbsOfCon LetDefs
ds' -> do
e <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e
let info = Range -> ExprInfo
ExprRange (Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e0)
return $ A.mkLet info ds' e
C.Let Range
_ List1 Declaration
_ Maybe Expr
Nothing -> [Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Missing body in let-expression"
C.Rec Range
r RecordAssignments
fs -> do
fs' <- Precedence
-> RecordAssignments -> ScopeM (AbsOfCon RecordAssignments)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx RecordAssignments
fs
let ds' = [ LetBinding
d | Right (ModuleName
_, Just LetBinding
d) <- [Either Assign (ModuleName, Maybe LetBinding)]
fs' ]
fs'' = (Either Assign (ModuleName, Maybe LetBinding)
-> Either Assign ModuleName)
-> [Either Assign (ModuleName, Maybe LetBinding)]
-> [Either Assign ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (((ModuleName, Maybe LetBinding) -> ModuleName)
-> Either Assign (ModuleName, Maybe LetBinding)
-> Either Assign ModuleName
forall b d a. (b -> d) -> Either a b -> Either a d
mapRight (ModuleName, Maybe LetBinding) -> ModuleName
forall a b. (a, b) -> a
fst) [Either Assign (ModuleName, Maybe LetBinding)]
fs'
i = Range -> ExprInfo
ExprRange Range
r
return $ A.mkLet i ds' (A.Rec i fs'')
C.RecUpdate Range
r Expr
e [FieldAssignment]
fs -> do
ExprInfo -> Expr -> Assigns -> Expr
A.RecUpdate (Range -> ExprInfo
ExprRange Range
r) (Expr -> Assigns -> Expr)
-> ScopeM Expr -> TCMT IO (Assigns -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e TCMT IO (Assigns -> Expr) -> TCMT IO Assigns -> ScopeM Expr
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence
-> [FieldAssignment] -> ScopeM (AbsOfCon [FieldAssignment])
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx [FieldAssignment]
fs
C.Paren Range
_ Expr
e -> Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
e
C.IdiomBrackets Range
r [Expr]
es ->
Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx (Expr -> ScopeM Expr) -> TCMT IO Expr -> ScopeM Expr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Range -> [Expr] -> TCMT IO Expr
parseIdiomBracketsSeq Range
r [Expr]
es
C.DoBlock Range
r List1 DoStmt
ss ->
Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx (Expr -> ScopeM Expr) -> TCMT IO Expr -> ScopeM Expr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Range -> List1 DoStmt -> TCMT IO Expr
desugarDoNotation Range
r List1 DoStmt
ss
C.Dot Range
r Expr
e -> ExprInfo -> Expr -> Expr
A.Dot (Range -> ExprInfo
ExprRange Range
r) (Expr -> Expr) -> ScopeM Expr -> ScopeM Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
C.As Range
_ Name
_ Expr
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
notAnExpression Expr
e
C.Absurd Range
_ -> Expr -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Expr -> m a
notAnExpression Expr
e
C.Equal{} -> [Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Parse error: unexpected '='"
C.Ellipsis Range
_ -> [Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Parse error: unexpected '...'"
C.DoubleDot Range
_ Expr
_ -> [Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Parse error: unexpected '..'"
C.Quote Range
r -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr
A.Quote (Range -> ExprInfo
ExprRange Range
r)
C.QuoteTerm Range
r -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr
A.QuoteTerm (Range -> ExprInfo
ExprRange Range
r)
C.Unquote Range
r -> Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> Expr
A.Unquote (Range -> ExprInfo
ExprRange Range
r)
C.Tactic Range
r Expr
e -> [Char] -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Syntax error: 'tactic' can only appear in attributes"
C.DontCare Expr
e -> Expr -> Expr
A.DontCare (Expr -> Expr) -> ScopeM Expr -> ScopeM Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
C.Generalized Expr
e -> do
(s, e) <- ScopeM Expr -> ScopeM (Set QName, Expr)
forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables (ScopeM Expr -> ScopeM (Set QName, Expr))
-> ScopeM Expr -> ScopeM (Set QName, Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
pure $ A.generalized s e
instance ToAbstract C.ModuleAssignment where
type AbsOfCon C.ModuleAssignment = (A.ModuleName, Maybe A.LetBinding)
toAbstract :: ModuleAssignment -> ScopeM (AbsOfCon ModuleAssignment)
toAbstract (C.ModuleAssignment QName
m [Expr]
es ImportDirective
i)
| [Expr] -> Bool
forall a. Null a => a -> Bool
null [Expr]
es Bool -> Bool -> Bool
&& ImportDirective -> Bool
forall n m. ImportDirective' n m -> Bool
isDefaultImportDir ImportDirective
i = (, Maybe LetBinding
forall a. Maybe a
Nothing) (ModuleName -> (ModuleName, Maybe LetBinding))
-> TCMT IO ModuleName -> TCMT IO (ModuleName, Maybe LetBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
m)
| Bool
otherwise = do
x <- Range -> NameId -> Name
C.NoName (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
m) (NameId -> Name) -> TCMT IO NameId -> ScopeM Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
r <- checkModuleMacro LetApply LetOpenModule
(getRange (m, es, i)) PublicAccess defaultErased x
(C.SectionApp (getRange (m , es)) [] (rawApp (Ident m :| es)))
DontOpen i
case r of
LetApply ModuleInfo
_ Erased
_ ModuleName
m' ModuleApplication
_ ScopeCopyInfo
_ ImportDirective
_ -> (ModuleName, Maybe LetBinding)
-> TCMT IO (ModuleName, Maybe LetBinding)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m', LetBinding -> Maybe LetBinding
forall a. a -> Maybe a
Just LetBinding
r)
LetBinding
_ -> TCMT IO (ModuleName, Maybe LetBinding)
forall a. HasCallStack => a
__IMPOSSIBLE__
instance ToAbstract c => ToAbstract (FieldAssignment' c) where
type AbsOfCon (FieldAssignment' c) = FieldAssignment' (AbsOfCon c)
toAbstract :: FieldAssignment' c -> ScopeM (AbsOfCon (FieldAssignment' c))
toAbstract = (c -> TCMT IO (AbsOfCon c))
-> FieldAssignment' c -> TCMT IO (FieldAssignment' (AbsOfCon c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
instance ToAbstract (C.Binder' (NewName C.BoundName)) where
type AbsOfCon (C.Binder' (NewName C.BoundName)) = A.Binder
toAbstract :: Binder' (NewName BoundName)
-> ScopeM (AbsOfCon (Binder' (NewName BoundName)))
toAbstract (C.Binder Maybe Pattern
p NewName BoundName
n) = do
let name :: Name
name = BoundName -> Name
C.boundName (BoundName -> Name) -> BoundName -> Name
forall a b. (a -> b) -> a -> b
$ NewName BoundName -> BoundName
forall a. NewName a -> a
newName NewName BoundName
n
n <- if Bool -> Bool
not (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
name Bool -> Bool -> Bool
&& Maybe Pattern -> Bool
forall a. Maybe a -> Bool
isJust Maybe Pattern
p) then NewName BoundName -> TCMT IO (NewName BoundName)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewName BoundName
n else do
n' <- Range -> Int -> [Char] -> ScopeM Name
freshConcreteName (BoundName -> Range
forall a. HasRange a => a -> Range
getRange (BoundName -> Range) -> BoundName -> Range
forall a b. (a -> b) -> a -> b
$ NewName BoundName -> BoundName
forall a. NewName a -> a
newName NewName BoundName
n) Int
0 [Char]
patternInTeleName
pure $ fmap (\ BoundName
n -> BoundName
n { C.boundName = n' }) n
n <- toAbstract n
puns <- optHiddenArgumentPuns <$> pragmaOptions
p <- return $ if puns then fmap expandPuns p else p
p <- traverse parsePattern p
p <- toAbstract p
checkPatternLinearity p $ \[Name]
ys ->
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
bindVarsToBind
p <- toAbstract p
pure $ A.Binder p n
instance ToAbstract C.LamBinding where
type AbsOfCon C.LamBinding = Maybe A.LamBinding
toAbstract :: LamBinding' TypedBinding
-> ScopeM (AbsOfCon (LamBinding' TypedBinding))
toAbstract (C.DomainFree NamedArg Binder
x) = do
tac <- (Expr -> ScopeM Expr)
-> TacticAttribute -> TCMT IO (TacticAttribute' Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TacticAttribute' a -> f (TacticAttribute' b)
traverse Expr -> ScopeM Expr
Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (TacticAttribute -> TCMT IO (TacticAttribute' Expr))
-> TacticAttribute -> TCMT IO (TacticAttribute' Expr)
forall a b. (a -> b) -> a -> b
$ BoundName -> TacticAttribute
bnameTactic (BoundName -> TacticAttribute) -> BoundName -> TacticAttribute
forall a b. (a -> b) -> a -> b
$ Binder -> BoundName
forall a. Binder' a -> a
C.binderName (Binder -> BoundName) -> Binder -> BoundName
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg NamedArg Binder
x
Just . A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)
toAbstract (C.DomainFull TypedBinding
tb) = (TypedBinding -> LamBinding)
-> Maybe TypedBinding -> Maybe LamBinding
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypedBinding -> LamBinding
A.DomainFull (Maybe TypedBinding -> Maybe LamBinding)
-> TCMT IO (Maybe TypedBinding) -> TCMT IO (Maybe LamBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedBinding -> ScopeM (AbsOfCon TypedBinding)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract TypedBinding
tb
makeDomainFull :: C.LamBinding -> C.TypedBinding
makeDomainFull :: LamBinding' TypedBinding -> TypedBinding
makeDomainFull (C.DomainFull TypedBinding
b) = TypedBinding
b
makeDomainFull (C.DomainFree NamedArg Binder
x) = Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding
forall e. Range -> List1 (NamedArg Binder) -> e -> TypedBinding' e
C.TBind Range
r (NamedArg Binder -> List1 (NamedArg Binder)
forall el coll. Singleton el coll => el -> coll
singleton NamedArg Binder
x) (Expr -> TypedBinding) -> Expr -> TypedBinding
forall a b. (a -> b) -> a -> b
$ Range -> Maybe [Char] -> Expr
C.Underscore Range
r Maybe [Char]
forall a. Maybe a
Nothing
where r :: Range
r = NamedArg Binder -> Range
forall a. HasRange a => a -> Range
getRange NamedArg Binder
x
instance ToAbstract C.TypedBinding where
type AbsOfCon C.TypedBinding = Maybe A.TypedBinding
toAbstract :: TypedBinding -> ScopeM (AbsOfCon TypedBinding)
toAbstract (C.TBind Range
r List1 (NamedArg Binder)
xs Expr
t) = do
t' <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
tac <- C.TacticAttribute <$> do
traverse toAbstract $
case List1.mapMaybe (theTacticAttribute . bnameTactic . C.binderName . namedArg) xs of
[] -> Maybe (Ranged Expr)
forall a. Maybe a
Nothing
Ranged Expr
tac : [Ranged Expr]
_ -> Ranged Expr -> Maybe (Ranged Expr)
forall a. a -> Maybe a
Just Ranged Expr
tac
let fin = (NamedArg Binder -> Bool) -> List1 (NamedArg Binder) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (BoundName -> Bool
bnameIsFinite (BoundName -> Bool)
-> (NamedArg Binder -> BoundName) -> NamedArg Binder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder -> BoundName
forall a. Binder' a -> a
C.binderName (Binder -> BoundName)
-> (NamedArg Binder -> Binder) -> NamedArg Binder -> BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg) List1 (NamedArg Binder)
xs
xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs
return $ Just $ A.TBind r (TypedBindingInfo tac fin) xs' t'
toAbstract (C.TLet Range
r List1 Declaration
ds) = Range -> [LetBinding] -> Maybe TypedBinding
A.mkTLet Range
r ([LetBinding] -> Maybe TypedBinding)
-> TCMT IO [LetBinding] -> TCMT IO (Maybe TypedBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetDefs -> ScopeM (AbsOfCon LetDefs)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (List1 Declaration -> LetDefs
LetDefs List1 Declaration
ds)
scopeCheckNiceModule
:: Range
-> Access
-> Erased
-> C.Name
-> C.Telescope
-> ScopeM [A.Declaration]
-> ScopeM A.Declaration
scopeCheckNiceModule :: Range
-> Access
-> Erased
-> Name
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO Declaration
scopeCheckNiceModule Range
r Access
p Erased
e Name
name Telescope
tel ScopeM [Declaration]
checkDs
| Telescope -> Bool
telHasOpenStmsOrModuleMacros Telescope
tel = do
Range
-> Access
-> Erased
-> Name
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO Declaration
scopeCheckNiceModule Range
forall a. Range' a
noRange Access
p Erased
e Name
noName_ [] (ScopeM [Declaration] -> TCMT IO Declaration)
-> ScopeM [Declaration] -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$ Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> TCMT IO Declaration -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Access -> TCMT IO Declaration
scopeCheckNiceModule_ Access
PublicAccess
| Bool
otherwise = do
Access -> TCMT IO Declaration
scopeCheckNiceModule_ Access
p
where
scopeCheckNiceModule_ :: Access -> ScopeM A.Declaration
scopeCheckNiceModule_ :: Access -> TCMT IO Declaration
scopeCheckNiceModule_ Access
p = do
(name, p', open) <- do
if Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
name then do
(i :: NameId) <- TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
return (C.NoName (getRange name) i, privateAccessInserted, True)
else (Name, Access, Bool) -> TCMT IO (Name, Access, Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Access
p, Bool
False)
aname <- toAbstract (NewModuleName name)
d <- snd <$> do
scopeCheckModule r e (C.QName name) aname tel checkDs
bindModule p' name aname
when open $
void $
openModule TopOpenModule (Just aname) (C.QName name) $
defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) empty }
return d
telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool
telHasOpenStmsOrModuleMacros :: Telescope -> Bool
telHasOpenStmsOrModuleMacros = (TypedBinding -> Bool) -> Telescope -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypedBinding -> Bool
forall {e}. TypedBinding' e -> Bool
yesBind
where
yesBind :: TypedBinding' e -> Bool
yesBind C.TBind{} = Bool
False
yesBind (C.TLet Range
_ List1 Declaration
ds) = (Declaration -> Bool) -> List1 Declaration -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
yes List1 Declaration
ds
yes :: Declaration -> Bool
yes C.ModuleMacro{} = Bool
True
yes C.Open{} = Bool
True
yes C.Import{} = Bool
True
yes (C.Mutual KwRange
_ [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 KwRange
_ [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 KwRange
_ 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
class EnsureNoLetStms a where
ensureNoLetStms :: a -> ScopeM ()
default ensureNoLetStms :: (Foldable t, EnsureNoLetStms b, t b ~ a) => a -> ScopeM ()
ensureNoLetStms = (b -> TCMT IO ()) -> t b -> TCMT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ b -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms
instance EnsureNoLetStms C.Binder where
ensureNoLetStms :: Binder -> TCMT IO ()
ensureNoLetStms arg :: Binder
arg@(C.Binder Maybe Pattern
p BoundName
n) =
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Pattern -> Bool
forall a. Maybe a -> Bool
isJust Maybe Pattern
p) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Binder -> TypeError
IllegalPatternInTelescope Binder
arg
instance EnsureNoLetStms C.TypedBinding where
ensureNoLetStms :: TypedBinding -> TCMT IO ()
ensureNoLetStms = \case
tb :: TypedBinding
tb@C.TLet{} -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypedBinding -> TypeError
IllegalLetInTelescope TypedBinding
tb
C.TBind Range
_ List1 (NamedArg Binder)
xs Expr
_ -> (NamedArg Binder -> TCMT IO ())
-> List1 (NamedArg Binder) -> TCMT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Binder -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms (Binder -> TCMT IO ())
-> (NamedArg Binder -> Binder) -> NamedArg Binder -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg) List1 (NamedArg Binder)
xs
instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where
ensureNoLetStms :: LamBinding' a -> TCMT IO ()
ensureNoLetStms = \case
C.DomainFree NamedArg Binder
a -> NamedArg Binder -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms NamedArg Binder
a
C.DomainFull a
a -> a -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms a
a
instance EnsureNoLetStms a => EnsureNoLetStms (Named_ a) where
instance EnsureNoLetStms a => EnsureNoLetStms (NamedArg a) where
instance EnsureNoLetStms a => EnsureNoLetStms [a] where
scopeCheckModule
:: Range
-> Erased
-> C.QName
-> A.ModuleName
-> C.Telescope
-> ScopeM [A.Declaration]
-> ScopeM (ScopeInfo, A.Declaration)
scopeCheckModule :: Range
-> Erased
-> QName
-> ModuleName
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO (ScopeInfo, Declaration)
scopeCheckModule Range
r Erased
e QName
x ModuleName
qm Telescope
tel ScopeM [Declaration]
checkDs = do
[Char] -> Int -> [Char] -> TCMT IO ()
printScope [Char]
"module" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"checking module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
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
tel <- GenTel -> ScopeM (AbsOfCon GenTel)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Telescope -> GenTel
GenTel Telescope
tel)
withCurrentModule qm $ do
printScope "module" 20 $ "inside module " ++ prettyShow x
ds <- checkDs
scope <- getScope
return (scope, A.Section r e (qm `withRangesOfQ` x) tel ds)
printScope "module" 20 $ "after module " ++ prettyShow x
return res
data TopLevel a = TopLevel
{ forall a. TopLevel a -> AbsolutePath
topLevelPath :: AbsolutePath
, forall a. TopLevel a -> TopLevelModuleName' Range
topLevelExpectedName :: TopLevelModuleName
, forall a. TopLevel a -> a
topLevelTheThing :: a
}
data TopLevelInfo = TopLevelInfo
{ TopLevelInfo -> [Declaration]
topLevelDecls :: [A.Declaration]
, TopLevelInfo -> ScopeInfo
topLevelScope :: ScopeInfo
}
topLevelModuleName :: TopLevelInfo -> A.ModuleName
topLevelModuleName :: TopLevelInfo -> ModuleName
topLevelModuleName = (ScopeInfo -> Lens' ScopeInfo ModuleName -> ModuleName
forall o i. o -> Lens' o i -> i
^. (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo ModuleName
scopeCurrent) (ScopeInfo -> ModuleName)
-> (TopLevelInfo -> ScopeInfo) -> TopLevelInfo -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelInfo -> ScopeInfo
topLevelScope
instance ToAbstract (TopLevel [C.Declaration]) where
type AbsOfCon (TopLevel [C.Declaration]) = TopLevelInfo
toAbstract :: TopLevel [Declaration]
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
toAbstract (TopLevel AbsolutePath
file TopLevelModuleName' Range
expectedMName [Declaration]
ds) =
case [Declaration] -> ([Declaration], [Declaration])
C.spanAllowedBeforeModule [Declaration]
ds of
([Declaration]
_, C.Module{} : Declaration
d : [Declaration]
_) -> Declaration
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Declaration
d (ScopeM (AbsOfCon (TopLevel [Declaration]))
-> ScopeM (AbsOfCon (TopLevel [Declaration])))
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
-> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall a b. (a -> b) -> a -> b
$
[Char] -> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM (AbsOfCon (TopLevel [Declaration])))
-> [Char] -> ScopeM (AbsOfCon (TopLevel [Declaration]))
forall a b. (a -> b) -> a -> b
$ [Char]
"No declarations allowed after top-level module."
([Declaration]
outsideDecls, [ C.Module Range
r Erased
e QName
m0 Telescope
tel [Declaration]
insideDecls ]) -> do
(m, top) <- if QName -> Bool
forall a. IsNoName a => a -> Bool
isNoName QName
m0
then do
case ((Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration]))
-> [Declaration]
-> (Declaration -> Bool)
-> ([Declaration], [Declaration])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span [Declaration]
insideDecls ((Declaration -> Bool) -> ([Declaration], [Declaration]))
-> (Declaration -> Bool) -> ([Declaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ \case { C.Module{} -> Bool
False; Declaration
_ -> Bool
True } of
([Declaration]
ds0, (C.Module Range
_ Erased
_ QName
m1 Telescope
_ [Declaration]
_ : [Declaration]
_))
| QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m1 RawTopLevelModuleName -> RawTopLevelModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==
TopLevelModuleName' Range -> RawTopLevelModuleName
rawTopLevelModuleName TopLevelModuleName' Range
expectedMName
, Range
r Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
== Range -> Range
beginningOfFile ([Declaration] -> Range
forall a. HasRange a => a -> Range
getRange [Declaration]
insideDecls) -> do
ScopeM [Declaration] -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ScopeM [Declaration]
importPrimitives
ScopeM [Declaration] -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScopeM [Declaration] -> TCMT IO ())
-> ScopeM [Declaration] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
outsideDecls)
ScopeM [Declaration] -> TCMT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScopeM [Declaration] -> TCMT IO ())
-> ScopeM [Declaration] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
ds0)
[Declaration]
-> TCMT IO (QName, TopLevelModuleName' Range)
-> TCMT IO (QName, TopLevelModuleName' Range)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Declaration]
ds0 (TCMT IO (QName, TopLevelModuleName' Range)
-> TCMT IO (QName, TopLevelModuleName' Range))
-> TCMT IO (QName, TopLevelModuleName' Range)
-> TCMT IO (QName, TopLevelModuleName' Range)
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO (QName, TopLevelModuleName' Range)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError
[Char]
"Illegal declaration(s) before top-level module"
([Declaration], [Declaration])
_ -> do
let m :: QName
m = Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ Range -> Name -> Name
forall a. SetRange a => Range -> a -> a
setRange (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
m0) (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
[Char] -> Name
C.simpleName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
stringToRawName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
AbsolutePath -> [Char]
rootNameModule AbsolutePath
file
top <- RawTopLevelModuleName -> TCM (TopLevelModuleName' Range)
S.topLevelModuleName
(QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m)
return (m, top)
else do
top <- RawTopLevelModuleName -> TCM (TopLevelModuleName' Range)
S.topLevelModuleName
(QName -> RawTopLevelModuleName
rawTopLevelModuleNameForQName QName
m0)
checkModuleName top (SourceFile file) (Just expectedMName)
return (m0, top)
setTopLevelModule top
am <- toAbstract (NewModuleQName m)
primitiveImport <- importPrimitives
outsideDecls <- toAbstract (Declarations outsideDecls)
(insideScope, insideDecl) <- scopeCheckModule r e m am tel $
toAbstract (Declarations insideDecls)
let scope = ScopeInfo
insideScope
setScope scope
saturateOpaqueBlocks
return $ TopLevelInfo (primitiveImport ++ outsideDecls ++ [ insideDecl ]) scope
([Declaration], [Declaration])
_ -> TCMT IO TopLevelInfo
ScopeM (AbsOfCon (TopLevel [Declaration]))
forall a. HasCallStack => a
__IMPOSSIBLE__
importPrimitives :: ScopeM [A.Declaration]
importPrimitives :: ScopeM [Declaration]
importPrimitives = do
TCMT IO Bool
-> ScopeM [Declaration]
-> ScopeM [Declaration]
-> ScopeM [Declaration]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (PragmaOptions -> Bool
optImportSorts (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) ([Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) do
prop <- PragmaOptions -> Bool
optProp (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
twoLevel <- optTwoLevel <$> pragmaOptions
let agdaPrimitiveName = Name -> QName -> QName
Qual ([Char] -> Name
C.simpleName [Char]
"Agda") (QName -> QName) -> QName -> QName
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
C.simpleName [Char]
"Primitive"
usingDirective = ([Char] -> ImportedName' Name Name)
-> [[Char]] -> [ImportedName' Name Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ImportedName' Name Name
forall n m. n -> ImportedName' n m
ImportedName (Name -> ImportedName' Name Name)
-> ([Char] -> Name) -> [Char] -> ImportedName' Name Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
C.simpleName) ([[Char]] -> [ImportedName' Name Name])
-> [[Char]] -> [ImportedName' Name Name]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [Char]
"Prop" | Bool
prop ]
, [ [Char]
"Set" | Bool
True ]
, [ [Char]
"SSet" | Bool
twoLevel ]
]
directives = Range
-> Using' Name Name
-> [ImportedName' Name Name]
-> [Renaming' Name Name]
-> Maybe KwRange
-> ImportDirective
forall n m.
Range
-> Using' n m
-> HidingDirective' n m
-> RenamingDirective' n m
-> Maybe KwRange
-> ImportDirective' n m
ImportDirective Range
forall a. Range' a
noRange ([ImportedName' Name Name] -> Using' Name Name
forall n m. [ImportedName' n m] -> Using' n m
Using [ImportedName' Name Name]
usingDirective) [] [] Maybe KwRange
forall a. Maybe a
Nothing
importAgdaPrimitive = [Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> Declaration
C.Import Range
forall a. Range' a
noRange QName
agdaPrimitiveName Maybe AsName
forall a. Maybe a
Nothing OpenShortHand
C.DoOpen ImportDirective
directives]
toAbstract (Declarations importAgdaPrimitive)
niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls :: forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
warn [Declaration]
ds [NiceDeclaration] -> ScopeM a
ret = [Declaration] -> ScopeM a -> ScopeM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Declaration]
ds (ScopeM a -> ScopeM a) -> ScopeM a -> ScopeM a
forall a b. (a -> b) -> a -> b
$ DoWarn -> [Declaration] -> ScopeM a -> ScopeM a
forall a. DoWarn -> [Declaration] -> ScopeM a -> ScopeM a
computeFixitiesAndPolarities DoWarn
warn [Declaration]
ds (ScopeM a -> ScopeM a) -> ScopeM a -> ScopeM a
forall a b. (a -> b) -> a -> b
$ do
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
safeButNotBuiltin <- and2M
do pure isSafe
do not <$> do Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath
fixs <- useScope scopeFixities
let (result, warns) = runNice (NiceEnv safeButNotBuiltin) $ niceDeclarations fixs ds
unless (warn == NoWarn || null warns) $ do
when isSafe $ do
let (errs, ws) = List.partition unsafeDeclarationWarning warns
unless (null errs) $ do
warnings $ NicifierIssue <$> ws
tcerrs <- mapM warning_ $ NicifierIssue <$> errs
setCurrentRange errs $ typeError $ NonFatalErrors tcerrs
mapM_ (\ DeclarationWarning
w -> CallStack -> Warning -> TCMT IO ()
forall (m :: * -> *).
MonadWarning m =>
CallStack -> Warning -> m ()
warning' (DeclarationWarning -> CallStack
dwLocation DeclarationWarning
w) (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue DeclarationWarning
w) warns
case result of
Left (DeclarationException CallStack
loc DeclarationException'
e) -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"error" Int
2 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error raised at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallStack -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow CallStack
loc
TCErr -> ScopeM a
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TCErr -> ScopeM a) -> TCErr -> ScopeM a
forall a b. (a -> b) -> a -> b
$ Range -> Doc -> TCErr
Exception (DeclarationException' -> Range
forall a. HasRange a => a -> Range
getRange DeclarationException'
e) (Doc -> TCErr) -> Doc -> TCErr
forall a b. (a -> b) -> a -> b
$ DeclarationException' -> Doc
forall a. Pretty a => a -> Doc
pretty DeclarationException'
e
Right [NiceDeclaration]
ds -> [NiceDeclaration] -> ScopeM a
ret [NiceDeclaration]
ds
newtype Declarations = Declarations [C.Declaration]
instance ToAbstract Declarations where
type AbsOfCon Declarations = [A.Declaration]
toAbstract :: Declarations -> ScopeM (AbsOfCon Declarations)
toAbstract (Declarations [Declaration]
ds) = DoWarn
-> [Declaration]
-> ([NiceDeclaration] -> ScopeM [Declaration])
-> ScopeM [Declaration]
forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn [Declaration]
ds [NiceDeclaration] -> ScopeM [Declaration]
[NiceDeclaration] -> ScopeM (AbsOfCon [NiceDeclaration])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
newtype LetDefs = LetDefs (List1 C.Declaration)
newtype LetDef = LetDef NiceDeclaration
instance ToAbstract LetDefs where
type AbsOfCon LetDefs = [A.LetBinding]
toAbstract :: LetDefs -> ScopeM (AbsOfCon LetDefs)
toAbstract (LetDefs List1 Declaration
ds) =
[List1 LetBinding] -> [LetBinding]
forall a. [List1 a] -> [a]
List1.concat ([List1 LetBinding] -> [LetBinding])
-> TCMT IO [List1 LetBinding] -> TCMT IO [LetBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DoWarn
-> [Declaration]
-> ([NiceDeclaration] -> TCMT IO [List1 LetBinding])
-> TCMT IO [List1 LetBinding]
forall a.
DoWarn
-> [Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a
niceDecls DoWarn
DoWarn (List1 Declaration -> [Item (List1 Declaration)]
forall l. IsList l => l -> [Item l]
List1.toList List1 Declaration
ds) ([LetDef] -> TCMT IO [List1 LetBinding]
[LetDef] -> ScopeM (AbsOfCon [LetDef])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([LetDef] -> TCMT IO [List1 LetBinding])
-> ([NiceDeclaration] -> [LetDef])
-> [NiceDeclaration]
-> TCMT IO [List1 LetBinding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NiceDeclaration -> LetDef) -> [NiceDeclaration] -> [LetDef]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> LetDef
LetDef)
instance ToAbstract LetDef where
type AbsOfCon LetDef = List1 A.LetBinding
toAbstract :: LetDef -> ScopeM (AbsOfCon LetDef)
toAbstract (LetDef NiceDeclaration
d) =
case NiceDeclaration
d of
NiceMutual KwRange
_ TerminationCheck
_ CoverageCheck
_ PositivityCheck
_ d :: [NiceDeclaration]
d@[C.FunSig Range
_ Access
_ IsAbstract
_ IsInstance
instanc IsMacro
macro ArgInfo
info TerminationCheck
_ CoverageCheck
_ Name
x Expr
t, C.FunDef Range
_ [Declaration]
_ IsAbstract
abstract IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_ [Clause
cl]] ->
do Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsAbstract
abstract IsAbstract -> IsAbstract -> Bool
forall a. Eq a => a -> a -> Bool
== IsAbstract
AbstractDef) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"`abstract` not allowed in let expressions"
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsMacro
macro IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Macros cannot be defined in a let expression"
t <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
t
fx <- getConcreteFixity x
x <- A.unBind <$> toAbstract (NewName LetBound $ mkBoundName x fx)
(x', e) <- letToAbstract cl
let info' = case IsInstance
instanc of
InstanceDef KwRange
_ -> ArgInfo -> ArgInfo
forall a. LensHiding a => a -> a
makeInstance ArgInfo
info
IsInstance
NotInstanceDef -> ArgInfo
info
return $ A.LetDeclaredVariable (A.mkBindName (setRange (getRange x') x)) :|
[ A.LetBind (LetRange $ getRange d) info' (A.mkBindName x) t e
]
NiceFunClause Range
r Access
PublicAccess IsAbstract
ConcreteDef TerminationCheck
tc CoverageCheck
cc Bool
catchall d :: Declaration
d@(C.FunClause lhs :: LHS
lhs@(C.LHS Pattern
p0 [] []) RHS' Expr
rhs0 WhereClause' [Declaration]
wh Bool
ca) -> do
WhereClause' [Declaration] -> TCMT IO ()
noWhereInLetBinding WhereClause' [Declaration]
wh
rhs <- RHS' Expr -> TCMT IO Expr
letBindingMustHaveRHS RHS' Expr
rhs0
puns <- optHiddenArgumentPuns <$> pragmaOptions
p0 <- return $ if puns then expandPuns p0 else p0
mp <- setCurrentRange p0 $
(Right <$> parsePattern p0)
`catchError`
(return . Left)
case mp of
Right Pattern
p -> do
rhs <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
setCurrentRange p0 $ do
p <- toAbstract p
checkValidLetPattern p
checkPatternLinearity p $ \[Name]
ys ->
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
bindVarsToBind
p <- toAbstract p
return $ singleton $ A.LetPatBind (LetRange r) p rhs
Left TCErr
err ->
case Pattern -> Maybe Name
definedName Pattern
p0 of
Maybe Name
Nothing -> TCErr -> TCMT IO (List1 LetBinding)
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
Just Name
x -> LetDef -> ScopeM (AbsOfCon LetDef)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (LetDef -> ScopeM (AbsOfCon LetDef))
-> LetDef -> ScopeM (AbsOfCon LetDef)
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> LetDef
LetDef (NiceDeclaration -> LetDef) -> NiceDeclaration -> LetDef
forall a b. (a -> b) -> a -> b
$ KwRange
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual KwRange
forall a. Null a => a
empty TerminationCheck
tc CoverageCheck
cc PositivityCheck
YesPositivityCheck
[ Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
C.FunSig Range
r Access
PublicAccess IsAbstract
ConcreteDef IsInstance
NotInstanceDef IsMacro
NotMacroDef
(Origin -> ArgInfo -> ArgInfo
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted ArgInfo
defaultArgInfo) TerminationCheck
tc CoverageCheck
cc Name
x (Range -> Maybe [Char] -> Expr
C.Underscore (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Maybe [Char]
forall a. Maybe a
Nothing)
, Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
C.FunDef Range
r [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__ IsAbstract
ConcreteDef IsInstance
NotInstanceDef TerminationCheck
forall a. HasCallStack => a
__IMPOSSIBLE__ CoverageCheck
forall a. HasCallStack => a
__IMPOSSIBLE__ Name
forall a. HasCallStack => a
__IMPOSSIBLE__
[Name
-> Bool
-> LHS
-> RHS' Expr
-> WhereClause' [Declaration]
-> [Clause]
-> Clause
C.Clause Name
x (Bool
ca Bool -> Bool -> Bool
|| Bool
catchall) LHS
lhs (Expr -> RHS' Expr
forall e. e -> RHS' e
C.RHS Expr
rhs) WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere []]
]
where
definedName :: Pattern -> Maybe Name
definedName (C.IdentP Bool
_ (C.QName Name
x)) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x
definedName C.IdentP{} = Maybe Name
forall a. Maybe a
Nothing
definedName (C.RawAppP Range
_ (List2 Pattern
p Pattern
_ [Pattern]
_)) = Pattern -> Maybe Name
definedName Pattern
p
definedName (C.ParenP Range
_ Pattern
p) = Pattern -> Maybe Name
definedName Pattern
p
definedName C.WildP{} = Maybe Name
forall a. Maybe a
Nothing
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
definedName C.InstanceP{} = Maybe Name
forall a. Maybe a
Nothing
definedName C.WithP{} = Maybe Name
forall a. Maybe a
Nothing
definedName C.AppP{} = Maybe Name
forall a. Maybe a
Nothing
definedName C.OpAppP{} = Maybe Name
forall a. HasCallStack => a
__IMPOSSIBLE__
definedName C.EllipsisP{} = Maybe Name
forall a. Maybe a
Nothing
NiceOpen Range
r QName
x ImportDirective
dirs -> do
Maybe KwRange -> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe KwRange
forall n m. ImportDirective' n m -> Maybe KwRange
publicOpen ImportDirective
dirs) ((KwRange -> TCMT IO ()) -> TCMT IO ())
-> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \KwRange
r -> KwRange -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange KwRange
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
m <- OldModuleName -> ScopeM (AbsOfCon OldModuleName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldModuleName
OldModuleName QName
x)
adir <- openModule_ LetOpenModule x dirs
let minfo = ModuleInfo
{ minfoRange :: Range
minfoRange = Range
r
, minfoAsName :: Maybe Name
minfoAsName = Maybe Name
forall a. Maybe a
Nothing
, minfoAsTo :: Range
minfoAsTo = ImportDirective -> Range
renamingRange ImportDirective
dirs
, minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = Maybe OpenShortHand
forall a. Maybe a
Nothing
, minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dirs
}
return $ singleton $ A.LetOpen minfo m adir
NiceModuleMacro Range
r Access
p Erased
erased Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
Maybe KwRange -> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe KwRange
forall n m. ImportDirective' n m -> Maybe KwRange
publicOpen ImportDirective
dir) ((KwRange -> TCMT IO ()) -> TCMT IO ())
-> (KwRange -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ KwRange
r -> KwRange -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange KwRange
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
UselessPublic
LetBinding -> List1 LetBinding
forall el coll. Singleton el coll => el -> coll
singleton (LetBinding -> List1 LetBinding)
-> ScopeM LetBinding -> TCMT IO (List1 LetBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM LetBinding
forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> LetBinding
LetApply OpenKind
LetOpenModule Range
r
Access
privateAccessInserted Erased
erased Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir
NiceDeclaration
_ -> NiceDeclaration -> TCMT IO (List1 LetBinding)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding NiceDeclaration
d
where
letToAbstract :: Clause -> TCMT IO (QName, Expr)
letToAbstract (C.Clause Name
top Bool
_catchall (C.LHS Pattern
p [] []) RHS' Expr
rhs0 WhereClause' [Declaration]
wh []) = do
WhereClause' [Declaration] -> TCMT IO ()
noWhereInLetBinding WhereClause' [Declaration]
wh
rhs <- RHS' Expr -> TCMT IO Expr
letBindingMustHaveRHS RHS' Expr
rhs0
(x, args) <- do
res <- setCurrentRange p $ parseLHS (C.QName top) p
case res of
C.LHSHead QName
x [NamedArg Pattern]
args -> (QName, [NamedArg Pattern]) -> TCMT IO (QName, [NamedArg Pattern])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, [NamedArg Pattern]
args)
C.LHSProj{} -> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (QName, [NamedArg Pattern]))
-> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall a b. (a -> b) -> a -> b
$ [Char]
"Copatterns not allowed in let bindings"
C.LHSWith{} -> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (QName, [NamedArg Pattern]))
-> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall a b. (a -> b) -> a -> b
$ [Char]
"`with` patterns not allowed in let bindings"
C.LHSEllipsis{} -> [Char] -> TCMT IO (QName, [NamedArg Pattern])
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"`...` not allowed in let bindings"
e <- localToAbstract args $ \AbsOfCon [NamedArg Pattern]
args -> do
TCMT IO ()
bindVarsToBind
rhs <- Name -> ScopeM Expr -> ScopeM Expr
forall a. Name -> ScopeM a -> ScopeM a
unbindVariable Name
top (ScopeM Expr -> ScopeM Expr) -> ScopeM Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
rhs
foldM lambda rhs (reverse args)
return (x, e)
letToAbstract Clause
_ = NiceDeclaration -> TCMT IO (QName, Expr)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding NiceDeclaration
d
lambda :: Expr -> Arg (Named NamedName (Pattern' Expr)) -> ScopeM Expr
lambda Expr
e (Arg ArgInfo
info (Named Maybe NamedName
Nothing (A.VarP BindName
x))) =
Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall a b. (a -> b) -> a -> b
$ ExprInfo -> LamBinding -> Expr -> Expr
A.Lam ExprInfo
i (NamedArg (Binder' BindName) -> LamBinding
A.mkDomainFree (NamedArg (Binder' BindName) -> LamBinding)
-> NamedArg (Binder' BindName) -> LamBinding
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Binder' BindName -> NamedArg (Binder' BindName)
forall a. ArgInfo -> a -> NamedArg a
unnamedArg ArgInfo
info (Binder' BindName -> NamedArg (Binder' BindName))
-> Binder' BindName -> NamedArg (Binder' BindName)
forall a b. (a -> b) -> a -> b
$ BindName -> Binder' BindName
forall a. a -> Binder' a
A.mkBinder BindName
x) Expr
e
where i :: ExprInfo
i = Range -> ExprInfo
ExprRange (BindName -> Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange BindName
x Expr
e)
lambda Expr
e (Arg ArgInfo
info (Named Maybe NamedName
Nothing (A.WildP PatInfo
i))) =
do x <- Range -> ScopeM Name
forall (m :: * -> *). MonadFresh NameId m => Range -> m Name
freshNoName (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i)
return $ A.Lam i' (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ x) e
where i' :: ExprInfo
i' = Range -> ExprInfo
ExprRange (PatInfo -> Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange PatInfo
i Expr
e)
lambda Expr
_ Arg (Named NamedName (Pattern' Expr))
_ = NiceDeclaration -> ScopeM Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
NiceDeclaration -> m a
notAValidLetBinding NiceDeclaration
d
noWhereInLetBinding :: C.WhereClause -> ScopeM ()
noWhereInLetBinding :: WhereClause' [Declaration] -> TCMT IO ()
noWhereInLetBinding = \case
WhereClause' [Declaration]
NoWhere -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
WhereClause' [Declaration]
wh -> WhereClause' [Declaration] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange WhereClause' [Declaration]
wh (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"`where` clauses not allowed in let bindings"
letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr
letBindingMustHaveRHS :: RHS' Expr -> TCMT IO Expr
letBindingMustHaveRHS = \case
C.RHS Expr
e -> Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
RHS' Expr
C.AbsurdRHS -> [Char] -> TCMT IO Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO Expr) -> [Char] -> TCMT IO Expr
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing right hand side in let binding"
checkValidLetPattern :: A.Pattern' e -> ScopeM ()
checkValidLetPattern :: forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern = \case
A.VarP{} -> TCMT IO ()
yes
A.ConP ConPatInfo
_ AmbiguousQName
_ NAPs e
ps -> (NamedArg (Pattern' e) -> TCMT IO ()) -> NAPs e -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern (Pattern' e -> TCMT IO ())
-> (NamedArg (Pattern' e) -> Pattern' e)
-> NamedArg (Pattern' e)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Pattern' e) -> Pattern' e
forall a. NamedArg a -> a
namedArg) NAPs e
ps
A.ProjP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.DefP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.WildP{} -> TCMT IO ()
yes
A.AsP PatInfo
_ BindName
_ Pattern' e
p -> Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' e
p
A.DotP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.AbsurdP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.LitP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.PatternSynP PatInfo
_ AmbiguousQName
_ NAPs e
ps -> (NamedArg (Pattern' e) -> TCMT IO ()) -> NAPs e -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern (Pattern' e -> TCMT IO ())
-> (NamedArg (Pattern' e) -> Pattern' e)
-> NamedArg (Pattern' e)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Pattern' e) -> Pattern' e
forall a. NamedArg a -> a
namedArg) NAPs e
ps
A.RecP ConPatInfo
_ [FieldAssignment' (Pattern' e)]
fs -> (FieldAssignment' (Pattern' e) -> TCMT IO ())
-> [FieldAssignment' (Pattern' e)] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern (Pattern' e -> TCMT IO ())
-> (FieldAssignment' (Pattern' e) -> Pattern' e)
-> FieldAssignment' (Pattern' e)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldAssignment' (Pattern' e) -> Pattern' e
forall a. FieldAssignment' a -> a
_exprFieldA) [FieldAssignment' (Pattern' e)]
fs
A.EqualP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.WithP{} -> TCMT IO ()
forall {a}. TCMT IO a
no
A.AnnP PatInfo
_ e
_ Pattern' e
p -> Pattern' e -> TCMT IO ()
forall e. Pattern' e -> TCMT IO ()
checkValidLetPattern Pattern' e
p
where
yes :: TCMT IO ()
yes = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
no :: TCMT IO a
no = [Char] -> TCMT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Not a valid let pattern"
instance ToAbstract NiceDeclaration where
type AbsOfCon NiceDeclaration = A.Declaration
toAbstract :: NiceDeclaration -> ScopeM (AbsOfCon NiceDeclaration)
toAbstract NiceDeclaration
d = ScopeM [Declaration] -> TCMT IO Declaration
forall (m :: * -> *).
ReadTCState m =>
m [Declaration] -> m Declaration
annotateDecls (ScopeM [Declaration] -> TCMT IO Declaration)
-> ScopeM [Declaration] -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$
[Char]
-> Int -> [[Char]] -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
[Char] -> Int -> a -> m c -> m c
forall (m :: * -> *) c.
MonadDebug m =>
[Char] -> Int -> [[Char]] -> m c -> m c
traceS [Char]
"scope.decl.trace" Int
50
[ [Char]
"scope checking declaration"
, [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NiceDeclaration -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow NiceDeclaration
d
] (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
[Char]
-> Int -> [[Char]] -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a (m :: * -> *) c.
(TraceS a, MonadDebug m) =>
[Char] -> Int -> a -> m c -> m c
forall (m :: * -> *) c.
MonadDebug m =>
[Char] -> Int -> [[Char]] -> m c -> m c
traceS [Char]
"scope.decl.trace" Int
80
[ [Char]
"scope checking declaration (raw)"
, [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NiceDeclaration -> [Char]
forall a. Show a => a -> [Char]
show NiceDeclaration
d
] (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
Call -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (NiceDeclaration -> Call
ScopeCheckDeclaration NiceDeclaration
d) (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
Maybe IsAbstract
-> (ScopeM [Declaration] -> ScopeM [Declaration])
-> (IsAbstract -> ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration]
-> ScopeM [Declaration]
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (NiceDeclaration -> Maybe IsAbstract
niceHasAbstract NiceDeclaration
d) ScopeM [Declaration] -> ScopeM [Declaration]
forall a. a -> a
id (\ IsAbstract
a -> (TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC ((TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration])
-> (TCEnv -> TCEnv) -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ \ TCEnv
e -> TCEnv
e { envAbstractMode = aDefToMode a }) (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
case NiceDeclaration
d of
C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
t -> do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((CommandLineOptions -> Bool
forall a. LensSafeMode a => a -> Bool
Lens.getSafeMode (CommandLineOptions -> Bool)
-> TCMT IO CommandLineOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions) TCMT IO Bool -> TCMT IO Bool -> TCMT IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M`
(Bool -> Bool
not (Bool -> Bool) -> TCMT IO Bool -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> TCMT IO Bool
forall (m :: * -> *). MonadIO m => [Char] -> m Bool
Lens.isBuiltinModuleWithSafePostulates ([Char] -> TCMT IO Bool)
-> (AbsolutePath -> [Char]) -> AbsolutePath -> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> [Char]
filePath (AbsolutePath -> TCMT IO Bool)
-> TCMT IO AbsolutePath -> TCMT IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO AbsolutePath
forall (m :: * -> *). MonadTCEnv m => m AbsolutePath
getCurrentPath)))
(Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> Warning
SafeFlagPostulate Name
x)
Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> TCMT IO Declaration -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfName -> NiceDeclaration -> TCMT IO Declaration
toAbstractNiceAxiom KindOfName
AxiomName NiceDeclaration
d
C.NiceGeneralize Range
r Access
p ArgInfo
i TacticAttribute
tac Name
x Expr
t -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.decl" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"found nice generalize: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
tac <- (Expr -> ScopeM Expr)
-> TacticAttribute -> TCMT IO (TacticAttribute' Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TacticAttribute' a -> f (TacticAttribute' b)
traverse (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
t_ <- toAbstractCtx TopCtx t
let (s, t) = unGeneralized t_
reportSLn "scope.decl" 50 $ "generalizations: " ++ show (Set.toList s, t)
f <- getConcreteFixity x
y <- freshAbstractQName f x
bindName p GeneralizeName x y
let info = (Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' Any
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
mkDefInfo Name
x Fixity'
f Access
p IsAbstract
ConcreteDef Range
r) { defTactic = tac }
return [A.Generalize s info i y t]
C.NiceField Range
r Access
p IsAbstract
a IsInstance
i TacticAttribute
tac Name
x Arg Expr
t -> do
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Access
p Access -> Access -> Bool
forall a. Eq a => a -> a -> Bool
== Access
PublicAccess) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Record fields can not be private"
let maskIP :: Expr -> Expr
maskIP (C.QuestionMark Range
r Maybe Int
_) = Range -> Maybe [Char] -> Expr
C.Underscore Range
r Maybe [Char]
forall a. Maybe a
Nothing
maskIP Expr
e = Expr
e
tac <- (Expr -> ScopeM Expr)
-> TacticAttribute -> TCMT IO (TacticAttribute' Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TacticAttribute' a -> f (TacticAttribute' b)
traverse (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) TacticAttribute
tac
t' <- toAbstractCtx TopCtx $ mapExpr maskIP t
f <- getConcreteFixity x
y <- freshAbstractQName f x
bindName p FldName x y
let info = (Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' Any
forall t.
Name
-> Fixity'
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> Range
-> DefInfo' t
mkDefInfoInstance Name
x Fixity'
f Access
p IsAbstract
a IsInstance
i IsMacro
NotMacroDef Range
r) { defTactic = tac }
return [ A.Field info y t' ]
PrimitiveFunction Range
r Access
p IsAbstract
a Name
x Arg Expr
t -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
notAffectedByOpaque (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
t' <- (Expr -> ScopeM Expr) -> Arg Expr -> TCMT IO (Arg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse (Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx) Arg Expr
t
f <- getConcreteFixity x
y <- freshAbstractQName f x
bindName p PrimName x y
unfoldFunction y
let di = 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
return [ A.Primitive di y t' ]
NiceMutual KwRange
kwr TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.mutual" Int
20 ([Char]
"starting checking mutual definitions: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [NiceDeclaration] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [NiceDeclaration]
ds)
ds' <- [NiceDeclaration] -> ScopeM (AbsOfCon [NiceDeclaration])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NiceDeclaration]
ds
reportSLn "scope.mutual" 20 ("finishing checking mutual definitions")
return [ A.Mutual (MutualInfo tc cc pc (fuseRange kwr ds)) ds' ]
C.NiceRecSig Range
r Erased
er Access
p IsAbstract
a PositivityCheck
_pc UniverseCheck
_uc Name
x [LamBinding' TypedBinding]
ls Expr
t -> do
[LamBinding' TypedBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
ls
ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
(ls', _) <- 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
$
GenTelAndType -> ScopeM (AbsOfCon GenTelAndType)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Telescope -> Expr -> GenTelAndType
GenTelAndType ((LamBinding' TypedBinding -> TypedBinding)
-> [LamBinding' TypedBinding] -> Telescope
forall a b. (a -> b) -> [a] -> [b]
map LamBinding' TypedBinding -> TypedBinding
makeDomainFull [LamBinding' TypedBinding]
ls) Expr
t)
t' <- toAbstract t
f <- getConcreteFixity x
x' <- freshAbstractQName f x
bindName' p RecName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'
return [ A.RecSig (mkDefInfo x f p a r) er x' ls' t' ]
C.NiceDataSig Range
r Erased
er Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding' TypedBinding]
ls Expr
t -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.data.sig" Int
20 ([Char]
"checking DataSig for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
[LamBinding' TypedBinding] -> TCMT IO ()
forall a. EnsureNoLetStms a => a -> TCMT IO ()
ensureNoLetStms [LamBinding' TypedBinding]
ls
ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
ls' <- TCMT IO GeneralizeTelescope -> TCMT IO GeneralizeTelescope
forall a. ScopeM a -> ScopeM a
withCheckNoShadowing (TCMT IO GeneralizeTelescope -> TCMT IO GeneralizeTelescope)
-> TCMT IO GeneralizeTelescope -> TCMT IO GeneralizeTelescope
forall a b. (a -> b) -> a -> b
$
GenTel -> ScopeM (AbsOfCon GenTel)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (GenTel -> ScopeM (AbsOfCon GenTel))
-> GenTel -> ScopeM (AbsOfCon GenTel)
forall a b. (a -> b) -> a -> b
$ Telescope -> GenTel
GenTel (Telescope -> GenTel) -> Telescope -> GenTel
forall a b. (a -> b) -> a -> b
$ (LamBinding' TypedBinding -> TypedBinding)
-> [LamBinding' TypedBinding] -> Telescope
forall a b. (a -> b) -> [a] -> [b]
map LamBinding' TypedBinding -> TypedBinding
makeDomainFull [LamBinding' TypedBinding]
ls
t' <- toAbstract $ C.Generalized t
f <- getConcreteFixity x
x' <- freshAbstractQName f x
mErr <- bindName'' p DataName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'
whenJust mErr $ \case
err :: TypeError
err@(ClashingDefinition QName
cn QName
an Maybe NiceDeclaration
_) -> do
QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) ScopeM ResolvedName -> (ResolvedName -> TCMT IO ()) -> TCMT IO ()
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
DefinedName Access
p AbstractName
ax Suffix
NoSuffix | AbstractName -> KindOfName
anameKind AbstractName
ax KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
AxiomName -> do
let suggestion :: NiceDeclaration
suggestion = Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding' TypedBinding]
-> [NiceDeclaration]
-> NiceDeclaration
NiceDataDef Range
r Origin
Inserted IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding' TypedBinding]
ls []
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition QName
cn QName
an (NiceDeclaration -> Maybe NiceDeclaration
forall a. a -> Maybe a
Just NiceDeclaration
suggestion)
ResolvedName
_ -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
err
TypeError
otherErr -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
otherErr
return [ A.DataSig (mkDefInfo x f p a r) er x' ls' t' ]
C.FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
_ CoverageCheck
_ Name
x Expr
t -> do
let kind :: KindOfName
kind = if IsMacro
m IsMacro -> IsMacro -> Bool
forall a. Eq a => a -> a -> Bool
== IsMacro
MacroDef then KindOfName
MacroName else KindOfName
FunName
Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> TCMT IO Declaration -> ScopeM [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfName -> NiceDeclaration -> TCMT IO Declaration
toAbstractNiceAxiom KindOfName
kind (Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
t)
C.FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
_ CoverageCheck
_ Name
x [Clause]
cs -> do
Int -> [Char] -> TCMT IO ()
printLocals Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"checking def " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
(x',cs) <- (OldName Name, [Clause])
-> ScopeM (AbsOfCon (OldName Name, [Clause]))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (Name -> OldName Name
forall a. a -> OldName a
OldName Name
x,[Clause]
cs)
unlessM ((A.qnameModule x' ==) <$> getCurrentModule) $
__IMPOSSIBLE__
f <- getConcreteFixity x
unfoldFunction x'
di <- updateDefInfoOpacity (mkDefInfoInstance x f PublicAccess a i NotMacroDef r)
return [ A.FunDef di x' cs ]
C.NiceFunClause Range
_ Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ Bool
_ (C.FunClause LHS
lhs RHS' Expr
_ WhereClause' [Declaration]
_ Bool
_) ->
[Char] -> ScopeM [Declaration]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM [Declaration]) -> [Char] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$
[Char]
"Missing type signature for left hand side " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LHS -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow LHS
lhs
C.NiceFunClause{} -> ScopeM [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__
C.NiceDataDef Range
r Origin
o IsAbstract
a PositivityCheck
_ UniverseCheck
uc Name
x [LamBinding' TypedBinding]
pars [NiceDeclaration]
cons -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
notAffectedByOpaque (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.data.def" Int
20 ([Char]
"checking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Origin -> [Char]
forall a. Show a => a -> [Char]
show Origin
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" DataDef for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
(p, ax) <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Access, AbstractName))
-> TCMT IO (Access, AbstractName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
DefinedName Access
p AbstractName
ax Suffix
NoSuffix -> do
Name -> KindOfName -> AbstractName -> TCMT IO ()
clashUnless Name
x KindOfName
DataName AbstractName
ax
AbstractName -> TCMT IO ()
forall a. LivesInCurrentModule a => a -> TCMT IO ()
livesInCurrentModule AbstractName
ax
Name -> AbstractName -> TCMT IO ()
clashIfModuleAlreadyDefinedInCurrentModule Name
x AbstractName
ax
(Access, AbstractName) -> TCMT IO (Access, AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
ResolvedName
_ -> [Char] -> TCMT IO (Access, AbstractName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Access, AbstractName))
-> [Char] -> TCMT IO (Access, AbstractName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing type signature for data definition " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
ensureNoLetStms pars
withLocalVars $ do
gvars <- bindGeneralizablesIfInserted o ax
do cs <- mapM conName cons
unlessNull (duplicates cs) $ \ [Name]
dups -> do
let bad :: [Name]
bad = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
cs
[Name] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Name]
bad (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
DuplicateConstructors [Name]
dups
pars <- catMaybes <$> toAbstract pars
let x' = AbstractName -> QName
anameName AbstractName
ax
checkForModuleClash x
let m = QName -> ModuleName
qnameToMName QName
x'
createModule (Just IsDataModule) m
bindModule p x m
cons <- toAbstract (map (DataConstrDecl m a p) cons)
printScope "data" 20 $ "Checked data " ++ prettyShow x
f <- getConcreteFixity x
return [ A.DataDef (mkDefInfo x f PublicAccess a r) x' uc (DataDefParams gvars pars) cons ]
where
conName :: NiceDeclaration -> ScopeM Name
conName (C.Axiom Range
_ Access
_ IsAbstract
_ IsInstance
_ ArgInfo
_ Name
c Expr
_) = Name -> ScopeM Name
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
c
conName NiceDeclaration
d = NiceDeclaration -> ScopeM Name
forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d
C.NiceRecDef Range
r Origin
o IsAbstract
a PositivityCheck
_ UniverseCheck
uc Name
x [RecordDirective]
directives [LamBinding' TypedBinding]
pars [Declaration]
fields -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
notAffectedByOpaque (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.rec.def" Int
20 ([Char]
"checking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Origin -> [Char]
forall a. Show a => a -> [Char]
show Origin
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" RecDef for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
WhereOrRecord -> [Declaration] -> TCMT IO ()
forall a. FoldDecl a => WhereOrRecord -> a -> TCMT IO ()
checkNoTerminationPragma WhereOrRecord
InRecordDef [Declaration]
fields
RecordDirectives ind eta pat cm <- [RecordDirective] -> ScopeM RecordDirectives
gatherRecordDirectives [RecordDirective]
directives
pat <- case pat of
Just Range
r
| Just (Ranged Range
_ Induction
CoInductive) <- Maybe (Ranged Induction)
ind -> Maybe Range
forall a. Maybe a
Nothing Maybe Range -> TCMT IO () -> TCMT IO (Maybe Range)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> TCMT IO ()
warn [Char]
"coinductive"
| Just (Ranged Range
_ HasEta0
YesEta) <- Maybe (Ranged HasEta0)
eta -> Maybe Range
forall a. Maybe a
Nothing Maybe Range -> TCMT IO () -> TCMT IO (Maybe Range)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> TCMT IO ()
warn [Char]
"eta"
| Bool
otherwise -> Maybe Range -> TCMT IO (Maybe Range)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Range
pat
where warn :: [Char] -> TCMT IO ()
warn = Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ())
-> ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ())
-> ([Char] -> Warning) -> [Char] -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Warning
UselessPatternDeclarationForRecord
Maybe Range
Nothing -> Maybe Range -> TCMT IO (Maybe Range)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Range
pat
(p, ax) <- resolveName (C.QName x) >>= \case
DefinedName Access
p AbstractName
ax Suffix
NoSuffix -> do
Name -> KindOfName -> AbstractName -> TCMT IO ()
clashUnless Name
x KindOfName
RecName AbstractName
ax
AbstractName -> TCMT IO ()
forall a. LivesInCurrentModule a => a -> TCMT IO ()
livesInCurrentModule AbstractName
ax
Name -> AbstractName -> TCMT IO ()
clashIfModuleAlreadyDefinedInCurrentModule Name
x AbstractName
ax
(Access, AbstractName) -> TCMT IO (Access, AbstractName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access
p, AbstractName
ax)
ResolvedName
_ -> [Char] -> TCMT IO (Access, AbstractName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Access, AbstractName))
-> [Char] -> TCMT IO (Access, AbstractName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing type signature for record definition " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
ensureNoLetStms pars
withLocalVars $ do
gvars <- bindGeneralizablesIfInserted o ax
checkForModuleClash x
pars <- catMaybes <$> toAbstract pars
let x' = AbstractName -> QName
anameName AbstractName
ax
contel <- localToAbstract (RecordConstructorType fields) return
m0 <- getCurrentModule
let m = ModuleName -> ModuleName -> ModuleName
A.qualifyM ModuleName
m0 (ModuleName -> ModuleName) -> ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ List1 Name -> ModuleName
mnameFromList1 (List1 Name -> ModuleName) -> List1 Name -> ModuleName
forall a b. (a -> b) -> a -> b
$ Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton (Name -> List1 Name) -> Name -> List1 Name
forall a b. (a -> b) -> a -> b
$ List1 Name -> Name
forall a. NonEmpty a -> a
List1.last (List1 Name -> Name) -> List1 Name -> Name
forall a b. (a -> b) -> a -> b
$ QName -> List1 Name
qnameToList QName
x'
printScope "rec" 15 "before record"
createModule (Just IsRecordModule) m
afields <- withCurrentModule m $ do
afields <- toAbstract (Declarations fields)
printScope "rec" 15 "checked fields"
return afields
do let fs :: [C.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 KwRange
_ [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 (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
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
unlessNull (duplicates fs) $ \ [Name]
dups -> do
let bad :: [Name]
bad = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dups) [Name]
fs
[Name] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Name]
bad (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
DuplicateFields [Name]
dups
bindModule p x m
let kind = KindOfName
-> (Ranged Induction -> KindOfName)
-> Maybe (Ranged Induction)
-> KindOfName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe KindOfName
ConName (Induction -> KindOfName
conKindOfName (Induction -> KindOfName)
-> (Ranged Induction -> Induction)
-> Ranged Induction
-> KindOfName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged Induction -> Induction
forall a. Ranged a -> a
rangedThing) Maybe (Ranged Induction)
ind
cm' <- forM cm $ \ (Name
c, IsInstance
_) -> Name -> KindOfName -> IsAbstract -> Access -> TCMT IO QName
bindRecordConstructorName Name
c KindOfName
kind IsAbstract
a Access
p
let 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
printScope "rec" 15 "record complete"
f <- getConcreteFixity x
let params = Set Name -> [LamBinding] -> DataDefParams
DataDefParams Set Name
gvars [LamBinding]
pars
let dir' = Maybe (Ranged Induction)
-> Maybe (Ranged HasEta0)
-> Maybe Range
-> Maybe QName
-> RecordDirectives' QName
forall a.
Maybe (Ranged Induction)
-> Maybe (Ranged HasEta0)
-> Maybe Range
-> Maybe a
-> RecordDirectives' a
RecordDirectives Maybe (Ranged Induction)
ind Maybe (Ranged HasEta0)
eta Maybe Range
pat Maybe QName
cm'
return [ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' uc dir' params contel afields ]
NiceModule Range
r Access
p IsAbstract
a Erased
e x :: QName
x@(C.QName Name
name) Telescope
tel [Declaration]
ds -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
notAffectedByOpaque (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
[Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking NiceModule " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
]
adecl <- Call -> TCMT IO Declaration -> TCMT IO Declaration
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (NiceDeclaration -> Call
ScopeCheckDeclaration (NiceDeclaration -> Call) -> NiceDeclaration -> Call
forall a b. (a -> b) -> a -> b
$
Range
-> Access
-> IsAbstract
-> Erased
-> QName
-> Telescope
-> [Declaration]
-> NiceDeclaration
NiceModule Range
r Access
p IsAbstract
a Erased
e QName
x Telescope
tel []) (TCMT IO Declaration -> TCMT IO Declaration)
-> TCMT IO Declaration -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$ do
Range
-> Access
-> Erased
-> Name
-> Telescope
-> ScopeM [Declaration]
-> TCMT IO Declaration
scopeCheckNiceModule Range
r Access
p Erased
e Name
name Telescope
tel (ScopeM [Declaration] -> TCMT IO Declaration)
-> ScopeM [Declaration] -> TCMT IO Declaration
forall a b. (a -> b) -> a -> b
$
Declarations -> ScopeM (AbsOfCon Declarations)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([Declaration] -> Declarations
Declarations [Declaration]
ds)
reportSDoc "scope.decl" 70 $ vcat $
[ text $ "scope checked NiceModule " ++ prettyShow x
, nest 2 $ prettyA adecl
]
return [ adecl ]
NiceModule Range
_ Access
_ IsAbstract
_ Erased
_ m :: QName
m@C.Qual{} Telescope
_ [Declaration]
_ ->
[Char] -> ScopeM [Declaration]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM [Declaration]) -> [Char] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ [Char]
"Local modules cannot have qualified names"
NiceModuleMacro Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir -> do
[Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"scope.decl" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"scope checking NiceModuleMacro " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x
]
adecl <- (ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> Declaration)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> TCMT IO Declaration
forall a.
(ToConcrete a, Pretty (ConOfAbs a)) =>
(ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> a)
-> OpenKind
-> Range
-> Access
-> Erased
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> ScopeM a
checkModuleMacro ModuleInfo
-> Erased
-> ModuleName
-> ModuleApplication
-> ScopeCopyInfo
-> ImportDirective
-> Declaration
Apply OpenKind
TopOpenModule
Range
r Access
p Erased
e Name
x ModuleApplication
modapp OpenShortHand
open ImportDirective
dir
reportSDoc "scope.decl" 70 $ vcat $
[ text $ "scope checked NiceModuleMacro " ++ prettyShow x
, nest 2 $ prettyA adecl
]
return [ adecl ]
NiceOpen Range
r QName
x ImportDirective
dir -> do
(minfo, m, adir) <- Range
-> Maybe ModuleName
-> QName
-> ImportDirective
-> ScopeM (ModuleInfo, ModuleName, ImportDirective)
checkOpen Range
r Maybe ModuleName
forall a. Maybe a
Nothing QName
x ImportDirective
dir
return [A.Open minfo m adir]
NicePragma Range
r Pragma
p -> do
ps <- Pragma -> ScopeM (AbsOfCon Pragma)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pragma
p
return $ map (A.Pragma r) ps
NiceImport Range
r QName
x Maybe AsName
as OpenShortHand
open ImportDirective
dir -> Range -> ScopeM [Declaration] -> ScopeM [Declaration]
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
dir <- OpenShortHand -> ImportDirective -> ScopeM ImportDirective
notPublicWithoutOpen OpenShortHand
open ImportDirective
dir
let illformedAs [Char]
s = Maybe AsName
-> TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name))
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Maybe AsName
as (TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name)))
-> TCMT IO (Maybe (AsName' Name)) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ do
Maybe (AsName' Name)
forall a. Maybe a
Nothing Maybe (AsName' Name)
-> TCMT IO () -> TCMT IO (Maybe (AsName' Name))
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning ([Char] -> Warning
IllformedAsClause [Char]
s)
as <- case as of
Maybe AsName
Nothing -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AsName' Name)
forall a. Maybe a
Nothing
Just (AsName (Right Name
asName) Range
r) -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name)))
-> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ AsName' Name -> Maybe (AsName' Name)
forall a. a -> Maybe a
Just (AsName' Name -> Maybe (AsName' Name))
-> AsName' Name -> Maybe (AsName' Name)
forall a b. (a -> b) -> a -> b
$ Name -> Range -> AsName' Name
forall a. a -> Range -> AsName' a
AsName Name
asName Range
r
Just (AsName (Left (C.Ident (C.QName Name
asName))) Range
r) -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name)))
-> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ AsName' Name -> Maybe (AsName' Name)
forall a. a -> Maybe a
Just (AsName' Name -> Maybe (AsName' Name))
-> AsName' Name -> Maybe (AsName' Name)
forall a b. (a -> b) -> a -> b
$ Name -> Range -> AsName' Name
forall a. a -> Range -> AsName' a
AsName Name
asName Range
r
Just (AsName (Left C.Underscore{}) Range
r) -> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name)))
-> Maybe (AsName' Name) -> TCMT IO (Maybe (AsName' Name))
forall a b. (a -> b) -> a -> b
$ AsName' Name -> Maybe (AsName' Name)
forall a. a -> Maybe a
Just (AsName' Name -> Maybe (AsName' Name))
-> AsName' Name -> Maybe (AsName' Name)
forall a b. (a -> b) -> a -> b
$ Name -> Range -> AsName' Name
forall a. a -> Range -> AsName' a
AsName Name
forall a. Underscore a => a
underscore Range
r
Just (AsName (Left (C.Ident C.Qual{})) Range
r) -> [Char] -> TCMT IO (Maybe (AsName' Name))
illformedAs [Char]
"; a qualified name is not allowed here"
Just (AsName (Left Expr
e) Range
r) -> [Char] -> TCMT IO (Maybe (AsName' Name))
illformedAs [Char]
""
top <- S.topLevelModuleName (rawTopLevelModuleNameForQName x)
(m, i) <- withCurrentModule noModuleName $
withTopLevelModule top $ do
m <- toAbstract $ NewModuleQName x
printScope "import" 10 "before import:"
(m, i) <- scopeCheckImport top m
printScope "import" 10 $ "scope checked import: " ++ prettyShow i
return (m, Map.delete noModuleName i)
(name, theAsSymbol, theAsName) <- case as of
Just AsName' Name
a | let y :: Name
y = AsName' Name -> Name
forall a. AsName' a -> a
asName AsName' Name
a, Bool -> Bool
not (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
y) -> do
Access -> Name -> ModuleName -> TCMT IO ()
bindModule Access
privateAccessInserted Name
y ModuleName
m
(QName, Range, Maybe Name) -> TCMT IO (QName, Range, Maybe Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> QName
C.QName Name
y, AsName' Name -> Range
forall a. AsName' a -> Range
asRange AsName' Name
a, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
y)
Maybe (AsName' Name)
_ -> do
Maybe (AsName' Name) -> TCMT IO () -> TCMT IO ()
forall m a. Monoid m => Maybe a -> m -> m
whenNothing Maybe (AsName' Name)
as (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Access -> QName -> ModuleName -> TCMT IO ()
bindQModule (Access
privateAccessInserted) QName
x ModuleName
m
(QName, Range, Maybe Name) -> TCMT IO (QName, Range, Maybe Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
x, Range
forall a. Range' a
noRange, Maybe Name
forall a. Maybe a
Nothing)
adir <- case open of
OpenShortHand
DoOpen -> do
(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
(_minfo, _m, 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
return adir
OpenShortHand
DontOpen -> do
(adir, i') <- (Scope -> ScopeM (ImportDirective, Scope))
-> ModuleName
-> Map ModuleName Scope
-> TCMT IO (ImportDirective, Map ModuleName Scope)
forall (f :: * -> *) k v a.
(Functor f, Ord k) =>
(v -> f (a, v)) -> k -> Map k v -> f (a, Map k v)
Map.adjustM' (QName
-> ImportDirective -> Scope -> ScopeM (ImportDirective, Scope)
applyImportDirectiveM QName
x ImportDirective
dir) ModuleName
m Map ModuleName Scope
i
modifyScopes $ \ Map ModuleName Scope
ms -> (Scope -> Scope -> Scope)
-> Map ModuleName Scope
-> Map ModuleName Scope
-> Map ModuleName Scope
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Scope -> Scope -> Scope
mergeScope Map ModuleName Scope
ms Map ModuleName Scope
i'
return adir
printScope "import" 10 "merged imported sig:"
let minfo = ModuleInfo
{ minfoRange :: Range
minfoRange = Range
r
, minfoAsName :: Maybe Name
minfoAsName = Maybe Name
theAsName
, minfoAsTo :: Range
minfoAsTo = (Range, Range) -> Range
forall a. HasRange a => a -> Range
getRange (Range
theAsSymbol, ImportDirective -> Range
renamingRange ImportDirective
dir)
, minfoOpenShort :: Maybe OpenShortHand
minfoOpenShort = OpenShortHand -> Maybe OpenShortHand
forall a. a -> Maybe a
Just OpenShortHand
open
, minfoDirective :: Maybe ImportDirective
minfoDirective = ImportDirective -> Maybe ImportDirective
forall a. a -> Maybe a
Just ImportDirective
dir
}
return [ A.Import minfo m adir ]
NiceUnquoteDecl Range
r Access
p IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
xs Expr
e -> do
fxs <- (Name -> ScopeM Fixity') -> [Name] -> TCMT IO [Fixity']
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
ys <- zipWithM freshAbstractQName fxs xs
zipWithM_ (bindName p QuotableName) xs ys
e <- toAbstract e
zipWithM_ (rebindName p OtherDefName) xs ys
let mi = TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo TerminationCheck
tc CoverageCheck
cc PositivityCheck
YesPositivityCheck Range
r
mapM_ unfoldFunction ys
opaque <- contextIsOpaque
return [ A.Mutual mi
[ A.UnquoteDecl mi
[ (mkDefInfoInstance x fx p a i NotMacroDef r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ]
ys e
] ]
NiceUnquoteDef Range
r Access
p IsAbstract
a TerminationCheck
_ CoverageCheck
_ [Name]
xs Expr
e -> do
fxs <- (Name -> ScopeM Fixity') -> [Name] -> TCMT IO [Fixity']
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> ScopeM Fixity'
getConcreteFixity [Name]
xs
ys <- mapM (toAbstract . OldName) xs
zipWithM_ (rebindName p QuotableName) xs ys
e <- toAbstract e
zipWithM_ (rebindName p OtherDefName) xs ys
mapM_ unfoldFunction ys
opaque <- contextIsOpaque
return [ A.UnquoteDef [ (mkDefInfo x fx PublicAccess a r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ] ys e ]
NiceUnquoteData Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [Name]
cs Expr
e -> ScopeM [Declaration] -> ScopeM [Declaration]
forall a. ScopeM a -> ScopeM a
notAffectedByOpaque (ScopeM [Declaration] -> ScopeM [Declaration])
-> ScopeM [Declaration] -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ do
fx <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
x' <- freshAbstractQName fx x
bindName p QuotableName x x'
checkForModuleClash x
let m = QName -> ModuleName
qnameToMName QName
x'
createModule (Just IsDataModule) m
bindModule p x m
cs' <- mapM (bindUnquoteConstructorName m p) cs
e <- withCurrentModule m $ toAbstract e
rebindName p DataName x x'
zipWithM_ (rebindName p ConName) cs cs'
withCurrentModule m $ zipWithM_ (rebindName p ConName) cs cs'
fcs <- mapM getConcreteFixity cs
let mi = TerminationCheck
-> CoverageCheck -> PositivityCheck -> Range -> MutualInfo
MutualInfo TerminationCheck
forall m. TerminationCheck m
TerminationCheck CoverageCheck
YesCoverageCheck PositivityCheck
pc Range
r
return
[ A.Mutual
mi [A.UnquoteData
[ mkDefInfo x fx p a r ] x' uc
[ mkDefInfo c fc p a r | (fc, c) <- zip fcs cs] cs' e ]
]
NicePatternSyn Range
r Access
a Name
n [WithHiding Name]
as Pattern
p -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"found nice pattern syn: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
n
(as, p) <- ScopeM ([WithHiding Name], Pattern' Void)
-> ScopeM ([WithHiding Name], Pattern' Void)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM ([WithHiding Name], Pattern' Void)
-> ScopeM ([WithHiding Name], Pattern' Void))
-> ScopeM ([WithHiding Name], Pattern' Void)
-> ScopeM ([WithHiding Name], Pattern' Void)
forall a b. (a -> b) -> a -> b
$ do
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
p <- parsePatternSyn $ applyWhen puns expandPuns p
p <- toAbstract p
when (containsAsPattern p) $
typeError AsPatternInPatternSynonym
checkPatternLinearity p $ \[Name]
ys ->
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
RepeatedVariablesInPattern [Name]
ys
bindVarsToBind
p <- noDotorEqPattern p
as <- mapM checkPatSynParam as
unlessNull (patternVars p List.\\ map whThing as) $ \ [Name]
xs -> do
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeError
UnboundVariablesInPatternSynonym [Name]
xs
return (as, p)
y <- freshAbstractQName' n
bindName a PatternSynName n y
ep <- expandPatternSynonyms p
modifyPatternSyns (Map.insert y (as, ep))
return [A.PatternSynDef y (map (fmap BindName) as) p]
where
checkPatSynParam :: WithHiding C.Name -> ScopeM (WithHiding A.Name)
checkPatSynParam :: WithHiding Name -> TCMT IO (WithHiding Name)
checkPatSynParam (WithHiding Hiding
h Name
x) = do
let err :: TypeError -> TCMT IO (WithHiding Name)
err = Name -> TCMT IO (WithHiding Name) -> TCMT IO (WithHiding Name)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x (TCMT IO (WithHiding Name) -> TCMT IO (WithHiding Name))
-> (TypeError -> TCMT IO (WithHiding Name))
-> TypeError
-> TCMT IO (WithHiding Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCMT IO (WithHiding Name)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError
QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
x) ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (WithHiding Name))
-> TCMT IO (WithHiding Name)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VarName Name
a (PatternBound Hiding
h')
| Hiding -> Bool
forall a. LensHiding a => a -> Bool
isInstance Hiding
h, Bool -> Bool
not (Hiding -> Bool
forall a. LensHiding a => a -> Bool
isInstance Hiding
h') -> TypeError -> TCMT IO (WithHiding Name)
err (TypeError -> TCMT IO (WithHiding Name))
-> TypeError -> TCMT IO (WithHiding Name)
forall a b. (a -> b) -> a -> b
$ Name -> TypeError
IllegalInstanceVariableInPatternSynonym Name
x
| Bool
otherwise -> WithHiding Name -> TCMT IO (WithHiding Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WithHiding Name -> TCMT IO (WithHiding Name))
-> WithHiding Name -> TCMT IO (WithHiding Name)
forall a b. (a -> b) -> a -> b
$ Hiding -> Name -> WithHiding Name
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h Name
a
ConstructorName Set Induction
_ List1 AbstractName
ys -> TypeError -> TCMT IO (WithHiding Name)
err (TypeError -> TCMT IO (WithHiding Name))
-> TypeError -> TCMT IO (WithHiding Name)
forall a b. (a -> b) -> a -> b
$ LHSOrPatSyn -> Name -> List1 AbstractName -> TypeError
PatternSynonymArgumentShadowsConstructorOrPatternSynonym LHSOrPatSyn
IsLHS Name
x List1 AbstractName
ys
PatternSynResName List1 AbstractName
ys -> TypeError -> TCMT IO (WithHiding Name)
err (TypeError -> TCMT IO (WithHiding Name))
-> TypeError -> TCMT IO (WithHiding Name)
forall a b. (a -> b) -> a -> b
$ LHSOrPatSyn -> Name -> List1 AbstractName -> TypeError
PatternSynonymArgumentShadowsConstructorOrPatternSynonym LHSOrPatSyn
IsPatSyn Name
x List1 AbstractName
ys
ResolvedName
UnknownName -> TypeError -> TCMT IO (WithHiding Name)
err (TypeError -> TCMT IO (WithHiding Name))
-> TypeError -> TCMT IO (WithHiding Name)
forall a b. (a -> b) -> a -> b
$ Name -> TypeError
UnusedVariableInPatternSynonym Name
x
ResolvedName
_ -> TCMT IO (WithHiding Name)
forall a. HasCallStack => a
__IMPOSSIBLE__
d :: NiceDeclaration
d@NiceLoneConstructor{} -> (CallStack -> ScopeM [Declaration]) -> ScopeM [Declaration]
forall b. HasCallStack => (CallStack -> b) -> b
withCurrentCallStack ((CallStack -> ScopeM [Declaration]) -> ScopeM [Declaration])
-> (CallStack -> ScopeM [Declaration]) -> ScopeM [Declaration]
forall a b. (a -> b) -> a -> b
$ \ CallStack
stk -> do
Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Warning
NicifierIssue (CallStack -> DeclarationWarning' -> DeclarationWarning
DeclarationWarning CallStack
stk (Range -> DeclarationWarning'
InvalidConstructorBlock (NiceDeclaration -> Range
forall a. HasRange a => a -> Range
getRange NiceDeclaration
d)))
[Declaration] -> ScopeM [Declaration]
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
NiceOpaque KwRange
kwr [QName]
names [NiceDeclaration]
decls -> do
let
r :: Range
r = (KwRange, [QName], [NiceDeclaration]) -> Range
forall a. HasRange a => a -> Range
getRange (KwRange
kwr, [QName]
names, [NiceDeclaration]
decls)
findName :: QName -> TCMT IO QName
findName QName
c = QName -> ScopeM ResolvedName
resolveName QName
c ScopeM ResolvedName
-> (ResolvedName -> TCMT IO QName) -> TCMT IO QName
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
A.DefinedName Access
_ AbstractName
an Suffix
_ -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractName -> QName
anameName AbstractName
an)
A.FieldName (AbstractName
an :| []) -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractName -> QName
anameName AbstractName
an)
A.ConstructorName Set Induction
_ (AbstractName
an :| []) -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractName -> QName
anameName AbstractName
an)
ResolvedName
A.UnknownName -> QName -> TCMT IO QName
forall a. QName -> TCM a
notInScopeError QName
c
ResolvedName
_ -> TypeError -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO QName)
-> (Doc -> TypeError) -> Doc -> TCMT IO QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO QName) -> TCMT IO Doc -> TCMT IO QName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
TCMT IO Doc
"Name in unfolding clause should be unambiguous defined name:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
c
names <- (QName -> TCMT IO QName) -> [QName] -> TCMT IO [QName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse QName -> TCMT IO QName
findName [QName]
names
oid <- fresh
parent <- asksTC envCurrentOpaqueId
stOpaqueBlocks `modifyTCLens` Map.insert oid OpaqueBlock
{ opaqueId = oid
, opaqueUnfolding = HashSet.fromList names
, opaqueDecls = mempty
, opaqueParent = parent
, opaqueRange = r
}
localTC (\TCEnv
e -> TCEnv
e { envCurrentOpaqueId = Just oid }) $ do
out <- traverse toAbstract decls
unless (any interestingOpaqueDecl out) $ setCurrentRange kwr $ warning UselessOpaque
pure $ UnfoldingDecl r names : out
where
toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM A.Declaration
toAbstractNiceAxiom :: KindOfName -> NiceDeclaration -> TCMT IO Declaration
toAbstractNiceAxiom KindOfName
kind (C.Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
info Name
x Expr
t) = do
t' <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
f <- getConcreteFixity x
mp <- getConcretePolarity x
y <- freshAbstractQName f x
let isMacro | KindOfName
kind KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
MacroName = IsMacro
MacroDef
| Bool
otherwise = IsMacro
NotMacroDef
bindName p kind x y
definfo <- updateDefInfoOpacity $ mkDefInfoInstance x f p a i isMacro r
return $ A.Axiom kind definfo info mp y t'
toAbstractNiceAxiom KindOfName
_ NiceDeclaration
_ = TCMT IO Declaration
forall a. HasCallStack => a
__IMPOSSIBLE__
interestingOpaqueDecl :: A.Declaration -> Bool
interestingOpaqueDecl :: Declaration -> Bool
interestingOpaqueDecl (A.Mutual MutualInfo
_ [Declaration]
ds) = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
interestingOpaqueDecl [Declaration]
ds
interestingOpaqueDecl (A.ScopedDecl ScopeInfo
_ [Declaration]
ds) = (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Declaration -> Bool
interestingOpaqueDecl [Declaration]
ds
interestingOpaqueDecl A.FunDef{} = Bool
True
interestingOpaqueDecl A.UnquoteDecl{} = Bool
True
interestingOpaqueDecl A.UnquoteDef{} = Bool
True
interestingOpaqueDecl Declaration
_ = Bool
False
unfoldFunction :: A.QName -> ScopeM ()
unfoldFunction :: QName -> TCMT IO ()
unfoldFunction QName
qn = (TCEnv -> Maybe OpaqueId) -> TCMT IO (Maybe OpaqueId)
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe OpaqueId
envCurrentOpaqueId TCMT IO (Maybe OpaqueId)
-> (Maybe OpaqueId -> TCMT IO ()) -> TCMT IO ()
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just OpaqueId
id -> do
let go :: Maybe OpaqueBlock -> Maybe OpaqueBlock
go Maybe OpaqueBlock
Nothing = Maybe OpaqueBlock
forall a. HasCallStack => a
__IMPOSSIBLE__
go (Just OpaqueBlock
ob) = OpaqueBlock -> Maybe OpaqueBlock
forall a. a -> Maybe a
Just OpaqueBlock
ob{ opaqueDecls = qn `HashSet.insert` opaqueDecls ob }
(Map OpaqueId OpaqueBlock -> f (Map OpaqueId OpaqueBlock))
-> TCState -> f TCState
Lens' TCState (Map OpaqueId OpaqueBlock)
stOpaqueBlocks Lens' TCState (Map OpaqueId OpaqueBlock)
-> (Map OpaqueId OpaqueBlock -> Map OpaqueId OpaqueBlock)
-> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> (a -> a) -> m ()
`modifyTCLens` (Maybe OpaqueBlock -> Maybe OpaqueBlock)
-> OpaqueId -> Map OpaqueId OpaqueBlock -> Map OpaqueId OpaqueBlock
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe OpaqueBlock -> Maybe OpaqueBlock
go OpaqueId
id
Maybe OpaqueId
Nothing -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
contextIsOpaque :: ScopeM IsOpaque
contextIsOpaque :: ScopeM IsOpaque
contextIsOpaque = IsOpaque -> (OpaqueId -> IsOpaque) -> Maybe OpaqueId -> IsOpaque
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IsOpaque
TransparentDef OpaqueId -> IsOpaque
OpaqueDef (Maybe OpaqueId -> IsOpaque)
-> TCMT IO (Maybe OpaqueId) -> ScopeM IsOpaque
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> Maybe OpaqueId) -> TCMT IO (Maybe OpaqueId)
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe OpaqueId
envCurrentOpaqueId
updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo
updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo
updateDefInfoOpacity DefInfo
di = (\IsOpaque
a -> DefInfo
di { Info.defOpaque = a }) (IsOpaque -> DefInfo) -> ScopeM IsOpaque -> ScopeM DefInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM IsOpaque
contextIsOpaque
notAffectedByOpaque :: ScopeM a -> ScopeM a
notAffectedByOpaque :: forall a. ScopeM a -> ScopeM a
notAffectedByOpaque ScopeM a
k = do
t <- (TCEnv -> Bool) -> TCMT IO Bool
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
envCheckingWhere
unless t $
maybe (pure ()) (const (warning NotAffectedByOpaque)) =<< asksTC envCurrentOpaqueId
notUnderOpaque k
unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr)
unGeneralized :: Expr -> (Set QName, Expr)
unGeneralized (A.Generalized Set QName
s Expr
t) = (Set QName
s, Expr
t)
unGeneralized (A.ScopedExpr ScopeInfo
si Expr
e) = ScopeInfo -> Expr -> Expr
A.ScopedExpr ScopeInfo
si (Expr -> Expr) -> (Set QName, Expr) -> (Set QName, Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> (Set QName, Expr)
unGeneralized Expr
e
unGeneralized Expr
t = (Set QName
forall a. Monoid a => a
mempty, Expr
t)
alreadyGeneralizing :: ScopeM Bool
alreadyGeneralizing :: TCMT IO Bool
alreadyGeneralizing = Maybe (Set QName) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Set QName) -> Bool)
-> TCMT IO (Maybe (Set QName)) -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars
collectGeneralizables :: ScopeM a -> ScopeM (Set I.QName, a)
collectGeneralizables :: forall a. ScopeM a -> ScopeM (Set QName, a)
collectGeneralizables ScopeM a
m =
TCMT IO Bool
-> TCMT IO (Set QName, a)
-> TCMT IO (Set QName, a)
-> TCMT IO (Set QName, a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM TCMT IO Bool
alreadyGeneralizing ((Set QName
forall a. Set a
Set.empty,) (a -> (Set QName, a)) -> ScopeM a -> TCMT IO (Set QName, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM a
m) (TCMT IO (Set QName, a) -> TCMT IO (Set QName, a))
-> TCMT IO (Set QName, a) -> TCMT IO (Set QName, a)
forall a b. (a -> b) -> a -> b
$
TCMT IO (Maybe (Set QName))
-> (Maybe (Set QName) -> TCMT IO ())
-> TCMT IO (Set QName, a)
-> TCMT IO (Set QName, a)
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> m ()) -> m b -> m b
bracket_ TCMT IO (Maybe (Set QName))
open Maybe (Set QName) -> TCMT IO ()
close (TCMT IO (Set QName, a) -> TCMT IO (Set QName, a))
-> TCMT IO (Set QName, a) -> TCMT IO (Set QName, a)
forall a b. (a -> b) -> a -> b
$ do
a <- ScopeM a
m
s <- useTC stGeneralizedVars
case s of
Maybe (Set QName)
Nothing -> TCMT IO (Set QName, a)
forall a. HasCallStack => a
__IMPOSSIBLE__
Just Set QName
s -> (Set QName, a) -> TCMT IO (Set QName, a)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set QName
s, a
a)
where
open :: TCMT IO (Maybe (Set QName))
open = do
gvs <- Lens' TCState (Maybe (Set QName)) -> TCMT IO (Maybe (Set QName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useTC (Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars
stGeneralizedVars `setTCLens` Just mempty
pure gvs
close :: Maybe (Set QName) -> TCMT IO ()
close = ((Maybe (Set QName) -> f (Maybe (Set QName)))
-> TCState -> f TCState
Lens' TCState (Maybe (Set QName))
stGeneralizedVars Lens' TCState (Maybe (Set QName))
-> Maybe (Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> a -> m ()
`setTCLens`)
createBoundNamesForGeneralizables :: Set I.QName -> ScopeM (Map I.QName I.Name)
createBoundNamesForGeneralizables :: Set QName -> ScopeM (Map QName Name)
createBoundNamesForGeneralizables Set QName
vs =
((QName -> () -> ScopeM Name)
-> Map QName () -> ScopeM (Map QName Name))
-> Map QName ()
-> (QName -> () -> ScopeM Name)
-> ScopeM (Map QName Name)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QName -> () -> ScopeM Name)
-> Map QName () -> ScopeM (Map QName Name)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey ((QName -> ()) -> Set QName -> Map QName ()
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (() -> QName -> ()
forall a b. a -> b -> a
const ()) Set QName
vs) ((QName -> () -> ScopeM Name) -> ScopeM (Map QName Name))
-> (QName -> () -> ScopeM Name) -> ScopeM (Map QName Name)
forall a b. (a -> b) -> a -> b
$ \ QName
q ()
_ -> do
let x :: Name
x = Name -> Name
nameConcrete (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ QName -> Name
qnameName QName
q
fx :: Fixity'
fx = Name -> Fixity'
nameFixity (Name -> Fixity') -> Name -> Fixity'
forall a b. (a -> b) -> a -> b
$ QName -> Name
qnameName QName
q
Fixity' -> Name -> ScopeM Name
freshAbstractName Fixity'
fx Name
x
collectAndBindGeneralizables :: ScopeM a -> ScopeM (Map I.QName I.Name, a)
collectAndBindGeneralizables :: forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables ScopeM a
m = do
fvBefore <- [(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Name, LocalVar)] -> Int)
-> TCMT IO [(Name, LocalVar)] -> TCMT IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
(s, res) <- collectGeneralizables m
fvAfter <- length <$> getLocalVars
binds <- createBoundNamesForGeneralizables s
outsideLocalVars (fvAfter - fvBefore) $ bindGeneralizables binds
return (binds, 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
bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set A.Name)
bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set Name)
bindGeneralizablesIfInserted Origin
Inserted AbstractName
y = Set Name
bound Set Name -> TCMT IO () -> ScopeM (Set Name)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map QName Name -> TCMT IO ()
bindGeneralizables Map QName Name
gvars
where gvars :: Map QName Name
gvars = case AbstractName -> NameMetadata
anameMetadata AbstractName
y of
GeneralizedVarsMetadata Map QName Name
gvars -> Map QName Name
gvars
NameMetadata
NoMetadata -> Map QName Name
forall k a. Map k a
Map.empty
bound :: Set Name
bound = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Map QName Name -> [Name]
forall k a. Map k a -> [a]
Map.elems Map QName Name
gvars)
bindGeneralizablesIfInserted Origin
UserWritten AbstractName
_ = Set Name -> ScopeM (Set Name)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Set Name
forall a. Set a
Set.empty
bindGeneralizablesIfInserted Origin
_ AbstractName
_ = ScopeM (Set Name)
forall a. HasCallStack => a
__IMPOSSIBLE__
newtype GenTel = GenTel C.Telescope
data GenTelAndType = GenTelAndType C.Telescope C.Expr
instance ToAbstract GenTel where
type AbsOfCon GenTel = A.GeneralizeTelescope
toAbstract :: GenTel -> ScopeM (AbsOfCon GenTel)
toAbstract (GenTel Telescope
tel) =
(Map QName Name -> [TypedBinding] -> GeneralizeTelescope)
-> (Map QName Name, [TypedBinding]) -> GeneralizeTelescope
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map QName Name -> [TypedBinding] -> GeneralizeTelescope
A.GeneralizeTel ((Map QName Name, [TypedBinding]) -> GeneralizeTelescope)
-> TCMT IO (Map QName Name, [TypedBinding])
-> TCMT IO GeneralizeTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [TypedBinding] -> TCMT IO (Map QName Name, [TypedBinding])
forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables ([Maybe TypedBinding] -> [TypedBinding]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TypedBinding] -> [TypedBinding])
-> TCMT IO [Maybe TypedBinding] -> TCMT IO [TypedBinding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ScopeM (AbsOfCon Telescope)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel)
instance ToAbstract GenTelAndType where
type AbsOfCon GenTelAndType = (A.GeneralizeTelescope, A.Expr)
toAbstract :: GenTelAndType -> ScopeM (AbsOfCon GenTelAndType)
toAbstract (GenTelAndType Telescope
tel Expr
t) = do
(binds, (tel, t)) <- ScopeM ([Maybe TypedBinding], Expr)
-> ScopeM (Map QName Name, ([Maybe TypedBinding], Expr))
forall a. ScopeM a -> ScopeM (Map QName Name, a)
collectAndBindGeneralizables (ScopeM ([Maybe TypedBinding], Expr)
-> ScopeM (Map QName Name, ([Maybe TypedBinding], Expr)))
-> ScopeM ([Maybe TypedBinding], Expr)
-> ScopeM (Map QName Name, ([Maybe TypedBinding], Expr))
forall a b. (a -> b) -> a -> b
$
(,) ([Maybe TypedBinding] -> Expr -> ([Maybe TypedBinding], Expr))
-> TCMT IO [Maybe TypedBinding]
-> TCMT IO (Expr -> ([Maybe TypedBinding], Expr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ScopeM (AbsOfCon Telescope)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Telescope
tel TCMT IO (Expr -> ([Maybe TypedBinding], Expr))
-> ScopeM Expr -> ScopeM ([Maybe TypedBinding], Expr)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
t
return (A.GeneralizeTel binds (catMaybes tel), t)
gatherRecordDirectives :: [C.RecordDirective] -> ScopeM C.RecordDirectives
gatherRecordDirectives :: [RecordDirective] -> ScopeM RecordDirectives
gatherRecordDirectives [RecordDirective]
ds = (RecordDirective -> StateT RecordDirectives (TCMT IO) ())
-> [RecordDirective] -> StateT RecordDirectives (TCMT IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RecordDirective -> StateT RecordDirectives (TCMT IO) ()
gatherRecordDirective [RecordDirective]
ds StateT RecordDirectives (TCMT IO) ()
-> RecordDirectives -> ScopeM RecordDirectives
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`execStateT` RecordDirectives
forall a. Null a => a
empty
gatherRecordDirective :: C.RecordDirective -> StateT C.RecordDirectives ScopeM ()
gatherRecordDirective :: RecordDirective -> StateT RecordDirectives (TCMT IO) ()
gatherRecordDirective RecordDirective
d = do
dir@RecordDirectives{ recInductive = ind, recHasEta = eta, recPattern = pat, recConstructor = con } <- StateT RecordDirectives (TCMT IO) RecordDirectives
forall s (m :: * -> *). MonadState s m => m s
get
case d of
Induction Ranged Induction
ri -> Maybe (Ranged Induction)
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a.
Maybe a
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
assertNothing Maybe (Ranged Induction)
ind (StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ())
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ RecordDirectives -> StateT RecordDirectives (TCMT IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RecordDirectives
dir{ recInductive = Just ri }
Eta Ranged HasEta0
re -> Maybe (Ranged HasEta0)
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a.
Maybe a
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
assertNothing Maybe (Ranged HasEta0)
eta (StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ())
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ RecordDirectives -> StateT RecordDirectives (TCMT IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RecordDirectives
dir{ recHasEta = Just re }
PatternOrCopattern Range
r -> Maybe Range
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a.
Maybe a
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
assertNothing Maybe Range
pat (StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ())
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ RecordDirectives -> StateT RecordDirectives (TCMT IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RecordDirectives
dir{ recPattern = Just r }
C.Constructor Name
x IsInstance
inst -> Maybe (Name, IsInstance)
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a.
Maybe a
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
assertNothing Maybe (Name, IsInstance)
con (StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ())
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ RecordDirectives -> StateT RecordDirectives (TCMT IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RecordDirectives
dir{ recConstructor = Just (x, inst) }
where
assertNothing :: Maybe a -> StateT C.RecordDirectives ScopeM () -> StateT C.RecordDirectives ScopeM ()
assertNothing :: forall a.
Maybe a
-> StateT RecordDirectives (TCMT IO) ()
-> StateT RecordDirectives (TCMT IO) ()
assertNothing Maybe a
Nothing StateT RecordDirectives (TCMT IO) ()
cont = StateT RecordDirectives (TCMT IO) ()
cont
assertNothing Just{} StateT RecordDirectives (TCMT IO) ()
_ = TCMT IO () -> StateT RecordDirectives (TCMT IO) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT RecordDirectives m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO () -> StateT RecordDirectives (TCMT IO) ())
-> TCMT IO () -> StateT RecordDirectives (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ RecordDirective -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange RecordDirective
d (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ RecordDirective -> Warning
DuplicateRecordDirective RecordDirective
d
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
m <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
reportS "scope.data.def" 30
[ " A.QName of data type: " ++ prettyShow x
, " current module: " ++ prettyShow m
]
unless (A.qnameModule x == m) $
typeError $ DefinitionInDifferentModule x
clashUnless :: C.Name -> KindOfName -> AbstractName -> ScopeM ()
clashUnless :: Name -> KindOfName -> AbstractName -> TCMT IO ()
clashUnless Name
x KindOfName
k AbstractName
ax = Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AbstractName -> KindOfName
anameKind AbstractName
ax KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
k) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
x) (AbstractName -> QName
anameName AbstractName
ax) Maybe NiceDeclaration
forall a. Maybe a
Nothing
clashIfModuleAlreadyDefinedInCurrentModule :: C.Name -> AbstractName -> ScopeM ()
clashIfModuleAlreadyDefinedInCurrentModule :: Name -> AbstractName -> TCMT IO ()
clashIfModuleAlreadyDefinedInCurrentModule Name
x AbstractName
ax = do
datRecMods <- [Maybe DataOrRecordModule] -> [DataOrRecordModule]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DataOrRecordModule] -> [DataOrRecordModule])
-> TCMT IO [Maybe DataOrRecordModule]
-> TCMT IO [DataOrRecordModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
(AbstractModule -> TCMT IO (Maybe DataOrRecordModule))
-> [AbstractModule] -> TCMT IO [Maybe DataOrRecordModule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ModuleName -> TCMT IO (Maybe DataOrRecordModule)
forall (m :: * -> *).
ReadTCState m =>
ModuleName -> m (Maybe DataOrRecordModule)
isDatatypeModule (ModuleName -> TCMT IO (Maybe DataOrRecordModule))
-> (AbstractModule -> ModuleName)
-> AbstractModule
-> TCMT IO (Maybe DataOrRecordModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractModule -> ModuleName
amodName) ([AbstractModule] -> TCMT IO [Maybe DataOrRecordModule])
-> TCMT IO [AbstractModule] -> TCMT IO [Maybe DataOrRecordModule]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x
unlessNull datRecMods $ const $
typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing
lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]
lookupModuleInCurrentModule :: Name -> TCMT IO [AbstractModule]
lookupModuleInCurrentModule Name
x =
Maybe (List1 AbstractModule) -> [AbstractModule]
forall a. Maybe (List1 a) -> [a]
List1.toList' (Maybe (List1 AbstractModule) -> [AbstractModule])
-> (Scope -> Maybe (List1 AbstractModule))
-> Scope
-> [AbstractModule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name
-> Map Name (List1 AbstractModule) -> Maybe (List1 AbstractModule)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (Map Name (List1 AbstractModule) -> Maybe (List1 AbstractModule))
-> (Scope -> Map Name (List1 AbstractModule))
-> Scope
-> Maybe (List1 AbstractModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> Map Name (List1 AbstractModule)
nsModules (NameSpace -> Map Name (List1 AbstractModule))
-> (Scope -> NameSpace) -> Scope -> Map Name (List1 AbstractModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSpaceId] -> Scope -> NameSpace
thingsInScope [NameSpaceId
PublicNS, NameSpaceId
PrivateNS] (Scope -> [AbstractModule])
-> TCMT IO Scope -> TCMT IO [AbstractModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO Scope
getCurrentScope
data DataConstrDecl = DataConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration
bindConstructorName
:: ModuleName
-> C.Name
-> IsAbstract
-> Access
-> ScopeM A.QName
bindConstructorName :: ModuleName -> Name -> IsAbstract -> Access -> TCMT IO QName
bindConstructorName ModuleName
m Name
x IsAbstract
a Access
p = do
f <- Name -> ScopeM Fixity'
getConcreteFixity Name
x
y <- withCurrentModule m $ freshAbstractQName f x
bindName p' ConName x y
withCurrentModule m $ bindName p'' ConName x y
return y
where
p' :: Access
p' = case IsAbstract
a of
IsAbstract
AbstractDef -> Access
privateAccessInserted
IsAbstract
_ -> Access
p
p'' :: Access
p'' = case IsAbstract
a of
IsAbstract
AbstractDef -> Access
privateAccessInserted
IsAbstract
_ -> Access
PublicAccess
bindRecordConstructorName :: C.Name -> KindOfName -> IsAbstract -> Access -> ScopeM A.QName
bindRecordConstructorName :: Name -> KindOfName -> IsAbstract -> Access -> TCMT IO QName
bindRecordConstructorName Name
x KindOfName
kind IsAbstract
a Access
p = do
y <- Name -> TCMT IO QName
freshAbstractQName' Name
x
bindName p' kind x y
return y
where
p' :: Access
p' = case IsAbstract
a of
IsAbstract
AbstractDef -> Access
privateAccessInserted
IsAbstract
_ -> Access
p
bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> TCM A.QName
bindUnquoteConstructorName :: ModuleName -> Access -> Name -> TCMT IO QName
bindUnquoteConstructorName ModuleName
m Access
p Name
c = do
r <- QName -> ScopeM ResolvedName
resolveName (Name -> QName
C.QName Name
c)
fc <- getConcreteFixity c
c' <- withCurrentModule m $ freshAbstractQName fc c
let aname QName
qn = QName -> KindOfName -> WhyInScope -> NameMetadata -> AbstractName
AbsName QName
qn KindOfName
QuotableName WhyInScope
Defined NameMetadata
NoMetadata
addName = (Scope -> Scope) -> TCMT IO ()
modifyCurrentScope ((Scope -> Scope) -> TCMT IO ()) -> (Scope -> Scope) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NameSpaceId -> Name -> AbstractName -> Scope -> Scope
addNameToScope (Access -> NameSpaceId
localNameSpace Access
p) Name
c (AbstractName -> Scope -> Scope) -> AbstractName -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ QName -> AbstractName
aname QName
c'
success = TCMT IO ()
addName TCMT IO () -> TCMT IO () -> TCMT IO ()
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ModuleName -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(ReadTCState m, MonadTCState m) =>
ModuleName -> m a -> m a
withCurrentModule ModuleName
m (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO ()
addName)
failure QName
y = TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> Maybe NiceDeclaration -> TypeError
ClashingDefinition (Name -> QName
C.QName Name
c) QName
y Maybe NiceDeclaration
forall a. Maybe a
Nothing
case r of
ResolvedName
_ | Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
c -> TCMT IO ()
success
ResolvedName
UnknownName -> TCMT IO ()
success
ConstructorName Set Induction
i List1 AbstractName
ds -> if (AbstractName -> Bool) -> List1 AbstractName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Induction -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Induction -> Bool)
-> (AbstractName -> Maybe Induction) -> AbstractName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindOfName -> Maybe Induction
isConName (KindOfName -> Maybe Induction)
-> (AbstractName -> KindOfName) -> AbstractName -> Maybe Induction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> KindOfName
anameKind) List1 AbstractName
ds
then TCMT IO ()
success
else QName -> TCMT IO ()
failure (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (AbstractName -> QName) -> AbstractName -> QName
forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds
DefinedName Access
_ AbstractName
d Suffix
_ -> QName -> TCMT IO ()
failure (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
FieldName List1 AbstractName
ds -> QName -> TCMT IO ()
failure (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (AbstractName -> QName) -> AbstractName -> QName
forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds
PatternSynResName List1 AbstractName
ds -> QName -> TCMT IO ()
failure (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName (AbstractName -> QName) -> AbstractName -> QName
forall a b. (a -> b) -> a -> b
$ List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
ds
VarName Name
y BindingSource
_ -> QName -> TCMT IO ()
failure (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> QName
qualify_ Name
y
return c'
instance ToAbstract DataConstrDecl where
type AbsOfCon DataConstrDecl = A.Declaration
toAbstract :: DataConstrDecl -> ScopeM (AbsOfCon DataConstrDecl)
toAbstract (DataConstrDecl ModuleName
m IsAbstract
a Access
p NiceDeclaration
d) = do
case NiceDeclaration
d of
C.Axiom Range
r Access
p1 IsAbstract
a1 IsInstance
i ArgInfo
info Name
x Expr
t -> do
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__
t' <- Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx Expr
t
f <- getConcreteFixity x
y <- bindConstructorName m x a p
printScope "con" 15 "bound constructor"
return $ A.Axiom ConName (mkDefInfoInstance x f p a i NotMacroDef r)
info Nothing y t'
NiceDeclaration
_ -> NiceDeclaration -> TCMT IO Declaration
forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d
errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a
errorNotConstrDecl :: forall a. NiceDeclaration -> ScopeM a
errorNotConstrDecl NiceDeclaration
d = NiceDeclaration -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NiceDeclaration
d (TCMT IO a -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$
TypeError -> TCMT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO a) -> TypeError -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ [Declaration] -> TypeError
IllegalDeclarationInDataDefinition ([Declaration] -> TypeError) -> [Declaration] -> TypeError
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> [Declaration]
notSoNiceDeclarations NiceDeclaration
d
instance ToAbstract C.Pragma where
type AbsOfCon C.Pragma = [A.Pragma]
toAbstract :: Pragma -> ScopeM (AbsOfCon Pragma)
toAbstract (C.ImpossiblePragma Range
_ [[Char]]
strs) =
case [[Char]]
strs of
[Char]
"ReduceM" : [[Char]]
_ -> [[Char]] -> TCMT IO [Pragma]
forall a. HasCallStack => [[Char]] -> TCM a
impossibleTestReduceM [[Char]]
strs
[[Char]]
_ -> [[Char]] -> TCMT IO [Pragma]
forall (m :: * -> *) a.
(MonadDebug m, HasCallStack) =>
[[Char]] -> m a
impossibleTest [[Char]]
strs
toAbstract (C.OptionsPragma Range
_ [[Char]]
opts) = [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ [[Char]] -> Pragma
A.OptionsPragma [[Char]]
opts ]
toAbstract (C.RewritePragma Range
_ Range
_ []) = [] [Pragma] -> TCMT IO () -> TCMT IO [Pragma]
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
EmptyRewritePragma
toAbstract (C.RewritePragma Range
_ Range
r [QName]
xs) = Pragma -> [Pragma]
forall el coll. Singleton el coll => el -> coll
singleton (Pragma -> [Pragma])
-> ([[QName]] -> Pragma) -> [[QName]] -> [Pragma]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [QName] -> Pragma
A.RewritePragma Range
r ([QName] -> Pragma)
-> ([[QName]] -> [QName]) -> [[QName]] -> Pragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[QName]] -> [QName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[QName]] -> [Pragma]) -> TCMT IO [[QName]] -> TCMT IO [Pragma]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
[QName] -> (QName -> TCMT IO [QName]) -> TCMT IO [[QName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QName]
xs ((QName -> TCMT IO [QName]) -> TCMT IO [[QName]])
-> (QName -> TCMT IO [QName]) -> TCMT IO [[QName]]
forall a b. (a -> b) -> a -> b
$ \ QName
x -> do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
case e of
A.Def QName
x -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO [QName]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [QName]) -> [Char] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName
x ]
A.Con AmbiguousQName
x -> [Char] -> TCMT IO [QName]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [QName]) -> [Char] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
A.Var Name
x -> [Char] -> TCMT IO [QName]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [QName]) -> [Char] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [Char]
"REWRITE used on parameter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" instead of on a defined symbol"
Expr
_ -> TCMT IO [QName]
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (C.ForeignPragma Range
_ RString
rb [Char]
s) = [] [Pragma] -> TCMT IO () -> TCMT IO [Pragma]
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> [Char] -> TCMT IO ()
addForeignCode (RString -> [Char]
forall a. Ranged a -> a
rangedThing RString
rb) [Char]
s
toAbstract (C.CompilePragma Range
_ RString
rb QName
x [Char]
s) = do
me <- MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName))
-> MaybeOldQName -> ScopeM (AbsOfCon MaybeOldQName)
forall a b. (a -> b) -> a -> b
$ OldQName -> MaybeOldQName
MaybeOldQName (OldQName -> MaybeOldQName) -> OldQName -> MaybeOldQName
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
case me of
Maybe Expr
Nothing -> [] [Pragma] -> TCMT IO () -> TCMT IO [Pragma]
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ QName -> TCMT IO ()
notInScopeWarning QName
x
Just Expr
e -> do
let err :: [Char] -> TCMT IO QName
err [Char]
what = [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot COMPILE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
y <- case Expr
e of
A.Def QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
err [Char]
"ambiguous projection"
A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Con AmbiguousQName
x -> [Char] -> TCMT IO QName
err [Char]
"ambiguous constructor"
A.PatternSyn{} -> [Char] -> TCMT IO QName
err [Char]
"pattern synonym"
A.Var{} -> [Char] -> TCMT IO QName
err [Char]
"local variable"
Expr
_ -> TCMT IO QName
forall a. HasCallStack => a
__IMPOSSIBLE__
return [ A.CompilePragma rb y s ]
toAbstract (C.StaticPragma Range
_ QName
x) = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
y <- case e of
A.Def QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
[Char]
"STATIC used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
Expr
_ -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of STATIC pragma should be a function"
return [ A.StaticPragma y ]
toAbstract (C.InjectivePragma Range
_ QName
x) = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
y <- case e of
A.Def QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
[Char]
"INJECTIVE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
Expr
_ -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of INJECTIVE pragma should be a defined symbol"
return [ A.InjectivePragma y ]
toAbstract (C.InjectiveForInferencePragma Range
_ QName
x) = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
y <- case e of
A.Def QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
Expr
_ -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"Target of INJECTIVE_FOR_INFERENCE pragma should be a defined symbol"
return [ A.InjectiveForInferencePragma y ]
toAbstract (C.InlinePragma Range
_ Bool
b QName
x) = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
let sINLINE = if Bool
b then [Char]
"INLINE" else [Char]
"NOINLINE"
let ret QName
y = [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> QName -> Pragma
A.InlinePragma Bool
b QName
y ]
case e of
A.Con (AmbQ NonEmpty QName
xs) -> (QName -> TCMT IO [Pragma]) -> [QName] -> TCMT IO [Pragma]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM QName -> TCMT IO [Pragma]
ret ([QName] -> TCMT IO [Pragma]) -> [QName] -> TCMT IO [Pragma]
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> [Item (NonEmpty QName)]
forall l. IsList l => l -> [Item l]
List1.toList NonEmpty QName
xs
A.Def QName
x -> QName -> TCMT IO [Pragma]
ret QName
x
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO [Pragma]
ret QName
x
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO [Pragma]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [Pragma]) -> [Char] -> TCMT IO [Pragma]
forall a b. (a -> b) -> a -> b
$
[Char]
sINLINE [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
Expr
_ -> [Char] -> TCMT IO [Pragma]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO [Pragma]) -> [Char] -> TCMT IO [Pragma]
forall a b. (a -> b) -> a -> b
$ ([Char]
"Target of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Bool -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen Bool
b ([Char]
"NO" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [Char]
"INLINE pragma should be a function or constructor"
toAbstract (C.NotProjectionLikePragma Range
_ QName
x) = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
y <- case e of
A.Def QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
[Char]
"NOT_PROJECTION_LIKE used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
Expr
_ -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Target of NOT_PROJECTION_LIKE pragma should be a function"
return [ A.NotProjectionLikePragma y ]
toAbstract (C.OverlapPragma Range
_ [QName]
xs OverlapMode
i) = do
let
name :: [Char]
name = case OverlapMode
i of
OverlapMode
Overlappable -> [Char]
"OVERLAPPABLE"
OverlapMode
Overlapping -> [Char]
"OVERLAPPING"
OverlapMode
Overlaps -> [Char]
"OVERLAPS"
OverlapMode
Incoherent -> [Char]
"INCOHERENT"
OverlapMode
DefaultOverlap -> [Char]
forall a. HasCallStack => a
__IMPOSSIBLE__
OverlapMode
FieldOverlap -> [Char]
forall a. HasCallStack => a
__IMPOSSIBLE__
single :: QName -> TCMT IO Pragma
single QName
x = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
flip A.OverlapPragma i <$> case e of
A.Def QName
x -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Con AmbiguousQName
c | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Con AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
[Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
A.Proj ProjOrigin
_ AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
A.Proj ProjOrigin
_ AmbiguousQName
x -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$
[Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" used on ambiguous name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AmbiguousQName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow AmbiguousQName
x
Expr
_ -> [Char] -> TCMT IO QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Target of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" pragma should be a function, constructor, or projection"
(QName -> TCMT IO Pragma) -> [QName] -> TCMT IO [Pragma]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse QName -> TCMT IO Pragma
single [QName]
xs
toAbstract (C.BuiltinPragma Range
_ RString
rb QName
qx)
| Just BuiltinId
b' <- Maybe BuiltinId
b, BuiltinId -> Bool
isUntypedBuiltin BuiltinId
b' = do
q <- ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (ResolveQName -> ScopeM (AbsOfCon ResolveQName))
-> ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall a b. (a -> b) -> a -> b
$ QName -> ResolveQName
ResolveQName QName
qx
bindUntypedBuiltin b' q
return [ A.BuiltinPragma rb q ]
| Just BuiltinId
b' <- Maybe BuiltinId
b, BuiltinId -> Bool
isBuiltinNoDef BuiltinId
b' = do
case QName
qx of
C.QName Name
x -> do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((ResolvedName
UnknownName ResolvedName -> ResolvedName -> Bool
forall a. Eq a => a -> a -> Bool
==) (ResolvedName -> Bool) -> ScopeM ResolvedName -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ScopeM ResolvedName
resolveName QName
qx) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ BuiltinId -> Warning
BuiltinDeclaresIdentifier BuiltinId
b'
(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
y <- Name -> TCMT IO QName
freshAbstractQName' Name
x
let kind = KindOfName -> Maybe KindOfName -> KindOfName
forall a. a -> Maybe a -> a
fromMaybe KindOfName
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe KindOfName -> KindOfName) -> Maybe KindOfName -> KindOfName
forall a b. (a -> b) -> a -> b
$ BuiltinId -> Maybe KindOfName
builtinKindOfName BuiltinId
b'
bindName PublicAccess kind x y
return [ A.BuiltinNoDefPragma rb kind y ]
QName
_ -> [Char] -> ScopeM (AbsOfCon Pragma)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> ScopeM (AbsOfCon Pragma))
-> [Char] -> ScopeM (AbsOfCon Pragma)
forall a b. (a -> b) -> a -> b
$
[Char]
"Pragma BUILTIN " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BuiltinId -> [Char]
forall a. IsBuiltin a => a -> [Char]
getBuiltinId BuiltinId
b' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": expected unqualified identifier, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"but found " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
qx
| Bool
otherwise = do
q0 <- ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (ResolveQName -> ScopeM (AbsOfCon ResolveQName))
-> ResolveQName -> ScopeM (AbsOfCon ResolveQName)
forall a b. (a -> b) -> a -> b
$ QName -> ResolveQName
ResolveQName QName
qx
q <- case (q0, b >>= builtinKindOfName, qx) of
(DefinedName Access
acc AbstractName
y Suffix
suffix, Just KindOfName
kind, C.QName Name
x)
| AbstractName -> KindOfName
anameKind AbstractName
y KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
/= KindOfName
kind
, KindOfName
kind KindOfName -> [KindOfName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ KindOfName
PrimName, KindOfName
AxiomName ] -> do
Access -> KindOfName -> Name -> QName -> TCMT IO ()
rebindName Access
acc KindOfName
kind Name
x (QName -> TCMT IO ()) -> QName -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
y
ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedName -> ScopeM ResolvedName)
-> ResolvedName -> ScopeM ResolvedName
forall a b. (a -> b) -> a -> b
$ Access -> AbstractName -> Suffix -> ResolvedName
DefinedName Access
acc AbstractName
y{ anameKind = kind } Suffix
suffix
(ResolvedName, Maybe KindOfName, QName)
_ -> ResolvedName -> ScopeM ResolvedName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResolvedName
q0
return [ A.BuiltinPragma rb q ]
where b :: Maybe BuiltinId
b = [Char] -> Maybe BuiltinId
builtinById (RString -> [Char]
forall a. Ranged a -> a
rangedThing RString
rb)
toAbstract (C.EtaPragma Range
_ QName
x) = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (OldQName -> ScopeM (AbsOfCon OldQName))
-> OldQName -> ScopeM (AbsOfCon OldQName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
case e of
A.Def QName
x -> [Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ QName -> Pragma
A.EtaPragma QName
x ]
Expr
_ -> do
e <- Expr -> TCMT IO [Char]
forall a (m :: * -> *).
(ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) =>
a -> m [Char]
showA Expr
e
genericError $ "Pragma ETA: expected identifier, " ++
"but found expression " ++ e
toAbstract (C.DisplayPragma Range
_ Pattern
lhs Expr
rhs) = ScopeM (AbsOfCon Pragma) -> ScopeM (AbsOfCon Pragma)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM (AbsOfCon Pragma) -> ScopeM (AbsOfCon Pragma))
-> ScopeM (AbsOfCon Pragma) -> ScopeM (AbsOfCon Pragma)
forall a b. (a -> b) -> a -> b
$ do
let err :: TCMT IO a
err = [Char] -> TCMT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"DISPLAY pragma left-hand side must have form 'f e1 .. en'"
getHead :: Pattern -> TCMT IO QName
getHead (C.IdentP Bool
_ QName
x) = QName -> TCMT IO QName
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
x
getHead (C.RawAppP Range
_ (List2 Pattern
p Pattern
_ [Pattern]
_)) = Pattern -> TCMT IO QName
getHead Pattern
p
getHead Pattern
_ = TCMT IO QName
forall {a}. TCMT IO a
err
top <- Pattern -> TCMT IO QName
getHead Pattern
lhs
(isPatSyn, hd) <- do
qx <- resolveName' allKindsOfNames Nothing top
case qx of
VarName Name
x' BindingSource
_ -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ List1 Name -> QName
A.qnameFromList (List1 Name -> QName) -> List1 Name -> QName
forall a b. (a -> b) -> a -> b
$ Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
x'
DefinedName Access
_ AbstractName
d Suffix
NoSuffix -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
DefinedName Access
_ AbstractName
d Suffix{} -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid pattern " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top
FieldName (AbstractName
d :| []) -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
FieldName List1 AbstractName
ds -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous projection " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
ConstructorName Set Induction
_ (AbstractName
d :| []) -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
ConstructorName Set Induction
_ List1 AbstractName
ds -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous constructor " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
ResolvedName
UnknownName -> QName -> TCMT IO (Bool, QName)
forall a. QName -> TCM a
notInScopeError QName
top
PatternSynResName (AbstractName
d :| []) -> (Bool, QName) -> TCMT IO (Bool, QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, QName) -> TCMT IO (Bool, QName))
-> (QName -> (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
True,) (QName -> TCMT IO (Bool, QName)) -> QName -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ AbstractName -> QName
anameName AbstractName
d
PatternSynResName List1 AbstractName
ds -> [Char] -> TCMT IO (Bool, QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (Bool, QName))
-> [Char] -> TCMT IO (Bool, QName)
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous pattern synonym" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
top [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
lhs <- toAbstract $ LeftHandSide top lhs
ps <- case lhs of
A.LHS LHSInfo
_ (A.LHSHead QName
_ [NamedArg Pattern]
ps) -> [NamedArg Pattern] -> TCMT IO [NamedArg Pattern]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [NamedArg Pattern]
ps
LHS
_ -> TCMT IO [NamedArg Pattern]
forall {a}. TCMT IO a
err
(hd, ps) <- do
let mkP | Bool
isPatSyn = PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP (Range -> PatInfo
PatRange (Range -> PatInfo) -> Range -> PatInfo
forall a b. (a -> b) -> a -> b
$ LHS -> Range
forall a. HasRange a => a -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
| Bool
otherwise = PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP (Range -> PatInfo
PatRange (Range -> PatInfo) -> Range -> PatInfo
forall a b. (a -> b) -> a -> b
$ LHS -> Range
forall a. HasRange a => a -> Range
getRange LHS
lhs) (QName -> AmbiguousQName
unambiguous QName
hd)
p <- expandPatternSynonyms $ mkP ps
case p of
A.DefP PatInfo
_ AmbiguousQName
f [NamedArg Pattern]
ps | Just QName
hd <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
f -> (QName, [NamedArg Pattern]) -> TCMT IO (QName, [NamedArg Pattern])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
hd, [NamedArg Pattern]
ps)
A.ConP ConPatInfo
_ AmbiguousQName
c [NamedArg Pattern]
ps | Just QName
hd <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c -> (QName, [NamedArg Pattern]) -> TCMT IO (QName, [NamedArg Pattern])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
hd, [NamedArg Pattern]
ps)
A.PatternSynP{} -> TCMT IO (QName, [NamedArg Pattern])
forall a. HasCallStack => a
__IMPOSSIBLE__
Pattern
_ -> TCMT IO (QName, [NamedArg Pattern])
forall {a}. TCMT IO a
err
rhs <- toAbstract rhs
return [A.DisplayPragma hd ps rhs]
toAbstract (C.WarningOnUsage Range
_ QName
x Text
str) = do
ys <- (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName (List1 AbstractName -> NonEmpty QName)
-> ScopeM (List1 AbstractName) -> TCMT IO (NonEmpty QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ScopeM (List1 AbstractName)
forall a. ToQName a => a -> ScopeM (List1 AbstractName)
toAbstractExistingName QName
x
forM_ ys $ \ QName
qn -> (Map QName Text -> f (Map QName Text)) -> TCState -> f TCState
Lens' TCState (Map QName Text)
stLocalUserWarnings Lens' TCState (Map QName Text)
-> (Map QName Text -> Map QName Text) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> (a -> a) -> m ()
`modifyTCLens` QName -> Text -> Map QName Text -> Map QName Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QName
qn Text
str
return []
toAbstract (C.WarningOnImport Range
_ Text
str) = do
(Maybe Text -> f (Maybe Text)) -> TCState -> f TCState
Lens' TCState (Maybe Text)
stWarningOnImport Lens' TCState (Maybe Text) -> Maybe Text -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> a -> m ()
`setTCLens` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
str
[Pragma] -> TCMT IO [Pragma]
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
toAbstract C.TerminationCheckPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract C.NoCoverageCheckPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract C.NoPositivityCheckPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract C.NoUniverseCheckPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract C.CatchallPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract C.PolarityPragma{} = TCMT IO [Pragma]
ScopeM (AbsOfCon Pragma)
forall a. HasCallStack => a
__IMPOSSIBLE__
instance ToAbstract C.Clause where
type AbsOfCon C.Clause = A.Clause
toAbstract :: Clause -> ScopeM (AbsOfCon Clause)
toAbstract (C.Clause Name
top Bool
catchall lhs :: LHS
lhs@(C.LHS Pattern
p [RewriteEqn]
eqs [WithExpr]
with) RHS' Expr
rhs WhereClause' [Declaration]
wh [Clause]
wcs) = ScopeM (AbsOfCon Clause) -> ScopeM (AbsOfCon Clause)
forall a. ScopeM a -> ScopeM a
withLocalVars (ScopeM (AbsOfCon Clause) -> ScopeM (AbsOfCon Clause))
-> ScopeM (AbsOfCon Clause) -> ScopeM (AbsOfCon Clause)
forall a b. (a -> b) -> a -> b
$ do
(ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(ScopeInfo -> ScopeInfo) -> m ()
modifyScope_ ((ScopeInfo -> ScopeInfo) -> TCMT IO ())
-> (ScopeInfo -> ScopeInfo) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ([(Name, LocalVar)] -> [(Name, LocalVar)])
-> ScopeInfo -> ScopeInfo
updateScopeLocals (([(Name, LocalVar)] -> [(Name, LocalVar)])
-> ScopeInfo -> ScopeInfo)
-> ([(Name, LocalVar)] -> [(Name, LocalVar)])
-> ScopeInfo
-> ScopeInfo
forall a b. (a -> b) -> a -> b
$ ((Name, LocalVar) -> (Name, LocalVar))
-> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a b. (a -> b) -> [a] -> [b]
map (((Name, LocalVar) -> (Name, LocalVar))
-> [(Name, LocalVar)] -> [(Name, LocalVar)])
-> ((Name, LocalVar) -> (Name, LocalVar))
-> [(Name, LocalVar)]
-> [(Name, LocalVar)]
forall a b. (a -> b) -> a -> b
$ (LocalVar -> LocalVar) -> (Name, LocalVar) -> (Name, LocalVar)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second LocalVar -> LocalVar
patternToModuleBound
vars0 <- TCMT IO [(Name, LocalVar)]
forall (m :: * -> *). ReadTCState m => m [(Name, LocalVar)]
getLocalVars
lhs' <- toAbstract $ LeftHandSide (C.QName top) p
printLocals 10 "after lhs:"
vars1 <- getLocalVars
eqs <- mapM (toAbstractCtx TopCtx) eqs
vars2 <- getLocalVars
let vars = Int -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. Int -> [a] -> [a]
dropEnd ([(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, LocalVar)]
vars1) [(Name, LocalVar)]
vars2 [(Name, LocalVar)] -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, LocalVar)]
vars0
let wcs' = ([(Name, LocalVar)]
vars, [Clause]
wcs)
if not (null eqs)
then do
rhs <- toAbstractCtx TopCtx $ RightHandSide eqs with wcs' rhs wh
rhs <- toAbstract rhs
return $ A.Clause lhs' [] rhs A.noWhereDecls catchall
else do
(rhs, ds) <- whereToAbstract (getRange wh) wh $
toAbstractCtx TopCtx $ RightHandSide [] with wcs' rhs NoWhere
rhs <- toAbstract rhs
return $ A.Clause lhs' [] rhs ds catchall
whereToAbstract
:: Range
-> C.WhereClause
-> ScopeM a
-> ScopeM (a, A.WhereDeclarations)
whereToAbstract :: forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract Range
r WhereClause' [Declaration]
wh ScopeM a
inner = do
case WhereClause' [Declaration]
wh of
WhereClause' [Declaration]
NoWhere -> ScopeM (a, WhereDeclarations)
ret
AnyWhere Range
_ [] -> ScopeM (a, WhereDeclarations)
warnEmptyWhere
AnyWhere Range
_ [Declaration]
ds -> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a. ScopeM a -> ScopeM a
enter (ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$ do
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
forall a.
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Erased
defaultErased Maybe (Name, Access)
forall a. Maybe a
Nothing
(Declaration -> List1 Declaration
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> List1 Declaration)
-> Declaration -> List1 Declaration
forall a b. (a -> b) -> a -> b
$ KwRange -> Origin -> [Declaration] -> Declaration
C.Private KwRange
forall a. Null a => a
empty Origin
Inserted [Declaration]
ds) ScopeM a
inner
SomeWhere Range
_ Erased
e Name
m Access
a [Declaration]
ds0 -> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a. ScopeM a -> ScopeM a
enter (ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations) -> ScopeM (a, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
[Declaration]
-> ScopeM (a, WhereDeclarations)
-> (List1 Declaration -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations)
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [Declaration]
ds0 ScopeM (a, WhereDeclarations)
warnEmptyWhere ((List1 Declaration -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations))
-> (List1 Declaration -> ScopeM (a, WhereDeclarations))
-> ScopeM (a, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$ \List1 Declaration
ds -> do
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
forall a.
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Erased
e ((Name, Access) -> Maybe (Name, Access)
forall a. a -> Maybe a
Just (Name
m, Access
a)) List1 Declaration
ds ScopeM a
inner
where
enter :: TCMT IO a -> TCMT IO a
enter = (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall a. (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC ((TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a)
-> (TCEnv -> TCEnv) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ \TCEnv
env -> TCEnv
env { envCheckingWhere = True }
ret :: ScopeM (a, WhereDeclarations)
ret = (,WhereDeclarations
A.noWhereDecls) (a -> (a, WhereDeclarations))
-> ScopeM a -> ScopeM (a, WhereDeclarations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScopeM a
inner
warnEmptyWhere :: ScopeM (a, WhereDeclarations)
warnEmptyWhere = do
Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning Warning
EmptyWhere
ScopeM (a, WhereDeclarations)
ret
whereToAbstract1
:: Range
-> Erased
-> Maybe (C.Name, Access)
-> List1 C.Declaration
-> ScopeM a
-> ScopeM (a, A.WhereDeclarations)
whereToAbstract1 :: forall a.
Range
-> Erased
-> Maybe (Name, Access)
-> List1 Declaration
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract1 Range
r Erased
e Maybe (Name, Access)
whname List1 Declaration
whds ScopeM a
inner = do
WhereOrRecord -> List1 Declaration -> TCMT IO ()
forall a. FoldDecl a => WhereOrRecord -> a -> TCMT IO ()
checkNoTerminationPragma WhereOrRecord
InWhereBlock List1 Declaration
whds
(m, acc) <- do
case Maybe (Name, Access)
whname of
Just (Name
m, Access
acc) | Bool -> Bool
not (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
m) -> (Name, Access) -> TCMT IO (Name, Access)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
m, Access
acc)
Maybe (Name, Access)
_ -> TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh TCMT IO NameId
-> (NameId -> (Name, Access)) -> TCMT IO (Name, Access)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ NameId
x -> (Range -> NameId -> Name
C.NoName (Maybe (Name, Access) -> Range
forall a. HasRange a => a -> Range
getRange Maybe (Name, Access)
whname) NameId
x, Access
privateAccessInserted)
old <- getCurrentModule
am <- toAbstract (NewModuleName m)
(scope, d) <- scopeCheckModule r e (C.QName m) am [] $
toAbstract $ Declarations $ List1.toList whds
setScope scope
x <- inner
setCurrentModule old
bindModule acc m am
let 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
when anonymousSomeWhere $
void $
openModule TopOpenModule (Just am) (C.QName m) $
defaultImportDir { publicOpen = Just empty }
return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d)
data TerminationOrPositivity = Termination | Positivity
deriving (Int -> TerminationOrPositivity -> [Char] -> [Char]
[TerminationOrPositivity] -> [Char] -> [Char]
TerminationOrPositivity -> [Char]
(Int -> TerminationOrPositivity -> [Char] -> [Char])
-> (TerminationOrPositivity -> [Char])
-> ([TerminationOrPositivity] -> [Char] -> [Char])
-> Show TerminationOrPositivity
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TerminationOrPositivity -> [Char] -> [Char]
showsPrec :: Int -> TerminationOrPositivity -> [Char] -> [Char]
$cshow :: TerminationOrPositivity -> [Char]
show :: TerminationOrPositivity -> [Char]
$cshowList :: [TerminationOrPositivity] -> [Char] -> [Char]
showList :: [TerminationOrPositivity] -> [Char] -> [Char]
Show)
data WhereOrRecord = InWhereBlock | InRecordDef
checkNoTerminationPragma :: FoldDecl a => WhereOrRecord -> a -> ScopeM ()
checkNoTerminationPragma :: forall a. FoldDecl a => WhereOrRecord -> a -> TCMT IO ()
checkNoTerminationPragma WhereOrRecord
b a
ds =
[(TerminationOrPositivity, Range)]
-> ((TerminationOrPositivity, Range) -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Declaration -> [(TerminationOrPositivity, Range)])
-> a -> [(TerminationOrPositivity, Range)]
forall m. Monoid m => (Declaration -> m) -> a -> m
forall a m. (FoldDecl a, Monoid m) => (Declaration -> m) -> a -> m
foldDecl (Declaration -> [Pragma]
forall m. CMaybe Pragma m => Declaration -> m
isPragma (Declaration -> [Pragma])
-> (Pragma -> [(TerminationOrPositivity, Range)])
-> Declaration
-> [(TerminationOrPositivity, Range)]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Pragma -> [(TerminationOrPositivity, Range)]
isTerminationPragma) a
ds) \ (TerminationOrPositivity
p, Range
r) ->
Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Range -> Doc -> Warning
UselessPragma Range
r (Doc -> Warning) -> Doc -> Warning
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
P.vcat
[ [Char] -> Doc
forall a. [Char] -> Doc a
P.text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ TerminationOrPositivity -> [Char]
forall a. Show a => a -> [Char]
show TerminationOrPositivity
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" pragmas are ignored in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WhereOrRecord -> [Char]
forall {a}. IsString a => WhereOrRecord -> a
what WhereOrRecord
b
, [Char] -> Doc
forall a. [Char] -> Doc a
P.text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"(see " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WhereOrRecord -> [Char]
issue WhereOrRecord
b [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
]
where
what :: WhereOrRecord -> a
what WhereOrRecord
InWhereBlock = a
"where clauses"
what WhereOrRecord
InRecordDef = a
"record definitions"
github :: a -> [Char]
github a
n = [Char]
"https://github.com/agda/agda/issues/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
n
issue :: WhereOrRecord -> [Char]
issue WhereOrRecord
InWhereBlock = Integer -> [Char]
forall a. Show a => a -> [Char]
github Integer
3355
issue WhereOrRecord
InRecordDef = Integer -> [Char]
forall a. Show a => a -> [Char]
github Integer
3008
isTerminationPragma :: C.Pragma -> [(TerminationOrPositivity, Range)]
isTerminationPragma :: Pragma -> [(TerminationOrPositivity, Range)]
isTerminationPragma = \case
C.TerminationCheckPragma Range
r TerminationCheck
_ -> [(TerminationOrPositivity
Termination, Range
r)]
C.NoPositivityCheckPragma Range
r -> [(TerminationOrPositivity
Positivity, Range
r)]
C.OptionsPragma Range
_ [[Char]]
_ -> []
C.BuiltinPragma Range
_ RString
_ QName
_ -> []
C.RewritePragma Range
_ Range
_ [QName]
_ -> []
C.ForeignPragma Range
_ RString
_ [Char]
_ -> []
C.CompilePragma Range
_ RString
_ QName
_ [Char]
_ -> []
C.StaticPragma Range
_ QName
_ -> []
C.InlinePragma Range
_ Bool
_ QName
_ -> []
C.ImpossiblePragma Range
_ [[Char]]
_ -> []
C.EtaPragma Range
_ QName
_ -> []
C.WarningOnUsage Range
_ QName
_ Text
_ -> []
C.WarningOnImport Range
_ Text
_ -> []
C.InjectivePragma Range
_ QName
_ -> []
C.InjectiveForInferencePragma{} -> []
C.DisplayPragma Range
_ Pattern
_ Expr
_ -> []
C.CatchallPragma Range
_ -> []
C.NoCoverageCheckPragma Range
_ -> []
C.PolarityPragma Range
_ Name
_ [Occurrence]
_ -> []
C.NoUniverseCheckPragma Range
_ -> []
C.NotProjectionLikePragma Range
_ QName
_ -> []
C.OverlapPragma Range
_ [QName]
_ OverlapMode
_ -> []
data RightHandSide = RightHandSide
{ RightHandSide -> [RewriteEqn' () BindName Pattern Expr]
_rhsRewriteEqn :: [RewriteEqn' () A.BindName A.Pattern A.Expr]
, RightHandSide -> [WithExpr]
_rhsWithExpr :: [C.WithExpr]
, RightHandSide -> ([(Name, LocalVar)], [Clause])
_rhsSubclauses :: (LocalVars, [C.Clause])
, RightHandSide -> RHS' Expr
_rhs :: C.RHS
, RightHandSide -> WhereClause' [Declaration]
_rhsWhere :: WhereClause
}
data AbstractRHS
= AbsurdRHS'
| WithRHS' [A.WithExpr] (List1 (ScopeM C.Clause))
| RHS' A.Expr C.Expr
| RewriteRHS' [RewriteEqn' () A.BindName A.Pattern A.Expr] AbstractRHS A.WhereDeclarations
qualifyName_ :: A.Name -> ScopeM A.QName
qualifyName_ :: Name -> TCMT IO QName
qualifyName_ Name
x = do
m <- TCMT IO ModuleName
forall (m :: * -> *). ReadTCState m => m ModuleName
getCurrentModule
return $ A.qualify m x
withFunctionName :: String -> ScopeM A.QName
withFunctionName :: [Char] -> TCMT IO QName
withFunctionName [Char]
s = do
NameId i _ <- TCMT IO NameId
forall i (m :: * -> *). MonadFresh i m => m i
fresh
qualifyName_ =<< freshName_ (s ++ show i)
instance ToAbstract (RewriteEqn' () A.BindName A.Pattern A.Expr) where
type AbsOfCon (RewriteEqn' () A.BindName A.Pattern A.Expr) = A.RewriteEqn
toAbstract :: RewriteEqn' () BindName Pattern Expr
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
toAbstract = \case
Rewrite List1 ((), Expr)
es -> (List1 (QName, Expr)
-> AbsOfCon (RewriteEqn' () BindName Pattern Expr))
-> TCMT IO (List1 (QName, Expr))
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap List1 (QName, Expr) -> RewriteEqn' QName BindName Pattern Expr
List1 (QName, Expr)
-> AbsOfCon (RewriteEqn' () BindName Pattern Expr)
forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite (TCMT IO (List1 (QName, Expr))
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr)))
-> TCMT IO (List1 (QName, Expr))
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
forall a b. (a -> b) -> a -> b
$ List1 ((), Expr)
-> (((), Expr) -> TCMT IO (QName, Expr))
-> TCMT IO (List1 (QName, Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 ((), Expr)
es ((((), Expr) -> TCMT IO (QName, Expr))
-> TCMT IO (List1 (QName, Expr)))
-> (((), Expr) -> TCMT IO (QName, Expr))
-> TCMT IO (List1 (QName, Expr))
forall a b. (a -> b) -> a -> b
$ \ (()
_, Expr
e) -> do
qn <- [Char] -> TCMT IO QName
withFunctionName [Char]
"-rewrite"
pure (qn, e)
Invert ()
_ List1 (Named BindName (Pattern, Expr))
pes -> do
qn <- [Char] -> TCMT IO QName
withFunctionName [Char]
"-invert"
pure $ Invert qn pes
LeftLet List1 (Pattern, Expr)
pes -> AbsOfCon (RewriteEqn' () BindName Pattern Expr)
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsOfCon (RewriteEqn' () BindName Pattern Expr)
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr)))
-> AbsOfCon (RewriteEqn' () BindName Pattern Expr)
-> ScopeM (AbsOfCon (RewriteEqn' () BindName Pattern Expr))
forall a b. (a -> b) -> a -> b
$ List1 (Pattern, Expr) -> RewriteEqn' QName BindName Pattern Expr
forall qn nm p e. List1 (p, e) -> RewriteEqn' qn nm p e
LeftLet List1 (Pattern, Expr)
pes
instance ToAbstract C.RewriteEqn where
type AbsOfCon C.RewriteEqn = RewriteEqn' () A.BindName A.Pattern A.Expr
toAbstract :: RewriteEqn -> ScopeM (AbsOfCon RewriteEqn)
toAbstract = \case
Rewrite List1 ((), Expr)
es -> List1 ((), Expr) -> RewriteEqn' () BindName Pattern Expr
forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite (List1 ((), Expr) -> RewriteEqn' () BindName Pattern Expr)
-> TCMT IO (List1 ((), Expr))
-> TCMT IO (RewriteEqn' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((), Expr) -> TCMT IO ((), Expr))
-> List1 ((), Expr) -> TCMT IO (List1 ((), Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((), Expr) -> TCMT IO ((), Expr)
((), Expr) -> ScopeM (AbsOfCon ((), Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract List1 ((), Expr)
es
Invert ()
_ List1 (Named Name (Pattern, Expr))
npes -> ()
-> List1 (Named BindName (Pattern, Expr))
-> RewriteEqn' () BindName Pattern Expr
forall qn nm p e.
qn -> List1 (Named nm (p, e)) -> RewriteEqn' qn nm p e
Invert () (List1 (Named BindName (Pattern, Expr))
-> RewriteEqn' () BindName Pattern Expr)
-> TCMT IO (List1 (Named BindName (Pattern, Expr)))
-> TCMT IO (RewriteEqn' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
let (NonEmpty (Maybe Name, Pattern)
nps, List1 Expr
es) = NonEmpty ((Maybe Name, Pattern), Expr)
-> (NonEmpty (Maybe Name, Pattern), List1 Expr)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
List1.unzip
(NonEmpty ((Maybe Name, Pattern), Expr)
-> (NonEmpty (Maybe Name, Pattern), List1 Expr))
-> NonEmpty ((Maybe Name, Pattern), Expr)
-> (NonEmpty (Maybe Name, Pattern), List1 Expr)
forall a b. (a -> b) -> a -> b
$ (Named Name (Pattern, Expr) -> ((Maybe Name, Pattern), Expr))
-> List1 (Named Name (Pattern, Expr))
-> NonEmpty ((Maybe Name, Pattern), Expr)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Named Maybe Name
nm (Pattern
p, Expr
e)) -> ((Maybe Name
nm, Pattern
p), Expr
e)) List1 (Named Name (Pattern, Expr))
npes
es <- List1 Expr -> ScopeM (AbsOfCon (List1 Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract List1 Expr
es
nps <- forM nps $ \ (Maybe Name
n, Pattern
p) -> do
p <- Pattern -> TCMT IO Pattern
toAbsPat Pattern
p
n <- toAbstract $ fmap (NewName WithBound . C.mkBoundName_) n
pure (n, p)
pure $ List1.zipWith (\ (Maybe BindName
n,Pattern
p) Expr
e -> Maybe BindName -> (Pattern, Expr) -> Named BindName (Pattern, Expr)
forall name a. Maybe name -> a -> Named name a
Named Maybe BindName
n (Pattern
p, Expr
e)) nps es
LeftLet List1 (Pattern, Expr)
pes -> (List1 (Pattern, Expr) -> AbsOfCon RewriteEqn)
-> TCMT IO (List1 (Pattern, Expr)) -> ScopeM (AbsOfCon RewriteEqn)
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap List1 (Pattern, Expr) -> RewriteEqn' () BindName Pattern Expr
List1 (Pattern, Expr) -> AbsOfCon RewriteEqn
forall qn nm p e. List1 (p, e) -> RewriteEqn' qn nm p e
LeftLet (TCMT IO (List1 (Pattern, Expr)) -> ScopeM (AbsOfCon RewriteEqn))
-> TCMT IO (List1 (Pattern, Expr)) -> ScopeM (AbsOfCon RewriteEqn)
forall a b. (a -> b) -> a -> b
$ List1 (Pattern, Expr)
-> ((Pattern, Expr) -> TCMT IO (Pattern, Expr))
-> TCMT IO (List1 (Pattern, Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 (Pattern, Expr)
pes (((Pattern, Expr) -> TCMT IO (Pattern, Expr))
-> TCMT IO (List1 (Pattern, Expr)))
-> ((Pattern, Expr) -> TCMT IO (Pattern, Expr))
-> TCMT IO (List1 (Pattern, Expr))
forall a b. (a -> b) -> a -> b
$ \ (Pattern
p, Expr
e) -> do
e <- Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
p <- toAbsPat p
pure (p, e)
where
toAbsPat :: Pattern -> TCMT IO Pattern
toAbsPat Pattern
p = do
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
p <- return $ if puns then expandPuns p else p
p <- parsePattern p
p <- toAbstract p
checkPatternLinearity p (typeError . RepeatedVariablesInPattern)
bindVarsToBind
toAbstract p
instance ToAbstract AbstractRHS where
type AbsOfCon AbstractRHS = A.RHS
toAbstract :: AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
toAbstract AbstractRHS
AbsurdRHS' = RHS -> TCMT IO RHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RHS
A.AbsurdRHS
toAbstract (RHS' Expr
e Expr
c) = AbsOfCon AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon AbstractRHS -> ScopeM (AbsOfCon AbstractRHS))
-> AbsOfCon AbstractRHS -> ScopeM (AbsOfCon AbstractRHS)
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr -> RHS
A.RHS Expr
e (Maybe Expr -> RHS) -> Maybe Expr -> RHS
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
c
toAbstract (RewriteRHS' [RewriteEqn' () BindName Pattern Expr]
eqs AbstractRHS
rhs WhereDeclarations
wh) = do
eqs <- [RewriteEqn' () BindName Pattern Expr]
-> ScopeM (AbsOfCon [RewriteEqn' () BindName Pattern Expr])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [RewriteEqn' () BindName Pattern Expr]
eqs
rhs <- toAbstract rhs
return $ RewriteRHS eqs [] rhs wh
toAbstract (WithRHS' [WithExpr]
es List1 (TCMT IO Clause)
cs) = do
aux <- [Char] -> TCMT IO QName
withFunctionName [Char]
"with-"
A.WithRHS aux es <$> do toAbstract =<< sequence cs
instance ToAbstract RightHandSide where
type AbsOfCon RightHandSide = AbstractRHS
toAbstract :: RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
toAbstract (RightHandSide eqs :: [RewriteEqn' () BindName Pattern Expr]
eqs@(RewriteEqn' () BindName Pattern Expr
_:[RewriteEqn' () BindName Pattern Expr]
_) [WithExpr]
es ([(Name, LocalVar)], [Clause])
cs RHS' Expr
rhs WhereClause' [Declaration]
wh) = do
(rhs, ds) <- Range
-> WhereClause' [Declaration]
-> TCMT IO AbstractRHS
-> ScopeM (AbstractRHS, WhereDeclarations)
forall a.
Range
-> WhereClause' [Declaration]
-> ScopeM a
-> ScopeM (a, WhereDeclarations)
whereToAbstract (WhereClause' [Declaration] -> Range
forall a. HasRange a => a -> Range
getRange WhereClause' [Declaration]
wh) WhereClause' [Declaration]
wh (TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations))
-> TCMT IO AbstractRHS -> ScopeM (AbstractRHS, WhereDeclarations)
forall a b. (a -> b) -> a -> b
$
RightHandSide -> TCMT IO (AbsOfCon RightHandSide)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract ([RewriteEqn' () BindName Pattern Expr]
-> [WithExpr]
-> ([(Name, LocalVar)], [Clause])
-> RHS' Expr
-> WhereClause' [Declaration]
-> RightHandSide
RightHandSide [] [WithExpr]
es ([(Name, LocalVar)], [Clause])
cs RHS' Expr
rhs WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere)
return $ RewriteRHS' eqs rhs ds
toAbstract (RightHandSide [] [] ([(Name, LocalVar)]
_ , Clause
_:[Clause]
_) RHS' Expr
_ WhereClause' [Declaration]
_) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] (WithExpr
_:[WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ (C.RHS Expr
_) WhereClause' [Declaration]
_) = TypeError -> TCMT IO (AbsOfCon RightHandSide)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (AbsOfCon RightHandSide))
-> TypeError -> TCMT IO (AbsOfCon RightHandSide)
forall a b. (a -> b) -> a -> b
$ TypeError
BothWithAndRHS
toAbstract (RightHandSide [] [] ([(Name, LocalVar)]
_ , []) RHS' Expr
rhs WhereClause' [Declaration]
NoWhere) = RHS' Expr -> ScopeM (AbsOfCon (RHS' Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract RHS' Expr
rhs
toAbstract (RightHandSide [] [WithExpr]
nes ([(Name, LocalVar)]
lv , Clause
c:[Clause]
cs) RHS' Expr
C.AbsurdRHS WhereClause' [Declaration]
NoWhere) = do
let ([Maybe (NewName BoundName)]
ns , [Arg Expr]
es) = (WithExpr -> (Maybe (NewName BoundName), Arg Expr))
-> [WithExpr] -> ([Maybe (NewName BoundName)], [Arg Expr])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
unzipWith (\ (Named Maybe Name
nm Arg Expr
e) -> (BindingSource -> BoundName -> NewName BoundName
forall a. BindingSource -> a -> NewName a
NewName BindingSource
WithBound (BoundName -> NewName BoundName)
-> (Name -> BoundName) -> Name -> NewName BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BoundName
C.mkBoundName_ (Name -> NewName BoundName)
-> Maybe Name -> Maybe (NewName BoundName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
nm, Arg Expr
e)) [WithExpr]
nes
es <- Precedence -> [Arg Expr] -> ScopeM (AbsOfCon [Arg Expr])
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
TopCtx [Arg Expr]
es
lvars0 <- getLocalVars
ns <- toAbstract ns
lvars1 <- getLocalVars
let lv' = Int -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. Int -> [a] -> [a]
dropEnd ([(Name, LocalVar)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, LocalVar)]
lvars0) [(Name, LocalVar)]
lvars1 [(Name, LocalVar)] -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, LocalVar)]
lv
let cs' = NonEmpty Clause
-> (Clause -> TCMT IO Clause) -> List1 (TCMT IO Clause)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for (Clause
c Clause -> [Clause] -> NonEmpty Clause
forall a. a -> [a] -> NonEmpty a
:| [Clause]
cs) ((Clause -> TCMT IO Clause) -> List1 (TCMT IO Clause))
-> (Clause -> TCMT IO Clause) -> List1 (TCMT IO Clause)
forall a b. (a -> b) -> a -> b
$ \ Clause
c -> [(Name, LocalVar)] -> TCMT IO ()
setLocalVars [(Name, LocalVar)]
lv' TCMT IO () -> Clause -> TCMT IO Clause
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Clause
c
let nes = (Maybe BindName -> Arg Expr -> WithExpr)
-> [Maybe BindName] -> [Arg Expr] -> [WithExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe BindName -> Arg Expr -> WithExpr
forall name a. Maybe name -> a -> Named name a
Named [Maybe BindName]
ns [Arg Expr]
es
return $ WithRHS' nes cs'
toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ RHS' Expr
C.AbsurdRHS AnyWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ RHS' Expr
C.AbsurdRHS SomeWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] (WithExpr
_ : [WithExpr]
_) ([(Name, LocalVar)], [Clause])
_ RHS' Expr
C.AbsurdRHS NoWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] [] ([(Name, LocalVar)]
_, []) RHS' Expr
C.AbsurdRHS AnyWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] [] ([(Name, LocalVar)]
_, []) RHS' Expr
C.AbsurdRHS SomeWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] [] ([(Name, LocalVar)]
_, []) C.RHS{} AnyWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RightHandSide [] [] ([(Name, LocalVar)]
_, []) C.RHS{} SomeWhere{}) = TCMT IO AbstractRHS
TCMT IO (AbsOfCon RightHandSide)
forall a. HasCallStack => a
__IMPOSSIBLE__
instance ToAbstract C.RHS where
type AbsOfCon C.RHS = AbstractRHS
toAbstract :: RHS' Expr -> ScopeM (AbsOfCon (RHS' Expr))
toAbstract RHS' Expr
C.AbsurdRHS = AbstractRHS -> TCMT IO AbstractRHS
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractRHS -> TCMT IO AbstractRHS)
-> AbstractRHS -> TCMT IO AbstractRHS
forall a b. (a -> b) -> a -> b
$ AbstractRHS
AbsurdRHS'
toAbstract (C.RHS Expr
e) = Expr -> Expr -> AbstractRHS
RHS' (Expr -> Expr -> AbstractRHS)
-> ScopeM Expr -> TCMT IO (Expr -> AbstractRHS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e TCMT IO (Expr -> AbstractRHS)
-> TCMT IO Expr -> TCMT IO AbstractRHS
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
e
data LeftHandSide = LeftHandSide C.QName C.Pattern
instance ToAbstract LeftHandSide where
type AbsOfCon LeftHandSide = A.LHS
toAbstract :: LeftHandSide -> ScopeM (AbsOfCon LeftHandSide)
toAbstract (LeftHandSide QName
top Pattern
lhs) =
Call
-> ScopeM (AbsOfCon LeftHandSide) -> ScopeM (AbsOfCon LeftHandSide)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (QName -> Pattern -> Call
ScopeCheckLHS QName
top Pattern
lhs) (ScopeM (AbsOfCon LeftHandSide) -> ScopeM (AbsOfCon LeftHandSide))
-> ScopeM (AbsOfCon LeftHandSide) -> ScopeM (AbsOfCon LeftHandSide)
forall a b. (a -> b) -> a -> b
$ do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
5 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"original lhs: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Pattern
lhs
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"patternQNames: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [QName] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Pattern -> [QName]
forall p. CPatternLike p => p -> [QName]
patternQNames Pattern
lhs)
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.lhs" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"original lhs (raw): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
lhs
puns <- PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
lhs <- return $ if puns then expandPuns lhs else lhs
reportSLn "scope.lhs" 5 $
"lhs with expanded puns: " ++ prettyShow lhs
reportSLn "scope.lhs" 60 $
"lhs with expanded puns (raw): " ++ show lhs
lhscore <- parseLHS top lhs
let ell = LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
lhscore
reportSLn "scope.lhs" 5 $ "parsed lhs: " ++ prettyShow lhscore
reportSLn "scope.lhs" 60 $ "parsed lhs (raw): " ++ show lhscore
printLocals 10 "before lhs:"
unlessM (optCopatterns <$> pragmaOptions) $
when (hasCopatterns lhscore) $
typeError $ NeedOptionCopatterns
lhscore <- toAbstract lhscore
bindVarsToBind
reportSLn "scope.lhs" 60 $ "parsed lhs patterns: " ++ show lhscore
printLocals 10 "checked pattern:"
lhscore <- toAbstract lhscore
reportSLn "scope.lhs" 60 $ "parsed lhs dot patterns: " ++ show lhscore
printLocals 10 "checked dots:"
return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore
expandPuns :: C.Pattern -> C.Pattern
expandPuns :: KillRangeT Pattern
expandPuns Pattern
p = case Pattern
p of
C.AppP Pattern
p1 NamedArg Pattern
p2 -> Pattern -> NamedArg Pattern -> Pattern
C.AppP (KillRangeT Pattern
expandPuns Pattern
p1)
(((Named NamedName Pattern -> Named NamedName Pattern)
-> NamedArg Pattern -> NamedArg Pattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named NamedName Pattern -> Named NamedName Pattern)
-> NamedArg Pattern -> NamedArg Pattern)
-> (KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern)
-> KillRangeT Pattern
-> NamedArg Pattern
-> NamedArg Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KillRangeT Pattern
expandPuns NamedArg Pattern
p2)
C.RawAppP Range
r List2 Pattern
ps -> Range -> List2 Pattern -> Pattern
C.RawAppP Range
r (KillRangeT Pattern -> List2 Pattern -> List2 Pattern
forall a b. (a -> b) -> List2 a -> List2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns List2 Pattern
ps)
C.OpAppP Range
r QName
q Set Name
xs [NamedArg Pattern]
ps -> Range -> QName -> Set Name -> [NamedArg Pattern] -> Pattern
C.OpAppP Range
r QName
q Set Name
xs
(((NamedArg Pattern -> NamedArg Pattern)
-> [NamedArg Pattern] -> [NamedArg Pattern]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NamedArg Pattern -> NamedArg Pattern)
-> [NamedArg Pattern] -> [NamedArg Pattern])
-> (KillRangeT Pattern -> NamedArg Pattern -> NamedArg Pattern)
-> KillRangeT Pattern
-> [NamedArg Pattern]
-> [NamedArg Pattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Pattern -> Named NamedName Pattern)
-> NamedArg Pattern -> NamedArg Pattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named NamedName Pattern -> Named NamedName Pattern)
-> NamedArg Pattern -> NamedArg Pattern)
-> (KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern)
-> KillRangeT Pattern
-> NamedArg Pattern
-> NamedArg Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) KillRangeT Pattern
expandPuns [NamedArg Pattern]
ps)
C.ParenP Range
r Pattern
p -> Range -> KillRangeT Pattern
C.ParenP Range
r (KillRangeT Pattern
expandPuns Pattern
p)
C.AsP Range
r Name
x Pattern
p -> Range -> Name -> KillRangeT Pattern
C.AsP Range
r Name
x (KillRangeT Pattern
expandPuns Pattern
p)
C.RecP Range
r [FieldAssignment' Pattern]
ps -> Range -> [FieldAssignment' Pattern] -> Pattern
C.RecP Range
r ((FieldAssignment' Pattern -> FieldAssignment' Pattern)
-> [FieldAssignment' Pattern] -> [FieldAssignment' Pattern]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KillRangeT Pattern
-> FieldAssignment' Pattern -> FieldAssignment' Pattern
forall a b. (a -> b) -> FieldAssignment' a -> FieldAssignment' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns) [FieldAssignment' Pattern]
ps)
C.WithP Range
r Pattern
p -> Range -> KillRangeT Pattern
C.WithP Range
r (KillRangeT Pattern
expandPuns Pattern
p)
C.EllipsisP Range
r Maybe Pattern
mp -> Range -> Maybe Pattern -> Pattern
C.EllipsisP Range
r (KillRangeT Pattern -> Maybe Pattern -> Maybe Pattern
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Maybe Pattern
mp)
C.IdentP{} -> Pattern
p
C.QuoteP{} -> Pattern
p
C.WildP{} -> Pattern
p
C.AbsurdP{} -> Pattern
p
C.DotP{} -> Pattern
p
C.LitP{} -> Pattern
p
C.EqualP{} -> Pattern
p
C.HiddenP Range
r Named NamedName Pattern
p -> Range -> Named NamedName Pattern -> Pattern
C.HiddenP Range
r (Named NamedName Pattern -> Named NamedName Pattern
expand (KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Named NamedName Pattern
p))
C.InstanceP Range
r Named NamedName Pattern
p -> Range -> Named NamedName Pattern -> Pattern
C.InstanceP Range
r (Named NamedName Pattern -> Named NamedName Pattern
expand (KillRangeT Pattern
-> Named NamedName Pattern -> Named NamedName Pattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KillRangeT Pattern
expandPuns Named NamedName Pattern
p))
where
expand :: Named_ C.Pattern -> Named_ C.Pattern
expand :: Named NamedName Pattern -> Named NamedName Pattern
expand (Named { nameOf :: forall name a. Named name a -> Maybe name
nameOf = Maybe NamedName
Nothing
, namedThing :: forall name a. Named name a -> a
namedThing = C.IdentP Bool
_ q :: QName
q@(C.QName x :: Name
x@C.Name{})
}) =
Named { namedThing :: Pattern
namedThing = Bool -> QName -> Pattern
C.IdentP Bool
False QName
q
, nameOf :: Maybe NamedName
nameOf = NamedName -> Maybe NamedName
forall a. a -> Maybe a
Just (NamedName -> Maybe NamedName) -> NamedName -> Maybe NamedName
forall a b. (a -> b) -> a -> b
$
WithOrigin
{ woOrigin :: Origin
woOrigin = Origin
ExpandedPun
, woThing :: RString
woThing = [Char] -> RString
forall a. a -> Ranged a
unranged (Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x)
}
}
expand Named NamedName Pattern
p = Named NamedName Pattern
p
hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis
hasExpandedEllipsis :: LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
core = case LHSCore
core of
C.LHSHead{} -> ExpandedEllipsis
NoEllipsis
C.LHSProj{} -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis (LHSCore -> ExpandedEllipsis) -> LHSCore -> ExpandedEllipsis
forall a b. (a -> b) -> a -> b
$ NamedArg LHSCore -> LHSCore
forall a. NamedArg a -> a
namedArg (NamedArg LHSCore -> LHSCore) -> NamedArg LHSCore -> LHSCore
forall a b. (a -> b) -> a -> b
$ LHSCore -> NamedArg LHSCore
C.lhsFocus LHSCore
core
C.LHSWith{} -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis (LHSCore -> ExpandedEllipsis) -> LHSCore -> ExpandedEllipsis
forall a b. (a -> b) -> a -> b
$ LHSCore -> LHSCore
C.lhsHead LHSCore
core
C.LHSEllipsis Range
r LHSCore
p -> case LHSCore
p of
C.LHSWith LHSCore
p [Pattern]
wps [NamedArg Pattern]
_ -> LHSCore -> ExpandedEllipsis
hasExpandedEllipsis LHSCore
p ExpandedEllipsis -> ExpandedEllipsis -> ExpandedEllipsis
forall a. Semigroup a => a -> a -> a
<> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r ([Pattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern]
wps)
C.LHSHead{} -> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r Int
0
C.LHSProj{} -> Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r Int
0
C.LHSEllipsis{} -> ExpandedEllipsis
forall a. HasCallStack => a
__IMPOSSIBLE__
mergeEqualPs :: [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs :: forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs = (PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall {e}.
(PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go (PatInfo
forall a. Null a => a
empty, [])
where
go :: (PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go (PatInfo, [(e, e)])
acc (p :: Arg (Named NamedName (Pattern' e))
p@(Arg ArgInfo
ai (Named Maybe NamedName
mn (A.EqualP PatInfo
r [(e, e)]
es))) : [Arg (Named NamedName (Pattern' e))]
ps) = Arg (Named NamedName (Pattern' e))
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Arg (Named NamedName (Pattern' e))
p (TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))])
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall a b. (a -> b) -> a -> b
$ do
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality ArgInfo
ai Modality -> Modality -> Bool
forall a. Eq a => a -> a -> Bool
== Modality
defaultModality) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
notVisible ArgInfo
ai) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Warning
FaceConstraintCannotBeHidden ArgInfo
ai
Maybe NamedName -> (NamedName -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe NamedName
mn ((NamedName -> TCMT IO ()) -> TCMT IO ())
-> (NamedName -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ NamedName
x -> NamedName -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedName
x (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ NamedName -> Warning
FaceConstraintCannotBeNamed NamedName
x
(PatInfo, [(e, e)])
-> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
go ((PatInfo, [(e, e)])
acc (PatInfo, [(e, e)]) -> (PatInfo, [(e, e)]) -> (PatInfo, [(e, e)])
forall a. Monoid a => a -> a -> a
`mappend` (PatInfo
r, [(e, e)]
es)) [Arg (Named NamedName (Pattern' e))]
ps
go (PatInfo
r, es :: [(e, e)]
es@((e, e)
_:[(e, e)]
_)) [Arg (Named NamedName (Pattern' e))]
ps = (Pattern' e -> Arg (Named NamedName (Pattern' e))
forall a. a -> NamedArg a
defaultNamedArg (PatInfo -> [(e, e)] -> Pattern' e
forall e. PatInfo -> [(e, e)] -> Pattern' e
A.EqualP PatInfo
r [(e, e)]
es) Arg (Named NamedName (Pattern' e))
-> [Arg (Named NamedName (Pattern' e))]
-> [Arg (Named NamedName (Pattern' e))]
forall a. a -> [a] -> [a]
:) ([Arg (Named NamedName (Pattern' e))]
-> [Arg (Named NamedName (Pattern' e))])
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs [Arg (Named NamedName (Pattern' e))]
ps
go (PatInfo
_, []) [] = [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
go (PatInfo
_, []) (Arg (Named NamedName (Pattern' e))
p : [Arg (Named NamedName (Pattern' e))]
ps) = (Arg (Named NamedName (Pattern' e))
p Arg (Named NamedName (Pattern' e))
-> [Arg (Named NamedName (Pattern' e))]
-> [Arg (Named NamedName (Pattern' e))]
forall a. a -> [a] -> [a]
:) ([Arg (Named NamedName (Pattern' e))]
-> [Arg (Named NamedName (Pattern' e))])
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Arg (Named NamedName (Pattern' e))]
-> TCMT IO [Arg (Named NamedName (Pattern' e))]
forall e. [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]
mergeEqualPs [Arg (Named NamedName (Pattern' e))]
ps
instance ToAbstract C.LHSCore where
type AbsOfCon C.LHSCore = (A.LHSCore' C.Expr)
toAbstract :: LHSCore -> ScopeM (AbsOfCon LHSCore)
toAbstract (C.LHSHead QName
x [NamedArg Pattern]
ps) = do
x <- TCMT IO QName -> TCMT IO QName
forall a. ScopeM a -> ScopeM a
withLocalVars (TCMT IO QName -> TCMT IO QName) -> TCMT IO QName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ do
[(Name, LocalVar)] -> TCMT IO ()
setLocalVars []
OldName QName -> ScopeM (AbsOfCon (OldName QName))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> OldName QName
forall a. a -> OldName a
OldName QName
x)
A.LHSHead x <$> do mergeEqualPs =<< toAbstract ps
toAbstract (C.LHSProj QName
d [NamedArg Pattern]
ps1 NamedArg LHSCore
l [NamedArg Pattern]
ps2) = do
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null [NamedArg Pattern]
ps1) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
IllformedProjectionPatternConcrete ((Pattern -> NamedArg Pattern -> Pattern)
-> Pattern -> [NamedArg Pattern] -> Pattern
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pattern -> NamedArg Pattern -> Pattern
C.AppP (Bool -> QName -> Pattern
C.IdentP Bool
True QName
d) [NamedArg Pattern]
ps1)
qx <- QName -> ScopeM ResolvedName
resolveName QName
d
ds <- case qx of
FieldName List1 AbstractName
ds -> NonEmpty QName -> TCMT IO (NonEmpty QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty QName -> TCMT IO (NonEmpty QName))
-> NonEmpty QName -> TCMT IO (NonEmpty QName)
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds
ResolvedName
UnknownName -> QName -> TCMT IO (NonEmpty QName)
forall a. QName -> TCM a
notInScopeError QName
d
ResolvedName
_ -> [Char] -> TCMT IO (NonEmpty QName)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError ([Char] -> TCMT IO (NonEmpty QName))
-> [Char] -> TCMT IO (NonEmpty QName)
forall a b. (a -> b) -> a -> b
$
[Char]
"head of copattern needs to be a field identifier, but "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
d [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" isn't one"
A.LHSProj (AmbQ ds) <$> toAbstract l <*> (mergeEqualPs =<< toAbstract ps2)
toAbstract (C.LHSWith LHSCore
core [Pattern]
wps [NamedArg Pattern]
ps) = do
(LHSCore' Expr
-> [Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr)
-> TCMT IO (LHSCore' Expr)
-> TCMT IO [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (LHSCore' Expr)
forall a b c. (a -> b -> c) -> TCMT IO a -> TCMT IO b -> TCMT IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 LHSCore' Expr
-> [Arg (Named NamedName (Pattern' Expr))] -> LHSCore' Expr
forall e. LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
A.lhsCoreApp
((LHSCore' Expr -> [Arg (Pattern' Expr)] -> LHSCore' Expr)
-> TCMT IO (LHSCore' Expr)
-> TCMT IO [Arg (Pattern' Expr)]
-> TCMT IO (LHSCore' Expr)
forall a b c. (a -> b -> c) -> TCMT IO a -> TCMT IO b -> TCMT IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 LHSCore' Expr -> [Arg (Pattern' Expr)] -> LHSCore' Expr
forall e. LHSCore' e -> [Arg (Pattern' e)] -> LHSCore' e
A.lhsCoreWith
(LHSCore -> ScopeM (AbsOfCon LHSCore)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
core)
((Pattern' Expr -> Arg (Pattern' Expr))
-> [Pattern' Expr] -> [Arg (Pattern' Expr)]
forall a b. (a -> b) -> [a] -> [b]
map Pattern' Expr -> Arg (Pattern' Expr)
forall a. a -> Arg a
defaultArg ([Pattern' Expr] -> [Arg (Pattern' Expr)])
-> TCMT IO [Pattern' Expr] -> TCMT IO [Arg (Pattern' Expr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern] -> ScopeM (AbsOfCon [Pattern])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Pattern]
wps))
([NamedArg Pattern] -> ScopeM (AbsOfCon [NamedArg Pattern])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [NamedArg Pattern]
ps)
toAbstract (C.LHSEllipsis Range
_ LHSCore
p) = do
ap <- LHSCore -> ScopeM (AbsOfCon LHSCore)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore
p
bindVarsToBind
return ap
instance ToAbstract c => ToAbstract (WithHiding c) where
type AbsOfCon (WithHiding c) = WithHiding (AbsOfCon c)
toAbstract :: WithHiding c -> ScopeM (AbsOfCon (WithHiding c))
toAbstract (WithHiding Hiding
h c
a) = Hiding -> AbsOfCon c -> WithHiding (AbsOfCon c)
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h (AbsOfCon c -> WithHiding (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (WithHiding (AbsOfCon c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hiding -> c -> TCMT IO (AbsOfCon c)
forall h c.
(LensHiding h, ToAbstract c) =>
h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding Hiding
h c
a
instance ToAbstract c => ToAbstract (Arg c) where
type AbsOfCon (Arg c) = Arg (AbsOfCon c)
toAbstract :: Arg c -> ScopeM (AbsOfCon (Arg c))
toAbstract (Arg ArgInfo
info c
e) =
ArgInfo -> AbsOfCon c -> Arg (AbsOfCon c)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info (AbsOfCon c -> Arg (AbsOfCon c))
-> TCMT IO (AbsOfCon c) -> TCMT IO (Arg (AbsOfCon c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgInfo -> c -> TCMT IO (AbsOfCon c)
forall h c.
(LensHiding h, ToAbstract c) =>
h -> c -> ScopeM (AbsOfCon c)
toAbstractHiding ArgInfo
info c
e
instance ToAbstract c => ToAbstract (Named name c) where
type AbsOfCon (Named name c) = Named name (AbsOfCon c)
toAbstract :: Named name c -> ScopeM (AbsOfCon (Named name c))
toAbstract = (c -> TCMT IO (AbsOfCon c))
-> Named name c -> TCMT IO (Named name (AbsOfCon c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named name a -> f (Named name b)
traverse c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
instance ToAbstract c => ToAbstract (Ranged c) where
type AbsOfCon (Ranged c) = Ranged (AbsOfCon c)
toAbstract :: Ranged c -> ScopeM (AbsOfCon (Ranged c))
toAbstract = (c -> TCMT IO (AbsOfCon c))
-> Ranged c -> TCMT IO (Ranged (AbsOfCon c))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Ranged a -> f (Ranged b)
traverse c -> TCMT IO (AbsOfCon c)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract
instance ToAbstract (A.LHSCore' C.Expr) where
type AbsOfCon (A.LHSCore' C.Expr) = A.LHSCore' A.Expr
toAbstract :: LHSCore' Expr -> ScopeM (AbsOfCon (LHSCore' Expr))
toAbstract (A.LHSHead QName
f [Arg (Named NamedName (Pattern' Expr))]
ps) = QName -> [NamedArg Pattern] -> LHSCore' Expr
forall e. QName -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSHead QName
f ([NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO [NamedArg Pattern] -> TCMT IO (LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Arg (Named NamedName (Pattern' Expr))
-> TCMT IO (NamedArg Pattern))
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [NamedArg Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Arg (Named NamedName (Pattern' Expr)) -> TCMT IO (NamedArg Pattern)
Arg (Named NamedName (Pattern' Expr))
-> ScopeM (AbsOfCon (Arg (Named NamedName (Pattern' Expr))))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps
toAbstract (A.LHSProj AmbiguousQName
d NamedArg (LHSCore' Expr)
lhscore [Arg (Named NamedName (Pattern' Expr))]
ps) = AmbiguousQName
-> NamedArg (LHSCore' Expr) -> [NamedArg Pattern] -> LHSCore' Expr
forall e.
AmbiguousQName
-> NamedArg (LHSCore' e) -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSProj AmbiguousQName
d (NamedArg (LHSCore' Expr) -> [NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO (NamedArg (LHSCore' Expr))
-> TCMT IO ([NamedArg Pattern] -> LHSCore' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Named_ (LHSCore' Expr) -> TCMT IO (Named_ (LHSCore' Expr)))
-> NamedArg (LHSCore' Expr) -> TCMT IO (NamedArg (LHSCore' Expr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Arg a -> m (Arg b)
mapM Named_ (LHSCore' Expr) -> TCMT IO (Named_ (LHSCore' Expr))
Named_ (LHSCore' Expr)
-> ScopeM (AbsOfCon (Named_ (LHSCore' Expr)))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract NamedArg (LHSCore' Expr)
lhscore TCMT IO ([NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO [NamedArg Pattern] -> TCMT IO (LHSCore' Expr)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Arg (Named NamedName (Pattern' Expr))
-> TCMT IO (NamedArg Pattern))
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO [NamedArg Pattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Arg (Named NamedName (Pattern' Expr)) -> TCMT IO (NamedArg Pattern)
Arg (Named NamedName (Pattern' Expr))
-> ScopeM (AbsOfCon (Arg (Named NamedName (Pattern' Expr))))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps
toAbstract (A.LHSWith LHSCore' Expr
core [Arg (Pattern' Expr)]
wps [Arg (Named NamedName (Pattern' Expr))]
ps) = (LHSCore' Expr
-> [Arg Pattern] -> [NamedArg Pattern] -> LHSCore' Expr)
-> TCMT IO (LHSCore' Expr)
-> TCMT IO [Arg Pattern]
-> TCMT IO [NamedArg Pattern]
-> TCMT IO (LHSCore' Expr)
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 LHSCore' Expr
-> [Arg Pattern] -> [NamedArg Pattern] -> LHSCore' Expr
forall e.
LHSCore' e
-> [Arg (Pattern' e)] -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSWith (LHSCore' Expr -> ScopeM (AbsOfCon (LHSCore' Expr))
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract LHSCore' Expr
core) ([Arg (Pattern' Expr)] -> ScopeM (AbsOfCon [Arg (Pattern' Expr)])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Pattern' Expr)]
wps) ([Arg (Named NamedName (Pattern' Expr))]
-> ScopeM (AbsOfCon [Arg (Named NamedName (Pattern' Expr))])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [Arg (Named NamedName (Pattern' Expr))]
ps)
instance ToAbstract (A.Pattern' C.Expr) where
type AbsOfCon (A.Pattern' C.Expr) = A.Pattern' A.Expr
toAbstract :: Pattern' Expr -> ScopeM (AbsOfCon (Pattern' Expr))
toAbstract = (Expr -> ScopeM Expr) -> Pattern' Expr -> TCMT IO Pattern
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Pattern' a -> f (Pattern' b)
traverse ((Expr -> ScopeM Expr) -> Pattern' Expr -> TCMT IO Pattern)
-> (Expr -> ScopeM Expr) -> Pattern' Expr -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ ScopeM Expr -> ScopeM Expr
forall a. ScopeM a -> ScopeM a
insideDotPattern (ScopeM Expr -> ScopeM Expr)
-> (Expr -> ScopeM Expr) -> Expr -> ScopeM Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
DotPatternCtx
resolvePatternIdentifier ::
Bool
-> Hiding
-> C.QName
-> Maybe (Set A.Name)
-> ScopeM (A.Pattern' C.Expr)
resolvePatternIdentifier :: Bool
-> Hiding -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
canBeConstructor Hiding
h QName
x Maybe (Set Name)
ns = do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"resolvePatternIdentifier " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at source position " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Range -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Range
r
px <- PatName -> ScopeM (AbsOfCon PatName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> Hiding -> PatName
PatName QName
x Maybe (Set Name)
ns Hiding
h)
case px of
VarPatName Name
y -> do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
" resolved to VarPatName " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with range " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Range -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
y)
Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern' Expr
forall e. BindName -> Pattern' e
VarP (BindName -> Pattern' Expr) -> BindName -> Pattern' Expr
forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.mkBindName Name
y
ConPatName List1 AbstractName
ds ->
if Bool
canBeConstructor
then Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ ConPatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
ConP (ConOrigin -> PatInfo -> ConPatLazy -> ConPatInfo
ConPatInfo ConOrigin
ConOCon (Range -> PatInfo
PatRange Range
r) ConPatLazy
ConPatEager)
(NonEmpty QName -> AmbiguousQName
AmbQ (NonEmpty QName -> AmbiguousQName)
-> NonEmpty QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds) []
else [Char] -> TCMT IO (Pattern' Expr)
err [Char]
"constructor"
PatternSynPatName List1 AbstractName
ds ->
if Bool
canBeConstructor
then Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
PatternSynP (Range -> PatInfo
PatRange Range
r)
(NonEmpty QName -> AmbiguousQName
AmbQ (NonEmpty QName -> AmbiguousQName)
-> NonEmpty QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ (AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds) []
else [Char] -> TCMT IO (Pattern' Expr)
err [Char]
"pattern synonym"
where
r :: Range
r = QName -> Range
forall a. HasRange a => a -> Range
getRange QName
x
err :: [Char] -> TCMT IO (Pattern' Expr)
err [Char]
s =
Range -> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr))
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$
TypeError -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (Pattern' Expr))
-> TypeError -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$
[Char]
"A pun must not use the " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
x
applyAPattern
:: C.Pattern
-> A.Pattern' C.Expr
-> NAPs C.Expr
-> ScopeM (A.Pattern' C.Expr)
applyAPattern :: Pattern
-> Pattern' Expr
-> [Arg (Named NamedName (Pattern' Expr))]
-> TCMT IO (Pattern' Expr)
applyAPattern Pattern
p0 Pattern' Expr
p [Arg (Named NamedName (Pattern' Expr))]
ps = do
Range -> Pattern' Expr -> Pattern' Expr
forall a. SetRange a => Range -> a -> a
setRange (Pattern -> Range
forall a. HasRange a => a -> Range
getRange Pattern
p0) (Pattern' Expr -> Pattern' Expr)
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
case Pattern' Expr
p of
A.ConP ConPatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ ConPatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
A.DefP PatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
A.PatternSynP PatInfo
i AmbiguousQName
x [Arg (Named NamedName (Pattern' Expr))]
as -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
x ([Arg (Named NamedName (Pattern' Expr))]
as [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
-> [Arg (Named NamedName (Pattern' Expr))]
forall a. [a] -> [a] -> [a]
++ [Arg (Named NamedName (Pattern' Expr))]
ps)
A.DotP PatInfo
i (Ident QName
x) -> QName -> ScopeM ResolvedName
resolveName QName
x ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Pattern' Expr))
-> TCMT IO (Pattern' Expr)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ConstructorName Set Induction
_ List1 AbstractName
ds -> do
let cpi :: ConPatInfo
cpi = ConOrigin -> PatInfo -> ConPatLazy -> ConPatInfo
ConPatInfo ConOrigin
ConOCon PatInfo
i ConPatLazy
ConPatLazy
c :: AmbiguousQName
c = NonEmpty QName -> AmbiguousQName
AmbQ ((AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
ds)
Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ ConPatInfo
-> AmbiguousQName
-> [Arg (Named NamedName (Pattern' Expr))]
-> Pattern' Expr
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
cpi AmbiguousQName
c [Arg (Named NamedName (Pattern' Expr))]
ps
ResolvedName
_ -> TCMT IO (Pattern' Expr)
failure
A.DotP{} -> TCMT IO (Pattern' Expr)
failure
A.VarP{} -> TCMT IO (Pattern' Expr)
failure
A.ProjP{} -> TCMT IO (Pattern' Expr)
failure
A.WildP{} -> TCMT IO (Pattern' Expr)
failure
A.AsP{} -> TCMT IO (Pattern' Expr)
failure
A.AbsurdP{} -> TCMT IO (Pattern' Expr)
failure
A.LitP{} -> TCMT IO (Pattern' Expr)
failure
A.RecP{} -> TCMT IO (Pattern' Expr)
failure
A.EqualP{} -> TCMT IO (Pattern' Expr)
failure
A.WithP{} -> TCMT IO (Pattern' Expr)
failure
A.AnnP{} -> TCMT IO (Pattern' Expr)
failure
where
failure :: TCMT IO (Pattern' Expr)
failure = TypeError -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (Pattern' Expr))
-> TypeError -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
InvalidPattern Pattern
p0
data WithHidingInfo a = WithHidingInfo Hiding a
propagateHidingInfo :: NamedArg a -> NamedArg (WithHidingInfo a)
propagateHidingInfo :: forall a. NamedArg a -> NamedArg (WithHidingInfo a)
propagateHidingInfo NamedArg a
a = (Named NamedName a -> Named_ (WithHidingInfo a))
-> NamedArg a -> Arg (Named_ (WithHidingInfo a))
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> WithHidingInfo a)
-> Named NamedName a -> Named_ (WithHidingInfo a)
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> WithHidingInfo a)
-> Named NamedName a -> Named_ (WithHidingInfo a))
-> (a -> WithHidingInfo a)
-> Named NamedName a
-> Named_ (WithHidingInfo a)
forall a b. (a -> b) -> a -> b
$ Hiding -> a -> WithHidingInfo a
forall a. Hiding -> a -> WithHidingInfo a
WithHidingInfo (Hiding -> a -> WithHidingInfo a)
-> Hiding -> a -> WithHidingInfo a
forall a b. (a -> b) -> a -> b
$ NamedArg a -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding NamedArg a
a) NamedArg a
a
instance ToAbstract (WithHidingInfo C.Pattern) where
type AbsOfCon (WithHidingInfo C.Pattern) = A.Pattern' C.Expr
toAbstract :: WithHidingInfo Pattern
-> ScopeM (AbsOfCon (WithHidingInfo Pattern))
toAbstract (WithHidingInfo Hiding
h (C.IdentP Bool
canBeConstructor QName
x)) =
Bool
-> Hiding -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
canBeConstructor Hiding
h QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
toAbstract (WithHidingInfo Hiding
_ Pattern
p) = Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
instance ToAbstract C.Pattern where
type AbsOfCon C.Pattern = A.Pattern' C.Expr
toAbstract :: Pattern -> ScopeM (AbsOfCon Pattern)
toAbstract (C.IdentP Bool
canBeConstructor QName
x) =
Bool
-> Hiding -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
canBeConstructor Hiding
forall a. Null a => a
empty QName
x Maybe (Set Name)
forall a. Maybe a
Nothing
toAbstract (AppP (QuoteP Range
_) NamedArg Pattern
p)
| IdentP Bool
_ QName
x <- NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg NamedArg Pattern
p,
NamedArg Pattern -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Pattern
p = do
e <- OldQName -> ScopeM (AbsOfCon OldQName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> OldQName
OldQName QName
x Maybe (Set Name)
forall a. Maybe a
Nothing)
A.LitP (PatRange $ getRange x) . LitQName <$> quotedName e
toAbstract (QuoteP Range
r) =
[Char] -> TCMT IO (Pattern' Expr)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
"quote must be applied to an identifier"
toAbstract p0 :: Pattern
p0@(AppP Pattern
p NamedArg Pattern
q) = do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
50 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"distributeDots before = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
p
p <- Pattern -> TCMT IO Pattern
distributeDots Pattern
p
reportSLn "scope.pat" 50 $ "distributeDots after = " ++ show p
p' <- toAbstract p
q' <- toAbstract $ propagateHidingInfo q
applyAPattern p0 p' $ singleton q'
where
distributeDots :: C.Pattern -> ScopeM C.Pattern
distributeDots :: Pattern -> TCMT IO Pattern
distributeDots p :: Pattern
p@(C.DotP Range
r Expr
e) = Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e
distributeDots Pattern
p = Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p
distributeDotsExpr :: Range -> C.Expr -> ScopeM C.Pattern
distributeDotsExpr :: Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e = Expr -> TCMT IO Expr
parseRawApp Expr
e TCMT IO Expr -> (Expr -> TCMT IO Pattern) -> TCMT IO Pattern
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
C.App Range
r Expr
e NamedArg Expr
a ->
Pattern -> NamedArg Pattern -> Pattern
AppP (Pattern -> NamedArg Pattern -> Pattern)
-> TCMT IO Pattern -> TCMT IO (NamedArg Pattern -> Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e
TCMT IO (NamedArg Pattern -> Pattern)
-> TCMT IO (NamedArg Pattern) -> TCMT IO Pattern
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> NamedArg Expr -> TCMT IO (NamedArg Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> ((Expr -> TCMT IO Pattern)
-> Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> (Expr -> TCMT IO Pattern)
-> NamedArg Expr
-> TCMT IO (NamedArg Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> TCMT IO Pattern)
-> Named NamedName Expr -> TCMT IO (Named NamedName Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) (Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r) NamedArg Expr
a
OpApp Range
r QName
q Set Name
ns OpAppArgs
as ->
case ((Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr))
-> OpAppArgs -> Maybe [NamedArg Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr))
-> OpAppArgs -> Maybe [NamedArg Expr])
-> ((MaybePlaceholder (OpApp Expr) -> Maybe Expr)
-> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr))
-> (MaybePlaceholder (OpApp Expr) -> Maybe Expr)
-> OpAppArgs
-> Maybe [NamedArg Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName (MaybePlaceholder (OpApp Expr))
-> Maybe (Named NamedName Expr))
-> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName (MaybePlaceholder (OpApp Expr))
-> Maybe (Named NamedName Expr))
-> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr))
-> ((MaybePlaceholder (OpApp Expr) -> Maybe Expr)
-> Named NamedName (MaybePlaceholder (OpApp Expr))
-> Maybe (Named NamedName Expr))
-> (MaybePlaceholder (OpApp Expr) -> Maybe Expr)
-> Arg (Named NamedName (MaybePlaceholder (OpApp Expr)))
-> Maybe (NamedArg Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaybePlaceholder (OpApp Expr) -> Maybe Expr)
-> Named NamedName (MaybePlaceholder (OpApp Expr))
-> Maybe (Named NamedName Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) MaybePlaceholder (OpApp Expr) -> Maybe Expr
forall a. MaybePlaceholder (OpApp a) -> Maybe a
fromNoPlaceholder OpAppArgs
as of
Just [NamedArg Expr]
as -> Range -> QName -> Set Name -> [NamedArg Pattern] -> Pattern
OpAppP Range
r QName
q Set Name
ns ([NamedArg Pattern] -> Pattern)
-> TCMT IO [NamedArg Pattern] -> TCMT IO Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
((NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> [NamedArg Expr] -> TCMT IO [NamedArg Pattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> [NamedArg Expr] -> TCMT IO [NamedArg Pattern])
-> ((Expr -> TCMT IO Pattern)
-> NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> (Expr -> TCMT IO Pattern)
-> [NamedArg Expr]
-> TCMT IO [NamedArg Pattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> NamedArg Expr -> TCMT IO (NamedArg Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> NamedArg Expr -> TCMT IO (NamedArg Pattern))
-> ((Expr -> TCMT IO Pattern)
-> Named NamedName Expr -> TCMT IO (Named NamedName Pattern))
-> (Expr -> TCMT IO Pattern)
-> NamedArg Expr
-> TCMT IO (NamedArg Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> TCMT IO Pattern)
-> Named NamedName Expr -> TCMT IO (Named NamedName Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) (Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r) [NamedArg Expr]
as
Maybe [NamedArg Expr]
Nothing -> Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Expr -> Pattern
C.DotP Range
r Expr
e
Paren Range
r Expr
e -> Range -> KillRangeT Pattern
ParenP Range
r KillRangeT Pattern -> TCMT IO Pattern -> TCMT IO Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr -> TCMT IO Pattern
distributeDotsExpr Range
r Expr
e
Expr
_ -> Pattern -> TCMT IO Pattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> TCMT IO Pattern) -> Pattern -> TCMT IO Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Expr -> Pattern
C.DotP Range
r Expr
e
fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a
fromNoPlaceholder :: forall a. MaybePlaceholder (OpApp a) -> Maybe a
fromNoPlaceholder (NoPlaceholder Maybe PositionInName
_ (Ordinary a
e)) = a -> Maybe a
forall a. a -> Maybe a
Just a
e
fromNoPlaceholder MaybePlaceholder (OpApp a)
_ = Maybe a
forall a. Maybe a
Nothing
parseRawApp :: C.Expr -> ScopeM C.Expr
parseRawApp :: Expr -> TCMT IO Expr
parseRawApp (RawApp Range
r List2 Expr
es) = List2 Expr -> TCMT IO Expr
parseApplication List2 Expr
es
parseRawApp Expr
e = Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
toAbstract p0 :: Pattern
p0@(OpAppP Range
r QName
op Set Name
ns [NamedArg Pattern]
ps) = do
[Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"scope.pat" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ConcreteToAbstract.toAbstract OpAppP{}: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
forall a. Show a => a -> [Char]
show Pattern
p0
p <- Bool
-> Hiding -> QName -> Maybe (Set Name) -> TCMT IO (Pattern' Expr)
resolvePatternIdentifier Bool
True Hiding
forall a. Null a => a
empty QName
op (Set Name -> Maybe (Set Name)
forall a. a -> Maybe a
Just Set Name
ns)
ps <- toAbstract $ map propagateHidingInfo ps
applyAPattern p0 p ps
toAbstract (EllipsisP Range
_ Maybe Pattern
mp) = TCMT IO (Pattern' Expr)
-> (Pattern -> TCMT IO (Pattern' Expr))
-> Maybe Pattern
-> TCMT IO (Pattern' Expr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO (Pattern' Expr)
forall a. HasCallStack => a
__IMPOSSIBLE__ Pattern -> TCMT IO (Pattern' Expr)
Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Maybe Pattern
mp
toAbstract (HiddenP Range
_ Named NamedName Pattern
_) = TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (InstanceP Range
_ Named NamedName Pattern
_) = TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract (RawAppP Range
_ List2 Pattern
_) = TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
forall a. HasCallStack => a
__IMPOSSIBLE__
toAbstract p :: Pattern
p@(C.WildP Range
r) = AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern))
-> AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Expr
forall e. PatInfo -> Pattern' e
A.WildP (Range -> PatInfo
PatRange Range
r)
toAbstract (C.ParenP Range
_ Pattern
p) = Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
toAbstract (C.LitP Range
r Literal
l) = Range -> ScopeM (AbsOfCon Pattern) -> ScopeM (AbsOfCon Pattern)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (ScopeM (AbsOfCon Pattern) -> ScopeM (AbsOfCon Pattern))
-> ScopeM (AbsOfCon Pattern) -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Literal -> Pattern' Expr
forall e. PatInfo -> Literal -> Pattern' e
A.LitP (Range -> PatInfo
PatRange Range
r) Literal
l Pattern' Expr -> TCMT IO () -> TCMT IO (Pattern' Expr)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Literal -> TCMT IO ()
checkLiteral Literal
l
toAbstract p0 :: Pattern
p0@(C.AsP Range
r Name
x Pattern
p) = do
PatName -> ScopeM (AbsOfCon PatName)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract (QName -> Maybe (Set Name) -> Hiding -> PatName
PatName (Name -> QName
C.QName Name
x) Maybe (Set Name)
forall a. Maybe a
Nothing Hiding
forall a. Null a => a
empty) TCMT IO APatName
-> (APatName -> TCMT IO (Pattern' Expr)) -> TCMT IO (Pattern' Expr)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
VarPatName Name
x -> PatInfo -> BindName -> Pattern' Expr -> Pattern' Expr
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP (Range -> PatInfo
PatRange Range
r) (Name -> BindName
A.mkBindName Name
x) (Pattern' Expr -> Pattern' Expr)
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
ConPatName{} -> LHSOrPatSyn -> TCMT IO (Pattern' Expr)
ignoreAsPat LHSOrPatSyn
IsLHS
PatternSynPatName{} -> LHSOrPatSyn -> TCMT IO (Pattern' Expr)
ignoreAsPat LHSOrPatSyn
IsPatSyn
where
ignoreAsPat :: LHSOrPatSyn -> TCMT IO (Pattern' Expr)
ignoreAsPat LHSOrPatSyn
b = do
Name -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ LHSOrPatSyn -> Warning
AsPatternShadowsConstructorOrPatternSynonym LHSOrPatSyn
b
Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
toAbstract p0 :: Pattern
p0@(C.EqualP Range
r [(Expr, Expr)]
es) = AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern))
-> AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> [(Expr, Expr)] -> Pattern' Expr
forall e. PatInfo -> [(e, e)] -> Pattern' e
A.EqualP (Range -> PatInfo
PatRange Range
r) [(Expr, Expr)]
es
toAbstract p0 :: Pattern
p0@(C.DotP Range
r Expr
e) = do
let fallback :: TCMT IO (Pattern' Expr)
fallback = Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Expr -> Pattern' Expr
forall e. PatInfo -> e -> Pattern' e
A.DotP (Range -> PatInfo
PatRange Range
r) Expr
e
case Expr
e of
C.Ident QName
x -> QName -> ScopeM ResolvedName
resolveName QName
x ScopeM ResolvedName
-> (ResolvedName -> TCMT IO (Pattern' Expr))
-> TCMT IO (Pattern' Expr)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
FieldName List1 AbstractName
xs -> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern' Expr -> TCMT IO (Pattern' Expr))
-> Pattern' Expr -> TCMT IO (Pattern' Expr)
forall a b. (a -> b) -> a -> b
$ PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' Expr
forall e. PatInfo -> ProjOrigin -> AmbiguousQName -> Pattern' e
A.ProjP (Range -> PatInfo
PatRange Range
r) ProjOrigin
ProjPostfix (AmbiguousQName -> Pattern' Expr)
-> AmbiguousQName -> Pattern' Expr
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> AmbiguousQName
AmbQ (NonEmpty QName -> AmbiguousQName)
-> NonEmpty QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$
(AbstractName -> QName) -> List1 AbstractName -> NonEmpty QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbstractName -> QName
anameName List1 AbstractName
xs
ResolvedName
_ -> TCMT IO (Pattern' Expr)
fallback
Expr
_ -> TCMT IO (Pattern' Expr)
ScopeM (AbsOfCon Pattern)
fallback
toAbstract p0 :: Pattern
p0@(C.AbsurdP Range
r) = AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern))
-> AbsOfCon Pattern -> ScopeM (AbsOfCon Pattern)
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Expr
forall e. PatInfo -> Pattern' e
A.AbsurdP (Range -> PatInfo
PatRange Range
r)
toAbstract (C.RecP Range
r [FieldAssignment' Pattern]
fs) = ConPatInfo -> [FieldAssignment' (Pattern' Expr)] -> Pattern' Expr
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP (ConOrigin -> PatInfo -> ConPatLazy -> ConPatInfo
ConPatInfo ConOrigin
ConORec (Range -> PatInfo
PatRange Range
r) ConPatLazy
ConPatEager) ([FieldAssignment' (Pattern' Expr)] -> Pattern' Expr)
-> TCMT IO [FieldAssignment' (Pattern' Expr)]
-> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldAssignment' Pattern
-> TCMT IO (FieldAssignment' (Pattern' Expr)))
-> [FieldAssignment' Pattern]
-> TCMT IO [FieldAssignment' (Pattern' Expr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Pattern -> TCMT IO (Pattern' Expr))
-> FieldAssignment' Pattern
-> TCMT IO (FieldAssignment' (Pattern' Expr))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse Pattern -> TCMT IO (Pattern' Expr)
Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract) [FieldAssignment' Pattern]
fs
toAbstract (C.WithP Range
r Pattern
p) = PatInfo -> Pattern' Expr -> Pattern' Expr
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP (Range -> PatInfo
PatRange Range
r) (Pattern' Expr -> Pattern' Expr)
-> TCMT IO (Pattern' Expr) -> TCMT IO (Pattern' Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> ScopeM (AbsOfCon Pattern)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Pattern
p
toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM A.Expr
toAbstractOpArg :: Precedence -> OpApp Expr -> ScopeM Expr
toAbstractOpArg Precedence
ctx (Ordinary Expr
e) = Precedence -> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => Precedence -> c -> ScopeM (AbsOfCon c)
toAbstractCtx Precedence
ctx Expr
e
toAbstractOpArg Precedence
ctx (SyntaxBindingLambda Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e) = Range
-> NonEmpty (LamBinding' TypedBinding)
-> Expr
-> Precedence
-> ScopeM Expr
toAbstractLam Range
r NonEmpty (LamBinding' TypedBinding)
bs Expr
e Precedence
ctx
toAbstractOpApp :: C.QName -> Set A.Name -> OpAppArgs -> ScopeM A.Expr
toAbstractOpApp :: QName -> Set Name -> OpAppArgs -> ScopeM Expr
toAbstractOpApp QName
op Set Name
ns OpAppArgs
es = do
(binders, es) <- OpAppArgs
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp Expr))])
forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders OpAppArgs
es
nota <- getNotation op ns
let parts = NewNotation -> Notation
notation NewNotation
nota
let nonBindingParts = (NotationPart -> Bool) -> Notation -> Notation
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (NotationPart -> Bool) -> NotationPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotationPart -> Bool
isBinder) Notation
parts
unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__
op <- toAbstract (OldQName op (Just ns))
es <- left (notaFixity nota) nonBindingParts es
let body = (Expr -> (ParenPreference, NamedArg Expr) -> Expr)
-> Expr -> [(ParenPreference, NamedArg Expr)] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Expr -> (ParenPreference, NamedArg Expr) -> Expr
app Expr
op [(ParenPreference, NamedArg Expr)]
es
return $ foldr (A.Lam (ExprRange (getRange body))) body binders
where
app :: Expr -> (ParenPreference, NamedArg Expr) -> Expr
app Expr
e (ParenPreference
pref, NamedArg Expr
arg) = AppInfo -> Expr -> NamedArg Expr -> Expr
A.App AppInfo
info Expr
e NamedArg Expr
arg
where info :: AppInfo
info = (Range -> AppInfo
defaultAppInfo Range
r) { appOrigin = getOrigin arg
, appParens = pref }
r :: Range
r = Expr -> NamedArg Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange Expr
e NamedArg Expr
arg
inferParenPref :: NamedArg (Either A.Expr (OpApp C.Expr)) -> ParenPreference
inferParenPref :: NamedArg (Either Expr (OpApp Expr)) -> ParenPreference
inferParenPref NamedArg (Either Expr (OpApp Expr))
e =
case NamedArg (Either Expr (OpApp Expr)) -> Either Expr (OpApp Expr)
forall a. NamedArg a -> a
namedArg NamedArg (Either Expr (OpApp Expr))
e of
Right (Ordinary Expr
e) -> Expr -> ParenPreference
inferParenPreference Expr
e
Left{} -> ParenPreference
PreferParenless
Right{} -> ParenPreference
PreferParenless
toAbsOpArg :: Precedence ->
NamedArg (Either A.Expr (OpApp C.Expr)) ->
ScopeM (ParenPreference, NamedArg A.Expr)
toAbsOpArg :: Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg Precedence
cxt NamedArg (Either Expr (OpApp Expr))
e = (ParenPreference
pref,) (NamedArg Expr -> (ParenPreference, NamedArg Expr))
-> TCMT IO (NamedArg Expr)
-> ScopeM (ParenPreference, NamedArg Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Named NamedName (Either Expr (OpApp Expr))
-> TCMT IO (Named NamedName Expr))
-> NamedArg (Either Expr (OpApp Expr)) -> TCMT IO (NamedArg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse ((Named NamedName (Either Expr (OpApp Expr))
-> TCMT IO (Named NamedName Expr))
-> NamedArg (Either Expr (OpApp Expr)) -> TCMT IO (NamedArg Expr))
-> ((Either Expr (OpApp Expr) -> ScopeM Expr)
-> Named NamedName (Either Expr (OpApp Expr))
-> TCMT IO (Named NamedName Expr))
-> (Either Expr (OpApp Expr) -> ScopeM Expr)
-> NamedArg (Either Expr (OpApp Expr))
-> TCMT IO (NamedArg Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Expr (OpApp Expr) -> ScopeM Expr)
-> Named NamedName (Either Expr (OpApp Expr))
-> TCMT IO (Named NamedName Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named NamedName a -> f (Named NamedName b)
traverse) ((Expr -> ScopeM Expr)
-> (OpApp Expr -> ScopeM Expr)
-> Either Expr (OpApp Expr)
-> ScopeM Expr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Expr -> ScopeM Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Precedence -> OpApp Expr -> ScopeM Expr
toAbstractOpArg Precedence
cxt)) NamedArg (Either Expr (OpApp Expr))
e
where pref :: ParenPreference
pref = NamedArg (Either Expr (OpApp Expr)) -> ParenPreference
inferParenPref NamedArg (Either Expr (OpApp Expr))
e
left :: Fixity
-> [NotationPart]
-> [NamedArg (Either A.Expr (OpApp C.Expr))]
-> ScopeM [(ParenPreference, NamedArg A.Expr)]
left :: Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> ScopeM [(ParenPreference, NamedArg Expr)]
left Fixity
f (IdPart RString
_ : Notation
xs) [NamedArg (Either Expr (OpApp Expr))]
es = Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> ScopeM [(ParenPreference, NamedArg Expr)]
inside Fixity
f Notation
xs [NamedArg (Either Expr (OpApp Expr))]
es
left Fixity
f (NotationPart
_ : Notation
xs) (NamedArg (Either Expr (OpApp Expr))
e : [NamedArg (Either Expr (OpApp Expr))]
es) = do
e <- Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg (Fixity -> Precedence
LeftOperandCtx Fixity
f) NamedArg (Either Expr (OpApp Expr))
e
es <- inside f xs es
return (e : es)
left Fixity
f (NotationPart
_ : Notation
_) [] = ScopeM [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
left Fixity
f [] [NamedArg (Either Expr (OpApp Expr))]
_ = ScopeM [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
inside :: Fixity
-> [NotationPart]
-> [NamedArg (Either A.Expr (OpApp C.Expr))]
-> ScopeM [(ParenPreference, NamedArg A.Expr)]
inside :: Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> ScopeM [(ParenPreference, NamedArg Expr)]
inside Fixity
f [NotationPart
x] [NamedArg (Either Expr (OpApp Expr))]
es = Fixity
-> NotationPart
-> [NamedArg (Either Expr (OpApp Expr))]
-> ScopeM [(ParenPreference, NamedArg Expr)]
right Fixity
f NotationPart
x [NamedArg (Either Expr (OpApp Expr))]
es
inside Fixity
f (IdPart RString
_ : Notation
xs) [NamedArg (Either Expr (OpApp Expr))]
es = Fixity
-> Notation
-> [NamedArg (Either Expr (OpApp Expr))]
-> ScopeM [(ParenPreference, NamedArg Expr)]
inside Fixity
f Notation
xs [NamedArg (Either Expr (OpApp Expr))]
es
inside Fixity
f (NotationPart
_ : Notation
xs) (NamedArg (Either Expr (OpApp Expr))
e : [NamedArg (Either Expr (OpApp Expr))]
es) = do
e <- Precedence
-> NamedArg (Either Expr (OpApp Expr))
-> ScopeM (ParenPreference, NamedArg Expr)
toAbsOpArg Precedence
InsideOperandCtx NamedArg (Either Expr (OpApp Expr))
e
es <- inside f xs es
return (e : es)
inside Fixity
_ [] [] = [(ParenPreference, NamedArg Expr)]
-> ScopeM [(ParenPreference, NamedArg Expr)]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
inside Fixity
_ (NotationPart
_ : Notation
_) [] = ScopeM [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
inside Fixity
_ [] (NamedArg (Either Expr (OpApp Expr))
_ : [NamedArg (Either Expr (OpApp Expr))]
_) = ScopeM [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
right :: Fixity
-> NotationPart
-> [NamedArg (Either A.Expr (OpApp C.Expr))]
-> ScopeM [(ParenPreference, NamedArg A.Expr)]
right :: Fixity
-> NotationPart
-> [NamedArg (Either Expr (OpApp Expr))]
-> ScopeM [(ParenPreference, NamedArg Expr)]
right Fixity
_ (IdPart RString
_) [] = [(ParenPreference, NamedArg Expr)]
-> ScopeM [(ParenPreference, NamedArg Expr)]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
right Fixity
f NotationPart
_ [NamedArg (Either Expr (OpApp Expr))
e] = do
let pref :: ParenPreference
pref = NamedArg (Either Expr (OpApp Expr)) -> ParenPreference
inferParenPref NamedArg (Either Expr (OpApp Expr))
e
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
return [e]
right Fixity
_ NotationPart
_ [NamedArg (Either Expr (OpApp Expr))]
_ = ScopeM [(ParenPreference, NamedArg Expr)]
forall a. HasCallStack => a
__IMPOSSIBLE__
replacePlaceholders ::
OpAppArgs' e ->
ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])
replacePlaceholders :: forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [] = ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
replacePlaceholders (NamedArg (MaybePlaceholder (OpApp e))
a : [NamedArg (MaybePlaceholder (OpApp e))]
as) = case NamedArg (MaybePlaceholder (OpApp e)) -> MaybePlaceholder (OpApp e)
forall a. NamedArg a -> a
namedArg NamedArg (MaybePlaceholder (OpApp e))
a of
NoPlaceholder Maybe PositionInName
_ OpApp e
x -> ([NamedArg (Either Expr (OpApp e))]
-> [NamedArg (Either Expr (OpApp e))])
-> ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (Either Expr (OpApp e)
-> NamedArg (MaybePlaceholder (OpApp e))
-> NamedArg (Either Expr (OpApp e))
forall a b. a -> NamedArg b -> NamedArg a
set (OpApp e -> Either Expr (OpApp e)
forall a b. b -> Either a b
Right OpApp e
x) NamedArg (MaybePlaceholder (OpApp e))
a NamedArg (Either Expr (OpApp e))
-> [NamedArg (Either Expr (OpApp e))]
-> [NamedArg (Either Expr (OpApp e))]
forall a. a -> [a] -> [a]
:) (([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> ([LamBinding], [NamedArg (Either Expr (OpApp e))]))
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[NamedArg (MaybePlaceholder (OpApp e))]
-> TCMT IO ([LamBinding], [NamedArg (Either Expr (OpApp e))])
forall e.
OpAppArgs' e
-> ScopeM ([LamBinding], [NamedArg (Either Expr (OpApp e))])
replacePlaceholders [NamedArg (MaybePlaceholder (OpApp e))]
as
Placeholder PositionInName
_ -> do
x <- Range -> [Char] -> ScopeM Name
forall (m :: * -> *).
MonadFresh NameId m =>
Range -> [Char] -> m Name
freshName Range
forall a. Range' a
noRange [Char]
"section"
let i = 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
(ls, ns) <- replacePlaceholders as
return ( A.mkDomainFree (unnamedArg i $ A.mkBinder_ x) : ls
, set (Left (Var x)) a : ns
)
where
set :: a -> NamedArg b -> NamedArg a
set :: forall a b. a -> NamedArg b -> NamedArg a
set a
x NamedArg b
arg = (Named NamedName b -> Named_ a) -> NamedArg b -> Arg (Named_ a)
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> a) -> Named NamedName b -> Named_ a
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> a
forall a b. a -> b -> a
const a
x)) NamedArg b
arg
checkAttributes :: Attributes -> ScopeM ()
checkAttributes :: Attributes -> TCMT IO ()
checkAttributes [] = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAttributes ((Attribute
attr, Range
r, [Char]
s) : Attributes
attrs) =
case Attribute
attr of
RelevanceAttribute{} -> TCMT IO ()
cont
CA.TacticAttribute{} -> TCMT IO ()
cont
LockAttribute Lock
IsNotLock -> TCMT IO ()
cont
LockAttribute IsLock{} -> do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optGuarded (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> TypeError
AttributeKindNotEnabled [Char]
"Lock" [Char]
"--guarded" [Char]
s
TCMT IO ()
cont
QuantityAttribute Quantityω{} -> TCMT IO ()
cont
QuantityAttribute Quantity1{} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
QuantityAttribute Quantity0{} -> do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optErasure (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> TypeError
AttributeKindNotEnabled [Char]
"Erasure" [Char]
"--erasure" [Char]
s
TCMT IO ()
cont
CohesionAttribute{} -> do
TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optCohesion (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
Range -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range
r (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> TypeError
AttributeKindNotEnabled [Char]
"Cohesion" [Char]
"--cohesion" [Char]
s
TCMT IO ()
cont
where
cont :: TCMT IO ()
cont = Attributes -> TCMT IO ()
checkAttributes Attributes
attrs
instance ToAbstract C.HoleContent where
type AbsOfCon C.HoleContent = A.HoleContent
toAbstract :: HoleContent -> ScopeM (AbsOfCon HoleContent)
toAbstract = \case
HoleContentExpr Expr
e -> Expr -> HoleContent' () BindName Pattern Expr
forall qn nm p e. e -> HoleContent' qn nm p e
HoleContentExpr (Expr -> HoleContent' () BindName Pattern Expr)
-> ScopeM Expr -> TCMT IO (HoleContent' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> ScopeM (AbsOfCon Expr)
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract Expr
e
HoleContentRewrite [RewriteEqn]
es -> [RewriteEqn' () BindName Pattern Expr]
-> HoleContent' () BindName Pattern Expr
forall qn nm p e. [RewriteEqn' qn nm p e] -> HoleContent' qn nm p e
HoleContentRewrite ([RewriteEqn' () BindName Pattern Expr]
-> HoleContent' () BindName Pattern Expr)
-> TCMT IO [RewriteEqn' () BindName Pattern Expr]
-> TCMT IO (HoleContent' () BindName Pattern Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RewriteEqn] -> ScopeM (AbsOfCon [RewriteEqn])
forall c. ToAbstract c => c -> ScopeM (AbsOfCon c)
toAbstract [RewriteEqn]
es