{-# LANGUAGE CPP          #-}

-- {-# 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
    , abstractToConcrete_
    , abstractToConcreteScope
    , abstractToConcreteHiding
    , runAbsToCon
    , RangeAndPragma(..)
    , abstractToConcreteCtx
    , withScope
    , preserveInteractionIds
    , MonadAbsToCon, AbsToCon, Env
    , noTakenNames
    , lookupQName
    ) where

import Prelude hiding (null)

import Control.Arrow        ( (&&&), first )
import Control.Monad        ( (<=<), forM, forM_, guard, liftM2 )
import Control.Monad.Except ( runExceptT )
import Control.Monad.Reader ( MonadReader(..), asks, runReaderT )
import Control.Monad.State  ( StateT(..), runStateT )

import qualified Control.Monad.Fail as Fail

import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid hiding ((<>))
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 (Semigroup, (<>))
import Data.String

import Agda.Syntax.Common
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
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.Signature
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.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 Agda.Utils.Pretty hiding ((<>))
import Agda.Utils.Singleton
import Agda.Utils.Suffix

import Agda.Utils.Impossible

-- 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 RawName QName
builtins     :: Map String 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 :: RawName -> Bool
noScopeCheck RawName
b = RawName
b RawName -> [RawName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RawName
builtinZero, RawName
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 :: RawName -> m [(RawName, QName)]
builtin RawName
b = RawName -> m (Maybe Term)
forall (m :: * -> *). HasBuiltins m => RawName -> m (Maybe Term)
getBuiltin' RawName
b m (Maybe Term)
-> (Maybe Term -> m [(RawName, QName)]) -> m [(RawName, 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,
                 RawName -> Bool
noScopeCheck RawName
b Bool -> Bool -> Bool
|| QName -> ScopeInfo -> Bool
isNameInScope QName
q ScopeInfo
scope -> [(RawName, QName)] -> m [(RawName, QName)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(RawName
b, QName
q)]
        Maybe Term
_                                                -> [(RawName, QName)] -> m [(RawName, QName)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [Name]
ctxVars <- (Dom' Term (Name, Type) -> Name)
-> [Dom' Term (Name, Type)] -> [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) ([Dom' Term (Name, Type)] -> [Name])
-> m [Dom' Term (Name, Type)] -> m [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> [Dom' Term (Name, Type)]) -> m [Dom' Term (Name, Type)]
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> [Dom' Term (Name, Type)]
envContext
  [Name]
letVars <- Map Name (Open (Term, Dom Type)) -> [Name]
forall k a. Map k a -> [k]
Map.keys (Map Name (Open (Term, Dom Type)) -> [Name])
-> m (Map Name (Open (Term, Dom Type))) -> m [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> Map Name (Open (Term, Dom Type)))
-> m (Map Name (Open (Term, Dom Type)))
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Map Name (Open (Term, Dom Type))
envLetBindings
  let vars :: [Name]
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
  [(Name, LocalVar)] -> ((Name, LocalVar) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ScopeInfo
scope ScopeInfo
-> Lens' [(Name, LocalVar)] ScopeInfo -> [(Name, LocalVar)]
forall o i. o -> Lens' i o -> i
^. ([(Name, LocalVar)] -> f [(Name, LocalVar)])
-> ScopeInfo -> f ScopeInfo
Lens' [(Name, LocalVar)] ScopeInfo
scopeLocals) (((Name, LocalVar) -> m ()) -> m ())
-> ((Name, LocalVar) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Name
y , LocalVar
x) -> do
    Name -> Name -> m ()
forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName (LocalVar -> Name
localVar LocalVar
x) Name
y

  [(RawName, QName)]
builtinList <- [[(RawName, QName)]] -> [(RawName, QName)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(RawName, QName)]] -> [(RawName, QName)])
-> m [[(RawName, QName)]] -> m [(RawName, QName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RawName -> m [(RawName, QName)])
-> [RawName] -> m [[(RawName, QName)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RawName -> m [(RawName, QName)]
builtin [ RawName
builtinFromNat, RawName
builtinFromString, RawName
builtinFromNeg, RawName
builtinZero, RawName
builtinSuc ]
  Bool
foldPatSyns <- PragmaOptions -> Bool
optPrintPatternSynonyms (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
  Env -> m Env
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> m Env) -> Env -> m Env
forall a b. (a -> b) -> a -> b
$
    Env { takenVarNames :: Set Name
takenVarNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
vars
        , takenDefNames :: Set NameParts
takenDefNames = Set NameParts
defs
        , currentScope :: ScopeInfo
currentScope = ScopeInfo
scope
        , builtins :: Map RawName QName
builtins     = (QName -> QName -> QName)
-> [(RawName, QName)] -> Map RawName QName
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith QName -> QName -> QName
forall a. HasCallStack => a
__IMPOSSIBLE__ [(RawName, QName)]
builtinList
        , preserveIIds :: Bool
preserveIIds = Bool
False
        , foldPatternSynonyms :: Bool
foldPatternSynonyms = Bool
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 [AbstractName] -> Set Name)
-> Map Name [AbstractName]
-> Set NameParts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name [AbstractName] -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Map Name [AbstractName] -> Set NameParts)
-> Map Name [AbstractName] -> Set NameParts
forall a b. (a -> b) -> a -> b
$
        (Name -> [AbstractName] -> Bool)
-> Map Name [AbstractName] -> Map Name [AbstractName]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Name -> [AbstractName] -> Bool
forall {t :: * -> *}. Foldable t => Name -> t AbstractName -> Bool
usefulDef (Map Name [AbstractName] -> Map Name [AbstractName])
-> Map Name [AbstractName] -> Map Name [AbstractName]
forall a b. (a -> b) -> a -> b
$
        NameSpace -> Map Name [AbstractName]
nsNames (NameSpace -> Map Name [AbstractName])
-> NameSpace -> Map Name [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

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

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

withPrecedence' :: PrecedenceStack -> AbsToCon a -> AbsToCon a
withPrecedence' :: forall a. PrecedenceStack -> AbsToCon a -> AbsToCon a
withPrecedence' PrecedenceStack
ps = (Env -> Env) -> AbsToCon a -> AbsToCon a
forall a. (Env -> Env) -> AbsToCon a -> AbsToCon a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> AbsToCon a -> AbsToCon a)
-> (Env -> Env) -> AbsToCon a -> AbsToCon a
forall a b. (a -> b) -> a -> b
$ \Env
e ->
  Env
e { currentScope :: ScopeInfo
currentScope = Lens' PrecedenceStack ScopeInfo
-> LensSet PrecedenceStack ScopeInfo
forall i o. Lens' i o -> LensSet i o
set (PrecedenceStack -> f PrecedenceStack) -> ScopeInfo -> f ScopeInfo
Lens' PrecedenceStack ScopeInfo
scopePrecedence PrecedenceStack
ps (Env -> ScopeInfo
currentScope Env
e) }

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

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

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

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

-- | 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 Name
takenVarNames = Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
x (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Env -> Set Name
takenVarNames Env
e
    , currentScope :: ScopeInfo
currentScope = (([(Name, LocalVar)] -> [(Name, LocalVar)])
-> ScopeInfo -> ScopeInfo
`updateScopeLocals` Env -> ScopeInfo
currentScope Env
e) (([(Name, LocalVar)] -> [(Name, LocalVar)]) -> ScopeInfo)
-> ([(Name, LocalVar)] -> [(Name, LocalVar)]) -> ScopeInfo
forall a b. (a -> b) -> a -> b
$
        Name -> LocalVar -> [(Name, LocalVar)] -> [(Name, LocalVar)]
forall k v. k -> v -> AssocList k v -> AssocList k v
AssocList.insert Name
y (Name -> BindingSource -> [AbstractName] -> LocalVar
LocalVar Name
x BindingSource
forall a. HasCallStack => a
__IMPOSSIBLE__ [])
    }

-- | Get a function to check if a name refers to a particular builtin function.
isBuiltinFun :: AbsToCon (A.QName -> String -> Bool)
isBuiltinFun :: AbsToCon (QName -> RawName -> Bool)
isBuiltinFun = (Env -> QName -> RawName -> Bool)
-> AbsToCon (QName -> RawName -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> QName -> RawName -> Bool)
 -> AbsToCon (QName -> RawName -> Bool))
-> (Env -> QName -> RawName -> Bool)
-> AbsToCon (QName -> RawName -> Bool)
forall a b. (a -> b) -> a -> b
$ Map RawName QName -> QName -> RawName -> Bool
forall {k} {a}. (Ord k, Eq a) => Map k a -> a -> k -> Bool
is (Map RawName QName -> QName -> RawName -> Bool)
-> (Env -> Map RawName QName) -> Env -> QName -> RawName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map RawName 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 :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> AbsToCon (Either AmbiguousNameReason ResolvedName)
resolveName :: KindsOfNames
-> Maybe (Set Name)
-> QName
-> AbsToCon (Either AmbiguousNameReason ResolvedName)
resolveName KindsOfNames
kinds Maybe (Set Name)
candidates QName
q = ExceptT AmbiguousNameReason AbsToCon ResolvedName
-> AbsToCon (Either AmbiguousNameReason ResolvedName)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AmbiguousNameReason AbsToCon ResolvedName
 -> AbsToCon (Either AmbiguousNameReason ResolvedName))
-> ExceptT AmbiguousNameReason AbsToCon ResolvedName
-> AbsToCon (Either AmbiguousNameReason ResolvedName)
forall a b. (a -> b) -> a -> b
$ KindsOfNames
-> Maybe (Set Name)
-> QName
-> ExceptT AmbiguousNameReason AbsToCon ResolvedName
forall (m :: * -> *).
(ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m) =>
KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName
tryResolveName KindsOfNames
kinds Maybe (Set Name)
candidates QName
q

-- | Treat illegally ambiguous names as UnknownNames.
resolveName_ :: C.QName -> [A.Name] -> AbsToCon ResolvedName
resolveName_ :: QName -> [Name] -> AbsToCon ResolvedName
resolveName_ QName
q [Name]
cands = (AmbiguousNameReason -> ResolvedName)
-> Either AmbiguousNameReason ResolvedName -> ResolvedName
forall a b. (a -> b) -> Either a b -> b
fromRight (ResolvedName -> AmbiguousNameReason -> ResolvedName
forall a b. a -> b -> a
const ResolvedName
UnknownName) (Either AmbiguousNameReason ResolvedName -> ResolvedName)
-> AbsToCon (Either AmbiguousNameReason ResolvedName)
-> AbsToCon ResolvedName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindsOfNames
-> Maybe (Set Name)
-> QName
-> AbsToCon (Either AmbiguousNameReason ResolvedName)
resolveName KindsOfNames
allKindsOfNames (Set Name -> Maybe (Set Name)
forall a. a -> Maybe a
Just (Set Name -> Maybe (Set Name)) -> Set Name -> Maybe (Set Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
cands) QName
q

-- The Monad --------------------------------------------------------------

-- | The function 'runAbsToCon' can target any monad that satisfies
-- the constraints of 'MonadAbsToCon'.
type MonadAbsToCon m =
  ( MonadFresh NameId m
  , MonadInteractionPoints m
  , MonadStConcreteNames m
  , HasOptions m
  , PureTCM m
  , IsString (m Doc)
  , Null (m Doc)
  , Semigroup (m Doc)
  )

newtype AbsToCon a = AbsToCon
  { forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon :: forall m.
      ( MonadReader Env m
      , MonadAbsToCon m
      ) => m a
  }

-- TODO: Is there some way to automatically derive these boilerplate
-- instances?  GeneralizedNewtypeDeriving fails us here.
instance Functor AbsToCon where
  fmap :: forall a b. (a -> b) -> AbsToCon a -> AbsToCon b
fmap a -> b
f AbsToCon a
x = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m b)
-> AbsToCon b
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m b)
 -> AbsToCon b)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
x

instance Applicative AbsToCon where
  pure :: forall a. a -> AbsToCon a
pure a
x = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m a)
 -> AbsToCon a)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m a)
-> AbsToCon a
forall a b. (a -> b) -> a -> b
$ a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  AbsToCon (a -> b)
f <*> :: forall a b. AbsToCon (a -> b) -> AbsToCon a -> AbsToCon b
<*> AbsToCon a
m = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m b)
-> AbsToCon b
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m b)
 -> AbsToCon b)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ AbsToCon (a -> b)
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m (a -> b)
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon (a -> b)
f m (a -> b) -> m a -> m b
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
m

instance Monad AbsToCon where
  -- ASR (2021-02-07). The eta-expansion @\m' -> unAbsToCon m'@ is
  -- required by GHC >= 9.0.1 (see Issue #4955).
  AbsToCon a
m >>= :: forall a b. AbsToCon a -> (a -> AbsToCon b) -> AbsToCon b
>>= a -> AbsToCon b
f = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m b)
-> AbsToCon b
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m b)
 -> AbsToCon b)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
m m a -> (a -> 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
>>= (\AbsToCon b
m' -> AbsToCon b
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m b
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon b
m')(AbsToCon b -> m b) -> (a -> AbsToCon b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AbsToCon b
f
#if __GLASGOW_HASKELL__ < 808
  fail = Fail.fail
#endif

instance Fail.MonadFail AbsToCon where
  fail :: forall a. RawName -> AbsToCon a
fail = RawName -> AbsToCon a
forall a. HasCallStack => RawName -> a
error

instance MonadReader Env AbsToCon where
  ask :: AbsToCon Env
ask = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m Env)
-> AbsToCon Env
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m Env
forall r (m :: * -> *). MonadReader r m => m r
forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m Env
ask
  local :: forall a. (Env -> Env) -> AbsToCon a -> AbsToCon a
local Env -> Env
f AbsToCon a
m = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m a)
 -> AbsToCon a)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m a)
-> AbsToCon a
forall a b. (a -> b) -> a -> b
$ (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
f (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
m

instance MonadTCEnv AbsToCon where
  askTC :: AbsToCon TCEnv
askTC = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m TCEnv)
-> AbsToCon TCEnv
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m TCEnv
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m TCEnv
forall (m :: * -> *). MonadTCEnv m => m TCEnv
askTC
  localTC :: forall a. (TCEnv -> TCEnv) -> AbsToCon a -> AbsToCon a
localTC TCEnv -> TCEnv
f AbsToCon a
m = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m a)
 -> AbsToCon a)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m a)
-> AbsToCon a
forall a b. (a -> b) -> a -> b
$ (TCEnv -> TCEnv) -> m a -> m a
forall a. (TCEnv -> TCEnv) -> m a -> m a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC TCEnv -> TCEnv
f (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
m

instance ReadTCState AbsToCon where
  getTCState :: AbsToCon TCState
getTCState = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m TCState)
-> AbsToCon TCState
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m TCState
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m TCState
forall (m :: * -> *). ReadTCState m => m TCState
getTCState
  locallyTCState :: forall a b. Lens' a TCState -> (a -> a) -> AbsToCon b -> AbsToCon b
locallyTCState Lens' a TCState
l a -> a
f AbsToCon b
m = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m b)
-> AbsToCon b
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m b)
 -> AbsToCon b)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Lens' a TCState -> (a -> a) -> m b -> m b
forall a b. Lens' a TCState -> (a -> a) -> m b -> m b
forall (m :: * -> *) a b.
ReadTCState m =>
Lens' a TCState -> (a -> a) -> m b -> m b
locallyTCState (a -> f a) -> TCState -> f TCState
Lens' a TCState
l a -> a
f (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ AbsToCon b
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m b
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon b
m

instance MonadStConcreteNames AbsToCon where
  -- ASR (2021-02-07). The eta-expansion @\m' -> unAbsToCon m'@ is
  -- required by GHC >= 9.0.1 (see Issue #4955).
  runStConcreteNames :: forall a. StateT ConcreteNames AbsToCon a -> AbsToCon a
runStConcreteNames StateT ConcreteNames AbsToCon a
m =
    (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m a)
 -> AbsToCon a)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m a)
-> AbsToCon a
forall a b. (a -> b) -> a -> b
$ StateT ConcreteNames m a -> m a
forall a. StateT ConcreteNames m a -> m a
forall (m :: * -> *) a.
MonadStConcreteNames m =>
StateT ConcreteNames m a -> m a
runStConcreteNames (StateT ConcreteNames m a -> m a)
-> StateT ConcreteNames m a -> m a
forall a b. (a -> b) -> a -> b
$ (ConcreteNames -> m (a, ConcreteNames)) -> StateT ConcreteNames m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((ConcreteNames -> m (a, ConcreteNames))
 -> StateT ConcreteNames m a)
-> (ConcreteNames -> m (a, ConcreteNames))
-> StateT ConcreteNames m a
forall a b. (a -> b) -> a -> b
$ (\AbsToCon (a, ConcreteNames)
m' -> AbsToCon (a, ConcreteNames)
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m (a, ConcreteNames)
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon (a, ConcreteNames)
m') (AbsToCon (a, ConcreteNames) -> m (a, ConcreteNames))
-> (ConcreteNames -> AbsToCon (a, ConcreteNames))
-> ConcreteNames
-> m (a, ConcreteNames)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT ConcreteNames AbsToCon a
-> ConcreteNames -> AbsToCon (a, ConcreteNames)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT ConcreteNames AbsToCon a
m

instance HasBuiltins AbsToCon where
  getBuiltinThing :: RawName -> AbsToCon (Maybe (Builtin PrimFun))
getBuiltinThing RawName
x = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m (Maybe (Builtin PrimFun)))
-> AbsToCon (Maybe (Builtin PrimFun))
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m (Maybe (Builtin PrimFun)))
 -> AbsToCon (Maybe (Builtin PrimFun)))
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m (Maybe (Builtin PrimFun)))
-> AbsToCon (Maybe (Builtin PrimFun))
forall a b. (a -> b) -> a -> b
$ RawName -> m (Maybe (Builtin PrimFun))
forall (m :: * -> *).
HasBuiltins m =>
RawName -> m (Maybe (Builtin PrimFun))
getBuiltinThing RawName
x

instance HasOptions AbsToCon where
  pragmaOptions :: AbsToCon PragmaOptions
pragmaOptions = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m PragmaOptions)
-> AbsToCon PragmaOptions
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m PragmaOptions
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  commandLineOptions :: AbsToCon CommandLineOptions
commandLineOptions = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m CommandLineOptions)
-> AbsToCon CommandLineOptions
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m CommandLineOptions
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions

instance MonadDebug AbsToCon where
  formatDebugMessage :: RawName -> VerboseLevel -> TCM Doc -> AbsToCon RawName
formatDebugMessage RawName
k VerboseLevel
n TCM Doc
s      = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m RawName)
-> AbsToCon RawName
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m RawName)
 -> AbsToCon RawName)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m RawName)
-> AbsToCon RawName
forall a b. (a -> b) -> a -> b
$ RawName -> VerboseLevel -> TCM Doc -> m RawName
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> TCM Doc -> m RawName
formatDebugMessage RawName
k VerboseLevel
n TCM Doc
s
  traceDebugMessage :: forall a.
RawName -> VerboseLevel -> RawName -> AbsToCon a -> AbsToCon a
traceDebugMessage  RawName
k VerboseLevel
n RawName
s AbsToCon a
cont = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m a)
 -> AbsToCon a)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m a)
