-- {-# OPTIONS -fwarn-unused-binds #-}

{-| The translation of abstract syntax to concrete syntax has two purposes.
    First it allows us to pretty print abstract syntax values without having to
    write a dedicated pretty printer, and second it serves as a sanity check
    for the concrete to abstract translation: translating from concrete to
    abstract and then back again should be (more or less) the identity.
-}
module Agda.Syntax.Translation.AbstractToConcrete
    ( ToConcrete(..)
    , toConcreteCtx
    , MonadAbsToCon
    , abstractToConcrete_
    , abstractToConcreteCtx
    , abstractToConcreteHiding
    , abstractToConcreteQName
    , abstractToConcreteScope
    , abstractToConcreteTelescope
    , RangeAndPragma(..)
    , noTakenNames
    ) where

import Prelude hiding (null)

import Control.Monad.Except ( runExceptT )
import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )
import Control.Monad.State  ( StateT(..), runStateT )

import Data.Bifunctor       ( first )
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Foldable as Fold
import Data.Void
import Data.List (sortBy)
import Data.Semigroup ( sconcat )
import Data.String

import Agda.Syntax.Common
import Agda.Syntax.Common.Pretty
import Agda.Syntax.Position
import Agda.Syntax.Literal
import Agda.Syntax.Info as A
import qualified Agda.Syntax.Internal as I
import Agda.Syntax.Fixity
import Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Pattern as C
import Agda.Syntax.Concrete.Glyph
import Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Views as A
import Agda.Syntax.Abstract.Pattern as A
import Agda.Syntax.Abstract.PatternSynonyms
import Agda.Syntax.Scope.Base
import Agda.Syntax.Scope.Monad ( tryResolveName )

