{-# LANGUAGE CPP                    #-}
{-# LANGUAGE UndecidableInstances   #-}

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

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

import Prelude hiding (null)

import Control.Arrow (first)
import Control.Monad.Reader
import Control.Monad.State

import qualified Control.Monad.Fail as Fail

import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Foldable as Fold
import Data.Traversable (traverse)
import Data.Void
import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty

import Agda.Syntax.Common
import Agda.Syntax.Position
import Agda.Syntax.Literal
import Agda.Syntax.Info as A
import Agda.Syntax.Internal (MetaId(..))
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.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.Debug
import Agda.TypeChecking.Monad.Builtin
import Agda.Interaction.Options

import qualified Agda.Utils.AssocList as AssocList
import Agda.Utils.Either
import Agda.Utils.Except
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Singleton
import Agda.Utils.Pretty

import Agda.Utils.Impossible

-- Environment ------------------------------------------------------------

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

makeEnv :: MonadAbsToCon m => ScopeInfo -> m Env
makeEnv :: ScopeInfo -> m Env
makeEnv ScopeInfo
scope = do
      -- zero and suc doesn't have to be in scope for natural number literals to work
  let noScopeCheck :: String -> Bool
noScopeCheck String
b = String
b String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
builtinZero, String
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 :: String -> m [(String, QName)]
builtin String
b = String -> m (Maybe Term)
forall (m :: * -> *). HasBuiltins m => String -> m (Maybe Term)
getBuiltin' String
b m (Maybe Term)
-> (Maybe Term -> m [(String, QName)]) -> m [(String, QName)]
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,
                 String -> Bool
noScopeCheck String
b Bool -> Bool -> Bool
|| QName -> ScopeInfo -> Bool
isNameInScope QName
q ScopeInfo
scope -> [(String, QName)] -> m [(String, QName)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String
b, QName
q)]
        Maybe Term
_                                                -> [(String, QName)] -> m [(String, QName)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [Name]
ctxVars <- (Dom' Term (Name, Type) -> Name)
-> [Dom' Term (Name, Type)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ((Name, Type) -> Name
forall a b. (a, b) -> a
fst ((Name, Type) -> Name)
-> (Dom' Term (Name, Type) -> (Name, Type))
-> Dom' Term (Name, Type)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom' Term (Name, Type) -> (Name, Type)
forall t e. Dom' t e -> e
I.unDom) ([Dom' Term (Name, Type)] -> [Name])
-> m [Dom' Term (Name, Type)] -> m [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> [Dom' Term (Name, Type)]) -> m [Dom' Term (Name, Type)]
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> [Dom' Term (Name, Type)]
envContext
  [Name]
letVars <- Map Name (Open (Term, Dom Type)) -> [Name]
forall k a. Map k a -> [k]
Map.keys (Map Name (Open (Term, Dom Type)) -> [Name])
-> m (Map Name (Open (Term, Dom Type))) -> m [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCEnv -> Map Name (Open (Term, Dom Type)))
-> m (Map Name (Open (Term, Dom Type)))
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Map Name (Open (Term, Dom Type))
envLetBindings
  let vars :: [Name]
vars = [Name]
ctxVars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
letVars

  -- pick concrete names for in-scope names now so we don't
  -- accidentally shadow them
  [(Name, LocalVar)] -> ((Name, LocalVar) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ScopeInfo
scope ScopeInfo
-> Lens' [(Name, LocalVar)] ScopeInfo -> [(Name, LocalVar)]
forall o i. o -> Lens' i o -> i
^. Lens' [(Name, LocalVar)] ScopeInfo
scopeLocals) (((Name, LocalVar) -> m ()) -> m ())
-> ((Name, LocalVar) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Name
y , LocalVar
x) -> do
    Name -> Name -> m ()
forall (m :: * -> *).
MonadStConcreteNames m =>
Name -> Name -> m ()
pickConcreteName (LocalVar -> Name
localVar LocalVar
x) Name
y

  [(String, QName)]
builtinList <- [[(String, QName)]] -> [(String, QName)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(String, QName)]] -> [(String, QName)])
-> m [[(String, QName)]] -> m [(String, QName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m [(String, QName)])
-> [String] -> m [[(String, QName)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m [(String, QName)]
forall (m :: * -> *).
HasBuiltins m =>
String -> m [(String, QName)]
builtin [ String
builtinFromNat, String
builtinFromString, String
builtinFromNeg, String
builtinZero, String
builtinSuc ]
  Bool
foldPatSyns <- PragmaOptions -> Bool
optPrintPatternSynonyms (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  Env -> m Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> m Env) -> Env -> m Env
forall a b. (a -> b) -> a -> b
$
    Env :: Set Name
-> Set Name -> ScopeInfo -> Map String QName -> Bool -> Bool -> Env
Env { takenVarNames :: Set Name
takenVarNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
vars
        , takenDefNames :: Set Name
takenDefNames = Set Name
defs
        , currentScope :: ScopeInfo
currentScope = ScopeInfo
scope
        , builtins :: Map String QName
builtins     = [(String, QName)] -> Map String QName
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, QName)]
builtinList
        , preserveIIds :: Bool
preserveIIds = Bool
False
        , foldPatternSynonyms :: Bool
foldPatternSynonyms = Bool
foldPatSyns
        }
  where
    -- Jesper, 2018-12-10: It's fine to shadow generalizable names as
    -- they will never show up directly in printed terms.
    notGeneralizeName :: AbstractName -> Bool
notGeneralizeName AbsName{ anameKind :: AbstractName -> KindOfName
anameKind = KindOfName
k }  =
      Bool -> Bool
not (KindOfName
k KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
GeneralizeName Bool -> Bool -> Bool
|| KindOfName
k KindOfName -> KindOfName -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfName
DisallowedGeneralizeName)

    defs :: Set Name
defs = Map Name [AbstractName] -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Map Name [AbstractName] -> Set Name)
-> Map Name [AbstractName] -> Set Name
forall a b. (a -> b) -> a -> b
$
           ([AbstractName] -> Bool)
-> Map Name [AbstractName] -> Map Name [AbstractName]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((AbstractName -> Bool) -> [AbstractName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AbstractName -> Bool
notGeneralizeName) (Map Name [AbstractName] -> Map Name [AbstractName])
-> Map Name [AbstractName] -> Map Name [AbstractName]
forall a b. (a -> b) -> a -> b
$
           NameSpace -> Map Name [AbstractName]
nsNames (NameSpace -> Map Name [AbstractName])
-> NameSpace -> Map Name [AbstractName]
forall a b. (a -> b) -> a -> b
$ ScopeInfo -> NameSpace
everythingInScope ScopeInfo
scope

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

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

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

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

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

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

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

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

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

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

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

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

-- | We need:
--   - Read access to the AbsToCon environment
--   - Read access to the TC environment
--   - Read access to the TC state
--   - Read and write access to the stConcreteNames part of the TC state
--   - Read access to the options
--   - Permission to print debug messages
type MonadAbsToCon m =
  ( MonadTCEnv m
  , ReadTCState m
  , MonadStConcreteNames m
  , HasOptions m
  , HasBuiltins m
  , MonadDebug m
  )

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

-- TODO: Is there some way to automatically derive these boilerplate
-- instances?  GeneralizedNewtypeDeriving fails us here.
instance Functor AbsToCon where
  fmap :: (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) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> m a -> m 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
x

instance Applicative AbsToCon where
  pure :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  AbsToCon (a -> b)
f <*> :: 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 (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 >>= :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AbsToCon b -> m b
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon (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 :: String -> AbsToCon a
fail = String -> AbsToCon a
forall a. HasCallStack => String -> 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 forall r (m :: * -> *). MonadReader r m => m r
forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m Env
ask
  local :: (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 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 forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m TCEnv
forall (m :: * -> *). MonadTCEnv m => m TCEnv
askTC
  localTC :: (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 (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 forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m TCState
forall (m :: * -> *). ReadTCState m => m TCState
getTCState
  locallyTCState :: Lens' a TCState -> (a -> a) -> AbsToCon b -> AbsToCon b
locallyTCState Lens' a TCState
l a -> a
f AbsToCon b
m = (forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m b)
-> AbsToCon b
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m b)
 -> AbsToCon b)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m b)
-> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Lens' a TCState -> (a -> a) -> m b -> m b
forall (m :: * -> *) a b.
ReadTCState m =>
Lens' a TCState -> (a -> a) -> m b -> m b
locallyTCState Lens' a TCState
l a -> a
f (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ AbsToCon b
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m b
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon AbsToCon b
m

instance MonadStConcreteNames AbsToCon where
  runStConcreteNames :: 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 (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 (a, ConcreteNames)
forall a.
AbsToCon a
-> forall (m :: * -> *).
   (MonadReader Env m, MonadAbsToCon m) =>
   m a
unAbsToCon (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 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 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 forall (m :: * -> *).
(MonadReader Env m, MonadAbsToCon m) =>
m CommandLineOptions
forall (m :: * -> *). HasOptions m => m CommandLineOptions
commandLineOptions

instance MonadDebug AbsToCon where
  displayDebugMessage :: String -> VerboseLevel -> String -> AbsToCon ()
displayDebugMessage String
k VerboseLevel
n String
s = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m ())
-> AbsToCon ()
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m ())
 -> AbsToCon ())
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m ())
-> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ String -> VerboseLevel -> String -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
displayDebugMessage String
k VerboseLevel
n String
s
  formatDebugMessage :: String -> VerboseLevel -> TCM Doc -> AbsToCon String
formatDebugMessage String
k VerboseLevel
n TCM Doc
s = (forall (m :: * -> *).
 (MonadReader Env m, MonadAbsToCon m) =>
 m String)
-> AbsToCon String
forall a.
(forall (m :: * -> *). (MonadReader Env m, MonadAbsToCon m) => m a)
-> AbsToCon a
AbsToCon ((forall (m :: * -> *).
  (MonadReader Env m, MonadAbsToCon m) =>
  m String)
 -> AbsToCon String)
-> (forall (m :: * -> *).
    (MonadReader Env m, MonadAbsToCon m) =>
    m String)
-> AbsToCon String
forall a b. (a -> b) -> a -> b
$ String -> VerboseLevel -> TCM Doc -> m String
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> TCM Doc -> m String
formatDebugMessage String
k VerboseLevel
n TCM Doc
s
  verboseBracket :: String -> VerboseLevel -> String -> AbsToCon a -> AbsToCon a
verboseBracket String
k VerboseLevel
n String
s 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
$ String -> VerboseLevel -> String -> m a -> m a
forall (m :: * -> *) a.
MonadDebug m =>
String -> VerboseLevel -> String -> m a -> m a
verboseBracket String
k VerboseLevel
n String
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
m

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

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

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

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

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

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

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

lookupQName :: AllowAmbiguousNames -> A.QName -> AbsToCon C.QName
lookupQName :: AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
ambCon QName
x | Just String
s <- QName -> Maybe String
getGeneralizedFieldName QName
x =
  QName -> AbsToCon QName
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 -> [NamePart] -> Name
C.Name Range
forall a. Range' a
noRange NameInScope
C.InScope ([NamePart] -> Name) -> [NamePart] -> Name
forall a b. (a -> b) -> a -> b
$ String -> [NamePart]
C.stringNameParts String
s)
lookupQName AllowAmbiguousNames
ambCon QName
x = do
  [QName]
ys <- AllowAmbiguousNames -> QName -> ScopeInfo -> [QName]
inverseScopeLookupName' AllowAmbiguousNames
ambCon QName
x (ScopeInfo -> [QName]) -> AbsToCon ScopeInfo -> AbsToCon [QName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> ScopeInfo) -> AbsToCon ScopeInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ScopeInfo
currentScope
  String -> VerboseLevel -> String -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"scope.inverse" VerboseLevel
100 (String -> AbsToCon ()) -> String -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$
    String
"inverse looking up abstract name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Pretty a => a -> String
prettyShow QName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" yields " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [QName] -> String
forall a. Pretty a => a -> String
prettyShow [QName]
ys
  [QName] -> AbsToCon QName
loop [QName]
ys

  where
    -- Found concrete name: check that it is not shadowed by a local
    loop :: [QName] -> AbsToCon QName
loop (qy :: QName
qy@Qual{}      : [QName]
_ ) = QName -> AbsToCon QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
qy -- local names cannot be qualified
    loop (qy :: QName
qy@(C.QName Name
y) : [QName]
ys) = Name -> AbsToCon (Maybe Name)
lookupNameInScope Name
y AbsToCon (Maybe Name)
-> (Maybe Name -> AbsToCon QName) -> AbsToCon QName
forall (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 (m :: * -> *) a. Monad m => a -> m a
return QName
qy
    -- Found no concrete name: make up a new one
    loop [] = case QName -> QName
qnameToConcrete QName
x of
      qy :: QName
qy@Qual{}    -> QName -> AbsToCon QName
forall (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 (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
$ Range -> NameInScope -> [NamePart] -> Name
C.Name Range
forall a. Range' a
noRange NameInScope
InScope [String -> NamePart
Id String
"-1"]
  -- Andreas, 2016-10-10 it can happen that we have an empty module name
  -- for instance when we query the current module inside the
  -- frontmatter or module telescope of the top level module.
  -- In this case, we print it as an invalid module name.
  -- (Should only affect debug printing.)
lookupModule ModuleName
x =
    do  ScopeInfo
scope <- (Env -> ScopeInfo) -> AbsToCon ScopeInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ScopeInfo
currentScope
        case ModuleName -> ScopeInfo -> [QName]
inverseScopeLookupModule ModuleName
x ScopeInfo
scope of
            (QName
y : [QName]
_) -> QName -> AbsToCon QName
forall (m :: * -> *) a. Monad m => a -> m a
return QName
y
            []      -> QName -> AbsToCon QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> AbsToCon QName) -> QName -> AbsToCon QName
forall a b. (a -> b) -> a -> b
$ ModuleName -> QName
mnameToConcrete ModuleName
x
                -- this is what happens for names that are not in scope (private names)

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

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

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

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

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

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

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


-- | Choose a new unshadowed name for the given abstract name
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  -- If the name is currently in scope, we do not rename it
  Just Name
x' | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x' -> do
    String -> VerboseLevel -> String -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"toConcrete.bindName" VerboseLevel
80 (String -> AbsToCon ()) -> String -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$
      String
"name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
C.nameToRawName (Name -> Name
nameConcrete Name
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already in scope, so not renaming"
    Name -> AbsToCon Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> AbsToCon Name) -> Name -> AbsToCon Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x
  -- Otherwise we pick a name that does not shadow other names
  Maybe Name
_ -> do
    Set String
taken   <- AbsToCon (Set String)
takenNames
    Set String
toAvoid <- Name -> AbsToCon (Set String)
forall (m :: * -> *).
(ReadTCState m, MonadStConcreteNames m) =>
Name -> m (Set String)
shadowingNames Name
x
    let shouldAvoid :: Name -> Bool
shouldAvoid = (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (Set String
taken Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set String
toAvoid)) (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
C.nameToRawName
        y :: Name
y = (Name -> Bool) -> Name -> Name
firstNonTakenName Name -> Bool
shouldAvoid (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x
    String -> VerboseLevel -> String -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"toConcrete.bindName" VerboseLevel
80 (String -> AbsToCon ()) -> String -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
      [ Doc
"picking concrete name for:" Doc -> Doc -> Doc
<+> String -> Doc
text (Name -> String
C.nameToRawName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameConcrete Name
x)
      , Doc
"names already taken:      " Doc -> Doc -> Doc
<+> [String] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
taken)
      , Doc
"names to avoid:           " Doc -> Doc -> Doc
<+> [String] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_ (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
toAvoid)
      , Doc
"concrete name chosen:     " Doc -> Doc -> Doc
<+> String -> Doc
text (Name -> String
C.nameToRawName Name
y)
      ]
    Name -> AbsToCon Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
y

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


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

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

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

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

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

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

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

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

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

-- | If a name is defined with a fixity that differs from the default, we have
--   to generate a fixity declaration for that name.
withInfixDecl :: DefInfo -> C.Name -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]
withInfixDecl :: DefInfo -> Name -> AbsToCon [Declaration] -> AbsToCon [Declaration]
withInfixDecl DefInfo
i Name
x AbsToCon [Declaration]
m = do
  [Declaration]
ds <- AbsToCon [Declaration]
m
  [Declaration] -> AbsToCon [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> AbsToCon [Declaration])
-> [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ [Declaration]
fixDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
synDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds
 where fixDecl :: [Declaration]
fixDecl = [Fixity -> [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) [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 (Fixity' -> Notation
theNotation (DefInfo -> Fixity'
forall t. DefInfo' t -> Fixity'
defFixity DefInfo
i))]

{- UNUSED
withInfixDecls :: [(DefInfo, C.Name)] -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]
withInfixDecls = foldr (.) id . map (uncurry withInfixDecl)
-}

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

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

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

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

class ToConcrete a c | a -> c where
    toConcrete :: a -> AbsToCon c
    bindToConcrete :: a -> (c -> AbsToCon b) -> AbsToCon b

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

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

-- | Translate something in a context of the given precedence.
bindToConcreteCtx :: ToConcrete a c => Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcreteCtx :: Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcreteCtx Precedence
p a
x c -> 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 -> (c -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a
x c -> AbsToCon b
ret

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

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

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

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

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

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

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

instance ToConcrete a c => ToConcrete [a] [c] where
    toConcrete :: [a] -> AbsToCon [c]
toConcrete     = (a -> AbsToCon c) -> [a] -> AbsToCon [c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> AbsToCon c
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete
    -- Andreas, 2017-04-11, Issue #2543
    -- The naive `thread'ing does not work as we have to undo
    -- changes to the Precedence.
    -- bindToConcrete = thread bindToConcrete
    bindToConcrete :: [a] -> ([c] -> AbsToCon b) -> AbsToCon b
bindToConcrete []     [c] -> AbsToCon b
ret = [c] -> AbsToCon b
ret []
    bindToConcrete (a
a:[a]
as) [c] -> AbsToCon b
ret = do
      PrecedenceStack
p <- AbsToCon PrecedenceStack
currentPrecedence  -- save precedence
      a -> (c -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a
a ((c -> AbsToCon b) -> AbsToCon b)
-> (c -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ c
c ->
        PrecedenceStack -> AbsToCon b -> AbsToCon b
forall a. PrecedenceStack -> AbsToCon a -> AbsToCon a
withPrecedence' PrecedenceStack
p (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ -- reset precedence
          [a] -> ([c] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete [a]
as (([c] -> AbsToCon b) -> AbsToCon b)
-> ([c] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ [c]
cs ->
            [c] -> AbsToCon b
ret (c
c c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
cs)

instance (ToConcrete a1 c1, ToConcrete a2 c2) => ToConcrete (Either a1 a2) (Either c1 c2) where
    toConcrete :: Either a1 a2 -> AbsToCon (Either c1 c2)
toConcrete = (a1 -> AbsToCon c1)
-> (a2 -> AbsToCon c2) -> Either a1 a2 -> AbsToCon (Either c1 c2)
forall (f :: * -> *) a c b d.
Functor f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
traverseEither a1 -> AbsToCon c1
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete a2 -> AbsToCon c2
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete
    bindToConcrete :: Either a1 a2 -> (Either c1 c2 -> AbsToCon b) -> AbsToCon b
bindToConcrete (Left a1
x) Either c1 c2 -> AbsToCon b
ret =
        a1 -> (c1 -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a1
x ((c1 -> AbsToCon b) -> AbsToCon b)
-> (c1 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \c1
x ->
        Either c1 c2 -> AbsToCon b
ret (c1 -> Either c1 c2
forall a b. a -> Either a b
Left c1
x)
    bindToConcrete (Right a2
y) Either c1 c2 -> AbsToCon b
ret =
        a2 -> (c2 -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a2
y ((c2 -> AbsToCon b) -> AbsToCon b)
-> (c2 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \c2
y ->
        Either c1 c2 -> AbsToCon b
ret (c2 -> Either c1 c2
forall a b. b -> Either a b
Right c2
y)

instance (ToConcrete a1 c1, ToConcrete a2 c2) => ToConcrete (a1,a2) (c1,c2) where
    toConcrete :: (a1, a2) -> AbsToCon (c1, c2)
toConcrete (a1
x,a2
y) = (c1 -> c2 -> (c1, c2))
-> AbsToCon c1 -> AbsToCon c2 -> AbsToCon (c1, c2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (a1 -> AbsToCon c1
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete a1
x) (a2 -> AbsToCon c2
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete a2
y)
    bindToConcrete :: (a1, a2) -> ((c1, c2) -> AbsToCon b) -> AbsToCon b
bindToConcrete (a1
x,a2
y) (c1, c2) -> AbsToCon b
ret =
        a1 -> (c1 -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a1
x ((c1 -> AbsToCon b) -> AbsToCon b)
-> (c1 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \c1
x ->
        a2 -> (c2 -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a2
y ((c2 -> AbsToCon b) -> AbsToCon b)
-> (c2 -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \c2
y ->
        (c1, c2) -> AbsToCon b
ret (c1
x,c2
y)

instance (ToConcrete a1 c1, ToConcrete a2 c2, ToConcrete a3 c3) =>
         ToConcrete (a1,a2,a3) (c1,c2,c3) where
    toConcrete :: (a1, a2, a3) -> AbsToCon (c1, c2, c3)
toConcrete (a1
x,a2
y,a3
z) = (c1, (c2, c3)) -> (c1, c2, c3)
forall a b c. (a, (b, c)) -> (a, b, c)
reorder ((c1, (c2, c3)) -> (c1, c2, c3))
-> AbsToCon (c1, (c2, c3)) -> AbsToCon (c1, c2, c3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a1, (a2, a3)) -> AbsToCon (c1, (c2, c3))
forall a c. ToConcrete a c => a -> AbsToCon c
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 :: (a1, a2, a3) -> ((c1, c2, c3) -> AbsToCon b) -> AbsToCon b
bindToConcrete (a1
x,a2
y,a3
z) (c1, c2, c3) -> AbsToCon b
ret = (a1, (a2, a3)) -> ((c1, (c2, c3)) -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete (a1
x,(a2
y,a3
z)) (((c1, (c2, c3)) -> AbsToCon b) -> AbsToCon b)
-> ((c1, (c2, c3)) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ (c1, c2, c3) -> AbsToCon b
ret ((c1, c2, c3) -> AbsToCon b)
-> ((c1, (c2, c3)) -> (c1, c2, c3)) -> (c1, (c2, c3)) -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c1, (c2, c3)) -> (c1, c2, c3)
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 c => ToConcrete (Arg a) (Arg c) where
    toConcrete :: Arg a -> AbsToCon (Arg c)
toConcrete (Arg ArgInfo
i a
a) = ArgInfo -> c -> Arg c
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (c -> Arg c) -> AbsToCon c -> AbsToCon (Arg c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgInfo -> a -> AbsToCon c
forall h a c.
(LensHiding h, ToConcrete a c) =>
h -> a -> AbsToCon c
toConcreteHiding ArgInfo
i a
a

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

instance ToConcrete a c => ToConcrete (WithHiding a) (WithHiding c) where
  toConcrete :: WithHiding a -> AbsToCon (WithHiding c)
toConcrete     (WithHiding Hiding
h a
a) = Hiding -> c -> WithHiding c
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h (c -> WithHiding c) -> AbsToCon c -> AbsToCon (WithHiding c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hiding -> a -> AbsToCon c
forall h a c.
(LensHiding h, ToConcrete a c) =>
h -> a -> AbsToCon c
toConcreteHiding Hiding
h a
a
  bindToConcrete :: WithHiding a -> (WithHiding c -> AbsToCon b) -> AbsToCon b
bindToConcrete (WithHiding Hiding
h a
a) WithHiding c -> AbsToCon b
ret = Hiding -> a -> (c -> AbsToCon b) -> AbsToCon b
forall h a c b.
(LensHiding h, ToConcrete a c) =>
h -> a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcreteHiding Hiding
h a
a ((c -> AbsToCon b) -> AbsToCon b)
-> (c -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ c
a ->
    WithHiding c -> AbsToCon b
ret (WithHiding c -> AbsToCon b) -> WithHiding c -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Hiding -> c -> WithHiding c
forall a. Hiding -> a -> WithHiding a
WithHiding Hiding
h c
a

instance ToConcrete a c => ToConcrete (Named name a) (Named name c) where
    toConcrete :: Named name a -> AbsToCon (Named name c)
toConcrete (Named Maybe name
n a
x) = Maybe name -> c -> Named name c
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n (c -> Named name c) -> AbsToCon c -> AbsToCon (Named name c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> AbsToCon c
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete a
x
    bindToConcrete :: Named name a -> (Named name c -> AbsToCon b) -> AbsToCon b
bindToConcrete (Named Maybe name
n a
x) Named name c -> AbsToCon b
ret = a -> (c -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a
x ((c -> AbsToCon b) -> AbsToCon b)
-> (c -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Named name c -> AbsToCon b
ret (Named name c -> AbsToCon b)
-> (c -> Named name c) -> c -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe name -> c -> Named name c
forall name a. Maybe name -> a -> Named name a
Named Maybe name
n

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

instance ToConcrete A.Name C.Name where
  toConcrete :: Name -> AbsToCon Name
toConcrete       = Name -> AbsToCon Name
toConcreteName
  bindToConcrete :: Name -> (Name -> AbsToCon b) -> AbsToCon b
bindToConcrete Name
x = Name -> (Name -> AbsToCon b) -> AbsToCon b
forall b. Name -> (Name -> AbsToCon b) -> AbsToCon b
bindName Name
x

instance ToConcrete BindName C.BoundName where
  toConcrete :: BindName -> AbsToCon BoundName
toConcrete       = (Name -> BoundName) -> AbsToCon Name -> AbsToCon BoundName
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 :: BindName -> (BoundName -> AbsToCon b) -> AbsToCon b
bindToConcrete BindName
x = Name -> (Name -> AbsToCon b) -> AbsToCon b
forall b. Name -> (Name -> AbsToCon b) -> AbsToCon b
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 C.QName where
  toConcrete :: QName -> AbsToCon QName
toConcrete = AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousConProjs

instance ToConcrete A.ModuleName C.QName where
  toConcrete :: ModuleName -> AbsToCon QName
toConcrete = ModuleName -> AbsToCon QName
lookupModule

instance ToConcrete AbstractName C.QName where
  toConcrete :: AbstractName -> AbsToCon QName
toConcrete = QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (QName -> AbsToCon QName)
-> (AbstractName -> QName) -> AbstractName -> AbsToCon QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractName -> QName
anameName

-- | Assumes name is not 'UnknownName'.
instance ToConcrete ResolvedName C.QName where
  toConcrete :: ResolvedName -> AbsToCon QName
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 Name
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Name
x
    DefinedName Access
_ AbstractName
x      -> AbstractName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete AbstractName
x
    FieldName NonEmpty AbstractName
xs         -> AbstractName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty AbstractName
xs)
    ConstructorName NonEmpty AbstractName
xs   -> AbstractName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty AbstractName
xs)
    PatternSynResName NonEmpty AbstractName
xs -> AbstractName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (NonEmpty AbstractName -> AbstractName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty AbstractName
xs)
    ResolvedName
UnknownName          -> AbsToCon QName
forall a. HasCallStack => a
__IMPOSSIBLE__

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

instance ToConcrete A.Expr C.Expr where
    toConcrete :: Expr -> AbsToCon Expr
toConcrete (Var Name
x)             = QName -> Expr
Ident (QName -> Expr) -> (Name -> QName) -> Name -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
C.QName (Name -> Expr) -> AbsToCon Name -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AbsToCon Name
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Name
x
    toConcrete (Def QName
x)             = QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete QName
x
    toConcrete (Proj ProjOrigin
ProjPrefix AmbiguousQName
p) = QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
    toConcrete (Proj ProjOrigin
_          AmbiguousQName
p) = Range -> Expr -> Expr
C.Dot Range
forall a. Range' a
noRange (Expr -> Expr) -> (QName -> Expr) -> QName -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)
    toConcrete (A.Macro QName
x)         = QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete QName
x
    toConcrete e :: Expr
e@(Con AmbiguousQName
c)           = Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr
Ident (QName -> Expr) -> AbsToCon QName -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
c)
        -- for names we have to use the name from the info, since the abstract
        -- name has been resolved to a fully qualified name (except for
        -- variables)
    toConcrete e :: Expr
e@(A.Lit (LitQName Range
r QName
x)) = Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverPatternSyn Expr
e (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
      QName
x <- AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
      (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
appBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$
        Range -> Expr -> NamedArg Expr -> Expr
C.App Range
r (Range -> Expr
C.Quote Range
r) (Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg (Expr -> NamedArg Expr) -> Expr -> NamedArg Expr
forall a b. (a -> b) -> a -> b
$ QName -> Expr
C.Ident QName
x)
    toConcrete e :: Expr
e@(A.Lit 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 (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Literal -> Expr
C.Lit Literal
l

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

    toConcrete (A.Underscore MetaInfo
i)     = Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$
      Range -> Maybe String -> Expr
C.Underscore (MetaInfo -> Range
forall t. HasRange t => t -> Range
getRange MetaInfo
i) (Maybe String -> Expr) -> Maybe String -> Expr
forall a b. (a -> b) -> a -> b
$
        NamedMeta -> String
forall a. Pretty a => a -> String
prettyShow (NamedMeta -> String) -> (MetaId -> NamedMeta) -> MetaId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MetaId -> NamedMeta
NamedMeta (MetaInfo -> String
metaNameSuggestion MetaInfo
i) (MetaId -> NamedMeta) -> (MetaId -> MetaId) -> MetaId -> NamedMeta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerboseLevel -> MetaId
MetaId (VerboseLevel -> MetaId)
-> (MetaId -> VerboseLevel) -> MetaId -> MetaId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaId -> VerboseLevel
metaId (MetaId -> String) -> Maybe MetaId -> Maybe String
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 t. HasRange t => t -> Range
getRange ExprInfo
i) (Expr -> Expr) -> AbsToCon Expr -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e

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

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

    toConcrete (A.AbsurdLam ExprInfo
i Hiding
h) =
      (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Expr -> AbsToCon Expr
forall (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 t. HasRange t => t -> Range
getRange ExprInfo
i) Hiding
h
    toConcrete e :: Expr
e@(A.Lam ExprInfo
i LamBinding
_ Expr
_)      =
        Expr -> AbsToCon Expr -> AbsToCon Expr
tryToRecoverOpApp Expr
e   -- recover sections
        (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ case Expr -> ([LamBinding], Expr)
lamView Expr
e of
            ([], Expr
e) -> Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e
            ([LamBinding]
bs, 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
$
                [LamBinding] -> ([LamBinding] -> AbsToCon Expr) -> AbsToCon Expr
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete ((LamBinding -> LamBinding) -> [LamBinding] -> [LamBinding]
forall a b. (a -> b) -> [a] -> [b]
map LamBinding -> LamBinding
makeDomainFree [LamBinding]
bs) (([LamBinding] -> AbsToCon Expr) -> AbsToCon Expr)
-> ([LamBinding] -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ \ [LamBinding]
bs -> do
                  Expr
e  <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcreteTop Expr
e
                  Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> [LamBinding] -> Expr -> Expr
C.Lam (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) [LamBinding]
bs Expr
e
        where
          -- #3238 GA: We drop the hidden lambda abstractions which have
          -- been inserted by the machine rather than the user. This means
          -- that the result of lamView may actually be an empty list of
          -- binders.
          lamView :: A.Expr -> ([A.LamBinding], A.Expr)
          lamView :: Expr -> ([LamBinding], Expr)
lamView (A.Lam ExprInfo
_ b :: LamBinding
b@(A.DomainFree TacticAttr
_ NamedArg Binder
x) Expr
e)
            | NamedArg Binder -> Bool
forall a. (LensHiding a, LensOrigin a) => a -> Bool
isInsertedHidden NamedArg Binder
x = Expr -> ([LamBinding], Expr)
lamView Expr
e
            | Bool
otherwise = case Expr -> ([LamBinding], Expr)
lamView Expr
e of
              (bs :: [LamBinding]
bs@(A.DomainFree{} : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
              ([LamBinding], Expr)
_                            -> ([LamBinding
b] , Expr
e)
          lamView (A.Lam ExprInfo
_ b :: LamBinding
b@(A.DomainFull A.TLet{}) Expr
e) = case Expr -> ([LamBinding], Expr)
lamView Expr
e of
            (bs :: [LamBinding]
bs@(A.DomainFull TypedBinding
_ : [LamBinding]
_), Expr
e) -> (LamBinding
bLamBinding -> [LamBinding] -> [LamBinding]
forall a. a -> [a] -> [a]
:[LamBinding]
bs, Expr
e)
            ([LamBinding], Expr)
_                            -> ([LamBinding
b], Expr
e)
          lamView (A.Lam ExprInfo
_ (A.DomainFull (A.TBind Range
r TacticAttr
t [NamedArg Binder]
xs Expr
ty)) Expr
e) =
            case (NamedArg Binder -> Bool) -> [NamedArg Binder] -> [NamedArg Binder]
forall a. (a -> Bool) -> [a] -> [a]
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) [NamedArg Binder]
xs of
              []  -> Expr -> ([LamBinding], Expr)
lamView Expr
e
              [NamedArg Binder]
xs' -> let b :: LamBinding
b = TypedBinding -> LamBinding
A.DomainFull (Range -> TacticAttr -> [NamedArg Binder] -> Expr -> TypedBinding
A.TBind Range
r TacticAttr
t [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 QName
qname [Clause]
cs) =
        (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
lamBrackets (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do
          [Declaration]
decls <- [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> AbsToCon [[Declaration]] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Clause] -> AbsToCon [[Declaration]]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [Clause]
cs
          let namedPat :: Arg (Named_ Pattern) -> Pattern
namedPat Arg (Named_ Pattern)
np = case Arg (Named_ Pattern) -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg (Named_ Pattern)
np of
                 Hiding
NotHidden  -> Arg (Named_ Pattern) -> Pattern
forall a. NamedArg a -> a
namedArg Arg (Named_ Pattern)
np
                 Hiding
Hidden     -> Range -> Named_ Pattern -> Pattern
C.HiddenP Range
forall a. Range' a
noRange (Arg (Named_ Pattern) -> Named_ Pattern
forall e. Arg e -> e
unArg Arg (Named_ Pattern)
np)
                 Instance{} -> Range -> Named_ Pattern -> Pattern
C.InstanceP Range
forall a. Range' a
noRange (Arg (Named_ Pattern) -> Named_ Pattern
forall e. Arg e -> e
unArg Arg (Named_ Pattern)
np)
              -- we know all lhs are of the form `.extlam p1 p2 ... pn`,
              -- with the name .extlam leftmost. It is our mission to remove it.
          let removeApp :: Pattern -> m Pattern
removeApp (C.RawAppP Range
r (Pattern
_:[Pattern]
es)) = Pattern -> m Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Range -> [Pattern] -> Pattern
C.RawAppP Range
r [Pattern]
es
              removeApp (C.AppP (C.IdentP QName
_) Arg (Named_ Pattern)
np) = Pattern -> m Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Arg (Named_ Pattern) -> Pattern
namedPat Arg (Named_ Pattern)
np
              removeApp (C.AppP Pattern
p Arg (Named_ Pattern)
np) = do
                Pattern
p <- Pattern -> m Pattern
removeApp Pattern
p
                Pattern -> m Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Arg (Named_ Pattern) -> Pattern
C.AppP Pattern
p Arg (Named_ Pattern)
np

              -- Andreas, 2018-06-18, issue #3136
              -- Empty pattern list also allowed in extended lambda,
              -- thus, we might face the unapplied .extendedlambda identifier.
              removeApp x :: Pattern
x@C.IdentP{} = Pattern -> m Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> m Pattern) -> Pattern -> m Pattern
forall a b. (a -> b) -> a -> b
$ Range -> [Pattern] -> Pattern
C.RawAppP (Pattern -> Range
forall t. HasRange t => t -> Range
getRange Pattern
x) []

              removeApp Pattern
p = do
                String -> VerboseLevel -> String -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"extendedlambda" VerboseLevel
50 (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"abstractToConcrete removeApp p = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p
                Pattern -> m Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern
p -- __IMPOSSIBLE__ -- Andreas, this is actually not impossible, my strictification exposed this sleeping bug
          let decl2clause :: Declaration -> m LamClause
decl2clause (C.FunClause LHS
lhs RHS
rhs WhereClause
wh Bool
ca) = do
                let p :: Pattern
p = LHS -> Pattern
lhsOriginalPattern LHS
lhs
                String -> VerboseLevel -> String -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"extendedlambda" VerboseLevel
50 (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"abstractToConcrete extended lambda pattern p = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p
                Pattern
p' <- Pattern -> m Pattern
forall (m :: * -> *). MonadDebug m => Pattern -> m Pattern
removeApp Pattern
p
                String -> VerboseLevel -> String -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"extendedlambda" VerboseLevel
50 (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"abstractToConcrete extended lambda pattern p' = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p'
                LamClause -> m LamClause
forall (m :: * -> *) a. Monad m => a -> m a
return (LamClause -> m LamClause) -> LamClause -> m LamClause
forall a b. (a -> b) -> a -> b
$ LHS -> RHS -> WhereClause -> Bool -> LamClause
LamClause LHS
lhs{ lhsOriginalPattern :: Pattern
lhsOriginalPattern = Pattern
p' } RHS
rhs WhereClause
wh Bool
ca
              decl2clause Declaration
_ = m LamClause
forall a. HasCallStack => a
__IMPOSSIBLE__
          Range -> [LamClause] -> Expr
C.ExtendedLam (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) ([LamClause] -> Expr) -> AbsToCon [LamClause] -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> AbsToCon LamClause)
-> [Declaration] -> AbsToCon [LamClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> AbsToCon LamClause
forall (m :: * -> *). MonadDebug m => Declaration -> m LamClause
decl2clause [Declaration]
decls
    toConcrete (A.Pi ExprInfo
_ [] Expr
e) = Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e
    toConcrete t :: Expr
t@(A.Pi ExprInfo
i [TypedBinding]
_ Expr
_)  = case Expr -> ([TypedBinding], Expr)
piTel Expr
t of
      ([TypedBinding]
tel, Expr
e) ->
        (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
$ [TypedBinding] -> (Telescope -> AbsToCon Expr) -> AbsToCon Expr
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete [TypedBinding]
tel ((Telescope -> AbsToCon Expr) -> AbsToCon Expr)
-> (Telescope -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ \ Telescope
tel' -> do
             Expr
e' <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcreteTop Expr
e
             Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
C.Pi Telescope
tel' Expr
e'
      where
        piTel :: Expr -> ([TypedBinding], Expr)
piTel (A.Pi ExprInfo
_ [TypedBinding]
tel Expr
e) = ([TypedBinding] -> [TypedBinding])
-> ([TypedBinding], Expr) -> ([TypedBinding], Expr)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([TypedBinding]
tel [TypedBinding] -> [TypedBinding] -> [TypedBinding]
forall a. [a] -> [a] -> [a]
++) (([TypedBinding], Expr) -> ([TypedBinding], Expr))
-> ([TypedBinding], Expr) -> ([TypedBinding], Expr)
forall a b. (a -> b) -> a -> b
$ Expr -> ([TypedBinding], Expr)
piTel 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 Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e

    toConcrete (A.Fun ExprInfo
i Arg Expr
a Expr
b) =
        (PrecedenceStack -> Bool) -> AbsToCon Expr -> AbsToCon Expr
bracket PrecedenceStack -> Bool
piBrackets
        (AbsToCon Expr -> AbsToCon Expr) -> AbsToCon Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ do Arg Expr
a' <- Precedence -> Arg Expr -> AbsToCon (Arg Expr)
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
ctx Arg Expr
a
             Expr
b' <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcreteTop Expr
b
             let dom :: Arg Expr
dom = Quantity -> Arg Expr -> Arg Expr
forall a. LensQuantity a => Quantity -> a -> a
setQuantity (Arg Expr -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity Arg Expr
a') (Arg Expr -> Arg Expr) -> Arg Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Arg Expr
forall a. a -> Arg a
defaultArg (Expr -> Arg Expr) -> Expr -> Arg Expr
forall a b. (a -> b) -> a -> b
$ Arg Expr -> Expr -> Expr
forall t. (LensRelevance t, HasRange t) => t -> Expr -> Expr
addRel Arg Expr
a' (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Arg Expr -> Expr
mkArg Arg Expr
a'
             Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Arg Expr -> Expr -> Expr
C.Fun (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) Arg Expr
dom Expr
b'
             -- Andreas, 2018-06-14, issue #2513
             -- TODO: print attributes
        where
            ctx :: Precedence
ctx = if Arg Expr -> Bool
forall a. LensRelevance a => a -> Bool
isRelevant Arg Expr
a then Precedence
FunctionSpaceDomainCtx else Precedence
DotPatternCtx
            addRel :: t -> Expr -> Expr
addRel t
a Expr
e = case t -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance t
a of
                           Relevance
Irrelevant -> Range -> Expr -> Expr
C.Dot (t -> Range
forall t. HasRange t => t -> Range
getRange t
a) Expr
e
                           Relevance
NonStrict  -> Range -> Expr -> Expr
C.DoubleDot (t -> Range
forall t. HasRange t => t -> Range
getRange t
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 t. HasRange t => t -> 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 t. HasRange t => t -> Range
getRange Expr
e) (Expr -> Named_ Expr
forall a name. a -> Named name a
unnamed Expr
e)
                                          Hiding
NotHidden  -> Expr
e

    toConcrete (A.Set ExprInfo
i Integer
0)  = Expr -> AbsToCon Expr
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.Set (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i)
    toConcrete (A.Set ExprInfo
i Integer
n)  = Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Integer -> Expr
C.SetN (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) Integer
n
    toConcrete (A.Prop ExprInfo
i Integer
0) = Expr -> AbsToCon Expr
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.Prop (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i)
    toConcrete (A.Prop ExprInfo
i Integer
n) = Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Integer -> Expr
C.PropN (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) Integer
n

    toConcrete (A.Let ExprInfo
i [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
$ [LetBinding] -> ([[Declaration]] -> AbsToCon Expr) -> AbsToCon Expr
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete [LetBinding]
ds (([[Declaration]] -> AbsToCon Expr) -> AbsToCon Expr)
-> ([[Declaration]] -> AbsToCon Expr) -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ \[[Declaration]]
ds' -> do
             Expr
e'  <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcreteTop Expr
e
             Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> [Declaration] -> Maybe Expr -> Expr
C.Let (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) ([[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
ds') (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e')

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

    toConcrete (A.ETel [TypedBinding]
tel) = Telescope -> Expr
C.ETel (Telescope -> Expr) -> AbsToCon Telescope -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypedBinding] -> AbsToCon Telescope
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [TypedBinding]
tel

    toConcrete (A.ScopedExpr ScopeInfo
_ Expr
e) = Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e
    toConcrete (A.Quote ExprInfo
i) = Expr -> AbsToCon Expr
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 t. HasRange t => t -> Range
getRange ExprInfo
i)
    toConcrete (A.QuoteTerm ExprInfo
i) = Expr -> AbsToCon Expr
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 t. HasRange t => t -> Range
getRange ExprInfo
i)
    toConcrete (A.Unquote ExprInfo
i) = Expr -> AbsToCon Expr
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 t. HasRange t => t -> Range
getRange ExprInfo
i)
    toConcrete (A.Tactic ExprInfo
i Expr
e [NamedArg Expr]
xs) = do
      Expr
e' <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e
      [NamedArg Expr]
xs' <- [NamedArg Expr] -> AbsToCon [NamedArg Expr]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [NamedArg Expr]
xs
      let r :: Range
r      = ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i
          rawtac :: Expr
rawtac = (Expr -> NamedArg Expr -> Expr) -> Expr -> [NamedArg Expr] -> Expr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Range -> Expr -> NamedArg Expr -> Expr
C.App Range
r) Expr
e' [NamedArg Expr]
xs'
      Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Expr -> Expr
C.Tactic (ExprInfo -> Range
forall t. HasRange t => t -> Range
getRange ExprInfo
i) Expr
rawtac

    -- Andreas, 2012-04-02: TODO!  print DontCare as irrAxiom
    -- Andreas, 2010-10-05 print irrelevant things as ordinary things
    toConcrete (A.DontCare Expr
e) = Range -> Expr -> Expr
C.Dot Range
r (Expr -> Expr) -> (Expr -> Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Expr -> Expr
C.Paren Range
r  (Expr -> Expr) -> AbsToCon Expr -> AbsToCon Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e
       where r :: Range
r = Expr -> Range
forall t. HasRange t => t -> 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 QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
n)

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

-- Christian Sattler, 2017-08-05, fixing #2669
-- Both methods of ToConcrete (FieldAssignment' a) (FieldAssignment' c) need
-- to be implemented, each in terms of the corresponding one of ToConcrete a c.
-- This mirrors the instance ToConcrete (Arg a) (Arg c).
-- The default implementations of ToConcrete are not valid semantically.
instance ToConcrete a c => ToConcrete (FieldAssignment' a) (FieldAssignment' c) where
    toConcrete :: FieldAssignment' a -> AbsToCon (FieldAssignment' c)
toConcrete = (a -> AbsToCon c)
-> FieldAssignment' a -> AbsToCon (FieldAssignment' c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> AbsToCon c
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete

    bindToConcrete :: FieldAssignment' a
-> (FieldAssignment' c -> AbsToCon b) -> AbsToCon b
bindToConcrete (FieldAssignment Name
name a
a) FieldAssignment' c -> AbsToCon b
ret =
      a -> (c -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a
a ((c -> AbsToCon b) -> AbsToCon b)
-> (c -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ FieldAssignment' c -> AbsToCon b
ret (FieldAssignment' c -> AbsToCon b)
-> (c -> FieldAssignment' c) -> c -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> c -> FieldAssignment' c
forall a. Name -> a -> FieldAssignment' a
FieldAssignment Name
name


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

-- If there is no label we set it to the bound name, to make renaming the bound
-- name safe.
forceNameIfHidden :: NamedArg A.Binder -> NamedArg A.Binder
forceNameIfHidden :: NamedArg Binder -> NamedArg Binder
forceNameIfHidden NamedArg Binder
x
  | Maybe (WithOrigin (Ranged String)) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (WithOrigin (Ranged String)) -> Bool)
-> Maybe (WithOrigin (Ranged String)) -> Bool
forall a b. (a -> b) -> a -> b
$ NamedArg Binder -> Maybe (WithOrigin (Ranged String))
forall name a. LensNamed name a => a -> Maybe name
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 (WithOrigin (Ranged String))
-> NamedArg Binder -> NamedArg Binder
forall name a. LensNamed name a => Maybe name -> a -> a
setNameOf (WithOrigin (Ranged String) -> Maybe (WithOrigin (Ranged String))
forall a. a -> Maybe a
Just WithOrigin (Ranged String)
name) NamedArg Binder
x
  where
    name :: WithOrigin (Ranged String)
name = Origin -> Ranged String -> WithOrigin (Ranged String)
forall a. Origin -> a -> WithOrigin a
WithOrigin Origin
Inserted
         (Ranged String -> WithOrigin (Ranged String))
-> Ranged String -> WithOrigin (Ranged String)
forall a b. (a -> b) -> a -> b
$ Range -> String -> Ranged String
forall a. Range -> a -> Ranged a
Ranged (NamedArg Binder -> Range
forall t. HasRange t => t -> Range
getRange NamedArg Binder
x)
         (String -> Ranged String) -> String -> Ranged String
forall a b. (a -> b) -> a -> b
$ Name -> String
C.nameToRawName (Name -> String) -> Name -> String
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 b => ToConcrete (A.Binder' a) (C.Binder' b) where
  bindToConcrete :: Binder' a -> (Binder' b -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.Binder Maybe Pattern
p a
a) Binder' b -> AbsToCon b
ret =
    a -> (b -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete a
a ((b -> AbsToCon b) -> AbsToCon b)
-> (b -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ b
a ->
    Maybe Pattern -> (Maybe Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete Maybe Pattern
p ((Maybe Pattern -> AbsToCon b) -> AbsToCon b)
-> (Maybe Pattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ Maybe Pattern
p ->
    Binder' b -> AbsToCon b
ret (Binder' b -> AbsToCon b) -> Binder' b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Maybe Pattern -> b -> Binder' b
forall a. Maybe Pattern -> a -> Binder' a
C.Binder Maybe Pattern
p b
a

instance ToConcrete A.LamBinding C.LamBinding where
    bindToConcrete :: LamBinding -> (LamBinding -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.DomainFree TacticAttr
t NamedArg Binder
x) LamBinding -> AbsToCon b
ret = do
      Maybe Expr
t <- (Expr -> AbsToCon Expr) -> TacticAttr -> AbsToCon (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete TacticAttr
t
      let setTac :: BoundName -> BoundName
setTac BoundName
x = BoundName
x { bnameTactic :: Maybe Expr
bnameTactic = Maybe Expr
t }
      NamedArg Binder
-> (NamedArg (Binder' BoundName) -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete (NamedArg Binder -> NamedArg Binder
forceNameIfHidden NamedArg Binder
x) ((NamedArg (Binder' BoundName) -> AbsToCon b) -> AbsToCon b)
-> (NamedArg (Binder' BoundName) -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$
        LamBinding -> AbsToCon b
ret (LamBinding -> AbsToCon b)
-> (NamedArg (Binder' BoundName) -> LamBinding)
-> NamedArg (Binder' BoundName)
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Binder' BoundName) -> LamBinding
forall a. NamedArg (Binder' BoundName) -> LamBinding' a
C.DomainFree (NamedArg (Binder' BoundName) -> LamBinding)
-> (NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName))
-> NamedArg (Binder' BoundName)
-> LamBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binder' BoundName -> Binder' BoundName)
-> NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> BoundName) -> Binder' BoundName -> Binder' BoundName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoundName -> BoundName
setTac)
    bindToConcrete (A.DomainFull TypedBinding
b) LamBinding -> AbsToCon b
ret = TypedBinding -> (TypedBinding -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete TypedBinding
b ((TypedBinding -> AbsToCon b) -> AbsToCon b)
-> (TypedBinding -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ LamBinding -> AbsToCon b
ret (LamBinding -> AbsToCon b)
-> (TypedBinding -> LamBinding) -> TypedBinding -> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedBinding -> LamBinding
forall a. a -> LamBinding' a
C.DomainFull

instance ToConcrete A.TypedBinding C.TypedBinding where
    bindToConcrete :: TypedBinding -> (TypedBinding -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.TBind Range
r TacticAttr
t [NamedArg Binder]
xs Expr
e) TypedBinding -> AbsToCon b
ret = do
        Maybe Expr
t <- (Expr -> AbsToCon Expr) -> TacticAttr -> AbsToCon (Maybe Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete TacticAttr
t
        [NamedArg Binder]
-> ([NamedArg (Binder' BoundName)] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete ((NamedArg Binder -> NamedArg Binder)
-> [NamedArg Binder] -> [NamedArg Binder]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Binder -> NamedArg Binder
forceNameIfHidden [NamedArg Binder]
xs) (([NamedArg (Binder' BoundName)] -> AbsToCon b) -> AbsToCon b)
-> ([NamedArg (Binder' BoundName)] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ [NamedArg (Binder' BoundName)]
xs -> do
          Expr
e <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcreteTop Expr
e
          let setTac :: BoundName -> BoundName
setTac BoundName
x = BoundName
x { bnameTactic :: Maybe Expr
bnameTactic = Maybe Expr
t }
          TypedBinding -> AbsToCon b
ret (TypedBinding -> AbsToCon b) -> TypedBinding -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Range -> [NamedArg (Binder' BoundName)] -> Expr -> TypedBinding
forall e.
Range -> [NamedArg (Binder' BoundName)] -> e -> TypedBinding' e
C.TBind Range
r ((NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName))
-> [NamedArg (Binder' BoundName)] -> [NamedArg (Binder' BoundName)]
forall a b. (a -> b) -> [a] -> [b]
map ((Binder' BoundName -> Binder' BoundName)
-> NamedArg (Binder' BoundName) -> NamedArg (Binder' BoundName)
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg ((BoundName -> BoundName) -> Binder' BoundName -> Binder' BoundName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BoundName -> BoundName
setTac)) [NamedArg (Binder' BoundName)]
xs) Expr
e
    bindToConcrete (A.TLet Range
r [LetBinding]
lbs) TypedBinding -> AbsToCon b
ret =
        [LetBinding] -> ([[Declaration]] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete [LetBinding]
lbs (([[Declaration]] -> AbsToCon b) -> AbsToCon b)
-> ([[Declaration]] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ [[Declaration]]
ds -> do
        TypedBinding -> AbsToCon b
ret (TypedBinding -> AbsToCon b) -> TypedBinding -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Range -> [Declaration] -> TypedBinding
forall e. Range -> [Declaration] -> TypedBinding' e
C.TLet Range
r ([Declaration] -> TypedBinding) -> [Declaration] -> TypedBinding
forall a b. (a -> b) -> a -> b
$ [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
ds

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

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

mergeSigAndDef :: [C.Declaration] -> [C.Declaration]
mergeSigAndDef :: [Declaration] -> [Declaration]
mergeSigAndDef (C.RecordSig Range
_ Name
x [LamBinding]
bs Expr
e : C.RecordDef Range
r Name
y Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
c [LamBinding]
_ [Declaration]
fs : [Declaration]
ds)
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> Expr
-> [Declaration]
-> Declaration
C.Record Range
r Name
y Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
c [LamBinding]
bs Expr
e [Declaration]
fs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (C.DataSig Range
_ Name
x [LamBinding]
bs Expr
e : C.DataDef Range
r Name
y [LamBinding]
_ [Declaration]
cs : [Declaration]
ds)
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y = Range
-> Name -> [LamBinding] -> Expr -> [Declaration] -> Declaration
C.Data Range
r Name
y [LamBinding]
bs Expr
e [Declaration]
cs Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef (Declaration
d : [Declaration]
ds) = Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration] -> [Declaration]
mergeSigAndDef [Declaration]
ds
mergeSigAndDef [] = []

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


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

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

instance ToConcrete A.RHS (C.RHS, [C.RewriteEqn], [WithHiding C.Expr], [C.Declaration]) where
    toConcrete :: RHS
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
toConcrete (A.RHS Expr
e (Just Expr
c)) = (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> RHS
forall e. e -> RHS' e
C.RHS Expr
c, [], [], [])
    toConcrete (A.RHS Expr
e Maybe Expr
Nothing) = do
      Expr
e <- Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e
      (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> RHS
forall e. e -> RHS' e
C.RHS Expr
e, [], [], [])
    toConcrete RHS
A.AbsurdRHS = (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
forall e. RHS' e
C.AbsurdRHS, [], [], [])
    toConcrete (A.WithRHS QName
_ [WithHiding Expr]
es [Clause]
cs) = do
      [WithHiding Expr]
es <- [WithHiding Expr] -> AbsToCon [WithHiding Expr]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [WithHiding Expr]
es
      [Declaration]
cs <- AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a. AbsToCon a -> AbsToCon a
noTakenNames (AbsToCon [Declaration] -> AbsToCon [Declaration])
-> AbsToCon [Declaration] -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> AbsToCon [[Declaration]] -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Clause] -> AbsToCon [[Declaration]]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [Clause]
cs
      (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
forall e. RHS' e
C.AbsurdRHS, [], [WithHiding Expr]
es, [Declaration]
cs)
    toConcrete (A.RewriteRHS [RewriteEqn]
xeqs [ProblemEq]
_spats RHS
rhs WhereDeclarations
wh) = do
      [Declaration]
wh <- [Declaration] -> AbsToCon [Declaration]
declsToConcrete (WhereDeclarations -> [Declaration]
A.whereDecls WhereDeclarations
wh)
      (RHS
rhs, [RewriteEqn]
eqs', [WithHiding Expr]
es, [Declaration]
whs) <- RHS
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete RHS
rhs
      Bool -> AbsToCon () -> AbsToCon ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RewriteEqn] -> Bool
forall a. Null a => a -> Bool
null [RewriteEqn]
eqs') AbsToCon ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      [RewriteEqn]
eqs <- [RewriteEqn] -> AbsToCon [RewriteEqn]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [RewriteEqn]
xeqs
      (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
-> AbsToCon (RHS, [RewriteEqn], [WithHiding Expr], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (RHS
rhs, [RewriteEqn]
eqs, [WithHiding Expr]
es, [Declaration]
wh [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
whs)

instance (ToConcrete p q, ToConcrete a b) =>
         ToConcrete (RewriteEqn' qn p a) (RewriteEqn' () q b) where
  toConcrete :: RewriteEqn' qn p a -> AbsToCon (RewriteEqn' () q b)
toConcrete = \case
    Rewrite [(qn, a)]
es    -> [((), b)] -> RewriteEqn' () q b
forall qn p e. [(qn, e)] -> RewriteEqn' qn p e
Rewrite ([((), b)] -> RewriteEqn' () q b)
-> AbsToCon [((), b)] -> AbsToCon (RewriteEqn' () q b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((qn, a) -> AbsToCon ((), b)) -> [(qn, a)] -> AbsToCon [((), b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((), a) -> AbsToCon ((), b)
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (((), a) -> AbsToCon ((), b))
-> ((qn, a) -> ((), a)) -> (qn, a) -> AbsToCon ((), b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (qn
_, a
e) -> ((),a
e))) [(qn, a)]
es
    Invert qn
qn [(p, a)]
pes -> () -> [(q, b)] -> RewriteEqn' () q b
forall qn p e. qn -> [(p, e)] -> RewriteEqn' qn p e
Invert () ([(q, b)] -> RewriteEqn' () q b)
-> AbsToCon [(q, b)] -> AbsToCon (RewriteEqn' () q b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((p, a) -> AbsToCon (q, b)) -> [(p, a)] -> AbsToCon [(q, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (p, a) -> AbsToCon (q, b)
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [(p, a)]
pes

instance ToConcrete (Maybe A.QName) (Maybe C.Name) where
  toConcrete :: Maybe QName -> AbsToCon (Maybe Name)
toConcrete = (QName -> AbsToCon Name) -> Maybe QName -> AbsToCon (Maybe Name)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> AbsToCon Name
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (Name -> AbsToCon Name)
-> (QName -> Name) -> QName -> AbsToCon Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName)

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

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

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

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

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

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

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

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

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

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

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

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

  toConcrete (A.RecDef  DefInfo
i QName
x UniverseCheck
uc Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe QName
c 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]
-> ([LamBinding] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall a c b.
ToConcrete a c =>
a -> (c -> 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) (([LamBinding] -> AbsToCon [Declaration])
 -> AbsToCon [Declaration])
-> ([LamBinding] -> AbsToCon [Declaration])
-> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ \ [LamBinding]
tel' -> do
      (Name
x',[Declaration]
cs') <- (QName -> Name) -> (QName, [Declaration]) -> (Name, [Declaration])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first QName -> Name
unsafeQNameToName ((QName, [Declaration]) -> (Name, [Declaration]))
-> AbsToCon (QName, [Declaration])
-> AbsToCon (Name, [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QName, [Constr Declaration]) -> AbsToCon (QName, [Declaration])
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (QName
x, (Declaration -> Constr Declaration)
-> [Declaration] -> [Constr Declaration]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Constr Declaration
forall a. a -> Constr a
Constr [Declaration]
cs)
      [Declaration] -> AbsToCon [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> [Declaration]
-> Declaration
C.RecordDef (DefInfo -> Range
forall t. HasRange t => t -> Range
getRange DefInfo
i) Name
x' Maybe (Ranged Induction)
ind Maybe HasEta
eta Maybe (Name, IsInstance)
forall a. Maybe a
Nothing [LamBinding]
tel' [Declaration]
cs' ]

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

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

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

  toConcrete (A.Import ModuleInfo
i ModuleName
x ImportDirective
_) = do
    QName
x <- ModuleName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete ModuleName
x
    let open :: OpenShortHand
open = OpenShortHand -> Maybe OpenShortHand -> OpenShortHand
forall a. a -> Maybe a -> a
fromMaybe OpenShortHand
DontOpen (Maybe OpenShortHand -> OpenShortHand)
-> Maybe OpenShortHand -> OpenShortHand
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe OpenShortHand
minfoOpenShort ModuleInfo
i
        dir :: ImportDirective
dir  = ImportDirective -> Maybe ImportDirective -> ImportDirective
forall a. a -> Maybe a -> a
fromMaybe ImportDirective
forall n m. ImportDirective' n m
defaultImportDir (Maybe ImportDirective -> ImportDirective)
-> Maybe ImportDirective -> ImportDirective
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe ImportDirective
minfoDirective ModuleInfo
i
    [Declaration] -> AbsToCon [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> Declaration
C.Import (ModuleInfo -> Range
forall t. HasRange t => t -> Range
getRange ModuleInfo
i) QName
x Maybe AsName
forall a. Maybe a
Nothing OpenShortHand
open ImportDirective
dir]

  toConcrete (A.Pragma Range
i Pragma
p)     = do
    Pragma
p <- RangeAndPragma -> AbsToCon Pragma
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (RangeAndPragma -> AbsToCon Pragma)
-> RangeAndPragma -> AbsToCon Pragma
forall a b. (a -> b) -> a -> b
$ Range -> Pragma -> RangeAndPragma
RangeAndPragma (Range -> Range
forall t. HasRange t => t -> Range
getRange Range
i) Pragma
p
    [Declaration] -> AbsToCon [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Declaration
C.Pragma Pragma
p]

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

  toConcrete (A.PatternSynDef QName
x [Arg Name]
xs Pattern' Void
p) = do
    C.QName Name
x <- QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete QName
x
    [Arg Name]
-> ([Arg Name] -> AbsToCon [Declaration]) -> AbsToCon [Declaration]
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete [Arg Name]
xs (([Arg Name] -> AbsToCon [Declaration]) -> AbsToCon [Declaration])
-> ([Arg Name] -> AbsToCon [Declaration]) -> AbsToCon [Declaration]
forall a b. (a -> b) -> a -> b
$ \[Arg Name]
xs -> (Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[]) (Declaration -> [Declaration])
-> (Pattern -> Declaration) -> Pattern -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Name -> [Arg Name] -> Pattern -> Declaration
C.PatternSyn (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x) Name
x [Arg Name]
xs (Pattern -> [Declaration])
-> AbsToCon Pattern -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsToCon Pattern -> AbsToCon Pattern
forall a. AbsToCon a -> AbsToCon a
dontFoldPatternSynonyms (Pattern -> AbsToCon Pattern
forall a c. ToConcrete a c => a -> AbsToCon c
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 (m :: * -> *) a. Monad m => a -> m a
return Name
x
        unqual QName
_           = m Name
forall a. HasCallStack => a
__IMPOSSIBLE__
    [Name]
xs <- (QName -> AbsToCon Name) -> [QName] -> AbsToCon [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete) [QName]
xs
    (Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[]) (Declaration -> [Declaration])
-> (Expr -> Declaration) -> Expr -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Name] -> Expr -> Declaration
C.UnquoteDecl ([DefInfo] -> Range
forall t. HasRange t => t -> Range
getRange [DefInfo]
i) [Name]
xs (Expr -> [Declaration]) -> AbsToCon Expr -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e

  toConcrete (A.UnquoteDef [DefInfo]
i [QName]
xs Expr
e) = do
    let unqual :: QName -> m Name
unqual (C.QName Name
x) = Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
x
        unqual QName
_           = m Name
forall a. HasCallStack => a
__IMPOSSIBLE__
    [Name]
xs <- (QName -> AbsToCon Name) -> [QName] -> AbsToCon [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete) [QName]
xs
    (Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[]) (Declaration -> [Declaration])
-> (Expr -> Declaration) -> Expr -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Name] -> Expr -> Declaration
C.UnquoteDef ([DefInfo] -> Range
forall t. HasRange t => t -> Range
getRange [DefInfo]
i) [Name]
xs (Expr -> [Declaration]) -> AbsToCon Expr -> AbsToCon [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
e


data RangeAndPragma = RangeAndPragma Range A.Pragma

instance ToConcrete RangeAndPragma C.Pragma where
  toConcrete :: RangeAndPragma -> AbsToCon Pragma
toConcrete (RangeAndPragma Range
r Pragma
p) = case Pragma
p of
    A.OptionsPragma [String]
xs  -> Pragma -> AbsToCon Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> AbsToCon Pragma) -> Pragma -> AbsToCon Pragma
forall a b. (a -> b) -> a -> b
$ Range -> [String] -> Pragma
C.OptionsPragma Range
r [String]
xs
    A.BuiltinPragma Ranged String
b ResolvedName
x       -> Range -> Ranged String -> QName -> Pragma
C.BuiltinPragma Range
r Ranged String
b (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvedName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete ResolvedName
x
    A.BuiltinNoDefPragma Ranged String
b QName
x  -> Range -> Ranged String -> QName -> Pragma
C.BuiltinPragma Range
r Ranged String
b (QName -> Pragma) -> AbsToCon QName -> AbsToCon Pragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
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 [QName]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [QName]
x
    A.CompilePragma Ranged String
b QName
x String
s -> do
      QName
x <- QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete QName
x
      Pragma -> AbsToCon Pragma
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma -> AbsToCon Pragma) -> Pragma -> AbsToCon Pragma
forall a b. (a -> b) -> a -> b
$ Range -> Ranged String -> QName -> String -> Pragma
C.CompilePragma Range
r Ranged String
b QName
x String
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 QName
forall a c. ToConcrete a c => a -> AbsToCon c
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 QName
forall a c. ToConcrete a c => a -> AbsToCon c
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 QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete QName
x
    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 QName
forall a c. ToConcrete a c => a -> AbsToCon c
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 Pattern
forall a c. ToConcrete a c => a -> AbsToCon c
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> AbsToCon Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Expr
rhs

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

instance ToConcrete A.SpineLHS C.LHS where
  bindToConcrete :: SpineLHS -> (LHS -> AbsToCon b) -> AbsToCon b
bindToConcrete SpineLHS
lhs = LHS -> (LHS -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> 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 C.LHS where
    bindToConcrete :: LHS -> (LHS -> AbsToCon b) -> AbsToCon b
bindToConcrete (A.LHS LHSInfo
i LHSCore
lhscore) LHS -> AbsToCon b
ret = do
      Precedence -> LHSCore -> (Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcreteCtx Precedence
TopCtx LHSCore
lhscore ((Pattern -> AbsToCon b) -> AbsToCon b)
-> (Pattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ Pattern
lhs ->
          LHS -> AbsToCon b
ret (LHS -> AbsToCon b) -> LHS -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern
-> [RewriteEqn] -> [WithHiding Expr] -> ExpandedEllipsis -> LHS
C.LHS (ExpandedEllipsis -> Pattern -> Pattern
reintroduceEllipsis (LHSInfo -> ExpandedEllipsis
lhsEllipsis LHSInfo
i) Pattern
lhs) [] [] ExpandedEllipsis
NoEllipsis

instance ToConcrete A.LHSCore C.Pattern where
  bindToConcrete :: LHSCore -> (Pattern -> AbsToCon b) -> AbsToCon b
bindToConcrete = Pattern -> (Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> 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 :: [arg] -> PrecedenceStack -> Bool
appBracketsArgs []    PrecedenceStack
_   = Bool
False
appBracketsArgs (arg
_:[arg]
_) PrecedenceStack
ctx = PrecedenceStack -> Bool
appBrackets PrecedenceStack
ctx

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

instance ToConcrete FreshenName A.Name where
  bindToConcrete :: FreshenName -> (Name -> AbsToCon b) -> AbsToCon b
bindToConcrete (FreshenName BindName{ unBind :: BindName -> Name
unBind = Name
x }) Name -> AbsToCon b
ret = Name -> (Name -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete Name
x ((Name -> AbsToCon b) -> AbsToCon b)
-> (Name -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ Name
y -> Name -> AbsToCon b
ret Name
x { nameConcrete :: Name
nameConcrete = Name
y }

-- Pass 1: (Issue #2729)
-- Takes care of binding the originally user-written pattern variables, but doesn't actually
-- translate anything to Concrete.
instance ToConcrete (UserPattern A.Pattern) A.Pattern where
  bindToConcrete :: UserPattern Pattern -> (Pattern -> AbsToCon b) -> AbsToCon b
bindToConcrete (UserPattern Pattern
p) Pattern -> AbsToCon b
ret = do
    String -> VerboseLevel -> String -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"toConcrete.pat" VerboseLevel
100 (String -> AbsToCon ()) -> String -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ String
"binding pattern (pass 1)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
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
$ Pattern -> AbsToCon b
ret (Pattern -> AbsToCon b) -> 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 b. Name -> (Name -> AbsToCon b) -> AbsToCon b
bindName Name
x ((Name -> AbsToCon b) -> AbsToCon b)
-> (Name -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \Name
y ->
                                Pattern -> AbsToCon b
ret (Pattern -> AbsToCon b) -> Pattern -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern) -> BindName -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> BindName
mkBindName (Name -> BindName) -> Name -> BindName
forall a b. (a -> b) -> a -> b
$ Name
x { nameConcrete :: Name
nameConcrete = Name
y }
      A.WildP{}              -> Pattern -> AbsToCon b
ret Pattern
p
      A.ProjP{}              -> Pattern -> AbsToCon b
ret Pattern
p
      A.AbsurdP{}            -> Pattern -> AbsToCon b
ret Pattern
p
      A.LitP{}               -> Pattern -> AbsToCon b
ret Pattern
p
      A.DotP{}               -> Pattern -> AbsToCon b
ret Pattern
p
      A.EqualP{}             -> Pattern -> AbsToCon b
ret Pattern
p
      -- Andreas, 2017-09-03, issue #2729:
      -- Do not go into patterns generated by case-split here!
      -- They are treated in a second pass.
      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args
        | ConPatInfo -> ConInfo
conPatOrigin ConPatInfo
i ConInfo -> ConInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ConInfo
ConOSplit -> Pattern -> AbsToCon b
ret Pattern
p
        | Bool
otherwise          -> [UserPattern (NamedArg Pattern)]
-> ([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> 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) (([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b)
-> ([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ 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)]
-> ([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> 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) (([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b)
-> ([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ 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)]
-> ([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> 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) (([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b)
-> ([NamedArg Pattern] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
f
      A.RecP PatInfo
i [FieldAssignment' Pattern]
args          -> [FieldAssignment' (UserPattern Pattern)]
-> ([FieldAssignment' Pattern] -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern [FieldAssignment' Pattern]
args) (([FieldAssignment' Pattern] -> AbsToCon b) -> AbsToCon b)
-> ([FieldAssignment' Pattern] -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon b
ret (Pattern -> AbsToCon b)
-> ([FieldAssignment' Pattern] -> Pattern)
-> [FieldAssignment' Pattern]
-> AbsToCon b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatInfo -> [FieldAssignment' Pattern] -> Pattern
forall e. PatInfo -> [FieldAssignment' (Pattern' e)] -> Pattern' e
A.RecP PatInfo
i
      A.AsP PatInfo
i BindName
x Pattern
p            -> Name -> AbsToCon b -> AbsToCon b
forall a. Name -> AbsToCon a -> AbsToCon a
bindName' (BindName -> Name
unBind BindName
x) (AbsToCon b -> AbsToCon b) -> AbsToCon b -> AbsToCon b
forall a b. (a -> b) -> a -> b
$
                                UserPattern Pattern -> (Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((Pattern -> AbsToCon b) -> AbsToCon b)
-> (Pattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ \ Pattern
p ->
                                Pattern -> AbsToCon b
ret (PatInfo -> BindName -> Pattern -> Pattern
forall e. PatInfo -> BindName -> Pattern' e -> Pattern' e
A.AsP PatInfo
i BindName
x Pattern
p)
      A.WithP PatInfo
i Pattern
p            -> UserPattern Pattern -> (Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete (Pattern -> UserPattern Pattern
forall a. a -> UserPattern a
UserPattern Pattern
p) ((Pattern -> AbsToCon b) -> AbsToCon b)
-> (Pattern -> AbsToCon b) -> AbsToCon b
forall a b. (a -> b) -> a -> b
$ 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

instance ToConcrete (UserPattern (NamedArg A.Pattern)) (NamedArg A.Pattern) where
  bindToConcrete :: UserPattern (NamedArg Pattern)
-> (NamedArg Pattern -> AbsToCon b) -> AbsToCon b
bindToConcrete (UserPattern NamedArg Pattern
np) NamedArg Pattern -> AbsToCon b
ret =
    case NamedArg Pattern -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
np of
      Origin
CaseSplit -> NamedArg Pattern -> AbsToCon b
ret NamedArg Pattern
np
      Origin
_         -> Arg (Named (WithOrigin (Ranged String)) (UserPattern Pattern))
-> (NamedArg Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete ((Named (WithOrigin (Ranged String)) Pattern
 -> Named (WithOrigin (Ranged String)) (UserPattern Pattern))
-> NamedArg Pattern
-> Arg (Named (WithOrigin (Ranged String)) (UserPattern Pattern))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pattern -> UserPattern Pattern)
-> Named (WithOrigin (Ranged String)) Pattern
-> Named (WithOrigin (Ranged String)) (UserPattern Pattern)
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) NamedArg Pattern -> AbsToCon b
ret

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

instance ToConcrete (SplitPattern (NamedArg A.Pattern)) (NamedArg A.Pattern) where
  bindToConcrete :: SplitPattern (NamedArg Pattern)
-> (NamedArg Pattern -> AbsToCon b) -> AbsToCon b
bindToConcrete (SplitPattern NamedArg Pattern
np) NamedArg Pattern -> AbsToCon b
ret =
    case NamedArg Pattern -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
np of
      Origin
CaseSplit -> Arg (Named (WithOrigin (Ranged String)) BindingPattern)
-> (NamedArg Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete ((Named (WithOrigin (Ranged String)) Pattern
 -> Named (WithOrigin (Ranged String)) BindingPattern)
-> NamedArg Pattern
-> Arg (Named (WithOrigin (Ranged String)) BindingPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pattern -> BindingPattern)
-> Named (WithOrigin (Ranged String)) Pattern
-> Named (WithOrigin (Ranged String)) BindingPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> BindingPattern
BindingPat  ) NamedArg Pattern
np) NamedArg Pattern -> AbsToCon b
ret
      Origin
_         -> Arg (Named (WithOrigin (Ranged String)) (SplitPattern Pattern))
-> (NamedArg Pattern -> AbsToCon b) -> AbsToCon b
forall a c b.
ToConcrete a c =>
a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcrete ((Named (WithOrigin (Ranged String)) Pattern
 -> Named (WithOrigin (Ranged String)) (SplitPattern Pattern))
-> NamedArg Pattern
-> Arg (Named (WithOrigin (Ranged String)) (SplitPattern Pattern))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pattern -> SplitPattern Pattern)
-> Named (WithOrigin (Ranged String)) Pattern
-> Named (WithOrigin (Ranged String)) (SplitPattern Pattern)
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) NamedArg Pattern -> AbsToCon b
ret


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

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

      A.WildP PatInfo
i ->
        Pattern -> AbsToCon Pattern
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 t. HasRange t => t -> Range
getRange PatInfo
i)

      A.ConP ConPatInfo
i AmbiguousQName
c [NamedArg Pattern]
args  -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon Pattern
tryOp (AmbiguousQName -> QName
headAmbQ AmbiguousQName
c) (ConPatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. ConPatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.ConP ConPatInfo
i AmbiguousQName
c) [NamedArg Pattern]
args

      A.ProjP PatInfo
i ProjOrigin
ProjPrefix AmbiguousQName
p -> QName -> Pattern
C.IdentP (QName -> Pattern) -> AbsToCon QName -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
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 QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (AmbiguousQName -> QName
headAmbQ AmbiguousQName
p)

      A.DefP PatInfo
i AmbiguousQName
x [NamedArg Pattern]
args -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon Pattern
tryOp (AmbiguousQName -> QName
headAmbQ AmbiguousQName
x) (PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.DefP PatInfo
i AmbiguousQName
x)  [NamedArg Pattern]
args

      A.AsP PatInfo
i BindName
x Pattern
p -> do
        (BoundName
x, Pattern
p) <- Precedence -> (BindName, Pattern) -> AbsToCon (BoundName, Pattern)
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
argumentCtx_ (BindName
x, Pattern
p)
        Pattern -> AbsToCon Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Range -> Name -> Pattern -> Pattern
C.AsP (PatInfo -> Range
forall t. HasRange t => t -> Range
getRange PatInfo
i) (BoundName -> Name
C.boundName BoundName
x) Pattern
p

      A.AbsurdP PatInfo
i ->
        Pattern -> AbsToCon Pattern
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 t. HasRange t => t -> Range
getRange PatInfo
i)

      A.LitP (LitQName Range
r QName
x) -> do
        QName
x <- AllowAmbiguousNames -> QName -> AbsToCon QName
lookupQName AllowAmbiguousNames
AmbiguousNothing QName
x
        (PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern
bracketP_ PrecedenceStack -> Bool
appBrackets (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> AbsToCon Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Arg (Named_ Pattern) -> Pattern
C.AppP (Range -> Pattern
C.QuoteP Range
r) (Pattern -> Arg (Named_ Pattern)
forall a. a -> NamedArg a
defaultNamedArg (QName -> Pattern
C.IdentP QName
x))
      A.LitP Literal
l ->
        Pattern -> AbsToCon Pattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> AbsToCon Pattern) -> Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ Literal -> Pattern
C.LitP Literal
l

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

      -- gallais, 2019-02-12, issue #3491
      -- Print p as .(p) if p is a variable but there is a projection of the
      -- same name in scope.
      A.DotP PatInfo
i e :: Expr
e@(A.Var Name
v) -> do
        let r :: Range
r = PatInfo -> Range
forall t. HasRange t => t -> Range
getRange PatInfo
i
        -- Erase @v@ to a concrete name and resolve it back to check whether
        -- we have a conflicting field name.
        Name
cn <- Name -> AbsToCon Name
toConcreteName Name
v
        KindsOfNames
-> Maybe (Set Name)
-> QName
-> AbsToCon (Either (NonEmpty QName) ResolvedName)
resolveName ([KindOfName] -> KindsOfNames
someKindsOfNames [KindOfName
FldName]) Maybe (Set Name)
forall a. Maybe a
Nothing (Name -> QName
C.QName Name
cn) AbsToCon (Either (NonEmpty QName) ResolvedName)
-> (Either (NonEmpty QName) ResolvedName -> AbsToCon Pattern)
-> AbsToCon Pattern
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
          -- If we do then we print .(v) rather than .v
          Right FieldName{} -> do
            String -> VerboseLevel -> String -> AbsToCon ()
forall (m :: * -> *).
MonadDebug m =>
String -> VerboseLevel -> String -> m ()
reportSLn String
"print.dotted" VerboseLevel
50 (String -> AbsToCon ()) -> String -> AbsToCon ()
forall a b. (a -> b) -> a -> b
$ String
"Wrapping ambiguous name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (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 Expr
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete (Name -> Expr
A.Var Name
v)
          Right ResolvedName
_ -> PatInfo -> Expr -> AbsToCon Pattern
printDotDefault PatInfo
i Expr
e
          Left NonEmpty QName
_ -> 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 t. HasRange t => t -> 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 [(Expr, Expr)]
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete [(Expr, Expr)]
es

      A.PatternSynP PatInfo
i AmbiguousQName
n [NamedArg Pattern]
args -> QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon Pattern
tryOp (AmbiguousQName -> QName
headAmbQ AmbiguousQName
n) (PatInfo -> AmbiguousQName -> [NamedArg Pattern] -> Pattern
forall e. PatInfo -> AmbiguousQName -> NAPs e -> Pattern' e
A.PatternSynP PatInfo
i AmbiguousQName
n) [NamedArg Pattern]
args

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

      A.WithP PatInfo
i Pattern
p -> Range -> Pattern -> Pattern
C.WithP (PatInfo -> Range
forall t. HasRange t => t -> 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 Pattern
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
WithArgCtx Pattern
p

    where

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

    tryOp :: A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> AbsToCon C.Pattern
    tryOp :: QName
-> ([NamedArg Pattern] -> Pattern)
-> [NamedArg Pattern]
-> AbsToCon Pattern
tryOp QName
x [NamedArg Pattern] -> Pattern
f [NamedArg Pattern]
args = do
      -- Andreas, 2016-02-04, Issue #1792
      -- To prevent failing of tryToRecoverOpAppP for overapplied operators,
      -- we take off the exceeding arguments first
      -- and apply them pointwise with C.AppP later.
      let ([NamedArg Pattern]
args1, [NamedArg Pattern]
args2) = VerboseLevel
-> [NamedArg Pattern] -> ([NamedArg Pattern], [NamedArg Pattern])
forall a. VerboseLevel -> [a] -> ([a], [a])
splitAt (QName -> VerboseLevel
forall a. NumHoles a => a -> VerboseLevel
numHoles QName
x) [NamedArg Pattern]
args
      let funCtx :: AbsToCon a -> AbsToCon a
funCtx = Bool -> (AbsToCon a -> AbsToCon a) -> AbsToCon a -> AbsToCon a
forall a. Bool -> (a -> a) -> a -> a
applyUnless ([NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null [NamedArg Pattern]
args2) (Precedence -> AbsToCon a -> AbsToCon a
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)
forall a. AbsToCon a -> AbsToCon a
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Pattern
c  -> [NamedArg Pattern] -> Pattern -> AbsToCon Pattern
forall arg.
ToConcrete arg (Arg (Named_ Pattern)) =>
[arg] -> Pattern -> AbsToCon Pattern
applyTo [NamedArg Pattern]
args2 Pattern
c
        Maybe Pattern
Nothing -> [NamedArg Pattern] -> Pattern -> AbsToCon Pattern
forall arg.
ToConcrete arg (Arg (Named_ Pattern)) =>
[arg] -> Pattern -> AbsToCon Pattern
applyTo [NamedArg Pattern]
args (Pattern -> AbsToCon Pattern)
-> (QName -> Pattern) -> QName -> AbsToCon Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Pattern
C.IdentP (QName -> AbsToCon Pattern) -> AbsToCon QName -> AbsToCon Pattern
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete QName
x
    -- Note: applyTo [] c = return c
    applyTo :: [arg] -> Pattern -> AbsToCon Pattern
applyTo [arg]
args Pattern
c = (PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern
bracketP_ ([arg] -> PrecedenceStack -> Bool
forall arg. [arg] -> PrecedenceStack -> Bool
appBracketsArgs [arg]
args) (AbsToCon Pattern -> AbsToCon Pattern)
-> AbsToCon Pattern -> AbsToCon Pattern
forall a b. (a -> b) -> a -> b
$ do
      (Pattern -> Arg (Named_ Pattern) -> Pattern)
-> Pattern -> [Arg (Named_ Pattern)] -> Pattern
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pattern -> Arg (Named_ Pattern) -> Pattern
C.AppP Pattern
c ([Arg (Named_ Pattern)] -> Pattern)
-> AbsToCon [Arg (Named_ Pattern)] -> AbsToCon Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> [arg] -> AbsToCon [Arg (Named_ Pattern)]
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
argumentCtx_ [arg]
args

instance ToConcrete (Maybe A.Pattern) (Maybe C.Pattern) where
  toConcrete :: Maybe Pattern -> AbsToCon (Maybe Pattern)
toConcrete = (Pattern -> AbsToCon Pattern)
-> Maybe Pattern -> AbsToCon (Maybe Pattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Pattern -> AbsToCon Pattern
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete

-- Helpers for recovering natural number literals

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

recoverNatural :: (A.QName -> String -> Bool) -> A.Expr -> Maybe Integer
recoverNatural :: (QName -> String -> Bool) -> Expr -> Maybe Integer
recoverNatural QName -> String -> Bool
is Expr
e = (QName -> Bool)
-> (QName -> Bool) -> Integer -> Expr -> Maybe Integer
explore (QName -> String -> Bool
`is` String
builtinZero) (QName -> String -> Bool
`is` String
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 (LitNat Range
_ Integer
l)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
l)
    explore QName -> Bool
_ QName -> Bool
_ Integer
_ Expr
_                             = Maybe Integer
forall a. Maybe a
Nothing

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

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

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

fromNoSection :: a -> MaybeSection a -> a
fromNoSection :: 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 t. HasRange t => t -> Range
getRange a
a

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

cOpApp :: Range -> C.QName -> A.Name -> [MaybeSection C.Expr] -> C.Expr
cOpApp :: Range -> QName -> Name -> [MaybeSection Expr] -> Expr
cOpApp Range
r QName
x Name
n [MaybeSection Expr]
es =
  Range
-> QName
-> Set Name
-> [NamedArg (MaybePlaceholder (OpApp Expr))]
-> Expr
C.OpApp Range
r QName
x (Name -> Set Name
forall a. a -> Set a
Set.singleton Name
n)
          (((MaybeSection Expr, PositionInName)
 -> NamedArg (MaybePlaceholder (OpApp Expr)))
-> [(MaybeSection Expr, PositionInName)]
-> [NamedArg (MaybePlaceholder (OpApp Expr))]
forall a b. (a -> b) -> [a] -> [b]
map (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)]
eps)
  where
    x0 :: Name
x0 = QName -> Name
C.unqualify QName
x
    positions :: [PositionInName]
positions | Name -> Bool
isPrefix  Name
x0 =                [ PositionInName
Middle | MaybeSection Expr
_ <- VerboseLevel -> [MaybeSection Expr] -> [MaybeSection Expr]
forall a. VerboseLevel -> [a] -> [a]
drop VerboseLevel
1 [MaybeSection Expr]
es ] [PositionInName] -> [PositionInName] -> [PositionInName]
forall a. [a] -> [a] -> [a]
++ [PositionInName
End]
              | Name -> Bool
isPostfix Name
x0 = [PositionInName
Beginning] [PositionInName] -> [PositionInName] -> [PositionInName]
forall a. [a] -> [a] -> [a]
++ [ PositionInName
Middle | MaybeSection Expr
_ <- VerboseLevel -> [MaybeSection Expr] -> [MaybeSection Expr]
forall a. VerboseLevel -> [a] -> [a]
drop VerboseLevel
1 [MaybeSection Expr]
es ]
              | Name -> Bool
isInfix Name
x0   = [PositionInName
Beginning] [PositionInName] -> [PositionInName] -> [PositionInName]
forall a. [a] -> [a] -> [a]
++ [ PositionInName
Middle | MaybeSection Expr
_ <- VerboseLevel -> [MaybeSection Expr] -> [MaybeSection Expr]
forall a. VerboseLevel -> [a] -> [a]
drop VerboseLevel
2 [MaybeSection Expr]
es ] [PositionInName] -> [PositionInName] -> [PositionInName]
forall a. [a] -> [a] -> [a]
++ [PositionInName
End]
              | Bool
otherwise    =                [ PositionInName
Middle | MaybeSection Expr
_ <- [MaybeSection Expr]
es ]
    eps :: [(MaybeSection Expr, PositionInName)]
eps = [MaybeSection Expr]
-> [PositionInName] -> [(MaybeSection Expr, PositionInName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MaybeSection Expr]
es [PositionInName]
positions
    placeholder :: (MaybeSection e, PositionInName) -> MaybePlaceholder (OpApp e)
placeholder (MaybeSection e
YesSection , PositionInName
pos ) = PositionInName -> MaybePlaceholder (OpApp e)
forall e. PositionInName -> MaybePlaceholder e
Placeholder PositionInName
pos
    placeholder (NoSection e
e, PositionInName
_pos) = OpApp e -> MaybePlaceholder (OpApp e)
forall e. e -> MaybePlaceholder e
noPlaceholder (e -> OpApp e
forall e. e -> OpApp e
Ordinary e
e)

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

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

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

    view Expr
e = (, ((NamedArg (AppInfo, Expr)
 -> NamedArg (MaybeSection (AppInfo, Expr)))
-> [NamedArg (AppInfo, Expr)]
-> [NamedArg (MaybeSection (AppInfo, Expr))]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArg (AppInfo, Expr)
  -> NamedArg (MaybeSection (AppInfo, Expr)))
 -> [NamedArg (AppInfo, Expr)]
 -> [NamedArg (MaybeSection (AppInfo, Expr))])
-> (((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
    -> NamedArg (AppInfo, Expr)
    -> NamedArg (MaybeSection (AppInfo, Expr)))
-> ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> [NamedArg (AppInfo, Expr)]
-> [NamedArg (MaybeSection (AppInfo, Expr))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named (WithOrigin (Ranged String)) (AppInfo, Expr)
 -> Named
      (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Expr)))
-> NamedArg (AppInfo, Expr)
-> NamedArg (MaybeSection (AppInfo, Expr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named (WithOrigin (Ranged String)) (AppInfo, Expr)
  -> Named
       (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Expr)))
 -> NamedArg (AppInfo, Expr)
 -> NamedArg (MaybeSection (AppInfo, Expr)))
-> (((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
    -> Named (WithOrigin (Ranged String)) (AppInfo, Expr)
    -> Named
         (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Expr)))
-> ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> NamedArg (AppInfo, Expr)
-> NamedArg (MaybeSection (AppInfo, Expr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AppInfo, Expr) -> MaybeSection (AppInfo, Expr))
-> Named (WithOrigin (Ranged String)) (AppInfo, Expr)
-> Named
     (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Expr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (AppInfo, Expr) -> MaybeSection (AppInfo, Expr)
forall a. a -> MaybeSection a
NoSection [NamedArg (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 [NamedArg (AppInfo, Expr)]
args = Expr -> AppView' (AppInfo, Expr)
A.appView' Expr
e

tryToRecoverOpAppP :: A.Pattern -> AbsToCon (Maybe C.Pattern)
tryToRecoverOpAppP :: Pattern -> AbsToCon (Maybe Pattern)
tryToRecoverOpAppP Pattern
p = do
  Maybe Pattern
res <- ((PrecedenceStack -> Bool) -> AbsToCon Pattern -> AbsToCon Pattern)
-> (Pattern -> Bool)
-> (Range -> QName -> Name -> [MaybeSection Pattern] -> Pattern)
-> (Pattern
    -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))]))
-> Pattern
-> AbsToCon (Maybe Pattern)
forall a c.
(ToConcrete a c, HasRange c) =>
((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)
-> (a -> Bool)
-> (Range -> QName -> Name -> [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 -> [MaybeSection Pattern] -> Pattern
opApp Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
view Pattern
p
  String -> VerboseLevel -> [String] -> AbsToCon ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
String -> VerboseLevel -> a -> m ()
reportS String
"print.op" VerboseLevel
90
    [ String
"tryToRecoverOpApp"
    , String
"in:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p
    , String
"out: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Pattern -> String
forall a. Show a => a -> String
show Maybe Pattern
res
    ]
  Maybe Pattern -> AbsToCon (Maybe Pattern)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pattern
res
  where
    opApp :: Range -> QName -> Name -> [MaybeSection Pattern] -> Pattern
opApp Range
r QName
x Name
n [MaybeSection Pattern]
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]
map (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]
ps
      -- `view` does not generate any `Nothing`s

    appInfo :: AppInfo
appInfo = AppInfo
defaultAppInfo_

    view :: A.Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Pattern))])
    view :: Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
view Pattern
p = case Pattern
p of
      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 (WithOrigin (Ranged String)) Pattern
 -> Named
      (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern)))
-> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named (WithOrigin (Ranged String)) Pattern
  -> Named
       (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern)))
 -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> Named (WithOrigin (Ranged String)) Pattern
    -> Named
         (WithOrigin (Ranged String)) (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 (WithOrigin (Ranged String)) Pattern
-> Named
     (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern))
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 (WithOrigin (Ranged String)) Pattern
 -> Named
      (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern)))
-> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named (WithOrigin (Ranged String)) Pattern
  -> Named
       (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern)))
 -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> Named (WithOrigin (Ranged String)) Pattern
    -> Named
         (WithOrigin (Ranged String)) (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 (WithOrigin (Ranged String)) Pattern
-> Named
     (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern))
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 (WithOrigin (Ranged String)) Pattern
 -> Named
      (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern)))
-> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named (WithOrigin (Ranged String)) Pattern
  -> Named
       (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern)))
 -> NamedArg Pattern -> NamedArg (MaybeSection (AppInfo, Pattern)))
-> ((Pattern -> MaybeSection (AppInfo, Pattern))
    -> Named (WithOrigin (Ranged String)) Pattern
    -> Named
         (WithOrigin (Ranged String)) (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 (WithOrigin (Ranged String)) Pattern
-> Named
     (WithOrigin (Ranged String)) (MaybeSection (AppInfo, Pattern))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern)
forall a. a -> MaybeSection a
NoSection ((AppInfo, Pattern) -> MaybeSection (AppInfo, Pattern))
-> (Pattern -> (AppInfo, Pattern))
-> Pattern
-> MaybeSection (AppInfo, Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo
appInfo,)) [NamedArg Pattern]
ps)
      Pattern
_                   -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, Pattern))])
forall a. Maybe a
Nothing
      -- ProjP _ _ d   -> Just (HdDef (headAmbQ d), [])   -- ? Andreas, 2016-04-21

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

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

  doQNameHelper :: Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> AbsToCon (Maybe c)
  doQNameHelper :: Either Name QName
-> [MaybeSection (AppInfo, a)] -> AbsToCon (Maybe c)
doQNameHelper Either Name QName
n [MaybeSection (AppInfo, a)]
args = do
    QName
x <- (Name -> AbsToCon QName)
-> (QName -> AbsToCon QName) -> Either Name QName -> AbsToCon QName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Name -> QName
C.QName (Name -> QName)
-> (Name -> AbsToCon Name) -> Name -> AbsToCon QName
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Name -> AbsToCon Name
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete) QName -> AbsToCon QName
forall a c. ToConcrete a c => a -> AbsToCon c
toConcrete Either Name QName
n
    let n' :: Name
n' = (Name -> Name) -> (QName -> Name) -> Either Name QName -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Name -> Name
forall a. a -> a
id QName -> Name
A.qnameName Either Name QName
n
    -- #1346: The fixity of the abstract name is not necessarily correct, it depends on which
    -- concrete name we choose! Make sure to resolve ambiguities with n'.
    Fixity
fx <- QName -> [Name] -> AbsToCon ResolvedName
resolveName_ QName
x [Name
n'] AbsToCon ResolvedName
-> (ResolvedName -> Fixity) -> AbsToCon Fixity
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ case
            VarName Name
y BindingSource
_                -> Name
y Name -> Lens' Fixity Name -> Fixity
forall o i. o -> Lens' i o -> i
^. forall a. LensFixity a => Lens' Fixity a
Lens' Fixity Name
lensFixity
            DefinedName Access
_ AbstractName
q            -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            FieldName (AbstractName
q :| [AbstractName]
_)         -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            ConstructorName (AbstractName
q :| [AbstractName]
_)   -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            PatternSynResName (AbstractName
q :| [AbstractName]
_) -> AbstractName
q AbstractName -> Lens' Fixity AbstractName -> Fixity
forall o i. o -> Lens' i o -> i
^. forall a. LensFixity a => Lens' Fixity a
Lens' Fixity AbstractName
lensFixity
            ResolvedName
UnknownName                -> Fixity
noFixity
    Fixity
-> QName
-> Name
-> [MaybeSection (AppInfo, a)]
-> [NamePart]
-> AbsToCon (Maybe c)
doQName Fixity
fx QName
x Name
n' [MaybeSection (AppInfo, a)]
args (Name -> [NamePart]
C.nameParts (Name -> [NamePart]) -> Name -> [NamePart]
forall a b. (a -> b) -> a -> b
$ QName -> Name
C.unqualify QName
x)

  doQName :: Fixity -> C.QName -> A.Name -> [MaybeSection (AppInfo, a)] -> [NamePart] -> AbsToCon (Maybe c)

  -- fall-back (wrong number of arguments or no holes)
  doQName :: Fixity
-> QName
-> Name
-> [MaybeSection (AppInfo, a)]
-> [NamePart]
-> AbsToCon (Maybe c)
doQName Fixity
_ QName
x Name
_ [MaybeSection (AppInfo, a)]
es [NamePart]
xs
    | [MaybeSection (AppInfo, a)] -> Bool
forall a. Null a => a -> Bool
null [MaybeSection (AppInfo, a)]
es                 = AbsToCon (Maybe c)
forall a. AbsToCon (Maybe a)
mDefault
    | [MaybeSection (AppInfo, a)] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length [MaybeSection (AppInfo, a)]
es VerboseLevel -> VerboseLevel -> Bool
forall a. Eq a => a -> a -> Bool
/= QName -> VerboseLevel
forall a. NumHoles a => a -> VerboseLevel
numHoles QName
x = AbsToCon (Maybe c)
forall a. AbsToCon (Maybe a)
mDefault

  -- binary case
  doQName Fixity
fixity QName
x Name
n [MaybeSection (AppInfo, a)]
as [NamePart]
xs
    | NamePart
Hole <- [NamePart] -> NamePart
forall a. [a] -> a
head [NamePart]
xs
    , NamePart
Hole <- [NamePart] -> NamePart
forall a. [a] -> a
last [NamePart]
xs = do
        let a1 :: MaybeSection (AppInfo, a)
a1  = [MaybeSection (AppInfo, a)] -> MaybeSection (AppInfo, a)
forall a. [a] -> a
head [MaybeSection (AppInfo, a)]
as
            an :: MaybeSection (AppInfo, a)
an  = [MaybeSection (AppInfo, a)] -> MaybeSection (AppInfo, a)
forall a. [a] -> a
last [MaybeSection (AppInfo, a)]
as
            as' :: [MaybeSection (AppInfo, a)]
as' = case [MaybeSection (AppInfo, a)]
as of
                    as :: [MaybeSection (AppInfo, a)]
as@(MaybeSection (AppInfo, a)
_ : MaybeSection (AppInfo, a)
_ : [MaybeSection (AppInfo, a)]
_) -> [MaybeSection (AppInfo, a)] -> [MaybeSection (AppInfo, a)]
forall a. [a] -> [a]
init ([MaybeSection (AppInfo, a)] -> [MaybeSection (AppInfo, a)])
-> [MaybeSection (AppInfo, a)] -> [MaybeSection (AppInfo, a)]
forall a b. (a -> b) -> a -> b
$ [MaybeSection (AppInfo, a)] -> [MaybeSection (AppInfo, a)]
forall a. [a] -> [a]
tail [MaybeSection (AppInfo, a)]
as
                    [MaybeSection (AppInfo, a)]
_              -> [MaybeSection (AppInfo, a)]
forall a. HasCallStack => a
__IMPOSSIBLE__
        c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket (Bool -> Fixity -> PrecedenceStack -> Bool
opBrackets' (MaybeSection (AppInfo, a) -> Bool
skipParens MaybeSection (AppInfo, a)
an) Fixity
fixity) (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ do
            MaybeSection c
e1 <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx (Fixity -> Precedence
LeftOperandCtx Fixity
fixity) (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) MaybeSection (AppInfo, a)
a1
            [MaybeSection c]
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> AbsToCon [MaybeSection c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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)
traverse) (Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) [MaybeSection (AppInfo, a)]
as'
            MaybeSection c
en <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((AppInfo -> a -> AbsToCon c) -> (AppInfo, a) -> AbsToCon c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((AppInfo -> a -> AbsToCon c) -> (AppInfo, a) -> AbsToCon c)
-> (AppInfo -> a -> AbsToCon c) -> (AppInfo, a) -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx (Precedence -> a -> AbsToCon c)
-> (AppInfo -> Precedence) -> AppInfo -> a -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixity -> ParenPreference -> Precedence
RightOperandCtx Fixity
fixity (ParenPreference -> Precedence)
-> (AppInfo -> ParenPreference) -> AppInfo -> Precedence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppInfo -> ParenPreference
appParens) MaybeSection (AppInfo, a)
an
            c -> AbsToCon c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> [MaybeSection c] -> c
opApp ((MaybeSection c, MaybeSection c) -> Range
forall t. HasRange t => t -> Range
getRange (MaybeSection c
e1, MaybeSection c
en)) QName
x Name
n ([MaybeSection c
e1] [MaybeSection c] -> [MaybeSection c] -> [MaybeSection c]
forall a. [a] -> [a] -> [a]
++ [MaybeSection c]
es [MaybeSection c] -> [MaybeSection c] -> [MaybeSection c]
forall a. [a] -> [a] -> [a]
++ [MaybeSection c
en])

  -- prefix
  doQName Fixity
fixity QName
x Name
n [MaybeSection (AppInfo, a)]
as [NamePart]
xs
    | NamePart
Hole <- [NamePart] -> NamePart
forall a. [a] -> a
last [NamePart]
xs = do
        let an :: MaybeSection (AppInfo, a)
an  = [MaybeSection (AppInfo, a)] -> MaybeSection (AppInfo, a)
forall a. [a] -> a
last [MaybeSection (AppInfo, a)]
as
            as' :: [MaybeSection (AppInfo, a)]
as' = case [MaybeSection (AppInfo, a)]
as of
                    as :: [MaybeSection (AppInfo, a)]
as@(MaybeSection (AppInfo, a)
_ : [MaybeSection (AppInfo, a)]
_) -> [MaybeSection (AppInfo, a)] -> [MaybeSection (AppInfo, a)]
forall a. [a] -> [a]
init [MaybeSection (AppInfo, a)]
as
                    [MaybeSection (AppInfo, a)]
_          -> [MaybeSection (AppInfo, a)]
forall a. HasCallStack => a
__IMPOSSIBLE__
        c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket (Bool -> Fixity -> PrecedenceStack -> Bool
opBrackets' (MaybeSection (AppInfo, a) -> Bool
skipParens MaybeSection (AppInfo, a)
an) Fixity
fixity) (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ do
            [MaybeSection c]
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> AbsToCon [MaybeSection c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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)
traverse) (Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) [MaybeSection (AppInfo, a)]
as'
            MaybeSection c
en <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\ (AppInfo
i, a
e) -> Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx (Fixity -> ParenPreference -> Precedence
RightOperandCtx Fixity
fixity (ParenPreference -> Precedence) -> ParenPreference -> Precedence
forall a b. (a -> b) -> a -> b
$ AppInfo -> ParenPreference
appParens AppInfo
i) a
e) MaybeSection (AppInfo, a)
an
            c -> AbsToCon c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> [MaybeSection c] -> c
opApp ((Name, MaybeSection c) -> Range
forall t. HasRange t => t -> Range
getRange (Name
n, MaybeSection c
en)) QName
x Name
n ([MaybeSection c]
es [MaybeSection c] -> [MaybeSection c] -> [MaybeSection c]
forall a. [a] -> [a] -> [a]
++ [MaybeSection c
en])

  -- postfix
  doQName Fixity
fixity QName
x Name
n [MaybeSection (AppInfo, a)]
as [NamePart]
xs
    | NamePart
Hole <- [NamePart] -> NamePart
forall a. [a] -> a
head [NamePart]
xs = do
        let a1 :: MaybeSection (AppInfo, a)
a1  = [MaybeSection (AppInfo, a)] -> MaybeSection (AppInfo, a)
forall a. [a] -> a
head [MaybeSection (AppInfo, a)]
as
            as' :: [MaybeSection (AppInfo, a)]
as' = [MaybeSection (AppInfo, a)] -> [MaybeSection (AppInfo, a)]
forall a. [a] -> [a]
tail [MaybeSection (AppInfo, a)]
as
        MaybeSection c
e1 <- ((AppInfo, a) -> AbsToCon c)
-> MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx (Fixity -> Precedence
LeftOperandCtx Fixity
fixity) (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) MaybeSection (AppInfo, a)
a1
        [MaybeSection c]
es <- ((MaybeSection (AppInfo, a) -> AbsToCon (MaybeSection c))
-> [MaybeSection (AppInfo, a)] -> AbsToCon [MaybeSection c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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)
traverse) (Precedence -> a -> AbsToCon c
forall a c. ToConcrete a c => Precedence -> a -> AbsToCon c
toConcreteCtx Precedence
InsideOperandCtx (a -> AbsToCon c)
-> ((AppInfo, a) -> a) -> (AppInfo, a) -> AbsToCon c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppInfo, a) -> a
forall a b. (a, b) -> b
snd) [MaybeSection (AppInfo, a)]
as'
        c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> AbsToCon c -> AbsToCon (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          (PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c
bracket (Fixity -> PrecedenceStack -> Bool
opBrackets Fixity
fixity) (AbsToCon c -> AbsToCon c) -> AbsToCon c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$
            c -> AbsToCon c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> AbsToCon c) -> c -> AbsToCon c
forall a b. (a -> b) -> a -> b
$ Range -> QName -> Name -> [MaybeSection c] -> c
opApp ((MaybeSection c, Name) -> Range
forall t. HasRange t => t -> Range
getRange (MaybeSection c
e1, Name
n)) QName
x Name
n ([MaybeSection c
e1] [MaybeSection c] -> [MaybeSection c] -> [MaybeSection c]
forall a. [a] -> [a] -> [a]
++ [MaybeSection c]
es)

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

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

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

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

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

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

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

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

instance ToConcrete InteractionId C.Expr where
    toConcrete :: InteractionId -> AbsToCon Expr
toConcrete (InteractionId VerboseLevel
i) = Expr -> AbsToCon Expr
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 C.Expr where
    toConcrete :: NamedMeta -> AbsToCon Expr
toConcrete NamedMeta
i = do
      Expr -> AbsToCon Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> AbsToCon Expr) -> Expr -> AbsToCon Expr
forall a b. (a -> b) -> a -> b
$ Range -> Maybe String -> Expr
C.Underscore Range
forall a. Range' a
noRange (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ NamedMeta -> String
forall a. Pretty a => a -> String
prettyShow NamedMeta
i)