-> AbsToCon a
forall a b. (a -> b) -> a -> b
$ RawName -> VerboseLevel -> RawName -> m a -> m a
forall a. RawName -> VerboseLevel -> RawName -> m a -> m a
forall (m :: * -> *) a.
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m a -> m a
traceDebugMessage  RawName
k VerboseLevel
n RawName
s (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
cont  -- can't eta-reduce!
  verboseBracket :: forall a.
RawName -> VerboseLevel -> RawName -> AbsToCon a -> AbsToCon a
verboseBracket     RawName
k VerboseLevel
n RawName
s AbsToCon a
cont = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m a)
 -> AbsToCon a)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m a)
-> AbsToCon a
forall a b. (a -> b) -> a -> b
$ RawName -> VerboseLevel -> RawName -> m a -> m a
forall a. RawName -> VerboseLevel -> RawName -> m a -> m a
forall (m :: * -> *) a.
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m a -> m a
verboseBracket     RawName
k VerboseLevel
n RawName
s (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
cont  -- because of GHC-9.0

  getVerbosity :: AbsToCon Verbosity
getVerbosity      = AbsToCon Verbosity
forall (m :: * -> *). HasOptions m => m Verbosity
defaultGetVerbosity
  getProfileOptions :: AbsToCon ProfileOptions
getProfileOptions = AbsToCon ProfileOptions
forall (m :: * -> *). HasOptions m => m ProfileOptions
defaultGetProfileOptions
  isDebugPrinting :: AbsToCon Bool
isDebugPrinting   = AbsToCon Bool
forall (m :: * -> *). MonadTCEnv m => m Bool
defaultIsDebugPrinting
  nowDebugPrinting :: forall a. AbsToCon a -> AbsToCon a
nowDebugPrinting  = AbsToCon a -> AbsToCon a
forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
defaultNowDebugPrinting

instance HasConstInfo AbsToCon where
  getConstInfo' :: QName -> AbsToCon (Either SigError Definition)
getConstInfo' QName
a      = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m (Either SigError Definition))
-> AbsToCon (Either SigError Definition)
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (QName -> m (Either SigError Definition)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Either SigError Definition)
getConstInfo' QName
a)
  getRewriteRulesFor :: QName -> AbsToCon RewriteRules
getRewriteRulesFor QName
a = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m RewriteRules)
-> AbsToCon RewriteRules
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (QName -> m RewriteRules
forall (m :: * -> *). HasConstInfo m => QName -> m RewriteRules
getRewriteRulesFor QName
a)

instance MonadAddContext AbsToCon where
  addCtx :: forall a. Name -> Dom Type -> AbsToCon a -> AbsToCon a
addCtx Name
a Dom Type
b AbsToCon a
c = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (Name -> Dom Type -> m a -> m a
forall a. Name -> Dom Type -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Name -> Dom Type -> m a -> m a
addCtx Name
a Dom Type
b (AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
c))

  addLetBinding' :: forall a. Name -> Term -> Dom Type -> AbsToCon a -> AbsToCon a
addLetBinding' Name
a Term
b Dom Type
c AbsToCon a
d =
    (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (Name -> Term -> Dom Type -> m a -> m a
forall a. Name -> Term -> Dom Type -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Name -> Term -> Dom Type -> m a -> m a
addLetBinding' Name
a Term
b Dom Type
c (AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
d))

  updateContext :: forall a.
Substitution
-> ([Dom' Term (Name, Type)] -> [Dom' Term (Name, Type)])
-> AbsToCon a
-> AbsToCon a
updateContext Substitution
a [Dom' Term (Name, Type)] -> [Dom' Term (Name, Type)]
b AbsToCon a
c = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (Substitution
-> ([Dom' Term (Name, Type)] -> [Dom' Term (Name, Type)])
-> m a
-> m a
forall a.
Substitution
-> ([Dom' Term (Name, Type)] -> [Dom' Term (Name, Type)])
-> m a
-> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Substitution
-> ([Dom' Term (Name, Type)] -> [Dom' Term (Name, Type)])
-> m a
-> m a
updateContext Substitution
a [Dom' Term (Name, Type)] -> [Dom' Term (Name, Type)]
b (AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon a
c))

  withFreshName :: forall a. Range -> RawName -> (Name -> AbsToCon a) -> AbsToCon a
withFreshName Range
a RawName
b Name -> AbsToCon a
c =
    (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (Range -> RawName -> (Name -> m a) -> m a
forall a. Range -> RawName -> (Name -> m a) -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Range -> RawName -> (Name -> m a) -> m a
withFreshName Range
a RawName
b (\Name
x -> AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon (Name -> AbsToCon a
c Name
x)))

instance MonadReduce AbsToCon where
  liftReduce :: forall a. ReduceM a -> AbsToCon a
liftReduce ReduceM a
a = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce ReduceM a
a)

instance PureTCM AbsToCon where

instance MonadFresh NameId AbsToCon where
  fresh :: AbsToCon NameId
fresh = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m NameId)
-> AbsToCon NameId
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m NameId
forall i (m :: * -> *). MonadFresh i m => m i
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m NameId
fresh

instance MonadInteractionPoints AbsToCon where
  freshInteractionId :: AbsToCon InteractionId
freshInteractionId        = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m InteractionId)
-> AbsToCon InteractionId
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m InteractionId
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m InteractionId
forall (m :: * -> *). MonadInteractionPoints m => m InteractionId
freshInteractionId
  modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> AbsToCon ()
modifyInteractionPoints InteractionPoints -> InteractionPoints
a = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m ())
-> AbsToCon ()
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((InteractionPoints -> InteractionPoints) -> m ()
forall (m :: * -> *).
MonadInteractionPoints m =>
(InteractionPoints -> InteractionPoints) -> m ()
modifyInteractionPoints InteractionPoints -> InteractionPoints
a)

instance IsString (AbsToCon Doc) where
  fromString :: RawName -> AbsToCon Doc
fromString RawName
a = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m Doc)
-> AbsToCon Doc
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (RawName -> m Doc
forall a. IsString a => RawName -> a
fromString RawName
a)

instance Null (AbsToCon Doc) where
  empty :: AbsToCon Doc
empty = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m Doc)
-> AbsToCon Doc
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m Doc
forall a. Null a => a
forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m Doc
empty
  null :: AbsToCon Doc -> Bool
null  = AbsToCon Doc -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__

instance Semigroup (AbsToCon Doc) where
  AbsToCon Doc
a <> :: AbsToCon Doc -> AbsToCon Doc -> AbsToCon Doc
<> AbsToCon Doc
b = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m Doc)
-> AbsToCon Doc
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (AbsToCon Doc
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m Doc
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon Doc
a m Doc -> m Doc -> m Doc
forall a. Semigroup a => a -> a -> a
<> AbsToCon Doc
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m Doc
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon Doc
b)

runAbsToCon :: MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon :: forall (m :: * -> *) c. MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon AbsToCon c
m = do
  ScopeInfo
scope <- m ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
  RawName -> VerboseLevel -> RawName -> m c -> m c
forall a. RawName -> VerboseLevel -> RawName -> m a -> m a
forall (m :: * -> *) a.
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m a -> m a
verboseBracket RawName
"toConcrete" VerboseLevel
50 RawName
"runAbsToCon" (m c -> m c) -> m c -> m c
forall a b. (a -> b) -> a -> b
$ do
    RawName -> VerboseLevel -> RawName -> m ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete" VerboseLevel
50 (RawName -> m ()) -> RawName -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> RawName
render (Doc -> RawName) -> Doc -> RawName
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
      [ Doc
"entering AbsToCon with scope:"
      , [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ (((Name, LocalVar) -> Doc) -> [(Name, LocalVar)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (RawName -> Doc
text (RawName -> Doc)
-> ((Name, LocalVar) -> RawName) -> (Name, LocalVar) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RawName
C.nameToRawName (Name -> RawName)
-> ((Name, LocalVar) -> Name) -> (Name, LocalVar) -> RawName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, LocalVar) -> Name
forall a b. (a, b) -> a
fst) ([(Name, LocalVar)] -> [Doc]) -> [(Name, LocalVar)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ScopeInfo
scope ScopeInfo
-> Lens' [(Name, LocalVar)] ScopeInfo -> [(Name, LocalVar)]
forall o i. o -> Lens' i o -> i
^. ([(Name, LocalVar)] -> f [(Name, LocalVar)])
-> ScopeInfo -> f ScopeInfo
Lens' [(Name, LocalVar)] ScopeInfo
scopeLocals)
      ]
    c
x <- ReaderT Env m c -> Env -> m c
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AbsToCon c
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m c
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon c
m) (Env -> m c) -> m Env -> m c
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
    RawName -> VerboseLevel -> RawName -> m ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete" VerboseLevel
50 (RawName -> m ()) -> RawName -> m ()
forall a b. (a -> b) -> a -> b
$ RawName
"leaving AbsToCon"
    c -> m c
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return c
x

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 (AbsToCon (ConOfAbs a)
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m (ConOfAbs a)
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon (AbsToCon (ConOfAbs a)
 -> forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m (ConOfAbs a))
-> AbsToCon (ConOfAbs a)
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m (ConOfAbs a)
forall a b. (a -> b) -> a -> b
$ a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (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 = AbsToCon (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) c. MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon (AbsToCon (ConOfAbs a) -> m (ConOfAbs a))
-> AbsToCon (ConOfAbs a) -> m (ConOfAbs a)
forall a b. (a -> b) -> a -> b
$ Precedence -> AbsToCon (ConOfAbs a) -> AbsToCon (ConOfAbs a)
forall a. Precedence -> AbsToCon a -> AbsToCon a
withPrecedence Precedence
ctx (a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (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_ = AbsToCon (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) c. MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon (AbsToCon (ConOfAbs a) -> m (ConOfAbs a))
-> (a -> AbsToCon (ConOfAbs a)) -> a -> m (ConOfAbs a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (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 = AbsToCon (ConOfAbs a) -> m (ConOfAbs a)
forall (m :: * -> *) c. MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon (AbsToCon (ConOfAbs a) -> m (ConOfAbs a))
-> (a -> AbsToCon (ConOfAbs a)) -> a -> m (ConOfAbs a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> a -> AbsToCon (ConOfAbs a)
forall h a.
(LensHiding h, ToConcrete a) =>
h -> a -> AbsToCon (ConOfAbs a)
toConcreteHiding i
i

-- 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

lookupQName :: AllowAmbiguousNames -> A.QName -> AbsToCon C.QName
lookupQName :: AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
ambCon QName
x | Just RawName
s <- QName -> Maybe RawName
getGeneralizedFieldName QName
x =
  QName -> AbsToCon QName
forall a. a -> AbsToCon 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
$ RawName -> NameParts
C.stringNameParts RawName
s)
lookupQName AllowAmbiguousNames
ambCon QName
x = do
  [QName]
ys <- (Env -> [QName]) -> AbsToCon [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)
  RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"scope.inverse" VerboseLevel
100 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$
    RawName
"inverse looking up abstract name " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ QName -> RawName
forall a. Pretty a => a -> RawName
prettyShow QName
x RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ RawName
" yields " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ [QName] -> RawName
forall a. Pretty a => a -> RawName
prettyShow [QName]
ys
  [QName] -> AbsToCon QName
loop [QName]
ys

  where
    -- Found concrete name: check that it is not shadowed by a local
    loop :: [QName] -> AbsToCon QName
loop (qy :: QName
qy@Qual{}      : [QName]
_ ) = QName -> AbsToCon QName
forall a. a -> AbsToCon 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 -> AbsToCon (Maybe Name)
lookupNameInScope Name
y AbsToCon (Maybe Name)
-> (Maybe Name -> AbsToCon QName) -> AbsToCon QName
forall a b. AbsToCon a -> (a -> AbsToCon b) -> AbsToCon 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] -> AbsToCon QName
loop [QName]
ys
      Maybe Name
_ -> QName -> AbsToCon QName
forall a. a -> AbsToCon 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 -> AbsToCon QName
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> AbsToCon QName) -> QName -> AbsToCon 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) -> AbsToCon Name -> AbsToCon QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AbsToCon Name
chooseName (QName -> Name
qnameName QName
x)

lookupModule :: A.ModuleName -> AbsToCon C.QName
lookupModule :: ModuleName -> AbsToCon QName
lookupModule (A.MName []) = QName -> AbsToCon QName
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> AbsToCon QName) -> QName -> AbsToCon QName
forall a b. (a -> b) -> a -> b
$ Name -> QName
C.QName (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ RawName -> Name
C.simpleName RawName
"-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  ScopeInfo
scope <- (Env -> ScopeInfo) -> AbsToCon ScopeInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ScopeInfo
currentScope
        case ModuleName -> ScopeInfo -> [QName]
inverseScopeLookupModule ModuleName
x ScopeInfo
scope of
            (QName
y : [QName]
_) -> QName -> AbsToCon QName
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
y
            []      -> QName -> AbsToCon QName
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> AbsToCon QName) -> QName -> AbsToCon 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 :: C.Name -> AbsToCon (Maybe A.Name)
lookupNameInScope :: Name -> AbsToCon (Maybe Name)
lookupNameInScope Name
y =
  (Env -> Maybe Name) -> AbsToCon (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' [(Name, LocalVar)] ScopeInfo -> [(Name, LocalVar)]
forall o i. o -> Lens' i o -> i
^. ([(Name, LocalVar)] -> f [(Name, LocalVar)])
-> ScopeInfo -> f ScopeInfo
Lens' [(Name, LocalVar)] ScopeInfo
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] -> Name -> ConcreteNames -> [Name]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] 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 [Name] -> Maybe [Name])
 -> Name -> ConcreteNames -> ConcreteNames)
-> Name
-> (Maybe [Name] -> Maybe [Name])
-> ConcreteNames
-> ConcreteNames
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe [Name] -> Maybe [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 [Name] -> Maybe [Name]) -> ConcreteNames -> ConcreteNames)
-> (Maybe [Name] -> Maybe [Name]) -> ConcreteNames -> ConcreteNames
forall a b. (a -> b) -> a -> b
$ \case
    Maybe [Name]