import Agda.TypeChecking.Monad.State (getScope, getAllPatternSyns)
import Agda.TypeChecking.Monad.Base as I
import Agda.TypeChecking.Monad.Context
import Agda.TypeChecking.Monad.Debug
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.MetaVars
import Agda.TypeChecking.Monad.Pure
import Agda.TypeChecking.Monad.Trace
import Agda.TypeChecking.Monad.Signature
import {-# SOURCE #-} Agda.TypeChecking.Records (isRecord)
import {-# SOURCE #-} Agda.TypeChecking.Pretty (prettyTCM)
import Agda.Interaction.Options

import qualified Agda.Utils.AssocList as AssocList
import Agda.Utils.Either
import Agda.Utils.Function
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 Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Syntax.Common.Aspect as Asp
import Agda.Utils.Set1 (Set1)
import qualified Agda.Utils.Set1 as Set1
import Agda.Utils.Singleton
import Agda.Utils.Suffix

import Agda.Utils.Impossible

---------------------------------------------------------------------------
-- * The Interface
---------------------------------------------------------------------------

-- | Preconditions to run the AbstractToConcrete translation.
--
type MonadAbsToCon m =
  ( MonadFresh NameId m
  , MonadInteractionPoints m
  , MonadStConcreteNames m
  , HasOptions m
  , PureTCM m
  , IsString (m Doc)
  , Null (m Doc)
  , Semigroup (m Doc)
  )

abstractToConcreteScope :: (ToConcrete a, MonadAbsToCon m)
  => ScopeInfo -> a -> m (ConOfAbs a)
abstractToConcreteScope :: forall a (m :: * -> *).
(ToConcrete a, MonadAbsToCon m) =>
ScopeInfo -> a -> m (ConOfAbs a)
abstractToConcreteScope ScopeInfo
scope a
a = ReaderT Env m (ConOfAbs a) -> Env -> m (ConOfAbs a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AbsToConT m (ConOfAbs a) -> ReaderT Env m (ConOfAbs a)
forall (m :: * -> *) a. AbsToConT m a -> ReaderT Env m a
unAbsToCon (AbsToConT m (ConOfAbs a) -> ReaderT Env m (ConOfAbs a))
-> AbsToConT m (ConOfAbs a) -> ReaderT Env m (ConOfAbs a)
forall a b. (a -> b) -> a -> b
$ a -> AbsToConT m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete a
a) (Env -> m (ConOfAbs a)) -> m Env -> m (ConOfAbs a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScopeInfo -> m Env
forall (m :: * -> *). MonadAbsToCon m => ScopeInfo -> m Env
makeEnv ScopeInfo
scope

abstractToConcreteCtx :: (ToConcrete a, MonadAbsToCon m)
  => Precedence -> a -> m (ConOfAbs a)
abstractToConcreteCtx :: forall a (m :: * -> *).
(ToConcrete a, MonadAbsToCon m) =>
Precedence -> a -> m (ConOfAbs a)
abstractToConcreteCtx Precedence
ctx a
x = AbsToConT m (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) c. MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon (AbsToConT m (ConOfAbs a) -> m (ConOfAbs a))
-> AbsToConT m (ConOfAbs a) -> m (ConOfAbs a)
forall a b. (a -> b) -> a -> b
$ Precedence -> AbsToConT m (ConOfAbs a) -> AbsToConT m (ConOfAbs a)
forall (m :: * -> *) a.
MonadToConcrete m =>
Precedence -> m a -> m a
withPrecedence Precedence
ctx (a -> AbsToConT m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete a
x)

abstractToConcrete_ :: (ToConcrete a, MonadAbsToCon m)
  => a -> m (ConOfAbs a)
abstractToConcrete_ :: forall a (m :: * -> *).
(ToConcrete a, MonadAbsToCon m) =>
a -> m (ConOfAbs a)
abstractToConcrete_ = AbsToConT m (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) c. MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon (AbsToConT m (ConOfAbs a) -> m (ConOfAbs a))
-> (a -> AbsToConT m (ConOfAbs a)) -> a -> m (ConOfAbs a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AbsToConT m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete

abstractToConcreteHiding :: (LensHiding i, ToConcrete a, MonadAbsToCon m)
  => i -> a -> m (ConOfAbs a)
abstractToConcreteHiding :: forall i a (m :: * -> *).
(LensHiding i, ToConcrete a, MonadAbsToCon m) =>
i -> a -> m (ConOfAbs a)
abstractToConcreteHiding i
i = AbsToConT m (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) c. MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon (AbsToConT m (ConOfAbs a) -> m (ConOfAbs a))
-> (a -> AbsToConT m (ConOfAbs a)) -> a -> m (ConOfAbs a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> a -> AbsToConT m (ConOfAbs a)
forall (m :: * -> *) h a.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> m (ConOfAbs a)
toConcreteHiding i
i

abstractToConcreteTelescope :: MonadAbsToCon m
  => A.Telescope -> m [Maybe C.TypedBinding]
abstractToConcreteTelescope :: forall (m :: * -> *).
MonadAbsToCon m =>
Telescope -> m [Maybe TypedBinding]
abstractToConcreteTelescope Telescope
tel = AbsToConT m [Maybe TypedBinding] -> m [Maybe TypedBinding]
forall (m :: * -> *) c. MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon (AbsToConT m [Maybe TypedBinding] -> m [Maybe TypedBinding])
-> AbsToConT m [Maybe TypedBinding] -> m [Maybe TypedBinding]
forall a b. (a -> b) -> a -> b
$ Telescope
-> (ConOfAbs Telescope -> AbsToConT m [Maybe TypedBinding])
-> AbsToConT m [Maybe TypedBinding]
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Telescope -> (ConOfAbs Telescope -> m b) -> m b
bindToConcrete Telescope
tel [Maybe TypedBinding] -> AbsToConT m [Maybe TypedBinding]
ConOfAbs Telescope -> AbsToConT m [Maybe TypedBinding]
forall a. a -> AbsToConT m a
forall (m :: * -> *) a. Monad m => a -> m a
return

abstractToConcreteQName :: MonadAbsToCon m
  => AllowAmbiguousNames -> A.QName -> m (C.QName)
abstractToConcreteQName :: forall (m :: * -> *).
MonadAbsToCon m =>
AllowAmbiguousNames -> QName -> m QName
abstractToConcreteQName AllowAmbiguousNames
amb = AbsToConT m QName -> m QName
forall (m :: * -> *) c. MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon (AbsToConT m QName -> m QName)
-> (QName -> AbsToConT m QName) -> QName -> m QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowAmbiguousNames -> QName -> AbsToConT m QName
forall (m :: * -> *).
MonadToConcrete m =>
AllowAmbiguousNames -> QName -> m QName
lookupQName AllowAmbiguousNames
amb

---------------------------------------------------------------------------
-- * The Monad for the implementation
---------------------------------------------------------------------------

type MonadToConcrete m =
  ( MonadAbsToCon m
  , MonadReader Env m
  )

newtype AbsToConT m a = AbsToCon { forall (m :: * -> *) a. AbsToConT m a -> ReaderT Env m a
unAbsToCon :: ReaderT Env m a }
  deriving
    ( (forall a b. (a -> b) -> AbsToConT m a -> AbsToConT m b)
-> (forall a b. a -> AbsToConT m b -> AbsToConT m a)
-> Functor (AbsToConT m)
forall a b. a -> AbsToConT m b -> AbsToConT m a
forall a b. (a -> b) -> AbsToConT m a -> AbsToConT m b
forall (m :: * -> *) a b.
Functor m =>
a -> AbsToConT m b -> AbsToConT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> AbsToConT m a -> AbsToConT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> AbsToConT m a -> AbsToConT m b
fmap :: forall a b. (a -> b) -> AbsToConT m a -> AbsToConT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> AbsToConT m b -> AbsToConT m a
<$ :: forall a b. a -> AbsToConT m b -> AbsToConT m a
Functor, Functor (AbsToConT m)
Functor (AbsToConT m) =>
(forall a. a -> AbsToConT m a)
-> (forall a b.
    AbsToConT m (a -> b) -> AbsToConT m a -> AbsToConT m b)
-> (forall a b c.
    (a -> b -> c) -> AbsToConT m a -> AbsToConT m b -> AbsToConT m c)
-> (forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m b)
-> (forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m a)
-> Applicative (AbsToConT m)
forall a. a -> AbsToConT m a
forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m a
forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m b
forall a b. AbsToConT m (a -> b) -> AbsToConT m a -> AbsToConT m b
forall a b c.
(a -> b -> c) -> AbsToConT m a -> AbsToConT m b -> AbsToConT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (AbsToConT m)
forall (m :: * -> *) a. Applicative m => a -> AbsToConT m a
forall (m :: * -> *) a b.
Applicative m =>
AbsToConT m a -> AbsToConT m b -> AbsToConT m a
forall (m :: * -> *) a b.
Applicative m =>
AbsToConT m a -> AbsToConT m b -> AbsToConT m b
forall (m :: * -> *) a b.
Applicative m =>
AbsToConT m (a -> b) -> AbsToConT m a -> AbsToConT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> AbsToConT m a -> AbsToConT m b -> AbsToConT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> AbsToConT m a
pure :: forall a. a -> AbsToConT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
AbsToConT m (a -> b) -> AbsToConT m a -> AbsToConT m b
<*> :: forall a b. AbsToConT m (a -> b) -> AbsToConT m a -> AbsToConT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> AbsToConT m a -> AbsToConT m b -> AbsToConT m c
liftA2 :: forall a b c.
(a -> b -> c) -> AbsToConT m a -> AbsToConT m b -> AbsToConT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
AbsToConT m a -> AbsToConT m b -> AbsToConT m b
*> :: forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
AbsToConT m a -> AbsToConT m b -> AbsToConT m a
<* :: forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m a
Applicative, Applicative (AbsToConT m)
Applicative (AbsToConT m) =>
(forall a b.
 AbsToConT m a -> (a -> AbsToConT m b) -> AbsToConT m b)
-> (forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m b)
-> (forall a. a -> AbsToConT m a)
-> Monad (AbsToConT m)
forall a. a -> AbsToConT m a
forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m b
forall a b. AbsToConT m a -> (a -> AbsToConT m b) -> AbsToConT m b
forall (m :: * -> *). Monad m => Applicative (AbsToConT m)
forall (m :: * -> *) a. Monad m => a -> AbsToConT m a
forall (m :: * -> *) a b.
Monad m =>
AbsToConT m a -> AbsToConT m b -> AbsToConT m b
forall (m :: * -> *) a b.
Monad m =>
AbsToConT m a -> (a -> AbsToConT m b) -> AbsToConT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
AbsToConT m a -> (a -> AbsToConT m b) -> AbsToConT m b
>>= :: forall a b. AbsToConT m a -> (a -> AbsToConT m b) -> AbsToConT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
AbsToConT m a -> AbsToConT m b -> AbsToConT m b
>> :: forall a b. AbsToConT m a -> AbsToConT m b -> AbsToConT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> AbsToConT m a
return :: forall a. a -> AbsToConT m a
Monad, MonadReader Env
    , Monad (AbsToConT m)
Functor (AbsToConT m)
Applicative (AbsToConT m)
(Functor (AbsToConT m), Applicative (AbsToConT m),
 Monad (AbsToConT m)) =>
(SomeBuiltin -> AbsToConT m (Maybe (Builtin PrimFun)))
-> HasBuiltins (AbsToConT m)
SomeBuiltin -> AbsToConT m (Maybe (Builtin PrimFun))
forall (m :: * -> *).
(Functor m, Applicative m, Monad m) =>
(SomeBuiltin -> m (Maybe (Builtin PrimFun))) -> HasBuiltins m
forall (m :: * -> *). HasBuiltins m => Monad (AbsToConT m)
forall (m :: * -> *). HasBuiltins m => Functor (AbsToConT m)
forall (m :: * -> *). HasBuiltins m => Applicative (AbsToConT m)
forall (m :: * -> *).
HasBuiltins m =>
SomeBuiltin -> AbsToConT m (Maybe (Builtin PrimFun))
$cgetBuiltinThing :: forall (m :: * -> *).
HasBuiltins m =>
SomeBuiltin -> AbsToConT m (Maybe (Builtin PrimFun))
getBuiltinThing :: SomeBuiltin -> AbsToConT m (Maybe (Builtin PrimFun))
HasBuiltins
    , Functor (AbsToConT m)
Applicative (AbsToConT m)
HasOptions (AbsToConT m)
MonadTCEnv (AbsToConT m)
MonadDebug (AbsToConT m)
(Functor (AbsToConT m), Applicative (AbsToConT m),
 HasOptions (AbsToConT m), MonadDebug (AbsToConT m),
 MonadTCEnv (AbsToConT m)) =>
(QName -> AbsToConT m Definition)
-> (QName -> AbsToConT m (Either SigError Definition))
-> (QName -> AbsToConT m RewriteRules)
-> HasConstInfo (AbsToConT m)
QName -> AbsToConT m RewriteRules
QName -> AbsToConT m (Either SigError Definition)
QName -> AbsToConT m Definition
forall (m :: * -> *).
(Functor m, Applicative m, HasOptions m, MonadDebug m,
 MonadTCEnv m) =>
(QName -> m Definition)
-> (QName -> m (Either SigError Definition))
-> (QName -> m RewriteRules)
-> HasConstInfo m
forall (m :: * -> *). HasConstInfo m => Functor (AbsToConT m)
forall (m :: * -> *). HasConstInfo m => Applicative (AbsToConT m)
forall (m :: * -> *). HasConstInfo m => HasOptions (AbsToConT m)
forall (m :: * -> *). HasConstInfo m => MonadTCEnv (AbsToConT m)
forall (m :: * -> *). HasConstInfo m => MonadDebug (AbsToConT m)
forall (m :: * -> *).
HasConstInfo m =>
QName -> AbsToConT m RewriteRules
forall (m :: * -> *).
HasConstInfo m =>
QName -> AbsToConT m (Either SigError Definition)
forall (m :: * -> *).
HasConstInfo m =>
QName -> AbsToConT m Definition
$cgetConstInfo :: forall (m :: * -> *).
HasConstInfo m =>
QName -> AbsToConT m Definition
getConstInfo :: QName -> AbsToConT m Definition
$cgetConstInfo' :: forall (m :: * -> *).
HasConstInfo m =>
QName -> AbsToConT m (Either SigError Definition)
getConstInfo' :: QName -> AbsToConT m (Either SigError Definition)
$cgetRewriteRulesFor :: forall (m :: * -> *).
HasConstInfo m =>
QName -> AbsToConT m RewriteRules
getRewriteRulesFor :: QName -> AbsToConT m RewriteRules
HasConstInfo
    , Monad (AbsToConT m)
Functor (AbsToConT m)
Applicative (AbsToConT m)
AbsToConT m PragmaOptions
AbsToConT m CommandLineOptions
(Functor (AbsToConT m), Applicative (AbsToConT m),
 Monad (AbsToConT m)) =>
AbsToConT m PragmaOptions
-> AbsToConT m CommandLineOptions -> HasOptions (AbsToConT m)
forall (m :: * -> *).
(Functor m, Applicative m, Monad m) =>
m PragmaOptions -> m CommandLineOptions -> HasOptions m
forall (m :: * -> *). HasOptions m => Monad (AbsToConT m)
forall (m :: * -> *). HasOptions m => Functor (AbsToConT m)
forall (m :: * -> *). HasOptions m => Applicative (AbsToConT m)
forall (m :: * -> *). HasOptions m => AbsToConT m PragmaOptions
forall (m :: * -> *).
HasOptions m =>
AbsToConT m CommandLineOptions
$cpragmaOptions :: forall (m :: * -> *). HasOptions m => AbsToConT m PragmaOptions
pragmaOptions :: AbsToConT m PragmaOptions
$ccommandLineOptions :: forall (m :: * -> *).
HasOptions m =>
AbsToConT m CommandLineOptions
commandLineOptions :: AbsToConT m CommandLineOptions
HasOptions
    , MonadTCEnv (AbsToConT m)
MonadTCEnv (AbsToConT m) =>
(forall a. Name -> Dom Type -> AbsToConT m a -> AbsToConT m a)
-> (forall a.
    Origin
    -> Name -> Term -> Dom Type -> AbsToConT m a -> AbsToConT m a)
-> (forall a.
    Substitution
    -> (Context -> Context) -> AbsToConT m a -> AbsToConT m a)
-> (forall a.
    Range -> ArgName -> (Name -> AbsToConT m a) -> AbsToConT m a)
-> MonadAddContext (AbsToConT m)
forall a.
Range -> ArgName -> (Name -> AbsToConT m a) -> AbsToConT m a
forall a.
Origin
-> Name -> Term -> Dom Type -> AbsToConT m a -> AbsToConT m a
forall a. Name -> Dom Type -> AbsToConT m a -> AbsToConT m a
forall a.
Substitution
-> (Context -> Context) -> AbsToConT m a -> AbsToConT m a
forall (m :: * -> *).
MonadTCEnv m =>
(forall a. Name -> Dom Type -> m a -> m a)
-> (forall a. Origin -> Name -> Term -> Dom Type -> m a -> m a)
-> (forall a. Substitution -> (Context -> Context) -> m a -> m a)
-> (forall a. Range -> ArgName -> (Name -> m a) -> m a)
-> MonadAddContext m
forall (m :: * -> *). MonadAddContext m => MonadTCEnv (AbsToConT m)
forall (m :: * -> *) a.
MonadAddContext m =>
Range -> ArgName -> (Name -> AbsToConT m a) -> AbsToConT m a
forall (m :: * -> *) a.
MonadAddContext m =>
Origin
-> Name -> Term -> Dom Type -> AbsToConT m a -> AbsToConT m a
forall (m :: * -> *) a.
MonadAddContext m =>
Name -> Dom Type -> AbsToConT m a -> AbsToConT m a
forall (m :: * -> *) a.
MonadAddContext m =>
Substitution
-> (Context -> Context) -> AbsToConT m a -> AbsToConT m a
$caddCtx :: forall (m :: * -> *) a.
MonadAddContext m =>
Name -> Dom Type -> AbsToConT m a -> AbsToConT m a
addCtx :: forall a. Name -> Dom Type -> AbsToConT m a -> AbsToConT m a
$caddLetBinding' :: forall (m :: * -> *) a.
MonadAddContext m =>
Origin
-> Name -> Term -> Dom Type -> AbsToConT m a -> AbsToConT m a
addLetBinding' :: forall a.
Origin
-> Name -> Term -> Dom Type -> AbsToConT m a -> AbsToConT m a
$cupdateContext :: forall (m :: * -> *) a.
MonadAddContext m =>
Substitution
-> (Context -> Context) -> AbsToConT m a -> AbsToConT m a
updateContext :: forall a.
Substitution
-> (Context -> Context) -> AbsToConT m a -> AbsToConT m a
$cwithFreshName :: forall (m :: * -> *) a.
MonadAddContext m =>
Range -> ArgName -> (Name -> AbsToConT m a) -> AbsToConT m a
withFreshName :: forall a.
Range -> ArgName -> (Name -> AbsToConT m a) -> AbsToConT m a
MonadAddContext
    , Monad (AbsToConT m)
Functor (AbsToConT m)
Applicative (AbsToConT m)
AbsToConT m Bool
AbsToConT m Verbosity
AbsToConT m ProfileOptions
(Functor (AbsToConT m), Applicative (AbsToConT m),
 Monad (AbsToConT m)) =>
(ArgName -> VerboseLevel -> TCM Doc -> AbsToConT m ArgName)
-> (forall a.
    ArgName
    -> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a)
-> (forall a.
    ArgName
    -> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a)
-> AbsToConT m Verbosity
-> AbsToConT m ProfileOptions
-> AbsToConT m Bool
-> (forall a. AbsToConT m a -> AbsToConT m a)
-> MonadDebug (AbsToConT m)
ArgName -> VerboseLevel -> TCM Doc -> AbsToConT m ArgName
forall a.
ArgName
-> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a
forall a. AbsToConT m a -> AbsToConT m a
forall (m :: * -> *).
(Functor m, Applicative m, Monad m) =>
(ArgName -> VerboseLevel -> TCM Doc -> m ArgName)
-> (forall a. ArgName -> VerboseLevel -> ArgName -> m a -> m a)
-> (forall a. ArgName -> VerboseLevel -> ArgName -> m a -> m a)
-> m Verbosity
-> m ProfileOptions
-> m Bool
-> (forall a. m a -> m a)
-> MonadDebug m
forall (m :: * -> *). MonadDebug m => Monad (AbsToConT m)
forall (m :: * -> *). MonadDebug m => Functor (AbsToConT m)
forall (m :: * -> *). MonadDebug m => Applicative (AbsToConT m)
forall (m :: * -> *). MonadDebug m => AbsToConT m Bool
forall (m :: * -> *). MonadDebug m => AbsToConT m Verbosity
forall (m :: * -> *). MonadDebug m => AbsToConT m ProfileOptions
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> TCM Doc -> AbsToConT m ArgName
forall (m :: * -> *) a.
MonadDebug m =>
ArgName
-> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a
forall (m :: * -> *) a.
MonadDebug m =>
AbsToConT m a -> AbsToConT m a
$cformatDebugMessage :: forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> TCM Doc -> AbsToConT m ArgName
formatDebugMessage :: ArgName -> VerboseLevel -> TCM Doc -> AbsToConT m ArgName
$ctraceDebugMessage :: forall (m :: * -> *) a.
MonadDebug m =>
ArgName
-> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a
traceDebugMessage :: forall a.
ArgName
-> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a
$cverboseBracket :: forall (m :: * -> *) a.
MonadDebug m =>
ArgName
-> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a
verboseBracket :: forall a.
ArgName
-> VerboseLevel -> ArgName -> AbsToConT m a -> AbsToConT m a
$cgetVerbosity :: forall (m :: * -> *). MonadDebug m => AbsToConT m Verbosity
getVerbosity :: AbsToConT m Verbosity
$cgetProfileOptions :: forall (m :: * -> *). MonadDebug m => AbsToConT m ProfileOptions
getProfileOptions :: AbsToConT m ProfileOptions
$cisDebugPrinting :: forall (m :: * -> *). MonadDebug m => AbsToConT m Bool
isDebugPrinting :: AbsToConT m Bool
$cnowDebugPrinting :: forall (m :: * -> *) a.
MonadDebug m =>
AbsToConT m a -> AbsToConT m a
nowDebugPrinting :: forall a. AbsToConT m a -> AbsToConT m a
MonadDebug
    , MonadTCEnv (AbsToConT m)
ReadTCState (AbsToConT m)
AbsToConT m InteractionId
(MonadTCEnv (AbsToConT m), ReadTCState (AbsToConT m)) =>
AbsToConT m InteractionId
-> ((InteractionPoints -> InteractionPoints) -> AbsToConT m ())
-> MonadInteractionPoints (AbsToConT m)
(InteractionPoints -> InteractionPoints) -> AbsToConT m ()
forall (m :: * -> *).
(MonadTCEnv m, ReadTCState m) =>
m InteractionId
-> ((InteractionPoints -> InteractionPoints) -> m ())
-> MonadInteractionPoints m
forall (m :: * -> *).
MonadInteractionPoints m =>
MonadTCEnv (AbsToConT m)
forall (m :: * -> *).
MonadInteractionPoints m =>
ReadTCState (AbsToConT m)
forall (m :: * -> *).
MonadInteractionPoints m =>
AbsToConT m InteractionId
forall (m :: * -> *).
MonadInteractionPoints m =>
(InteractionPoints -> InteractionPoints) -> AbsToConT m ()
$cfreshInteractionId :: forall (m :: * -> *).
MonadInteractionPoints m =>
AbsToConT m InteractionId
freshInteractionId :: AbsToConT m InteractionId
$cmodifyInteractionPoints :: forall (m :: * -> *).
MonadInteractionPoints m =>
(InteractionPoints -> InteractionPoints) -> AbsToConT m ()
modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> AbsToConT m ()
MonadInteractionPoints
    , Applicative (AbsToConT m)
HasOptions (AbsToConT m)
MonadTCEnv (AbsToConT m)
ReadTCState (AbsToConT m)
(Applicative (AbsToConT m), MonadTCEnv (AbsToConT m),
 ReadTCState (AbsToConT m), HasOptions (AbsToConT m)) =>
(forall a. ReduceM a -> AbsToConT m a) -> MonadReduce (AbsToConT m)
forall a. ReduceM a -> AbsToConT m a
forall (m :: * -> *).
(Applicative m, MonadTCEnv m, ReadTCState m, HasOptions m) =>
(forall a. ReduceM a -> m a) -> MonadReduce m
forall (m :: * -> *). MonadReduce m => Applicative (AbsToConT m)
forall (m :: * -> *). MonadReduce m => HasOptions (AbsToConT m)
forall (m :: * -> *). MonadReduce m => MonadTCEnv (AbsToConT m)
forall (m :: * -> *). MonadReduce m => ReadTCState (AbsToConT m)
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> AbsToConT m a
$cliftReduce :: forall (m :: * -> *) a. MonadReduce m => ReduceM a -> AbsToConT m a
liftReduce :: forall a. ReduceM a -> AbsToConT m a
MonadReduce
    , Monad (AbsToConT m)
AbsToConT m ConcreteNames
Monad (AbsToConT m) =>
(forall a. StateT ConcreteNames (AbsToConT m) a -> AbsToConT m a)
-> AbsToConT m ConcreteNames
-> ((ConcreteNames -> ConcreteNames) -> AbsToConT m ())
-> MonadStConcreteNames (AbsToConT m)
(ConcreteNames -> ConcreteNames) -> AbsToConT m ()
forall a. StateT ConcreteNames (AbsToConT m) a -> AbsToConT m a
forall (m :: * -> *).
Monad m =>
(forall a. StateT ConcreteNames m a -> m a)
-> m ConcreteNames
-> ((ConcreteNames -> ConcreteNames) -> m ())
-> MonadStConcreteNames m
forall (m :: * -> *). MonadStConcreteNames m => Monad (AbsToConT m)
forall (m :: * -> *).
MonadStConcreteNames m =>
AbsToConT m ConcreteNames
forall (m :: * -> *).
MonadStConcreteNames m =>
(ConcreteNames -> ConcreteNames) -> AbsToConT m ()
forall (m :: * -> *) a.
MonadStConcreteNames m =>
StateT ConcreteNames (AbsToConT m) a -> AbsToConT m a
$crunStConcreteNames :: forall (m :: * -> *) a.
MonadStConcreteNames m =>
StateT ConcreteNames (AbsToConT m) a -> AbsToConT m a
runStConcreteNames :: forall a. StateT ConcreteNames (AbsToConT m) a -> AbsToConT m a
$cuseConcreteNames :: forall (m :: * -> *).
MonadStConcreteNames m =>
AbsToConT m ConcreteNames
useConcreteNames :: AbsToConT m ConcreteNames
$cmodifyConcreteNames :: forall (m :: * -> *).
MonadStConcreteNames m =>
(ConcreteNames -> ConcreteNames) -> AbsToConT m ()
modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> AbsToConT m ()
MonadStConcreteNames
    , Monad (AbsToConT m)
AbsToConT m TCEnv
Monad (AbsToConT m) =>
AbsToConT m TCEnv
-> (forall a. (TCEnv -> TCEnv) -> AbsToConT m a -> AbsToConT m a)
-> MonadTCEnv (AbsToConT m)
forall a. (TCEnv -> TCEnv) -> AbsToConT m a -> AbsToConT m a
forall (m :: * -> *).
Monad m =>
m TCEnv
-> (forall a. (TCEnv -> TCEnv) -> m a -> m a) -> MonadTCEnv m
forall (m :: * -> *). MonadTCEnv m => Monad (AbsToConT m)
forall (m :: * -> *). MonadTCEnv m => AbsToConT m TCEnv
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> AbsToConT m a -> AbsToConT m a
$caskTC :: forall (m :: * -> *). MonadTCEnv m => AbsToConT m TCEnv
askTC :: AbsToConT m TCEnv
$clocalTC :: forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> AbsToConT m a -> AbsToConT m a
localTC :: forall a. (TCEnv -> TCEnv) -> AbsToConT m a -> AbsToConT m a
MonadTCEnv
    , MonadTCEnv (AbsToConT m)
MonadReduce (AbsToConT m)
ReadTCState (AbsToConT m)
HasBuiltins (AbsToConT m)
MonadAddContext (AbsToConT m)
MonadDebug (AbsToConT m)
HasConstInfo (AbsToConT m)
(HasBuiltins (AbsToConT m), HasConstInfo (AbsToConT m),
 MonadAddContext (AbsToConT m), MonadDebug (AbsToConT m),
 MonadReduce (AbsToConT m), MonadTCEnv (AbsToConT m),
 ReadTCState (AbsToConT m)) =>
PureTCM (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
MonadTCEnv (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
MonadReduce (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
ReadTCState (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
HasBuiltins (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
MonadAddContext (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
MonadDebug (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m,
 MonadReduce m) =>
HasConstInfo (AbsToConT m)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m, MonadAddContext m, MonadDebug m,
 MonadReduce m, MonadTCEnv m, ReadTCState m) =>
PureTCM m
PureTCM
    , Monad (AbsToConT m)
AbsToConT m TCState
Monad (AbsToConT m) =>
AbsToConT m TCState
-> (forall a b.
    Lens' TCState a -> (a -> a) -> AbsToConT m b -> AbsToConT m b)
-> (forall a.
    (TCState -> TCState) -> AbsToConT m a -> AbsToConT m a)
-> ReadTCState (AbsToConT m)
forall a. (TCState -> TCState) -> AbsToConT m a -> AbsToConT m a
forall a b.
Lens' TCState a -> (a -> a) -> AbsToConT m b -> AbsToConT m b
forall (m :: * -> *).
Monad m =>
m TCState
-> (forall a b. Lens' TCState a -> (a -> a) -> m b -> m b)
-> (forall a. (TCState -> TCState) -> m a -> m a)
-> ReadTCState m
forall (m :: * -> *). ReadTCState m => Monad (AbsToConT m)
forall (m :: * -> *). ReadTCState m => AbsToConT m TCState
forall (m :: * -> *) a.
ReadTCState m =>
(TCState -> TCState) -> AbsToConT m a -> AbsToConT m a
forall (m :: * -> *) a b.
ReadTCState m =>
Lens' TCState a -> (a -> a) -> AbsToConT m b -> AbsToConT m b
$cgetTCState :: forall (m :: * -> *). ReadTCState m => AbsToConT m TCState
getTCState :: AbsToConT m TCState
$clocallyTCState :: forall (m :: * -> *) a b.
ReadTCState m =>
Lens' TCState a -> (a -> a) -> AbsToConT m b -> AbsToConT m b
locallyTCState :: forall a b.
Lens' TCState a -> (a -> a) -> AbsToConT m b -> AbsToConT m b
$cwithTCState :: forall (m :: * -> *) a.
ReadTCState m =>
(TCState -> TCState) -> AbsToConT m a -> AbsToConT m a
withTCState :: forall a. (TCState -> TCState) -> AbsToConT m a -> AbsToConT m a
ReadTCState
    )

deriving instance MonadFresh NameId m => MonadFresh NameId (AbsToConT m)
deriving instance (Monad m, IsString  (m Doc)) => IsString (AbsToConT m Doc)
deriving instance (Monad m, Null      (m Doc)) => Null (AbsToConT m Doc)
deriving instance (Monad m, Semigroup (m Doc)) => Semigroup (AbsToConT m Doc)

runAbsToCon :: MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon :: forall (m :: * -> *) c. MonadAbsToCon m => AbsToConT m c -> m c
runAbsToCon AbsToConT m c
m = do
  scope <- m ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  verboseBracket "toConcrete" 50 "runAbsToCon" $ do
    reportSLn "toConcrete" 50 $ render $ hsep $
      [ "entering AbsToCon with scope:"
      , prettyList_ (map (text . C.nameToRawName . fst) $ scope ^. scopeLocals)
      ]
    x <- runReaderT (unAbsToCon m) =<< makeEnv scope
    reportSLn "toConcrete" 50 $ "leaving AbsToCon"
    return x

---------------------------------------------------------------------------
-- * The Environment
---------------------------------------------------------------------------

data Env = Env
  { Env -> Set Name
takenVarNames :: Set A.Name
      -- ^ Abstract names currently in scope.
      --   Unlike the 'ScopeInfo', this includes names for hidden arguments
      --   inserted by the system.
  , Env -> Set NameParts
takenDefNames :: Set C.NameParts
      -- ^ Concrete names of all definitions in scope.
  , Env -> ScopeInfo
currentScope :: ScopeInfo
  , Env -> Map BuiltinId QName
builtins     :: Map BuiltinId A.QName
      -- ^ Certain builtins (like `fromNat`) have special printing.
  , Env -> Bool
preserveIIds :: Bool
      -- ^ Preserve interaction point ids?
  , Env -> Bool
foldPatternSynonyms :: Bool
  }

makeEnv :: MonadAbsToCon m => ScopeInfo -> m Env
makeEnv :: forall (m :: * -> *). MonadAbsToCon m => ScopeInfo -> m Env
makeEnv ScopeInfo
scope = do
      -- zero and suc doesn't have to be in scope for natural number literals to work
  let noScopeCheck :: BuiltinId -> Bool
noScopeCheck BuiltinId
b = BuiltinId
b BuiltinId -> [BuiltinId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuiltinId
builtinZero, BuiltinId
builtinSuc]
      name :: Term -> Maybe QName
name (I.Def QName
q Elims
_)   = QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q
      name (I.Con ConHead
q ConInfo
_ Elims
_) = QName -> Maybe QName
forall a. a -> Maybe a
Just (ConHead -> QName
I.conName ConHead
q)
      name Term
_             = Maybe QName
forall a. Maybe a
Nothing
      builtin :: BuiltinId -> m [(BuiltinId, QName)]
builtin BuiltinId
b = BuiltinId -> m (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
b m (Maybe Term)
-> (Maybe Term -> m [(BuiltinId, QName)]) -> m [(BuiltinId, QName)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
        Just Term
v | Just QName
q <- Term -> Maybe QName
name Term
v,
                 BuiltinId -> Bool
noScopeCheck BuiltinId
b Bool -> Bool -> Bool
|| QName -> ScopeInfo -> Bool
isNameInScope QName
q ScopeInfo
scope -> [(BuiltinId, QName)] -> m [(BuiltinId, QName)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(BuiltinId
b, QName
q)]
        Maybe Term
_                                                -> [(BuiltinId, QName)] -> m [(BuiltinId, QName)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  ctxVars <- (Dom' Term (Name, Type) -> Name) -> Context -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ((Name, Type) -> Name
forall a b. (a, b) -> a
fst ((Name, Type) -> Name)
-> (Dom' Term (Name, Type) -> (Name, Type))
-> Dom' Term (Name, Type)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom' Term (Name, Type) -> (Name, Type)
forall t e. Dom' t e -> e
I.unDom) (Context -> [Name]) -> m Context -> m [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> Context) -> m Context
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Context
envContext
  letVars <- Map.keys <$> asksTC envLetBindings
  let vars = [Name]
ctxVars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
letVars

  -- pick concrete names for in-scope names now so we don't
  -- accidentally shadow them
  forM_ (scope ^. scopeLocals) $ \(Name
y , LocalVar
x) -> do
    Name -> Name -> m ()
forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName (LocalVar -> Name
localVar LocalVar
x) Name
y

  builtinList <- concat <$> mapM builtin [ builtinFromNat, builtinFromString, builtinFromNeg, builtinZero, builtinSuc ]
  foldPatSyns <- optPrintPatternSynonyms <$> pragmaOptions
  return $
    Env { takenVarNames = Set.fromList vars
        , takenDefNames = defs
        , currentScope = scope
        , builtins     = Map.fromListWith __IMPOSSIBLE__ builtinList
        , preserveIIds = False
        , foldPatternSynonyms = foldPatSyns
        }
  where
    defs :: Set NameParts
defs = (Name -> NameParts) -> Set Name -> Set NameParts
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> NameParts
nameParts (Set Name -> Set NameParts)
-> (Map Name (NonEmpty AbstractName) -> Set Name)
-> Map Name (NonEmpty AbstractName)
-> Set NameParts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name (NonEmpty AbstractName) -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Map Name (NonEmpty AbstractName) -> Set NameParts)
-> Map Name (NonEmpty AbstractName) -> Set NameParts
forall a b. (a -> b) -> a -> b
$
        (Name -> NonEmpty AbstractName -> Bool)
-> Map Name (NonEmpty AbstractName)
-> Map Name (NonEmpty AbstractName)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Name -> NonEmpty AbstractName -> Bool
forall {t :: * -> *}. Foldable t => Name -> t AbstractName -> Bool
usefulDef (Map Name (NonEmpty AbstractName)
 -> Map Name (NonEmpty AbstractName))
-> Map Name (NonEmpty AbstractName)
-> Map Name (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$
        NameSpace -> Map Name (NonEmpty AbstractName)
nsNames (NameSpace -> Map Name (NonEmpty AbstractName))
-> NameSpace -> Map Name (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$ ScopeInfo -> NameSpace
everythingInScope ScopeInfo
scope

    -- Jesper, 2018-12-10: It's fine to shadow generalizable names as
    -- they will never show up directly in printed terms.
    notGeneralizeName :: AbstractName -> Bool
notGeneralizeName AbsName{ anameKind :: AbstractName -> KindOfName
anameKind = KindOfName
k }  =
      Bool -> Bool
not (KindOfName
k KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
GeneralizeName Bool -> Bool -> Bool
|| KindOfName
k KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
DisallowedGeneralizeName)

    usefulDef :: Name -> t AbstractName -> Bool
usefulDef C.NoName{} t AbstractName
_ = Bool
False
    usefulDef C.Name{} t AbstractName
names = (AbstractName -> Bool) -> t AbstractName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AbstractName -> Bool
notGeneralizeName t AbstractName
names

    nameParts :: Name -> NameParts
nameParts (C.NoName {}) = NameParts
forall a. HasCallStack => a
__IMPOSSIBLE__
    nameParts (C.Name { NameParts
nameNameParts :: NameParts
nameNameParts :: Name -> NameParts
nameNameParts }) = NameParts
nameNameParts

-- | Bind a concrete name to an abstract in the translation environment.
addBinding :: C.Name -> A.Name -> Env -> Env
addBinding :: Name -> Name -> Env -> Env
addBinding Name
y Name
x Env
e =
  Env
e { takenVarNames = Set.insert x $ takenVarNames e
    , currentScope = (`updateScopeLocals` currentScope e) $
        AssocList.insert y (LocalVar x __IMPOSSIBLE__ [])
    }

---------------------------------------------------------------------------
-- * Service functions
---------------------------------------------------------------------------

currentPrecedence :: MonadToConcrete m => m PrecedenceStack
currentPrecedence :: forall (m :: * -> *). MonadToConcrete m => m PrecedenceStack
currentPrecedence = (Env -> PrecedenceStack) -> m PrecedenceStack
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> PrecedenceStack) -> m PrecedenceStack)
-> (Env -> PrecedenceStack) -> m PrecedenceStack
forall a b. (a -> b) -> a -> b
$ (ScopeInfo -> Lens' ScopeInfo PrecedenceStack -> PrecedenceStack
forall o i. o -> Lens' o i -> i
^. (PrecedenceStack -> f PrecedenceStack) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo PrecedenceStack
scopePrecedence) (ScopeInfo -> PrecedenceStack)
-> (Env -> ScopeInfo) -> Env -> PrecedenceStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ScopeInfo
currentScope

preserveInteractionIds :: MonadToConcrete m => m a -> m a
preserveInteractionIds :: forall (m :: * -> *) a. MonadToConcrete m => m a -> m a
preserveInteractionIds = (Env -> Env) -> m a -> m a
forall a. (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> m a -> m a) -> (Env -> Env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \ Env
e -> Env
e { preserveIIds = True }

withPrecedence' :: MonadToConcrete m => PrecedenceStack -> m a -> m a
withPrecedence' :: forall (m :: * -> *) a.
MonadToConcrete m =>
PrecedenceStack -> m a -> m a
withPrecedence' PrecedenceStack
ps = (Env -> Env) -> m a -> m a
forall a. (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> m a -> m a) -> (Env -> Env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \Env
e ->
  Env
e { currentScope = set scopePrecedence ps (currentScope e) }

withPrecedence :: MonadToConcrete m => Precedence -> m a -> m a
withPrecedence :: forall (m :: * -> *) a.
MonadToConcrete m =>
Precedence -> m a -> m a
withPrecedence Precedence
p m a
ret = do
  ps <- m PrecedenceStack
forall (m :: * -> *). MonadToConcrete m => m PrecedenceStack
currentPrecedence
  withPrecedence' (pushPrecedence p ps) ret

withScope :: MonadToConcrete m => ScopeInfo -> m a -> m a
withScope :: forall (m :: * -> *) a.
MonadToConcrete m =>
ScopeInfo -> m a -> m a
withScope ScopeInfo
scope = (Env -> Env) -> m a -> m a
forall a. (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> m a -> m a) -> (Env -> Env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \Env
e -> Env
e { currentScope = scope }

noTakenNames :: MonadToConcrete m => m a -> m a
noTakenNames :: forall (m :: * -> *) a. MonadToConcrete m => m a -> m a
noTakenNames = (Env -> Env) -> m a -> m a
forall a. (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> m a -> m a) -> (Env -> Env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \Env
e -> Env
e { takenVarNames = Set.empty }

dontFoldPatternSynonyms :: MonadToConcrete m => m a -> m a
dontFoldPatternSynonyms :: forall (m :: * -> *) a. MonadToConcrete m => m a -> m a
dontFoldPatternSynonyms = (Env -> Env) -> m a -> m a
forall a. (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> m a -> m a) -> (Env -> Env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \ Env
e -> Env
e { foldPatternSynonyms = False }

-- | Get a function to check if a name refers to a particular builtin function.
isBuiltinFun :: MonadToConcrete m => m (A.QName -> BuiltinId -> Bool)
isBuiltinFun :: forall (m :: * -> *).
MonadToConcrete m =>
m (QName -> BuiltinId -> Bool)
isBuiltinFun = (Env -> QName -> BuiltinId -> Bool)
-> m (QName -> BuiltinId -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> QName -> BuiltinId -> Bool)
 -> m (QName -> BuiltinId -> Bool))
-> (Env -> QName -> BuiltinId -> Bool)
-> m (QName -> BuiltinId -> Bool)
forall a b. (a -> b) -> a -> b
$ Map BuiltinId QName -> QName -> BuiltinId -> Bool
forall {k} {a}. (Ord k, Eq a) => Map k a -> a -> k -> Bool
is (Map BuiltinId QName -> QName -> BuiltinId -> Bool)
-> (Env -> Map BuiltinId QName)
-> Env
-> QName
-> BuiltinId
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map BuiltinId QName
builtins
  where is :: Map k a -> a -> k -> Bool
is Map k a
m a
q k
b = a -> Maybe a
forall a. a -> Maybe a
Just a
q Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
b Map k a
m

-- | Resolve a concrete name. If illegally ambiguous fail with the ambiguous names.
resolveName :: MonadToConcrete m => KindsOfNames -> Maybe (Set1 A.Name) -> C.QName -> m (Either NameResolutionError ResolvedName)
resolveName :: forall (m :: * -> *).
MonadToConcrete m =>
KindsOfNames
-> Maybe (Set1 Name)
-> QName
-> m (Either NameResolutionError ResolvedName)
resolveName KindsOfNames
kinds Maybe (Set1 Name)
candidates QName
q = ExceptT NameResolutionError m ResolvedName
-> m (Either NameResolutionError ResolvedName)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NameResolutionError m ResolvedName
 -> m (Either NameResolutionError ResolvedName))
-> ExceptT NameResolutionError m ResolvedName
-> m (Either NameResolutionError ResolvedName)
forall a b. (a -> b) -> a -> b
$ KindsOfNames
-> Maybe (Set1 Name)
-> QName
-> ExceptT NameResolutionError m ResolvedName
forall (m :: * -> *).
(ReadTCState m, HasBuiltins m, MonadError NameResolutionError m) =>
KindsOfNames -> Maybe (Set1 Name) -> QName -> m ResolvedName
tryResolveName KindsOfNames
kinds Maybe (Set1 Name)
candidates QName
q

-- | Treat illegally ambiguous names as UnknownNames.
resolveName_ :: MonadToConcrete m => C.QName -> A.Name -> m ResolvedName
resolveName_ :: forall (m :: * -> *).
MonadToConcrete m =>
QName -> Name -> m ResolvedName
resolveName_ QName
q Name
cand = (NameResolutionError -> ResolvedName)
-> Either NameResolutionError ResolvedName -> ResolvedName
forall a b. (a -> b) -> Either a b -> b
fromRight (ResolvedName -> NameResolutionError -> ResolvedName
forall a b. a -> b -> a
const ResolvedName
UnknownName) (Either NameResolutionError ResolvedName -> ResolvedName)
-> m (Either NameResolutionError ResolvedName) -> m ResolvedName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindsOfNames
-> Maybe (Set1 Name)
-> QName
-> m (Either NameResolutionError ResolvedName)
forall (m :: * -> *).
MonadToConcrete m =>
KindsOfNames
-> Maybe (Set1 Name)
-> QName
-> m (Either NameResolutionError ResolvedName)
resolveName KindsOfNames
allKindsOfNames (Set1 Name -> Maybe (Set1 Name)
forall a. a -> Maybe a
Just (Set1 Name -> Maybe (Set1 Name)) -> Set1 Name -> Maybe (Set1 Name)
forall a b. (a -> b) -> a -> b
$ Name -> Set1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
cand) QName
q

---------------------------------------------------------------------------
-- ** Dealing with names
---------------------------------------------------------------------------

-- | Names in abstract syntax are fully qualified, but the concrete syntax
--   requires non-qualified names in places. In theory (if all scopes are
--   correct), we should get a non-qualified name when translating back to a
--   concrete name, but I suspect the scope isn't always perfect. In these
--   cases we just throw away the qualified part. It's just for pretty printing
--   anyway...
unsafeQNameToName :: C.QName -> C.Name
unsafeQNameToName :: QName -> Name
unsafeQNameToName = QName -> Name
C.unqualify

-- | Like 'isRecordConstructor' but does not throw IMPOSSIBLE if the
-- name is not in scope.
isExistingRecordConstructor :: MonadToConcrete m => A.QName -> m (Maybe (A.QName, RecordData))
isExistingRecordConstructor :: forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (Maybe (QName, RecordData))
isExistingRecordConstructor QName
c = QName -> m (Either SigError Definition)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Either SigError Definition)
getConstInfo' QName
c m (Either SigError Definition)
-> (Either SigError Definition -> m (Maybe (QName, RecordData)))
-> m (Maybe (QName, RecordData))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left (SigUnknown ArgName
err)     -> Maybe (QName, RecordData) -> m (Maybe (QName, RecordData))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (QName, RecordData)
forall a. Maybe a
Nothing
  Left SigError
SigCubicalNotErasure -> Maybe (QName, RecordData) -> m (Maybe (QName, RecordData))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (QName, RecordData)
forall a. Maybe a
Nothing
  Left SigError
SigAbstract          -> Maybe (QName, RecordData) -> m (Maybe (QName, RecordData))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (QName, RecordData)
forall a. Maybe a
Nothing
  Right Definition
def                 -> case Definition -> Defn
theDef (Definition -> Defn) -> Definition -> Defn
forall a b. (a -> b) -> a -> b
$ Definition
def of
    I.Constructor{ conData :: Defn -> QName
conData = QName
r } -> (RecordData -> (QName, RecordData))
-> Maybe RecordData -> Maybe (QName, RecordData)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName
r,) (Maybe RecordData -> Maybe (QName, RecordData))
-> m (Maybe RecordData) -> m (Maybe (QName, RecordData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (Maybe RecordData)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe RecordData)
isRecord QName
r
    Defn
_                            -> Maybe (QName, RecordData) -> m (Maybe (QName, RecordData))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (QName, RecordData)
forall a. Maybe a
Nothing


lookupQName :: MonadToConcrete m => AllowAmbiguousNames -> A.QName -> m C.QName
lookupQName :: forall (m :: * -> *).
MonadToConcrete m =>
AllowAmbiguousNames -> QName -> m QName
lookupQName AllowAmbiguousNames
ambCon QName
x | Just ArgName
s <- QName -> Maybe ArgName
getGeneralizedFieldName QName
x =
  QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ Range -> NameInScope -> NameParts -> Name
C.Name Range
forall a. Range' a
noRange NameInScope
C.InScope (NameParts -> Name) -> NameParts -> Name
forall a b. (a -> b) -> a -> b
$ ArgName -> NameParts
C.stringNameParts ArgName
s)
lookupQName AllowAmbiguousNames
ambCon QName
x = m (Maybe (QName, RecordData)) -> m (Maybe (QName, RecordData))
forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
ignoreAbstractMode (QName -> m (Maybe (QName, RecordData))
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (Maybe (QName, RecordData))
isExistingRecordConstructor QName
x) m (Maybe (QName, RecordData))
-> (Maybe (QName, RecordData) -> m QName) -> m QName
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  -- If the QName is the internal name of a record with no named
  -- constructor, we should first concretise the name *of the record*,
  -- since that will *actually* be in scope through a concrete QName.
  Just (QName
r, RecordData
def) | Bool -> Bool
not (RecordData -> Bool
_recNamedCon RecordData
def) -> do
    ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"scope.inverse" VerboseLevel
100 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$
      ArgName
"inverse lookup of record constructor " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ QName -> ArgName
forall a. Pretty a => a -> ArgName
prettyShow QName
x
    recr <- AllowAmbiguousNames -> QName -> m QName
forall (m :: * -> *).
MonadToConcrete m =>
AllowAmbiguousNames -> QName -> m QName
lookupQName AllowAmbiguousNames
ambCon QName
r
    pure (recr `C.qualify` simpleName "constructor")

  Maybe (QName, RecordData)
_ -> do
    ys <- (Env -> [QName]) -> m [QName]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (AllowAmbiguousNames -> QName -> ScopeInfo -> [QName]
inverseScopeLookupName' AllowAmbiguousNames
ambCon QName
x (ScopeInfo -> [QName]) -> (Env -> ScopeInfo) -> Env -> [QName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ScopeInfo
currentScope)
    reportSLn "scope.inverse" 100 $
      "inverse looking up abstract name " ++ prettyShow x ++ " yields " ++ prettyShow ys
    loop ys

  where
    -- Found concrete name: check that it is not shadowed by a local
    loop :: [QName] -> m QName
loop (qy :: QName
qy@Qual{}      : [QName]
_ ) = QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
qy -- local names cannot be qualified
    loop (qy :: QName
qy@(C.QName Name
y) : [QName]
ys) = Name -> m (Maybe Name)
forall (m :: * -> *). MonadToConcrete m => Name -> m (Maybe Name)
lookupNameInScope Name
y m (Maybe Name) -> (Maybe Name -> m QName) -> m QName
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Name
x' | Name
x' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= QName -> Name
qnameName QName
x -> [QName] -> m QName
loop [QName]
ys
      Maybe Name
_ -> QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
qy
    -- Found no concrete name: make up a new one
    loop [] = case QName -> QName
qnameToConcrete QName
x of
      qy :: QName
qy@Qual{}    -> QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> m QName) -> QName -> m QName
forall a b. (a -> b) -> a -> b
$ QName -> QName
forall a. LensInScope a => a -> a
setNotInScope QName
qy
      qy :: QName
qy@C.QName{} -> Name -> QName
C.QName (Name -> QName) -> m Name -> m QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m Name
forall (m :: * -> *). MonadToConcrete m => Name -> m Name
chooseName (QName -> Name
qnameName QName
x)

lookupModule :: MonadToConcrete m => A.ModuleName -> m C.QName
lookupModule :: forall (m :: * -> *). MonadToConcrete m => ModuleName -> m QName
lookupModule (A.MName []) = QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> m QName) -> QName -> m QName
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ ArgName -> Name
C.simpleName ArgName
"-1"
  -- Andreas, 2016-10-10 it can happen that we have an empty module name
  -- for instance when we query the current module inside the
  -- frontmatter or module telescope of the top level module.
  -- In this case, we print it as an invalid module name.
  -- (Should only affect debug printing.)
lookupModule ModuleName
x =
    do  scope <- (Env -> ScopeInfo) -> m ScopeInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ScopeInfo
currentScope
        case inverseScopeLookupModule x scope of
            (QName
y : [QName]
_) -> QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
y
            []      -> QName -> m QName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> m QName) -> QName -> m QName
forall a b. (a -> b) -> a -> b
$ ModuleName -> QName
mnameToConcrete ModuleName
x
                -- this is what happens for names that are not in scope (private names)

-- | Is this concrete name currently in use by a particular abstract
--   name in the current scope?
lookupNameInScope :: MonadToConcrete m => C.Name -> m (Maybe A.Name)
lookupNameInScope :: forall (m :: * -> *). MonadToConcrete m => Name -> m (Maybe Name)
lookupNameInScope Name
y =
  (Env -> Maybe Name) -> m (Maybe Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (((LocalVar -> Name) -> Maybe LocalVar -> Maybe Name
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalVar -> Name
localVar (Maybe LocalVar -> Maybe Name)
-> ([(Name, LocalVar)] -> Maybe LocalVar)
-> [(Name, LocalVar)]
-> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [(Name, LocalVar)] -> Maybe LocalVar
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
y) ([(Name, LocalVar)] -> Maybe Name)
-> (Env -> [(Name, LocalVar)]) -> Env -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ScopeInfo
-> Lens' ScopeInfo [(Name, LocalVar)] -> [(Name, LocalVar)]
forall o i. o -> Lens' o i -> i
^. ([(Name, LocalVar)] -> f [(Name, LocalVar)])
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo [(Name, LocalVar)]
scopeLocals) (ScopeInfo -> [(Name, LocalVar)])
-> (Env -> ScopeInfo) -> Env -> [(Name, LocalVar)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ScopeInfo
currentScope))

-- | Have we already committed to a specific concrete name for this
--   abstract name? If yes, return the concrete name(s).
hasConcreteNames :: (MonadStConcreteNames m) => A.Name -> m [C.Name]
hasConcreteNames :: forall (m :: * -> *). MonadStConcreteNames m => Name -> m [Name]
hasConcreteNames Name
x = [Name] -> (List1 Name -> [Name]) -> Maybe (List1 Name) -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] List1 Name -> [Item (List1 Name)]
List1 Name -> [Name]
forall l. IsList l => l -> [Item l]
List1.toList (Maybe (List1 Name) -> [Name])
-> (ConcreteNames -> Maybe (List1 Name)) -> ConcreteNames -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ConcreteNames -> Maybe (List1 Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (ConcreteNames -> [Name]) -> m ConcreteNames -> m [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ConcreteNames
forall (m :: * -> *). MonadStConcreteNames m => m ConcreteNames
useConcreteNames

-- | Commit to a specific concrete name for printing the given
--   abstract name. If the abstract name already has associated
---  concrete name(s), the new name is only used when all previous
---  names are shadowed. Precondition: the abstract name should be in
--   scope.
pickConcreteName :: (MonadStConcreteNames m) => A.Name -> C.Name -> m ()
pickConcreteName :: forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName Name
x Name
y = (ConcreteNames -> ConcreteNames) -> m ()
forall (m :: * -> *).
MonadStConcreteNames m =>
(ConcreteNames -> ConcreteNames) -> m ()
modifyConcreteNames ((ConcreteNames -> ConcreteNames) -> m ())
-> (ConcreteNames -> ConcreteNames) -> m ()
forall a b. (a -> b) -> a -> b
$ ((Maybe (List1 Name) -> Maybe (List1 Name))
 -> Name -> ConcreteNames -> ConcreteNames)
-> Name
-> (Maybe (List1 Name) -> Maybe (List1 Name))
-> ConcreteNames
-> ConcreteNames
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (List1 Name) -> Maybe (List1 Name))
-> Name -> ConcreteNames -> ConcreteNames
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Name
x ((Maybe (List1 Name) -> Maybe (List1 Name))
 -> ConcreteNames -> ConcreteNames)
-> (Maybe (List1 Name) -> Maybe (List1 Name))
-> ConcreteNames
-> ConcreteNames
forall a b. (a -> b) -> a -> b
$ List1 Name -> Maybe (List1 Name)
forall a. a -> Maybe a
Just (List1 Name -> Maybe (List1 Name))
-> (Maybe (List1 Name) -> List1 Name)
-> Maybe (List1 Name)
-> Maybe (List1 Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Maybe (List1 Name)
Nothing -> Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
y
    Just List1 Name
ys -> [Name] -> Name -> List1 Name
forall a. [a] -> a -> List1 a
List1.snoc (List1 Name -> [Item (List1 Name)]
forall l. IsList l => l -> [Item l]
List1.toList List1 Name
ys) Name
y

-- | For the given abstract name, return the names that could shadow it.
shadowingNames :: (ReadTCState m, MonadStConcreteNames m)
               => A.Name -> m (Set RawName)
shadowingNames :: forall (m :: * -> *).
(ReadTCState m, MonadStConcreteNames m) =>
Name -> m (Set ArgName)
shadowingNames Name
x = Maybe (Set1 ArgName) -> Set ArgName
forall a. Maybe (Set1 a) -> Set a
Set1.toSet' (Maybe (Set1 ArgName) -> Set ArgName)
-> (Map Name (Set1 ArgName) -> Maybe (Set1 ArgName))
-> Map Name (Set1 ArgName)
-> Set ArgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name (Set1 ArgName) -> Maybe (Set1 ArgName)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (Map Name (Set1 ArgName) -> Set ArgName)
-> m (Map Name (Set1 ArgName)) -> m (Set ArgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCState (Map Name (Set1 ArgName))
-> m (Map Name (Set1 ArgName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useR (Map Name (Set1 ArgName) -> f (Map Name (Set1 ArgName)))
-> TCState -> f TCState
Lens' TCState (Map Name (Set1 ArgName))
stShadowingNames

toConcreteName :: MonadToConcrete m => A.Name -> m C.Name
toConcreteName :: forall (m :: * -> *). MonadToConcrete m => Name -> m Name
toConcreteName Name
x | Name
y <- Name -> Name
nameConcrete Name
x , Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
y = Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y
toConcreteName Name
x = Name -> m [Name]
forall (m :: * -> *). MonadStConcreteNames m => Name -> m [Name]
hasConcreteNames Name
x m [Name] -> ([Name] -> m Name) -> m Name
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Name] -> m Name
loop
  where
    -- case: we already have picked some name(s) for x
    loop :: [Name] -> m Name
loop (Name
y:[Name]
ys) = m Bool -> m Name -> m Name -> m Name
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Name -> Name -> m Bool
forall (m :: * -> *). MonadToConcrete m => Name -> Name -> m Bool
isGoodName Name
x Name
y) (Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y) ([Name] -> m Name
loop [Name]
ys)

    -- case: we haven't picked a concrete name yet, or all previously
    -- picked names are shadowed, so we pick a new name now
    loop [] = do
      y <- Name -> m Name
forall (m :: * -> *). MonadToConcrete m => Name -> m Name
chooseName Name
x
      pickConcreteName x y
      return y

    -- Is 'y' a good concrete name for abstract name 'x'?
    isGoodName :: MonadToConcrete m => A.Name -> C.Name -> m Bool
    isGoodName :: forall (m :: * -> *). MonadToConcrete m => Name -> Name -> m Bool
isGoodName Name
x Name
y = do
      zs <- (Env -> [Name]) -> m [Name]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> [Name]) -> (Env -> Set Name) -> Env -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Set Name
takenVarNames)
      allM zs $ \Name
z -> if Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
z then Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
        czs <- Name -> m [Name]
forall (m :: * -> *). MonadStConcreteNames m => Name -> m [Name]
hasConcreteNames Name
z
        return $ notElem y czs


-- | Choose a new unshadowed name for the given abstract name
-- | NOTE: See @withName@ in @Agda.Syntax.Translation.ReflectedToAbstract@ for similar logic.
-- | NOTE: See @freshConcreteName@ in @Agda.Syntax.Scope.Monad@ also for similar logic.
chooseName :: MonadToConcrete m => A.Name -> m C.Name
chooseName :: forall (m :: * -> *). MonadToConcrete m => Name -> m Name
chooseName Name
x = Name -> m (Maybe Name)
forall (m :: * -> *). MonadToConcrete m => Name -> m (Maybe Name)
lookupNameInScope (Name -> Name
nameConcrete Name
x) m (Maybe Name) -> (Maybe Name -> m Name) -> m Name
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  -- If the name is currently in scope, we do not rename it
  Just Name
x' | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x' -> do
    ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"toConcrete.bindName" VerboseLevel
80 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$
      ArgName
"name " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Name -> ArgName
C.nameToRawName (Name -> Name
nameConcrete Name
x) ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ ArgName
" already in scope, so not renaming"
    Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x
  -- Otherwise we pick a name that does not shadow other names
  Maybe Name
_ -> do
    takenDefs <- (Env -> Set NameParts) -> m (Set NameParts)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Set NameParts
takenDefNames
    taken   <- takenNames
    toAvoid <- shadowingNames x
    glyphMode <- optUseUnicode <$> pragmaOptions
    let freshNameMode = case UnicodeOrAscii
glyphMode of
          UnicodeOrAscii
UnicodeOk -> FreshNameMode
A.UnicodeSubscript
          UnicodeOrAscii
AsciiOnly -> FreshNameMode
A.AsciiCounter

        shouldAvoid C.NoName {} = Bool
False
        shouldAvoid name :: Name
name@C.Name { NameParts
nameNameParts :: Name -> NameParts
nameNameParts :: NameParts
nameNameParts } =
          let raw :: ArgName
raw = Name -> ArgName
C.nameToRawName Name
name in
          NameParts
nameNameParts NameParts -> Set NameParts -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NameParts
takenDefs Bool -> Bool -> Bool
||
          ArgName
raw ArgName -> Set ArgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ArgName
taken Bool -> Bool -> Bool
||
          ArgName
raw ArgName -> Set ArgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ArgName
toAvoid

        y = FreshNameMode -> (Name -> Bool) -> Name -> Name
firstNonTakenName FreshNameMode
freshNameMode Name -> Bool
shouldAvoid (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x
    reportSLn "toConcrete.bindName" 80 $ render $ vcat
      [ "picking concrete name for:" <+> text (C.nameToRawName $ nameConcrete x)
      , "names already taken:      " <+> prettyList_ (Set.toList taken)
      , "names to avoid:           " <+> prettyList_ (Set.toList toAvoid)
      , "concrete name chosen:     " <+> text (C.nameToRawName y)
      ]
    return y

  where
    takenNames :: MonadToConcrete m => m (Set RawName)
    takenNames :: forall (m :: * -> *). MonadToConcrete m => m (Set ArgName)
takenNames = do
      ys0 <- (Env -> Set Name) -> m (Set Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Set Name
takenVarNames
      reportSLn "toConcrete.bindName" 90 $ render $ "abstract names of local vars: " <+> prettyList_ (map (C.nameToRawName . nameConcrete) $ Set.toList ys0)
      ys <- Set.fromList . concat <$> mapM hasConcreteNames (Set.toList ys0)
      return $ Set.map C.nameToRawName ys


-- | Add a abstract name to the scope and produce an available concrete version of it.
bindName :: MonadToConcrete m => A.Name -> (C.Name -> m a) -> m a
bindName :: forall (m :: * -> *) a.
MonadToConcrete m =>
Name -> (Name -> m a) -> m a
bindName Name
x Name -> m a
ret = do
  y <- Name -> m Name
forall (m :: * -> *). MonadToConcrete m => Name -> m Name
toConcreteName Name
x
  reportSLn "toConcrete.bindName" 30 $ "adding " ++ C.nameToRawName (nameConcrete x) ++ " to the scope under concrete name " ++ C.nameToRawName y
  local (addBinding y x) $ ret y

-- | Like 'bindName', but do not care whether name is already taken.
bindName' :: MonadToConcrete m => A.Name -> m a -> m a
bindName' :: forall (m :: * -> *) a. MonadToConcrete m => Name -> m a -> m a
bindName' Name
x m a
ret = do
  ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"toConcrete.bindName" VerboseLevel
30 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"adding " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Name -> ArgName
C.nameToRawName (Name -> Name
nameConcrete Name
x) ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ ArgName
" to the scope with forced name"
  Name -> Name -> m ()
forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName Name
x Name
y
  Bool -> (m a -> m a) -> m a -> m a
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyUnless (Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
y) ((Env -> Env) -> m a -> m a
forall a. (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> m a -> m a) -> (Env -> Env) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Env -> Env
addBinding Name
y Name
x) m a
ret
  where y :: Name
y = Name -> Name
nameConcrete Name
x

---------------------------------------------------------------------------
-- ** Dealing with precedences
---------------------------------------------------------------------------

-- | General bracketing function.
bracket' :: MonadToConcrete m
  => (e -> e)
       -- ^ The bracketing function.
  -> (PrecedenceStack -> Bool)
       -- ^ Should we bracket things which have the given precedence?
  -> e
  -> m e
bracket' :: forall (m :: * -> *) e.
MonadToConcrete m =>
(e -> e) -> (PrecedenceStack -> Bool) -> e -> m e
bracket' e -> e
paren PrecedenceStack -> Bool
needParen e
e =
    do  p <- m PrecedenceStack
forall (m :: * -> *). MonadToConcrete m => m PrecedenceStack
currentPrecedence
        return $ if needParen p then paren e else e

-- | Expression bracketing
bracket :: MonadToConcrete m => (PrecedenceStack -> Bool) -> m C.Expr -> m C.Expr
bracket :: forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
par m Expr
m =
    do  e <- m Expr
m
        bracket' (Paren (getRange e)) par e

-- | Pattern bracketing
bracketP_ :: MonadToConcrete m => (PrecedenceStack -> Bool) -> m C.Pattern -> m C.Pattern
bracketP_ :: forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Pattern -> m Pattern
bracketP_ PrecedenceStack -> Bool
par m Pattern
m =
    do  e <- m Pattern
m
        bracket' (ParenP (getRange e)) par e

-- | Applications where the argument is a lambda without parentheses need
--   parens more often than other applications.
isLambda :: NamedArg A.Expr -> Bool
isLambda :: NamedArg Expr -> Bool
isLambda NamedArg Expr
e | NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
notVisible NamedArg Expr
e = Bool
False
isLambda NamedArg Expr
e =
  case Expr -> Expr
unScope (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
e of
    A.Lam{}         -> Bool
True
    A.AbsurdLam{}   -> Bool
True
    A.ExtendedLam{} -> Bool
True
    Expr
_               -> Bool
False

---------------------------------------------------------------------------
-- ** Dealing with infix declarations
---------------------------------------------------------------------------

-- | If a name is defined with a fixity that differs from the default, we have
--   to generate a fixity declaration for that name.
withInfixDecl :: MonadToConcrete m => DefInfo -> C.Name -> m [C.Declaration] -> m [C.Declaration]
withInfixDecl :: forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> Name -> m [Declaration] -> m [Declaration]
withInfixDecl DefInfo
i Name
x m [Declaration]
m = (([Declaration]
fixDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
synDecl) [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++) ([Declaration] -> [Declaration])
-> m [Declaration] -> m [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Declaration]
m
  where
  fixDecl :: [Declaration]
fixDecl = [ Fixity -> List1 Name -> Declaration
C.Infix (Fixity' -> Fixity
theFixity (Fixity' -> Fixity) -> Fixity' -> Fixity
forall a b. (a -> b) -> a -> b
$ DefInfo -> Fixity'
forall t. DefInfo' t -> Fixity'
defFixity DefInfo
i) (List1 Name -> Declaration) -> List1 Name -> Declaration
forall a b. (a -> b) -> a -> b
$ Name -> List1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
x
            | Fixity' -> Fixity
theFixity (DefInfo -> Fixity'
forall t. DefInfo' t -> Fixity'
defFixity DefInfo
i) Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
/= Fixity
noFixity
            ]
  synDecl :: [Declaration]
synDecl = [ Name -> Notation -> Declaration
C.Syntax Name
x (Notation -> Declaration) -> Notation -> Declaration
forall a b. (a -> b) -> a -> b
$ Fixity' -> Notation
theNotation (Fixity' -> Notation) -> Fixity' -> Notation
forall a b. (a -> b) -> a -> b
$ DefInfo -> Fixity'
forall t. DefInfo' t -> Fixity'
defFixity DefInfo
i ]

---------------------------------------------------------------------------
-- ** Dealing with private definitions
---------------------------------------------------------------------------

-- | Add @abstract@, @private@, @instance@ modifiers.
withAbstractPrivate :: MonadToConcrete m => DefInfo -> m [C.Declaration] -> m [C.Declaration]
withAbstractPrivate :: forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> m [Declaration] -> m [Declaration]
withAbstractPrivate DefInfo
i m [Declaration]
m =
    Access -> [Declaration] -> [Declaration]
priv (DefInfo -> Access
forall t. DefInfo' t -> Access
defAccess DefInfo
i)
      ([Declaration] -> [Declaration])
-> ([Declaration] -> [Declaration])
-> [Declaration]
-> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsAbstract -> [Declaration] -> [Declaration]
abst (DefInfo -> IsAbstract
forall t. DefInfo' t -> IsAbstract
A.defAbstract DefInfo
i)
      ([Declaration] -> [Declaration])
-> ([Declaration] -> [Declaration])
-> [Declaration]
-> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe KwRange -> [Declaration] -> [Declaration]
addInstanceB (case DefInfo -> IsInstance
forall t. DefInfo' t -> IsInstance
A.defInstance DefInfo
i of InstanceDef KwRange
r -> KwRange -> Maybe KwRange
forall a. a -> Maybe a
Just KwRange
r; IsInstance
NotInstanceDef -> Maybe KwRange
forall a. Maybe a
Nothing)
      ([Declaration] -> [Declaration])
-> m [Declaration] -> m [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Declaration]
m
    where
        priv :: Access -> [Declaration] -> [Declaration]
priv (PrivateAccess KwRange
kwr Origin
UserWritten)
                         [Declaration]
ds = [ KwRange -> Origin -> [Declaration] -> Declaration
C.Private KwRange
kwr Origin
UserWritten [Declaration]
ds ]
        priv Access
_           [Declaration]
ds = [Declaration]
ds
        abst :: IsAbstract -> [Declaration] -> [Declaration]
abst IsAbstract
AbstractDef [Declaration]
ds = [ KwRange -> [Declaration] -> Declaration
C.Abstract KwRange
forall a. Null a => a
empty [Declaration]
ds ]
        abst IsAbstract
ConcreteDef [Declaration]
ds = [Declaration]
ds

addInstanceB :: Maybe KwRange -> [C.Declaration] -> [C.Declaration]
addInstanceB :: Maybe KwRange -> [Declaration] -> [Declaration]
addInstanceB (Just KwRange
r) [Declaration]
ds = [ KwRange -> [Declaration] -> Declaration
C.InstanceB KwRange
r [Declaration]
ds ]
addInstanceB Maybe KwRange
Nothing  [Declaration]
ds = [Declaration]
ds

---------------------------------------------------------------------------
-- * The To Concrete Class
---------------------------------------------------------------------------

class ToConcrete a where
    type ConOfAbs a
    toConcrete :: MonadToConcrete m => a -> m (ConOfAbs a)
    bindToConcrete :: MonadToConcrete m => a -> (ConOfAbs a -> m b) -> m b

    -- Christian Sattler, 2017-08-05:
    -- These default implementations are not valid semantically (at least
    -- the second one). Perhaps they (it) should be removed.
    toConcrete     a
x     = a -> (ConOfAbs a -> m (ConOfAbs a)) -> m (ConOfAbs a)
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
x ConOfAbs a -> m (ConOfAbs a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    bindToConcrete a
x ConOfAbs a -> m b
ret = ConOfAbs a -> m b
ret (ConOfAbs a -> m b) -> m (ConOfAbs a) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete a
x

-- | Translate something in a context of the given precedence.
toConcreteCtx :: MonadToConcrete m => ToConcrete a => Precedence -> a -> m (ConOfAbs a)
toConcreteCtx :: forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
p a
x = Precedence -> m (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) a.
MonadToConcrete m =>
Precedence -> m a -> m a
withPrecedence Precedence
p (m (ConOfAbs a) -> m (ConOfAbs a))
-> m (ConOfAbs a) -> m (ConOfAbs a)
forall a b. (a -> b) -> a -> b
$ a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete a
x

-- | Translate something in a context of the given precedence.
bindToConcreteCtx :: MonadToConcrete m => ToConcrete a => Precedence -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteCtx :: forall (m :: * -> *) a b.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteCtx Precedence
p a
x ConOfAbs a -> m b
ret = Precedence -> m b -> m b
forall (m :: * -> *) a.
MonadToConcrete m =>
Precedence -> m a -> m a
withPrecedence Precedence
p (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
x ConOfAbs a -> m b
ret

-- | Translate something in the top context.
toConcreteTop :: MonadToConcrete m => ToConcrete a => a -> m (ConOfAbs a)
toConcreteTop :: forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop = Precedence -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
TopCtx

-- | Translate something in the top context.
bindToConcreteTop :: MonadToConcrete m => ToConcrete a => a -> (ConOfAbs a -> m b) -> m b
bindToConcreteTop :: forall (m :: * -> *) a b.
(MonadToConcrete m, ToConcrete a) =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcreteTop = Precedence -> a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) a b.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteCtx Precedence
TopCtx

-- | Translate something in a context indicated by 'Hiding' info.
toConcreteHiding :: MonadToConcrete m => (LensHiding h, ToConcrete a) => h -> a -> m (ConOfAbs a)
toConcreteHiding :: forall (m :: * -> *) h a.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> m (ConOfAbs a)
toConcreteHiding h
h =
  case h -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding h
h of
    Hiding
NotHidden  -> a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
    Hiding
Hidden     -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop
    Instance{} -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop

-- | Translate something in a context indicated by 'Hiding' info.
bindToConcreteHiding :: MonadToConcrete m => (LensHiding h, ToConcrete a) => h -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteHiding :: forall (m :: * -> *) h a b.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteHiding h
h =
  case h -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding h
h of
    Hiding
NotHidden  -> a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete
    Hiding
Hidden     -> a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) a b.
(MonadToConcrete m, ToConcrete a) =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcreteTop
    Instance{} -> a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) a b.
(MonadToConcrete m, ToConcrete a) =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcreteTop

-- Base type instances ------------------------------------------------------

instance ToConcrete () where
  type ConOfAbs () = ()
  toConcrete :: forall (m :: * -> *). MonadToConcrete m => () -> m (ConOfAbs ())
toConcrete = () -> m ()
() -> m (ConOfAbs ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToConcrete Bool where
  type ConOfAbs Bool = Bool
  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Bool -> m (ConOfAbs Bool)
toConcrete = Bool -> m Bool
Bool -> m (ConOfAbs Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToConcrete Char where
  type ConOfAbs Char = Char
  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Char -> m (ConOfAbs Char)
toConcrete = Char -> m Char
Char -> m (ConOfAbs Char)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- Functors ---------------------------------------------------------------

instance ToConcrete a => ToConcrete [a] where
    type ConOfAbs [a] = [ConOfAbs a]

    toConcrete :: forall (m :: * -> *). MonadToConcrete m => [a] -> m (ConOfAbs [a])
toConcrete     = (a -> m (ConOfAbs a)) -> [a] -> m [ConOfAbs a]
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
[a] -> (ConOfAbs [a] -> m b) -> m b
bindToConcrete []     ConOfAbs [a] -> m b
ret = ConOfAbs [a] -> m b
ret []
    bindToConcrete (a
a:[a]
as) ConOfAbs [a] -> m b
ret = NonEmpty a -> (ConOfAbs (NonEmpty a) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
NonEmpty a -> (ConOfAbs (NonEmpty a) -> m b) -> m b
bindToConcrete (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as) ((ConOfAbs (NonEmpty a) -> m b) -> m b)
-> (ConOfAbs (NonEmpty a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ (ConOfAbs a
c :| [ConOfAbs a]
cs) -> ConOfAbs [a] -> m b
ret (ConOfAbs a
cConOfAbs a -> [ConOfAbs a] -> [ConOfAbs a]
forall a. a -> [a] -> [a]
:[ConOfAbs a]
cs)

instance ToConcrete a => ToConcrete (List1 a) where
    type ConOfAbs (List1 a) = List1 (ConOfAbs a)

    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
List1 a -> m (ConOfAbs (List1 a))
toConcrete     = (a -> m (ConOfAbs a)) -> List1 a -> m (NonEmpty (ConOfAbs a))
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
    -- Andreas, 2017-04-11, Issue #2543
    -- The naive `thread'ing does not work as we have to undo
    -- changes to the Precedence.
    -- bindToConcrete = thread bindToConcrete
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
List1 a -> (ConOfAbs (List1 a) -> m b) -> m b
bindToConcrete (a
a :| [a]
as) ConOfAbs (List1 a) -> m b
ret = do
      p <- m PrecedenceStack
forall (m :: * -> *). MonadToConcrete m => m PrecedenceStack
currentPrecedence  -- save precedence
      bindToConcrete a $ \ ConOfAbs a
c ->
        PrecedenceStack -> m b -> m b
forall (m :: * -> *) a.
MonadToConcrete m =>
PrecedenceStack -> m a -> m a
withPrecedence' PrecedenceStack
p (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ -- reset precedence
          [a] -> (ConOfAbs [a] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[a] -> (ConOfAbs [a] -> m b) -> m b
bindToConcrete [a]
as ((ConOfAbs [a] -> m b) -> m b) -> (ConOfAbs [a] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [a]
cs ->
            ConOfAbs (List1 a) -> m b
ret (ConOfAbs a
c ConOfAbs a -> [ConOfAbs a] -> NonEmpty (ConOfAbs a)
forall a. a -> [a] -> NonEmpty a
:| [ConOfAbs a]
ConOfAbs [a]
cs)

instance ToConcrete a => ToConcrete (Maybe a)  where
    type ConOfAbs (Maybe a) = Maybe (ConOfAbs a)
    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Maybe a -> m (ConOfAbs (Maybe a))
toConcrete = (a -> m (ConOfAbs a)) -> Maybe a -> m (Maybe (ConOfAbs a))
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Maybe a -> (ConOfAbs (Maybe a) -> m b) -> m b
bindToConcrete (Just a
x) ConOfAbs (Maybe a) -> m b
ret = a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
x ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Maybe (ConOfAbs a) -> m b
ConOfAbs (Maybe a) -> m b
ret (Maybe (ConOfAbs a) -> m b)
-> (ConOfAbs a -> Maybe (ConOfAbs a)) -> ConOfAbs a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConOfAbs a -> Maybe (ConOfAbs a)
forall a. a -> Maybe a
Just
    bindToConcrete Maybe a
Nothing  ConOfAbs (Maybe a) -> m b
ret = ConOfAbs (Maybe a) -> m b
ret Maybe (ConOfAbs a)
ConOfAbs (Maybe a)
forall a. Maybe a
Nothing

-- Bifunctors etc. --------------------------------------------------------

instance (ToConcrete a1, ToConcrete a2) => ToConcrete (Either a1 a2) where
    type ConOfAbs (Either a1 a2) = Either (ConOfAbs a1) (ConOfAbs a2)

    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Either a1 a2 -> m (ConOfAbs (Either a1 a2))
toConcrete = (a1 -> m (ConOfAbs a1))
-> (a2 -> m (ConOfAbs a2))
-> Either a1 a2
-> m (Either (ConOfAbs a1) (ConOfAbs a2))
forall (f :: * -> *) a c b d.
Functor f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
traverseEither a1 -> m (ConOfAbs a1)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a1 -> m (ConOfAbs a1)
toConcrete a2 -> m (ConOfAbs a2)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a2 -> m (ConOfAbs a2)
toConcrete
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Either a1 a2 -> (ConOfAbs (Either a1 a2) -> m b) -> m b
bindToConcrete (Left a1
x) ConOfAbs (Either a1 a2) -> m b
ret =
        a1 -> (ConOfAbs a1 -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a1 -> (ConOfAbs a1 -> m b) -> m b
bindToConcrete a1
x ((ConOfAbs a1 -> m b) -> m b) -> (ConOfAbs a1 -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a1
x ->
        ConOfAbs (Either a1 a2) -> m b
ret (ConOfAbs a1 -> Either (ConOfAbs a1) (ConOfAbs a2)
forall a b. a -> Either a b
Left ConOfAbs a1
x)
    bindToConcrete (Right a2
y) ConOfAbs (Either a1 a2) -> m b
ret =
        a2 -> (ConOfAbs a2 -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a2 -> (ConOfAbs a2 -> m b) -> m b
bindToConcrete a2
y ((ConOfAbs a2 -> m b) -> m b) -> (ConOfAbs a2 -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a2
y ->
        ConOfAbs (Either a1 a2) -> m b
ret (ConOfAbs a2 -> Either (ConOfAbs a1) (ConOfAbs a2)
forall a b. b -> Either a b
Right ConOfAbs a2
y)

instance (ToConcrete a1, ToConcrete a2) => ToConcrete (a1, a2) where
    type ConOfAbs (a1, a2) = (ConOfAbs a1, ConOfAbs a2)

    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
(a1, a2) -> m (ConOfAbs (a1, a2))
toConcrete (a1
x,a2
y) = (ConOfAbs a1 -> ConOfAbs a2 -> (ConOfAbs a1, ConOfAbs a2))
-> m (ConOfAbs a1)
-> m (ConOfAbs a2)
-> m (ConOfAbs a1, ConOfAbs a2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (a1 -> m (ConOfAbs a1)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a1 -> m (ConOfAbs a1)
toConcrete a1
x) (a2 -> m (ConOfAbs a2)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a2 -> m (ConOfAbs a2)
toConcrete a2
y)
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
(a1, a2) -> (ConOfAbs (a1, a2) -> m b) -> m b
bindToConcrete (a1
x,a2
y) ConOfAbs (a1, a2) -> m b
ret =
        a1 -> (ConOfAbs a1 -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a1 -> (ConOfAbs a1 -> m b) -> m b
bindToConcrete a1
x ((ConOfAbs a1 -> m b) -> m b) -> (ConOfAbs a1 -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a1
x ->
        a2 -> (ConOfAbs a2 -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a2 -> (ConOfAbs a2 -> m b) -> m b
bindToConcrete a2
y ((ConOfAbs a2 -> m b) -> m b) -> (ConOfAbs a2 -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a2
y ->
        ConOfAbs (a1, a2) -> m b
ret (ConOfAbs a1
x,ConOfAbs a2
y)

instance (ToConcrete a1, ToConcrete a2, ToConcrete a3) => ToConcrete (a1,a2,a3) where
    type ConOfAbs (a1, a2, a3) = (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)

    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
(a1, a2, a3) -> m (ConOfAbs (a1, a2, a3))
toConcrete (a1
x,a2
y,a3
z) = (ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
-> (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)
forall {a} {b} {c}. (a, (b, c)) -> (a, b, c)
reorder ((ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
 -> (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3))
-> m (ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
-> m (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a1, (a2, a3)) -> m (ConOfAbs (a1, (a2, a3)))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
(a1, (a2, a3)) -> m (ConOfAbs (a1, (a2, a3)))
toConcrete (a1
x,(a2
y,a3
z))
        where
            reorder :: (a, (b, c)) -> (a, b, c)
reorder (a
x,(b
y,c
z)) = (a
x,b
y,c
z)

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
(a1, a2, a3) -> (ConOfAbs (a1, a2, a3) -> m b) -> m b
bindToConcrete (a1
x,a2
y,a3
z) ConOfAbs (a1, a2, a3) -> m b
ret = (a1, (a2, a3)) -> (ConOfAbs (a1, (a2, a3)) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
(a1, (a2, a3)) -> (ConOfAbs (a1, (a2, a3)) -> m b) -> m b
bindToConcrete (a1
x,(a2
y,a3
z)) ((ConOfAbs (a1, (a2, a3)) -> m b) -> m b)
-> (ConOfAbs (a1, (a2, a3)) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3) -> m b
ConOfAbs (a1, a2, a3) -> m b
ret ((ConOfAbs a1, ConOfAbs a2, ConOfAbs a3) -> m b)
-> ((ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
    -> (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3))
-> (ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
-> (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)
forall {a} {b} {c}. (a, (b, c)) -> (a, b, c)
reorder
        where
            reorder :: (a, (b, c)) -> (a, b, c)
reorder (a
x,(b
y,c
z)) = (a
x,b
y,c
z)

-- Decorations ------------------------------------------------------------

instance ToConcrete a => ToConcrete (Arg a) where
    type ConOfAbs (Arg a) = Arg (ConOfAbs a)

    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Arg a -> m (ConOfAbs (Arg a))
toConcrete (Arg ArgInfo
i a
a) = ArgInfo -> ConOfAbs a -> Arg (ConOfAbs a)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (ConOfAbs a -> Arg (ConOfAbs a))
-> m (ConOfAbs a) -> m (Arg (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgInfo -> a -> m (ConOfAbs a)
forall (m :: * -> *) h a.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> m (ConOfAbs a)
toConcreteHiding ArgInfo
i a
a

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Arg a -> (ConOfAbs (Arg a) -> m b) -> m b
bindToConcrete (Arg ArgInfo
info a
x) ConOfAbs (Arg a) -> m b
ret =
      ArgInfo -> a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) h a b.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteHiding ArgInfo
info a
x ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Arg (ConOfAbs a) -> m b
ConOfAbs (Arg a) -> m b
ret (Arg (ConOfAbs a) -> m b)
-> (ConOfAbs a -> Arg (ConOfAbs a)) -> ConOfAbs a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgInfo -> ConOfAbs a -> Arg (ConOfAbs a)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info

instance ToConcrete a => ToConcrete (WithHiding a) where
  type ConOfAbs (WithHiding a) = WithHiding (ConOfAbs a)

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
WithHiding a -> m (ConOfAbs (WithHiding a))
toConcrete     (WithHiding Hiding
h a
a) = Hiding -> ConOfAbs a -> WithHiding (ConOfAbs a)
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h (ConOfAbs a -> WithHiding (ConOfAbs a))
-> m (ConOfAbs a) -> m (WithHiding (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hiding -> a -> m (ConOfAbs a)
forall (m :: * -> *) h a.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> m (ConOfAbs a)
toConcreteHiding Hiding
h a
a
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
WithHiding a -> (ConOfAbs (WithHiding a) -> m b) -> m b
bindToConcrete (WithHiding Hiding
h a
a) ConOfAbs (WithHiding a) -> m b
ret = Hiding -> a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) h a b.
(MonadToConcrete m, LensHiding h, ToConcrete a) =>
h -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteHiding Hiding
h a
a ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs a
a ->
    ConOfAbs (WithHiding a) -> m b
ret (ConOfAbs (WithHiding a) -> m b) -> ConOfAbs (WithHiding a) -> m b
forall a b. (a -> b) -> a -> b
$ Hiding -> ConOfAbs a -> WithHiding (ConOfAbs a)
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h ConOfAbs a
a

instance ToConcrete a => ToConcrete (Named name a)  where
    type ConOfAbs (Named name a) = Named name (ConOfAbs a)
    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Named name a -> m (ConOfAbs (Named name a))
toConcrete = (a -> m (ConOfAbs a))
-> Named name a -> m (Named name (ConOfAbs a))
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Named name a -> (ConOfAbs (Named name a) -> m b) -> m b
bindToConcrete (Named Maybe name
n a
x) ConOfAbs (Named name a) -> m b
ret = a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
x ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Named name (ConOfAbs a) -> m b
ConOfAbs (Named name a) -> m b
ret (Named name (ConOfAbs a) -> m b)
-> (ConOfAbs a -> Named name (ConOfAbs a)) -> ConOfAbs a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe name -> ConOfAbs a -> Named name (ConOfAbs a)
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n

instance ToConcrete a => ToConcrete (Ranged a)  where
    type ConOfAbs (Ranged a) = Ranged (ConOfAbs a)
    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Ranged a -> m (ConOfAbs (Ranged a))
toConcrete = (a -> m (ConOfAbs a)) -> Ranged a -> m (Ranged (ConOfAbs a))
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Ranged a -> (ConOfAbs (Ranged a) -> m b) -> m b
bindToConcrete (Ranged Range
r a
x) ConOfAbs (Ranged a) -> m b
ret = a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
x ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Ranged (ConOfAbs a) -> m b
ConOfAbs (Ranged a) -> m b
ret (Ranged (ConOfAbs a) -> m b)
-> (ConOfAbs a -> Ranged (ConOfAbs a)) -> ConOfAbs a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> ConOfAbs a -> Ranged (ConOfAbs a)
forall a. Range -> a -> Ranged a
Ranged Range
r

-- Christian Sattler, 2017-08-05, fixing #2669
-- Both methods of ToConcrete (FieldAssignment' a) need
-- to be implemented, each in terms of the corresponding one of ToConcrete a.
-- This mirrors the instance ToConcrete (Ranged a).
-- The default implementations of ToConcrete are not valid semantically.
instance ToConcrete a => ToConcrete (FieldAssignment' a) where
    type ConOfAbs (FieldAssignment' a) = FieldAssignment' (ConOfAbs a)
    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
FieldAssignment' a -> m (ConOfAbs (FieldAssignment' a))
toConcrete = (a -> m (ConOfAbs a))
-> FieldAssignment' a -> m (FieldAssignment' (ConOfAbs a))
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
FieldAssignment' a -> (ConOfAbs (FieldAssignment' a) -> m b) -> m b
bindToConcrete (FieldAssignment Name
name a
a) ConOfAbs (FieldAssignment' a) -> m b
ret =
      a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
a ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ FieldAssignment' (ConOfAbs a) -> m b
ConOfAbs (FieldAssignment' a) -> m b
ret (FieldAssignment' (ConOfAbs a) -> m b)
-> (ConOfAbs a -> FieldAssignment' (ConOfAbs a))
-> ConOfAbs a
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ConOfAbs a -> FieldAssignment' (ConOfAbs a)
forall a. Name -> a -> FieldAssignment' a
FieldAssignment Name
name

-- Newtypes ---------------------------------------------------------------

-- Deriving this requires UndecidableInstances,
-- as TacticAttribute' is not larger than its expansion (Maybe . Ranged).
-- (Also the derived instance produce a type error.)
instance ToConcrete a => ToConcrete (TacticAttribute' a) where
  type ConOfAbs (TacticAttribute' a) = TacticAttribute' (ConOfAbs a)
  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
TacticAttribute' a -> m (ConOfAbs (TacticAttribute' a))
toConcrete = (a -> m (ConOfAbs a))
-> TacticAttribute' a -> m (TacticAttribute' (ConOfAbs a))
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 a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
TacticAttribute' a -> (ConOfAbs (TacticAttribute' a) -> m b) -> m b
bindToConcrete (TacticAttribute Maybe (Ranged a)
a) ConOfAbs (TacticAttribute' a) -> m b
ret = Maybe (Ranged a) -> (ConOfAbs (Maybe (Ranged a)) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Maybe (Ranged a) -> (ConOfAbs (Maybe (Ranged a)) -> m b) -> m b
bindToConcrete Maybe (Ranged a)
a ((ConOfAbs (Maybe (Ranged a)) -> m b) -> m b)
-> (ConOfAbs (Maybe (Ranged a)) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ TacticAttribute' (ConOfAbs a) -> m b
ConOfAbs (TacticAttribute' a) -> m b
ret (TacticAttribute' (ConOfAbs a) -> m b)
-> (Maybe (Ranged (ConOfAbs a)) -> TacticAttribute' (ConOfAbs a))
-> Maybe (Ranged (ConOfAbs a))
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Ranged (ConOfAbs a)) -> TacticAttribute' (ConOfAbs a)
forall a. Maybe (Ranged a) -> TacticAttribute' a
TacticAttribute

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

instance ToConcrete A.Name where
  type ConOfAbs A.Name = C.Name

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Name -> m (ConOfAbs Name)
toConcrete       = Name -> m Name
Name -> m (ConOfAbs Name)
forall (m :: * -> *). MonadToConcrete m => Name -> m Name
toConcreteName
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Name -> (ConOfAbs Name -> m b) -> m b
bindToConcrete Name
x = Name -> (Name -> m b) -> m b
forall (m :: * -> *) a.
MonadToConcrete m =>
Name -> (Name -> m a) -> m a
bindName Name
x

instance ToConcrete BindName where
  type ConOfAbs BindName = C.BoundName

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
BindName -> m (ConOfAbs BindName)
toConcrete       = (Name -> BoundName) -> m Name -> m BoundName
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> BoundName
C.mkBoundName_ (m Name -> m BoundName)
-> (BindName -> m Name) -> BindName -> m BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m Name
forall (m :: * -> *). MonadToConcrete m => Name -> m Name
toConcreteName (Name -> m Name) -> (BindName -> Name) -> BindName -> m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindName -> Name
unBind
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
BindName -> (ConOfAbs BindName -> m b) -> m b
bindToConcrete BindName
x = Name -> (Name -> m b) -> m b
forall (m :: * -> *) a.
MonadToConcrete m =>
Name -> (Name -> m a) -> m a
bindName (BindName -> Name
unBind BindName
x) ((Name -> m b) -> m b)
-> ((BoundName -> m b) -> Name -> m b) -> (BoundName -> m b) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BoundName -> m b) -> (Name -> BoundName) -> Name -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BoundName
C.mkBoundName_)

instance ToConcrete A.QName where
  type ConOfAbs A.QName = C.QName

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete = AllowAmbiguousNames -> QName -> m QName
forall (m :: * -> *).
MonadToConcrete m =>
AllowAmbiguousNames -> QName -> m QName
lookupQName AllowAmbiguousNames
AmbiguousConProjs

instance ToConcrete A.ModuleName where
  type ConOfAbs A.ModuleName = C.QName
  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete = ModuleName -> m QName
ModuleName -> m (ConOfAbs ModuleName)
forall (m :: * -> *). MonadToConcrete m => ModuleName -> m QName
lookupModule

instance ToConcrete AbstractName where
  type ConOfAbs AbstractName = C.QName
  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
AbstractName -> m (ConOfAbs AbstractName)
toConcrete = QName -> m QName
QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (QName -> m QName)
-> (AbstractName -> QName) -> AbstractName -> m QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName

-- | Assumes name is not 'UnknownName'.
instance ToConcrete ResolvedName where
  type ConOfAbs ResolvedName = C.QName

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
ResolvedName -> m (ConOfAbs ResolvedName)
toConcrete = \case
    VarName Name
x BindingSource
_          -> Name -> QName
C.QName (Name -> QName) -> m Name -> m QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m (ConOfAbs Name)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Name -> m (ConOfAbs Name)
toConcrete Name
x
    DefinedName Access
_ AbstractName
x Suffix
s    -> Suffix -> m QName -> m QName
forall (m :: * -> *). HasOptions m => Suffix -> m QName -> m QName
addSuffixConcrete Suffix
s (m QName -> m QName) -> m QName -> m QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> m (ConOfAbs AbstractName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
AbstractName -> m (ConOfAbs AbstractName)
toConcrete AbstractName
x
    FieldName NonEmpty AbstractName
xs         -> AbstractName -> m (ConOfAbs AbstractName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
AbstractName -> m (ConOfAbs AbstractName)
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty AbstractName
xs)
    ConstructorName Set1 Induction
_ NonEmpty AbstractName
xs -> AbstractName -> m (ConOfAbs AbstractName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
AbstractName -> m (ConOfAbs AbstractName)
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty AbstractName
xs)
    PatternSynResName NonEmpty AbstractName
xs -> AbstractName -> m (ConOfAbs AbstractName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
AbstractName -> m (ConOfAbs AbstractName)
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty AbstractName
xs)
    ResolvedName
UnknownName          -> m QName
m (ConOfAbs ResolvedName)
forall a. HasCallStack => a
__IMPOSSIBLE__

addSuffixConcrete :: HasOptions m => A.Suffix -> m C.QName -> m C.QName
addSuffixConcrete :: forall (m :: * -> *). HasOptions m => Suffix -> m QName -> m QName
addSuffixConcrete Suffix
A.NoSuffix m QName
x = m QName
x
addSuffixConcrete (A.Suffix Integer
i) m QName
x = do
  glyphMode <- PragmaOptions -> UnicodeOrAscii
optUseUnicode (PragmaOptions -> UnicodeOrAscii)
-> m PragmaOptions -> m UnicodeOrAscii
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  addSuffixConcrete' glyphMode i <$> x

addSuffixConcrete' :: UnicodeOrAscii -> Integer -> C.QName -> C.QName
addSuffixConcrete' :: UnicodeOrAscii -> Integer -> QName -> QName
addSuffixConcrete' UnicodeOrAscii
glyphMode Integer
i = Lens' QName (Maybe Suffix) -> LensSet QName (Maybe Suffix)
forall o i. Lens' o i -> LensSet o i
set ((Name -> f Name) -> QName -> f QName
Lens' QName Name
C.lensQNameName ((Name -> f Name) -> QName -> f QName)
-> ((Maybe Suffix -> f (Maybe Suffix)) -> Name -> f Name)
-> (Maybe Suffix -> f (Maybe Suffix))
-> QName
-> f QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Suffix -> f (Maybe Suffix)) -> Name -> f Name
Lens' Name (Maybe Suffix)
nameSuffix) Maybe Suffix
suffix
  where
    suffix :: Maybe Suffix
suffix = Suffix -> Maybe Suffix
forall a. a -> Maybe a
Just (Suffix -> Maybe Suffix) -> Suffix -> Maybe Suffix
forall a b. (a -> b) -> a -> b
$ case UnicodeOrAscii
glyphMode of
      UnicodeOrAscii
UnicodeOk -> Integer -> Suffix
Subscript (Integer -> Suffix) -> Integer -> Suffix
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i
      UnicodeOrAscii
AsciiOnly -> Integer -> Suffix
Index (Integer -> Suffix) -> Integer -> Suffix
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i

-- Expression instance ----------------------------------------------------

instance ToConcrete A.Expr where
    type ConOfAbs A.Expr = C.Expr

    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete (Var Name
x)             = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Bound (QName -> Expr) -> (Name -> QName) -> Name -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName (Name -> Expr) -> m Name -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m (ConOfAbs Name)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Name -> m (ConOfAbs Name)
toConcrete Name
x
    toConcrete (Def' QName
x Suffix
suffix)     = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Function (QName -> Expr) -> m QName -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Suffix -> m QName -> m QName
forall (m :: * -> *). HasOptions m => Suffix -> m QName -> m QName
addSuffixConcrete Suffix
suffix (QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x)
    toConcrete (Proj ProjOrigin
ProjPrefix AmbiguousQName
p) = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Field (QName -> Expr) -> m QName -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
    toConcrete (Proj ProjOrigin
_          AmbiguousQName
p) = KwRange -> Expr -> Expr
C.Dot KwRange
forall a. Null a => a
empty (Expr -> Expr) -> (QName -> Expr) -> QName -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Field (QName -> Expr) -> m QName -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
    toConcrete (A.Macro QName
x)         = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Macro (QName -> Expr) -> m QName -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    toConcrete e :: Expr
e@(Con AmbiguousQName
c)           = Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverPatternSyn Expr
e (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ NameKind -> QName -> Expr
KnownIdent (Induction -> NameKind
Asp.Constructor Induction
Inductive) (QName -> Expr) -> m QName -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
c)
        -- for names we have to use the name from the info, since the abstract
        -- name has been resolved to a fully qualified name (except for
        -- variables)
    toConcrete e :: Expr
e@(A.Lit ExprInfo
i (LitQName QName
x)) = Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverPatternSyn Expr
e (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ do
      x <- AllowAmbiguousNames -> QName -> m QName
forall (m :: * -> *).
MonadToConcrete m =>
AllowAmbiguousNames -> QName -> m QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
      let r = ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i
      bracket appBrackets $ return $
        C.App r (C.Quote r) (defaultNamedArg $ C.Ident x)
    toConcrete e :: Expr
e@(A.Lit ExprInfo
i Literal
l) = Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverPatternSyn Expr
e (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Range -> Literal -> Expr
C.Lit (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) Literal
l

    -- Andreas, 2014-05-17  We print question marks with their
    -- interaction id, in case @metaNumber /= Nothing@
    -- Ulf, 2017-09-20  ... or @preserveIIds == True@.
    toConcrete (A.QuestionMark MetaInfo
i InteractionId
ii) = do
      preserve <- (Env -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
preserveIIds
      return $ C.QuestionMark (getRange i) $
                 interactionId ii <$ guard (preserve || isJust (metaNumber i))

    toConcrete (A.Underscore MetaInfo
i) =
      Range -> Maybe ArgName -> Expr
C.Underscore (MetaInfo -> Range
forall a. HasRange a => a -> Range
getRange MetaInfo
i) (Maybe ArgName -> Expr) -> m (Maybe ArgName) -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (NamedMeta -> m ArgName) -> Maybe NamedMeta -> m (Maybe ArgName)
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 (Doc -> ArgName
forall a. Doc a -> ArgName
render (Doc -> ArgName) -> (NamedMeta -> m Doc) -> NamedMeta -> m ArgName
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> NamedMeta -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NamedMeta -> m Doc
prettyTCM)
        (ArgName -> MetaId -> NamedMeta
NamedMeta (MetaInfo -> ArgName
metaNameSuggestion MetaInfo
i) (MetaId -> NamedMeta) -> Maybe MetaId -> Maybe NamedMeta
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaInfo -> Maybe MetaId
metaNumber MetaInfo
i)

    toConcrete (A.Dot ExprInfo
i Expr
e) =
      KwRange -> Expr -> Expr
C.Dot KwRange
forall a. Null a => a
empty (Expr -> Expr) -> m Expr -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e

    toConcrete e :: Expr
e@(A.App AppInfo
i Expr
e1 NamedArg Expr
e2) = do
      is <- m (QName -> BuiltinId -> Bool)
forall (m :: * -> *).
MonadToConcrete m =>
m (QName -> BuiltinId -> Bool)
isBuiltinFun
      -- Special printing of desugared overloaded literals:
      --  fromNat 4        --> 4
      --  fromNeg 4        --> -4
      --  fromString "foo" --> "foo"
      -- Only when the corresponding conversion function is in scope and was
      -- inserted by the system.
      case (getHead e1, namedArg e2) of
        (Just (HdDef QName
q), l :: Expr
l@A.Lit{})
          | (BuiltinId -> Bool) -> [BuiltinId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (QName -> BuiltinId -> Bool
is QName
q) [BuiltinId
builtinFromNat, BuiltinId
builtinFromString], NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Expr
e2,
            AppInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin AppInfo
i Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Inserted -> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
l
        (Just (HdDef QName
q), A.Lit ExprInfo
r (LitNat Integer
n))
          | QName
q QName -> BuiltinId -> Bool
`is` BuiltinId
builtinFromNeg, NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Expr
e2,
            AppInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin AppInfo
i Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Inserted -> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete (ExprInfo -> Literal -> Expr
A.Lit ExprInfo
r (Integer -> Literal
LitNat (-Integer
n)))
        (Maybe Hd, Expr)
_ ->
          Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverPatternSyn Expr
e
          (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverOpApp Expr
e
          (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverNatural Expr
e
          -- or fallback to App
          (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket (Bool -> PrecedenceStack -> Bool
appBrackets' (Bool -> PrecedenceStack -> Bool)
-> Bool -> PrecedenceStack -> Bool
forall a b. (a -> b) -> a -> b
$ ParenPreference -> Bool
preferParenless (AppInfo -> ParenPreference
appParens AppInfo
i) Bool -> Bool -> Bool
&& NamedArg Expr -> Bool
isLambda NamedArg Expr
e2)
          (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ do e1' <- Precedence -> Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
FunctionCtx Expr
e1
               e2' <- toConcreteCtx (ArgumentCtx $ appParens i) e2
               return $ C.App (getRange i) e1' e2'

    toConcrete (A.WithApp ExprInfo
i Expr
e List1 Expr
es) =
      (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
withAppBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ do
        e <- Precedence -> Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
WithFunCtx Expr
e
        es <- mapM (toConcreteCtx WithArgCtx) es
        return $ C.WithApp (getRange i) e es

    toConcrete (A.AbsurdLam ExprInfo
i Hiding
h) =
      (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
lamBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Range -> Hiding -> Expr
C.AbsurdLam (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) Hiding
h
    toConcrete e :: Expr
e@(A.Lam ExprInfo
i LamBinding
_ Expr
_) =
      Expr -> m Expr -> m Expr
forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverOpApp Expr
e (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$   -- recover sections
        [LamBinding] -> (ConOfAbs [LamBinding] -> m Expr) -> m Expr
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[LamBinding] -> (ConOfAbs [LamBinding] -> m b) -> m b
bindToConcrete ((LamBinding -> LamBinding) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LamBinding -> LamBinding
makeDomainFree [LamBinding]
bs) ((ConOfAbs [LamBinding] -> m Expr) -> m Expr)
-> (ConOfAbs [LamBinding] -> m Expr) -> m Expr
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [LamBinding]
bs' -> do
          [LamBinding] -> m Expr -> (List1 LamBinding -> m Expr) -> m Expr
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull ([Maybe LamBinding] -> [LamBinding]
forall a. [Maybe a] -> [a]
catMaybes [Maybe LamBinding]
ConOfAbs [LamBinding]
bs')
            {-then-} (Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e')
            {-else-} ((List1 LamBinding -> m Expr) -> m Expr)
-> (List1 LamBinding -> m Expr) -> m Expr
forall a b. (a -> b) -> a -> b
$ \ List1 LamBinding
bs -> (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
lamBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$
              Range -> List1 LamBinding -> Expr -> Expr
C.Lam (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) List1 LamBinding
bs (Expr -> Expr) -> m Expr -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop Expr
e'
      where
          ([LamBinding]
bs, Expr
e') = Expr -> ([LamBinding], Expr)
lamView Expr
e
          -- #3238 GA: We drop the hidden lambda abstractions which have
          -- been inserted by the machine rather than the user. This means
          -- that the result of lamView may actually be an empty list of
          -- binders.
          lamView :: A.Expr -> ([A.LamBinding], A.Expr)
          lamView :: Expr -> ([LamBinding], Expr)
lamView (A.Lam ExprInfo
_ b :: LamBinding
b@(A.DomainFree TacticAttribute
_ NamedArg Binder
x) Expr
e)
            | NamedArg Binder -> Bool
forall a. (LensHiding a, LensOrigin a) => a -> Bool
isInsertedHidden NamedArg Binder
x = Expr -> ([LamBinding], Expr)
lamView Expr
e
            | Bool
otherwise = case Expr -> ([LamBinding], Expr)
lamView Expr
e of
              (bs :: [LamBinding]
bs@(A.DomainFree{} : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
              ([LamBinding], Expr)
_                            -> ([LamBinding
b] , Expr
e)
          lamView (A.Lam ExprInfo
_ b :: LamBinding
b@(A.DomainFull A.TLet{}) Expr
e) = case Expr -> ([LamBinding], Expr)
lamView Expr
e of
            (bs :: [LamBinding]
bs@(A.DomainFull TypedBinding
_ : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
            ([LamBinding], Expr)
_                            -> ([LamBinding
b], Expr
e)
          lamView (A.Lam ExprInfo
_ (A.DomainFull (A.TBind Range
r TypedBindingInfo
t List1 (NamedArg Binder)
xs Expr
ty)) Expr
e) =
            case (NamedArg Binder -> Bool)
-> List1 (NamedArg Binder) -> [NamedArg Binder]
forall a. (a -> Bool) -> NonEmpty a -> [a]
List1.filter (Bool -> Bool
not (Bool -> Bool)
-> (NamedArg Binder -> Bool) -> NamedArg Binder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Binder -> Bool
forall a. (LensHiding a, LensOrigin a) => a -> Bool
isInsertedHidden) List1 (NamedArg Binder)
xs of
              []    -> Expr -> ([LamBinding], Expr)
lamView Expr
e
              NamedArg Binder
x:[NamedArg Binder]
xs' -> let b :: LamBinding
b = TypedBinding -> LamBinding
A.DomainFull (Range
-> TypedBindingInfo
-> List1 (NamedArg Binder)
-> Expr
-> TypedBinding
A.TBind Range
r TypedBindingInfo
t (NamedArg Binder
x NamedArg Binder -> [NamedArg Binder] -> List1 (NamedArg Binder)
forall a. a -> [a] -> NonEmpty a
:| [NamedArg Binder]
xs') Expr
ty) in
                case Expr -> ([LamBinding], Expr)
lamView Expr
e of
                  (bs :: [LamBinding]
bs@(A.DomainFull TypedBinding
_ : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
                  ([LamBinding], Expr)
_                            -> ([LamBinding
b], Expr
e)
          lamView Expr
e = ([], Expr
e)
    toConcrete (A.ExtendedLam ExprInfo
i DefInfo
di Erased
erased QName
qname List1 Clause
cs) =
        (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
lamBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ do
          decls <- NonEmpty (NonEmpty Declaration) -> NonEmpty Declaration
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (NonEmpty Declaration) -> NonEmpty Declaration)
-> m (NonEmpty (NonEmpty Declaration)) -> m (NonEmpty Declaration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 Clause -> m (ConOfAbs (List1 Clause))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
List1 Clause -> m (ConOfAbs (List1 Clause))
toConcrete List1 Clause
cs
          puns  <- optHiddenArgumentPuns <$> pragmaOptions
          let -- If --hidden-argument-puns is active, then {x} is
              -- replaced by {(x)} and ⦃ x ⦄ by ⦃ (x) ⦄.
              noPun (Named Maybe NamedName
Nothing p :: Pattern
p@C.IdentP{}) | Bool
puns =
                Maybe NamedName -> Pattern -> Named_ Pattern
forall name a. Maybe name -> a -> Named name a
Named Maybe NamedName
forall a. Maybe a
Nothing (Range -> Pattern -> Pattern
C.ParenP Range
forall a. Range' a
noRange Pattern
p)
              noPun Named_ Pattern
p = Named_ Pattern
p

              namedPat Arg (Named_ Pattern)
np = case Arg (Named_ Pattern) -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg (Named_ Pattern)
np of
                 Hiding
NotHidden  -> Arg (Named_ Pattern) -> Pattern
forall a. NamedArg a -> a
namedArg Arg (Named_ Pattern)
np
                 Hiding
Hidden     -> Range -> Named_ Pattern -> Pattern
C.HiddenP Range
forall a. Range' a
noRange (Named_ Pattern -> Named_ Pattern
noPun (Arg (Named_ Pattern) -> Named_ Pattern
forall e. Arg e -> e
unArg Arg (Named_ Pattern)
np))
                 Instance{} -> Range -> Named_ Pattern -> Pattern
C.InstanceP Range
forall a. Range' a
noRange (Named_ Pattern -> Named_ Pattern
noPun (Arg (Named_ Pattern) -> Named_ Pattern
forall e. Arg e -> e
unArg Arg (Named_ Pattern)
np))
              -- we know all lhs are of the form `.extlam p1 p2 ... pn`,
              -- with the name .extlam leftmost. It is our mission to remove it.
          let removeApp :: MonadToConcrete m => C.Pattern -> m [C.Pattern]
              removeApp (C.RawAppP Range
_ (List2 Pattern
_ Pattern
p [Pattern]
ps)) = [Pattern] -> m [Pattern]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pattern] -> m [Pattern]) -> [Pattern] -> m [Pattern]
forall a b. (a -> b) -> a -> b
$ Pattern
pPattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
:[Pattern]
ps
              removeApp (C.AppP (C.IdentP Bool
_ QName
_) Arg (Named_ Pattern)
np) = [Pattern] -> m [Pattern]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Arg (Named_ Pattern) -> Pattern
namedPat Arg (Named_ Pattern)
np]
              removeApp (C.AppP Pattern
p Arg (Named_ Pattern)
np)            = Pattern -> m [Pattern]
forall (m :: * -> *). MonadToConcrete m => Pattern -> m [Pattern]
removeApp Pattern
p m [Pattern] -> ([Pattern] -> [Pattern]) -> m [Pattern]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Pattern] -> [Pattern] -> [Pattern]
forall a. [a] -> [a] -> [a]
++ [Arg (Named_ Pattern) -> Pattern
namedPat Arg (Named_ Pattern)
np])
              -- Andreas, 2018-06-18, issue #3136
              -- Empty pattern list also allowed in extended lambda,
              -- thus, we might face the unapplied .extendedlambda identifier.
              removeApp x :: Pattern
x@C.IdentP{} = [Pattern] -> m [Pattern]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

              removeApp Pattern
p = do
                ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"extendedlambda" VerboseLevel
50 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"abstractToConcrete removeApp p = " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Pattern -> ArgName
forall a. Show a => a -> ArgName
show Pattern
p
                [Pattern] -> m [Pattern]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pattern
p] -- __IMPOSSIBLE__
                  -- Andreas, this is actually not impossible,
                  -- my strictification exposed this sleeping bug
          let decl2clause (C.FunClause (C.LHS Pattern
p [] []) RHS
rhs WhereClause' [Declaration]
C.NoWhere Bool
ca) = do
                ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"extendedlambda" VerboseLevel
50 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"abstractToConcrete extended lambda pattern p = " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Pattern -> ArgName
forall a. Show a => a -> ArgName
show Pattern
p
                ps <- Pattern -> m [Pattern]
forall (m :: * -> *). MonadToConcrete m => Pattern -> m [Pattern]
removeApp Pattern
p
                reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps
                return $ LamClause ps rhs ca
              decl2clause Declaration
_ = m LamClause
forall a. HasCallStack => a
__IMPOSSIBLE__
          C.ExtendedLam (getRange i) erased <$>
            mapM decl2clause decls

    toConcrete (A.Pi ExprInfo
_ NonEmpty TypedBinding
tel1 Expr
e0) = do
      let (NonEmpty TypedBinding
tel, Expr
e) = NonEmpty TypedBinding -> Expr -> (NonEmpty TypedBinding, Expr)
piTel1 NonEmpty TypedBinding
tel1 Expr
e0
      (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
piBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$
         NonEmpty TypedBinding
-> (ConOfAbs (NonEmpty TypedBinding) -> m Expr) -> m Expr
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
NonEmpty TypedBinding
-> (ConOfAbs (NonEmpty TypedBinding) -> m b) -> m b
bindToConcrete NonEmpty TypedBinding
tel ((ConOfAbs (NonEmpty TypedBinding) -> m Expr) -> m Expr)
-> (ConOfAbs (NonEmpty TypedBinding) -> m Expr) -> m Expr
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (NonEmpty TypedBinding)
tel' ->
           Telescope -> Expr -> Expr
C.makePi (List1 (Maybe TypedBinding) -> Telescope
forall a. List1 (Maybe a) -> [a]
List1.catMaybes List1 (Maybe TypedBinding)
ConOfAbs (NonEmpty TypedBinding)
tel') (Expr -> Expr) -> m Expr -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop Expr
e
      where
        piTel1 :: NonEmpty TypedBinding -> Expr -> (NonEmpty TypedBinding, Expr)
piTel1 NonEmpty TypedBinding
tel Expr
e         = (Telescope -> NonEmpty TypedBinding)
-> (Telescope, Expr) -> (NonEmpty TypedBinding, Expr)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (NonEmpty TypedBinding -> Telescope -> NonEmpty TypedBinding
forall a. NonEmpty a -> [a] -> NonEmpty a
List1.appendList NonEmpty TypedBinding
tel) ((Telescope, Expr) -> (NonEmpty TypedBinding, Expr))
-> (Telescope, Expr) -> (NonEmpty TypedBinding, Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> (Telescope, Expr)
piTel Expr
e
        piTel :: Expr -> (Telescope, Expr)
piTel (A.Pi ExprInfo
_ NonEmpty TypedBinding
tel Expr
e) = (NonEmpty TypedBinding -> Telescope)
-> (NonEmpty TypedBinding, Expr) -> (Telescope, Expr)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first NonEmpty TypedBinding -> [Item (NonEmpty TypedBinding)]
NonEmpty TypedBinding -> Telescope
forall l. IsList l => l -> [Item l]
List1.toList ((NonEmpty TypedBinding, Expr) -> (Telescope, Expr))
-> (NonEmpty TypedBinding, Expr) -> (Telescope, Expr)
forall a b. (a -> b) -> a -> b
$ NonEmpty TypedBinding -> Expr -> (NonEmpty TypedBinding, Expr)
piTel1 NonEmpty TypedBinding
tel Expr
e
        piTel Expr
e              = ([], Expr
e)

    toConcrete (A.Generalized Set1 QName
_ Expr
e) = Expr -> Expr
C.Generalized (Expr -> Expr) -> m Expr -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e

    toConcrete (A.Fun ExprInfo
i Arg Expr
a Expr
b) =
        (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
piBrackets
        (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ do a' <- Precedence -> Arg Expr -> m (ConOfAbs (Arg Expr))
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
ctx Arg Expr
a
             b' <- toConcreteTop b
             -- NOTE We set relevance to Relevant in arginfo because we wrap
             -- with C.Dot or C.DoubleDot using addRel instead.
             let dom = Relevance -> Arg Expr -> Arg Expr
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
relevant (Arg Expr -> Arg Expr) -> Arg Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Modality -> Arg Expr -> Arg Expr
forall a. LensModality a => Modality -> a -> a
setModality (Arg Expr -> Modality
forall a. LensModality a => a -> Modality
getModality Arg Expr
a') (Arg Expr -> Arg Expr) -> Arg Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Arg Expr
forall a. a -> Arg a
defaultArg (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Arg Expr -> Expr -> Expr
forall {a}. LensRelevance a => a -> Expr -> Expr
addRel Arg Expr
a' (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Arg Expr -> Expr
mkArg Arg Expr
a'
             return $ C.Fun (getRange i) dom b'
             -- Andreas, 2018-06-14, issue #2513
             -- TODO: print attributes
        where
            ctx :: Precedence
ctx = if Arg Expr -> Bool
forall a. LensRelevance a => a -> Bool
isRelevant Arg Expr
a then Precedence
FunctionSpaceDomainCtx else Precedence
DotPatternCtx
            addRel :: a -> Expr -> Expr
addRel a
a Expr
e =
              case a -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance a
a of
                Irrelevant      {} -> KwRange -> Expr -> Expr
C.Dot KwRange
forall a. Null a => a
empty Expr
e
                ShapeIrrelevant {} -> KwRange -> Expr -> Expr
C.DoubleDot KwRange
forall a. Null a => a
empty Expr
e
                Relevant        {} -> Expr
e
            mkArg :: Arg Expr -> Expr
mkArg (Arg ArgInfo
info Expr
e) = case ArgInfo -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding ArgInfo
info of
                                          Hiding
Hidden     -> Range -> Named_ Expr -> Expr
HiddenArg   (Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e) (Expr -> Named_ Expr
forall a name. a -> Named name a
unnamed Expr
e)
                                          Instance{} -> Range -> Named_ Expr -> Expr
InstanceArg (Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e) (Expr -> Named_ Expr
forall a name. a -> Named name a
unnamed Expr
e)
                                          Hiding
NotHidden  -> Expr
e

    toConcrete (A.Let ExprInfo
i List1 LetBinding
ds Expr
e) =
        (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
lamBrackets
        (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ List1 LetBinding
-> (ConOfAbs (List1 LetBinding) -> m Expr) -> m Expr
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
List1 LetBinding -> (ConOfAbs (List1 LetBinding) -> m b) -> m b
bindToConcrete List1 LetBinding
ds ((ConOfAbs (List1 LetBinding) -> m Expr) -> m Expr)
-> (ConOfAbs (List1 LetBinding) -> m Expr) -> m Expr
forall a b. (a -> b) -> a -> b
$ \ConOfAbs (List1 LetBinding)
ds' -> do
             e'  <- Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop Expr
e
             return $ C.mkLet (getRange i) (concat ds') e'

    toConcrete (A.Rec RecInfo
i RecordAssigns
fs) =
      (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
appBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$
        case RecInfo
i of
          A.RecInfo Range
r RecStyle
A.RecStyleBrace ->
            Range -> RecordAssignments -> Expr
C.Rec Range
r (RecordAssignments -> Expr)
-> ([Either FieldAssignment QName] -> RecordAssignments)
-> [Either FieldAssignment QName]
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either FieldAssignment QName -> RecordAssignment)
-> [Either FieldAssignment QName] -> RecordAssignments
forall a b. (a -> b) -> [a] -> [b]
map ((QName -> ModuleAssignment)
-> Either FieldAssignment QName -> RecordAssignment
forall a b.
(a -> b) -> Either FieldAssignment a -> Either FieldAssignment b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\QName
x -> QName -> [Expr] -> ImportDirective -> ModuleAssignment
ModuleAssignment QName
x [] ImportDirective
forall n m. ImportDirective' n m
defaultImportDir)) ([Either FieldAssignment QName] -> Expr)
-> m [Either FieldAssignment QName] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordAssigns -> m (ConOfAbs RecordAssigns)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop RecordAssigns
fs
          A.RecInfo Range
r RecStyle
A.RecStyleWhere ->
            Range -> [Declaration] -> Expr
C.RecWhere Range
r ([Declaration] -> Expr)
-> ([Either FieldAssignment QName] -> [Declaration])
-> [Either FieldAssignment QName]
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either FieldAssignment QName -> Declaration)
-> [Either FieldAssignment QName] -> [Declaration]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldAssignment -> Declaration)
-> (QName -> Declaration)
-> Either FieldAssignment QName
-> Declaration
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FieldAssignment -> Declaration
fieldToDecl QName -> Declaration
forall {a}. a
moduleToDecl) ([Either FieldAssignment QName] -> Expr)
-> m [Either FieldAssignment QName] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordAssigns -> m (ConOfAbs RecordAssigns)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop RecordAssigns
fs
            where
              fieldToDecl :: FieldAssignment -> Declaration
fieldToDecl (C.FieldAssignment Name
x Expr
e) = LHS -> RHS -> WhereClause' [Declaration] -> Bool -> Declaration
C.FunClause (Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS (Bool -> QName -> Pattern
C.IdentP Bool
True (QName -> Pattern) -> QName -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName Name
x) [] [])
                                                                (Expr -> RHS
forall e. e -> RHS' e
C.RHS Expr
e) WhereClause' [Declaration]
forall decls. WhereClause' decls
C.NoWhere Bool
False
              -- record where cannot contain modules
              moduleToDecl :: a
moduleToDecl = a
forall a. HasCallStack => a
__IMPOSSIBLE__

    toConcrete (A.RecUpdate RecInfo
i Expr
e Assigns
fs) =
      (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket PrecedenceStack -> Bool
appBrackets (m Expr -> m Expr) -> m Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ do
        Range -> Expr -> [FieldAssignment] -> Expr
C.RecUpdate (RecInfo -> Range
forall a. HasRange a => a -> Range
getRange RecInfo
i) (Expr -> [FieldAssignment] -> Expr)
-> m Expr -> m ([FieldAssignment] -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e m ([FieldAssignment] -> Expr) -> m [FieldAssignment] -> m Expr
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Assigns -> m (ConOfAbs Assigns)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop Assigns
fs

    toConcrete (A.ScopedExpr ScopeInfo
_ Expr
e) = Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e
    toConcrete (A.Quote ExprInfo
i) = Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Range -> Expr
C.Quote (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i)
    toConcrete (A.QuoteTerm ExprInfo
i) = Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Range -> Expr
C.QuoteTerm (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i)
    toConcrete (A.Unquote ExprInfo
i) = Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Range -> Expr
C.Unquote (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i)

    -- Andreas, 2012-04-02: TODO!  print DontCare as irrAxiom
    -- Andreas, 2010-10-05 print irrelevant things as ordinary things
    toConcrete (A.DontCare Expr
e) = KwRange -> Expr -> Expr
C.Dot KwRange
forall a. Null a => a
empty (Expr -> Expr) -> (Expr -> Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Expr -> Expr
C.Paren Range
r  (Expr -> Expr) -> m Expr -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e
       where r :: Range
r = Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e
    toConcrete (A.PatternSyn AmbiguousQName
n) = QName -> Expr
C.Ident (QName -> Expr) -> m QName -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
n)

makeDomainFree :: A.LamBinding -> A.LamBinding
makeDomainFree :: LamBinding -> LamBinding
makeDomainFree b :: LamBinding
b@(A.DomainFull (A.TBind Range
_ TypedBindingInfo
tac (NamedArg Binder
x :| []) Expr
t)) =
  case Expr -> Expr
unScope Expr
t of
    A.Underscore A.MetaInfo{metaNumber :: MetaInfo -> Maybe MetaId
metaNumber = Maybe MetaId
Nothing} ->
      TacticAttribute -> NamedArg Binder -> LamBinding
A.DomainFree (TypedBindingInfo -> TacticAttribute
tbTacticAttr TypedBindingInfo
tac) NamedArg Binder
x
    Expr
_ -> LamBinding
b
makeDomainFree LamBinding
b = LamBinding
b


-- Binder instances -------------------------------------------------------

-- If there is no label we set it to the bound name, to make renaming the bound
-- name safe.
forceNameIfHidden :: NamedArg A.Binder -> NamedArg A.Binder
forceNameIfHidden :: NamedArg Binder -> NamedArg Binder
forceNameIfHidden NamedArg Binder
x
  | Maybe NamedName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe NamedName -> Bool) -> Maybe NamedName -> Bool
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Maybe (NameOf (NamedArg Binder))
forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf  NamedArg Binder
x = NamedArg Binder
x
  | NamedArg Binder -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Binder
x             = NamedArg Binder
x
  | Bool
otherwise             = Maybe (NameOf (NamedArg Binder))
-> NamedArg Binder -> NamedArg Binder
forall a. LensNamed a => Maybe (NameOf a) -> a -> a
setNameOf (NamedName -> Maybe NamedName
forall a. a -> Maybe a
Just NamedName
name) NamedArg Binder
x
  where
    name :: NamedName
name = Origin -> Ranged ArgName -> NamedName
forall a. Origin -> a -> WithOrigin a
WithOrigin Origin
Inserted
         (Ranged ArgName -> NamedName) -> Ranged ArgName -> NamedName
forall a b. (a -> b) -> a -> b
$ Range -> ArgName -> Ranged ArgName
forall a. Range -> a -> Ranged a
Ranged (NamedArg Binder -> Range
forall a. HasRange a => a -> Range
getRange NamedArg Binder
x)
         (ArgName -> Ranged ArgName) -> ArgName -> Ranged ArgName
forall a b. (a -> b) -> a -> b
$ Name -> ArgName
C.nameToRawName (Name -> ArgName) -> Name -> ArgName
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete
         (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ BindName -> Name
unBind (BindName -> Name) -> BindName -> Name
forall a b. (a -> b) -> a -> b
$ Binder -> BindName
forall a. Binder' a -> a
A.binderName (Binder -> BindName) -> Binder -> BindName
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg NamedArg Binder
x

instance ToConcrete a => ToConcrete (A.Binder' a) where
  type ConOfAbs (A.Binder' a) = C.Binder' (ConOfAbs a)

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Binder' a -> (ConOfAbs (Binder' a) -> m b) -> m b
bindToConcrete (A.Binder Maybe Pattern
p BinderNameOrigin
o a
a) ConOfAbs (Binder' a) -> m b
ret =
    a -> (ConOfAbs a -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
a ((ConOfAbs a -> m b) -> m b) -> (ConOfAbs a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs a
a ->
    Maybe Pattern -> (ConOfAbs (Maybe Pattern) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Maybe Pattern -> (ConOfAbs (Maybe Pattern) -> m b) -> m b
bindToConcrete Maybe Pattern
p ((ConOfAbs (Maybe Pattern) -> m b) -> m b)
-> (ConOfAbs (Maybe Pattern) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (Maybe Pattern)
p ->
    ConOfAbs (Binder' a) -> m b
ret (ConOfAbs (Binder' a) -> m b) -> ConOfAbs (Binder' a) -> m b
forall a b. (a -> b) -> a -> b
$ Maybe Pattern
-> BinderNameOrigin -> ConOfAbs a -> Binder' (ConOfAbs a)
forall a. Maybe Pattern -> BinderNameOrigin -> a -> Binder' a
C.Binder Maybe Pattern
ConOfAbs (Maybe Pattern)
p BinderNameOrigin
o ConOfAbs a
a

instance ToConcrete A.LamBinding where
    type ConOfAbs A.LamBinding = Maybe C.LamBinding

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
LamBinding -> (ConOfAbs LamBinding -> m b) -> m b
bindToConcrete (A.DomainFree TacticAttribute
t NamedArg Binder
x) ConOfAbs LamBinding -> m b
ret = do
      t <- (Expr -> m Expr) -> TacticAttribute -> m (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 -> m Expr
Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete TacticAttribute
t
      let setTac BoundName
x = BoundName
x { bnameTactic = t }
      bindToConcrete (forceNameIfHidden x) $
        ret . Just . C.DomainFree . updateNamedArg (fmap setTac)
    bindToConcrete (A.DomainFull TypedBinding
b) ConOfAbs LamBinding -> m b
ret = TypedBinding -> (ConOfAbs TypedBinding -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
TypedBinding -> (ConOfAbs TypedBinding -> m b) -> m b
bindToConcrete TypedBinding
b ((ConOfAbs TypedBinding -> m b) -> m b)
-> (ConOfAbs TypedBinding -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Maybe LamBinding -> m b
ConOfAbs LamBinding -> m b
ret (Maybe LamBinding -> m b)
-> (Maybe TypedBinding -> Maybe LamBinding)
-> Maybe TypedBinding
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
forall a. a -> LamBinding' a
C.DomainFull

instance ToConcrete A.TypedBinding where
    type ConOfAbs A.TypedBinding = Maybe C.TypedBinding

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
TypedBinding -> (ConOfAbs TypedBinding -> m b) -> m b
bindToConcrete (A.TBind Range
r TypedBindingInfo
t List1 (NamedArg Binder)
xs Expr
e) ConOfAbs TypedBinding -> m b
ret = do
        tac <- (Expr -> m Expr) -> TacticAttribute -> m (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 -> m Expr
Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete (TypedBindingInfo -> TacticAttribute
tbTacticAttr TypedBindingInfo
t)
        bindToConcrete (fmap forceNameIfHidden xs) $ \ ConOfAbs (List1 (NamedArg Binder))
xs -> do
          e <- Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop Expr
e
          let setTac BoundName
x = BoundName
x { bnameTactic = tac , C.bnameIsFinite = tbFinite t }
          ret $ Just $ C.TBind r (fmap (updateNamedArg (fmap setTac)) xs) e
    bindToConcrete (A.TLet Range
r List1 LetBinding
lbs) ConOfAbs TypedBinding -> m b
ret =
        List1 LetBinding -> (ConOfAbs (List1 LetBinding) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
List1 LetBinding -> (ConOfAbs (List1 LetBinding) -> m b) -> m b
bindToConcrete List1 LetBinding
lbs ((ConOfAbs (List1 LetBinding) -> m b) -> m b)
-> (ConOfAbs (List1 LetBinding) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (List1 LetBinding)
ds -> do
        ConOfAbs TypedBinding -> m b
ret (ConOfAbs TypedBinding -> m b) -> ConOfAbs TypedBinding -> m b
forall a b. (a -> b) -> a -> b
$ Range -> [Declaration] -> Maybe TypedBinding
forall e. Range -> [Declaration] -> Maybe (TypedBinding' e)
C.mkTLet Range
r ([Declaration] -> Maybe TypedBinding)
-> [Declaration] -> Maybe TypedBinding
forall a b. (a -> b) -> a -> b
$ NonEmpty [Declaration] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NonEmpty [Declaration]
ConOfAbs (List1 LetBinding)
ds

instance ToConcrete A.LetBinding where
    type ConOfAbs A.LetBinding = [C.Declaration]

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
LetBinding -> (ConOfAbs LetBinding -> m b) -> m b
bindToConcrete (A.LetBind LetInfo
i ArgInfo
info BindName
x Expr
t Expr
e) ConOfAbs LetBinding -> m b
ret =
      BindName -> (ConOfAbs BindName -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
BindName -> (ConOfAbs BindName -> m b) -> m b
bindToConcrete BindName
x \ ConOfAbs BindName
x -> do
        (Expr, RHS) -> m (ConOfAbs (Expr, RHS))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
(Expr, RHS) -> m (ConOfAbs (Expr, RHS))
toConcrete (Expr
t, Expr -> Maybe Expr -> RHS
A.RHS Expr
e Maybe Expr
forall a. Maybe a
Nothing) m (Expr, (RHS, [RewriteEqn], [WithExpr], [Declaration]))
-> ((Expr, (RHS, [RewriteEqn], [WithExpr], [Declaration])) -> m b)
-> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Expr
t, (RHS
e, [], [], [])) ->
           ConOfAbs LetBinding -> m b
ret (ConOfAbs LetBinding -> m b) -> ConOfAbs LetBinding -> m b
forall a b. (a -> b) -> a -> b
$ Maybe KwRange -> [Declaration] -> [Declaration]
addInstanceB (if ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
isInstance ArgInfo
info then KwRange -> Maybe KwRange
forall a. a -> Maybe a
Just KwRange
forall a. Null a => a
empty else Maybe KwRange
forall a. Maybe a
Nothing) ([Declaration] -> [Declaration]) -> [Declaration] -> [Declaration]
forall a b. (a -> b) -> a -> b
$
               [ ArgInfo -> TacticAttribute' Expr -> Name -> Expr -> Declaration
C.TypeSig ArgInfo
info TacticAttribute' Expr
forall a. Null a => a
empty (BoundName -> Name
C.boundName BoundName
ConOfAbs BindName
x) Expr
t
               , LHS -> RHS -> WhereClause' [Declaration] -> Bool -> Declaration
C.FunClause
                   (Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS (Bool -> QName -> Pattern
C.IdentP Bool
True (QName -> Pattern) -> QName -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ BoundName -> Name
C.boundName BoundName
ConOfAbs BindName
x) [] [])
                   RHS
e WhereClause' [Declaration]
forall decls. WhereClause' decls
C.NoWhere Bool
False
               ]
          (Expr, (RHS, [RewriteEqn], [WithExpr], [Declaration]))
_ -> m b
forall a. HasCallStack => a
__IMPOSSIBLE__
    bindToConcrete (A.LetAxiom LetInfo
i ArgInfo
info BindName
x Expr
t) ConOfAbs LetBinding -> m b
ret = BindName -> (ConOfAbs BindName -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
BindName -> (ConOfAbs BindName -> m b) -> m b
bindToConcrete BindName
x \ConOfAbs BindName
x -> do
      t <- Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
t
      ret $ addInstanceB (if isInstance info then Just empty else Nothing) $
        [ C.TypeSig info empty (C.boundName x) t ]
    -- TODO: bind variables
    bindToConcrete (LetPatBind LetInfo
i Pattern
p Expr
e) ConOfAbs LetBinding -> m b
ret = do
        p <- Pattern -> m (ConOfAbs Pattern)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (ConOfAbs Pattern)
toConcrete Pattern
p
        e <- toConcrete e
        ret [ C.FunClause (C.LHS p [] []) (C.RHS e) NoWhere False ]
    bindToConcrete (LetApply ModuleInfo
i Erased
erased ModuleName
x ModuleApplication
modapp ScopeCopyInfo
_ ImportDirective
_) ConOfAbs LetBinding -> m b
ret = do
      x' <- QName -> Name
unqualify (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
x
      modapp <- toConcrete modapp
      let r = ModuleApplication -> Range
forall a. HasRange a => a -> Range
getRange ModuleApplication
modapp
          open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
          dir  = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir{ importDirRange = r } (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
      -- This is no use since toAbstract LetDefs is in localToAbstract.
      local (openModule' x dir id) $
        ret [ C.ModuleMacro (getRange i) erased x' modapp open dir ]
    bindToConcrete (LetOpen ModuleInfo
i ModuleName
x ImportDirective
_) ConOfAbs LetBinding -> m b
ret = do
      x' <- ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
x
      let dir = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
      local (openModule' x dir restrictPrivate) $
            ret [ C.Open (getRange i) x' dir ]
    bindToConcrete (LetDeclaredVariable BindName
_) ConOfAbs LetBinding -> m b
ret =
      -- Note that the range of the declaration site is dropped.
      ConOfAbs LetBinding -> m b
ret []

instance ToConcrete A.WhereDeclarations where
  type ConOfAbs A.WhereDeclarations = WhereClause

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
WhereDeclarations -> (ConOfAbs WhereDeclarations -> m b) -> m b
bindToConcrete (A.WhereDecls Maybe ModuleName
_ Bool
_ Maybe Declaration
Nothing) ConOfAbs WhereDeclarations -> m b
ret = ConOfAbs WhereDeclarations -> m b
ret WhereClause' [Declaration]
ConOfAbs WhereDeclarations
forall decls. WhereClause' decls
C.NoWhere
  bindToConcrete (A.WhereDecls (Just ModuleName
am) Bool
False
                    (Just (A.Section Range
_ Erased
erased ModuleName
_ GeneralizeTelescope
_ [Declaration]
ds)))
                 ConOfAbs WhereDeclarations -> m b
ret = do
    ds' <- [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
[Declaration] -> m [Declaration]
declsToConcrete [Declaration]
ds
    cm  <- unqualify <$> lookupModule am
    -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere
    -- Should not really matter for printing...
    let wh' = if Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
cm Bool -> Bool -> Bool
&& Bool -> Bool
not (Erased -> Bool
isErased Erased
erased)
              then Range -> [Declaration] -> WhereClause' [Declaration]
forall decls. Range -> decls -> WhereClause' decls
AnyWhere Range
forall a. Range' a
noRange [Declaration]
ds'
              else Range
-> Erased
-> Name
-> Access
-> [Declaration]
-> WhereClause' [Declaration]
forall decls.
Range -> Erased -> Name -> Access -> decls -> WhereClause' decls
SomeWhere Range
forall a. Range' a
noRange Erased
erased Name
cm Access
PublicAccess [Declaration]
ds'
    local (openModule' am defaultImportDir id) $ ret wh'
  bindToConcrete (A.WhereDecls Maybe ModuleName
_ Bool
_ (Just Declaration
d)) ConOfAbs WhereDeclarations -> m b
ret =
    WhereClause' [Declaration] -> m b
ConOfAbs WhereDeclarations -> m b
ret (WhereClause' [Declaration] -> m b)
-> ([Declaration] -> WhereClause' [Declaration])
-> [Declaration]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Declaration] -> WhereClause' [Declaration]
forall decls. Range -> decls -> WhereClause' decls
AnyWhere Range
forall a. Range' a
noRange ([Declaration] -> m b) -> m [Declaration] -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Declaration -> m (ConOfAbs Declaration)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Declaration -> m (ConOfAbs Declaration)
toConcrete Declaration
d

mergeSigAndDef :: [C.Declaration] -> [C.Declaration]
mergeSigAndDef :: [Declaration] -> [Declaration]
mergeSigAndDef (C.RecordSig Range
_ Erased
er Name
x [LamBinding]
bs Expr
e : C.RecordDef Range
r Name
y [RecordDirective]
dir [LamBinding]
_ [Declaration]
fs : [Declaration]
ds)
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Erased
-> Name
-> [RecordDirective]
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Erased
er Name
y [RecordDirective]
dir [LamBinding]
bs Expr
e [Declaration]
fs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (C.DataSig Range
_ Erased
er Name
x [LamBinding]
bs Expr
e : C.DataDef Range
r Name
y [LamBinding]
_ [Declaration]
cs : [Declaration]
ds)
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Erased
-> Name
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Data Range
r Erased
er Name
y [LamBinding]
bs Expr
e [Declaration]
cs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (Declaration
d : [Declaration]
ds) = Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef [] = []

openModule' :: A.ModuleName -> C.ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' :: ModuleName -> ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' ModuleName
x ImportDirective
dir Scope -> Scope
restrict Env
env = Env
env{currentScope = set scopeModules mods' sInfo}
  where sInfo :: ScopeInfo
sInfo = Env -> ScopeInfo
currentScope Env
env
        amod :: ModuleName
amod  = ScopeInfo
sInfo ScopeInfo -> Lens' ScopeInfo ModuleName -> ModuleName
forall o i. o -> Lens' o i -> i
^. (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo ModuleName
scopeCurrent
        mods :: Map ModuleName Scope
mods  = ScopeInfo
sInfo ScopeInfo
-> Lens' ScopeInfo (Map ModuleName Scope) -> Map ModuleName Scope
forall o i. o -> Lens' o i -> i
^. (Map ModuleName Scope -> f (Map ModuleName Scope))
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo (Map ModuleName Scope)
scopeModules
        news :: Scope
news  = NameSpaceId -> Scope -> Scope
setScopeAccess NameSpaceId
PrivateNS
                (Scope -> Scope) -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ ImportDirective -> Scope -> Scope
applyImportDirective ImportDirective
dir
                (Scope -> Scope) -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ Scope -> (Scope -> Scope) -> Maybe Scope -> Scope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scope
emptyScope Scope -> Scope
restrict
                (Maybe Scope -> Scope) -> Maybe Scope -> Scope
forall a b. (a -> b) -> a -> b
$ ModuleName -> Map ModuleName Scope -> Maybe Scope
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
x Map ModuleName Scope
mods
        mods' :: Map ModuleName Scope
mods' = (Scope -> Maybe Scope)
-> ModuleName -> Map ModuleName Scope -> Map ModuleName Scope
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> (Scope -> Scope) -> Scope -> Maybe Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scope -> Scope -> Scope
`mergeScope` Scope
news)) ModuleName
amod Map ModuleName Scope
mods


-- Declaration instances --------------------------------------------------

declsToConcrete :: MonadToConcrete m => [A.Declaration] -> m [C.Declaration]
declsToConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
[Declaration] -> m [Declaration]
declsToConcrete [Declaration]
ds = [Declaration] -> [Declaration]
mergeSigAndDef ([Declaration] -> [Declaration])
-> ([[Declaration]] -> [Declaration])
-> [[Declaration]]
-> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> m [[Declaration]] -> m [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m (ConOfAbs [Declaration])
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
[Declaration] -> m (ConOfAbs [Declaration])
toConcrete [Declaration]
ds

instance ToConcrete A.RHS where
    type ConOfAbs A.RHS = (C.RHS, [C.RewriteEqn], [C.WithExpr], [C.Declaration])

    toConcrete :: forall (m :: * -> *). MonadToConcrete m => RHS -> m (ConOfAbs RHS)
toConcrete (A.RHS Expr
e (Just Expr
c)) = (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> m (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> RHS
forall e. e -> RHS' e
C.RHS Expr
c, [], [], [])
    toConcrete (A.RHS Expr
e Maybe Expr
Nothing) = do
      e <- Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
e
      return (C.RHS e, [], [], [])
    toConcrete RHS
A.AbsurdRHS = (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> m (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
forall e. RHS' e
C.AbsurdRHS, [], [], [])
    toConcrete (A.WithRHS QName
_ List1 WithExpr
es List1 Clause
cs) = do
      es <- do es <- List1 WithExpr -> m (ConOfAbs (List1 WithExpr))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
List1 WithExpr -> m (ConOfAbs (List1 WithExpr))
toConcrete List1 WithExpr
es
               forM es $ \ (Named Maybe BindName
n Arg Expr
e) -> do
                 n <- (BindName -> m BoundName) -> Maybe BindName -> m (Maybe BoundName)
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 BindName -> m BoundName
BindName -> m (ConOfAbs BindName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
BindName -> m (ConOfAbs BindName)
toConcrete Maybe BindName
n
                 pure $ Named (C.boundName <$> n) e
      cs <- noTakenNames $ sconcat <$> toConcrete cs
      return (C.AbsurdRHS, [], List1.toList es, List1.toList cs)
    toConcrete (A.RewriteRHS [RewriteEqn]
xeqs [ProblemEq]
_spats RHS
rhs WhereDeclarations
wh) = do
      wh <- m [Declaration]
-> (Declaration -> m [Declaration])
-> Maybe Declaration
-> m [Declaration]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Declaration] -> m [Declaration]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []) Declaration -> m [Declaration]
Declaration -> m (ConOfAbs Declaration)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Declaration -> m (ConOfAbs Declaration)
toConcrete (Maybe Declaration -> m [Declaration])
-> Maybe Declaration -> m [Declaration]
forall a b. (a -> b) -> a -> b
$ WhereDeclarations -> Maybe Declaration
A.whereDecls WhereDeclarations
wh
      (rhs, eqs', es, whs) <- toConcrete rhs
      unless (null eqs') __IMPOSSIBLE__
      eqs <- toConcrete xeqs
      return (rhs, eqs, es, wh ++ whs)

instance (ToConcrete p, ToConcrete a) => ToConcrete (RewriteEqn' qn A.BindName p a) where
  type ConOfAbs (RewriteEqn' qn A.BindName p a) = (RewriteEqn' () C.Name (ConOfAbs p) (ConOfAbs a))

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
RewriteEqn' qn BindName p a
-> m (ConOfAbs (RewriteEqn' qn BindName p a))
toConcrete = \case
    Rewrite List1 (qn, a)
es    -> List1 ((), ConOfAbs a)
-> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a)
forall qn nm p e. List1 (qn, e) -> RewriteEqn' qn nm p e
Rewrite (List1 ((), ConOfAbs a)
 -> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
-> m (List1 ((), ConOfAbs a))
-> m (RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((qn, a) -> m ((), ConOfAbs a))
-> List1 (qn, a) -> m (List1 ((), ConOfAbs a))
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 (((), a) -> m ((), ConOfAbs a)
((), a) -> m (ConOfAbs ((), a))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
((), a) -> m (ConOfAbs ((), a))
toConcrete (((), a) -> m ((), ConOfAbs a))
-> ((qn, a) -> ((), a)) -> (qn, a) -> m ((), ConOfAbs a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (qn
_, a
e) -> ((),a
e))) List1 (qn, a)
es
    Invert qn
qn List1 (Named BindName (p, a))
pes -> (List1 (Named Name (ConOfAbs p, ConOfAbs a))
 -> ConOfAbs (RewriteEqn' qn BindName p a))
-> m (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
-> m (ConOfAbs (RewriteEqn' qn BindName p a))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (()
-> List1 (Named Name (ConOfAbs p, ConOfAbs a))
-> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a)
forall qn nm p e.
qn -> List1 (Named nm (p, e)) -> RewriteEqn' qn nm p e
Invert ()) (m (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
 -> m (ConOfAbs (RewriteEqn' qn BindName p a)))
-> m (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
-> m (ConOfAbs (RewriteEqn' qn BindName p a))
forall a b. (a -> b) -> a -> b
$ List1 (Named BindName (p, a))
-> (Named BindName (p, a)
    -> m (Named Name (ConOfAbs p, ConOfAbs a)))
-> m (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 (Named BindName (p, a))
pes ((Named BindName (p, a) -> m (Named Name (ConOfAbs p, ConOfAbs a)))
 -> m (List1 (Named Name (ConOfAbs p, ConOfAbs a))))
-> (Named BindName (p, a)
    -> m (Named Name (ConOfAbs p, ConOfAbs a)))
-> m (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
forall a b. (a -> b) -> a -> b
$ \ (Named Maybe BindName
n (p, a)
pe) -> do
      pe <- (p, a) -> m (ConOfAbs (p, a))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
(p, a) -> m (ConOfAbs (p, a))
toConcrete (p, a)
pe
      n  <- fmap C.boundName <$> toConcrete n
      pure $ Named n pe
    LeftLet List1 (p, a)
pes -> List1 (ConOfAbs p, ConOfAbs a)
-> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a)
forall qn nm p e. List1 (p, e) -> RewriteEqn' qn nm p e
LeftLet (List1 (ConOfAbs p, ConOfAbs a)
 -> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
-> m (List1 (ConOfAbs p, ConOfAbs a))
-> m (RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((p, a) -> m (ConOfAbs p, ConOfAbs a))
-> List1 (p, a) -> m (List1 (ConOfAbs p, ConOfAbs a))
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 (p, a) -> m (ConOfAbs p, ConOfAbs a)
(p, a) -> m (ConOfAbs (p, a))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
(p, a) -> m (ConOfAbs (p, a))
toConcrete List1 (p, a)
pes

instance ToConcrete (Constr A.Constructor) where
  type ConOfAbs (Constr A.Constructor) = C.Declaration

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Constr Declaration -> m (ConOfAbs (Constr Declaration))
toConcrete (Constr (A.ScopedDecl ScopeInfo
scope [Declaration
d])) =
    ScopeInfo
-> m (ConOfAbs (Constr Declaration))
-> m (ConOfAbs (Constr Declaration))
forall (m :: * -> *) a.
MonadToConcrete m =>
ScopeInfo -> m a -> m a
withScope ScopeInfo
scope (m (ConOfAbs (Constr Declaration))
 -> m (ConOfAbs (Constr Declaration)))
-> m (ConOfAbs (Constr Declaration))
-> m (ConOfAbs (Constr Declaration))
forall a b. (a -> b) -> a -> b
$ Constr Declaration -> m (ConOfAbs (Constr Declaration))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Constr Declaration -> m (ConOfAbs (Constr Declaration))
toConcrete (Declaration -> Constr Declaration
forall a. a -> Constr a
Constr Declaration
d)
  toConcrete (Constr (A.Axiom KindOfName
_ DefInfo
i ArgInfo
info Maybe (List1 Occurrence)
Nothing QName
x Expr
t)) = do
    x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    t' <- toConcreteTop t
    return $ C.TypeSig info empty x' t'
  toConcrete (Constr (A.Axiom KindOfName
_ DefInfo
_ ArgInfo
_ (Just List1 Occurrence
_) QName
_ Expr
_)) = m Declaration
m (ConOfAbs (Constr Declaration))
forall a. HasCallStack => a
__IMPOSSIBLE__
  toConcrete (Constr Declaration
d) = Declaration -> [Declaration] -> Declaration
forall a. a -> [a] -> a
headWithDefault Declaration
forall a. HasCallStack => a
__IMPOSSIBLE__ ([Declaration] -> Declaration) -> m [Declaration] -> m Declaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Declaration -> m (ConOfAbs Declaration)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Declaration -> m (ConOfAbs Declaration)
toConcrete Declaration
d

instance (ToConcrete a, ConOfAbs a ~ C.LHS) => ToConcrete (A.Clause' a) where
  type ConOfAbs (A.Clause' a) = List1 C.Declaration

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Clause' a -> m (ConOfAbs (Clause' a))
toConcrete (A.Clause a
lhs [ProblemEq]
_ RHS
rhs WhereDeclarations
wh Bool
catchall) =
      a
-> (ConOfAbs a -> m (ConOfAbs (Clause' a)))
-> m (ConOfAbs (Clause' a))
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
a -> (ConOfAbs a -> m b) -> m b
bindToConcrete a
lhs ((ConOfAbs a -> m (ConOfAbs (Clause' a)))
 -> m (ConOfAbs (Clause' a)))
-> (ConOfAbs a -> m (ConOfAbs (Clause' a)))
-> m (ConOfAbs (Clause' a))
forall a b. (a -> b) -> a -> b
$ \case
          C.LHS Pattern
p [RewriteEqn]
_ [WithExpr]
_ -> do
            WhereDeclarations
-> (ConOfAbs WhereDeclarations -> m (ConOfAbs (Clause' a)))
-> m (ConOfAbs (Clause' a))
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
WhereDeclarations -> (ConOfAbs WhereDeclarations -> m b) -> m b
bindToConcrete WhereDeclarations
wh ((ConOfAbs WhereDeclarations -> m (ConOfAbs (Clause' a)))
 -> m (ConOfAbs (Clause' a)))
-> (ConOfAbs WhereDeclarations -> m (ConOfAbs (Clause' a)))
-> m (ConOfAbs (Clause' a))
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs WhereDeclarations
wh' -> do
                (rhs', eqs, with, wcs) <- RHS -> m (ConOfAbs RHS)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
a -> m (ConOfAbs a)
toConcreteTop RHS
rhs
                return $ FunClause (C.LHS p eqs with) rhs' wh' catchall :| wcs

instance ToConcrete A.ModuleApplication where
  type ConOfAbs A.ModuleApplication = C.ModuleApplication

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
ModuleApplication -> m (ConOfAbs ModuleApplication)
toConcrete (A.SectionApp Telescope
tel ModuleName
y [NamedArg Expr]
es) = do
    y  <- Precedence -> ModuleName -> m (ConOfAbs ModuleName)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
FunctionCtx ModuleName
y
    bindToConcrete tel $ \ ConOfAbs Telescope
tel -> do
      es <- Precedence -> [NamedArg Expr] -> m (ConOfAbs [NamedArg Expr])
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ [NamedArg Expr]
es
      let r = QName -> [NamedArg Expr] -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange QName
y [NamedArg Expr]
es
      return $ C.SectionApp r (catMaybes tel) y $ map unNamedArg es

  toConcrete (A.RecordModuleInstance ModuleName
recm) = do
    recm <- ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
recm
    return $ C.RecordModuleInstance (getRange recm) recm

instance ToConcrete A.RecordDirectives where
  type ConOfAbs A.RecordDirectives = [C.RecordDirective]

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
RecordDirectives -> m (ConOfAbs RecordDirectives)
toConcrete RecordDirectives
dir = RecordDirectives -> [RecordDirective]
C.ungatherRecordDirectives (RecordDirectives -> [RecordDirective])
-> m RecordDirectives -> m [RecordDirective]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordConName -> m (Maybe (Name, IsInstance)))
-> RecordDirectives -> m RecordDirectives
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) -> RecordDirectives' a -> f (RecordDirectives' b)
traverse RecordConName -> m (Maybe (Name, IsInstance))
forall (m :: * -> *).
MonadToConcrete m =>
RecordConName -> m (Maybe (Name, IsInstance))
f RecordDirectives
dir
    where
      f :: MonadToConcrete m => RecordConName -> m (Maybe (C.Name, IsInstance))
      f :: forall (m :: * -> *).
MonadToConcrete m =>
RecordConName -> m (Maybe (Name, IsInstance))
f (FreshRecCon QName
_) = Maybe (Name, IsInstance) -> m (Maybe (Name, IsInstance))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Name, IsInstance)
forall a. Maybe a
Nothing
      f (NamedRecCon QName
nm) = (Name, IsInstance) -> Maybe (Name, IsInstance)
forall a. a -> Maybe a
Just ((Name, IsInstance) -> Maybe (Name, IsInstance))
-> (QName -> (Name, IsInstance))
-> QName
-> Maybe (Name, IsInstance)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, IsInstance
NotInstanceDef) (Name -> (Name, IsInstance))
-> (QName -> Name) -> QName -> (Name, IsInstance)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
C.unqualify (QName -> Maybe (Name, IsInstance))
-> m QName -> m (Maybe (Name, IsInstance))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
nm


instance ToConcrete A.Declaration where
  type ConOfAbs A.Declaration = [C.Declaration]

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Declaration -> m (ConOfAbs Declaration)
toConcrete (ScopedDecl ScopeInfo
scope [Declaration]
ds) =
    ScopeInfo -> m [Declaration] -> m [Declaration]
forall (m :: * -> *) a.
MonadToConcrete m =>
ScopeInfo -> m a -> m a
withScope ScopeInfo
scope ([Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
[Declaration] -> m [Declaration]
declsToConcrete [Declaration]
ds)

  toConcrete (A.Axiom KindOfName
_ DefInfo
i ArgInfo
info Maybe (List1 Occurrence)
mp QName
x Expr
t) = do
    x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    withAbstractPrivate i $
      withInfixDecl i x'  $ do
      t' <- toConcreteTop t
      return $
        (case mp of
           Maybe (List1 Occurrence)
Nothing   -> []
           Just List1 Occurrence
occs -> [Pragma -> Declaration
C.Pragma (Range -> Name -> [Occurrence] -> Pragma
PolarityPragma Range
forall a. Range' a
noRange Name
x' ([Occurrence] -> Pragma) -> [Occurrence] -> Pragma
forall a b. (a -> b) -> a -> b
$ List1 Occurrence -> [Item (List1 Occurrence)]
forall l. IsList l => l -> [Item l]
List1.toList List1 Occurrence
occs)]) ++
        [C.Postulate empty [C.TypeSig info empty x' t']]

  toConcrete (A.Generalize Set QName
s DefInfo
i ArgInfo
j QName
x Expr
t) = do
    x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    tac <- toConcrete (defTactic i)
    withAbstractPrivate i $
      withInfixDecl i x'  $ do
      t' <- toConcreteTop t
      return [C.Generalize empty [C.TypeSig j tac x' $ C.Generalized t']]

  toConcrete (A.Field DefInfo
i QName
x Arg Expr
t) = do
    x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    tac <- toConcrete (defTactic i)
    withAbstractPrivate i $
      withInfixDecl i x'  $ do
      t' <- toConcreteTop t
      return [C.FieldSig (A.defInstance i) tac x' t']

  toConcrete (A.Primitive DefInfo
i QName
x Arg Expr
t) = do
    x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    withAbstractPrivate i $
      withInfixDecl i x'  $ do
      t' <- traverse toConcreteTop t
      return [C.Primitive empty [C.TypeSig (argInfo t') empty x' (unArg t')]]
        -- Primitives are always relevant.

  toConcrete (A.FunDef DefInfo
i QName
_ [Clause]
cs) =
    DefInfo -> m [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> m [Declaration] -> m [Declaration]
withAbstractPrivate DefInfo
i (m [Declaration] -> m [Declaration])
-> m [Declaration] -> m [Declaration]
forall a b. (a -> b) -> a -> b
$ [NonEmpty Declaration] -> [Declaration]
forall a. [List1 a] -> [a]
List1.concat ([NonEmpty Declaration] -> [Declaration])
-> m [NonEmpty Declaration] -> m [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Clause] -> m (ConOfAbs [Clause])
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
[Clause] -> m (ConOfAbs [Clause])
toConcrete [Clause]
cs

  toConcrete (A.DataSig DefInfo
i Erased
erased QName
x GeneralizeTelescope
bs Expr
t) =
    DefInfo -> m [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> m [Declaration] -> m [Declaration]
withAbstractPrivate DefInfo
i (m [Declaration] -> m [Declaration])
-> m [Declaration] -> m [Declaration]
forall a b. (a -> b) -> a -> b
$
    Telescope
-> (ConOfAbs Telescope -> m [Declaration]) -> m [Declaration]
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Telescope -> (ConOfAbs Telescope -> m b) -> m b
bindToConcrete (GeneralizeTelescope -> Telescope
A.generalizeTel GeneralizeTelescope
bs) ((ConOfAbs Telescope -> m [Declaration]) -> m [Declaration])
-> (ConOfAbs Telescope -> m [Declaration]) -> m [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs Telescope
tel' -> do
      x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
      t' <- toConcreteTop t
      return [ C.DataSig (getRange i) erased x'
                 (map C.DomainFull $ catMaybes tel') t' ]

  toConcrete (A.DataDef DefInfo
i QName
x UniverseCheck
uc DataDefParams
bs [Declaration]
cs) =
    DefInfo -> m [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> m [Declaration] -> m [Declaration]
withAbstractPrivate DefInfo
i (m [Declaration] -> m [Declaration])
-> m [Declaration] -> m [Declaration]
forall a b. (a -> b) -> a -> b
$
    [LamBinding]
-> (ConOfAbs [LamBinding] -> m [Declaration]) -> m [Declaration]
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[LamBinding] -> (ConOfAbs [LamBinding] -> m b) -> m b
bindToConcrete ((LamBinding -> LamBinding) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> [a] -> [b]
map LamBinding -> LamBinding
makeDomainFree ([LamBinding] -> [LamBinding]) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> a -> b
$ DataDefParams -> [LamBinding]
dataDefParams DataDefParams
bs) ((ConOfAbs [LamBinding] -> m [Declaration]) -> m [Declaration])
-> (ConOfAbs [LamBinding] -> m [Declaration]) -> m [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [LamBinding]
tel' -> do
      (x',cs') <- (QName -> Name) -> (QName, [Declaration]) -> (Name, [Declaration])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first QName -> Name
unsafeQNameToName ((QName, [Declaration]) -> (Name, [Declaration]))
-> m (QName, [Declaration]) -> m (Name, [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QName, [Constr Declaration])
-> m (ConOfAbs (QName, [Constr Declaration]))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
(QName, [Constr Declaration])
-> m (ConOfAbs (QName, [Constr Declaration]))
toConcrete (QName
x, (Declaration -> Constr Declaration)
-> [Declaration] -> [Constr Declaration]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Constr Declaration
forall a. a -> Constr a
Constr [Declaration]
cs)
      return [ C.DataDef (getRange i) x' (catMaybes tel') cs' ]

  toConcrete (A.RecSig DefInfo
i Erased
erased QName
x GeneralizeTelescope
bs Expr
t) =
    DefInfo -> m [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> m [Declaration] -> m [Declaration]
withAbstractPrivate DefInfo
i (m [Declaration] -> m [Declaration])
-> m [Declaration] -> m [Declaration]
forall a b. (a -> b) -> a -> b
$
    Telescope
-> (ConOfAbs Telescope -> m [Declaration]) -> m [Declaration]
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Telescope -> (ConOfAbs Telescope -> m b) -> m b
bindToConcrete (GeneralizeTelescope -> Telescope
A.generalizeTel GeneralizeTelescope
bs) ((ConOfAbs Telescope -> m [Declaration]) -> m [Declaration])
-> (ConOfAbs Telescope -> m [Declaration]) -> m [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs Telescope
tel' -> do
      x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
      t' <- toConcreteTop t
      return [ C.RecordSig (getRange i) erased x'
                 (map C.DomainFull $ catMaybes tel') t' ]

  toConcrete (A.RecDef  DefInfo
i QName
x UniverseCheck
uc RecordDirectives
dir DataDefParams
bs Expr
t [Declaration]
cs) =
    DefInfo -> m [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
DefInfo -> m [Declaration] -> m [Declaration]
withAbstractPrivate DefInfo
i (m [Declaration] -> m [Declaration])
-> m [Declaration] -> m [Declaration]
forall a b. (a -> b) -> a -> b
$
    [LamBinding]
-> (ConOfAbs [LamBinding] -> m [Declaration]) -> m [Declaration]
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[LamBinding] -> (ConOfAbs [LamBinding] -> m b) -> m b
bindToConcrete ((LamBinding -> LamBinding) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> [a] -> [b]
map LamBinding -> LamBinding
makeDomainFree ([LamBinding] -> [LamBinding]) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> a -> b
$ DataDefParams -> [LamBinding]
dataDefParams DataDefParams
bs) ((ConOfAbs [LamBinding] -> m [Declaration]) -> m [Declaration])
-> (ConOfAbs [LamBinding] -> m [Declaration]) -> m [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [LamBinding]
tel' -> do
      dirs <- RecordDirectives -> m (ConOfAbs RecordDirectives)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
RecordDirectives -> m (ConOfAbs RecordDirectives)
toConcrete RecordDirectives
dir
      (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)
      return [ C.RecordDef (getRange i) x' dirs (catMaybes tel') cs' ]

  toConcrete (A.Mutual MutualInfo
i [Declaration]
ds) = Declaration -> [Declaration]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Declaration -> [Declaration])
-> ([Declaration] -> Declaration) -> [Declaration] -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KwRange -> [Declaration] -> Declaration
C.Mutual KwRange
forall a. Null a => a
empty ([Declaration] -> [Declaration])
-> m [Declaration] -> m [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
[Declaration] -> m [Declaration]
declsToConcrete [Declaration]
ds

  toConcrete (A.Section Range
i Erased
erased ModuleName
x (A.GeneralizeTel Map QName Name
_ Telescope
tel) [Declaration]
ds) = do
    x <- ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
x
    bindToConcrete tel $ \ ConOfAbs Telescope
tel -> do
      ds <- [Declaration] -> m [Declaration]
forall (m :: * -> *).
MonadToConcrete m =>
[Declaration] -> m [Declaration]
declsToConcrete [Declaration]
ds
      return [ C.Module (getRange i) erased x (catMaybes tel) ds ]

  toConcrete (A.Apply ModuleInfo
i Erased
erased ModuleName
x ModuleApplication
modapp ScopeCopyInfo
_ ImportDirective
_) = do
    x  <- QName -> Name
unsafeQNameToName (QName -> Name) -> m QName -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
x
    modapp <- toConcrete modapp
    let r = ModuleApplication -> Range
forall a. HasRange a => a -> Range
getRange ModuleApplication
modapp
        open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
        dir  = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir{ importDirRange = r } (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
    return [ C.ModuleMacro (getRange i) erased x modapp open dir ]

  toConcrete (A.Import ModuleInfo
i ModuleName
x ImportDirective
_) = do
    x <- ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
x
    let open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
        dir  = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
    return [ C.Import (getRange i) x Nothing open dir]

  toConcrete (A.Pragma Range
i Pragma
p)     = do
    p <- RangeAndPragma -> m (ConOfAbs RangeAndPragma)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
RangeAndPragma -> m (ConOfAbs RangeAndPragma)
toConcrete (RangeAndPragma -> m (ConOfAbs RangeAndPragma))
-> RangeAndPragma -> m (ConOfAbs RangeAndPragma)
forall a b. (a -> b) -> a -> b
$ Range -> Pragma -> RangeAndPragma
RangeAndPragma (Range -> Range
forall a. HasRange a => a -> Range
getRange Range
i) Pragma
p
    return [C.Pragma p]

  toConcrete (A.Open ModuleInfo
i ModuleName
x ImportDirective
_) = do
    x <- ModuleName -> m (ConOfAbs ModuleName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ModuleName -> m (ConOfAbs ModuleName)
toConcrete ModuleName
x
    return [C.Open (getRange i) x defaultImportDir]

  toConcrete (A.PatternSynDef QName
x [WithHiding BindName]
xs Pattern' Void
p) = QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x m QName -> (QName -> m [Declaration]) -> m [Declaration]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    C.QName Name
x -> [WithHiding Name]
-> (ConOfAbs [WithHiding Name] -> m [Declaration])
-> m [Declaration]
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[WithHiding Name] -> (ConOfAbs [WithHiding Name] -> m b) -> m b
bindToConcrete ((WithHiding BindName -> WithHiding Name)
-> [WithHiding BindName] -> [WithHiding Name]
forall a b. (a -> b) -> [a] -> [b]
map ((BindName -> Name) -> WithHiding BindName -> WithHiding Name
forall a b. (a -> b) -> WithHiding a -> WithHiding b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BindName -> Name
A.unBind) [WithHiding BindName]
xs) \ ConOfAbs [WithHiding Name]
xs ->
      Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> (Pattern -> Declaration) -> Pattern -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Name -> [WithHiding Name] -> Pattern -> Declaration
C.PatternSyn (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Name
x [WithHiding Name]
ConOfAbs [WithHiding Name]
xs (Pattern -> [Declaration]) -> m Pattern -> m [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        m Pattern -> m Pattern
forall (m :: * -> *) a. MonadToConcrete m => m a -> m a
dontFoldPatternSynonyms (m Pattern -> m Pattern) -> m Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> m (ConOfAbs Pattern)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (ConOfAbs Pattern)
toConcrete (Pattern' Void -> Pattern
forall (f :: * -> *) a. Functor f => f Void -> f a
vacuous Pattern' Void
p :: A.Pattern)
    QName
_ -> m [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__

  toConcrete (A.UnquoteDecl MutualInfo
_ [DefInfo]
i [QName]
xs Expr
e) = do
    let unqual :: QName -> m Name
unqual (C.QName Name
x) = Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
        unqual QName
_           = m Name
forall a. HasCallStack => a
__IMPOSSIBLE__
    xs <- (QName -> m Name) -> [QName] -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (QName -> m Name
forall {m :: * -> *}. Monad m => QName -> m Name
unqual (QName -> m Name) -> (QName -> m QName) -> QName -> m Name
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< QName -> m QName
QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete) [QName]
xs
    (:[]) . C.UnquoteDecl (getRange i) xs <$> toConcrete e

  toConcrete (A.UnquoteDef [DefInfo]
i [QName]
xs Expr
e) = do
    let unqual :: QName -> m Name
unqual (C.QName Name
x) = Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
        unqual QName
_           = m Name
forall a. HasCallStack => a
__IMPOSSIBLE__
    xs <- (QName -> m Name) -> [QName] -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (QName -> m Name
forall {m :: * -> *}. Monad m => QName -> m Name
unqual (QName -> m Name) -> (QName -> m QName) -> QName -> m Name
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< QName -> m QName
QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete) [QName]
xs
    (:[]) . C.UnquoteDef (getRange i) xs <$> toConcrete e

  toConcrete (A.UnquoteData [DefInfo]
i QName
xs UniverseCheck
uc [DefInfo]
j [QName]
cs Expr
e) = m [Declaration]
m (ConOfAbs Declaration)
forall a. HasCallStack => a
__IMPOSSIBLE__
  toConcrete (A.UnfoldingDecl Range
r [QName]
ns) = [Declaration] -> m [Declaration]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

data RangeAndPragma = RangeAndPragma Range A.Pragma

instance ToConcrete RangeAndPragma where
  type ConOfAbs RangeAndPragma = C.Pragma

  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
RangeAndPragma -> m (ConOfAbs RangeAndPragma)
toConcrete (RangeAndPragma Range
r Pragma
p) = case Pragma
p of
    A.OptionsPragma [ArgName]
xs  -> Pragma -> m Pragma
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> m Pragma) -> Pragma -> m Pragma
forall a b. (a -> b) -> a -> b
$ Range -> [ArgName] -> Pragma
C.OptionsPragma Range
r [ArgName]
xs
    A.BuiltinPragma Ranged ArgName
b ResolvedName
x       -> Range -> Ranged ArgName -> QName -> Pragma
C.BuiltinPragma Range
r Ranged ArgName
b (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvedName -> m (ConOfAbs ResolvedName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
ResolvedName -> m (ConOfAbs ResolvedName)
toConcrete ResolvedName
x
    A.BuiltinNoDefPragma Ranged ArgName
b KindOfName
_kind QName
x -> Range -> Ranged ArgName -> QName -> Pragma
C.BuiltinPragma Range
r Ranged ArgName
b (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    A.RewritePragma Range
r' [QName]
x      -> Range -> Range -> [QName] -> Pragma
C.RewritePragma Range
r Range
r' ([QName] -> Pragma) -> m [QName] -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QName] -> m (ConOfAbs [QName])
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
[QName] -> m (ConOfAbs [QName])
toConcrete [QName]
x
    A.CompilePragma Ranged BackendName
b QName
x ArgName
s -> do
      x <- QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
      return $ C.CompilePragma r b x s
    A.StaticPragma QName
x -> Range -> QName -> Pragma
C.StaticPragma Range
r (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    A.InjectivePragma QName
x -> Range -> QName -> Pragma
C.InjectivePragma Range
r (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    A.InjectiveForInferencePragma QName
x -> Range -> QName -> Pragma
C.InjectiveForInferencePragma Range
r (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    A.InlinePragma Bool
b QName
x -> Range -> Bool -> QName -> Pragma
C.InlinePragma Range
r Bool
b (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    A.NotProjectionLikePragma QName
q -> Range -> QName -> Pragma
C.NotProjectionLikePragma Range
r (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
q
    A.OverlapPragma QName
q OverlapMode
i -> Range -> [QName] -> OverlapMode -> Pragma
C.OverlapPragma Range
r ([QName] -> OverlapMode -> Pragma)
-> m [QName] -> m (OverlapMode -> Pragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((QName -> [QName]) -> m QName -> m [QName]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QName -> [QName]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
q)) m (OverlapMode -> Pragma) -> m OverlapMode -> m Pragma
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OverlapMode -> m OverlapMode
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
i
    A.EtaPragma QName
x    -> Range -> QName -> Pragma
C.EtaPragma    Range
r (QName -> Pragma) -> m QName -> m Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    A.DisplayPragma QName
f [NamedArg Pattern]
ps Expr
rhs ->
      Range -> Pattern -> Expr -> Pragma
C.DisplayPragma Range
r (Pattern -> Expr -> Pragma) -> m Pattern -> m (Expr -> Pragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> m (ConOfAbs Pattern)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (ConOfAbs Pattern)
toConcrete (PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP (Range -> PatInfo
PatRange Range
forall a. Range' a
noRange) (QName -> AmbiguousQName
unambiguous QName
f) [NamedArg Pattern]
ps) m (Expr -> Pragma) -> m Expr -> m Pragma
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete Expr
rhs

-- Left hand sides --------------------------------------------------------

instance ToConcrete A.SpineLHS where
  type ConOfAbs A.SpineLHS = C.LHS

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
SpineLHS -> (ConOfAbs SpineLHS -> m b) -> m b
bindToConcrete SpineLHS
lhs = LHS -> (ConOfAbs LHS -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
LHS -> (ConOfAbs LHS -> m b) -> m b
bindToConcrete (SpineLHS -> LHS
forall a b. LHSToSpine a b => b -> a
A.spineToLhs SpineLHS
lhs :: A.LHS)

instance ToConcrete A.LHS where
    type ConOfAbs A.LHS = C.LHS

    bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
LHS -> (ConOfAbs LHS -> m b) -> m b
bindToConcrete (A.LHS LHSInfo
i LHSCore
lhscore) ConOfAbs LHS -> m b
ret = do
      Precedence -> LHSCore -> (ConOfAbs LHSCore -> m b) -> m b
forall (m :: * -> *) a b.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> (ConOfAbs a -> m b) -> m b
bindToConcreteCtx Precedence
TopCtx LHSCore
lhscore ((ConOfAbs LHSCore -> m b) -> m b)
-> (ConOfAbs LHSCore -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs LHSCore
lhs ->
          ConOfAbs LHS -> m b
ret (ConOfAbs LHS -> m b) -> ConOfAbs LHS -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS (ExpandedEllipsis -> Pattern -> Pattern
reintroduceEllipsis (LHSInfo -> ExpandedEllipsis
lhsEllipsis LHSInfo
i) Pattern
ConOfAbs LHSCore
lhs) [] []

instance ToConcrete A.LHSCore where
  type ConOfAbs A.LHSCore = C.Pattern
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
LHSCore -> (ConOfAbs LHSCore -> m b) -> m b
bindToConcrete = Pattern -> (Pattern -> m b) -> m b
Pattern -> (ConOfAbs Pattern -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Pattern -> (ConOfAbs Pattern -> m b) -> m b
bindToConcrete (Pattern -> (Pattern -> m b) -> m b)
-> (LHSCore -> Pattern) -> LHSCore -> (Pattern -> m b) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHSCore -> Pattern
lhsCoreToPattern

appBracketsArgs :: [arg] -> PrecedenceStack -> Bool
appBracketsArgs :: forall arg. [arg] -> PrecedenceStack -> Bool
appBracketsArgs []    PrecedenceStack
_   = Bool
False
appBracketsArgs (arg
_:[arg]
_) PrecedenceStack
ctx = PrecedenceStack -> Bool
appBrackets PrecedenceStack
ctx

-- Auxiliary wrappers for processing the bindings in patterns in the right order.
newtype UserPattern a  = UserPattern a
newtype SplitPattern a = SplitPattern a
newtype BindingPattern = BindingPat A.Pattern
newtype FreshenName = FreshenName BindName

instance ToConcrete FreshenName where
  type ConOfAbs FreshenName = A.Name
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
FreshenName -> (ConOfAbs FreshenName -> m b) -> m b
bindToConcrete (FreshenName BindName{ unBind :: BindName -> Name
unBind = Name
x }) ConOfAbs FreshenName -> m b
ret = Name -> (ConOfAbs Name -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Name -> (ConOfAbs Name -> m b) -> m b
bindToConcrete Name
x ((ConOfAbs Name -> m b) -> m b) -> (ConOfAbs Name -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs Name
y -> ConOfAbs FreshenName -> m b
ret Name
x { nameConcrete = y }

-- Pass 1: (Issue #2729)
-- Takes care of binding the originally user-written pattern variables, but doesn't actually
-- translate anything to Concrete.
instance ToConcrete (UserPattern A.Pattern) where
  type ConOfAbs (UserPattern A.Pattern) = A.Pattern

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
bindToConcrete (UserPattern Pattern
p) ConOfAbs (UserPattern Pattern) -> m b
ret = do
    ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"toConcrete.pat" VerboseLevel
100 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"binding pattern (pass 1)" ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Pattern -> ArgName
forall a. Show a => a -> ArgName
show Pattern
p
    case Pattern
p of
      A.VarP BindName
bx -> do
        let x :: Name
x = BindName -> Name
unBind BindName
bx
        case Name -> NameInScope
forall a. LensInScope a => a -> NameInScope
isInScope Name
x of
          NameInScope
InScope            -> Name -> m b -> m b
forall (m :: * -> *) a. MonadToConcrete m => Name -> m a -> m a
bindName' Name
x (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ ConOfAbs (UserPattern Pattern) -> m b
ret (ConOfAbs (UserPattern Pattern) -> m b)
-> ConOfAbs (UserPattern Pattern) -> m b
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP BindName
bx
          NameInScope
C.NotInScope       -> Name -> (Name -> m b) -> m b
forall (m :: * -> *) a.
MonadToConcrete m =>
Name -> (Name -> m a) -> m a
bindName Name
x ((Name -> m b) -> m b) -> (Name -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \Name
y ->
                                ConOfAbs (UserPattern Pattern) -> m b
ret (ConOfAbs (UserPattern Pattern) -> m b)
-> ConOfAbs (UserPattern Pattern) -> m b
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern) -> BindName -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> BindName
mkBindName (Name -> BindName) -> Name -> BindName
forall a b. (a -> b) -> a -> b
$ Name
x { nameConcrete = y }
      A.WildP{}              -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.ProjP{}              -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.AbsurdP{}            -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.LitP{}               -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.DotP{}               -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.EqualP{}             -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      -- Andreas, 2017-09-03, issue #2729:
      -- Do not go into patterns generated by case-split here!
      -- They are treated in a second pass.
      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args
        | ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
        | Bool
otherwise          -> [UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> UserPattern (NamedArg Pattern))
-> [NamedArg Pattern] -> [UserPattern (NamedArg Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> UserPattern (NamedArg Pattern)
forall a. a -> UserPattern a
UserPattern [NamedArg Pattern]
args) ((ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b)
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (UserPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c
      A.DefP PatInfo
i AmbiguousQName
f [NamedArg Pattern]
args        -> [UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> UserPattern (NamedArg Pattern))
-> [NamedArg Pattern] -> [UserPattern (NamedArg Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> UserPattern (NamedArg Pattern)
forall a. a -> UserPattern a
UserPattern [NamedArg Pattern]
args) ((ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b)
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (UserPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
f
      A.PatternSynP PatInfo
i AmbiguousQName
f [NamedArg Pattern]
args -> [UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> UserPattern (NamedArg Pattern))
-> [NamedArg Pattern] -> [UserPattern (NamedArg Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> UserPattern (NamedArg Pattern)
forall a. a -> UserPattern a
UserPattern [NamedArg Pattern]
args) ((ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b)
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (UserPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
f
      A.RecP ConPatInfo
i [FieldAssignment' Pattern]
args
        | ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit -> ConOfAbs (UserPattern Pattern) -> m b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
        | Bool
otherwise          -> [FieldAssignment' (UserPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (UserPattern Pattern)] -> m b)
-> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[FieldAssignment' (UserPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (UserPattern Pattern)] -> m b)
-> m b
bindToConcrete (((FieldAssignment' Pattern
 -> FieldAssignment' (UserPattern Pattern))
-> [FieldAssignment' Pattern]
-> [FieldAssignment' (UserPattern Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldAssignment' Pattern
  -> FieldAssignment' (UserPattern Pattern))
 -> [FieldAssignment' Pattern]
 -> [FieldAssignment' (UserPattern Pattern)])
-> ((Pattern -> UserPattern Pattern)
    -> FieldAssignment' Pattern
    -> FieldAssignment' (UserPattern Pattern))
-> (Pattern -> UserPattern Pattern)
-> [FieldAssignment' Pattern]
-> [FieldAssignment' (UserPattern Pattern)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> UserPattern Pattern)
-> FieldAssignment' Pattern
-> FieldAssignment' (UserPattern Pattern)
forall a b. (a -> b) -> FieldAssignment' a -> FieldAssignment' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern [FieldAssignment' Pattern]
args) ((ConOfAbs [FieldAssignment' (UserPattern Pattern)] -> m b) -> m b)
-> (ConOfAbs [FieldAssignment' (UserPattern Pattern)] -> m b)
-> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (UserPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> Name -> m b -> m b
forall (m :: * -> *) a. MonadToConcrete m => Name -> m a -> m a
bindName' (BindName -> Name
unBind BindName
x) (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$
                                UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((ConOfAbs (UserPattern Pattern) -> m b) -> m b)
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (UserPattern Pattern)
p ->
                                ConOfAbs (UserPattern Pattern) -> m b
ret (PatInfo -> BindName -> Pattern -> Pattern
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i BindName
x Pattern
ConOfAbs (UserPattern Pattern)
p)
      A.WithP PatInfo
i Pattern
p            -> UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((ConOfAbs (UserPattern Pattern) -> m b) -> m b)
-> (ConOfAbs (UserPattern Pattern) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (UserPattern Pattern) -> m b
ret (Pattern -> m b) -> (Pattern -> Pattern) -> Pattern -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> Pattern -> Pattern
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP PatInfo
i

instance ToConcrete (UserPattern (NamedArg A.Pattern)) where
  type ConOfAbs (UserPattern (NamedArg A.Pattern)) = NamedArg A.Pattern

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
UserPattern (NamedArg Pattern)
-> (ConOfAbs (UserPattern (NamedArg Pattern)) -> m b) -> m b
bindToConcrete (UserPattern NamedArg Pattern
np) ConOfAbs (UserPattern (NamedArg Pattern)) -> m b
ret =
    case NamedArg Pattern -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
np of
      Origin
CaseSplit -> ConOfAbs (UserPattern (NamedArg Pattern)) -> m b
ret NamedArg Pattern
ConOfAbs (UserPattern (NamedArg Pattern))
np
      Origin
_         -> Arg (Named NamedName (UserPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (UserPattern Pattern))) -> m b)
-> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Arg (Named NamedName (UserPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (UserPattern Pattern))) -> m b)
-> m b
bindToConcrete ((Named NamedName Pattern -> Named NamedName (UserPattern Pattern))
-> NamedArg Pattern -> Arg (Named NamedName (UserPattern Pattern))
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pattern -> UserPattern Pattern)
-> Named NamedName Pattern -> Named NamedName (UserPattern 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 Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern) NamedArg Pattern
np) ConOfAbs (Arg (Named NamedName (UserPattern Pattern))) -> m b
ConOfAbs (UserPattern (NamedArg Pattern)) -> m b
ret

-- Pass 2a: locate case-split pattern.  Don't bind anything!
instance ToConcrete (SplitPattern A.Pattern) where
  type ConOfAbs (SplitPattern A.Pattern) = A.Pattern

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
bindToConcrete (SplitPattern Pattern
p) ConOfAbs (SplitPattern Pattern) -> m b
ret = do
    ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"toConcrete.pat" VerboseLevel
100 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"binding pattern (pass 2a)" ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Pattern -> ArgName
forall a. Show a => a -> ArgName
show Pattern
p
    case Pattern
p of
      A.VarP BindName
x               -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.WildP{}              -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.ProjP{}              -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.AbsurdP{}            -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.LitP{}               -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.DotP{}               -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.EqualP{}             -> ConOfAbs (SplitPattern Pattern) -> m b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      -- Andreas, 2017-09-03, issue #2729:
      -- For patterns generated by case-split here, switch to freshening & binding.
      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args
        | ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit
                             -> [Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
bindToConcrete (((NamedArg Pattern -> Arg (Named NamedName BindingPattern))
-> [NamedArg Pattern] -> [Arg (Named NamedName BindingPattern)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArg Pattern -> Arg (Named NamedName BindingPattern))
 -> [NamedArg Pattern] -> [Arg (Named NamedName BindingPattern)])
-> ((Pattern -> BindingPattern)
    -> NamedArg Pattern -> Arg (Named NamedName BindingPattern))
-> (Pattern -> BindingPattern)
-> [NamedArg Pattern]
-> [Arg (Named NamedName BindingPattern)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Pattern -> Named NamedName BindingPattern)
-> NamedArg Pattern -> Arg (Named NamedName BindingPattern)
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 BindingPattern)
 -> NamedArg Pattern -> Arg (Named NamedName BindingPattern))
-> ((Pattern -> BindingPattern)
    -> Named NamedName Pattern -> Named NamedName BindingPattern)
-> (Pattern -> BindingPattern)
-> NamedArg Pattern
-> Arg (Named NamedName BindingPattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> BindingPattern)
-> Named NamedName Pattern -> Named NamedName BindingPattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Pattern -> BindingPattern
BindingPat [NamedArg Pattern]
args) ((ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c
        | Bool
otherwise          -> [SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> SplitPattern (NamedArg Pattern))
-> [NamedArg Pattern] -> [SplitPattern (NamedArg Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> SplitPattern (NamedArg Pattern)
forall a. a -> SplitPattern a
SplitPattern [NamedArg Pattern]
args) ((ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b)
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c
      A.DefP PatInfo
i AmbiguousQName
f [NamedArg Pattern]
args        -> [SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> SplitPattern (NamedArg Pattern))
-> [NamedArg Pattern] -> [SplitPattern (NamedArg Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> SplitPattern (NamedArg Pattern)
forall a. a -> SplitPattern a
SplitPattern [NamedArg Pattern]
args) ((ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b)
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
f
      A.PatternSynP PatInfo
i AmbiguousQName
f [NamedArg Pattern]
args -> [SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> SplitPattern (NamedArg Pattern))
-> [NamedArg Pattern] -> [SplitPattern (NamedArg Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> SplitPattern (NamedArg Pattern)
forall a. a -> SplitPattern a
SplitPattern [NamedArg Pattern]
args) ((ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b)
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
f
      A.RecP ConPatInfo
i [FieldAssignment' Pattern]
args
        | ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit
                             -> [FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b
bindToConcrete (((FieldAssignment' Pattern -> FieldAssignment' BindingPattern)
-> [FieldAssignment' Pattern] -> [FieldAssignment' BindingPattern]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldAssignment' Pattern -> FieldAssignment' BindingPattern)
 -> [FieldAssignment' Pattern] -> [FieldAssignment' BindingPattern])
-> ((Pattern -> BindingPattern)
    -> FieldAssignment' Pattern -> FieldAssignment' BindingPattern)
-> (Pattern -> BindingPattern)
-> [FieldAssignment' Pattern]
-> [FieldAssignment' BindingPattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> BindingPattern)
-> FieldAssignment' Pattern -> FieldAssignment' BindingPattern
forall a b. (a -> b) -> FieldAssignment' a -> FieldAssignment' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Pattern -> BindingPattern
BindingPat [FieldAssignment' Pattern]
args) ((ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b)
-> (ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
        | Bool
otherwise          -> [FieldAssignment' (SplitPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)] -> m b)
-> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[FieldAssignment' (SplitPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)] -> m b)
-> m b
bindToConcrete (((FieldAssignment' Pattern
 -> FieldAssignment' (SplitPattern Pattern))
-> [FieldAssignment' Pattern]
-> [FieldAssignment' (SplitPattern Pattern)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldAssignment' Pattern
  -> FieldAssignment' (SplitPattern Pattern))
 -> [FieldAssignment' Pattern]
 -> [FieldAssignment' (SplitPattern Pattern)])
-> ((Pattern -> SplitPattern Pattern)
    -> FieldAssignment' Pattern
    -> FieldAssignment' (SplitPattern Pattern))
-> (Pattern -> SplitPattern Pattern)
-> [FieldAssignment' Pattern]
-> [FieldAssignment' (SplitPattern Pattern)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> SplitPattern Pattern)
-> FieldAssignment' Pattern
-> FieldAssignment' (SplitPattern Pattern)
forall a b. (a -> b) -> FieldAssignment' a -> FieldAssignment' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern [FieldAssignment' Pattern]
args) ((ConOfAbs [FieldAssignment' (SplitPattern Pattern)] -> m b)
 -> m b)
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)] -> m b)
-> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
p)  ((ConOfAbs (SplitPattern Pattern) -> m b) -> m b)
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (SplitPattern Pattern)
p ->
                                ConOfAbs (SplitPattern Pattern) -> m b
ret (PatInfo -> BindName -> Pattern -> Pattern
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i BindName
x Pattern
ConOfAbs (SplitPattern Pattern)
p)
      A.WithP PatInfo
i Pattern
p            -> SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
p) ((ConOfAbs (SplitPattern Pattern) -> m b) -> m b)
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs (SplitPattern Pattern) -> m b
ret (Pattern -> m b) -> (Pattern -> Pattern) -> Pattern -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> Pattern -> Pattern
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP PatInfo
i

instance ToConcrete (SplitPattern (NamedArg A.Pattern)) where
  type ConOfAbs (SplitPattern (NamedArg A.Pattern)) = NamedArg A.Pattern
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
SplitPattern (NamedArg Pattern)
-> (ConOfAbs (SplitPattern (NamedArg Pattern)) -> m b) -> m b
bindToConcrete (SplitPattern NamedArg Pattern
np) ConOfAbs (SplitPattern (NamedArg Pattern)) -> m b
ret =
    case NamedArg Pattern -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
np of
      Origin
CaseSplit -> Arg (Named NamedName BindingPattern)
-> (ConOfAbs (Arg (Named NamedName BindingPattern)) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Arg (Named NamedName BindingPattern)
-> (ConOfAbs (Arg (Named NamedName BindingPattern)) -> m b) -> m b
bindToConcrete ((Named NamedName Pattern -> Named NamedName BindingPattern)
-> NamedArg Pattern -> Arg (Named NamedName BindingPattern)
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pattern -> BindingPattern)
-> Named NamedName Pattern -> Named NamedName BindingPattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> BindingPattern
BindingPat  ) NamedArg Pattern
np) ConOfAbs (Arg (Named NamedName BindingPattern)) -> m b
ConOfAbs (SplitPattern (NamedArg Pattern)) -> m b
ret
      Origin
_         -> Arg (Named NamedName (SplitPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (SplitPattern Pattern))) -> m b)
-> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
Arg (Named NamedName (SplitPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (SplitPattern Pattern))) -> m b)
-> m b
bindToConcrete ((Named NamedName Pattern -> Named NamedName (SplitPattern Pattern))
-> NamedArg Pattern -> Arg (Named NamedName (SplitPattern Pattern))
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pattern -> SplitPattern Pattern)
-> Named NamedName Pattern
-> Named NamedName (SplitPattern 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 Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern) NamedArg Pattern
np) ConOfAbs (Arg (Named NamedName (SplitPattern Pattern))) -> m b
ConOfAbs (SplitPattern (NamedArg Pattern)) -> m b
ret


-- Pass 2b:
-- Takes care of freshening and binding pattern variables introduced by case split.
-- Still does not translate anything to Concrete.
instance ToConcrete BindingPattern where
  type ConOfAbs BindingPattern = A.Pattern
  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
BindingPattern -> (ConOfAbs BindingPattern -> m b) -> m b
bindToConcrete (BindingPat Pattern
p) ConOfAbs BindingPattern -> m b
ret = do
    ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"toConcrete.pat" VerboseLevel
100 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"binding pattern (pass 2b)" ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Pattern -> ArgName
forall a. Show a => a -> ArgName
show Pattern
p
    case Pattern
p of
      A.VarP BindName
x               -> FreshenName -> (ConOfAbs FreshenName -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
FreshenName -> (ConOfAbs FreshenName -> m b) -> m b
bindToConcrete (BindName -> FreshenName
FreshenName BindName
x) ((ConOfAbs FreshenName -> m b) -> m b)
-> (ConOfAbs FreshenName -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs BindingPattern -> m b
ret (Pattern -> m b) -> (Name -> Pattern) -> Name -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern) -> (Name -> BindName) -> Name -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BindName
mkBindName
      A.WildP{}              -> ConOfAbs BindingPattern -> m b
ret Pattern
ConOfAbs BindingPattern
p
      A.ProjP{}              -> ConOfAbs BindingPattern -> m b
ret Pattern
ConOfAbs BindingPattern
p
      A.AbsurdP{}            -> ConOfAbs BindingPattern -> m b
ret Pattern
ConOfAbs BindingPattern
p
      A.LitP{}               -> ConOfAbs BindingPattern -> m b
ret Pattern
ConOfAbs BindingPattern
p
      A.DotP{}               -> ConOfAbs BindingPattern -> m b
ret Pattern
ConOfAbs BindingPattern
p
      A.EqualP{}             -> ConOfAbs BindingPattern -> m b
ret Pattern
ConOfAbs BindingPattern
p
      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args        -> [Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> Arg (Named NamedName BindingPattern))
-> [NamedArg Pattern] -> [Arg (Named NamedName BindingPattern)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pattern -> BindingPattern)
-> NamedArg Pattern -> Arg (Named NamedName BindingPattern)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg Pattern -> BindingPattern
BindingPat) [NamedArg Pattern]
args) ((ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs BindingPattern -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c
      A.DefP PatInfo
i AmbiguousQName
f [NamedArg Pattern]
args        -> [Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> Arg (Named NamedName BindingPattern))
-> [NamedArg Pattern] -> [Arg (Named NamedName BindingPattern)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pattern -> BindingPattern)
-> NamedArg Pattern -> Arg (Named NamedName BindingPattern)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg Pattern -> BindingPattern
BindingPat) [NamedArg Pattern]
args) ((ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs BindingPattern -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
f
      A.PatternSynP PatInfo
i AmbiguousQName
f [NamedArg Pattern]
args -> [Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
bindToConcrete ((NamedArg Pattern -> Arg (Named NamedName BindingPattern))
-> [NamedArg Pattern] -> [Arg (Named NamedName BindingPattern)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pattern -> BindingPattern)
-> NamedArg Pattern -> Arg (Named NamedName BindingPattern)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg Pattern -> BindingPattern
BindingPat) [NamedArg Pattern]
args) ((ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs BindingPattern -> m b
ret (Pattern -> m b)
-> ([NamedArg Pattern] -> Pattern) -> [NamedArg Pattern] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
f
      A.RecP ConPatInfo
i [FieldAssignment' Pattern]
args          -> [FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
[FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b
bindToConcrete (((FieldAssignment' Pattern -> FieldAssignment' BindingPattern)
-> [FieldAssignment' Pattern] -> [FieldAssignment' BindingPattern]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldAssignment' Pattern -> FieldAssignment' BindingPattern)
 -> [FieldAssignment' Pattern] -> [FieldAssignment' BindingPattern])
-> ((Pattern -> BindingPattern)
    -> FieldAssignment' Pattern -> FieldAssignment' BindingPattern)
-> (Pattern -> BindingPattern)
-> [FieldAssignment' Pattern]
-> [FieldAssignment' BindingPattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> BindingPattern)
-> FieldAssignment' Pattern -> FieldAssignment' BindingPattern
forall a b. (a -> b) -> FieldAssignment' a -> FieldAssignment' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)        Pattern -> BindingPattern
BindingPat [FieldAssignment' Pattern]
args) ((ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b)
-> (ConOfAbs [FieldAssignment' BindingPattern] -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs BindingPattern -> m b
ret (Pattern -> m b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> FreshenName -> (ConOfAbs FreshenName -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
FreshenName -> (ConOfAbs FreshenName -> m b) -> m b
bindToConcrete (BindName -> FreshenName
FreshenName BindName
x) ((ConOfAbs FreshenName -> m b) -> m b)
-> (ConOfAbs FreshenName -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs FreshenName
x ->
                                BindingPattern -> (ConOfAbs BindingPattern -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
BindingPattern -> (ConOfAbs BindingPattern -> m b) -> m b
bindToConcrete (Pattern -> BindingPattern
BindingPat Pattern
p)  ((ConOfAbs BindingPattern -> m b) -> m b)
-> (ConOfAbs BindingPattern -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs BindingPattern
p ->
                                ConOfAbs BindingPattern -> m b
ret (PatInfo -> BindName -> Pattern -> Pattern
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i (Name -> BindName
mkBindName Name
ConOfAbs FreshenName
x) Pattern
ConOfAbs BindingPattern
p)
      A.WithP PatInfo
i Pattern
p            -> BindingPattern -> (ConOfAbs BindingPattern -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
BindingPattern -> (ConOfAbs BindingPattern -> m b) -> m b
bindToConcrete (Pattern -> BindingPattern
BindingPat Pattern
p) ((ConOfAbs BindingPattern -> m b) -> m b)
-> (ConOfAbs BindingPattern -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ Pattern -> m b
ConOfAbs BindingPattern -> m b
ret (Pattern -> m b) -> (Pattern -> Pattern) -> Pattern -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> Pattern -> Pattern
forall e. PatInfo -> Pattern' e -> Pattern' e
A.WithP PatInfo
i

instance ToConcrete A.Pattern where
  type ConOfAbs A.Pattern = C.Pattern

  bindToConcrete :: forall (m :: * -> *) b.
MonadToConcrete m =>
Pattern -> (ConOfAbs Pattern -> m b) -> m b
bindToConcrete Pattern
p ConOfAbs Pattern -> m b
ret = do
    prec <- m PrecedenceStack
forall (m :: * -> *). MonadToConcrete m => m PrecedenceStack
currentPrecedence
    bindToConcrete (UserPattern p) $ \ ConOfAbs (UserPattern Pattern)
p -> do
      SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
forall a (m :: * -> *) b.
(ToConcrete a, MonadToConcrete m) =>
a -> (ConOfAbs a -> m b) -> m b
forall (m :: * -> *) b.
MonadToConcrete m =>
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
ConOfAbs (UserPattern Pattern)
p) ((ConOfAbs (SplitPattern Pattern) -> m b) -> m b)
-> (ConOfAbs (SplitPattern Pattern) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (SplitPattern Pattern)
p -> do
        Pattern -> m b
ConOfAbs Pattern -> m b
ret (Pattern -> m b) -> m Pattern -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do PrecedenceStack -> m Pattern -> m Pattern
forall (m :: * -> *) a.
MonadToConcrete m =>
PrecedenceStack -> m a -> m a
withPrecedence' PrecedenceStack
prec (m Pattern -> m Pattern) -> m Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> m (ConOfAbs Pattern)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (ConOfAbs Pattern)
toConcrete Pattern
ConOfAbs (SplitPattern Pattern)
p
  toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (ConOfAbs Pattern)
toConcrete Pattern
p =
    case Pattern
p of
      A.VarP BindName
x ->
        Bool -> QName -> Pattern
C.IdentP Bool
True (QName -> Pattern) -> (BoundName -> QName) -> BoundName -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName (Name -> QName) -> (BoundName -> Name) -> BoundName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundName -> Name
C.boundName (BoundName -> Pattern) -> m BoundName -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BindName -> m (ConOfAbs BindName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
BindName -> m (ConOfAbs BindName)
toConcrete BindName
x

      A.WildP PatInfo
i ->
        Pattern -> m Pattern
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Pattern
C.WildP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i)

      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args  -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
tryOp (AmbiguousQName -> QName
headAmbQ AmbiguousQName
c) (ConPatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c) [NamedArg Pattern]
args

      A.ProjP PatInfo
i ProjOrigin
ProjPrefix AmbiguousQName
p -> Bool -> QName -> Pattern
C.IdentP Bool
True (QName -> Pattern) -> m QName -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
      A.ProjP PatInfo
i ProjOrigin
_          AmbiguousQName
p -> KwRange -> Range -> Expr -> Pattern
C.DotP KwRange
forall a. Null a => a
empty Range
forall a. Range' a
noRange (Expr -> Pattern) -> (QName -> Expr) -> QName -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Expr
C.Ident (QName -> Pattern) -> m QName -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)

      A.DefP PatInfo
i AmbiguousQName
x [NamedArg Pattern]
args -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
tryOp (AmbiguousQName -> QName
headAmbQ AmbiguousQName
x) (PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
x)  [NamedArg Pattern]
args

      A.AsP PatInfo
i BindName
x Pattern
p -> do
        (x, p) <- Precedence
-> (BindName, Pattern) -> m (ConOfAbs (BindName, Pattern))
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ (BindName
x, Pattern
p)
        return $ C.AsP (getRange i) (C.boundName x) p

      A.AbsurdP PatInfo
i ->
        Pattern -> m Pattern
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Pattern
C.AbsurdP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i)

      A.LitP PatInfo
i (LitQName QName
x) -> do
        x <- AllowAmbiguousNames -> QName -> m QName
forall (m :: * -> *).
MonadToConcrete m =>
AllowAmbiguousNames -> QName -> m QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
        bracketP_ appBrackets $ return $
          C.AppP (C.QuoteP (getRange i))
            (defaultNamedArg (C.IdentP True x))
      A.LitP PatInfo
i Literal
l ->
        Pattern -> m Pattern
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Literal -> Pattern
C.LitP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i) Literal
l

      -- Andreas, 2018-06-19, issue #3130
      -- Print .p as .(p) if p is a projection
      -- to avoid confusion with projection pattern.
      A.DotP PatInfo
i e :: Expr
e@A.Proj{} -> KwRange -> Range -> Expr -> Pattern
C.DotP KwRange
forall a. Null a => a
empty Range
r (Expr -> Pattern) -> (Expr -> Expr) -> Expr -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Expr -> Expr
C.Paren Range
r (Expr -> Pattern) -> m Expr -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
TopCtx Expr
e
        where r :: Range
r = PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i

      -- gallais, 2019-02-12, issue #3491
      -- Print p as .(p) if p is a variable but there is a projection of the
      -- same name in scope.
      A.DotP PatInfo
i e :: Expr
e@(A.Var Name
v) -> do
        let r :: Range
r = PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i
        -- Erase @v@ to a concrete name and resolve it back to check whether
        -- we have a conflicting field name.
        cn <- Name -> m Name
forall (m :: * -> *). MonadToConcrete m => Name -> m Name
toConcreteName Name
v
        resolveName (someKindsOfNames [FldName]) Nothing (C.QName cn) >>= \ case
          -- If we do then we print .(v) rather than .v
          Right FieldName{} -> do
            ArgName -> VerboseLevel -> ArgName -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> VerboseLevel -> ArgName -> m ()
reportSLn ArgName
"print.dotted" VerboseLevel
50 (ArgName -> m ()) -> ArgName -> m ()
forall a b. (a -> b) -> a -> b
$ ArgName
"Wrapping ambiguous name " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ Name -> ArgName
forall a. Pretty a => a -> ArgName
prettyShow (Name -> Name
nameConcrete Name
v)
            KwRange -> Range -> Expr -> Pattern
C.DotP KwRange
forall a. Null a => a
empty Range
r (Expr -> Pattern) -> (Expr -> Expr) -> Expr -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Expr -> Expr
C.Paren Range
r (Expr -> Pattern) -> m Expr -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Expr -> m (ConOfAbs Expr)
toConcrete (Name -> Expr
A.Var Name
v)
          Right ResolvedName
_ -> PatInfo -> Expr -> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
PatInfo -> Expr -> m Pattern
printDotDefault PatInfo
i Expr
e
          Left NameResolutionError
_ -> m Pattern
forall a. HasCallStack => a
__IMPOSSIBLE__

      A.DotP PatInfo
i Expr
e -> PatInfo -> Expr -> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
PatInfo -> Expr -> m Pattern
printDotDefault PatInfo
i Expr
e

      A.EqualP PatInfo
i List1 (Expr, Expr)
es -> do
        Range -> List1 (Expr, Expr) -> Pattern
C.EqualP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i) (List1 (Expr, Expr) -> Pattern)
-> m (List1 (Expr, Expr)) -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 (Expr, Expr) -> m (ConOfAbs (List1 (Expr, Expr)))
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
List1 (Expr, Expr) -> m (ConOfAbs (List1 (Expr, Expr)))
toConcrete List1 (Expr, Expr)
es

      A.PatternSynP PatInfo
i AmbiguousQName
n [NamedArg Pattern]
args -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
tryOp (AmbiguousQName -> QName
headAmbQ AmbiguousQName
n) (PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
n) [NamedArg Pattern]
args

      A.RecP ConPatInfo
i [FieldAssignment' Pattern]
as ->
        Range -> [FieldAssignment' Pattern] -> Pattern
C.RecP (ConPatInfo -> Range
forall a. HasRange a => a -> Range
getRange ConPatInfo
i) ([FieldAssignment' Pattern] -> Pattern)
-> m [FieldAssignment' Pattern] -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldAssignment' Pattern -> m (FieldAssignment' Pattern))
-> [FieldAssignment' Pattern] -> m [FieldAssignment' 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 ((Pattern -> m Pattern)
-> FieldAssignment' Pattern -> m (FieldAssignment' 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) -> FieldAssignment' a -> f (FieldAssignment' b)
traverse Pattern -> m Pattern
Pattern -> m (ConOfAbs Pattern)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (ConOfAbs Pattern)
toConcrete) [FieldAssignment' Pattern]
as

      A.WithP PatInfo
i Pattern
p -> Range -> Pattern -> Pattern
C.WithP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i) (Pattern -> Pattern) -> m Pattern -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Pattern -> m (ConOfAbs Pattern)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
WithArgCtx Pattern
p

    where

    printDotDefault :: MonadToConcrete m => PatInfo -> A.Expr -> m C.Pattern
    printDotDefault :: forall (m :: * -> *).
MonadToConcrete m =>
PatInfo -> Expr -> m Pattern
printDotDefault PatInfo
i Expr
e = do
      c <- Precedence -> Expr -> m (ConOfAbs Expr)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
DotPatternCtx Expr
e
      let r = PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i
      case c of
        -- Andreas, 2016-02-04 print ._ pattern as _ pattern,
        -- following the fusing of WildP and ImplicitP.
        C.Underscore{} -> Pattern -> m Pattern
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Pattern
C.WildP Range
r
        Expr
_ -> Pattern -> m Pattern
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ KwRange -> Range -> Expr -> Pattern
C.DotP KwRange
forall a. Null a => a
empty Range
r Expr
c

    tryOp :: MonadToConcrete m => A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> m C.Pattern
    tryOp :: forall (m :: * -> *).
MonadToConcrete m =>
QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> m Pattern
tryOp QName
x [NamedArg Pattern] -> Pattern
f [NamedArg Pattern]
args = do
      -- Andreas, 2016-02-04, Issue #1792
      -- To prevent failing of tryToRecoverOpAppP for overapplied operators,
      -- we take off the exceeding arguments first
      -- and apply them pointwise with C.AppP later.
      let ([NamedArg Pattern]
args1, [NamedArg Pattern]
args2) = VerboseLevel
-> [NamedArg Pattern] -> ([NamedArg Pattern], [NamedArg Pattern])
forall a. VerboseLevel -> [a] -> ([a], [a])
splitAt (QName -> VerboseLevel
forall a. NumHoles a => a -> VerboseLevel
numHoles QName
x) [NamedArg Pattern]
args
      let funCtx :: m (Maybe Pattern) -> m (Maybe Pattern)
funCtx = Bool
-> (m (Maybe Pattern) -> m (Maybe Pattern))
-> m (Maybe Pattern)
-> m (Maybe Pattern)
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyUnless ([NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null [NamedArg Pattern]
args2) (Precedence -> m (Maybe Pattern) -> m (Maybe Pattern)
forall (m :: * -> *) a.
MonadToConcrete m =>
Precedence -> m a -> m a
withPrecedence Precedence
FunctionCtx)
      Pattern -> m Pattern -> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m Pattern -> m Pattern
tryToRecoverPatternSynP ([NamedArg Pattern] -> Pattern
f [NamedArg Pattern]
args) (m Pattern -> m Pattern) -> m Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ m (Maybe Pattern) -> m (Maybe Pattern)
funCtx (Pattern -> m (Maybe Pattern)
forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (Maybe Pattern)
tryToRecoverOpAppP (Pattern -> m (Maybe Pattern)) -> Pattern -> m (Maybe Pattern)
forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Pattern
f [NamedArg Pattern]
args1) m (Maybe Pattern) -> (Maybe Pattern -> m Pattern) -> m Pattern
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Pattern
c  -> [NamedArg Pattern] -> Pattern -> m Pattern
forall {arg} {m :: * -> *}.
(ConOfAbs arg ~ Arg (Named_ Pattern), MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc),
 MonadReader Env m, ToConcrete arg) =>
[arg] -> Pattern -> m Pattern
applyTo [NamedArg Pattern]
args2 Pattern
c
        Maybe Pattern
Nothing -> [NamedArg Pattern] -> Pattern -> m Pattern
forall {arg} {m :: * -> *}.
(ConOfAbs arg ~ Arg (Named_ Pattern), MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc),
 MonadReader Env m, ToConcrete arg) =>
[arg] -> Pattern -> m Pattern
applyTo [NamedArg Pattern]
args (Pattern -> m Pattern) -> (QName -> Pattern) -> QName -> m Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> QName -> Pattern
C.IdentP Bool
True (QName -> m Pattern) -> m QName -> m Pattern
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete QName
x
    -- Note: applyTo [] c = return c
    applyTo :: [arg] -> Pattern -> m Pattern
applyTo [arg]
args Pattern
c = (PrecedenceStack -> Bool) -> m Pattern -> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Pattern -> m Pattern
bracketP_ ([arg] -> PrecedenceStack -> Bool
forall arg. [arg] -> PrecedenceStack -> Bool
appBracketsArgs [arg]
args) (m Pattern -> m Pattern) -> m Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ do
      (Pattern -> Arg (Named_ Pattern) -> Pattern)
-> Pattern -> [Arg (Named_ 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 -> Arg (Named_ Pattern) -> Pattern
C.AppP Pattern
c ([Arg (Named_ Pattern)] -> Pattern)
-> m [Arg (Named_ Pattern)] -> m Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ((Arg (Named_ Pattern) -> m (Arg (Named_ Pattern)))
-> [Arg (Named_ Pattern)] -> m [Arg (Named_ 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_ Pattern) -> m (Arg (Named_ Pattern))
forall (m :: * -> *).
MonadToConcrete m =>
Arg (Named_ Pattern) -> m (Arg (Named_ Pattern))
avoidPun ([Arg (Named_ Pattern)] -> m [Arg (Named_ Pattern)])
-> m [Arg (Named_ Pattern)] -> m [Arg (Named_ Pattern)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Precedence -> [arg] -> m (ConOfAbs [arg])
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ [arg]
args)

    -- If --hidden-argument-puns is active, then {x} is replaced by
    -- {(x)} and ⦃ x ⦄ by ⦃ (x) ⦄.
    avoidPun :: MonadToConcrete m => NamedArg C.Pattern -> m (NamedArg C.Pattern)
    avoidPun :: forall (m :: * -> *).
MonadToConcrete m =>
Arg (Named_ Pattern) -> m (Arg (Named_ Pattern))
avoidPun Arg (Named_ Pattern)
arg =
      m Bool
-> m (Arg (Named_ Pattern))
-> m (Arg (Named_ Pattern))
-> m (Arg (Named_ Pattern))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions)
          (Arg (Named_ Pattern) -> m (Arg (Named_ Pattern))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg (Named_ Pattern) -> m (Arg (Named_ Pattern)))
-> Arg (Named_ Pattern) -> m (Arg (Named_ Pattern))
forall a b. (a -> b) -> a -> b
$ case Arg (Named_ Pattern)
arg of
             Arg ArgInfo
i (Named Maybe NamedName
Nothing x :: Pattern
x@C.IdentP{}) | ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
notVisible ArgInfo
i ->
               ArgInfo -> Named_ Pattern -> Arg (Named_ Pattern)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (Maybe NamedName -> Pattern -> Named_ Pattern
forall name a. Maybe name -> a -> Named name a
Named Maybe NamedName
forall a. Maybe a
Nothing (Range -> Pattern -> Pattern
C.ParenP Range
forall a. Range' a
noRange Pattern
x))
             Arg (Named_ Pattern)
arg -> Arg (Named_ Pattern)
arg)
          (Arg (Named_ Pattern) -> m (Arg (Named_ Pattern))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Arg (Named_ Pattern)
arg)

-- Helpers for recovering natural number literals

tryToRecoverNatural :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr
tryToRecoverNatural :: forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverNatural Expr
e m Expr
def = do
  is <- m (QName -> BuiltinId -> Bool)
forall (m :: * -> *).
MonadToConcrete m =>
m (QName -> BuiltinId -> Bool)
isBuiltinFun
  caseMaybe (recoverNatural is e) def $ return . C.Lit noRange . LitNat

recoverNatural :: (A.QName -> BuiltinId -> Bool) -> A.Expr -> Maybe Integer
recoverNatural :: (QName -> BuiltinId -> Bool) -> Expr -> Maybe Integer
recoverNatural QName -> BuiltinId -> Bool
is Expr
e = (QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore (QName -> BuiltinId -> Bool
`is` BuiltinId
builtinZero) (QName -> BuiltinId -> Bool
`is` BuiltinId
builtinSuc) Integer
0 Expr
e
  where
    explore :: (A.QName -> Bool) -> (A.QName -> Bool) -> Integer -> A.Expr -> Maybe Integer
    explore :: (QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore QName -> Bool
isZero QName -> Bool
isSuc Integer
k (A.App AppInfo
_ (A.Con AmbiguousQName
c) NamedArg Expr
t) | Just QName
f <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c, QName -> Bool
isSuc QName
f
                                                = ((QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore QName -> Bool
isZero QName -> Bool
isSuc (Integer -> Expr -> Maybe Integer)
-> Integer -> Expr -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
t)
    explore QName -> Bool
isZero QName -> Bool
isSuc Integer
k (A.Con AmbiguousQName
c) | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c, QName -> Bool
isZero QName
x = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
k
    explore QName -> Bool
isZero QName -> Bool
isSuc Integer
k (A.Lit ExprInfo
_ (LitNat Integer
l)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
l)
    explore QName -> Bool
_ QName -> Bool
_ Integer
_ Expr
_                             = Maybe Integer
forall a. Maybe a
Nothing

-- Helpers for recovering C.OpApp ------------------------------------------

data Hd = HdVar A.Name | HdCon A.QName | HdDef A.QName | HdSyn A.QName

data MaybeSection a
  = YesSection
  | NoSection a
  deriving (MaybeSection a -> MaybeSection a -> Bool
(MaybeSection a -> MaybeSection a -> Bool)
-> (MaybeSection a -> MaybeSection a -> Bool)
-> Eq (MaybeSection a)
forall a. Eq a => MaybeSection a -> MaybeSection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => MaybeSection a -> MaybeSection a -> Bool
== :: MaybeSection a -> MaybeSection a -> Bool
$c/= :: forall a. Eq a => MaybeSection a -> MaybeSection a -> Bool
/= :: MaybeSection a -> MaybeSection a -> Bool
Eq, VerboseLevel -> MaybeSection a -> ArgName -> ArgName
[MaybeSection a] -> ArgName -> ArgName
MaybeSection a -> ArgName
(VerboseLevel -> MaybeSection a -> ArgName -> ArgName)
-> (MaybeSection a -> ArgName)
-> ([MaybeSection a] -> ArgName -> ArgName)
-> Show (MaybeSection a)
forall a.
Show a =>
VerboseLevel -> MaybeSection a -> ArgName -> ArgName
forall a. Show a => [MaybeSection a] -> ArgName -> ArgName
forall a. Show a => MaybeSection a -> ArgName
forall a.
(VerboseLevel -> a -> ArgName -> ArgName)
-> (a -> ArgName) -> ([a] -> ArgName -> ArgName) -> Show a
$cshowsPrec :: forall a.
Show a =>
VerboseLevel -> MaybeSection a -> ArgName -> ArgName
showsPrec :: VerboseLevel -> MaybeSection a -> ArgName -> ArgName
$cshow :: forall a. Show a => MaybeSection a -> ArgName
show :: MaybeSection a -> ArgName
$cshowList :: forall a. Show a => [MaybeSection a] -> ArgName -> ArgName
showList :: [MaybeSection a] -> ArgName -> ArgName
Show, (forall a b. (a -> b) -> MaybeSection a -> MaybeSection b)
-> (forall a b. a -> MaybeSection b -> MaybeSection a)
-> Functor MaybeSection
forall a b. a -> MaybeSection b -> MaybeSection a
forall a b. (a -> b) -> MaybeSection a -> MaybeSection 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) -> MaybeSection a -> MaybeSection b
fmap :: forall a b. (a -> b) -> MaybeSection a -> MaybeSection b
$c<$ :: forall a b. a -> MaybeSection b -> MaybeSection a
<$ :: forall a b. a -> MaybeSection b -> MaybeSection a
Functor, (forall m. Monoid m => MaybeSection m -> m)
-> (forall m a. Monoid m => (a -> m) -> MaybeSection a -> m)
-> (forall m a. Monoid m => (a -> m) -> MaybeSection a -> m)
-> (forall a b. (a -> b -> b) -> b -> MaybeSection a -> b)
-> (forall a b. (a -> b -> b) -> b -> MaybeSection a -> b)
-> (forall b a. (b -> a -> b) -> b -> MaybeSection a -> b)
-> (forall b a. (b -> a -> b) -> b -> MaybeSection a -> b)
-> (forall a. (a -> a -> a) -> MaybeSection a -> a)
-> (forall a. (a -> a -> a) -> MaybeSection a -> a)
-> (forall a. MaybeSection a -> [a])
-> (forall a. MaybeSection a -> Bool)
-> (forall a. MaybeSection a -> VerboseLevel)
-> (forall a. Eq a => a -> MaybeSection a -> Bool)
-> (forall a. Ord a => MaybeSection a -> a)
-> (forall a. Ord a => MaybeSection a -> a)
-> (forall a. Num a => MaybeSection a -> a)
-> (forall a. Num a => MaybeSection a -> a)
-> Foldable MaybeSection
forall a. Eq a => a -> MaybeSection a -> Bool
forall a. Num a => MaybeSection a -> a
forall a. Ord a => MaybeSection a -> a
forall m. Monoid m => MaybeSection m -> m
forall a. MaybeSection a -> Bool
forall a. MaybeSection a -> VerboseLevel
forall a. MaybeSection a -> [a]
forall a. (a -> a -> a) -> MaybeSection a -> a
forall m a. Monoid m => (a -> m) -> MaybeSection a -> m
forall b a. (b -> a -> b) -> b -> MaybeSection a -> b
forall a b. (a -> b -> b) -> b -> MaybeSection a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> VerboseLevel)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => MaybeSection m -> m
fold :: forall m. Monoid m => MaybeSection m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MaybeSection a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> MaybeSection a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> MaybeSection a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> MaybeSection a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> MaybeSection a -> b
foldr :: forall a b. (a -> b -> b) -> b -> MaybeSection a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> MaybeSection a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> MaybeSection a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> MaybeSection a -> b
foldl :: forall b a. (b -> a -> b) -> b -> MaybeSection a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> MaybeSection a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> MaybeSection a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> MaybeSection a -> a
foldr1 :: forall a. (a -> a -> a) -> MaybeSection a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MaybeSection a -> a
foldl1 :: forall a. (a -> a -> a) -> MaybeSection a -> a
$ctoList :: forall a. MaybeSection a -> [a]
toList :: forall a. MaybeSection a -> [a]
$cnull :: forall a. MaybeSection a -> Bool
null :: forall a. MaybeSection a -> Bool
$clength :: forall a. MaybeSection a -> VerboseLevel
length :: forall a. MaybeSection a -> VerboseLevel
$celem :: forall a. Eq a => a -> MaybeSection a -> Bool
elem :: forall a. Eq a => a -> MaybeSection a -> Bool
$cmaximum :: forall a. Ord a => MaybeSection a -> a
maximum :: forall a. Ord a => MaybeSection a -> a
$cminimum :: forall a. Ord a => MaybeSection a -> a
minimum :: forall a. Ord a => MaybeSection a -> a
$csum :: forall a. Num a => MaybeSection a -> a
sum :: forall a. Num a => MaybeSection a -> a
$cproduct :: forall a. Num a => MaybeSection a -> a
product :: forall a. Num a => MaybeSection a -> a
Foldable, Functor MaybeSection
Foldable MaybeSection
(Functor MaybeSection, Foldable MaybeSection) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> MaybeSection a -> f (MaybeSection b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    MaybeSection (f a) -> f (MaybeSection a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> MaybeSection a -> m (MaybeSection b))
-> (forall (m :: * -> *) a.
    Monad m =>
    MaybeSection (m a) -> m (MaybeSection a))
-> Traversable MaybeSection
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
MaybeSection (m a) -> m (MaybeSection a)
forall (f :: * -> *) a.
Applicative f =>
MaybeSection (f a) -> f (MaybeSection a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MaybeSection a -> m (MaybeSection b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MaybeSection a -> f (MaybeSection b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MaybeSection a -> f (MaybeSection b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MaybeSection a -> f (MaybeSection b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MaybeSection (f a) -> f (MaybeSection a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MaybeSection (f a) -> f (MaybeSection a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MaybeSection a -> m (MaybeSection b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MaybeSection a -> m (MaybeSection b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MaybeSection (m a) -> m (MaybeSection a)
sequence :: forall (m :: * -> *) a.
Monad m =>
MaybeSection (m a) -> m (MaybeSection a)
Traversable)

fromNoSection :: a -> MaybeSection a -> a
fromNoSection :: forall a. a -> MaybeSection a -> a
fromNoSection a
fallback = \case
  MaybeSection a
YesSection  -> a
fallback
  NoSection a
x -> a
x

instance HasRange a => HasRange (MaybeSection a) where
  getRange :: MaybeSection a -> Range
getRange = \case
    MaybeSection a
YesSection  -> Range
forall a. Range' a
noRange
    NoSection a
a -> a -> Range
forall a. HasRange a => a -> Range
getRange a
a

getHead :: A.Expr -> Maybe Hd
getHead :: Expr -> Maybe Hd
getHead (Var Name
x)          = Hd -> Maybe Hd
forall a. a -> Maybe a
Just (Name -> Hd
HdVar Name
x)
getHead (Def QName
f)          = Hd -> Maybe Hd
forall a. a -> Maybe a
Just (QName -> Hd
HdDef QName
f)
getHead (Proj ProjOrigin
o AmbiguousQName
f)       = Hd -> Maybe Hd
forall a. a -> Maybe a
Just (QName -> Hd
HdDef (QName -> Hd) -> QName -> Hd
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> QName
headAmbQ AmbiguousQName
f)
getHead (Con AmbiguousQName
c)          = Hd -> Maybe Hd
forall a. a -> Maybe a
Just (QName -> Hd
HdCon (QName -> Hd) -> QName -> Hd
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> QName
headAmbQ AmbiguousQName
c)
getHead (A.PatternSyn AmbiguousQName
n) = Hd -> Maybe Hd
forall a. a -> Maybe a
Just (QName -> Hd
HdSyn (QName -> Hd) -> QName -> Hd
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> QName
headAmbQ AmbiguousQName
n)
getHead Expr
_                = Maybe Hd
forall a. Maybe a
Nothing

cOpApp :: Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr
cOpApp :: NameKind
-> Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr
cOpApp NameKind
nk Range
r QName
x Name
n List1 (MaybeSection Expr)
es =
  NameKind -> Range -> QName -> Set1 Name -> OpAppArgs -> Expr
C.KnownOpApp NameKind
nk Range
r QName
x (Name -> Set1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
n) (OpAppArgs -> Expr) -> OpAppArgs -> Expr
forall a b. (a -> b) -> a -> b
$
  ((MaybeSection Expr, PositionInName)
 -> NamedArg (MaybePlaceholder (OpApp Expr)))
-> NonEmpty (MaybeSection Expr, PositionInName) -> OpAppArgs
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MaybePlaceholder (OpApp Expr)
-> NamedArg (MaybePlaceholder (OpApp Expr))
forall a. a -> NamedArg a
defaultNamedArg (MaybePlaceholder (OpApp Expr)
 -> NamedArg (MaybePlaceholder (OpApp Expr)))
-> ((MaybeSection Expr, PositionInName)
    -> MaybePlaceholder (OpApp Expr))
-> (MaybeSection Expr, PositionInName)
-> NamedArg (MaybePlaceholder (OpApp Expr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaybeSection Expr, PositionInName)
-> MaybePlaceholder (OpApp Expr)
forall {e}.
(MaybeSection e, PositionInName) -> MaybePlaceholder (OpApp e)
placeholder) (NonEmpty (MaybeSection Expr, PositionInName) -> OpAppArgs)
-> NonEmpty (MaybeSection Expr, PositionInName) -> OpAppArgs
forall a b. (a -> b) -> a -> b
$
  List1 (MaybeSection Expr)
-> NonEmpty PositionInName
-> NonEmpty (MaybeSection Expr, PositionInName)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
List1.zip List1 (MaybeSection Expr)
es NonEmpty PositionInName
positions
  where
    x0 :: Name
x0 = QName -> Name
C.unqualify QName
x
    positions :: NonEmpty PositionInName
positions | Name -> Bool
isPrefix  Name
x0 =              (PositionInName -> MaybeSection Expr -> PositionInName
forall a b. a -> b -> a
const PositionInName
Middle (MaybeSection Expr -> PositionInName)
-> [MaybeSection Expr] -> [PositionInName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseLevel -> List1 (MaybeSection Expr) -> [MaybeSection Expr]
forall a. VerboseLevel -> NonEmpty a -> [a]
List1.drop VerboseLevel
1 List1 (MaybeSection Expr)
es) [PositionInName] -> PositionInName -> NonEmpty PositionInName
forall a. [a] -> a -> List1 a
`List1.snoc` PositionInName
End
              | Name -> Bool
isPostfix Name
x0 = PositionInName
Beginning PositionInName -> [PositionInName] -> NonEmpty PositionInName
forall a. a -> [a] -> NonEmpty a
:| (PositionInName -> MaybeSection Expr -> PositionInName
forall a b. a -> b -> a
const PositionInName
Middle (MaybeSection Expr -> PositionInName)
-> [MaybeSection Expr] -> [PositionInName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseLevel -> List1 (MaybeSection Expr) -> [MaybeSection Expr]
forall a. VerboseLevel -> NonEmpty a -> [a]
List1.drop VerboseLevel
1 List1 (MaybeSection Expr)
es)
              | Name -> Bool
isInfix Name
x0   = PositionInName
Beginning PositionInName -> [PositionInName] -> NonEmpty PositionInName
forall a. a -> [a] -> NonEmpty a
:| (PositionInName -> MaybeSection Expr -> PositionInName
forall a b. a -> b -> a
const PositionInName
Middle (MaybeSection Expr -> PositionInName)
-> [MaybeSection Expr] -> [PositionInName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseLevel -> List1 (MaybeSection Expr) -> [MaybeSection Expr]
forall a. VerboseLevel -> NonEmpty a -> [a]
List1.drop VerboseLevel
2 List1 (MaybeSection Expr)
es) [PositionInName] -> [PositionInName] -> [PositionInName]
forall a. [a] -> [a] -> [a]
++ [ PositionInName
End ]
              | Bool
otherwise    =               PositionInName -> MaybeSection Expr -> PositionInName
forall a b. a -> b -> a
const PositionInName
Middle (MaybeSection Expr -> PositionInName)
-> List1 (MaybeSection Expr) -> NonEmpty PositionInName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 (MaybeSection Expr)
es
    placeholder :: (MaybeSection e, PositionInName) -> MaybePlaceholder (OpApp e)
placeholder (MaybeSection e
YesSection , PositionInName
pos ) = PositionInName -> MaybePlaceholder (OpApp e)
forall e. PositionInName -> MaybePlaceholder e
Placeholder PositionInName
pos
    placeholder (NoSection e
e, PositionInName
_pos) = OpApp e -> MaybePlaceholder (OpApp e)
forall e. e -> MaybePlaceholder e
noPlaceholder (e -> OpApp e
forall e. e -> OpApp e
Ordinary e
e)

tryToRecoverOpApp :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr
tryToRecoverOpApp :: forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverOpApp Expr
e m Expr
def = m Expr -> m (Maybe Expr) -> m Expr
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM m Expr
def (m (Maybe Expr) -> m Expr) -> m (Maybe Expr) -> m Expr
forall a b. (a -> b) -> a -> b
$
  ((PrecedenceStack -> Bool) -> m Expr -> m Expr)
-> (Expr -> Bool)
-> (NameKind
    -> Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr)
-> (Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))]))
-> Expr
-> m (Maybe Expr)
forall a c (m :: * -> *).
(ToConcrete a, c ~ ConOfAbs a, HasRange c, MonadToConcrete m) =>
((PrecedenceStack -> Bool) -> m c -> m c)
-> (a -> Bool)
-> (NameKind
    -> Range -> QName -> Name -> List1 (MaybeSection c) -> c)
-> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
-> a
-> m (Maybe c)
recoverOpApp (PrecedenceStack -> Bool) -> m Expr -> m Expr
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Expr -> m Expr
bracket (NamedArg Expr -> Bool
isLambda (NamedArg Expr -> Bool) -> (Expr -> NamedArg Expr) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg) NameKind
-> Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr
cOpApp Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))])
view Expr
e
  where
    view :: A.Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Expr))])
    view :: Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))])
view Expr
e
        -- Do we have a series of inserted lambdas?
      | Just xs :: [Binder]
xs@(Binder
_:[Binder]
_) <- (LamBinding -> Maybe Binder) -> [LamBinding] -> Maybe [Binder]
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 LamBinding -> Maybe Binder
insertedName [LamBinding]
bs =
        (,) (Hd
 -> [NamedArg (MaybeSection (AppInfo, Expr))]
 -> (Hd, [NamedArg (MaybeSection (AppInfo, Expr))]))
-> Maybe Hd
-> Maybe
     ([NamedArg (MaybeSection (AppInfo, Expr))]
      -> (Hd, [NamedArg (MaybeSection (AppInfo, Expr))]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Hd
getHead Expr
hd Maybe
  ([NamedArg (MaybeSection (AppInfo, Expr))]
   -> (Hd, [NamedArg (MaybeSection (AppInfo, Expr))]))
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
-> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Name]
-> [Arg (Named_ (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
sectionArgs ((Binder -> Name) -> [Binder] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (BindName -> Name
unBind (BindName -> Name) -> (Binder -> BindName) -> Binder -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder -> BindName
forall a. Binder' a -> a
A.binderName) [Binder]
xs) [Arg (Named_ (AppInfo, Expr))]
args
      where
        LamView     [LamBinding]
bs Expr
body = Expr -> LamView
A.lamView Expr
e
        Application Expr
hd [Arg (Named_ (AppInfo, Expr))]
args = Expr -> AppView' (AppInfo, Expr)
A.appView' Expr
body

        -- Only inserted domain-free visible lambdas come from sections.
        insertedName :: LamBinding -> Maybe Binder
insertedName (A.DomainFree TacticAttribute
_ NamedArg Binder
x)
          | NamedArg Binder -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Binder
x Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Inserted Bool -> Bool -> Bool
&& NamedArg Binder -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Binder
x = Binder -> Maybe Binder
forall a. a -> Maybe a
Just (Binder -> Maybe Binder) -> Binder -> Maybe Binder
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg NamedArg Binder
x
        insertedName LamBinding
_ = Maybe Binder
forall a. Maybe a
Nothing

        -- Build section arguments. Need to check that:
        -- lambda bound variables appear in the right order and only as
        -- top-level arguments.
        sectionArgs :: [A.Name] -> [NamedArg (AppInfo, A.Expr)] -> Maybe [NamedArg (MaybeSection (AppInfo, A.Expr))]
        sectionArgs :: [Name]
-> [Arg (Named_ (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
sectionArgs [Name]
xs = [Name]
-> [Arg (Named_ (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
go [Name]
xs
          where
            noXs :: Arg (Named_ (AppInfo, Expr)) -> Bool
noXs = All -> Bool
getAll (All -> Bool)
-> (Arg (Named_ (AppInfo, Expr)) -> All)
-> Arg (Named_ (AppInfo, Expr))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> All) -> Expr -> All
forall m. FoldExprFn m Expr
forall a m. ExprLike a => FoldExprFn m a
foldExpr (\ case A.Var Name
x -> Bool -> All
All (Name
x Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
xs)
                                             Expr
_       -> Bool -> All
All Bool
True) (Expr -> All)
-> (Arg (Named_ (AppInfo, Expr)) -> Expr)
-> Arg (Named_ (AppInfo, Expr))
-> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, Expr) -> Expr
forall a b. (a, b) -> b
snd ((AppInfo, Expr) -> Expr)
-> (Arg (Named_ (AppInfo, Expr)) -> (AppInfo, Expr))
-> Arg (Named_ (AppInfo, Expr))
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg (Named_ (AppInfo, Expr)) -> (AppInfo, Expr)
forall a. NamedArg a -> a
namedArg
            go :: [Name]
-> [Arg (Named_ (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
go [] [] = [NamedArg (MaybeSection (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            go (Name
y : [Name]
ys) (Arg (Named_ (AppInfo, Expr))
arg : [Arg (Named_ (AppInfo, Expr))]
args)
              | Arg (Named_ (AppInfo, Expr)) -> Bool
forall a. LensHiding a => a -> Bool
visible Arg (Named_ (AppInfo, Expr))
arg
              , A.Var Name
y' <- (AppInfo, Expr) -> Expr
forall a b. (a, b) -> b
snd ((AppInfo, Expr) -> Expr) -> (AppInfo, Expr) -> Expr
forall a b. (a -> b) -> a -> b
$ Arg (Named_ (AppInfo, Expr)) -> (AppInfo, Expr)
forall a. NamedArg a -> a
namedArg Arg (Named_ (AppInfo, Expr))
arg
              , Name
y Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y' = ((Named_ (AppInfo, Expr)
 -> Named NamedName (MaybeSection (AppInfo, Expr)))
-> Arg (Named_ (AppInfo, Expr))
-> NamedArg (MaybeSection (AppInfo, Expr))
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MaybeSection (AppInfo, Expr)
forall a. MaybeSection a
YesSection MaybeSection (AppInfo, Expr)
-> Named_ (AppInfo, Expr)
-> Named NamedName (MaybeSection (AppInfo, Expr))
forall a b. a -> Named NamedName b -> Named NamedName a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) Arg (Named_ (AppInfo, Expr))
arg NamedArg (MaybeSection (AppInfo, Expr))
-> [NamedArg (MaybeSection (AppInfo, Expr))]
-> [NamedArg (MaybeSection (AppInfo, Expr))]
forall a. a -> [a] -> [a]
:) ([NamedArg (MaybeSection (AppInfo, Expr))]
 -> [NamedArg (MaybeSection (AppInfo, Expr))])
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
-> [Arg (Named_ (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
go [Name]
ys [Arg (Named_ (AppInfo, Expr))]
args
            go [Name]
ys (Arg (Named_ (AppInfo, Expr))
arg : [Arg (Named_ (AppInfo, Expr))]
args)
              | Arg (Named_ (AppInfo, Expr)) -> Bool
forall a. LensHiding a => a -> Bool
visible Arg (Named_ (AppInfo, Expr))
arg, Arg (Named_ (AppInfo, Expr)) -> Bool
noXs Arg (Named_ (AppInfo, Expr))
arg = (((Named_ (AppInfo, Expr)
 -> Named NamedName (MaybeSection (AppInfo, Expr)))
-> Arg (Named_ (AppInfo, Expr))
-> NamedArg (MaybeSection (AppInfo, Expr))
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named_ (AppInfo, Expr)
  -> Named NamedName (MaybeSection (AppInfo, Expr)))
 -> Arg (Named_ (AppInfo, Expr))
 -> NamedArg (MaybeSection (AppInfo, Expr)))
-> (((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
    -> Named_ (AppInfo, Expr)
    -> Named NamedName (MaybeSection (AppInfo, Expr)))
-> ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> Arg (Named_ (AppInfo, Expr))
-> NamedArg (MaybeSection (AppInfo, Expr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> Named_ (AppInfo, Expr)
-> Named NamedName (MaybeSection (AppInfo, Expr))
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (AppInfo, Expr) -> MaybeSection (AppInfo, Expr)
forall a. a -> MaybeSection a
NoSection Arg (Named_ (AppInfo, Expr))
arg NamedArg (MaybeSection (AppInfo, Expr))
-> [NamedArg (MaybeSection (AppInfo, Expr))]
-> [NamedArg (MaybeSection (AppInfo, Expr))]
forall a. a -> [a] -> [a]
:) ([NamedArg (MaybeSection (AppInfo, Expr))]
 -> [NamedArg (MaybeSection (AppInfo, Expr))])
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
-> [Arg (Named_ (AppInfo, Expr))]
-> Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
go [Name]
ys [Arg (Named_ (AppInfo, Expr))]
args
            go [Name]
_ [Arg (Named_ (AppInfo, Expr))]
_ = Maybe [NamedArg (MaybeSection (AppInfo, Expr))]
forall a. Maybe a
Nothing

    view Expr
e = (, ((Arg (Named_ (AppInfo, Expr))
 -> NamedArg (MaybeSection (AppInfo, Expr)))
-> [Arg (Named_ (AppInfo, Expr))]
-> [NamedArg (MaybeSection (AppInfo, Expr))]
forall a b. (a -> b) -> [a] -> [b]
map ((Arg (Named_ (AppInfo, Expr))
  -> NamedArg (MaybeSection (AppInfo, Expr)))
 -> [Arg (Named_ (AppInfo, Expr))]
 -> [NamedArg (MaybeSection (AppInfo, Expr))])
-> (((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
    -> Arg (Named_ (AppInfo, Expr))
    -> NamedArg (MaybeSection (AppInfo, Expr)))
-> ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> [Arg (Named_ (AppInfo, Expr))]
-> [NamedArg (MaybeSection (AppInfo, Expr))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named_ (AppInfo, Expr)
 -> Named NamedName (MaybeSection (AppInfo, Expr)))
-> Arg (Named_ (AppInfo, Expr))
-> NamedArg (MaybeSection (AppInfo, Expr))
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named_ (AppInfo, Expr)
  -> Named NamedName (MaybeSection (AppInfo, Expr)))
 -> Arg (Named_ (AppInfo, Expr))
 -> NamedArg (MaybeSection (AppInfo, Expr)))
-> (((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
    -> Named_ (AppInfo, Expr)
    -> Named NamedName (MaybeSection (AppInfo, Expr)))
-> ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> Arg (Named_ (AppInfo, Expr))
-> NamedArg (MaybeSection (AppInfo, Expr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> Named_ (AppInfo, Expr)
-> Named NamedName (MaybeSection (AppInfo, Expr))
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (AppInfo, Expr) -> MaybeSection (AppInfo, Expr)
forall a. a -> MaybeSection a
NoSection [Arg (Named_ (AppInfo, Expr))]
args) (Hd -> (Hd, [NamedArg (MaybeSection (AppInfo, Expr))]))
-> Maybe Hd
-> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Hd
getHead Expr
hd
      where Application Expr
hd [Arg (Named_ (AppInfo, Expr))]
args = Expr -> AppView' (AppInfo, Expr)
A.appView' Expr
e

tryToRecoverOpAppP :: MonadToConcrete m => A.Pattern -> m (Maybe C.Pattern)
tryToRecoverOpAppP :: forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m (Maybe Pattern)
tryToRecoverOpAppP Pattern
p = do
  res <- ((PrecedenceStack -> Bool) -> m Pattern -> m Pattern)
-> (Pattern -> Bool)
-> (NameKind
    -> Range
    -> QName
    -> Name
    -> List1 (MaybeSection Pattern)
    -> Pattern)
-> (Pattern
    -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))]))
-> Pattern
-> m (Maybe Pattern)
forall a c (m :: * -> *).
(ToConcrete a, c ~ ConOfAbs a, HasRange c, MonadToConcrete m) =>
((PrecedenceStack -> Bool) -> m c -> m c)
-> (a -> Bool)
-> (NameKind
    -> Range -> QName -> Name -> List1 (MaybeSection c) -> c)
-> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
-> a
-> m (Maybe c)
recoverOpApp (PrecedenceStack -> Bool) -> m Pattern -> m Pattern
forall (m :: * -> *).
MonadToConcrete m =>
(PrecedenceStack -> Bool) -> m Pattern -> m Pattern
bracketP_ (Bool -> Pattern -> Bool
forall a b. a -> b -> a
const Bool
False) ((Range -> QName -> Name -> List1 (MaybeSection Pattern) -> Pattern)
-> NameKind
-> Range
-> QName
-> Name
-> List1 (MaybeSection Pattern)
-> Pattern
forall a b. a -> b -> a
const Range -> QName -> Name -> List1 (MaybeSection Pattern) -> Pattern
opApp) Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
view Pattern
p
  reportS "print.op" 90
    [ "tryToRecoverOpApp"
    , "in:  " ++ show p
    , "out: " ++ show res
    ]
  return res
  where
    opApp :: Range -> QName -> Name -> List1 (MaybeSection Pattern) -> Pattern
opApp Range
r QName
x Name
n List1 (MaybeSection Pattern)
ps = Range
-> QName -> Set1 Name -> List1 (Arg (Named_ Pattern)) -> Pattern
C.OpAppP Range
r QName
x (Name -> Set1 Name
forall el coll. Singleton el coll => el -> coll
singleton Name
n) (List1 (Arg (Named_ Pattern)) -> Pattern)
-> List1 (Arg (Named_ Pattern)) -> Pattern
forall a b. (a -> b) -> a -> b
$
      (MaybeSection Pattern -> Arg (Named_ Pattern))
-> List1 (MaybeSection Pattern) -> List1 (Arg (Named_ Pattern))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pattern -> Arg (Named_ Pattern)
forall a. a -> NamedArg a
defaultNamedArg (Pattern -> Arg (Named_ Pattern))
-> (MaybeSection Pattern -> Pattern)
-> MaybeSection Pattern
-> Arg (Named_ Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> MaybeSection Pattern -> Pattern
forall a. a -> MaybeSection a -> a
fromNoSection Pattern
forall a. HasCallStack => a
__IMPOSSIBLE__) (List1 (MaybeSection Pattern) -> List1 (Arg (Named_ Pattern)))
-> List1 (MaybeSection Pattern) -> List1 (Arg (Named_ Pattern))
forall a b. (a -> b) -> a -> b
$
      -- `view` does not generate any `Nothing`s
      List1 (MaybeSection Pattern)
ps

    appInfo :: AppInfo
appInfo = AppInfo
defaultAppInfo_

    view :: A.Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Pattern))])
    view :: Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
view = \case
      ConP ConPatInfo
_        AmbiguousQName
cs [NamedArg Pattern]
ps -> (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
-> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
forall a. a -> Maybe a
Just (QName -> Hd
HdCon (AmbiguousQName -> QName
headAmbQ AmbiguousQName
cs), ((NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> [NamedArg Pattern]
-> [NamedArg (MaybeSection (AppInfo, Pattern))]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
 -> [NamedArg Pattern]
 -> [NamedArg (MaybeSection (AppInfo, Pattern))])
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> (Pattern -> MaybeSection (AppInfo, Pattern))
-> [NamedArg Pattern]
-> [NamedArg (MaybeSection (AppInfo, Pattern))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Pattern
 -> Named_ (MaybeSection (AppInfo, Pattern)))
-> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, 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_ (MaybeSection (AppInfo, Pattern)))
 -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> Named NamedName Pattern
    -> Named_ (MaybeSection (AppInfo, Pattern)))
-> (Pattern -> MaybeSection (AppInfo, Pattern))
-> NamedArg Pattern
-> NamedArg (MaybeSection (AppInfo, Pattern))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> MaybeSection (AppInfo, Pattern))
-> Named NamedName Pattern
-> Named_ (MaybeSection (AppInfo, 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) ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern)
forall a. a -> MaybeSection a
NoSection ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern))
-> (Pattern -> (AppInfo, Pattern))
-> Pattern
-> MaybeSection (AppInfo, Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo
appInfo,)) [NamedArg Pattern]
ps)
      DefP PatInfo
_        AmbiguousQName
fs [NamedArg Pattern]
ps -> (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
-> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
forall a. a -> Maybe a
Just (QName -> Hd
HdDef (AmbiguousQName -> QName
headAmbQ AmbiguousQName
fs), ((NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> [NamedArg Pattern]
-> [NamedArg (MaybeSection (AppInfo, Pattern))]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
 -> [NamedArg Pattern]
 -> [NamedArg (MaybeSection (AppInfo, Pattern))])
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> (Pattern -> MaybeSection (AppInfo, Pattern))
-> [NamedArg Pattern]
-> [NamedArg (MaybeSection (AppInfo, Pattern))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Pattern
 -> Named_ (MaybeSection (AppInfo, Pattern)))
-> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, 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_ (MaybeSection (AppInfo, Pattern)))
 -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> Named NamedName Pattern
    -> Named_ (MaybeSection (AppInfo, Pattern)))
-> (Pattern -> MaybeSection (AppInfo, Pattern))
-> NamedArg Pattern
-> NamedArg (MaybeSection (AppInfo, Pattern))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> MaybeSection (AppInfo, Pattern))
-> Named NamedName Pattern
-> Named_ (MaybeSection (AppInfo, 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) ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern)
forall a. a -> MaybeSection a
NoSection ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern))
-> (Pattern -> (AppInfo, Pattern))
-> Pattern
-> MaybeSection (AppInfo, Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo
appInfo,)) [NamedArg Pattern]
ps)
      PatternSynP PatInfo
_ AmbiguousQName
ns [NamedArg Pattern]
ps -> (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
-> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
forall a. a -> Maybe a
Just (QName -> Hd
HdSyn (AmbiguousQName -> QName
headAmbQ AmbiguousQName
ns), ((NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> [NamedArg Pattern]
-> [NamedArg (MaybeSection (AppInfo, Pattern))]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
 -> [NamedArg Pattern]
 -> [NamedArg (MaybeSection (AppInfo, Pattern))])
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> (Pattern -> MaybeSection (AppInfo, Pattern))
-> [NamedArg Pattern]
-> [NamedArg (MaybeSection (AppInfo, Pattern))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName Pattern
 -> Named_ (MaybeSection (AppInfo, Pattern)))
-> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, 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_ (MaybeSection (AppInfo, Pattern)))
 -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> Named NamedName Pattern
    -> Named_ (MaybeSection (AppInfo, Pattern)))
-> (Pattern -> MaybeSection (AppInfo, Pattern))
-> NamedArg Pattern
-> NamedArg (MaybeSection (AppInfo, Pattern))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> MaybeSection (AppInfo, Pattern))
-> Named NamedName Pattern
-> Named_ (MaybeSection (AppInfo, 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) ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern)
forall a. a -> MaybeSection a
NoSection ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern))
-> (Pattern -> (AppInfo, Pattern))
-> Pattern
-> MaybeSection (AppInfo, Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo
appInfo,)) [NamedArg Pattern]
ps)
      Pattern
_                   -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
forall a. Maybe a
Nothing
      -- ProjP _ _ d   -> Just (HdDef (headAmbQ d), [])   -- ? Andreas, 2016-04-21

recoverOpApp :: forall a c m. (ToConcrete a, c ~ ConOfAbs a, HasRange c, MonadToConcrete m)
  => ((PrecedenceStack -> Bool) -> m c -> m c)
  -> (a -> Bool)  -- ^ Check for lambdas
  -> (Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)  -- ^ @opApp@
  -> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
  -> a
  -> m (Maybe c)
recoverOpApp :: forall a c (m :: * -> *).
(ToConcrete a, c ~ ConOfAbs a, HasRange c, MonadToConcrete m) =>
((PrecedenceStack -> Bool) -> m c -> m c)
-> (a -> Bool)
-> (NameKind
    -> Range -> QName -> Name -> List1 (MaybeSection c) -> c)
-> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
-> a
-> m (Maybe c)
recoverOpApp (PrecedenceStack -> Bool) -> m c -> m c
bracket a -> Bool
isLam NameKind -> Range -> QName -> Name -> List1 (MaybeSection c) -> c
opApp a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])
view a
e = case a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])
view a
e of
  Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])
Nothing -> m (Maybe c)
forall {a}. m (Maybe a)
mDefault
  Just (Hd
hd, [NamedArg (MaybeSection (AppInfo, a))]
args)
    | (NamedArg (MaybeSection (AppInfo, a)) -> Bool)
-> [NamedArg (MaybeSection (AppInfo, a))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NamedArg (MaybeSection (AppInfo, a)) -> Bool
forall a. LensHiding a => a -> Bool
visible [NamedArg (MaybeSection (AppInfo, a))]
args    -> do
      let  args' :: [MaybeSection (AppInfo, a)]
args' = (NamedArg (MaybeSection (AppInfo, a)) -> MaybeSection (AppInfo, a))
-> [NamedArg (MaybeSection (AppInfo, a))]
-> [MaybeSection (AppInfo, a)]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg (MaybeSection (AppInfo, a)) -> MaybeSection (AppInfo, a)
forall a. NamedArg a -> a
namedArg [NamedArg (MaybeSection (AppInfo, a))]
args
      case Hd
hd of
        HdVar  Name
n
          | Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
n    -> m (Maybe c)
forall {a}. m (Maybe a)
mDefault
          | Bool
otherwise     -> Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
MonadToConcrete m =>
Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
doQNameHelper (Name -> Either Name QName
forall a b. a -> Either a b
Left Name
n) [MaybeSection (AppInfo, a)]
args'
        HdDef QName
qn
          | QName -> Bool
isExtendedLambdaName QName
qn
                          -> m (Maybe c)
forall {a}. m (Maybe a)
mDefault
          | Bool
otherwise     -> Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
MonadToConcrete m =>
Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
doQNameHelper (QName -> Either Name QName
forall a b. b -> Either a b
Right QName
qn) [MaybeSection (AppInfo, a)]
args'
        -- HdDef qn          -> doQNameHelper (Right qn) args'
        HdCon QName
qn          -> Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
MonadToConcrete m =>
Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
doQNameHelper (QName -> Either Name QName
forall a b. b -> Either a b
Right QName
qn) [MaybeSection (AppInfo, a)]
args'
        HdSyn QName
qn          -> Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
MonadToConcrete m =>
Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
doQNameHelper (QName -> Either Name QName
forall a b. b -> Either a b
Right QName
qn) [MaybeSection (AppInfo, a)]
args'
    | Bool
otherwise           -> m (Maybe c)
forall {a}. m (Maybe a)
mDefault
  where
  mDefault :: m (Maybe a)
mDefault = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

  skipParens :: MaybeSection (AppInfo, a) -> Bool
  skipParens :: MaybeSection (AppInfo, a) -> Bool
skipParens = \case
     MaybeSection (AppInfo, a)
YesSection       -> Bool
False
     NoSection (AppInfo
i, a
e) -> a -> Bool
isLam a
e Bool -> Bool -> Bool
&& ParenPreference -> Bool
preferParenless (AppInfo -> ParenPreference
appParens AppInfo
i)

  doQNameHelper :: MonadToConcrete m => Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
  doQNameHelper :: MonadToConcrete m =>
Either Name QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)
doQNameHelper Either Name QName
n [MaybeSection (AppInfo, a)]
args = do
    x <- (Name -> m QName)
-> (QName -> m QName) -> Either Name QName -> m QName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Name -> QName
C.QName (Name -> QName) -> (Name -> m Name) -> Name -> m QName
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Name -> m Name
Name -> m (ConOfAbs Name)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
Name -> m (ConOfAbs Name)
toConcrete) QName -> m QName
QName -> m (ConOfAbs QName)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *).
MonadToConcrete m =>
QName -> m (ConOfAbs QName)
toConcrete Either Name QName
n
    let n' = (Name -> Name) -> (QName -> Name) -> Either Name QName -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Name -> Name
forall a. a -> a
id QName -> Name
A.qnameName Either Name QName
n
    -- #1346: The fixity of the abstract name is not necessarily correct, it depends on which
    -- concrete name we choose! Make sure to resolve ambiguities with n'.
    (fx, nk) <- resolveName_ x n' <&> \ case
      VarName Name
y BindingSource
_                -> (Name
y Name -> Lens' Name Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> Name -> f Name
forall a. LensFixity a => Lens' a Fixity
Lens' Name Fixity
lensFixity, NameKind
Asp.Bound)
      DefinedName Access
_ AbstractName
q Suffix
_          -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, NameKind
Asp.Function)
      FieldName (AbstractName
q :| [AbstractName]
_)         -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, NameKind
Asp.Field)
      ConstructorName Set1 Induction
_ (AbstractName
q :| [AbstractName]
_) -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, Induction -> NameKind
Asp.Constructor Induction
Asp.Inductive)
      PatternSynResName (AbstractName
q :| [AbstractName]
_) -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, Induction -> NameKind
Asp.Constructor Induction
Asp.Inductive)
      ResolvedName
UnknownName                -> (Fixity
noFixity, NameKind
Asp.Bound)
    List1.ifNull args {-then-} mDefault {-else-} $ \ List1 (MaybeSection (AppInfo, a))
as ->
      MonadToConcrete m =>
NameKind
-> Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> m (Maybe c)
NameKind
-> Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> m (Maybe c)
doQName NameKind
nk Fixity
fx QName
x Name
n' List1 (MaybeSection (AppInfo, a))
as (Name -> NameParts
C.nameParts (Name -> NameParts) -> Name -> NameParts
forall a b. (a -> b) -> a -> b
$ QName -> Name
C.unqualify QName
x)

  doQName :: MonadToConcrete m => Asp.NameKind -> Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> m (Maybe c)

  -- fall-back (wrong number of arguments or no holes)
  doQName :: MonadToConcrete m =>
NameKind
-> Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> m (Maybe c)
doQName NameKind
nk Fixity
_ QName
x Name
_ List1 (MaybeSection (AppInfo, a))
as NameParts
xs
    | List1 (MaybeSection (AppInfo, a)) -> VerboseLevel
forall a. NonEmpty a -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length List1 (MaybeSection (AppInfo, a))
as VerboseLevel -> VerboseLevel -> Bool
forall a. Eq a => a -> a -> Bool
/= QName -> VerboseLevel
forall a. NumHoles a => a -> VerboseLevel
numHoles QName
x = m (Maybe c)
forall {a}. m (Maybe a)
mDefault

  -- binary case
  doQName NameKind
nk Fixity
fixity QName
x Name
n (MaybeSection (AppInfo, a)
a1 :| [MaybeSection (AppInfo, a)]
as) NameParts
xs
    | NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.head NameParts
xs
    , NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.last NameParts
xs = do
        let ([MaybeSection (AppInfo, a)]
as', MaybeSection (AppInfo, a)
an) = [MaybeSection (AppInfo, a)]
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
-> (List1 (MaybeSection (AppInfo, a))
    -> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a)))
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [MaybeSection (AppInfo, a)]
as {-then-} ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a. HasCallStack => a
__IMPOSSIBLE__ {-else-} List1 (MaybeSection (AppInfo, a))
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a. List1 a -> ([a], a)
List1.initLast
        c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> m c -> m (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> m c -> m c
bracket (Bool -> Fixity -> PrecedenceStack -> Bool
opBrackets' (MaybeSection (AppInfo, a) -> Bool
skipParens MaybeSection (AppInfo, a)
an) Fixity
fixity) (m c -> m c) -> m c -> m c
forall a b. (a -> b) -> a -> b
$ do
            e1 <- ((AppInfo, a) -> m c)
-> MaybeSection (AppInfo, a) -> m (MaybeSection 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) -> MaybeSection a -> f (MaybeSection b)
traverse (Precedence -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx (Fixity -> Precedence
LeftOperandCtx Fixity
fixity) (a -> m c) -> ((AppInfo, a) -> a) -> (AppInfo, a) -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) MaybeSection (AppInfo, a)
a1
            es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'
            en <- traverse (uncurry $ toConcreteCtx . RightOperandCtx fixity . appParens) an
            return $ opApp nk (getRange (e1, en)) x n (e1 :| es ++ [en])

  -- prefix
  doQName NameKind
nk Fixity
fixity QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
xs
    | NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.last NameParts
xs = do
        let ([MaybeSection (AppInfo, a)]
as', MaybeSection (AppInfo, a)
an) = List1 (MaybeSection (AppInfo, a))
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a. List1 a -> ([a], a)
List1.initLast List1 (MaybeSection (AppInfo, a))
as
        c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> m c -> m (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> m c -> m c
bracket (Bool -> Fixity -> PrecedenceStack -> Bool
opBrackets' (MaybeSection (AppInfo, a) -> Bool
skipParens MaybeSection (AppInfo, a)
an) Fixity
fixity) (m c -> m c) -> m c -> m c
forall a b. (a -> b) -> a -> b
$ do
            es <- ((MaybeSection (AppInfo, a) -> m (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> m [MaybeSection 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 ((MaybeSection (AppInfo, a) -> m (MaybeSection c))
 -> [MaybeSection (AppInfo, a)] -> m [MaybeSection c])
-> (((AppInfo, a) -> m c)
    -> MaybeSection (AppInfo, a) -> m (MaybeSection c))
-> ((AppInfo, a) -> m c)
-> [MaybeSection (AppInfo, a)]
-> m [MaybeSection c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, a) -> m c)
-> MaybeSection (AppInfo, a) -> m (MaybeSection 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) -> MaybeSection a -> f (MaybeSection b)
traverse) (Precedence -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
InsideOperandCtx (a -> m c) -> ((AppInfo, a) -> a) -> (AppInfo, a) -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) [MaybeSection (AppInfo, a)]
as'
            en <- traverse (\ (AppInfo
i, a
e) -> Precedence -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx (Fixity -> ParenPreference -> Precedence
RightOperandCtx Fixity
fixity (ParenPreference -> Precedence) -> ParenPreference -> Precedence
forall a b. (a -> b) -> a -> b
$ AppInfo -> ParenPreference
appParens AppInfo
i) a
e) an
            return $ opApp nk (getRange (n, en)) x n (List1.snoc es en)

  -- postfix
  doQName NameKind
nk Fixity
fixity QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
xs
    | NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.head NameParts
xs = do
        let a1 :: MaybeSection (AppInfo, a)
a1  = List1 (MaybeSection (AppInfo, a)) -> MaybeSection (AppInfo, a)
forall a. NonEmpty a -> a
List1.head List1 (MaybeSection (AppInfo, a))
as
            as' :: [MaybeSection (AppInfo, a)]
as' = List1 (MaybeSection (AppInfo, a)) -> [MaybeSection (AppInfo, a)]
forall a. NonEmpty a -> [a]
List1.tail List1 (MaybeSection (AppInfo, a))
as
        e1 <- ((AppInfo, a) -> m c)
-> MaybeSection (AppInfo, a) -> m (MaybeSection 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) -> MaybeSection a -> f (MaybeSection b)
traverse (Precedence -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx (Fixity -> Precedence
LeftOperandCtx Fixity
fixity) (a -> m c) -> ((AppInfo, a) -> a) -> (AppInfo, a) -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) MaybeSection (AppInfo, a)
a1
        es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'
        Just <$> do
          bracket (opBrackets fixity) $
            return $ opApp nk (getRange (e1, n)) x n (e1 :| es)

  -- roundfix
  doQName NameKind
nk Fixity
_ QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
_ = do
    es <- ((MaybeSection (AppInfo, a) -> m (MaybeSection c))
-> List1 (MaybeSection (AppInfo, a)) -> m (List1 (MaybeSection 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 ((MaybeSection (AppInfo, a) -> m (MaybeSection c))
 -> List1 (MaybeSection (AppInfo, a)) -> m (List1 (MaybeSection c)))
-> (((AppInfo, a) -> m c)
    -> MaybeSection (AppInfo, a) -> m (MaybeSection c))
-> ((AppInfo, a) -> m c)
-> List1 (MaybeSection (AppInfo, a))
-> m (List1 (MaybeSection c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, a) -> m c)
-> MaybeSection (AppInfo, a) -> m (MaybeSection 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) -> MaybeSection a -> f (MaybeSection b)
traverse) (Precedence -> a -> m (ConOfAbs a)
forall (m :: * -> *) a.
(MonadToConcrete m, ToConcrete a) =>
Precedence -> a -> m (ConOfAbs a)
toConcreteCtx Precedence
InsideOperandCtx (a -> m c) -> ((AppInfo, a) -> a) -> (AppInfo, a) -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) List1 (MaybeSection (AppInfo, a))
as
    Just <$> do
      bracket roundFixBrackets $
        return $ opApp nk (getRange x) x n es

-- Recovering pattern synonyms --------------------------------------------

-- | Recover pattern synonyms for expressions.
tryToRecoverPatternSyn :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr
tryToRecoverPatternSyn :: forall (m :: * -> *). MonadToConcrete m => Expr -> m Expr -> m Expr
tryToRecoverPatternSyn Expr
e m Expr
fallback
  | Expr -> Bool
userWritten Expr
e = m Expr
fallback
  | Expr -> Bool
litOrCon Expr
e    = (QName -> [NamedArg Expr] -> Expr)
-> (PatternSynDefn -> Expr -> Maybe [WithHiding Expr])
-> Expr
-> m (ConOfAbs Expr)
-> m (ConOfAbs Expr)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> m (ConOfAbs a)
-> m (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg Expr] -> Expr
apply PatternSynDefn -> Expr -> Maybe [WithHiding Expr]
matchPatternSyn Expr
e m Expr
m (ConOfAbs Expr)
fallback
  | Bool
otherwise     = m Expr
fallback
  where
    userWritten :: Expr -> Bool
userWritten (A.App AppInfo
info Expr
_ NamedArg Expr
_) = AppInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin AppInfo
info Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
UserWritten
    userWritten Expr
_                = Bool
False  -- this means we always use pattern synonyms for nullary constructors

    -- Only literals or constructors can head pattern synonym definitions
    litOrCon :: Expr -> Bool
litOrCon Expr
e =
      case Expr -> AppView
A.appView Expr
e of
        Application Con{}   [NamedArg Expr]
_ -> Bool
True
        Application A.Lit{} [NamedArg Expr]
_ -> Bool
True
        AppView
_                     -> Bool
False

    apply :: QName -> [NamedArg Expr] -> Expr
apply QName
c [NamedArg Expr]
args = AppView -> Expr
A.unAppView (AppView -> Expr) -> AppView -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> [NamedArg Expr] -> AppView
forall arg. Expr -> [NamedArg arg] -> AppView' arg
Application (AmbiguousQName -> Expr
A.PatternSyn (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
forall a b. (a -> b) -> a -> b
$ QName -> AmbiguousQName
unambiguous QName
c) [NamedArg Expr]
args

-- | Recover pattern synonyms in patterns.
tryToRecoverPatternSynP :: MonadToConcrete m => A.Pattern -> m C.Pattern -> m C.Pattern
tryToRecoverPatternSynP :: forall (m :: * -> *).
MonadToConcrete m =>
Pattern -> m Pattern -> m Pattern
tryToRecoverPatternSynP = (QName -> [NamedArg Pattern] -> Pattern)
-> (PatternSynDefn -> Pattern -> Maybe [WithHiding Pattern])
-> Pattern
-> m (ConOfAbs Pattern)
-> m (ConOfAbs Pattern)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> m (ConOfAbs a)
-> m (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg Pattern] -> Pattern
forall {e}. QName -> NAPs e -> Pattern' e
apply PatternSynDefn -> Pattern -> Maybe [WithHiding Pattern]
forall e.
PatternSynDefn -> Pattern' e -> Maybe [WithHiding (Pattern' e)]
matchPatternSynP
  where apply :: QName -> NAPs e -> Pattern' e
apply QName
c NAPs e
args = PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
PatternSynP PatInfo
patNoRange (QName -> AmbiguousQName
unambiguous QName
c) NAPs e
args

-- | General pattern synonym recovery parameterised over expression type.
recoverPatternSyn :: forall a m. (ToConcrete a, MonadToConcrete m)
  => (A.QName -> [NamedArg a] -> a)                 -- applySyn
  -> (PatternSynDefn -> a -> Maybe [WithHiding a])  -- match
  -> a                                              -- expressions
  -> m (ConOfAbs a)                       -- fallback
  -> m (ConOfAbs a)
recoverPatternSyn :: forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> m (ConOfAbs a)
-> m (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg a] -> a
applySyn PatternSynDefn -> a -> Maybe [WithHiding a]
match a
e m (ConOfAbs a)
fallback = do
  doFold <- (Env -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
foldPatternSynonyms
  if not doFold then fallback else do
    psyns  <- getAllPatternSyns
    scope  <- getScope
    reportSLn "toConcrete.patsyn" 100 $ render $ hsep $
      [ "Scope when attempting to recover pattern synonyms:"
      , pretty scope
      ]
    let isConP ConP{} = Bool
True    -- #2828: only fold pattern synonyms with
        isConP Pattern' e
_      = Bool
False   --        constructor rhs
        cands = [ (QName
q, [WithHiding a]
args, Pattern' Void -> VerboseLevel
score Pattern' Void
rhs)
                | (QName
q, psyndef :: PatternSynDefn
psyndef@([WithHiding Name]
_, Pattern' Void
rhs)) <- [(QName, PatternSynDefn)] -> [(QName, PatternSynDefn)]
forall a. [a] -> [a]
reverse ([(QName, PatternSynDefn)] -> [(QName, PatternSynDefn)])
-> [(QName, PatternSynDefn)] -> [(QName, PatternSynDefn)]
forall a b. (a -> b) -> a -> b
$ PatternSynDefns -> [(QName, PatternSynDefn)]
forall k a. Map k a -> [(k, a)]
Map.toList PatternSynDefns
psyns
                , Pattern' Void -> Bool
forall {e}. Pattern' e -> Bool
isConP Pattern' Void
rhs
                , Just [WithHiding a]
args <- [PatternSynDefn -> a -> Maybe [WithHiding a]
match PatternSynDefn
psyndef a
e]
                -- #3879: only fold pattern synonyms with an unqualified concrete name in scope
                -- Note that we only need to consider the head of the inverse lookup result: they
                -- are already sorted from shortest to longest!
                , C.QName{} <- Maybe QName -> [QName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList (Maybe QName -> [QName]) -> Maybe QName -> [QName]
forall a b. (a -> b) -> a -> b
$ [QName] -> Maybe QName
forall a. [a] -> Maybe a
listToMaybe ([QName] -> Maybe QName) -> [QName] -> Maybe QName
forall a b. (a -> b) -> a -> b
$ QName -> ScopeInfo -> [QName]
inverseScopeLookupName QName
q ScopeInfo
scope
                ]
        cmp (a
_, b
_, a
x) (a
_, b
_, a
y) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
y a
x
    reportSLn "toConcrete.patsyn" 50 $ render $ hsep $
      [ "Found pattern synonym candidates:"
      , prettyList_ $ map (\ (QName
q,[WithHiding a]
_,VerboseLevel
_) -> QName
q) cands
      ]
    case sortBy cmp cands of
      (QName
q, [WithHiding a]
args, VerboseLevel
_) : [(QName, [WithHiding a], VerboseLevel)]
_ -> a -> m (ConOfAbs a)
forall a (m :: * -> *).
(ToConcrete a, MonadToConcrete m) =>
a -> m (ConOfAbs a)
forall (m :: * -> *). MonadToConcrete m => a -> m (ConOfAbs a)
toConcrete (a -> m (ConOfAbs a)) -> a -> m (ConOfAbs a)
forall a b. (a -> b) -> a -> b
$ QName -> [NamedArg a] -> a
applySyn QName
q ([NamedArg a] -> a) -> [NamedArg a] -> a
forall a b. (a -> b) -> a -> b
$
        [WithHiding a] -> (WithHiding a -> NamedArg a) -> [NamedArg a]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [WithHiding a]
args ((WithHiding a -> NamedArg a) -> [NamedArg a])
-> (WithHiding a -> NamedArg a) -> [NamedArg a]
forall a b. (a -> b) -> a -> b
$ \ (WithHiding Hiding
h a
arg) -> Hiding -> NamedArg a -> NamedArg a
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
h (NamedArg a -> NamedArg a) -> NamedArg a -> NamedArg a
forall a b. (a -> b) -> a -> b
$ a -> NamedArg a
forall a. a -> NamedArg a
defaultNamedArg a
arg
      [] -> m (ConOfAbs a)
fallback
  where
    -- Heuristic to pick the best pattern synonym: the one that folds the most
    -- constructors.
    score :: Pattern' Void -> Int
    score :: Pattern' Void -> VerboseLevel
score = Sum VerboseLevel -> VerboseLevel
forall a. Sum a -> a
getSum (Sum VerboseLevel -> VerboseLevel)
-> (Pattern' Void -> Sum VerboseLevel)
-> Pattern' Void
-> VerboseLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern' (ADotT (Pattern' Void)) -> Sum VerboseLevel)
-> Pattern' Void -> Sum VerboseLevel
forall p m.
(APatternLike p, Monoid m) =>
(Pattern' (ADotT p) -> m) -> p -> m
foldAPattern Pattern' Void -> Sum VerboseLevel
Pattern' (ADotT (Pattern' Void)) -> Sum VerboseLevel
forall {a} {e}. Num a => Pattern' e -> a
con
      where con :: Pattern' e -> a
con ConP{} = a
1
            con Pattern' e
_      = a
0

-- Some instances that are related to interaction with users -----------

instance ToConcrete InteractionId where
    type ConOfAbs InteractionId = C.Expr
    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
InteractionId -> m (ConOfAbs InteractionId)
toConcrete (InteractionId VerboseLevel
i) = Expr -> m Expr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Range -> Maybe VerboseLevel -> Expr
C.QuestionMark Range
forall a. Range' a
noRange (VerboseLevel -> Maybe VerboseLevel
forall a. a -> Maybe a
Just VerboseLevel
i)

instance ToConcrete NamedMeta where
    type ConOfAbs NamedMeta = C.Expr
    toConcrete :: forall (m :: * -> *).
MonadToConcrete m =>
NamedMeta -> m (ConOfAbs NamedMeta)
toConcrete NamedMeta
i =
      Range -> Maybe ArgName -> Expr
C.Underscore Range
forall a. Range' a
noRange (Maybe ArgName -> Expr) -> (Doc -> Maybe ArgName) -> Doc -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgName -> Maybe ArgName
forall a. a -> Maybe a
Just (ArgName -> Maybe ArgName)
-> (Doc -> ArgName) -> Doc -> Maybe ArgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> ArgName
forall a. Doc a -> ArgName
render (Doc -> Expr) -> m Doc -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedMeta -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NamedMeta -> m Doc
prettyTCM NamedMeta
i