{-# LANGUAGE CPP #-}
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.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 Data.Bifunctor ( first )
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, (<>), sconcat )
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.List
import Agda.Utils.List1 (List1, pattern (:|), (<|) )
import Agda.Utils.List2 (List2, pattern List2)
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Syntax.Common.Aspect as Asp
import Agda.Syntax.Common.Pretty hiding ((<>))
import Agda.Utils.Singleton
import Agda.Utils.Suffix
import Agda.Utils.Impossible
data Env = Env { Env -> Set Name
takenVarNames :: Set A.Name
, Env -> Set NameParts
takenDefNames :: Set C.NameParts
, Env -> ScopeInfo
currentScope :: ScopeInfo
, Env -> Map BuiltinId QName
builtins :: Map BuiltinId A.QName
, Env -> Bool
preserveIIds :: Bool
, Env -> Bool
foldPatternSynonyms :: Bool
}
makeEnv :: MonadAbsToCon m => ScopeInfo -> m Env
makeEnv :: forall (m :: * -> *). MonadAbsToCon m => ScopeInfo -> m Env
makeEnv ScopeInfo
scope = do
let noScopeCheck :: BuiltinId -> Bool
noScopeCheck BuiltinId
b = BuiltinId
b BuiltinId -> [BuiltinId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuiltinId
builtinZero, BuiltinId
builtinSuc]
name :: Term -> Maybe QName
name (I.Def QName
q Elims
_) = QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q
name (I.Con ConHead
q ConInfo
_ Elims
_) = QName -> Maybe QName
forall a. a -> Maybe a
Just (ConHead -> QName
I.conName ConHead
q)
name Term
_ = Maybe QName
forall a. Maybe a
Nothing
builtin :: BuiltinId -> m [(BuiltinId, QName)]
builtin BuiltinId
b = BuiltinId -> m (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
b m (Maybe Term)
-> (Maybe Term -> m [(BuiltinId, QName)]) -> m [(BuiltinId, QName)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
Just Term
v | Just QName
q <- Term -> Maybe QName
name Term
v,
BuiltinId -> Bool
noScopeCheck BuiltinId
b Bool -> Bool -> Bool
|| QName -> ScopeInfo -> Bool
isNameInScope QName
q ScopeInfo
scope -> [(BuiltinId, QName)] -> m [(BuiltinId, QName)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(BuiltinId
b, QName
q)]
Maybe Term
_ -> [(BuiltinId, QName)] -> m [(BuiltinId, QName)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
ctxVars <- (Dom' Term (Name, Type) -> Name)
-> [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
letVars <- Map.keys <$> asksTC envLetBindings
let vars = [Name]
ctxVars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
letVars
forM_ (scope ^. scopeLocals) $ \(Name
y , LocalVar
x) -> do
Name -> Name -> m ()
forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName (LocalVar -> Name
localVar LocalVar
x) Name
y
builtinList <- concat <$> mapM builtin [ builtinFromNat, builtinFromString, builtinFromNeg, builtinZero, builtinSuc ]
foldPatSyns <- optPrintPatternSynonyms <$> pragmaOptions
return $
Env { takenVarNames = Set.fromList vars
, takenDefNames = defs
, currentScope = scope
, builtins = Map.fromListWith __IMPOSSIBLE__ builtinList
, preserveIIds = False
, foldPatternSynonyms = foldPatSyns
}
where
defs :: Set NameParts
defs = (Name -> NameParts) -> Set Name -> Set NameParts
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> NameParts
nameParts (Set Name -> Set NameParts)
-> (Map Name (NonEmpty AbstractName) -> Set Name)
-> Map Name (NonEmpty AbstractName)
-> Set NameParts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name (NonEmpty AbstractName) -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Map Name (NonEmpty AbstractName) -> Set NameParts)
-> Map Name (NonEmpty AbstractName) -> Set NameParts
forall a b. (a -> b) -> a -> b
$
(Name -> NonEmpty AbstractName -> Bool)
-> Map Name (NonEmpty AbstractName)
-> Map Name (NonEmpty AbstractName)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Name -> NonEmpty AbstractName -> Bool
forall {t :: * -> *}. Foldable t => Name -> t AbstractName -> Bool
usefulDef (Map Name (NonEmpty AbstractName)
-> Map Name (NonEmpty AbstractName))
-> Map Name (NonEmpty AbstractName)
-> Map Name (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$
NameSpace -> Map Name (NonEmpty AbstractName)
nsNames (NameSpace -> Map Name (NonEmpty AbstractName))
-> NameSpace -> Map Name (NonEmpty AbstractName)
forall a b. (a -> b) -> a -> b
$ ScopeInfo -> NameSpace
everythingInScope ScopeInfo
scope
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' ScopeInfo PrecedenceStack -> PrecedenceStack
forall o i. o -> Lens' o i -> i
^. (PrecedenceStack -> f PrecedenceStack) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo PrecedenceStack
scopePrecedence) (ScopeInfo -> PrecedenceStack)
-> (Env -> ScopeInfo) -> Env -> PrecedenceStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ScopeInfo
currentScope
preserveInteractionIds :: 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 = 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 = set scopePrecedence ps (currentScope e) }
withPrecedence :: Precedence -> AbsToCon a -> AbsToCon a
withPrecedence :: forall a. Precedence -> AbsToCon a -> AbsToCon a
withPrecedence Precedence
p AbsToCon a
ret = do
ps <- AbsToCon PrecedenceStack
currentPrecedence
withPrecedence' (pushPrecedence p ps) 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 = 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.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 = False }
addBinding :: C.Name -> A.Name -> Env -> Env
addBinding :: Name -> Name -> Env -> Env
addBinding Name
y Name
x Env
e =
Env
e { takenVarNames = Set.insert x $ takenVarNames e
, currentScope = (`updateScopeLocals` currentScope e) $
AssocList.insert y (LocalVar x __IMPOSSIBLE__ [])
}
isBuiltinFun :: AbsToCon (A.QName -> BuiltinId -> Bool)
isBuiltinFun :: AbsToCon (QName -> BuiltinId -> Bool)
isBuiltinFun = (Env -> QName -> BuiltinId -> Bool)
-> AbsToCon (QName -> BuiltinId -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> QName -> BuiltinId -> Bool)
-> AbsToCon (QName -> BuiltinId -> Bool))
-> (Env -> QName -> BuiltinId -> Bool)
-> AbsToCon (QName -> BuiltinId -> Bool)
forall a b. (a -> b) -> a -> b
$ Map BuiltinId QName -> QName -> BuiltinId -> Bool
forall {k} {a}. (Ord k, Eq a) => Map k a -> a -> k -> Bool
is (Map BuiltinId QName -> QName -> BuiltinId -> Bool)
-> (Env -> Map BuiltinId QName)
-> Env
-> QName
-> BuiltinId
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map BuiltinId QName
builtins
where is :: Map k a -> a -> k -> Bool
is Map k a
m a
q k
b = a -> Maybe a
forall a. a -> Maybe a
Just a
q Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
b Map k a
m
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
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
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
}
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
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' TCState a -> (a -> a) -> AbsToCon b -> AbsToCon b
locallyTCState Lens' TCState a
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' TCState a -> (a -> a) -> m b -> m b
forall a b. Lens' TCState a -> (a -> a) -> m b -> m b
forall (m :: * -> *) a b.
ReadTCState m =>
Lens' TCState a -> (a -> a) -> m b -> m b
locallyTCState (a -> f a) -> TCState -> f TCState
Lens' TCState a
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
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 :: SomeBuiltin -> AbsToCon (Maybe (Builtin PrimFun))
getBuiltinThing SomeBuiltin
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
$ SomeBuiltin -> m (Maybe (Builtin PrimFun))
forall (m :: * -> *).
HasBuiltins m =>
SomeBuiltin -> m (Maybe (Builtin PrimFun))
getBuiltinThing SomeBuiltin
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 Aspects) -> AbsToCon RawName
formatDebugMessage RawName
k VerboseLevel
n TCM (Doc Aspects)
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 Aspects) -> m RawName
forall (m :: * -> *).
MonadDebug m =>
RawName -> VerboseLevel -> TCM (Doc Aspects) -> m RawName
formatDebugMessage RawName
k VerboseLevel
n TCM (Doc Aspects)
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
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
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.
Origin -> Name -> Term -> Dom Type -> AbsToCon a -> AbsToCon a
addLetBinding' Origin
o 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 (Origin -> Name -> Term -> Dom Type -> m a -> m a
forall a. Origin -> Name -> Term -> Dom Type -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Origin -> Name -> Term -> Dom Type -> m a -> m a
addLetBinding' Origin
o 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 Aspects)
fromString RawName
a = (forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m (Doc Aspects))
-> AbsToCon (Doc Aspects)
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (RawName -> m (Doc Aspects)
forall a. IsString a => RawName -> a
fromString RawName
a)
instance Null (AbsToCon Doc) where
empty :: AbsToCon (Doc Aspects)
empty = (forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m (Doc Aspects))
-> AbsToCon (Doc Aspects)
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon m (Doc Aspects)
forall a. Null a => a
forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m (Doc Aspects)
empty
null :: AbsToCon (Doc Aspects) -> Bool
null = AbsToCon (Doc Aspects) -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
instance Semigroup (AbsToCon Doc) where
AbsToCon (Doc Aspects)
a <> :: AbsToCon (Doc Aspects)
-> AbsToCon (Doc Aspects) -> AbsToCon (Doc Aspects)
<> AbsToCon (Doc Aspects)
b = (forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m (Doc Aspects))
-> AbsToCon (Doc Aspects)
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon (AbsToCon (Doc Aspects)
-> forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m (Doc Aspects)
forall a.
AbsToCon a
-> forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m a
unAbsToCon AbsToCon (Doc Aspects)
a m (Doc Aspects) -> m (Doc Aspects) -> m (Doc Aspects)
forall a. Semigroup a => a -> a -> a
<> AbsToCon (Doc Aspects)
-> forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m (Doc Aspects)
forall a.
AbsToCon a
-> forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m a
unAbsToCon AbsToCon (Doc Aspects)
b)
runAbsToCon :: MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon :: forall (m :: * -> *) c. MonadAbsToCon m => AbsToCon c -> m c
runAbsToCon AbsToCon c
m = do
scope <- m ScopeInfo
forall (m :: * -> *). ReadTCState m => m ScopeInfo
getScope
verboseBracket "toConcrete" 50 "runAbsToCon" $ do
reportSLn "toConcrete" 50 $ render $ hsep $
[ "entering AbsToCon with scope:"
, prettyList_ (map (text . C.nameToRawName . fst) $ scope ^. scopeLocals)
]
x <- runReaderT (unAbsToCon m) =<< makeEnv scope
reportSLn "toConcrete" 50 $ "leaving AbsToCon"
return x
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
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
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)
reportSLn "scope.inverse" 100 $
"inverse looking up abstract name " ++ prettyShow x ++ " yields " ++ prettyShow ys
loop ys
where
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
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
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"
lookupModule ModuleName
x =
do scope <- (Env -> ScopeInfo) -> AbsToCon ScopeInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ScopeInfo
currentScope
case inverseScopeLookupModule x scope of
(QName
y : [QName]
_) -> QName -> 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
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' ScopeInfo [(Name, LocalVar)] -> [(Name, LocalVar)]
forall o i. o -> Lens' o i -> i
^. ([(Name, LocalVar)] -> f [(Name, LocalVar)])
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo [(Name, LocalVar)]
scopeLocals) (ScopeInfo -> [(Name, LocalVar)])
-> (Env -> ScopeInfo) -> Env -> [(Name, LocalVar)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ScopeInfo
currentScope))
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
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]
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' TCState (Map Name (DList RawName))
-> m (Map Name (DList RawName))
forall (m :: * -> *) a. ReadTCState m => Lens' TCState a -> m a
useR (Map Name (DList RawName) -> f (Map Name (DList RawName)))
-> TCState -> f TCState
Lens' TCState (Map Name (DList RawName))
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
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)
loop [] = do
y <- Name -> AbsToCon Name
chooseName Name
x
pickConcreteName x y
return y
isGoodName :: A.Name -> C.Name -> AbsToCon Bool
isGoodName :: Name -> Name -> AbsToCon Bool
isGoodName Name
x Name
y = do
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)
allM zs $ \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
czs <- Name -> AbsToCon [Name]
forall (m :: * -> *). MonadStConcreteNames m => Name -> m [Name]
hasConcreteNames Name
z
return $ notElem y czs
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
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
Maybe Name
_ -> do
takenDefs <- (Env -> Set NameParts) -> AbsToCon (Set NameParts)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Set NameParts
takenDefNames
taken <- takenNames
toAvoid <- shadowingNames x
glyphMode <- optUseUnicode <$> pragmaOptions
let freshNameMode = case UnicodeOrAscii
glyphMode of
UnicodeOrAscii
UnicodeOk -> FreshNameMode
A.UnicodeSubscript
UnicodeOrAscii
AsciiOnly -> FreshNameMode
A.AsciiCounter
shouldAvoid C.NoName {} = Bool
False
shouldAvoid name :: Name
name@C.Name { NameParts
nameNameParts :: Name -> NameParts
nameNameParts :: NameParts
nameNameParts } =
let raw :: 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 = FreshNameMode -> (Name -> Bool) -> Name -> Name
firstNonTakenName FreshNameMode
freshNameMode Name -> Bool
shouldAvoid (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x
reportSLn "toConcrete.bindName" 80 $ render $ vcat
[ "picking concrete name for:" <+> text (C.nameToRawName $ nameConcrete x)
, "names already taken: " <+> prettyList_ (Set.toList taken)
, "names to avoid: " <+> prettyList_ (Set.toList toAvoid)
, "concrete name chosen: " <+> text (C.nameToRawName y)
]
return y
where
takenNames :: AbsToCon (Set RawName)
takenNames :: AbsToCon (Set RawName)
takenNames = do
ys0 <- (Env -> Set Name) -> AbsToCon (Set Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Set Name
takenVarNames
reportSLn "toConcrete.bindName" 90 $ render $ "abstract names of local vars: " <+> prettyList_ (map (C.nameToRawName . nameConcrete) $ Set.toList ys0)
ys <- Set.fromList . concat <$> mapM hasConcreteNames (Set.toList ys0)
return $ Set.map C.nameToRawName ys
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
y <- Name -> AbsToCon Name
toConcreteName Name
x
reportSLn "toConcrete.bindName" 30 $ "adding " ++ C.nameToRawName (nameConcrete x) ++ " to the scope under concrete name " ++ C.nameToRawName y
local (addBinding y x) $ ret y
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 b a. IsBool b => b -> (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
bracket' :: (e -> e)
-> (PrecedenceStack -> Bool)
-> e -> AbsToCon e
bracket' :: forall e. (e -> e) -> (PrecedenceStack -> Bool) -> e -> AbsToCon e
bracket' e -> e
paren PrecedenceStack -> Bool
needParen e
e =
do p <- AbsToCon PrecedenceStack
currentPrecedence
return $ if needParen p then paren e else e
bracket :: (PrecedenceStack -> Bool) -> AbsToCon C.Expr -> AbsToCon C.Expr
bracket :: (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
par AbsToCon Expr
m =
do e <- AbsToCon Expr
m
bracket' (Paren (getRange e)) par e
bracketP_ :: (PrecedenceStack -> Bool) -> AbsToCon C.Pattern -> AbsToCon C.Pattern
bracketP_ :: (PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern
bracketP_ PrecedenceStack -> Bool
par AbsToCon Pattern
m =
do e <- AbsToCon Pattern
m
bracket' (ParenP (getRange e)) par e
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
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 ]
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 KwRange -> [Declaration] -> [Declaration]
addInstanceB (case DefInfo -> IsInstance
forall t. DefInfo' t -> IsInstance
A.defInstance DefInfo
i of InstanceDef KwRange
r -> KwRange -> Maybe KwRange
forall a. a -> Maybe a
Just KwRange
r; IsInstance
NotInstanceDef -> Maybe KwRange
forall a. Maybe a
Nothing)
([Declaration] -> [Declaration])
-> 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 KwRange
kwr Origin
UserWritten)
[Declaration]
ds = [ KwRange -> Origin -> [Declaration] -> Declaration
C.Private KwRange
kwr Origin
UserWritten [Declaration]
ds ]
priv Access
_ [Declaration]
ds = [Declaration]
ds
abst :: IsAbstract -> [Declaration] -> [Declaration]
abst IsAbstract
AbstractDef [Declaration]
ds = [ KwRange -> [Declaration] -> Declaration
C.Abstract KwRange
forall a. Null a => a
empty [Declaration]
ds ]
abst IsAbstract
ConcreteDef [Declaration]
ds = [Declaration]
ds
addInstanceB :: Maybe KwRange -> [C.Declaration] -> [C.Declaration]
addInstanceB :: Maybe KwRange -> [Declaration] -> [Declaration]
addInstanceB (Just KwRange
r) [Declaration]
ds = [ KwRange -> [Declaration] -> Declaration
C.InstanceB KwRange
r [Declaration]
ds ]
addInstanceB Maybe KwRange
Nothing [Declaration]
ds = [Declaration]
ds
class ToConcrete a where
type ConOfAbs a
toConcrete :: a -> AbsToCon (ConOfAbs a)
bindToConcrete :: a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
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
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
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
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
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
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
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
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 Char where
type ConOfAbs Char = Char
toConcrete :: Char -> AbsToCon (ConOfAbs Char)
toConcrete = Char -> AbsToCon Char
Char -> AbsToCon (ConOfAbs Char)
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
a a -> [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
bindToConcrete :: forall b.
List1 a -> (ConOfAbs (List1 a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (a
a :| [a]
as) ConOfAbs (List1 a) -> AbsToCon b
ret = do
p <- AbsToCon PrecedenceStack
currentPrecedence
bindToConcrete a $ \ 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
$
[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 a => ToConcrete (Maybe a) where
type ConOfAbs (Maybe a) = Maybe (ConOfAbs a)
toConcrete :: Maybe a -> AbsToCon (ConOfAbs (Maybe a))
toConcrete = (a -> AbsToCon (ConOfAbs a))
-> Maybe a -> AbsToCon (Maybe (ConOfAbs a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
bindToConcrete :: forall b.
Maybe a -> (ConOfAbs (Maybe a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (Just a
x) ConOfAbs (Maybe 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
$ Maybe (ConOfAbs a) -> AbsToCon b
ConOfAbs (Maybe a) -> AbsToCon b
ret (Maybe (ConOfAbs a) -> AbsToCon b)
-> (ConOfAbs a -> Maybe (ConOfAbs a)) -> ConOfAbs a -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConOfAbs a -> Maybe (ConOfAbs a)
forall a. a -> Maybe a
Just
bindToConcrete Maybe a
Nothing ConOfAbs (Maybe a) -> AbsToCon b
ret = ConOfAbs (Maybe a) -> AbsToCon b
ret Maybe (ConOfAbs a)
ConOfAbs (Maybe a)
forall a. Maybe a
Nothing
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 = (a -> AbsToCon (ConOfAbs a))
-> Named name a -> AbsToCon (Named name (ConOfAbs a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Named name a -> f (Named name b)
traverse a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
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
instance ToConcrete a => ToConcrete (Ranged a) where
type ConOfAbs (Ranged a) = Ranged (ConOfAbs a)
toConcrete :: Ranged a -> AbsToCon (ConOfAbs (Ranged a))
toConcrete = (a -> AbsToCon (ConOfAbs a))
-> Ranged a -> AbsToCon (Ranged (ConOfAbs a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Ranged a -> f (Ranged b)
traverse a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
bindToConcrete :: forall b.
Ranged a -> (ConOfAbs (Ranged a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (Ranged Range
r a
x) ConOfAbs (Ranged 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
$ Ranged (ConOfAbs a) -> AbsToCon b
ConOfAbs (Ranged a) -> AbsToCon b
ret (Ranged (ConOfAbs a) -> AbsToCon b)
-> (ConOfAbs a -> Ranged (ConOfAbs a)) -> ConOfAbs a -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> ConOfAbs a -> Ranged (ConOfAbs a)
forall a. Range -> a -> Ranged a
Ranged Range
r
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
instance ToConcrete a => ToConcrete (TacticAttribute' a) where
type ConOfAbs (TacticAttribute' a) = TacticAttribute' (ConOfAbs a)
toConcrete :: TacticAttribute' a -> AbsToCon (ConOfAbs (TacticAttribute' a))
toConcrete = (a -> AbsToCon (ConOfAbs a))
-> TacticAttribute' a -> AbsToCon (TacticAttribute' (ConOfAbs a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TacticAttribute' a -> f (TacticAttribute' b)
traverse a -> AbsToCon (ConOfAbs a)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
bindToConcrete :: forall b.
TacticAttribute' a
-> (ConOfAbs (TacticAttribute' a) -> AbsToCon b) -> AbsToCon b
bindToConcrete (TacticAttribute Maybe (Ranged a)
a) ConOfAbs (TacticAttribute' a) -> AbsToCon b
ret = Maybe (Ranged a)
-> (ConOfAbs (Maybe (Ranged a)) -> AbsToCon b) -> AbsToCon b
forall b.
Maybe (Ranged a)
-> (ConOfAbs (Maybe (Ranged a)) -> AbsToCon b) -> AbsToCon b
forall a b.
ToConcrete a =>
a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b
bindToConcrete Maybe (Ranged a)
a ((ConOfAbs (Maybe (Ranged a)) -> AbsToCon b) -> AbsToCon b)
-> (ConOfAbs (Maybe (Ranged a)) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ TacticAttribute' (ConOfAbs a) -> AbsToCon b
ConOfAbs (TacticAttribute' a) -> AbsToCon b
ret (TacticAttribute' (ConOfAbs a) -> AbsToCon b)
-> (Maybe (Ranged (ConOfAbs a)) -> TacticAttribute' (ConOfAbs a))
-> Maybe (Ranged (ConOfAbs a))
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Ranged (ConOfAbs a)) -> TacticAttribute' (ConOfAbs a)
forall a. Maybe (Ranged a) -> TacticAttribute' a
TacticAttribute
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
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 NonEmpty AbstractName
xs -> AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty AbstractName
xs)
ConstructorName Set Induction
_ NonEmpty AbstractName
xs -> AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty AbstractName
xs)
PatternSynResName NonEmpty AbstractName
xs -> AbstractName -> AbsToCon (ConOfAbs AbstractName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
List1.head NonEmpty 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
glyphMode <- PragmaOptions -> UnicodeOrAscii
optUseUnicode (PragmaOptions -> UnicodeOrAscii)
-> m PragmaOptions -> m UnicodeOrAscii
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
addSuffixConcrete' glyphMode i <$> x
addSuffixConcrete' :: UnicodeOrAscii -> Integer -> C.QName -> C.QName
addSuffixConcrete' :: UnicodeOrAscii -> Integer -> QName -> QName
addSuffixConcrete' UnicodeOrAscii
glyphMode Integer
i = Lens' QName (Maybe Suffix) -> LensSet QName (Maybe Suffix)
forall o i. Lens' o i -> LensSet o i
set ((Name -> f Name) -> QName -> f QName
Lens' QName Name
C.lensQNameName ((Name -> f Name) -> QName -> f QName)
-> ((Maybe Suffix -> f (Maybe Suffix)) -> Name -> f Name)
-> (Maybe Suffix -> f (Maybe Suffix))
-> QName
-> f QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Suffix -> f (Maybe Suffix)) -> Name -> f Name
Lens' Name (Maybe Suffix)
nameSuffix) Maybe Suffix
suffix
where
suffix :: Maybe Suffix
suffix = Suffix -> Maybe Suffix
forall a. a -> Maybe a
Just (Suffix -> Maybe Suffix) -> Suffix -> Maybe Suffix
forall a b. (a -> b) -> a -> b
$ case UnicodeOrAscii
glyphMode of
UnicodeOrAscii
UnicodeOk -> Integer -> Suffix
Subscript (Integer -> Suffix) -> Integer -> Suffix
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i
UnicodeOrAscii
AsciiOnly -> Integer -> Suffix
Index (Integer -> Suffix) -> Integer -> Suffix
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i
instance ToConcrete A.Expr where
type ConOfAbs A.Expr = C.Expr
toConcrete :: Expr -> AbsToCon (ConOfAbs Expr)
toConcrete (Var Name
x) = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Bound (QName -> Expr) -> (Name -> QName) -> Name -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName (Name -> Expr) -> 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) = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Function (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) = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Field (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
. NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Field (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) = NameKind -> QName -> Expr
KnownIdent NameKind
Asp.Macro (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
$ NameKind -> QName -> Expr
KnownIdent (Induction -> NameKind
Asp.Constructor Induction
Inductive) (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)
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
x <- AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
let r = ExprInfo -> Range
forall a. HasRange a => a -> Range
getRange ExprInfo
i
bracket appBrackets $ return $
C.App r (C.Quote r) (defaultNamedArg $ C.Ident x)
toConcrete e :: Expr
e@(A.Lit ExprInfo
i Literal
l) = Expr -> 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
toConcrete (A.QuestionMark MetaInfo
i InteractionId
ii) = do
preserve <- (Env -> Bool) -> AbsToCon Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
preserveIIds
return $ C.QuestionMark (getRange i) $
interactionId ii <$ guard (preserve || isJust (metaNumber i))
toConcrete (A.Underscore MetaInfo
i) =
Range -> Maybe 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 Aspects -> RawName
forall a. Doc a -> RawName
render (Doc Aspects -> RawName)
-> (NamedMeta -> AbsToCon (Doc Aspects))
-> NamedMeta
-> AbsToCon RawName
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> NamedMeta -> AbsToCon (Doc Aspects)
forall a (m :: * -> *).
(PrettyTCM a, MonadPretty m) =>
a -> m (Doc Aspects)
forall (m :: * -> *). MonadPretty m => NamedMeta -> m (Doc Aspects)
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
is <- AbsToCon (QName -> BuiltinId -> Bool)
isBuiltinFun
case (getHead e1, namedArg e2) of
(Just (HdDef QName
q), l :: Expr
l@A.Lit{})
| (BuiltinId -> Bool) -> [BuiltinId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (QName -> BuiltinId -> Bool
is QName
q) [BuiltinId
builtinFromNat, BuiltinId
builtinFromString], NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Expr
e2,
AppInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin AppInfo
i Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Inserted -> Expr -> 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 -> BuiltinId -> Bool
`is` BuiltinId
builtinFromNeg, NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Expr
e2,
AppInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin AppInfo
i Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Inserted -> Expr -> 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
(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 e1' <- Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
FunctionCtx Expr
e1
e2' <- toConcreteCtx (ArgumentCtx $ appParens i) e2
return $ C.App (getRange i) e1' e2'
toConcrete (A.WithApp ExprInfo
i Expr
e [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
e <- Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
WithFunCtx Expr
e
es <- mapM (toConcreteCtx WithArgCtx) es
return $ C.WithApp (getRange i) e es
toConcrete (A.AbsurdLam ExprInfo
i Hiding
h) =
(PrecedenceStack -> Bool) -> 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
$
[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')
(Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e')
((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
lamView :: A.Expr -> ([A.LamBinding], A.Expr)
lamView :: Expr -> ([LamBinding], Expr)
lamView (A.Lam ExprInfo
_ b :: LamBinding
b@(A.DomainFree TacticAttribute
_ NamedArg Binder
x) Expr
e)
| NamedArg Binder -> Bool
forall a. (LensHiding a, LensOrigin a) => a -> Bool
isInsertedHidden NamedArg Binder
x = Expr -> ([LamBinding], Expr)
lamView Expr
e
| Bool
otherwise = case Expr -> ([LamBinding], Expr)
lamView Expr
e of
(bs :: [LamBinding]
bs@(A.DomainFree{} : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
([LamBinding], Expr)
_ -> ([LamBinding
b] , Expr
e)
lamView (A.Lam ExprInfo
_ b :: LamBinding
b@(A.DomainFull A.TLet{}) Expr
e) = case Expr -> ([LamBinding], Expr)
lamView Expr
e of
(bs :: [LamBinding]
bs@(A.DomainFull TypedBinding
_ : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
([LamBinding], Expr)
_ -> ([LamBinding
b], Expr
e)
lamView (A.Lam ExprInfo
_ (A.DomainFull (A.TBind Range
r TypedBindingInfo
t List1 (NamedArg Binder)
xs Expr
ty)) Expr
e) =
case (NamedArg Binder -> Bool)
-> List1 (NamedArg Binder) -> [NamedArg Binder]
forall a. (a -> Bool) -> NonEmpty a -> [a]
List1.filter (Bool -> Bool
not (Bool -> Bool)
-> (NamedArg Binder -> Bool) -> NamedArg Binder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Binder -> Bool
forall a. (LensHiding a, LensOrigin a) => a -> Bool
isInsertedHidden) List1 (NamedArg Binder)
xs of
[] -> Expr -> ([LamBinding], Expr)
lamView Expr
e
NamedArg Binder
x:[NamedArg Binder]
xs' -> let b :: LamBinding
b = TypedBinding -> LamBinding
A.DomainFull (Range
-> TypedBindingInfo
-> List1 (NamedArg Binder)
-> Expr
-> TypedBinding
A.TBind Range
r TypedBindingInfo
t (NamedArg Binder
x NamedArg Binder -> [NamedArg Binder] -> List1 (NamedArg Binder)
forall a. a -> [a] -> NonEmpty a
:| [NamedArg Binder]
xs') Expr
ty) in
case Expr -> ([LamBinding], Expr)
lamView Expr
e of
(bs :: [LamBinding]
bs@(A.DomainFull TypedBinding
_ : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
([LamBinding], Expr)
_ -> ([LamBinding
b], Expr
e)
lamView Expr
e = ([], Expr
e)
toConcrete (A.ExtendedLam ExprInfo
i DefInfo
di Erased
erased QName
qname List1 Clause
cs) =
(PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
decls <- NonEmpty (NonEmpty Declaration) -> NonEmpty Declaration
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (NonEmpty Declaration) -> NonEmpty Declaration)
-> AbsToCon (NonEmpty (NonEmpty Declaration))
-> AbsToCon (NonEmpty 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
puns <- optHiddenArgumentPuns <$> pragmaOptions
let
noPun (Named Maybe NamedName
Nothing p :: Pattern
p@C.IdentP{}) | Bool
puns =
Maybe NamedName -> Pattern -> Named_ Pattern
forall name a. Maybe name -> a -> Named name a
Named Maybe NamedName
forall a. Maybe a
Nothing (Range -> Pattern -> Pattern
C.ParenP Range
forall a. Range' a
noRange Pattern
p)
noPun Named_ Pattern
p = Named_ Pattern
p
namedPat Arg (Named_ Pattern)
np = case Arg (Named_ Pattern) -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg (Named_ Pattern)
np of
Hiding
NotHidden -> Arg (Named_ Pattern) -> Pattern
forall a. NamedArg a -> a
namedArg Arg (Named_ Pattern)
np
Hiding
Hidden -> Range -> Named_ Pattern -> Pattern
C.HiddenP Range
forall a. Range' a
noRange (Named_ Pattern -> Named_ Pattern
noPun (Arg (Named_ Pattern) -> Named_ Pattern
forall e. Arg e -> e
unArg Arg (Named_ Pattern)
np))
Instance{} -> Range -> Named_ Pattern -> Pattern
C.InstanceP Range
forall a. Range' a
noRange (Named_ Pattern -> Named_ Pattern
noPun (Arg (Named_ Pattern) -> Named_ Pattern
forall e. Arg e -> e
unArg Arg (Named_ Pattern)
np))
let removeApp :: C.Pattern -> AbsToCon [C.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 Bool
_ 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 (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Pattern] -> [Pattern] -> [Pattern]
forall a. [a] -> [a] -> [a]
++ [Arg (Named_ Pattern) -> Pattern
namedPat Arg (Named_ Pattern)
np])
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]
let 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
ps <- Pattern -> AbsToCon [Pattern]
removeApp Pattern
p
reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps
return $ LamClause ps rhs ca
decl2clause Declaration
_ = AbsToCon LamClause
forall a. HasCallStack => a
__IMPOSSIBLE__
C.ExtendedLam (getRange i) erased <$>
mapM decl2clause decls
toConcrete (A.Pi ExprInfo
_ NonEmpty TypedBinding
tel1 Expr
e0) = do
let (NonEmpty TypedBinding
tel, Expr
e) = NonEmpty TypedBinding -> Expr -> (NonEmpty TypedBinding, Expr)
piTel1 NonEmpty TypedBinding
tel1 Expr
e0
(PrecedenceStack -> Bool) -> 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 a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (NonEmpty TypedBinding -> [TypedBinding] -> NonEmpty TypedBinding
forall a. NonEmpty a -> [a] -> NonEmpty 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 a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first NonEmpty TypedBinding -> [Item (NonEmpty TypedBinding)]
NonEmpty TypedBinding -> [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 a' <- Precedence -> Arg Expr -> AbsToCon (ConOfAbs (Arg Expr))
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
ctx Arg Expr
a
b' <- toConcreteTop b
let dom = Relevance -> Arg Expr -> Arg Expr
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Relevant (Arg Expr -> Arg Expr) -> Arg Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Modality -> Arg Expr -> Arg Expr
forall a. LensModality a => Modality -> a -> a
setModality (Arg Expr -> Modality
forall a. LensModality a => a -> Modality
getModality Arg Expr
a') (Arg Expr -> Arg Expr) -> Arg Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Arg Expr
forall a. a -> Arg a
defaultArg (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Arg Expr -> Expr -> Expr
forall {a}. (LensRelevance a, 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'
return $ C.Fun (getRange i) dom b'
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
e' <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
e
return $ C.mkLet (getRange i) (concat ds') 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)
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} ->
TacticAttribute -> NamedArg Binder -> LamBinding
A.DomainFree (TypedBindingInfo -> TacticAttribute
tbTacticAttr TypedBindingInfo
tac) NamedArg Binder
x
Expr
_ -> LamBinding
b
makeDomainFree LamBinding
b = LamBinding
b
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 TacticAttribute
t NamedArg Binder
x) ConOfAbs LamBinding -> AbsToCon b
ret = do
t <- (Expr -> AbsToCon Expr)
-> TacticAttribute -> AbsToCon (TacticAttribute' Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TacticAttribute' a -> f (TacticAttribute' b)
traverse Expr -> AbsToCon Expr
Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete TacticAttribute
t
let setTac BoundName
x = BoundName
x { bnameTactic = t }
bindToConcrete (forceNameIfHidden x) $
ret . Just . C.DomainFree . updateNamedArg (fmap setTac)
bindToConcrete (A.DomainFull TypedBinding
b) ConOfAbs LamBinding -> 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
tac <- (Expr -> AbsToCon Expr)
-> TacticAttribute -> AbsToCon (TacticAttribute' Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TacticAttribute' a -> f (TacticAttribute' b)
traverse Expr -> AbsToCon Expr
Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (TypedBindingInfo -> TacticAttribute
tbTacticAttr TypedBindingInfo
t)
bindToConcrete (fmap forceNameIfHidden xs) $ \ ConOfAbs (List1 (NamedArg Binder))
xs -> do
e <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop Expr
e
let setTac BoundName
x = BoundName
x { bnameTactic = tac , C.bnameIsFinite = tbFinite t }
ret $ Just $ C.TBind r (fmap (updateNamedArg (fmap setTac)) xs) e
bindToConcrete (A.TLet Range
r List1 LetBinding
lbs) ConOfAbs TypedBinding -> 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 (t, (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)
ret $ addInstanceB (if isInstance info then Just empty else Nothing) $
[ C.TypeSig info empty (C.boundName x) t
, C.FunClause
(C.LHS (C.IdentP True $ C.QName $ C.boundName x) [] [])
e C.NoWhere False
]
bindToConcrete (LetPatBind LetInfo
i Pattern
p Expr
e) ConOfAbs LetBinding -> AbsToCon b
ret = do
p <- Pattern -> AbsToCon (ConOfAbs Pattern)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Pattern
p
e <- toConcrete e
ret [ C.FunClause (C.LHS p [] []) (C.RHS e) NoWhere False ]
bindToConcrete (LetApply ModuleInfo
i Erased
erased ModuleName
x ModuleApplication
modapp ScopeCopyInfo
_ ImportDirective
_) ConOfAbs LetBinding -> AbsToCon b
ret = do
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
modapp <- toConcrete modapp
let r = ModuleApplication -> Range
forall a. HasRange a => a -> Range
getRange ModuleApplication
modapp
open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
dir = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir{ importDirRange = r } (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
local (openModule' x dir id) $
ret [ C.ModuleMacro (getRange i) erased x' modapp open dir ]
bindToConcrete (LetOpen ModuleInfo
i ModuleName
x ImportDirective
_) ConOfAbs LetBinding -> AbsToCon b
ret = do
x' <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
let dir = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
local (openModule' x dir restrictPrivate) $
ret [ C.Open (getRange i) x' dir ]
bindToConcrete (LetDeclaredVariable BindName
_) ConOfAbs LetBinding -> AbsToCon b
ret =
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
_ Erased
erased ModuleName
_ GeneralizeTelescope
_ [Declaration]
ds)))
ConOfAbs WhereDeclarations -> AbsToCon b
ret = do
ds' <- [Declaration] -> AbsToCon [Declaration]
declsToConcrete [Declaration]
ds
cm <- unqualify <$> lookupModule am
let wh' = if Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
cm Bool -> Bool -> Bool
&& Bool -> Bool
not (Erased -> Bool
isErased Erased
erased)
then Range -> [Declaration] -> WhereClause' [Declaration]
forall decls. Range -> decls -> WhereClause' decls
AnyWhere Range
forall a. Range' a
noRange [Declaration]
ds'
else Range
-> Erased
-> Name
-> Access
-> [Declaration]
-> WhereClause' [Declaration]
forall decls.
Range -> Erased -> Name -> Access -> decls -> WhereClause' decls
SomeWhere Range
forall a. Range' a
noRange Erased
erased Name
cm Access
PublicAccess [Declaration]
ds'
local (openModule' am defaultImportDir id) $ ret wh'
bindToConcrete (A.WhereDecls Maybe ModuleName
_ Bool
_ (Just Declaration
d)) ConOfAbs WhereDeclarations -> 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
_ Erased
er Name
x [LamBinding]
bs Expr
e : C.RecordDef Range
r Name
y [RecordDirective]
dir [LamBinding]
_ [Declaration]
fs : [Declaration]
ds)
| Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Erased
-> Name
-> [RecordDirective]
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Erased
er Name
y [RecordDirective]
dir [LamBinding]
bs Expr
e [Declaration]
fs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (C.DataSig Range
_ Erased
er Name
x [LamBinding]
bs Expr
e : C.DataDef Range
r Name
y [LamBinding]
_ [Declaration]
cs : [Declaration]
ds)
| Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Erased
-> Name
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Data Range
r Erased
er Name
y [LamBinding]
bs Expr
e [Declaration]
cs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (Declaration
d : [Declaration]
ds) = Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef [] = []
openModule' :: A.ModuleName -> C.ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' :: ModuleName -> ImportDirective -> (Scope -> Scope) -> Env -> Env
openModule' ModuleName
x ImportDirective
dir Scope -> Scope
restrict Env
env = Env
env{currentScope = set scopeModules mods' sInfo}
where sInfo :: ScopeInfo
sInfo = Env -> ScopeInfo
currentScope Env
env
amod :: ModuleName
amod = ScopeInfo
sInfo ScopeInfo -> Lens' ScopeInfo ModuleName -> ModuleName
forall o i. o -> Lens' o i -> i
^. (ModuleName -> f ModuleName) -> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo ModuleName
scopeCurrent
mods :: Map ModuleName Scope
mods = ScopeInfo
sInfo ScopeInfo
-> Lens' ScopeInfo (Map ModuleName Scope) -> Map ModuleName Scope
forall o i. o -> Lens' o i -> i
^. (Map ModuleName Scope -> f (Map ModuleName Scope))
-> ScopeInfo -> f ScopeInfo
Lens' ScopeInfo (Map ModuleName Scope)
scopeModules
news :: Scope
news = NameSpaceId -> Scope -> Scope
setScopeAccess NameSpaceId
PrivateNS
(Scope -> Scope) -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ ImportDirective -> Scope -> Scope
applyImportDirective ImportDirective
dir
(Scope -> Scope) -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ Scope -> (Scope -> Scope) -> Maybe Scope -> Scope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scope
emptyScope Scope -> Scope
restrict
(Maybe Scope -> Scope) -> Maybe Scope -> Scope
forall a b. (a -> b) -> a -> b
$ ModuleName -> Map ModuleName Scope -> Maybe Scope
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
x Map ModuleName Scope
mods
mods' :: Map ModuleName Scope
mods' = (Scope -> Maybe Scope)
-> ModuleName -> Map ModuleName Scope -> Map ModuleName Scope
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> (Scope -> Scope) -> Scope -> Maybe Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scope -> Scope -> Scope
`mergeScope` Scope
news)) ModuleName
amod Map ModuleName Scope
mods
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
e <- Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete Expr
e
return (C.RHS 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 List1 Clause
cs) = do
es <- do es <- [WithExpr] -> AbsToCon (ConOfAbs [WithExpr])
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete [WithExpr]
es
forM es $ \ (Named Maybe BindName
n Arg Expr
e) -> do
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
pure $ Named (C.boundName <$> n) e
cs <- noTakenNames $ sconcat <$> toConcrete cs
return (C.AbsurdRHS, [], es, List1.toList cs)
toConcrete (A.RewriteRHS [RewriteEqn]
xeqs [ProblemEq]
_spats RHS
rhs WhereDeclarations
wh) = do
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, eqs', es, whs) <- toConcrete rhs
unless (null eqs') __IMPOSSIBLE__
eqs <- toConcrete xeqs
return (rhs, eqs, es, wh ++ whs)
instance (ToConcrete p, ToConcrete a) => ToConcrete (RewriteEqn' qn A.BindName p a) where
type ConOfAbs (RewriteEqn' qn A.BindName p a) = (RewriteEqn' () C.Name (ConOfAbs p) (ConOfAbs a))
toConcrete :: 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
pe <- (p, a) -> AbsToCon (ConOfAbs (p, a))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete (p, a)
pe
n <- fmap C.boundName <$> toConcrete n
pure $ Named n pe
LeftLet List1 (p, a)
pes -> List1 (ConOfAbs p, ConOfAbs a)
-> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a)
forall qn nm p e. List1 (p, e) -> RewriteEqn' qn nm p e
LeftLet (List1 (ConOfAbs p, ConOfAbs a)
-> RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
-> AbsToCon (List1 (ConOfAbs p, ConOfAbs a))
-> AbsToCon (RewriteEqn' () Name (ConOfAbs p) (ConOfAbs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((p, a) -> AbsToCon (ConOfAbs p, ConOfAbs a))
-> List1 (p, a) -> AbsToCon (List1 (ConOfAbs p, ConOfAbs a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (p, a) -> AbsToCon (ConOfAbs p, ConOfAbs a)
(p, a) -> AbsToCon (ConOfAbs (p, a))
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete List1 (p, a)
pes
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
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
t' <- toConcreteTop t
return $ C.TypeSig info empty x' 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] -> Declaration
forall a. a -> [a] -> a
headWithDefault Declaration
forall a. HasCallStack => a
__IMPOSSIBLE__ ([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) = List1 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', eqs, with, wcs) <- RHS -> AbsToCon (ConOfAbs RHS)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcreteTop RHS
rhs
return $ FunClause (C.LHS p eqs with) rhs' wh' catchall :| wcs
instance ToConcrete A.ModuleApplication where
type ConOfAbs A.ModuleApplication = C.ModuleApplication
toConcrete :: ModuleApplication -> AbsToCon (ConOfAbs ModuleApplication)
toConcrete (A.SectionApp [TypedBinding]
tel ModuleName
y [NamedArg Expr]
es) = do
y <- Precedence -> ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
FunctionCtx ModuleName
y
bindToConcrete tel $ \ ConOfAbs [TypedBinding]
tel -> do
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 = QName -> [NamedArg Expr] -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange QName
y [NamedArg Expr]
es
return $ C.SectionApp r (catMaybes tel) (foldl (C.App r) (C.Ident y) es)
toConcrete (A.RecordModuleInstance ModuleName
recm) = do
recm <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
recm
return $ C.RecordModuleInstance (getRange recm) recm
instance ToConcrete A.RecordDirectives where
type ConOfAbs A.RecordDirectives = [C.RecordDirective]
toConcrete :: RecordDirectives -> AbsToCon (ConOfAbs RecordDirectives)
toConcrete RecordDirectives
dir = RecordDirectives -> [RecordDirective]
C.ungatherRecordDirectives (RecordDirectives -> [RecordDirective])
-> AbsToCon RecordDirectives -> AbsToCon [RecordDirective]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QName -> AbsToCon (Name, IsInstance))
-> RecordDirectives -> AbsToCon RecordDirectives
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> RecordDirectives' a -> f (RecordDirectives' b)
traverse QName -> AbsToCon (Name, IsInstance)
f RecordDirectives
dir
where
f :: A.QName -> AbsToCon (C.Name, IsInstance)
f :: QName -> AbsToCon (Name, IsInstance)
f = (,IsInstance
NotInstanceDef) (Name -> (Name, IsInstance))
-> (QName -> AbsToCon Name) -> QName -> AbsToCon (Name, IsInstance)
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> QName -> Name
C.unqualify (QName -> Name)
-> (QName -> AbsToCon QName) -> QName -> AbsToCon Name
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> QName -> AbsToCon QName
QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete
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
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
withAbstractPrivate i $
withInfixDecl i x' $ do
t' <- toConcreteTop t
return $
(case 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)]) ++
[C.Postulate empty [C.TypeSig info empty x' t']]
toConcrete (A.Generalize Set QName
s DefInfo
i ArgInfo
j QName
x Expr
t) = do
x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> 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
tac <- toConcrete (defTactic i)
withAbstractPrivate i $
withInfixDecl i x' $ do
t' <- toConcreteTop t
return [C.Generalize empty [C.TypeSig j tac x' $ C.Generalized t']]
toConcrete (A.Field DefInfo
i QName
x Arg Expr
t) = do
x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> 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
tac <- toConcrete (defTactic i)
withAbstractPrivate i $
withInfixDecl i x' $ do
t' <- toConcreteTop t
return [C.FieldSig (A.defInstance i) tac x' t']
toConcrete (A.Primitive DefInfo
i QName
x Arg Expr
t) = do
x' <- QName -> Name
unsafeQNameToName (QName -> Name) -> 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
withAbstractPrivate i $
withInfixDecl i x' $ do
t' <- traverse toConcreteTop t
return [C.Primitive empty [C.TypeSig (argInfo t') empty x' (unArg t')]]
toConcrete (A.FunDef DefInfo
i QName
_ [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
$ [NonEmpty Declaration] -> [Declaration]
forall a. [List1 a] -> [a]
List1.concat ([NonEmpty Declaration] -> [Declaration])
-> AbsToCon [NonEmpty 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 Erased
erased 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
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
t' <- toConcreteTop t
return [ C.DataSig (getRange i) erased x'
(map C.DomainFull $ catMaybes tel') t' ]
toConcrete (A.DataDef DefInfo
i QName
x UniverseCheck
uc DataDefParams
bs [Declaration]
cs) =
DefInfo -> 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
(x',cs') <- (QName -> Name) -> (QName, [Declaration]) -> (Name, [Declaration])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first QName -> Name
unsafeQNameToName ((QName, [Declaration]) -> (Name, [Declaration]))
-> 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)
return [ C.DataDef (getRange i) x' (catMaybes tel') cs' ]
toConcrete (A.RecSig DefInfo
i Erased
erased 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
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
t' <- toConcreteTop t
return [ C.RecordSig (getRange i) erased x'
(map C.DomainFull $ catMaybes tel') t' ]
toConcrete (A.RecDef DefInfo
i QName
x UniverseCheck
uc RecordDirectives
dir DataDefParams
bs Expr
t [Declaration]
cs) =
DefInfo -> 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
dirs <- RecordDirectives -> AbsToCon (ConOfAbs RecordDirectives)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete RecordDirectives
dir
(x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)
return [ C.RecordDef (getRange i) x' dirs (catMaybes tel') cs' ]
toConcrete (A.Mutual MutualInfo
i [Declaration]
ds) = Declaration -> [Declaration]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Declaration -> [Declaration])
-> ([Declaration] -> Declaration) -> [Declaration] -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KwRange -> [Declaration] -> Declaration
C.Mutual KwRange
forall a. Null a => a
empty ([Declaration] -> [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> AbsToCon [Declaration]
declsToConcrete [Declaration]
ds
toConcrete (A.Section Range
i Erased
erased ModuleName
x (A.GeneralizeTel Map QName Name
_ [TypedBinding]
tel) [Declaration]
ds) = do
x <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
bindToConcrete tel $ \ ConOfAbs [TypedBinding]
tel -> do
ds <- [Declaration] -> AbsToCon [Declaration]
declsToConcrete [Declaration]
ds
return [ C.Module (getRange i) erased x (catMaybes tel) ds ]
toConcrete (A.Apply ModuleInfo
i Erased
erased ModuleName
x ModuleApplication
modapp ScopeCopyInfo
_ ImportDirective
_) = do
x <- QName -> Name
unsafeQNameToName (QName -> Name) -> 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
modapp <- toConcrete modapp
let r = ModuleApplication -> Range
forall a. HasRange a => a -> Range
getRange ModuleApplication
modapp
open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
dir = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir{ importDirRange = r } (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
return [ C.ModuleMacro (getRange i) erased x modapp open dir ]
toConcrete (A.Import ModuleInfo
i ModuleName
x ImportDirective
_) = do
x <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
let open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
dir = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
return [ C.Import (getRange i) x Nothing open dir]
toConcrete (A.Pragma Range
i Pragma
p) = do
p <- RangeAndPragma -> 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
return [C.Pragma p]
toConcrete (A.Open ModuleInfo
i ModuleName
x ImportDirective
_) = do
x <- ModuleName -> AbsToCon (ConOfAbs ModuleName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete ModuleName
x
return [C.Open (getRange i) x defaultImportDir]
toConcrete (A.PatternSynDef QName
x [WithHiding BindName]
xs Pattern' Void
p) = do
C.QName x <- QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
bindToConcrete (map (fmap A.unBind) xs) $ \ ConOfAbs [WithHiding Name]
xs ->
Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton (Declaration -> [Declaration])
-> (Pattern -> Declaration) -> Pattern -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Name -> [WithHiding Name] -> Pattern -> Declaration
C.PatternSyn (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x) Name
x [WithHiding Name]
ConOfAbs [WithHiding Name]
xs (Pattern -> [Declaration])
-> 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__
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
(:[]) . C.UnquoteDecl (getRange i) xs <$> toConcrete e
toConcrete (A.UnquoteDef [DefInfo]
i [QName]
xs Expr
e) = do
let unqual :: QName -> m Name
unqual (C.QName Name
x) = Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
unqual QName
_ = m Name
forall a. HasCallStack => a
__IMPOSSIBLE__
xs <- (QName -> 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
(:[]) . C.UnquoteDef (getRange i) xs <$> toConcrete 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__
toConcrete (A.UnfoldingDecl Range
r [QName]
ns) = [Declaration] -> AbsToCon [Declaration]
forall a. a -> AbsToCon a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
data RangeAndPragma = RangeAndPragma Range A.Pragma
instance ToConcrete RangeAndPragma where
type ConOfAbs RangeAndPragma = C.Pragma
toConcrete :: 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
x <- QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
x
return $ C.CompilePragma r b x 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.InjectiveForInferencePragma QName
x -> Range -> QName -> Pragma
C.InjectiveForInferencePragma 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.OverlapPragma QName
q OverlapMode
i -> Range -> [QName] -> OverlapMode -> Pragma
C.OverlapPragma Range
r ([QName] -> OverlapMode -> Pragma)
-> AbsToCon [QName] -> AbsToCon (OverlapMode -> Pragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((QName -> [QName]) -> AbsToCon QName -> AbsToCon [QName]
forall a b. (a -> b) -> AbsToCon a -> AbsToCon b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QName -> [QName]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> AbsToCon (ConOfAbs QName)
forall a. ToConcrete a => a -> AbsToCon (ConOfAbs a)
toConcrete QName
q)) AbsToCon (OverlapMode -> Pragma)
-> AbsToCon OverlapMode -> 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
<*> OverlapMode -> AbsToCon OverlapMode
forall a. a -> AbsToCon a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
i
A.EtaPragma QName
x -> Range -> QName -> Pragma
C.EtaPragma Range
r (QName -> Pragma) -> 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
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
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 = y }
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 = 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
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 ConPatInfo
i [FieldAssignment' Pattern]
args
| ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit -> ConOfAbs (UserPattern Pattern) -> AbsToCon b
ret Pattern
ConOfAbs (UserPattern Pattern)
p
| Bool
otherwise -> [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
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
A.AsP PatInfo
i BindName
x Pattern
p -> Name -> 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
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
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 ConPatInfo
i [FieldAssignment' Pattern]
args
| ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit
-> [FieldAssignment' BindingPattern]
-> (ConOfAbs [FieldAssignment' BindingPattern] -> 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 (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
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
| Bool
otherwise -> [FieldAssignment' (SplitPattern Pattern)]
-> (ConOfAbs [FieldAssignment' (SplitPattern Pattern)]
-> 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
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
A.AsP PatInfo
i BindName
x Pattern
p -> SplitPattern Pattern
-> (ConOfAbs (SplitPattern Pattern) -> 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
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 ConPatInfo
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
. ConPatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e.
ConPatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP ConPatInfo
i
A.AsP PatInfo
i BindName
x Pattern
p -> FreshenName -> (ConOfAbs FreshenName -> 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
prec <- AbsToCon PrecedenceStack
currentPrecedence
bindToConcrete (UserPattern p) $ \ 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 ->
Bool -> QName -> Pattern
C.IdentP Bool
True (QName -> Pattern) -> (BoundName -> QName) -> BoundName -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName (Name -> QName) -> (BoundName -> Name) -> BoundName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundName -> Name
C.boundName (BoundName -> Pattern) -> 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 -> Bool -> QName -> Pattern
C.IdentP Bool
True (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
(x, p) <- Precedence
-> (BindName, Pattern) -> AbsToCon (ConOfAbs (BindName, Pattern))
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ (BindName
x, Pattern
p)
return $ C.AsP (getRange i) (C.boundName x) 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
x <- AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
bracketP_ appBrackets $ return $
C.AppP (C.QuoteP (getRange i))
(defaultNamedArg (C.IdentP True x))
A.LitP PatInfo
i Literal
l ->
Pattern -> 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
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
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
cn <- Name -> AbsToCon Name
toConcreteName Name
v
resolveName (someKindsOfNames [FldName]) Nothing (C.QName cn) >>= \ case
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 ConPatInfo
i [FieldAssignment' Pattern]
as ->
Range -> [FieldAssignment' Pattern] -> Pattern
C.RecP (ConPatInfo -> Range
forall a. HasRange a => a -> Range
getRange ConPatInfo
i) ([FieldAssignment' Pattern] -> Pattern)
-> 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
where
printDotDefault :: PatInfo -> A.Expr -> AbsToCon C.Pattern
printDotDefault :: PatInfo -> Expr -> AbsToCon Pattern
printDotDefault PatInfo
i Expr
e = do
c <- Precedence -> Expr -> AbsToCon (ConOfAbs Expr)
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
DotPatternCtx Expr
e
let r = PatInfo -> Range
forall a. HasRange a => a -> Range
getRange PatInfo
i
case c of
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
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 b a. IsBool b => b -> (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
. Bool -> QName -> Pattern
C.IdentP Bool
True (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
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
<$>
((Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern)))
-> [Arg (Named_ Pattern)] -> AbsToCon [Arg (Named_ Pattern)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern))
avoidPun ([Arg (Named_ Pattern)] -> AbsToCon [Arg (Named_ Pattern)])
-> AbsToCon [Arg (Named_ Pattern)]
-> AbsToCon [Arg (Named_ Pattern)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Precedence -> [arg] -> AbsToCon (ConOfAbs [arg])
forall a. ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)
toConcreteCtx Precedence
argumentCtx_ [arg]
args)
avoidPun :: NamedArg C.Pattern -> AbsToCon (NamedArg C.Pattern)
avoidPun :: Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern))
avoidPun Arg (Named_ Pattern)
arg =
AbsToCon Bool
-> AbsToCon (Arg (Named_ Pattern))
-> AbsToCon (Arg (Named_ Pattern))
-> AbsToCon (Arg (Named_ Pattern))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PragmaOptions -> Bool
optHiddenArgumentPuns (PragmaOptions -> Bool) -> AbsToCon PragmaOptions -> AbsToCon Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions)
(Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern))
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern)))
-> Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern))
forall a b. (a -> b) -> a -> b
$ case Arg (Named_ Pattern)
arg of
Arg ArgInfo
i (Named Maybe NamedName
Nothing x :: Pattern
x@C.IdentP{}) | ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
notVisible ArgInfo
i ->
ArgInfo -> Named_ Pattern -> Arg (Named_ Pattern)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (Maybe NamedName -> Pattern -> Named_ Pattern
forall name a. Maybe name -> a -> Named name a
Named Maybe NamedName
forall a. Maybe a
Nothing (Range -> Pattern -> Pattern
C.ParenP Range
forall a. Range' a
noRange Pattern
x))
Arg (Named_ Pattern)
arg -> Arg (Named_ Pattern)
arg)
(Arg (Named_ Pattern) -> AbsToCon (Arg (Named_ Pattern))
forall a. a -> AbsToCon a
forall (m :: * -> *) a. Monad m => a -> m a
return Arg (Named_ Pattern)
arg)
tryToRecoverNatural :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr
tryToRecoverNatural :: Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverNatural Expr
e AbsToCon Expr
def = do
is <- AbsToCon (QName -> BuiltinId -> Bool)
isBuiltinFun
caseMaybe (recoverNatural is e) def $ return . C.Lit noRange . LitNat
recoverNatural :: (A.QName -> BuiltinId -> Bool) -> A.Expr -> Maybe Integer
recoverNatural :: (QName -> BuiltinId -> Bool) -> Expr -> Maybe Integer
recoverNatural QName -> BuiltinId -> Bool
is Expr
e = (QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore (QName -> BuiltinId -> Bool
`is` BuiltinId
builtinZero) (QName -> BuiltinId -> Bool
`is` BuiltinId
builtinSuc) Integer
0 Expr
e
where
explore :: (A.QName -> Bool) -> (A.QName -> Bool) -> Integer -> A.Expr -> Maybe Integer
explore :: (QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore QName -> Bool
isZero QName -> Bool
isSuc Integer
k (A.App AppInfo
_ (A.Con AmbiguousQName
c) NamedArg Expr
t) | Just QName
f <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c, QName -> Bool
isSuc QName
f
= ((QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore QName -> Bool
isZero QName -> Bool
isSuc (Integer -> Expr -> Maybe Integer)
-> Integer -> Expr -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
t)
explore QName -> Bool
isZero QName -> Bool
isSuc Integer
k (A.Con AmbiguousQName
c) | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
c, QName -> Bool
isZero QName
x = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
k
explore QName -> Bool
isZero QName -> Bool
isSuc Integer
k (A.Lit ExprInfo
_ (LitNat Integer
l)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
l)
explore QName -> Bool
_ QName -> Bool
_ Integer
_ Expr
_ = Maybe Integer
forall a. Maybe a
Nothing
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 :: Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr
cOpApp :: NameKind
-> Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr
cOpApp NameKind
nk Range
r QName
x Name
n List1 (MaybeSection Expr)
es =
NameKind -> Range -> QName -> Set Name -> OpAppArgs -> Expr
C.KnownOpApp NameKind
nk 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)
-> (NameKind
-> 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)
-> (NameKind
-> 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) NameKind
-> Range -> QName -> Name -> List1 (MaybeSection Expr) -> Expr
cOpApp Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))])
view Expr
e
where
view :: A.Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Expr))])
view :: Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Expr))])
view Expr
e
| 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
insertedName :: LamBinding -> Maybe Binder
insertedName (A.DomainFree TacticAttribute
_ NamedArg Binder
x)
| NamedArg Binder -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Binder
x Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
Inserted Bool -> Bool -> Bool
&& NamedArg Binder -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Binder
x = Binder -> Maybe Binder
forall a. a -> Maybe a
Just (Binder -> Maybe Binder) -> Binder -> Maybe Binder
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg NamedArg Binder
x
insertedName LamBinding
_ = Maybe Binder
forall a. Maybe a
Nothing
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
res <- ((PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern)
-> (Pattern -> Bool)
-> (NameKind
-> 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)
-> (NameKind
-> 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)
-> NameKind
-> Range
-> QName
-> Name
-> List1 (MaybeSection Pattern)
-> Pattern
forall a b. a -> b -> a
const 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
reportS "print.op" 90
[ "tryToRecoverOpApp"
, "in: " ++ show p
, "out: " ++ show res
]
return 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
$
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
recoverOpApp :: forall a c . (ToConcrete a, c ~ ConOfAbs a, HasRange c)
=> ((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)
-> (a -> Bool)
-> (Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)
-> (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)
-> (NameKind
-> 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 NameKind -> Range -> QName -> Name -> List1 (MaybeSection c) -> c
opApp a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])
view a
e = case a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])
view a
e of
Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))])
Nothing -> 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'
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
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 -> 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
(fx, nk) <- resolveName_ x [n'] <&> \ case
VarName Name
y BindingSource
_ -> (Name
y Name -> Lens' Name Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> Name -> f Name
forall a. LensFixity a => Lens' a Fixity
Lens' Name Fixity
lensFixity, NameKind
Asp.Bound)
DefinedName Access
_ AbstractName
q Suffix
_ -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, NameKind
Asp.Function)
FieldName (AbstractName
q :| [AbstractName]
_) -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, NameKind
Asp.Field)
ConstructorName Set Induction
_ (AbstractName
q :| [AbstractName]
_) -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, Induction -> NameKind
Asp.Constructor Induction
Asp.Inductive)
PatternSynResName (AbstractName
q :| [AbstractName]
_) -> (AbstractName
q AbstractName -> Lens' AbstractName Fixity -> Fixity
forall o i. o -> Lens' o i -> i
^. (Fixity -> f Fixity) -> AbstractName -> f AbstractName
forall a. LensFixity a => Lens' a Fixity
Lens' AbstractName Fixity
lensFixity, Induction -> NameKind
Asp.Constructor Induction
Asp.Inductive)
ResolvedName
UnknownName -> (Fixity
noFixity, NameKind
Asp.Bound)
List1.ifNull args mDefault $ \ List1 (MaybeSection (AppInfo, a))
as ->
NameKind
-> Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> AbsToCon (Maybe c)
doQName NameKind
nk Fixity
fx QName
x Name
n' List1 (MaybeSection (AppInfo, a))
as (Name -> NameParts
C.nameParts (Name -> NameParts) -> Name -> NameParts
forall a b. (a -> b) -> a -> b
$ QName -> Name
C.unqualify QName
x)
doQName :: Asp.NameKind -> Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> AbsToCon (Maybe c)
doQName :: NameKind
-> Fixity
-> QName
-> Name
-> List1 (MaybeSection (AppInfo, a))
-> NameParts
-> AbsToCon (Maybe c)
doQName NameKind
nk Fixity
_ QName
x Name
_ List1 (MaybeSection (AppInfo, a))
as NameParts
xs
| List1 (MaybeSection (AppInfo, a)) -> VerboseLevel
forall a. NonEmpty a -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length List1 (MaybeSection (AppInfo, a))
as VerboseLevel -> VerboseLevel -> Bool
forall a. Eq a => a -> a -> Bool
/= QName -> VerboseLevel
forall a. NumHoles a => a -> VerboseLevel
numHoles QName
x = AbsToCon (Maybe c)
forall {a}. AbsToCon (Maybe a)
mDefault
doQName NameKind
nk Fixity
fixity QName
x Name
n (MaybeSection (AppInfo, a)
a1 :| [MaybeSection (AppInfo, a)]
as) NameParts
xs
| NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.head NameParts
xs
, NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.last NameParts
xs = do
let ([MaybeSection (AppInfo, a)]
as', MaybeSection (AppInfo, a)
an) = [MaybeSection (AppInfo, a)]
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
-> (List1 (MaybeSection (AppInfo, a))
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a)))
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [MaybeSection (AppInfo, a)]
as ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a. HasCallStack => a
__IMPOSSIBLE__ 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
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
es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'
en <- traverse (uncurry $ toConcreteCtx . RightOperandCtx fixity . appParens) an
return $ opApp nk (getRange (e1, en)) x n (e1 :| es ++ [en])
doQName NameKind
nk Fixity
fixity QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
xs
| NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.last NameParts
xs = do
let ([MaybeSection (AppInfo, a)]
as', MaybeSection (AppInfo, a)
an) = List1 (MaybeSection (AppInfo, a))
-> ([MaybeSection (AppInfo, a)], MaybeSection (AppInfo, a))
forall a. List1 a -> ([a], a)
List1.initLast List1 (MaybeSection (AppInfo, a))
as
c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> 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
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'
en <- 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) an
return $ opApp nk (getRange (n, en)) x n (List1.snoc es en)
doQName NameKind
nk Fixity
fixity QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
xs
| NamePart
Hole <- NameParts -> NamePart
forall a. NonEmpty a -> a
List1.head NameParts
xs = do
let a1 :: MaybeSection (AppInfo, a)
a1 = List1 (MaybeSection (AppInfo, a)) -> MaybeSection (AppInfo, a)
forall a. NonEmpty a -> a
List1.head List1 (MaybeSection (AppInfo, a))
as
as' :: [MaybeSection (AppInfo, a)]
as' = List1 (MaybeSection (AppInfo, a)) -> [MaybeSection (AppInfo, a)]
forall a. NonEmpty a -> [a]
List1.tail List1 (MaybeSection (AppInfo, a))
as
e1 <- ((AppInfo, a) -> 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
es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'
Just <$> do
bracket (opBrackets fixity) $
return $ opApp nk (getRange (e1, n)) x n (e1 :| es)
doQName NameKind
nk Fixity
_ QName
x Name
n List1 (MaybeSection (AppInfo, a))
as NameParts
_ = do
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
Just <$> do
bracket roundFixBrackets $
return $ opApp nk (getRange x) x n es
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 [WithHiding Expr])
-> Expr
-> AbsToCon (ConOfAbs Expr)
-> AbsToCon (ConOfAbs Expr)
forall a.
ToConcrete a =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg Expr] -> Expr
apply PatternSynDefn -> Expr -> Maybe [WithHiding 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
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
tryToRecoverPatternSynP :: A.Pattern -> AbsToCon C.Pattern -> AbsToCon C.Pattern
tryToRecoverPatternSynP :: Pattern -> AbsToCon Pattern -> AbsToCon Pattern
tryToRecoverPatternSynP = (QName -> [NamedArg Pattern] -> Pattern)
-> (PatternSynDefn -> Pattern -> Maybe [WithHiding Pattern])
-> Pattern
-> AbsToCon (ConOfAbs Pattern)
-> AbsToCon (ConOfAbs Pattern)
forall a.
ToConcrete a =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg Pattern] -> Pattern
forall {e}. QName -> NAPs e -> Pattern' e
apply PatternSynDefn -> Pattern -> Maybe [WithHiding Pattern]
forall e.
PatternSynDefn -> Pattern' e -> Maybe [WithHiding (Pattern' e)]
matchPatternSynP
where apply :: QName -> NAPs e -> Pattern' e
apply QName
c NAPs e
args = PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
PatternSynP PatInfo
patNoRange (QName -> AmbiguousQName
unambiguous QName
c) NAPs e
args
recoverPatternSyn :: forall a. ToConcrete a
=> (A.QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn :: forall a.
ToConcrete a =>
(QName -> [NamedArg a] -> a)
-> (PatternSynDefn -> a -> Maybe [WithHiding a])
-> a
-> AbsToCon (ConOfAbs a)
-> AbsToCon (ConOfAbs a)
recoverPatternSyn QName -> [NamedArg a] -> a
applySyn PatternSynDefn -> a -> Maybe [WithHiding a]
match a
e AbsToCon (ConOfAbs a)
fallback = do
doFold <- (Env -> Bool) -> AbsToCon Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Bool
foldPatternSynonyms
if not doFold then fallback else do
psyns <- getAllPatternSyns
scope <- getScope
reportSLn "toConcrete.patsyn" 100 $ render $ hsep $
[ "Scope when attempting to recover pattern synonyms:"
, pretty scope
]
let isConP ConP{} = Bool
True
isConP Pattern' e
_ = Bool
False
cands = [ (QName
q, [WithHiding a]
args, Pattern' Void -> VerboseLevel
score Pattern' Void
rhs)
| (QName
q, psyndef :: PatternSynDefn
psyndef@([WithHiding Name]
_, Pattern' Void
rhs)) <- [(QName, PatternSynDefn)] -> [(QName, PatternSynDefn)]
forall a. [a] -> [a]
reverse ([(QName, PatternSynDefn)] -> [(QName, PatternSynDefn)])
-> [(QName, PatternSynDefn)] -> [(QName, PatternSynDefn)]
forall a b. (a -> b) -> a -> b
$ PatternSynDefns -> [(QName, PatternSynDefn)]
forall k a. Map k a -> [(k, a)]
Map.toList PatternSynDefns
psyns
, Pattern' Void -> Bool
forall {e}. Pattern' e -> Bool
isConP Pattern' Void
rhs
, Just [WithHiding a]
args <- [PatternSynDefn -> a -> Maybe [WithHiding a]
match PatternSynDefn
psyndef a
e]
, C.QName{} <- Maybe QName -> [QName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList (Maybe QName -> [QName]) -> Maybe QName -> [QName]
forall a b. (a -> b) -> a -> b
$ [QName] -> Maybe QName
forall a. [a] -> Maybe a
listToMaybe ([QName] -> Maybe QName) -> [QName] -> Maybe QName
forall a b. (a -> b) -> a -> b
$ QName -> ScopeInfo -> [QName]
inverseScopeLookupName QName
q ScopeInfo
scope
]
cmp (a
_, b
_, a
x) (a
_, b
_, a
y) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
y a
x
reportSLn "toConcrete.patsyn" 50 $ render $ hsep $
[ "Found pattern synonym candidates:"
, prettyList_ $ map (\ (QName
q,[WithHiding a]
_,VerboseLevel
_) -> QName
q) cands
]
case sortBy cmp cands of
(QName
q, [WithHiding a]
args, VerboseLevel
_) : [(QName, [WithHiding a], VerboseLevel)]
_ -> a -> 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
$
[WithHiding a] -> (WithHiding a -> NamedArg a) -> [NamedArg a]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [WithHiding a]
args ((WithHiding a -> NamedArg a) -> [NamedArg a])
-> (WithHiding a -> NamedArg a) -> [NamedArg a]
forall a b. (a -> b) -> a -> b
$ \ (WithHiding Hiding
h a
arg) -> Hiding -> NamedArg a -> NamedArg a
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
h (NamedArg a -> NamedArg a) -> NamedArg a -> NamedArg a
forall a b. (a -> b) -> a -> b
$ a -> NamedArg a
forall a. a -> NamedArg a
defaultNamedArg a
arg
[] -> AbsToCon (ConOfAbs a)
fallback
where
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
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 Aspects -> Maybe RawName) -> Doc Aspects -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawName -> Maybe RawName
forall a. a -> Maybe a
Just (RawName -> Maybe RawName)
-> (Doc Aspects -> RawName) -> Doc Aspects -> Maybe RawName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Aspects -> RawName
forall a. Doc a -> RawName
render (Doc Aspects -> Expr) -> AbsToCon (Doc Aspects) -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedMeta -> AbsToCon (Doc Aspects)
forall a (m :: * -> *).
(PrettyTCM a, MonadPretty m) =>
a -> m (Doc Aspects)
forall (m :: * -> *). MonadPretty m => NamedMeta -> m (Doc Aspects)
prettyTCM NamedMeta
i