Nothing   -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name]) -> [Name] -> Maybe [Name]
forall a b. (a -> b) -> a -> b
$ [Name
y]
    (Just [Name]
ys) -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name]) -> [Name] -> Maybe [Name]
forall a b. (a -> b) -> a -> b
$ [Name]
ys [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [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 RawName)
shadowingNames Name
x =
  [RawName] -> Set RawName
forall a. Ord a => [a] -> Set a
Set.fromList ([RawName] -> Set RawName)
-> (Map Name (DList RawName) -> [RawName])
-> Map Name (DList RawName)
-> Set RawName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList RawName -> [RawName]
forall a. DList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList (DList RawName -> [RawName])
-> (Map Name (DList RawName) -> DList RawName)
-> Map Name (DList RawName)
-> [RawName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList RawName -> Name -> Map Name (DList RawName) -> DList RawName
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault DList RawName
forall a. Monoid a => a
mempty Name
x (Map Name (DList RawName) -> Set RawName)
-> m (Map Name (DList RawName)) -> m (Set RawName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Lens' (Map Name (DList RawName)) TCState
-> m (Map Name (DList RawName))
forall (m :: * -> *) a. ReadTCState m => Lens' a TCState -> m a
useR (Map Name (DList RawName) -> f (Map Name (DList RawName)))
-> TCState -> f TCState
Lens' (Map Name (DList RawName)) TCState
stShadowingNames

toConcreteName :: A.Name -> AbsToCon C.Name
toConcreteName :: Name -> AbsToCon Name
toConcreteName Name
x | Name
y <- Name -> Name
nameConcrete Name
x , Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
y = Name -> AbsToCon Name
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y
toConcreteName Name
x = ([Name] -> Name -> ConcreteNames -> [Name]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Name
x (ConcreteNames -> [Name])
-> AbsToCon ConcreteNames -> AbsToCon [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon ConcreteNames
forall (m :: * -> *). MonadStConcreteNames m => m ConcreteNames
useConcreteNames) AbsToCon [Name] -> ([Name] -> AbsToCon Name) -> AbsToCon Name
forall a b. AbsToCon a -> (a -> AbsToCon b) -> AbsToCon b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Name] -> AbsToCon Name
loop
  where
    -- case: we already have picked some name(s) for x
    loop :: [Name] -> AbsToCon Name
loop (Name
y:[Name]
ys) = AbsToCon Bool -> AbsToCon Name -> AbsToCon Name -> AbsToCon Name
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Name -> Name -> AbsToCon Bool
isGoodName Name
x Name
y) (Name -> AbsToCon Name
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y) ([Name] -> AbsToCon 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
      Name
y <- Name -> AbsToCon Name
chooseName Name
x
      Name -> Name -> AbsToCon ()
forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName Name
x Name
y
      Name -> AbsToCon Name
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y

    -- Is 'y' a good concrete name for abstract name 'x'?
    isGoodName :: A.Name -> C.Name -> AbsToCon Bool
    isGoodName :: Name -> Name -> AbsToCon Bool
isGoodName Name
x Name
y = do
      [Name]
zs <- (Env -> [Name]) -> AbsToCon [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)
      [Name] -> (Name -> AbsToCon Bool) -> AbsToCon Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
f a -> (a -> m Bool) -> m Bool
allM [Name]
zs ((Name -> AbsToCon Bool) -> AbsToCon Bool)
-> (Name -> AbsToCon Bool) -> AbsToCon Bool
forall a b. (a -> b) -> a -> b
$ \Name
z -> if Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
z then Bool -> AbsToCon Bool
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
        [Name]
czs <- Name -> AbsToCon [Name]
forall (m :: * -> *). MonadStConcreteNames m => Name -> m [Name]
hasConcreteNames Name
z
        Bool -> AbsToCon Bool
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> AbsToCon Bool) -> Bool -> AbsToCon Bool
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Name
y [Name]
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 :: A.Name -> AbsToCon C.Name
chooseName :: Name -> AbsToCon Name
chooseName Name
x = Name -> AbsToCon (Maybe Name)
lookupNameInScope (Name -> Name
nameConcrete Name
x) AbsToCon (Maybe Name)
-> (Maybe Name -> AbsToCon Name) -> AbsToCon Name
forall a b. AbsToCon a -> (a -> AbsToCon b) -> AbsToCon 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
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.bindName" VerboseLevel
80 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$
      RawName
"name " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Name -> RawName
C.nameToRawName (Name -> Name
nameConcrete Name
x) RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ RawName
" already in scope, so not renaming"
    Name -> AbsToCon Name
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> AbsToCon Name) -> Name -> AbsToCon 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
    Set NameParts
takenDefs <- (Env -> Set NameParts) -> AbsToCon (Set NameParts)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Set NameParts
takenDefNames
    Set RawName
taken   <- AbsToCon (Set RawName)
takenNames
    Set RawName
toAvoid <- Name -> AbsToCon (Set RawName)
forall (m :: * -> *).
(ReadTCState m, MonadStConcreteNames m) =>
Name -> m (Set RawName)
shadowingNames Name
x
    UnicodeOrAscii
glyphMode <- PragmaOptions -> UnicodeOrAscii
optUseUnicode (PragmaOptions -> UnicodeOrAscii)
-> AbsToCon PragmaOptions -> AbsToCon UnicodeOrAscii
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
    let freshNameMode :: FreshNameMode
freshNameMode = case UnicodeOrAscii
glyphMode of
          UnicodeOrAscii
UnicodeOk -> FreshNameMode
A.UnicodeSubscript
          UnicodeOrAscii
AsciiOnly -> FreshNameMode
A.AsciiCounter

        shouldAvoid :: Name -> Bool
shouldAvoid C.NoName {} = Bool
False
        shouldAvoid name :: Name
name@C.Name { NameParts
nameNameParts :: Name -> NameParts
nameNameParts :: NameParts
nameNameParts } =
          let raw :: RawName
raw = Name -> RawName
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
||
          RawName
raw RawName -> Set RawName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set RawName
taken Bool -> Bool -> Bool
||
          RawName
raw RawName -> Set RawName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set RawName
toAvoid

        y :: Name
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
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.bindName" VerboseLevel
80 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ Doc -> RawName
render (Doc -> RawName) -> Doc -> RawName
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat
      [ Doc
"picking concrete name for:" Doc -> Doc -> Doc
<+> RawName -> Doc
text (Name -> RawName
C.nameToRawName (Name -> RawName) -> Name -> RawName
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x)
      , Doc
"names already taken:      " Doc -> Doc -> Doc
<+> [RawName] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ (Set RawName -> [RawName]
forall a. Set a -> [a]
Set.toList Set RawName
taken)
      , Doc
"names to avoid:           " Doc -> Doc -> Doc
<+> [RawName] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ (Set RawName -> [RawName]
forall a. Set a -> [a]
Set.toList Set RawName
toAvoid)
      , Doc
"concrete name chosen:     " Doc -> Doc -> Doc
<+> RawName -> Doc
text (Name -> RawName
C.nameToRawName Name
y)
      ]
    Name -> AbsToCon Name
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y

  where
    takenNames :: AbsToCon (Set RawName)
    takenNames :: AbsToCon (Set RawName)
takenNames = do
      Set Name
ys0 <- (Env -> Set Name) -> AbsToCon (Set Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Set Name
takenVarNames
      RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.bindName" VerboseLevel
90 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ Doc -> RawName
render (Doc -> RawName) -> Doc -> RawName
forall a b. (a -> b) -> a -> b
$ Doc
"abstract names of local vars: " Doc -> Doc -> Doc
<+> [RawName] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ ((Name -> RawName) -> [Name] -> [RawName]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> RawName
C.nameToRawName (Name -> RawName) -> (Name -> Name) -> Name -> RawName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
nameConcrete) ([Name] -> [RawName]) -> [Name] -> [RawName]
forall a b. (a -> b) -> a -> b
$ Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
ys0)
      Set Name
ys <- [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name)
-> ([[Name]] -> [Name]) -> [[Name]] -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> Set Name) -> AbsToCon [[Name]] -> AbsToCon (Set Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> AbsToCon [Name]) -> [Name] -> AbsToCon [[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 Name -> AbsToCon [Name]
forall (m :: * -> *). MonadStConcreteNames m => Name -> m [Name]
hasConcreteNames (Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
ys0)
      Set RawName -> AbsToCon (Set RawName)
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set RawName -> AbsToCon (Set RawName))
-> Set RawName -> AbsToCon (Set RawName)
forall a b. (a -> b) -> a -> b
$ (Name -> RawName) -> Set Name -> Set RawName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> RawName
C.nameToRawName Set Name
ys


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

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

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

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

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

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

{- UNUSED
-- | Pattern bracketing
bracketP :: (PrecedenceStack -> Bool) -> (C.Pattern -> AbsToCon a)
                                 -> ((C.Pattern -> AbsToCon a) -> AbsToCon a)
                                 -> AbsToCon a
bracketP par ret m = m $ \p -> do
    p <- bracket' (ParenP $ getRange p) par p
    ret p
-}

-- | 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 :: DefInfo -> C.Name -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]
withInfixDecl :: DefInfo -> Name -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withInfixDecl DefInfo
i Name
x AbsToCon [Declaration]
m = (([Declaration]
fixDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
synDecl) [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++) ([Declaration] -> [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon [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 :: DefInfo -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]
withAbstractPrivate :: DefInfo -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withAbstractPrivate DefInfo
i AbsToCon [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 Range -> [Declaration] -> [Declaration]
addInstanceB (case DefInfo -> IsInstance
forall t. DefInfo' t -> IsInstance
A.defInstance DefInfo
i of InstanceDef Range
r -> Range -> Maybe Range
forall a. a -> Maybe a
Just Range
r; IsInstance
NotInstanceDef -> Maybe Range
forall a. Maybe a
Nothing)
      ([Declaration] -> [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon [Declaration]
m
    where
        priv :: Access -> [Declaration] -> [Declaration]
priv (PrivateAccess Origin
UserWritten)
                         [Declaration]
ds = [ Range -> Origin -> [Declaration] -> Declaration
C.Private  ([Declaration] -> Range
forall a. HasRange a => a -> Range
getRange [Declaration]
ds) Origin
UserWritten [Declaration]
ds ]
        priv Access
_           [Declaration]
ds = [Declaration]
ds
        abst :: IsAbstract -> [Declaration] -> [Declaration]
abst IsAbstract
AbstractDef [Declaration]
ds = [ Range -> [Declaration] -> Declaration
C.Abstract ([Declaration] -> Range
forall a. HasRange a => a -> Range
getRange [Declaration]
ds) [Declaration]
ds ]
        abst IsAbstract
ConcreteDef [Declaration]
ds = [Declaration]
ds

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

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

class ToConcrete a where
    type ConOfAbs a
    toConcrete :: a -> AbsToCon (ConOfAbs a)
    bindToConcrete :: a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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 -> AbsToCon (ConOfAbs a)) -> AbsToCon (ConOfAbs a)
forall b. a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a
x ConOfAbs a -> AbsToCon (ConOfAbs a)
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return
    bindToConcrete a
x ConOfAbs a -> AbsToCon b
ret = ConOfAbs a -> AbsToCon b
ret (ConOfAbs a -> AbsToCon b) -> AbsToCon (ConOfAbs a) -> AbsToCon b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete a
x

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

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

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

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

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

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

-- General instances ------------------------------------------------------

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

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

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

    toConcrete :: [a] -> AbsToCon (ConOfAbs [a])
toConcrete     = (a -> AbsToCon (ConOfAbs a)) -> [a] -> AbsToCon [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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
    bindToConcrete :: forall b. [a] -> (ConOfAbs [a] -> AbsToCon b) -> AbsToCon b
bindToConcrete []     ConOfAbs [a] -> AbsToCon b
ret = ConOfAbs [a] -> AbsToCon b
ret []
    bindToConcrete (a
a:[a]
as) ConOfAbs [a] -> AbsToCon b
ret = NonEmpty a -> (ConOfAbs (NonEmpty a) -> AbsToCon b) -> AbsToCon b
forall b.
NonEmpty a -> (ConOfAbs (NonEmpty a) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (a
aa -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[a]
as) ((ConOfAbs (NonEmpty a) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (NonEmpty a) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ (ConOfAbs a
c:|[ConOfAbs a]
cs) -> ConOfAbs [a] -> AbsToCon 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 :: List1 a -> AbsToCon (ConOfAbs (List1 a))
toConcrete     = (a -> AbsToCon (ConOfAbs a))
-> List1 a -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (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 b.
List1 a -> (ConOfAbs (List1 a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (a
a :| [a]
as) ConOfAbs (List1 a) -> AbsToCon b
ret = do
      PrecedenceStack
p <- AbsToCon PrecedenceStack
currentPrecedence  -- save precedence
      a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall b. a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a
a ((ConOfAbs a -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs a
c ->
        PrecedenceStack -> AbsToCon b -> AbsToCon b
forall a. PrecedenceStack -> AbsToCon a -> AbsToCon a
withPrecedence' PrecedenceStack
p (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ -- reset precedence
          [a] -> (ConOfAbs [a] -> AbsToCon b) -> AbsToCon b
forall b. [a] -> (ConOfAbs [a] -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete [a]
as ((ConOfAbs [a] -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs [a] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [a]
cs ->
            ConOfAbs (List1 a) -> AbsToCon 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 a1, ToConcrete a2) => ToConcrete (Either a1 a2) where
    type ConOfAbs (Either a1 a2) = Either (ConOfAbs a1) (ConOfAbs a2)

    toConcrete :: Either a1 a2 -> AbsToCon (ConOfAbs (Either a1 a2))
toConcrete = (a1 -> AbsToCon (ConOfAbs a1))
-> (a2 -> AbsToCon (ConOfAbs a2))
-> Either a1 a2
-> AbsToCon (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 -> AbsToCon (ConOfAbs a1)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete a2 -> AbsToCon (ConOfAbs a2)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
    bindToConcrete :: forall b.
Either a1 a2
-> (ConOfAbs (Either a1 a2) -> AbsToCon b) -> AbsToCon b
bindToConcrete (Left a1
x) ConOfAbs (Either a1 a2) -> AbsToCon b
ret =
        a1 -> (ConOfAbs a1 -> AbsToCon b) -> AbsToCon b
forall b. a1 -> (ConOfAbs a1 -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a1
x ((ConOfAbs a1 -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a1 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a1
x ->
        ConOfAbs (Either a1 a2) -> AbsToCon 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) -> AbsToCon b
ret =
        a2 -> (ConOfAbs a2 -> AbsToCon b) -> AbsToCon b
forall b. a2 -> (ConOfAbs a2 -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a2
y ((ConOfAbs a2 -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a2 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a2
y ->
        ConOfAbs (Either a1 a2) -> AbsToCon 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 :: (a1, a2) -> AbsToCon (ConOfAbs (a1, a2))
toConcrete (a1
x,a2
y) = (ConOfAbs a1 -> ConOfAbs a2 -> (ConOfAbs a1, ConOfAbs a2))
-> AbsToCon (ConOfAbs a1)
-> AbsToCon (ConOfAbs a2)
-> AbsToCon (ConOfAbs a1, ConOfAbs a2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (a1 -> AbsToCon (ConOfAbs a1)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete a1
x) (a2 -> AbsToCon (ConOfAbs a2)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete a2
y)
    bindToConcrete :: forall b.
(a1, a2) -> (ConOfAbs (a1, a2) -> AbsToCon b) -> AbsToCon b
bindToConcrete (a1
x,a2
y) ConOfAbs (a1, a2) -> AbsToCon b
ret =
        a1 -> (ConOfAbs a1 -> AbsToCon b) -> AbsToCon b
forall b. a1 -> (ConOfAbs a1 -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a1
x ((ConOfAbs a1 -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a1 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a1
x ->
        a2 -> (ConOfAbs a2 -> AbsToCon b) -> AbsToCon b
forall b. a2 -> (ConOfAbs a2 -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a2
y ((ConOfAbs a2 -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a2 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ConOfAbs a2
y ->
        ConOfAbs (a1, a2) -> AbsToCon 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 :: (a1, a2, a3) -> AbsToCon (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))
-> AbsToCon (ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
-> AbsToCon (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a1, (a2, a3)) -> AbsToCon (ConOfAbs (a1, (a2, a3)))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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 b.
(a1, a2, a3) -> (ConOfAbs (a1, a2, a3) -> AbsToCon b) -> AbsToCon b
bindToConcrete (a1
x,a2
y,a3
z) ConOfAbs (a1, a2, a3) -> AbsToCon b
ret = (a1, (a2, a3))
-> (ConOfAbs (a1, (a2, a3)) -> AbsToCon b) -> AbsToCon b
forall b.
(a1, (a2, a3))
-> (ConOfAbs (a1, (a2, a3)) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (a1
x,(a2
y,a3
z)) ((ConOfAbs (a1, (a2, a3)) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (a1, (a2, a3)) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3) -> AbsToCon b
ConOfAbs (a1, a2, a3) -> AbsToCon b
ret ((ConOfAbs a1, ConOfAbs a2, ConOfAbs a3) -> AbsToCon b)
-> ((ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
    -> (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3))
-> (ConOfAbs a1, (ConOfAbs a2, ConOfAbs a3))
-> AbsToCon 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)

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

    toConcrete :: Arg a -> AbsToCon (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))
-> AbsToCon (ConOfAbs a) -> AbsToCon (Arg (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgInfo -> a -> AbsToCon (ConOfAbs a)
forall h a.
(LensHiding h, ToConcrete a) =>
h -> a -> AbsToCon (ConOfAbs a)
toConcreteHiding ArgInfo
i a
a

    bindToConcrete :: forall b. Arg a -> (ConOfAbs (Arg a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (Arg ArgInfo
info a
x) ConOfAbs (Arg a) -> AbsToCon b
ret =
      ArgInfo -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall h a b.
(LensHiding h, ToConcrete a) =>
h -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcreteHiding ArgInfo
info a
x ((ConOfAbs a -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Arg (ConOfAbs a) -> AbsToCon b
ConOfAbs (Arg a) -> AbsToCon b
ret (Arg (ConOfAbs a) -> AbsToCon b)
-> (ConOfAbs a -> Arg (ConOfAbs a)) -> ConOfAbs a -> AbsToCon 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 :: WithHiding a -> AbsToCon (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))
-> AbsToCon (ConOfAbs a) -> AbsToCon (WithHiding (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hiding -> a -> AbsToCon (ConOfAbs a)
forall h a.
(LensHiding h, ToConcrete a) =>
h -> a -> AbsToCon (ConOfAbs a)
toConcreteHiding Hiding
h a
a
  bindToConcrete :: forall b.
WithHiding a
-> (ConOfAbs (WithHiding a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (WithHiding Hiding
h a
a) ConOfAbs (WithHiding a) -> AbsToCon b
ret = Hiding -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall h a b.
(LensHiding h, ToConcrete a) =>
h -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcreteHiding Hiding
h a
a ((ConOfAbs a -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs a
a ->
    ConOfAbs (WithHiding a) -> AbsToCon b
ret (ConOfAbs (WithHiding a) -> AbsToCon b)
-> ConOfAbs (WithHiding a) -> AbsToCon 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 :: Named name a -> AbsToCon (ConOfAbs (Named name a))
toConcrete (Named Maybe name
n a
x) = Maybe name -> ConOfAbs a -> Named name (ConOfAbs a)
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n (ConOfAbs a -> Named name (ConOfAbs a))
-> AbsToCon (ConOfAbs a) -> AbsToCon (Named name (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete a
x
    bindToConcrete :: forall b.
Named name a
-> (ConOfAbs (Named name a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (Named Maybe name
n a
x) ConOfAbs (Named name a) -> AbsToCon b
ret = a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall b. a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a
x ((ConOfAbs a -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Named name (ConOfAbs a) -> AbsToCon b
ConOfAbs (Named name a) -> AbsToCon b
ret (Named name (ConOfAbs a) -> AbsToCon b)
-> (ConOfAbs a -> Named name (ConOfAbs a))
-> ConOfAbs a
-> AbsToCon 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

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

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

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

instance ToConcrete BindName where
  type ConOfAbs BindName = C.BoundName

  toConcrete :: BindName -> AbsToCon (ConOfAbs BindName)
toConcrete       = (Name -> BoundName) -> AbsToCon Name -> AbsToCon BoundName
forall a b. (a -> b) -> AbsToCon a -> AbsToCon b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> BoundName
C.mkBoundName_ (AbsToCon Name -> AbsToCon BoundName)
-> (BindName -> AbsToCon Name) -> BindName -> AbsToCon BoundName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> AbsToCon Name
toConcreteName (Name -> AbsToCon Name)
-> (BindName -> Name) -> BindName -> AbsToCon Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindName -> Name
unBind
  bindToConcrete :: forall b.
BindName -> (ConOfAbs BindName -> AbsToCon b) -> AbsToCon b
bindToConcrete BindName
x = Name -> (Name -> AbsToCon b) -> AbsToCon b
forall a. Name -> (Name -> AbsToCon a) -> AbsToCon a
bindName (BindName -> Name
unBind BindName
x) ((Name -> AbsToCon b) -> AbsToCon b)
-> ((BoundName -> AbsToCon b) -> Name -> AbsToCon b)
-> (BoundName -> AbsToCon b)
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BoundName -> AbsToCon b)
-> (Name -> BoundName) -> Name -> AbsToCon 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 :: QName -> AbsToCon (ConOfAbs QName)
toConcrete = AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousConProjs

instance ToConcrete A.ModuleName where
  type ConOfAbs A.ModuleName = C.QName
  toConcrete :: ModuleName -> AbsToCon (ConOfAbs ModuleName)
toConcrete = ModuleName -> AbsToCon QName
ModuleName -> AbsToCon (ConOfAbs ModuleName)
lookupModule

instance ToConcrete AbstractName where
  type ConOfAbs AbstractName = C.QName
  toConcrete :: AbstractName -> AbsToCon (ConOfAbs AbstractName)
toConcrete = QName -> AbsToCon QName
QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (QName -> AbsToCon QName)
-> (AbstractName -> QName) -> AbstractName -> AbsToCon 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 :: ResolvedName -> AbsToCon (ConOfAbs ResolvedName)
toConcrete = \case
    VarName Name
x BindingSource
_          -> Name -> QName
C.QName (Name -> QName) -> AbsToCon Name -> AbsToCon QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AbsToCon (ConOfAbs Name)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Name
x
    DefinedName Access
_ AbstractName
x Suffix
s    -> Suffix -> AbsToCon QName -> AbsToCon QName
forall (m :: * -> *). HasOptions m => Suffix -> m QName -> m QName
addSuffixConcrete Suffix
s (AbsToCon QName -> AbsToCon QName)
-> AbsToCon QName -> AbsToCon QName
forall a b. (a -> b) -> a -> b
$ AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete AbstractName
x
    FieldName List1 AbstractName
xs         -> AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
xs)
    ConstructorName Set Induction
_ List1 AbstractName
xs -> AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
xs)
    PatternSynResName List1 AbstractName
xs -> AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (List1 AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head List1 AbstractName
xs)
    ResolvedName
UnknownName          -> AbsToCon QName
AbsToCon (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
  UnicodeOrAscii
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
  UnicodeOrAscii -> Integer -> QName -> QName
addSuffixConcrete' UnicodeOrAscii
glyphMode Integer
i (QName -> QName) -> m QName -> m QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m QName
x

addSuffixConcrete' :: UnicodeOrAscii -> Integer -> C.QName -> C.QName
addSuffixConcrete' :: UnicodeOrAscii -> Integer -> QName -> QName
addSuffixConcrete' UnicodeOrAscii
glyphMode Integer
i = Lens' (Maybe Suffix) QName -> LensSet (Maybe Suffix) QName
forall i o. Lens' i o -> LensSet i o
set ((Name -> f Name) -> QName -> f QName
Lens' Name QName
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' (Maybe Suffix) Name
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 :: Expr -> AbsToCon (ConOfAbs Expr)
toConcrete (Var Name
x)             = QName -> Expr
Ident (QName -> Expr) -> (Name -> QName) -> Name -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName (Name -> Expr) -> AbsToCon Name -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AbsToCon (ConOfAbs Name)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Name
x
    toConcrete (Def' QName
x Suffix
suffix)     = QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Suffix -> AbsToCon QName -> AbsToCon QName
forall (m :: * -> *). HasOptions m => Suffix -> m QName -> m QName
addSuffixConcrete Suffix
suffix (QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x)
    toConcrete (Proj ProjOrigin
ProjPrefix AmbiguousQName
p) = QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
    toConcrete (Proj ProjOrigin
_          AmbiguousQName
p) = Range -> Expr -> Expr
C.Dot Range
forall a. Range' a
noRange (Expr -> Expr) -> (QName -> Expr) -> QName -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
    toConcrete (A.Macro QName
x)         = QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    toConcrete e :: Expr
e@(Con AmbiguousQName
c)           = Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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 -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
      QName
x <- AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
      let r :: Range
r = ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i
      (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
appBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$
        Range -> Expr -> NamedArg Expr -> Expr
C.App Range
r (Range -> Expr
C.Quote Range
r) (Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg (Expr -> NamedArg Expr) -> Expr -> NamedArg Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr
C.Ident QName
x)
    toConcrete e :: Expr
e@(A.Lit ExprInfo
i Literal
l) = Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon 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
      Bool
preserve <- (Env -> Bool) -> AbsToCon Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
preserveIIds
      Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Maybe VerboseLevel -> Expr
C.QuestionMark (MetaInfo -> Range
forall a. HasRange a => a -> Range
getRange MetaInfo
i) (Maybe VerboseLevel -> Expr) -> Maybe VerboseLevel -> Expr
forall a b. (a -> b) -> a -> b
$
                 InteractionId -> VerboseLevel
interactionId InteractionId
ii VerboseLevel -> Maybe () -> Maybe VerboseLevel
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool
preserve Bool -> Bool -> Bool
|| Maybe MetaId -> Bool
forall a. Maybe a -> Bool
isJust (MetaInfo -> Maybe MetaId
metaNumber MetaInfo
i))

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

    toConcrete e :: Expr
e@(A.App AppInfo
i Expr
e1 NamedArg Expr
e2) = do
      QName -> RawName -> Bool
is <- AbsToCon (QName -> RawName -> 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 (Expr -> Maybe Hd
getHead Expr
e1, NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
e2) of
        (Just (HdDef QName
q), l :: Expr
l@A.Lit{})
          | (RawName -> Bool) -> [RawName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (QName -> RawName -> Bool
is QName
q) [RawName
builtinFromNat, RawName
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 -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
l
        (Just (HdDef QName
q), A.Lit ExprInfo
r (LitNat Integer
n))
          | QName
q QName -> RawName -> Bool
`is` RawName
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 -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (ExprInfo -> Literal -> Expr
A.Lit ExprInfo
r (Integer -> Literal
LitNat (-Integer
n)))
        (Maybe Hd, Expr)
_ ->
          Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e
          (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverOpApp Expr
e
          (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverNatural Expr
e
          -- or fallback to App
          (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon 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)
          (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do Expr
e1' <- Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
FunctionCtx Expr
e1
               NamedArg Expr
e2' <- Precedence -> NamedArg Expr -> AbsToCon (ConOfAbs (NamedArg Expr))
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx (ParenPreference -> Precedence
ArgumentCtx (ParenPreference -> Precedence) -> ParenPreference -> Precedence
forall a b. (a -> b) -> a -> b
$ AppInfo -> ParenPreference
appParens AppInfo
i) NamedArg Expr
e2
               Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Expr -> NamedArg Expr -> Expr
C.App (AppInfo -> Range
forall a. HasRange a => a -> Range
getRange AppInfo
i) Expr
e1' NamedArg Expr
e2'

    toConcrete (A.WithApp ExprInfo
i Expr
e [Expr]
es) =
      (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
withAppBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
        Expr
e <- Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
WithFunCtx Expr
e
        [Expr]
es <- (Expr -> AbsToCon Expr) -> [Expr] -> AbsToCon [Expr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
WithArgCtx) [Expr]
es
        Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Expr -> [Expr] -> Expr
C.WithApp (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) Expr
e [Expr]
es

    toConcrete (A.AbsurdLam ExprInfo
i Hiding
h) =
      (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon 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 -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverOpApp Expr
e (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$   -- recover sections
        [LamBinding]
-> (ConOfAbs [LamBinding] -> AbsToCon Expr) -> AbsToCon Expr
forall b.
[LamBinding] -> (ConOfAbs [LamBinding] -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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] -> AbsToCon Expr) -> AbsToCon Expr)
-> (ConOfAbs [LamBinding] -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [LamBinding]
bs' -> do
          [LamBinding]
-> AbsToCon Expr
-> (List1 LamBinding -> AbsToCon Expr)
-> AbsToCon 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 -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e')
            {-else-} ((List1 LamBinding -> AbsToCon Expr) -> AbsToCon Expr)
-> (List1 LamBinding -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ \ List1 LamBinding
bs -> (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon 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) -> AbsToCon Expr -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (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 TacticAttr
_ 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) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
          [Declaration]
decls <- NonEmpty [Declaration] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NonEmpty [Declaration] -> [Declaration])
-> AbsToCon (NonEmpty [Declaration]) -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 Clause -> AbsToCon (ConOfAbs (List1 Clause))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete List1 Clause
cs
          let namedPat :: Arg (Named_ Pattern) -> Pattern
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 (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 (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 :: C.Pattern -> AbsToCon [C.Pattern]
              removeApp :: Pattern -> AbsToCon [Pattern]
removeApp (C.RawAppP Range
_ (List2 Pattern
_ Pattern
p [Pattern]
ps)) = [Pattern] -> AbsToCon [Pattern]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pattern] -> AbsToCon [Pattern])
-> [Pattern] -> AbsToCon [Pattern]
forall a b. (a -> b) -> a -> b
$ Pattern
pPattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
:[Pattern]
ps
              removeApp (C.AppP (C.IdentP QName
_) Arg (Named_ Pattern)
np) = [Pattern] -> AbsToCon [Pattern]
forall a. a -> AbsToCon 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 -> AbsToCon [Pattern]
removeApp Pattern
p AbsToCon [Pattern]
-> ([Pattern] -> [Pattern]) -> AbsToCon [Pattern]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m 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] -> AbsToCon [Pattern]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return []

              removeApp Pattern
p = do
                RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"extendedlambda" VerboseLevel
50 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"abstractToConcrete removeApp p = " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Pattern -> RawName
forall a. Show a => a -> RawName
show Pattern
p
                [Pattern] -> AbsToCon [Pattern]
forall a. a -> AbsToCon 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 :: Declaration -> AbsToCon LamClause
decl2clause (C.FunClause (C.LHS Pattern
p [] []) RHS
rhs WhereClause' [Declaration]
C.NoWhere Bool
ca) = do
                RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"extendedlambda" VerboseLevel
50 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"abstractToConcrete extended lambda pattern p = " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Pattern -> RawName
forall a. Show a => a -> RawName
show Pattern
p
                [Pattern]
ps <- Pattern -> AbsToCon [Pattern]
removeApp Pattern
p
                RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"extendedlambda" VerboseLevel
50 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"abstractToConcrete extended lambda patterns ps = " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ [Pattern] -> RawName
forall a. Pretty a => a -> RawName
prettyShow [Pattern]
ps
                LamClause -> AbsToCon LamClause
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (LamClause -> AbsToCon LamClause)
-> LamClause -> AbsToCon LamClause
forall a b. (a -> b) -> a -> b
$ [Pattern] -> RHS -> Bool -> LamClause
LamClause [Pattern]
ps RHS
rhs Bool
ca
              decl2clause Declaration
_ = AbsToCon LamClause
forall a. HasCallStack => a
__IMPOSSIBLE__
          Range -> Erased -> List1 LamClause -> Expr
C.ExtendedLam (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) Erased
erased (List1 LamClause -> Expr)
-> ([LamClause] -> List1 LamClause) -> [LamClause] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 LamClause -> [LamClause] -> List1 LamClause
forall a. List1 a -> [a] -> List1 a
List1.fromListSafe List1 LamClause
forall a. HasCallStack => a
__IMPOSSIBLE__ ([LamClause] -> Expr) -> AbsToCon [LamClause] -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (Declaration -> AbsToCon LamClause)
-> [Declaration] -> AbsToCon [LamClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Declaration -> AbsToCon LamClause
decl2clause [Declaration]
decls
            -- TODO List1: can we demonstrate non-emptiness?

    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) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
piBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$
         NonEmpty TypedBinding
-> (ConOfAbs (NonEmpty TypedBinding) -> AbsToCon Expr)
-> AbsToCon Expr
forall b.
NonEmpty TypedBinding
-> (ConOfAbs (NonEmpty TypedBinding) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete NonEmpty TypedBinding
tel ((ConOfAbs (NonEmpty TypedBinding) -> AbsToCon Expr)
 -> AbsToCon Expr)
-> (ConOfAbs (NonEmpty TypedBinding) -> AbsToCon Expr)
-> AbsToCon 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) -> AbsToCon Expr -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
e
      where
        piTel1 :: NonEmpty TypedBinding -> Expr -> (NonEmpty TypedBinding, Expr)
piTel1 NonEmpty TypedBinding
tel Expr
e         = ([TypedBinding] -> NonEmpty TypedBinding)
-> ([TypedBinding], Expr) -> (NonEmpty TypedBinding, Expr)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (NonEmpty TypedBinding -> [TypedBinding] -> NonEmpty TypedBinding
forall a. List1 a -> [a] -> List1 a
List1.appendList NonEmpty TypedBinding
tel) (([TypedBinding], Expr) -> (NonEmpty TypedBinding, Expr))
-> ([TypedBinding], Expr) -> (NonEmpty TypedBinding, Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> ([TypedBinding], Expr)
piTel Expr
e
        piTel :: Expr -> ([TypedBinding], Expr)
piTel (A.Pi ExprInfo
_ NonEmpty TypedBinding
tel Expr
e) = (NonEmpty TypedBinding -> [TypedBinding])
-> (NonEmpty TypedBinding, Expr) -> ([TypedBinding], Expr)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first NonEmpty TypedBinding -> [Item (NonEmpty TypedBinding)]
NonEmpty TypedBinding -> [TypedBinding]
forall l. IsList l => l -> [Item l]
List1.toList ((NonEmpty TypedBinding, Expr) -> ([TypedBinding], Expr))
-> (NonEmpty TypedBinding, Expr) -> ([TypedBinding], 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 Set QName
_ Expr
e) = Expr -> Expr
C.Generalized (Expr -> Expr) -> AbsToCon Expr -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e

    toConcrete (A.Fun ExprInfo
i Arg Expr
a Expr
b) =
        (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
piBrackets
        (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do Arg Expr
a' <- Precedence -> Arg Expr -> AbsToCon (ConOfAbs (Arg Expr))
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
ctx Arg Expr
a
             Expr
b' <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
b
             let dom :: Arg Expr
dom = Quantity -> Arg Expr -> Arg Expr
forall a. LensQuantity a => Quantity -> a -> a
setQuantity (Arg Expr -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity 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, HasRange 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'
             Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Arg Expr -> Expr -> Expr
C.Fun (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) Arg Expr
dom Expr
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
                           Relevance
Irrelevant -> Range -> Expr -> Expr
C.Dot (a -> Range
forall a. HasRange a => a -> Range
getRange a
a) Expr
e
                           Relevance
NonStrict  -> Range -> Expr -> Expr
C.DoubleDot (a -> Range
forall a. HasRange a => a -> Range
getRange a
a) Expr
e
                           Relevance
_          -> 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) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets
        (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ List1 LetBinding
-> (ConOfAbs (List1 LetBinding) -> AbsToCon Expr) -> AbsToCon Expr
forall b.
List1 LetBinding
-> (ConOfAbs (List1 LetBinding) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete List1 LetBinding
ds ((ConOfAbs (List1 LetBinding) -> AbsToCon Expr) -> AbsToCon Expr)
-> (ConOfAbs (List1 LetBinding) -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ \ConOfAbs (List1 LetBinding)
ds' -> do
             Expr
e'  <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
e
             Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> [Declaration] -> Expr -> Expr
C.mkLet (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) (NonEmpty [Declaration] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NonEmpty [Declaration]
ConOfAbs (List1 LetBinding)
ds') Expr
e'

    toConcrete (A.Rec ExprInfo
i RecordAssigns
fs) =
      (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
appBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
        Range -> RecordAssignments -> Expr
C.Rec (ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i) (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)
-> AbsToCon [Either FieldAssignment QName] -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordAssigns -> AbsToCon (ConOfAbs RecordAssigns)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop RecordAssigns
fs

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

    toConcrete (A.ScopedExpr ScopeInfo
_ Expr
e) = Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e
    toConcrete (A.Quote ExprInfo
i) = Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon 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 -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon 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 -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon 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) = Range -> Expr -> Expr
C.Dot Range
r (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) -> AbsToCon Expr -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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} ->
      TacticAttr -> NamedArg Binder -> LamBinding
A.DomainFree (TypedBindingInfo -> TacticAttr
tbTacticAttr TypedBindingInfo
tac) NamedArg Binder
x
    Expr
_ -> LamBinding
b
makeDomainFree LamBinding
b = LamBinding
b

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

    bindToConcrete :: forall b.
FieldAssignment' a
-> (ConOfAbs (FieldAssignment' a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (FieldAssignment Name
name a
a) ConOfAbs (FieldAssignment' a) -> AbsToCon b
ret =
      a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall b. a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a
a ((ConOfAbs a -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ FieldAssignment' (ConOfAbs a) -> AbsToCon b
ConOfAbs (FieldAssignment' a) -> AbsToCon b
ret (FieldAssignment' (ConOfAbs a) -> AbsToCon b)
-> (ConOfAbs a -> FieldAssignment' (ConOfAbs a))
-> ConOfAbs a
-> AbsToCon 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


-- 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 RawName -> NamedName
forall a. Origin -> a -> WithOrigin a
WithOrigin Origin
Inserted
         (Ranged RawName -> NamedName) -> Ranged RawName -> NamedName
forall a b. (a -> b) -> a -> b
$ Range -> RawName -> Ranged RawName
forall a. Range -> a -> Ranged a
Ranged (NamedArg Binder -> Range
forall a. HasRange a => a -> Range
getRange NamedArg Binder
x)
         (RawName -> Ranged RawName) -> RawName -> Ranged RawName
forall a b. (a -> b) -> a -> b
$ Name -> RawName
C.nameToRawName (Name -> RawName) -> Name -> RawName
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 b.
Binder' a -> (ConOfAbs (Binder' a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.Binder Maybe Pattern
p a
a) ConOfAbs (Binder' a) -> AbsToCon b
ret =
    a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall b. a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete a
a ((ConOfAbs a -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs a
a ->
    Maybe Pattern
-> (ConOfAbs (Maybe Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
Maybe Pattern
-> (ConOfAbs (Maybe Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete Maybe Pattern
p ((ConOfAbs (Maybe Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (Maybe Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (Maybe Pattern)
p ->
    ConOfAbs (Binder' a) -> AbsToCon b
ret (ConOfAbs (Binder' a) -> AbsToCon b)
-> ConOfAbs (Binder' a) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Maybe Pattern -> ConOfAbs a -> Binder' (ConOfAbs a)
forall a. Maybe Pattern -> a -> Binder' a
C.Binder Maybe Pattern
ConOfAbs (Maybe Pattern)
p ConOfAbs a
a

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

    bindToConcrete :: forall b.
LamBinding -> (ConOfAbs LamBinding -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.DomainFree TacticAttr
t NamedArg Binder
x) ConOfAbs LamBinding -> AbsToCon b
ret = do
      Maybe Expr
t <- (Expr -> AbsToCon Expr) -> TacticAttr -> AbsToCon (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Expr -> AbsToCon Expr
Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete TacticAttr
t
      let setTac :: BoundName -> BoundName
setTac BoundName
x = BoundName
x { bnameTactic :: Maybe Expr
bnameTactic = Maybe Expr
t }
      NamedArg Binder
-> (ConOfAbs (NamedArg Binder) -> AbsToCon b) -> AbsToCon b
forall b.
NamedArg Binder
-> (ConOfAbs (NamedArg Binder) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (NamedArg Binder -> NamedArg Binder
forceNameIfHidden NamedArg Binder
x) ((ConOfAbs (NamedArg Binder) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (NamedArg Binder) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$
        Maybe LamBinding -> AbsToCon b
ConOfAbs LamBinding -> AbsToCon b
ret (Maybe LamBinding -> AbsToCon b)
-> (NamedArg (Binder' BoundName) -> Maybe LamBinding)
-> NamedArg (Binder' BoundName)
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LamBinding -> Maybe LamBinding
forall a. a -> Maybe a
Just (LamBinding -> Maybe LamBinding)
-> (NamedArg (Binder' BoundName) -> LamBinding)
-> NamedArg (Binder' BoundName)
-> Maybe LamBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Binder' BoundName) -> LamBinding
forall a. NamedArg (Binder' BoundName) -> LamBinding' a
C.DomainFree (NamedArg (Binder' BoundName) -> LamBinding)
-> (NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName))
-> NamedArg (Binder' BoundName)
-> LamBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binder' BoundName -> Binder' BoundName)
-> NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> BoundName) -> Binder' BoundName -> Binder' BoundName
forall a b. (a -> b) -> Binder' a -> Binder' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoundName -> BoundName
setTac)
    bindToConcrete (A.DomainFull TypedBinding
b) ConOfAbs LamBinding -> AbsToCon b
ret = TypedBinding -> (ConOfAbs TypedBinding -> AbsToCon b) -> AbsToCon b
forall b.
TypedBinding -> (ConOfAbs TypedBinding -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete TypedBinding
b ((ConOfAbs TypedBinding -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs TypedBinding -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Maybe LamBinding -> AbsToCon b
ConOfAbs LamBinding -> AbsToCon b
ret (Maybe LamBinding -> AbsToCon b)
-> (Maybe TypedBinding -> Maybe LamBinding)
-> Maybe TypedBinding
-> AbsToCon 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 b.
TypedBinding -> (ConOfAbs TypedBinding -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.TBind Range
r TypedBindingInfo
t List1 (NamedArg Binder)
xs Expr
e) ConOfAbs TypedBinding -> AbsToCon b
ret = do
        Maybe Expr
tac <- (Expr -> AbsToCon Expr) -> TacticAttr -> AbsToCon (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Expr -> AbsToCon Expr
Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (TypedBindingInfo -> TacticAttr
tbTacticAttr TypedBindingInfo
t)
        List1 (NamedArg Binder)
-> (ConOfAbs (List1 (NamedArg Binder)) -> AbsToCon b) -> AbsToCon b
forall b.
List1 (NamedArg Binder)
-> (ConOfAbs (List1 (NamedArg Binder)) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete ((NamedArg Binder -> NamedArg Binder)
-> List1 (NamedArg Binder) -> List1 (NamedArg Binder)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedArg Binder -> NamedArg Binder
forceNameIfHidden List1 (NamedArg Binder)
xs) ((ConOfAbs (List1 (NamedArg Binder)) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (List1 (NamedArg Binder)) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (List1 (NamedArg Binder))
xs -> do
          Expr
e <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
e
          let setTac :: BoundName -> BoundName
setTac BoundName
x = BoundName
x { bnameTactic :: Maybe Expr
bnameTactic = Maybe Expr
tac , bnameIsFinite :: Bool
C.bnameIsFinite = TypedBindingInfo -> Bool
tbFinite TypedBindingInfo
t }
          ConOfAbs TypedBinding -> AbsToCon b
ret (ConOfAbs TypedBinding -> AbsToCon b)
-> ConOfAbs TypedBinding -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ TypedBinding -> Maybe TypedBinding
forall a. a -> Maybe a
Just (TypedBinding -> Maybe TypedBinding)
-> TypedBinding -> Maybe TypedBinding
forall a b. (a -> b) -> a -> b
$ Range
-> List1 (NamedArg (Binder' BoundName)) -> Expr -> TypedBinding
forall e.
Range
-> List1 (NamedArg (Binder' BoundName)) -> e -> TypedBinding' e
C.TBind Range
r ((NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName))
-> List1 (NamedArg (Binder' BoundName))
-> List1 (NamedArg (Binder' BoundName))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Binder' BoundName -> Binder' BoundName)
-> NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> BoundName) -> Binder' BoundName -> Binder' BoundName
forall a b. (a -> b) -> Binder' a -> Binder' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoundName -> BoundName
setTac)) List1 (NamedArg (Binder' BoundName))
ConOfAbs (List1 (NamedArg Binder))
xs) Expr
e
    bindToConcrete (A.TLet Range
r List1 LetBinding
lbs) ConOfAbs TypedBinding -> AbsToCon b
ret =
        List1 LetBinding
-> (ConOfAbs (List1 LetBinding) -> AbsToCon b) -> AbsToCon b
forall b.
List1 LetBinding
-> (ConOfAbs (List1 LetBinding) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete List1 LetBinding
lbs ((ConOfAbs (List1 LetBinding) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (List1 LetBinding) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (List1 LetBinding)
ds -> do
        ConOfAbs TypedBinding -> AbsToCon b
ret (ConOfAbs TypedBinding -> AbsToCon b)
-> ConOfAbs TypedBinding -> AbsToCon 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 b.
LetBinding -> (ConOfAbs LetBinding -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.LetBind LetInfo
i ArgInfo
info BindName
x Expr
t Expr
e) ConOfAbs LetBinding -> AbsToCon b
ret =
        BindName -> (ConOfAbs BindName -> AbsToCon b) -> AbsToCon b
forall b.
BindName -> (ConOfAbs BindName -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete BindName
x ((ConOfAbs BindName -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs BindName -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs BindName
x ->
        do (Expr
t, (RHS
e, [], [], [])) <- (Expr, RHS) -> AbsToCon (ConOfAbs (Expr, RHS))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (Expr
t, Expr -> Maybe Expr -> RHS
A.RHS Expr
e Maybe Expr
forall a. Maybe a
Nothing)
           ConOfAbs LetBinding -> AbsToCon b
ret (ConOfAbs LetBinding -> AbsToCon b)
-> ConOfAbs LetBinding -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Maybe Range -> [Declaration] -> [Declaration]
addInstanceB (if ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
isInstance ArgInfo
info then Range -> Maybe Range
forall a. a -> Maybe a
Just Range
forall a. Range' a
noRange else Maybe Range
forall a. Maybe a
Nothing) ([Declaration] -> [Declaration]) -> [Declaration] -> [Declaration]
forall a b. (a -> b) -> a -> b
$
               [ ArgInfo -> Maybe Expr -> Name -> Expr -> Declaration
C.TypeSig ArgInfo
info Maybe Expr
forall a. Maybe a
Nothing (BoundName -> Name
C.boundName BoundName
ConOfAbs BindName
x) Expr
t
               , LHS -> RHS -> WhereClause' [Declaration] -> Bool -> Declaration
C.FunClause (Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS (QName -> Pattern
C.IdentP (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
               ]
    -- TODO: bind variables
    bindToConcrete (LetPatBind LetInfo
i Pattern
p Expr
e) ConOfAbs LetBinding -> AbsToCon b
ret = do
        Pattern
p <- Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Pattern
p
        Expr
e <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e
        ConOfAbs LetBinding -> AbsToCon b
ret [ LHS -> RHS -> WhereClause' [Declaration] -> Bool -> Declaration
C.FunClause (Pattern -> [RewriteEqn] -> [WithExpr] -> LHS
C.LHS Pattern
p [] []) (Expr -> RHS
forall e. e -> RHS' e
C.RHS Expr
e) WhereClause' [Declaration]
forall decls. WhereClause' decls
NoWhere Bool
False ]
    bindToConcrete (LetApply ModuleInfo
i ModuleName
x ModuleApplication
modapp ScopeCopyInfo
_ ImportDirective
_) ConOfAbs LetBinding -> AbsToCon b
ret = do
      Name
x' <- QName -> Name
unqualify (QName -> Name) -> AbsToCon QName -> AbsToCon Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
      ModuleApplication
modapp <- ModuleApplication -> AbsToCon (ConOfAbs ModuleApplication)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleApplication
modapp
      let r :: Range
r = ModuleApplication -> Range
forall a. HasRange a => a -> Range
getRange ModuleApplication
modapp
          open :: OpenShortHand
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
dir  = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir{ importDirRange :: Range
importDirRange = Range
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.
      (Env -> Env) -> AbsToCon b -> AbsToCon b
forall a. (Env -> Env) -> AbsToCon a -> AbsToCon a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ModuleName -> ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' ModuleName
x ImportDirective
dir Scope -> Scope
forall a. a -> a
id) (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$
        ConOfAbs LetBinding -> AbsToCon b
ret [ Range
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> Declaration
C.ModuleMacro (ModuleInfo -> Range
forall a. HasRange a => a -> Range
getRange ModuleInfo
i) Name
x' ModuleApplication
modapp OpenShortHand
open ImportDirective
dir ]
    bindToConcrete (LetOpen ModuleInfo
i ModuleName
x ImportDirective
_) ConOfAbs LetBinding -> AbsToCon b
ret = do
      QName
x' <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
      let dir :: ImportDirective
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
      (Env -> Env) -> AbsToCon b -> AbsToCon b
forall a. (Env -> Env) -> AbsToCon a -> AbsToCon a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ModuleName -> ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' ModuleName
x ImportDirective
dir Scope -> Scope
restrictPrivate) (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$
            ConOfAbs LetBinding -> AbsToCon b
ret [ Range -> QName -> ImportDirective -> Declaration
C.Open (ModuleInfo -> Range
forall a. HasRange a => a -> Range
getRange ModuleInfo
i) QName
x' ImportDirective
dir ]
    bindToConcrete (LetDeclaredVariable BindName
_) ConOfAbs LetBinding -> AbsToCon b
ret =
      -- Note that the range of the declaration site is dropped.
      ConOfAbs LetBinding -> AbsToCon b
ret []

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

  bindToConcrete :: forall b.
WhereDeclarations
-> (ConOfAbs WhereDeclarations -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.WhereDecls Maybe ModuleName
_ Bool
_ Maybe Declaration
Nothing) ConOfAbs WhereDeclarations -> AbsToCon b
ret = ConOfAbs WhereDeclarations -> AbsToCon b
ret WhereClause' [Declaration]
ConOfAbs WhereDeclarations
forall decls. WhereClause' decls
C.NoWhere
  bindToConcrete (A.WhereDecls (Just ModuleName
am) Bool
False (Just (A.Section Range
_ ModuleName
_ GeneralizeTelescope
_ [Declaration]
ds))) ConOfAbs WhereDeclarations -> AbsToCon b
ret = do
    [Declaration]
ds' <- [Declaration] -> AbsToCon [Declaration]
declsToConcrete [Declaration]
ds
    Name
cm  <- QName -> Name
unqualify (QName -> Name) -> AbsToCon QName -> AbsToCon Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> AbsToCon QName
lookupModule ModuleName
am
    -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere
    -- Should not really matter for printing...
    let wh' :: WhereClause' [Declaration]
wh' = (if Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
cm then Range -> [Declaration] -> WhereClause' [Declaration]
forall decls. Range -> decls -> WhereClause' decls
AnyWhere Range
forall a. Range' a
noRange else Range
-> Name -> Access -> [Declaration] -> WhereClause' [Declaration]
forall decls.
Range -> Name -> Access -> decls -> WhereClause' decls
SomeWhere Range
forall a. Range' a
noRange Name
cm Access
PublicAccess) ([Declaration] -> WhereClause' [Declaration])
-> [Declaration] -> WhereClause' [Declaration]
forall a b. (a -> b) -> a -> b
$ [Declaration]
ds'
    (Env -> Env) -> AbsToCon b -> AbsToCon b
forall a. (Env -> Env) -> AbsToCon a -> AbsToCon a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ModuleName -> ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' ModuleName
am ImportDirective
forall n m. ImportDirective' n m
defaultImportDir Scope -> Scope
forall a. a -> a
id) (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ ConOfAbs WhereDeclarations -> AbsToCon b
ret WhereClause' [Declaration]
ConOfAbs WhereDeclarations
wh'
  bindToConcrete (A.WhereDecls Maybe ModuleName
_ Bool
_ (Just Declaration
d)) ConOfAbs WhereDeclarations -> AbsToCon b
ret =
    WhereClause' [Declaration] -> AbsToCon b
ConOfAbs WhereDeclarations -> AbsToCon b
ret (WhereClause' [Declaration] -> AbsToCon b)
-> ([Declaration] -> WhereClause' [Declaration])
-> [Declaration]
-> AbsToCon 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] -> AbsToCon b)
-> AbsToCon [Declaration] -> AbsToCon b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Declaration -> AbsToCon (ConOfAbs Declaration)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Declaration
d

mergeSigAndDef :: [C.Declaration] -> [C.Declaration]
mergeSigAndDef :: [Declaration] -> [Declaration]
mergeSigAndDef (C.RecordSig Range
_ Name
x [LamBinding]
bs Expr
e : C.RecordDef Range
r Name
y RecordDirectives
dir [LamBinding]
_ [Declaration]
fs : [Declaration]
ds)
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Name
-> RecordDirectives
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Name
y RecordDirectives
dir [LamBinding]
bs Expr
e [Declaration]
fs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (C.DataSig Range
_ 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
-> Name -> [LamBinding] -> Expr -> [Declaration] -> Declaration
C.Data Range
r 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 :: ScopeInfo
currentScope = Lens' (Map ModuleName Scope) ScopeInfo
-> LensSet (Map ModuleName Scope) ScopeInfo
forall i o. Lens' i o -> LensSet i o
set (Map ModuleName Scope -> f (Map ModuleName Scope))
-> ScopeInfo -> f ScopeInfo
Lens' (Map ModuleName Scope) ScopeInfo
scopeModules Map ModuleName Scope
mods' ScopeInfo
sInfo}
  where sInfo :: ScopeInfo
sInfo = Env -> ScopeInfo
currentScope Env
env
        amod :: ModuleName
amod  = ScopeInfo
sInfo ScopeInfo -> Lens' ModuleName ScopeInfo -> ModuleName
forall o i. o -> Lens' i o -> i
^. (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ModuleName ScopeInfo
scopeCurrent
        mods :: Map ModuleName Scope
mods  = ScopeInfo
sInfo ScopeInfo
-> Lens' (Map ModuleName Scope) ScopeInfo -> Map ModuleName Scope
forall o i. o -> Lens' i o -> i
^. (Map ModuleName Scope -> f (Map ModuleName Scope))
-> ScopeInfo -> f ScopeInfo
Lens' (Map ModuleName Scope) ScopeInfo
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 :: [A.Declaration] -> AbsToCon [C.Declaration]
declsToConcrete :: [Declaration] -> AbsToCon [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])
-> AbsToCon [[Declaration]] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> AbsToCon (ConOfAbs [Declaration])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [Declaration]
ds

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

    toConcrete :: RHS -> AbsToCon (ConOfAbs RHS)
toConcrete (A.RHS Expr
e (Just Expr
c)) = (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> AbsToCon 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
      Expr
e <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e
      (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> RHS
forall e. e -> RHS' e
C.RHS Expr
e, [], [], [])
    toConcrete RHS
A.AbsurdRHS = (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
forall e. RHS' e
C.AbsurdRHS, [], [], [])
    toConcrete (A.WithRHS QName
_ [WithExpr]
es [Clause]
cs) = do
      [WithExpr]
es <- do [Named BindName (Arg Expr)]
es <- [WithExpr] -> AbsToCon (ConOfAbs [WithExpr])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [WithExpr]
es
               [Named BindName (Arg Expr)]
-> (Named BindName (Arg Expr) -> AbsToCon WithExpr)
-> AbsToCon [WithExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Named BindName (Arg Expr)]
es ((Named BindName (Arg Expr) -> AbsToCon WithExpr)
 -> AbsToCon [WithExpr])
-> (Named BindName (Arg Expr) -> AbsToCon WithExpr)
-> AbsToCon [WithExpr]
forall a b. (a -> b) -> a -> b
$ \ (Named Maybe BindName
n Arg Expr
e) -> do
                 Maybe BoundName
n <- (BindName -> AbsToCon BoundName)
-> Maybe BindName -> AbsToCon (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 -> AbsToCon BoundName
BindName -> AbsToCon (ConOfAbs BindName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Maybe BindName
n
                 WithExpr -> AbsToCon WithExpr
forall a. a -> AbsToCon a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithExpr -> AbsToCon WithExpr) -> WithExpr -> AbsToCon WithExpr
forall a b. (a -> b) -> a -> b
$ Maybe Name -> Arg Expr -> WithExpr
forall name a. Maybe name -> a -> Named name a
Named (BoundName -> Name
C.boundName (BoundName -> Name) -> Maybe BoundName -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BoundName
n) Arg Expr
e
      [Declaration]
cs <- AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a. AbsToCon a -> AbsToCon a
noTakenNames (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> AbsToCon [[Declaration]] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Clause] -> AbsToCon (ConOfAbs [Clause])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [Clause]
cs
      (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
forall e. RHS' e
C.AbsurdRHS, [], [WithExpr]
es, [Declaration]
cs)
    toConcrete (A.RewriteRHS [RewriteEqn]
xeqs [ProblemEq]
_spats RHS
rhs WhereDeclarations
wh) = do
      [Declaration]
wh <- AbsToCon [Declaration]
-> (Declaration -> AbsToCon [Declaration])
-> Maybe Declaration
-> AbsToCon [Declaration]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return []) Declaration -> AbsToCon [Declaration]
Declaration -> AbsToCon (ConOfAbs Declaration)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (Maybe Declaration -> AbsToCon [Declaration])
-> Maybe Declaration -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ WhereDeclarations -> Maybe Declaration
A.whereDecls WhereDeclarations
wh
      (RHS
rhs, [RewriteEqn]
eqs', [WithExpr]
es, [Declaration]
whs) <- RHS -> AbsToCon (ConOfAbs RHS)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete RHS
rhs
      Bool -> AbsToCon () -> AbsToCon ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RewriteEqn] -> Bool
forall a. Null a => a -> Bool
null [RewriteEqn]
eqs') AbsToCon ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      [RewriteEqn]
eqs <- [RewriteEqn] -> AbsToCon (ConOfAbs [RewriteEqn])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [RewriteEqn]
xeqs
      (RHS, [RewriteEqn], [WithExpr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithExpr], [Declaration])
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
rhs, [RewriteEqn]
eqs, [WithExpr]
es, [Declaration]
wh [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
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 :: RewriteEqn' qn BindName p a
-> AbsToCon (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))
-> AbsToCon (List1 ((), ConOfAbs a))
-> AbsToCon (RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((qn, a) -> AbsToCon ((), ConOfAbs a))
-> List1 (qn, a) -> AbsToCon (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) -> AbsToCon ((), ConOfAbs a)
((), a) -> AbsToCon (ConOfAbs ((), a))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (((), a) -> AbsToCon ((), ConOfAbs a))
-> ((qn, a) -> ((), a)) -> (qn, a) -> AbsToCon ((), 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))
-> AbsToCon (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
-> AbsToCon (ConOfAbs (RewriteEqn' qn BindName p a))
forall a b. (a -> b) -> AbsToCon a -> AbsToCon 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 ()) (AbsToCon (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
 -> AbsToCon (ConOfAbs (RewriteEqn' qn BindName p a)))
-> AbsToCon (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
-> AbsToCon (ConOfAbs (RewriteEqn' qn BindName p a))
forall a b. (a -> b) -> a -> b
$ List1 (Named BindName (p, a))
-> (Named BindName (p, a)
    -> AbsToCon (Named Name (ConOfAbs p, ConOfAbs a)))
-> AbsToCon (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)
  -> AbsToCon (Named Name (ConOfAbs p, ConOfAbs a)))
 -> AbsToCon (List1 (Named Name (ConOfAbs p, ConOfAbs a))))
-> (Named BindName (p, a)
    -> AbsToCon (Named Name (ConOfAbs p, ConOfAbs a)))
-> AbsToCon (List1 (Named Name (ConOfAbs p, ConOfAbs a)))
forall a b. (a -> b) -> a -> b
$ \ (Named Maybe BindName
n (p, a)
pe) -> do
      (ConOfAbs p, ConOfAbs a)
pe <- (p, a) -> AbsToCon (ConOfAbs (p, a))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (p, a)
pe
      Maybe Name
n  <- Maybe BindName -> AbsToCon (ConOfAbs (Maybe BindName))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Maybe BindName
n
      Named Name (ConOfAbs p, ConOfAbs a)
-> AbsToCon (Named Name (ConOfAbs p, ConOfAbs a))
forall a. a -> AbsToCon a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Named Name (ConOfAbs p, ConOfAbs a)
 -> AbsToCon (Named Name (ConOfAbs p, ConOfAbs a)))
-> Named Name (ConOfAbs p, ConOfAbs a)
-> AbsToCon (Named Name (ConOfAbs p, ConOfAbs a))
forall a b. (a -> b) -> a -> b
$ Maybe Name
-> (ConOfAbs p, ConOfAbs a) -> Named Name (ConOfAbs p, ConOfAbs a)
forall name a. Maybe name -> a -> Named name a
Named Maybe Name
n (ConOfAbs p, ConOfAbs a)
pe

instance ToConcrete (Maybe A.BindName) where
  type ConOfAbs (Maybe A.BindName) = Maybe C.Name
  toConcrete :: Maybe BindName -> AbsToCon (ConOfAbs (Maybe BindName))
toConcrete = (BindName -> AbsToCon Name)
-> Maybe BindName -> AbsToCon (Maybe Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (BoundName -> Name
C.boundName (BoundName -> Name)
-> (BindName -> AbsToCon BoundName) -> BindName -> AbsToCon Name
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> BindName -> AbsToCon BoundName
BindName -> AbsToCon (ConOfAbs BindName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete)

instance ToConcrete (Maybe A.QName) where
  type ConOfAbs (Maybe A.QName) = Maybe C.Name

  toConcrete :: Maybe QName -> AbsToCon (ConOfAbs (Maybe QName))
toConcrete = (QName -> AbsToCon Name) -> Maybe QName -> AbsToCon (Maybe 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) -> Maybe a -> m (Maybe b)
mapM (Name -> AbsToCon Name
Name -> AbsToCon (ConOfAbs Name)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (Name -> AbsToCon Name)
-> (QName -> Name) -> QName -> AbsToCon Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName)

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

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

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

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

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

  toConcrete :: ModuleApplication -> AbsToCon (ConOfAbs ModuleApplication)
toConcrete (A.SectionApp [TypedBinding]
tel ModuleName
y [NamedArg Expr]
es) = do
    QName
y  <- Precedence -> ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
FunctionCtx ModuleName
y
    [TypedBinding]
-> (ConOfAbs [TypedBinding] -> AbsToCon ModuleApplication)
-> AbsToCon ModuleApplication
forall b.
[TypedBinding]
-> (ConOfAbs [TypedBinding] -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete [TypedBinding]
tel ((ConOfAbs [TypedBinding] -> AbsToCon ModuleApplication)
 -> AbsToCon ModuleApplication)
-> (ConOfAbs [TypedBinding] -> AbsToCon ModuleApplication)
-> AbsToCon ModuleApplication
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [TypedBinding]
tel -> do
      [NamedArg Expr]
es <- Precedence
-> [NamedArg Expr] -> AbsToCon (ConOfAbs [NamedArg Expr])
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ [NamedArg Expr]
es
      let r :: Range
r = QName -> [NamedArg Expr] -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange QName
y [NamedArg Expr]
es
      ModuleApplication -> AbsToCon ModuleApplication
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleApplication -> AbsToCon ModuleApplication)
-> ModuleApplication -> AbsToCon ModuleApplication
forall a b. (a -> b) -> a -> b
$ Range -> Telescope -> Expr -> ModuleApplication
C.SectionApp Range
r ([Maybe TypedBinding] -> Telescope
forall a. [Maybe a] -> [a]
catMaybes [Maybe TypedBinding]
ConOfAbs [TypedBinding]
tel) ((Expr -> NamedArg Expr -> Expr) -> Expr -> [NamedArg Expr] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Range -> Expr -> NamedArg Expr -> Expr
C.App Range
r) (QName -> Expr
C.Ident QName
y) [NamedArg Expr]
es)

  toConcrete (A.RecordModuleInstance ModuleName
recm) = do
    QName
recm <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
recm
    ModuleApplication -> AbsToCon ModuleApplication
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleApplication -> AbsToCon ModuleApplication)
-> ModuleApplication -> AbsToCon ModuleApplication
forall a b. (a -> b) -> a -> b
$ Range -> QName -> ModuleApplication
C.RecordModuleInstance (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
recm) QName
recm

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

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

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

  toConcrete (A.Generalize Set QName
s DefInfo
i ArgInfo
j QName
x Expr
t) = do
    Name
x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> AbsToCon QName -> AbsToCon Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    Maybe Expr
tac <- (Expr -> AbsToCon Expr) -> TacticAttr -> AbsToCon (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Expr -> AbsToCon Expr
Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (DefInfo -> TacticAttr
forall t. DefInfo' t -> Maybe t
defTactic DefInfo
i)
    DefInfo -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withAbstractPrivate DefInfo
i (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$
      DefInfo -> Name -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withInfixDecl DefInfo
i Name
x'  (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ do
      Expr
t' <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
t
      [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [Range -> [Declaration] -> Declaration
C.Generalize (DefInfo -> Range
forall a. HasRange a => a -> Range
getRange DefInfo
i) [ArgInfo -> Maybe Expr -> Name -> Expr -> Declaration
C.TypeSig ArgInfo
j Maybe Expr
tac Name
x' (Expr -> Declaration) -> Expr -> Declaration
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
C.Generalized Expr
t']]

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

  toConcrete (A.Primitive DefInfo
i QName
x Arg Expr
t) = do
    Name
x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> AbsToCon QName -> AbsToCon Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    DefInfo -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withAbstractPrivate DefInfo
i (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$
      DefInfo -> Name -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withInfixDecl DefInfo
i Name
x'  (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ do
      Arg Expr
t' <- (Expr -> AbsToCon Expr) -> Arg Expr -> AbsToCon (Arg Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse Expr -> AbsToCon Expr
Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Arg Expr
t
      [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [Range -> [Declaration] -> Declaration
C.Primitive (DefInfo -> Range
forall a. HasRange a => a -> Range
getRange DefInfo
i) [ArgInfo -> Maybe Expr -> Name -> Expr -> Declaration
C.TypeSig (Arg Expr -> ArgInfo
forall e. Arg e -> ArgInfo
argInfo Arg Expr
t') Maybe Expr
forall a. Maybe a
Nothing Name
x' (Arg Expr -> Expr
forall e. Arg e -> e
unArg Arg Expr
t')]]
        -- Primitives are always relevant.

  toConcrete (A.FunDef DefInfo
i QName
_ Delayed
_ [Clause]
cs) =
    DefInfo -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withAbstractPrivate DefInfo
i (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> AbsToCon [[Declaration]] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Clause] -> AbsToCon (ConOfAbs [Clause])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [Clause]
cs

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

  toConcrete (A.DataDef DefInfo
i QName
x UniverseCheck
uc DataDefParams
bs [Declaration]
cs) =
    DefInfo -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withAbstractPrivate DefInfo
i (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$
    [LamBinding]
-> (ConOfAbs [LamBinding] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall b.
[LamBinding] -> (ConOfAbs [LamBinding] -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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] -> AbsToCon [Declaration])
 -> AbsToCon [Declaration])
-> (ConOfAbs [LamBinding] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [LamBinding]
tel' -> do
      (Name
x',[Declaration]
cs') <- (QName -> Name) -> (QName, [Declaration]) -> (Name, [Declaration])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first QName -> Name
unsafeQNameToName ((QName, [Declaration]) -> (Name, [Declaration]))
-> AbsToCon (QName, [Declaration])
-> AbsToCon (Name, [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QName, [Constr Declaration])
-> AbsToCon (ConOfAbs (QName, [Constr Declaration]))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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)
      [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range -> Name -> [LamBinding] -> [Declaration] -> Declaration
C.DataDef (DefInfo -> Range
forall a. HasRange a => a -> Range
getRange DefInfo
i) Name
x' ([Maybe LamBinding] -> [LamBinding]
forall a. [Maybe a] -> [a]
catMaybes [Maybe LamBinding]
ConOfAbs [LamBinding]
tel') [Declaration]
cs' ]

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

  toConcrete (A.RecDef  DefInfo
i QName
x UniverseCheck
uc RecordDirectives
dir DataDefParams
bs Expr
t [Declaration]
cs) =
    DefInfo -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withAbstractPrivate DefInfo
i (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$
    [LamBinding]
-> (ConOfAbs [LamBinding] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall b.
[LamBinding] -> (ConOfAbs [LamBinding] -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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] -> AbsToCon [Declaration])
 -> AbsToCon [Declaration])
-> (ConOfAbs [LamBinding] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [LamBinding]
tel' -> do
      (Name
x',[Declaration]
cs') <- (QName -> Name) -> (QName, [Declaration]) -> (Name, [Declaration])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first QName -> Name
unsafeQNameToName ((QName, [Declaration]) -> (Name, [Declaration]))
-> AbsToCon (QName, [Declaration])
-> AbsToCon (Name, [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QName, [Constr Declaration])
-> AbsToCon (ConOfAbs (QName, [Constr Declaration]))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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)
      [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> Name
-> RecordDirectives
-> [LamBinding]
-> [Declaration]
-> Declaration
C.RecordDef (DefInfo -> Range
forall a. HasRange a => a -> Range
getRange DefInfo
i) Name
x' (RecordDirectives
dir { recConstructor :: Maybe (Name, IsInstance)
recConstructor = Maybe (Name, IsInstance)
forall a. Maybe a
Nothing }) ([Maybe LamBinding] -> [LamBinding]
forall a. [Maybe a] -> [a]
catMaybes [Maybe LamBinding]
ConOfAbs [LamBinding]
tel') [Declaration]
cs' ]

  toConcrete (A.Mutual MutualInfo
i [Declaration]
ds) = [Declaration] -> AbsToCon [Declaration]
declsToConcrete [Declaration]
ds

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

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

  toConcrete (A.Import ModuleInfo
i ModuleName
x ImportDirective
_) = do
    QName
x <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
    let open :: OpenShortHand
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
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
    [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> Declaration
C.Import (ModuleInfo -> Range
forall a. HasRange a => a -> Range
getRange ModuleInfo
i) QName
x Maybe AsName
forall a. Maybe a
Nothing OpenShortHand
open ImportDirective
dir]

  toConcrete (A.Pragma Range
i Pragma
p)     = do
    Pragma
p <- RangeAndPragma -> AbsToCon (ConOfAbs RangeAndPragma)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (RangeAndPragma -> AbsToCon (ConOfAbs RangeAndPragma))
-> RangeAndPragma -> AbsToCon (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
    [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Declaration
C.Pragma Pragma
p]

  toConcrete (A.Open ModuleInfo
i ModuleName
x ImportDirective
_) = do
    QName
x <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
    [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return [Range -> QName -> ImportDirective -> Declaration
C.Open (ModuleInfo -> Range
forall a. HasRange a => a -> Range
getRange ModuleInfo
i) QName
x ImportDirective
forall n m. ImportDirective' n m
defaultImportDir]

  toConcrete (A.PatternSynDef QName
x [Arg BindName]
xs Pattern' Void
p) = do
    C.QName Name
x <- QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    [Arg Name]
-> (ConOfAbs [Arg Name] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall b.
[Arg Name] -> (ConOfAbs [Arg Name] -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete ((Arg BindName -> Arg Name) -> [Arg BindName] -> [Arg Name]
forall a b. (a -> b) -> [a] -> [b]
map ((BindName -> Name) -> Arg BindName -> Arg Name
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BindName -> Name
A.unBind) [Arg BindName]
xs) ((ConOfAbs [Arg Name] -> AbsToCon [Declaration])
 -> AbsToCon [Declaration])
-> (ConOfAbs [Arg Name] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs [Arg 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 -> [Arg Name] -> Pattern -> Declaration
C.PatternSyn (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Name
x [Arg Name]
ConOfAbs [Arg Name]
xs (Pattern -> [Declaration])
-> AbsToCon Pattern -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        AbsToCon Pattern -> AbsToCon Pattern
forall a. AbsToCon a -> AbsToCon a
dontFoldPatternSynonyms (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (Pattern' Void -> Pattern
forall (f :: * -> *) a. Functor f => f Void -> f a
vacuous Pattern' Void
p :: A.Pattern)

  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__
    [Name]
xs <- (QName -> AbsToCon Name) -> [QName] -> AbsToCon [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 -> AbsToCon Name
forall {m :: * -> *}. Monad m => QName -> m Name
unqual (QName -> AbsToCon Name)
-> (QName -> AbsToCon QName) -> QName -> AbsToCon Name
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< QName -> AbsToCon QName
QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete) [QName]
xs
    (Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[]) (Declaration -> [Declaration])
-> (Expr -> Declaration) -> Expr -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Name] -> Expr -> Declaration
C.UnquoteDecl ([DefInfo] -> Range
forall a. HasRange a => a -> Range
getRange [DefInfo]
i) [Name]
xs (Expr -> [Declaration]) -> AbsToCon Expr -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
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__
    [Name]
xs <- (QName -> AbsToCon Name) -> [QName] -> AbsToCon [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 -> AbsToCon Name
forall {m :: * -> *}. Monad m => QName -> m Name
unqual (QName -> AbsToCon Name)
-> (QName -> AbsToCon QName) -> QName -> AbsToCon Name
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< QName -> AbsToCon QName
QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete) [QName]
xs
    (Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[]) (Declaration -> [Declaration])
-> (Expr -> Declaration) -> Expr -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Name] -> Expr -> Declaration
C.UnquoteDef ([DefInfo] -> Range
forall a. HasRange a => a -> Range
getRange [DefInfo]
i) [Name]
xs (Expr -> [Declaration]) -> AbsToCon Expr -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e

  toConcrete (A.UnquoteData [DefInfo]
i QName
xs UniverseCheck
uc [DefInfo]
j [QName]
cs Expr
e) = AbsToCon [Declaration]
AbsToCon (ConOfAbs Declaration)
forall a. HasCallStack => a
__IMPOSSIBLE__


data RangeAndPragma = RangeAndPragma Range A.Pragma

instance ToConcrete RangeAndPragma where
  type ConOfAbs RangeAndPragma = C.Pragma

  toConcrete :: RangeAndPragma -> AbsToCon (ConOfAbs RangeAndPragma)
toConcrete (RangeAndPragma Range
r Pragma
p) = case Pragma
p of
    A.OptionsPragma [RawName]
xs  -> Pragma -> AbsToCon Pragma
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> AbsToCon Pragma) -> Pragma -> AbsToCon Pragma
forall a b. (a -> b) -> a -> b
$ Range -> [RawName] -> Pragma
C.OptionsPragma Range
r [RawName]
xs
    A.BuiltinPragma Ranged RawName
b ResolvedName
x       -> Range -> Ranged RawName -> QName -> Pragma
C.BuiltinPragma Range
r Ranged RawName
b (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvedName -> AbsToCon (ConOfAbs ResolvedName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ResolvedName
x
    A.BuiltinNoDefPragma Ranged RawName
b KindOfName
_kind QName
x -> Range -> Ranged RawName -> QName -> Pragma
C.BuiltinPragma Range
r Ranged RawName
b (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    A.RewritePragma Range
r' [QName]
x      -> Range -> Range -> [QName] -> Pragma
C.RewritePragma Range
r Range
r' ([QName] -> Pragma) -> AbsToCon [QName] -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QName] -> AbsToCon (ConOfAbs [QName])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [QName]
x
    A.CompilePragma Ranged RawName
b QName
x RawName
s -> do
      QName
x <- QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
      Pragma -> AbsToCon Pragma
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> AbsToCon Pragma) -> Pragma -> AbsToCon Pragma
forall a b. (a -> b) -> a -> b
$ Range -> Ranged RawName -> QName -> RawName -> Pragma
C.CompilePragma Range
r Ranged RawName
b QName
x RawName
s
    A.StaticPragma QName
x -> Range -> QName -> Pragma
C.StaticPragma Range
r (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    A.InjectivePragma QName
x -> Range -> QName -> Pragma
C.InjectivePragma Range
r (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    A.InlinePragma Bool
b QName
x -> Range -> Bool -> QName -> Pragma
C.InlinePragma Range
r Bool
b (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    A.NotProjectionLikePragma QName
q -> Range -> QName -> Pragma
C.NotProjectionLikePragma Range
r (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
q
    A.EtaPragma QName
x    -> Range -> QName -> Pragma
C.EtaPragma    Range
r (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    A.DisplayPragma QName
f [NamedArg Pattern]
ps Expr
rhs ->
      Range -> Pattern -> Expr -> Pragma
C.DisplayPragma Range
r (Pattern -> Expr -> Pragma)
-> AbsToCon Pattern -> AbsToCon (Expr -> Pragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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) AbsToCon (Expr -> Pragma) -> AbsToCon Expr -> AbsToCon Pragma
forall a b. AbsToCon (a -> b) -> AbsToCon a -> AbsToCon b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
rhs

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

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

  bindToConcrete :: forall b.
SpineLHS -> (ConOfAbs SpineLHS -> AbsToCon b) -> AbsToCon b
bindToConcrete SpineLHS
lhs = LHS -> (ConOfAbs LHS -> AbsToCon b) -> AbsToCon b
forall b. LHS -> (ConOfAbs LHS -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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 b. LHS -> (ConOfAbs LHS -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.LHS LHSInfo
i LHSCore
lhscore) ConOfAbs LHS -> AbsToCon b
ret = do
      Precedence
-> LHSCore -> (ConOfAbs LHSCore -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
Precedence -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcreteCtx Precedence
TopCtx LHSCore
lhscore ((ConOfAbs LHSCore -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs LHSCore -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs LHSCore
lhs ->
          ConOfAbs LHS -> AbsToCon b
ret (ConOfAbs LHS -> AbsToCon b) -> ConOfAbs LHS -> AbsToCon 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 b. LHSCore -> (ConOfAbs LHSCore -> AbsToCon b) -> AbsToCon b
bindToConcrete = Pattern -> (Pattern -> AbsToCon b) -> AbsToCon b
Pattern -> (ConOfAbs Pattern -> AbsToCon b) -> AbsToCon b
forall b. Pattern -> (ConOfAbs Pattern -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> (Pattern -> AbsToCon b) -> AbsToCon b)
-> (LHSCore -> Pattern)
-> LHSCore
-> (Pattern -> AbsToCon b)
-> AbsToCon 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 b.
FreshenName -> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
bindToConcrete (FreshenName BindName{ unBind :: BindName -> Name
unBind = Name
x }) ConOfAbs FreshenName -> AbsToCon b
ret = Name -> (ConOfAbs Name -> AbsToCon b) -> AbsToCon b
forall b. Name -> (ConOfAbs Name -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete Name
x ((ConOfAbs Name -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs Name -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs Name
y -> ConOfAbs FreshenName -> AbsToCon b
ret Name
x { nameConcrete :: Name
nameConcrete = Name
ConOfAbs Name
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 b.
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
bindToConcrete (UserPattern Pattern
p) ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret = do
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.pat" VerboseLevel
100 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"binding pattern (pass 1)" RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Pattern -> RawName
forall a. Show a => a -> RawName
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 -> AbsToCon b -> AbsToCon b
forall a. Name -> AbsToCon a -> AbsToCon a
bindName' Name
x (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (ConOfAbs (UserPattern Pattern) -> AbsToCon b)
-> ConOfAbs (UserPattern Pattern) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP BindName
bx
          NameInScope
C.NotInScope       -> Name -> (Name -> AbsToCon b) -> AbsToCon b
forall a. Name -> (Name -> AbsToCon a) -> AbsToCon a
bindName Name
x ((Name -> AbsToCon b) -> AbsToCon b)
-> (Name -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \Name
y ->
                                ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (ConOfAbs (UserPattern Pattern) -> AbsToCon b)
-> ConOfAbs (UserPattern Pattern) -> AbsToCon 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 :: Name
nameConcrete = Name
y }
      A.WildP{}              -> ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.ProjP{}              -> ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.AbsurdP{}            -> ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.LitP{}               -> ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.DotP{}               -> ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
      A.EqualP{}             -> ConOfAbs (UserPattern Pattern) -> AbsToCon 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) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
        | Bool
otherwise          -> [UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall b.
[UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[UserPattern (NamedArg Pattern)]
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [UserPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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 PatInfo
i [FieldAssignment' Pattern]
args          -> [FieldAssignment' (UserPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (UserPattern Pattern)]
    -> AbsToCon b)
-> AbsToCon b
forall b.
[FieldAssignment' (UserPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (UserPattern Pattern)]
    -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [FieldAssignment' (UserPattern Pattern)]
    -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP PatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> Name -> AbsToCon b -> AbsToCon b
forall a. Name -> AbsToCon a -> AbsToCon a
bindName' (BindName -> Name
unBind BindName
x) (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$
                                UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (UserPattern Pattern)
p ->
                                ConOfAbs (UserPattern Pattern) -> AbsToCon 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) -> AbsToCon b) -> AbsToCon b
forall b.
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> (Pattern -> Pattern) -> Pattern -> AbsToCon 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
      A.AnnP PatInfo
i Expr
a Pattern
p           -> UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> (Pattern -> Pattern) -> Pattern -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> Expr -> Pattern -> Pattern
forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
i Expr
a

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

  bindToConcrete :: forall b.
UserPattern (NamedArg Pattern)
-> (ConOfAbs (UserPattern (NamedArg Pattern)) -> AbsToCon b)
-> AbsToCon b
bindToConcrete (UserPattern NamedArg Pattern
np) ConOfAbs (UserPattern (NamedArg Pattern)) -> AbsToCon b
ret =
    case NamedArg Pattern -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
np of
      Origin
CaseSplit -> ConOfAbs (UserPattern (NamedArg Pattern)) -> AbsToCon b
ret NamedArg Pattern
ConOfAbs (UserPattern (NamedArg Pattern))
np
      Origin
_         -> Arg (Named NamedName (UserPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (UserPattern Pattern)))
    -> AbsToCon b)
-> AbsToCon b
forall b.
Arg (Named NamedName (UserPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (UserPattern Pattern)))
    -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)))
-> AbsToCon b
ConOfAbs (UserPattern (NamedArg Pattern)) -> AbsToCon 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 b.
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
bindToConcrete (SplitPattern Pattern
p) ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret = do
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.pat" VerboseLevel
100 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"binding pattern (pass 2a)" RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Pattern -> RawName
forall a. Show a => a -> RawName
show Pattern
p
    case Pattern
p of
      A.VarP BindName
x               -> ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.WildP{}              -> ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.ProjP{}              -> ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.AbsurdP{}            -> ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.LitP{}               -> ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.DotP{}               -> ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (SplitPattern Pattern)
p
      A.EqualP{}             -> ConOfAbs (SplitPattern Pattern) -> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[SplitPattern (NamedArg Pattern)]
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [SplitPattern (NamedArg Pattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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 PatInfo
i [FieldAssignment' Pattern]
args          -> [FieldAssignment' (SplitPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)]
    -> AbsToCon b)
-> AbsToCon b
forall b.
[FieldAssignment' (SplitPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)]
    -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)]
    -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP PatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
p)  ((ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (SplitPattern Pattern)
p ->
                                ConOfAbs (SplitPattern Pattern) -> AbsToCon 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) -> AbsToCon b) -> AbsToCon b
forall b.
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
p) ((ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> (Pattern -> Pattern) -> Pattern -> AbsToCon 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
      A.AnnP PatInfo
i Expr
a Pattern
p           -> SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
p) ((ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs (SplitPattern Pattern) -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> (Pattern -> Pattern) -> Pattern -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> Expr -> Pattern -> Pattern
forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
i Expr
a

instance ToConcrete (SplitPattern (NamedArg A.Pattern)) where
  type ConOfAbs (SplitPattern (NamedArg A.Pattern)) = NamedArg A.Pattern
  bindToConcrete :: forall b.
SplitPattern (NamedArg Pattern)
-> (ConOfAbs (SplitPattern (NamedArg Pattern)) -> AbsToCon b)
-> AbsToCon b
bindToConcrete (SplitPattern NamedArg Pattern
np) ConOfAbs (SplitPattern (NamedArg Pattern)) -> AbsToCon 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)) -> AbsToCon b)
-> AbsToCon b
forall b.
Arg (Named NamedName BindingPattern)
-> (ConOfAbs (Arg (Named NamedName BindingPattern)) -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)) -> AbsToCon b
ConOfAbs (SplitPattern (NamedArg Pattern)) -> AbsToCon b
ret
      Origin
_         -> Arg (Named NamedName (SplitPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (SplitPattern Pattern)))
    -> AbsToCon b)
-> AbsToCon b
forall b.
Arg (Named NamedName (SplitPattern Pattern))
-> (ConOfAbs (Arg (Named NamedName (SplitPattern Pattern)))
    -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)))
-> AbsToCon b
ConOfAbs (SplitPattern (NamedArg Pattern)) -> AbsToCon 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 b.
BindingPattern
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
bindToConcrete (BindingPat Pattern
p) ConOfAbs BindingPattern -> AbsToCon b
ret = do
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.pat" VerboseLevel
100 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"binding pattern (pass 2b)" RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Pattern -> RawName
forall a. Show a => a -> RawName
show Pattern
p
    case Pattern
p of
      A.VarP BindName
x               -> FreshenName -> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
forall b.
FreshenName -> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (BindName -> FreshenName
FreshenName BindName
x) ((ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b) -> (Name -> Pattern) -> Name -> AbsToCon 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 -> AbsToCon b
ret Pattern
ConOfAbs BindingPattern
p
      A.ProjP{}              -> ConOfAbs BindingPattern -> AbsToCon b
ret Pattern
ConOfAbs BindingPattern
p
      A.AbsurdP{}            -> ConOfAbs BindingPattern -> AbsToCon b
ret Pattern
ConOfAbs BindingPattern
p
      A.LitP{}               -> ConOfAbs BindingPattern -> AbsToCon b
ret Pattern
ConOfAbs BindingPattern
p
      A.DotP{}               -> ConOfAbs BindingPattern -> AbsToCon b
ret Pattern
ConOfAbs BindingPattern
p
      A.EqualP{}             -> ConOfAbs BindingPattern -> AbsToCon b
ret Pattern
ConOfAbs BindingPattern
p
      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args        -> [Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall b.
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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)] -> AbsToCon b)
-> AbsToCon b
forall b.
[Arg (Named NamedName BindingPattern)]
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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)] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [Arg (Named NamedName BindingPattern)] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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 PatInfo
i [FieldAssignment' Pattern]
args          -> [FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> AbsToCon b)
-> AbsToCon b
forall b.
[FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> AbsToCon b)
-> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon 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] -> AbsToCon b)
 -> AbsToCon b)
-> (ConOfAbs [FieldAssignment' BindingPattern] -> AbsToCon b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP PatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> FreshenName -> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
forall b.
FreshenName -> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (BindName -> FreshenName
FreshenName BindName
x) ((ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs FreshenName -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs FreshenName
x ->
                                BindingPattern
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall b.
BindingPattern
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> BindingPattern
BindingPat Pattern
p)  ((ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs BindingPattern
p ->
                                ConOfAbs BindingPattern -> AbsToCon 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 -> AbsToCon b) -> AbsToCon b
forall b.
BindingPattern
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> BindingPattern
BindingPat Pattern
p) ((ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> (Pattern -> Pattern) -> Pattern -> AbsToCon 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
      A.AnnP PatInfo
i Expr
a Pattern
p           -> BindingPattern
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall b.
BindingPattern
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> BindingPattern
BindingPat Pattern
p) ((ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs BindingPattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ConOfAbs BindingPattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> (Pattern -> Pattern) -> Pattern -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> Expr -> Pattern -> Pattern
forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
i Expr
a

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

  bindToConcrete :: forall b. Pattern -> (ConOfAbs Pattern -> AbsToCon b) -> AbsToCon b
bindToConcrete Pattern
p ConOfAbs Pattern -> AbsToCon b
ret = do
    PrecedenceStack
prec <- AbsToCon PrecedenceStack
currentPrecedence
    UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
UserPattern Pattern
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (UserPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (UserPattern Pattern)
p -> do
      SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall b.
SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> SplitPattern Pattern
forall a. a -> SplitPattern a
SplitPattern Pattern
ConOfAbs (UserPattern Pattern)
p) ((ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (SplitPattern Pattern) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ ConOfAbs (SplitPattern Pattern)
p -> do
        Pattern -> AbsToCon b
ConOfAbs Pattern -> AbsToCon b
ret (Pattern -> AbsToCon b) -> AbsToCon Pattern -> AbsToCon b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do PrecedenceStack -> AbsToCon Pattern -> AbsToCon Pattern
forall a. PrecedenceStack -> AbsToCon a -> AbsToCon a
withPrecedence' PrecedenceStack
prec (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Pattern
ConOfAbs (SplitPattern Pattern)
p
  toConcrete :: Pattern -> AbsToCon (ConOfAbs Pattern)
toConcrete Pattern
p =
    case Pattern
p of
      A.VarP BindName
x ->
        QName -> Pattern
C.IdentP (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) -> AbsToCon BoundName -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BindName -> AbsToCon (ConOfAbs BindName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete BindName
x

      A.WildP PatInfo
i ->
        Pattern -> AbsToCon Pattern
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon 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]
-> AbsToCon 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 -> QName -> Pattern
C.IdentP (QName -> Pattern) -> AbsToCon QName -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
      A.ProjP PatInfo
i ProjOrigin
_          AmbiguousQName
p -> Range -> Expr -> Pattern
C.DotP 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) -> AbsToCon QName -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)

      A.DefP PatInfo
i AmbiguousQName
x [NamedArg Pattern]
args -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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
        (BoundName
x, Pattern
p) <- Precedence
-> (BindName, Pattern) -> AbsToCon (ConOfAbs (BindName, Pattern))
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ (BindName
x, Pattern
p)
        Pattern -> AbsToCon Pattern
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Name -> Pattern -> Pattern
C.AsP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i) (BoundName -> Name
C.boundName BoundName
x) Pattern
p

      A.AbsurdP PatInfo
i ->
        Pattern -> AbsToCon Pattern
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon 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
        QName
x <- AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
        (PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern
bracketP_ PrecedenceStack -> Bool
appBrackets (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon Pattern
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Arg (Named_ Pattern) -> Pattern
C.AppP (Range -> Pattern
C.QuoteP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i)) (Pattern -> Arg (Named_ Pattern)
forall a. a -> NamedArg a
defaultNamedArg (QName -> Pattern
C.IdentP QName
x))
      A.LitP PatInfo
i Literal
l ->
        Pattern -> AbsToCon Pattern
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon 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{} -> Range -> Expr -> Pattern
C.DotP 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) -> AbsToCon Expr -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (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.
        Name
cn <- Name -> AbsToCon Name
toConcreteName Name
v
        KindsOfNames
-> Maybe (Set Name)
-> QName
-> AbsToCon (Either AmbiguousNameReason ResolvedName)
resolveName ([KindOfName] -> KindsOfNames
someKindsOfNames [KindOfName
FldName]) Maybe (Set Name)
forall a. Maybe a
Nothing (Name -> QName
C.QName Name
cn) AbsToCon (Either AmbiguousNameReason ResolvedName)
-> (Either AmbiguousNameReason ResolvedName -> AbsToCon Pattern)
-> AbsToCon Pattern
forall a b. AbsToCon a -> (a -> AbsToCon b) -> AbsToCon b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
          -- If we do then we print .(v) rather than .v
          Right FieldName{} -> do
            RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"print.dotted" VerboseLevel
50 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ RawName
"Wrapping ambiguous name " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Name -> RawName
forall a. Pretty a => a -> RawName
prettyShow (Name -> Name
nameConcrete Name
v)
            Range -> Expr -> Pattern
C.DotP 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) -> AbsToCon Expr -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (Name -> Expr
A.Var Name
v)
          Right ResolvedName
_ -> PatInfo -> Expr -> AbsToCon Pattern
printDotDefault PatInfo
i Expr
e
          Left AmbiguousNameReason
_ -> AbsToCon Pattern
forall a. HasCallStack => a
__IMPOSSIBLE__

      A.DotP PatInfo
i Expr
e -> PatInfo -> Expr -> AbsToCon Pattern
printDotDefault PatInfo
i Expr
e

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

      A.PatternSynP PatInfo
i AmbiguousQName
n [NamedArg Pattern]
args -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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 PatInfo
i [FieldAssignment' Pattern]
as ->
        Range -> [FieldAssignment' Pattern] -> Pattern
C.RecP (PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i) ([FieldAssignment' Pattern] -> Pattern)
-> AbsToCon [FieldAssignment' Pattern] -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldAssignment' Pattern -> AbsToCon (FieldAssignment' Pattern))
-> [FieldAssignment' Pattern]
-> AbsToCon [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 -> AbsToCon Pattern)
-> FieldAssignment' Pattern -> AbsToCon (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 -> AbsToCon Pattern
Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
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) -> AbsToCon Pattern -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
WithArgCtx Pattern
p

      A.AnnP PatInfo
i Expr
a Pattern
p -> Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Pattern
p -- TODO: print type annotation

    where

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

    tryOp :: A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> AbsToCon C.Pattern
    tryOp :: QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon 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 :: AbsToCon (Maybe Pattern) -> AbsToCon (Maybe Pattern)
funCtx = Bool
-> (AbsToCon (Maybe Pattern) -> AbsToCon (Maybe Pattern))
-> AbsToCon (Maybe Pattern)
-> AbsToCon (Maybe Pattern)
forall a. Bool -> (a -> a) -> a -> a
applyUnless ([NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null [NamedArg Pattern]
args2) (Precedence -> AbsToCon (Maybe Pattern) -> AbsToCon (Maybe Pattern)
forall a. Precedence -> AbsToCon a -> AbsToCon a
withPrecedence Precedence
FunctionCtx)
      Pattern -> AbsToCon Pattern -> AbsToCon Pattern
tryToRecoverPatternSynP ([NamedArg Pattern] -> Pattern
f [NamedArg Pattern]
args) (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ AbsToCon (Maybe Pattern) -> AbsToCon (Maybe Pattern)
funCtx (Pattern -> AbsToCon (Maybe Pattern)
tryToRecoverOpAppP (Pattern -> AbsToCon (Maybe Pattern))
-> Pattern -> AbsToCon (Maybe Pattern)
forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Pattern
f [NamedArg Pattern]
args1) AbsToCon (Maybe Pattern)
-> (Maybe Pattern -> AbsToCon Pattern) -> AbsToCon Pattern
forall a b. AbsToCon a -> (a -> AbsToCon b) -> AbsToCon b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Pattern
c  -> [NamedArg Pattern] -> Pattern -> AbsToCon Pattern
forall {arg}.
(ConOfAbs arg ~ Arg (Named_ Pattern), ToConcrete arg) =>
[arg] -> Pattern -> AbsToCon Pattern
applyTo [NamedArg Pattern]
args2 Pattern
c
        Maybe Pattern
Nothing -> [NamedArg Pattern] -> Pattern -> AbsToCon Pattern
forall {arg}.
(ConOfAbs arg ~ Arg (Named_ Pattern), ToConcrete arg) =>
[arg] -> Pattern -> AbsToCon Pattern
applyTo [NamedArg Pattern]
args (Pattern -> AbsToCon Pattern)
-> (QName -> Pattern) -> QName -> AbsToCon Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Pattern
C.IdentP (QName -> AbsToCon Pattern) -> AbsToCon QName -> AbsToCon Pattern
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
    -- Note: applyTo [] c = return c
    applyTo :: [arg] -> Pattern -> AbsToCon Pattern
applyTo [arg]
args Pattern
c = (PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern
bracketP_ ([arg] -> PrecedenceStack -> Bool
forall arg. [arg] -> PrecedenceStack -> Bool
appBracketsArgs [arg]
args) (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon 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)
-> AbsToCon [Arg (Named_ Pattern)] -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> [arg] -> AbsToCon (ConOfAbs [arg])
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ [arg]
args

instance ToConcrete (Maybe A.Pattern) where
  type ConOfAbs (Maybe A.Pattern) = Maybe C.Pattern

  toConcrete :: Maybe Pattern -> AbsToCon (ConOfAbs (Maybe Pattern))
toConcrete = (Pattern -> AbsToCon Pattern)
-> Maybe Pattern -> AbsToCon (Maybe Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Pattern -> AbsToCon Pattern
Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete

-- Helpers for recovering natural number literals

tryToRecoverNatural :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr
tryToRecoverNatural :: Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverNatural Expr
e AbsToCon Expr
def = do
  QName -> RawName -> Bool
is <- AbsToCon (QName -> RawName -> Bool)
isBuiltinFun
  Maybe Integer
-> AbsToCon Expr -> (Integer -> AbsToCon Expr) -> AbsToCon Expr
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe ((QName -> RawName -> Bool) -> Expr -> Maybe Integer
recoverNatural QName -> RawName -> Bool
is Expr
e) AbsToCon Expr
def ((Integer -> AbsToCon Expr) -> AbsToCon Expr)
-> (Integer -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr)
-> (Integer -> Expr) -> Integer -> AbsToCon Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Literal -> Expr
C.Lit Range
forall a. Range' a
noRange (Literal -> Expr) -> (Integer -> Literal) -> Integer -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
LitNat

recoverNatural :: (A.QName -> String -> Bool) -> A.Expr -> Maybe Integer
recoverNatural :: (QName -> RawName -> Bool) -> Expr -> Maybe Integer
recoverNatural QName -> RawName -> Bool
is Expr
e = (QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore (QName -> RawName -> Bool
`is` RawName
builtinZero) (QName -> RawName -> Bool
`is` RawName
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 -> RawName -> RawName
[MaybeSection a] -> RawName -> RawName
MaybeSection a -> RawName
(VerboseLevel -> MaybeSection a -> RawName -> RawName)
-> (MaybeSection a -> RawName)
-> ([MaybeSection a] -> RawName -> RawName)
-> Show (MaybeSection a)
forall a.
Show a =>
VerboseLevel -> MaybeSection a -> RawName -> RawName
forall a. Show a => [MaybeSection a] -> RawName -> RawName
forall a. Show a => MaybeSection a -> RawName
forall a.
(VerboseLevel -> a -> RawName -> RawName)
-> (a -> RawName) -> ([a] -> RawName -> RawName) -> Show a
$cshowsPrec :: forall a.
Show a =>
VerboseLevel -> MaybeSection a -> RawName -> RawName
showsPrec :: VerboseLevel -> MaybeSection a -> RawName -> RawName
$cshow :: forall a. Show a => MaybeSection a -> RawName
show :: MaybeSection a -> RawName
$cshowList :: forall a. Show a => [MaybeSection a] -> RawName -> RawName
showList :: [MaybeSection a] -> RawName -> RawName
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 :: Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr
cOpApp :: Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr
cOpApp Range
r QName
x Name
n List1 (MaybeSection Expr)
es =
  Range -> QName -> Set Name -> OpAppArgs -> Expr
C.OpApp Range
r QName
x (Name -> Set Name
forall a. a -> Set a
Set.singleton Name
n) (OpAppArgs -> Expr) -> OpAppArgs -> Expr
forall a b. (a -> b) -> a -> b
$
  ((MaybeSection Expr, PositionInName)
 -> NamedArg (MaybePlaceholder (OpApp Expr)))
-> [(MaybeSection Expr, PositionInName)] -> OpAppArgs
forall a b. (a -> b) -> [a] -> [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) ([(MaybeSection Expr, PositionInName)] -> OpAppArgs)
-> [(MaybeSection Expr, PositionInName)] -> OpAppArgs
forall a b. (a -> b) -> a -> b
$
  NonEmpty (MaybeSection Expr, PositionInName)
-> [Item (NonEmpty (MaybeSection Expr, PositionInName))]
forall l. IsList l => l -> [Item l]
List1.toList NonEmpty (MaybeSection Expr, PositionInName)
eps
  where
    x0 :: Name
x0 = QName -> Name
C.unqualify QName
x
    positions :: List1 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 -> List1 PositionInName
forall a. [a] -> a -> List1 a
`List1.snoc` PositionInName
End
              | Name -> Bool
isPostfix Name
x0 = PositionInName
Beginning PositionInName -> [PositionInName] -> List1 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] -> List1 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) -> List1 PositionInName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 (MaybeSection Expr)
es
    eps :: NonEmpty (MaybeSection Expr, PositionInName)
eps = List1 (MaybeSection Expr)
-> List1 PositionInName
-> NonEmpty (MaybeSection Expr, PositionInName)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
List1.zip List1 (MaybeSection Expr)
es List1 PositionInName
positions
    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 :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr
tryToRecoverOpApp :: Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverOpApp Expr
e AbsToCon Expr
def = AbsToCon Expr -> AbsToCon (Maybe Expr) -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM AbsToCon Expr
def (AbsToCon (Maybe Expr) -> AbsToCon Expr)
-> AbsToCon (Maybe Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$
  ((PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr)
-> (Expr -> Bool)
-> (Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr)
-> (Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))]))
-> Expr
-> AbsToCon (Maybe Expr)
forall a c.
(ToConcrete a, c ~ ConOfAbs a, HasRange c) =>
((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)
-> (a -> Bool)
-> (Range -> QName -> Name -> List1 (MaybeSection c) -> c)
-> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
-> a
-> AbsToCon (Maybe c)
recoverOpApp (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon 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) 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 TacticAttr
_ 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 :: A.Pattern -> AbsToCon (Maybe C.Pattern)
tryToRecoverOpAppP :: Pattern -> AbsToCon (Maybe Pattern)
tryToRecoverOpAppP Pattern
p = do
  Maybe Pattern
res <- ((PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern)
-> (Pattern -> Bool)
-> (Range
    -> QName -> Name -> List1 (MaybeSection Pattern) -> Pattern)
-> (Pattern
    -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))]))
-> Pattern
-> AbsToCon (Maybe Pattern)
forall a c.
(ToConcrete a, c ~ ConOfAbs a, HasRange c) =>
((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)
-> (a -> Bool)
-> (Range -> QName -> Name -> List1 (MaybeSection c) -> c)
-> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
-> a
-> AbsToCon (Maybe c)
recoverOpApp (PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern
bracketP_ (Bool -> Pattern -> Bool
forall a b. a -> b -> a
const Bool
False) Range -> QName -> Name -> List1 (MaybeSection Pattern) -> Pattern
forall {l}.
(Item l ~ MaybeSection Pattern, IsList l) =>
Range -> QName -> Name -> l -> Pattern
opApp Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
view Pattern
p
  RawName -> VerboseLevel -> [RawName] -> AbsToCon ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
RawName -> VerboseLevel -> a -> m ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> [RawName] -> m ()
reportS RawName
"print.op" VerboseLevel
90
    [ RawName
"tryToRecoverOpApp"
    , RawName
"in:  " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Pattern -> RawName
forall a. Show a => a -> RawName
show Pattern
p
    , RawName
"out: " RawName -> RawName -> RawName
forall a. [a] -> [a] -> [a]
++ Maybe Pattern -> RawName
forall a. Show a => a -> RawName
show Maybe Pattern
res
    ]
  Maybe Pattern -> AbsToCon (Maybe Pattern)
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pattern
res
  where
    opApp :: Range -> QName -> Name -> l -> Pattern
opApp Range
r QName
x Name
n l
ps = Range -> QName -> Set Name -> [Arg (Named_ Pattern)] -> Pattern
C.OpAppP Range
r QName
x (Name -> Set Name
forall a. a -> Set a
Set.singleton Name
n) ([Arg (Named_ Pattern)] -> Pattern)
-> [Arg (Named_ Pattern)] -> Pattern
forall a b. (a -> b) -> a -> b
$
      (MaybeSection Pattern -> Arg (Named_ Pattern))
-> [MaybeSection Pattern] -> [Arg (Named_ Pattern)]
forall a b. (a -> b) -> [a] -> [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__) ([MaybeSection Pattern] -> [Arg (Named_ Pattern)])
-> [MaybeSection Pattern] -> [Arg (Named_ Pattern)]
forall a b. (a -> b) -> a -> b
$
      -- `view` does not generate any `Nothing`s
      l -> [Item l]
forall l. IsList l => l -> [Item l]
List1.toList l
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 . (ToConcrete a, c ~ ConOfAbs a, HasRange c)
  => ((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)
  -> (a -> Bool)  -- ^ Check for lambdas
  -> (Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)  -- ^ @opApp@
  -> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
  -> a
  -> AbsToCon (Maybe c)
recoverOpApp :: forall a c.
(ToConcrete a, c ~ ConOfAbs a, HasRange c) =>
((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)
-> (a -> Bool)
-> (Range -> QName -> Name -> List1 (MaybeSection c) -> c)
-> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))
-> a
-> AbsToCon (Maybe c)
recoverOpApp (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket a -> Bool
isLam 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 -> AbsToCon (Maybe c)
forall {a}. AbsToCon (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    -> AbsToCon (Maybe c)
forall {a}. AbsToCon (Maybe a)
mDefault
          | Bool
otherwise     -> Either Name QName
-> [MaybeSection (AppInfo, a)] -> AbsToCon (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
                          -> AbsToCon (Maybe c)
forall {a}. AbsToCon (Maybe a)
mDefault
          | Bool
otherwise     -> Either Name QName
-> [MaybeSection (AppInfo, a)] -> AbsToCon (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)] -> AbsToCon (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)] -> AbsToCon (Maybe c)
doQNameHelper (QName -> Either Name QName
forall a b. b -> Either a b
Right QName
qn) [MaybeSection (AppInfo, a)]
args'
    | Bool
otherwise           -> AbsToCon (Maybe c)
forall {a}. AbsToCon (Maybe a)
mDefault
  where
  mDefault :: AbsToCon (Maybe a)
mDefault = Maybe a -> AbsToCon (Maybe a)
forall a. a -> AbsToCon 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 :: Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> AbsToCon (Maybe c)
  doQNameHelper :: Either Name QName
-> [MaybeSection (AppInfo, a)] -> AbsToCon (Maybe c)
doQNameHelper Either Name QName
n [MaybeSection (AppInfo, a)]
args = do
    QName
x <- (Name -> AbsToCon QName)
-> (QName -> AbsToCon QName) -> Either Name QName -> AbsToCon QName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Name -> QName
C.QName (Name -> QName)
-> (Name -> AbsToCon Name) -> Name -> AbsToCon QName
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Name -> AbsToCon Name
Name -> AbsToCon (ConOfAbs Name)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete) QName -> AbsToCon QName
QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Either Name QName
n
    let n' :: Name
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'.
    Fixity
fx <- QName -> [Name] -> AbsToCon ResolvedName
resolveName_ QName
x [Name
n'] AbsToCon ResolvedName
-> (ResolvedName -> Fixity) -> AbsToCon Fixity
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ case
            VarName Name
y BindingSource
_                -> Name
y Name -> Lens' Fixity Name -> Fixity
forall o i. o -> Lens' i o -> i
^. (Fixity -> f Fixity) -> Name -> f Name
forall a. LensFixity a => Lens' Fixity a
Lens' Fixity Name
lensFixity
            DefinedName Access
_ AbstractName
q Suffix
_          -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            FieldName (AbstractName
q :| [AbstractName]
_)         -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            ConstructorName Set Induction
_ (AbstractName
q :| [AbstractName]
_) -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            PatternSynResName (AbstractName
q :| [AbstractName]
_) -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            ResolvedName
UnknownName                -> Fixity
noFixity
    [MaybeSection (AppInfo, a)]
-> AbsToCon (Maybe c)
-> (List1 (MaybeSection (AppInfo, a)) -> AbsToCon (Maybe c))
-> AbsToCon (Maybe c)
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [MaybeSection (AppInfo, a)]
args {-then-} AbsToCon (Maybe c)
forall {a}. AbsToCon (Maybe a)
mDefault {-else-} ((List1 (MaybeSection (AppInfo, a)) -> AbsToCon (Maybe c))
 -> AbsToCon (Maybe c))
-> (List1 (MaybeSection (AppInfo, a)) -> AbsToCon (Maybe c))
-> AbsToCon (Maybe c)
forall a b. (a -> b) -> a -> b
$ \ List1 (MaybeSection (AppInfo, a))
as ->
      Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> AbsToCon (Maybe c)
doQName 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 :: Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> AbsToCon (Maybe c)

  -- fall-back (wrong number of arguments or no holes)
  doQName :: Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> AbsToCon (Maybe c)
doQName 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 = AbsToCon (Maybe c)
forall {a}. AbsToCon (Maybe a)
mDefault

  -- binary case
  doQName 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) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket (Bool -> Fixity -> PrecedenceStack -> Bool
opBrackets' (MaybeSection (AppInfo, a) -> Bool
skipParens MaybeSection (AppInfo, a)
an) Fixity
fixity) (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ do
            MaybeSection c
e1 <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx (Fixity -> Precedence
LeftOperandCtx Fixity
fixity) (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon 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
            [MaybeSection c]
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> AbsToCon [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) -> AbsToCon (MaybeSection c))
 -> [MaybeSection (AppInfo, a)] -> AbsToCon [MaybeSection c])
-> (((AppInfo, a) -> AbsToCon c)
    -> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> ((AppInfo, a) -> AbsToCon c)
-> [MaybeSection (AppInfo, a)]
-> AbsToCon [MaybeSection c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon 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'
            MaybeSection c
en <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 ((AppInfo -> a -> AbsToCon c) -> (AppInfo, a) -> AbsToCon c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((AppInfo -> a -> AbsToCon c) -> (AppInfo, a) -> AbsToCon c)
-> (AppInfo -> a -> AbsToCon c) -> (AppInfo, a) -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Precedence -> a -> AbsToCon c
Precedence -> a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx (Precedence -> a -> AbsToCon c)
-> (AppInfo -> Precedence) -> AppInfo -> a -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixity -> ParenPreference -> Precedence
RightOperandCtx Fixity
fixity (ParenPreference -> Precedence)
-> (AppInfo -> ParenPreference) -> AppInfo -> Precedence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppInfo -> ParenPreference
appParens) MaybeSection (AppInfo, a)
an
            c -> AbsToCon c
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> List1 (MaybeSection c) -> c
opApp ((MaybeSection c, MaybeSection c) -> Range
forall a. HasRange a => a -> Range
getRange (MaybeSection c
e1, MaybeSection c
en)) QName
x Name
n (MaybeSection c
e1 MaybeSection c -> [MaybeSection c] -> List1 (MaybeSection c)
forall a. a -> [a] -> NonEmpty a
:| [MaybeSection c]
es [MaybeSection c] -> [MaybeSection c] -> [MaybeSection c]
forall a. [a] -> [a] -> [a]
++ [MaybeSection c
en])

  -- prefix
  doQName 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) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket (Bool -> Fixity -> PrecedenceStack -> Bool
opBrackets' (MaybeSection (AppInfo, a) -> Bool
skipParens MaybeSection (AppInfo, a)
an) Fixity
fixity) (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ do
            [MaybeSection c]
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> AbsToCon [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) -> AbsToCon (MaybeSection c))
 -> [MaybeSection (AppInfo, a)] -> AbsToCon [MaybeSection c])
-> (((AppInfo, a) -> AbsToCon c)
    -> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> ((AppInfo, a) -> AbsToCon c)
-> [MaybeSection (AppInfo, a)]
-> AbsToCon [MaybeSection c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon 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'
            MaybeSection c
en <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 (\ (AppInfo
i, a
e) -> Precedence -> a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (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) MaybeSection (AppInfo, a)
an
            c -> AbsToCon c
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> List1 (MaybeSection c) -> c
opApp ((Name, MaybeSection c) -> Range
forall a. HasRange a => a -> Range
getRange (Name
n, MaybeSection c
en)) QName
x Name
n ([MaybeSection c] -> MaybeSection c -> List1 (MaybeSection c)
forall a. [a] -> a -> List1 a
List1.snoc [MaybeSection c]
es MaybeSection c
en)

  -- postfix
  doQName 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
        MaybeSection c
e1 <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx (Fixity -> Precedence
LeftOperandCtx Fixity
fixity) (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon 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
        [MaybeSection c]
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> AbsToCon [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) -> AbsToCon (MaybeSection c))
 -> [MaybeSection (AppInfo, a)] -> AbsToCon [MaybeSection c])
-> (((AppInfo, a) -> AbsToCon c)
    -> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> ((AppInfo, a) -> AbsToCon c)
-> [MaybeSection (AppInfo, a)]
-> AbsToCon [MaybeSection c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon 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'
        c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket (Fixity -> PrecedenceStack -> Bool
opBrackets Fixity
fixity) (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$
            c -> AbsToCon c
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> List1 (MaybeSection c) -> c
opApp ((MaybeSection c, Name) -> Range
forall a. HasRange a => a -> Range
getRange (MaybeSection c
e1, Name
n)) QName
x Name
n (MaybeSection c
e1 MaybeSection c -> [MaybeSection c] -> List1 (MaybeSection c)
forall a. a -> [a] -> NonEmpty a
:| [MaybeSection c]
es)

  -- roundfix
  doQName Fixity
_ QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
_ = do
    List1 (MaybeSection c)
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> List1 (MaybeSection (AppInfo, a))
-> AbsToCon (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) -> AbsToCon (MaybeSection c))
 -> List1 (MaybeSection (AppInfo, a))
 -> AbsToCon (List1 (MaybeSection c)))
-> (((AppInfo, a) -> AbsToCon c)
    -> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> ((AppInfo, a) -> AbsToCon c)
-> List1 (MaybeSection (AppInfo, a))
-> AbsToCon (List1 (MaybeSection c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (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 -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon 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
    c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket PrecedenceStack -> Bool
roundFixBrackets (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$
        c -> AbsToCon c
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> List1 (MaybeSection c) -> c
opApp (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
x) QName
x Name
n List1 (MaybeSection c)
es

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

-- | Recover pattern synonyms for expressions.
tryToRecoverPatternSyn :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr
tryToRecoverPatternSyn :: Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e AbsToCon Expr
fallback
  | Expr -> Bool
userWritten Expr
e = AbsToCon Expr
fallback
  | Expr -> Bool
litOrCon Expr
e    = (QName -> [NamedArg Expr] -> Expr)
-> (PatternSynDefn -> Expr -> Maybe [Arg Expr])
-> Expr
-> AbsToCon (ConOfAbs Expr)
-> AbsToCon (ConOfAbs Expr)
forall a.
ToConcrete a =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [Arg a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg Expr] -> Expr
apply PatternSynDefn -> Expr -> Maybe [Arg Expr]
matchPatternSyn Expr
e AbsToCon Expr
AbsToCon (ConOfAbs Expr)
fallback
  | Bool
otherwise     = AbsToCon 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 :: A.Pattern -> AbsToCon C.Pattern -> AbsToCon C.Pattern
tryToRecoverPatternSynP :: Pattern -> AbsToCon Pattern -> AbsToCon Pattern
tryToRecoverPatternSynP = (QName -> [NamedArg Pattern] -> Pattern)
-> (PatternSynDefn -> Pattern -> Maybe [Arg Pattern])
-> Pattern
-> AbsToCon (ConOfAbs Pattern)
-> AbsToCon (ConOfAbs Pattern)
forall a.
ToConcrete a =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [Arg a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg Pattern] -> Pattern
forall {e}. QName -> NAPs e -> Pattern' e
apply PatternSynDefn -> Pattern -> Maybe [Arg Pattern]
forall e. PatternSynDefn -> Pattern' e -> Maybe [Arg (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 :: ToConcrete a =>
  (A.QName -> [NamedArg a] -> a)         -> -- applySyn
  (PatternSynDefn -> a -> Maybe [Arg a]) -> -- match
  a -> AbsToCon (ConOfAbs a) -> AbsToCon (ConOfAbs a)
recoverPatternSyn :: forall a.
ToConcrete a =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [Arg a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg a] -> a
applySyn PatternSynDefn -> a -> Maybe [Arg a]
match a
e AbsToCon (ConOfAbs a)
fallback = do
  Bool
doFold <- (Env -> Bool) -> AbsToCon Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
foldPatternSynonyms
  if Bool -> Bool
not Bool
doFold then AbsToCon (ConOfAbs a)
fallback else do
    PatternSynDefns
psyns  <- AbsToCon PatternSynDefns
forall (m :: * -> *). ReadTCState m => m PatternSynDefns
getAllPatternSyns
    ScopeInfo
scope  <- AbsToCon ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.patsyn" VerboseLevel
100 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ Doc -> RawName
render (Doc -> RawName) -> Doc -> RawName
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
      [ Doc
"Scope when attempting to recover pattern synonyms:"
      , ScopeInfo -> Doc
forall a. Pretty a => a -> Doc
pretty ScopeInfo
scope
      ]
    let isConP :: Pattern' e -> Bool
isConP ConP{} = Bool
True    -- #2828: only fold pattern synonyms with
        isConP Pattern' e
_      = Bool
False   --        constructor rhs
        cands :: [(QName, [Arg a], VerboseLevel)]
cands = [ (QName
q, [Arg a]
args, Pattern' Void -> VerboseLevel
score Pattern' Void
rhs)
                | (QName
q, psyndef :: PatternSynDefn
psyndef@([Arg 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 [Arg a]
args <- [PatternSynDefn -> a -> Maybe [Arg 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) -> (a, b, a) -> Ordering
cmp (a
_, b
_, a
x) (a
_, b
_, a
y) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
y a
x
    RawName -> VerboseLevel -> RawName -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> RawName -> m ()
reportSLn RawName
"toConcrete.patsyn" VerboseLevel
50 (RawName -> AbsToCon ()) -> RawName -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ Doc -> RawName
render (Doc -> RawName) -> Doc -> RawName
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
      [ Doc
"Found pattern synonym candidates:"
      , [QName] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ ([QName] -> Doc) -> [QName] -> Doc
forall a b. (a -> b) -> a -> b
$ ((QName, [Arg a], VerboseLevel) -> QName)
-> [(QName, [Arg a], VerboseLevel)] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
q,[Arg a]
_,VerboseLevel
_) -> QName
q) [(QName, [Arg a], VerboseLevel)]
cands
      ]
    case ((QName, [Arg a], VerboseLevel)
 -> (QName, [Arg a], VerboseLevel) -> Ordering)
-> [(QName, [Arg a], VerboseLevel)]
-> [(QName, [Arg a], VerboseLevel)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (QName, [Arg a], VerboseLevel)
-> (QName, [Arg a], VerboseLevel) -> Ordering
forall {a} {a} {b} {a} {b}.
Ord a =>
(a, b, a) -> (a, b, a) -> Ordering
cmp [(QName, [Arg a], VerboseLevel)]
cands of
      (QName
q, [Arg a]
args, VerboseLevel
_) : [(QName, [Arg a], VerboseLevel)]
_ -> a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (a -> AbsToCon (ConOfAbs a)) -> a -> AbsToCon (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
$ ((Arg a -> NamedArg a) -> [Arg a] -> [NamedArg a]
forall a b. (a -> b) -> [a] -> [b]
map ((Arg a -> NamedArg a) -> [Arg a] -> [NamedArg a])
-> ((a -> Named_ a) -> Arg a -> NamedArg a)
-> (a -> Named_ a)
-> [Arg a]
-> [NamedArg a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Named_ a) -> Arg a -> NamedArg a
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> Named_ a
forall a name. a -> Named name a
unnamed [Arg a]
args
      []               -> AbsToCon (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 :: InteractionId -> AbsToCon (ConOfAbs InteractionId)
toConcrete (InteractionId VerboseLevel
i) = Expr -> AbsToCon Expr
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon 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 :: NamedMeta -> AbsToCon (ConOfAbs NamedMeta)
toConcrete NamedMeta
i =
      Range -> Maybe RawName -> Expr
C.Underscore Range
forall a. Range' a
noRange (Maybe RawName -> Expr) -> (Doc -> Maybe RawName) -> Doc -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawName -> Maybe RawName
forall a. a -> Maybe a
Just (RawName -> Maybe RawName)
-> (Doc -> RawName) -> Doc -> Maybe RawName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> RawName
render (Doc -> Expr) -> AbsToCon Doc -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedMeta -> AbsToCon Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NamedMeta -> m Doc
prettyTCM NamedMeta
i