summaryrefslogtreecommitdiff
path: root/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/full/Agda/Syntax/Translation/AbstractToConcrete.hs')
-rw-r--r--src/full/Agda/Syntax/Translation/AbstractToConcrete.hs279
1 files changed, 129 insertions, 150 deletions
diff --git a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
index 31e6675..6653721 100644
--- a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
+++ b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
@@ -1,11 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
-- {-# OPTIONS -fwarn-unused-binds #-}
@@ -35,10 +34,11 @@ import Control.Applicative hiding (empty)
import Control.Monad.Reader
import Data.List as List hiding (null)
-import Data.Maybe
import qualified Data.Map as Map
-import qualified Data.Set as Set
+import Data.Maybe
+import Data.Monoid
import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Traversable (traverse)
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
@@ -58,9 +58,11 @@ import Agda.TypeChecking.Monad.Base (TCM, NamedMeta(..))
import Agda.TypeChecking.Monad.Options
import qualified Agda.Utils.AssocList as AssocList
+import Agda.Utils.Functor
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Tuple
+import Agda.Utils.Pretty (prettyShow)
#include "undefined.h"
import Agda.Utils.Impossible
@@ -77,14 +79,12 @@ defaultEnv = Env { takenNames = Set.empty
}
makeEnv :: ScopeInfo -> Env
-makeEnv scope = Env { takenNames = taken
+makeEnv scope = Env { takenNames = Set.union vars defs
, currentScope = scope
}
where
- ns = everythingInScope scope
- taken = Set.union vars defs
vars = Set.fromList $ map fst $ scopeLocals scope
- defs = Set.fromList [ x | (x, _) <- Map.toList $ nsNames ns ]
+ defs = Map.keysSet $ nsNames $ everythingInScope scope
currentPrecedence :: AbsToCon Precedence
currentPrecedence = asks $ scopePrecedence . currentScope
@@ -121,37 +121,6 @@ abstractToConcreteCtx ctx x = do
abstractToConcrete_ :: ToConcrete a c => a -> TCM c
abstractToConcrete_ = runAbsToCon . toConcrete
-{-
--- | We make the translation monadic for modularity purposes.
-type AbsToCon = Reader Env
-
-runAbsToCon :: AbsToCon a -> TCM a
-runAbsToCon m = do
- scope <- getScope
- return $ runReader m (makeEnv scope)
-
-abstractToConcreteEnv :: ToConcrete a c => Env -> a -> TCM c
-abstractToConcreteEnv flags a = return $ runReader (toConcrete a) flags
-
-{- Andreas, 2013-02-26 discontinue non-monadic version in favor of debug msg.
-abstractToConcrete :: ToConcrete a c => Env -> a -> c
-abstractToConcrete flags a = runReader (toConcrete a) flags
--}
-
-abstractToConcreteCtx :: ToConcrete a c => Precedence -> a -> TCM c
-abstractToConcreteCtx ctx x = do
- scope <- getScope
- let scope' = scope { scopePrecedence = ctx }
- return $ abstractToConcrete (makeEnv scope') x
- where
- scope = (currentScope defaultEnv) { scopePrecedence = ctx }
-
-abstractToConcrete_ :: ToConcrete a c => a -> TCM c
-abstractToConcrete_ x = do
- scope <- getScope
- return $ abstractToConcrete (makeEnv scope) x
--}
-
-- Dealing with names -----------------------------------------------------
-- | Names in abstract syntax are fully qualified, but the concrete syntax
@@ -287,6 +256,30 @@ toConcreteCtx p x = withPrecedence p $ toConcrete x
bindToConcreteCtx :: ToConcrete a c => Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b
bindToConcreteCtx p x ret = withPrecedence p $ bindToConcrete x ret
+-- | Translate something in the top context.
+toConcreteTop :: ToConcrete a c => a -> AbsToCon c
+toConcreteTop = toConcreteCtx TopCtx
+
+-- | Translate something in the top context.
+bindToConcreteTop :: ToConcrete a c => a -> (c -> AbsToCon b) -> AbsToCon b
+bindToConcreteTop = bindToConcreteCtx TopCtx
+
+-- | Translate something in a context indicated by 'Hiding' info.
+toConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> AbsToCon c
+toConcreteHiding h =
+ case getHiding h of
+ NotHidden -> toConcrete
+ Hidden -> toConcreteTop
+ Instance -> 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 =
+ case getHiding h of
+ NotHidden -> bindToConcrete
+ Hidden -> bindToConcreteTop
+ Instance -> bindToConcreteTop
+
-- General instances ------------------------------------------------------
instance ToConcrete a c => ToConcrete [a] [c] where
@@ -315,15 +308,19 @@ instance ToConcrete (Common.ArgInfo ac) C.ArgInfo where
return $ info { argInfoColors = [] } -- TODO: zapping ignoring colours
instance ToConcrete a c => ToConcrete (Common.Arg ac a) (C.Arg c) where
- toConcrete (Common.Arg info x) = liftM2 Common.Arg (toConcrete info) (f x)
- where f = case getHiding info of
- Hidden -> toConcreteCtx TopCtx
- Instance -> toConcreteCtx TopCtx
- NotHidden -> toConcrete
+ toConcrete (Common.Arg info x) = Common.Arg
+ <$> toConcrete info
+ <*> toConcreteHiding info x
+
+ bindToConcrete (Common.Arg info x) ret = do
+ info <- toConcrete info
+ bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $
+ ret . Common.Arg info
- bindToConcrete (Common.Arg info x) ret = do info <- toConcrete info
- bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $
- ret . Common.Arg info
+instance ToConcrete a c => ToConcrete (WithHiding a) (WithHiding c) where
+ toConcrete (WithHiding h a) = WithHiding h <$> toConcreteHiding h a
+ bindToConcrete (WithHiding h a) ret = bindToConcreteHiding h a $ \ a ->
+ ret $ WithHiding h a
instance ToConcrete a c => ToConcrete (Named name a) (Named name c) where
toConcrete (Named n x) = Named n <$> toConcrete x
@@ -371,7 +368,7 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.Underscore i) = return $
C.Underscore (getRange i) $
- show . NamedMeta (metaNameSuggestion i) . MetaId <$> metaNumber i
+ prettyShow . NamedMeta (metaNameSuggestion i) . MetaId <$> metaNumber i
toConcrete e@(A.App i e1 e2) =
tryToRecoverOpApp e
@@ -394,7 +391,7 @@ instance ToConcrete A.Expr C.Expr where
$ case lamView e of
(bs, e) ->
bindToConcrete (map makeDomainFree bs) $ \bs -> do
- e <- toConcreteCtx TopCtx e
+ e <- toConcreteTop e
return $ C.Lam (getRange i) (concat bs) e
where
lamView (A.Lam _ b@(A.DomainFree _ _) e) =
@@ -438,7 +435,7 @@ instance ToConcrete A.Expr C.Expr where
(tel, e) ->
bracket piBrackets
$ bindToConcrete tel $ \b' -> do
- e' <- toConcreteCtx TopCtx e
+ e' <- toConcreteTop e
return $ C.Pi (concat b') e'
where
piTel (A.Pi _ tel e) = (tel ++) -*- id $ piTel e
@@ -447,7 +444,7 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.Fun i a b) =
bracket piBrackets
$ do a' <- toConcreteCtx (if irr then DotPatternCtx else FunctionSpaceDomainCtx) a
- b' <- toConcreteCtx TopCtx b
+ b' <- toConcreteTop b
return $ C.Fun (getRange i) (addRel a' $ mkArg a') b'
where
irr = getRelevance a `elem` [Irrelevant, NonStrict]
@@ -468,20 +465,20 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.Let i ds e) =
bracket lamBrackets
$ bindToConcrete ds $ \ds' -> do
- e' <- toConcreteCtx TopCtx e
+ e' <- toConcreteTop e
return $ C.Let (getRange i) (concat ds') e'
toConcrete (A.Rec i fs) =
bracket appBrackets $ do
let (xs, es) = unzip fs
- es <- toConcreteCtx TopCtx es
+ es <- toConcreteTop es
return $ C.Rec (getRange i) $ zip xs es
toConcrete (A.RecUpdate i e fs) =
bracket appBrackets $ do
let (xs, es) = unzip fs
e <- toConcrete e
- es <- toConcreteCtx TopCtx es
+ es <- toConcreteTop es
return $ C.RecUpdate (getRange i) e $ zip xs es
toConcrete (A.ETel tel) = do
@@ -508,7 +505,7 @@ instance ToConcrete A.Expr C.Expr where
-- Andreas, 2010-10-05 print irrelevant things as ordinary things
toConcrete (A.DontCare e) = C.Dot r . C.Paren r <$> toConcrete e
where r = getRange e
--- toConcrete (A.DontCare e) = C.DontCare <$> toConcreteCtx TopCtx e
+-- toConcrete (A.DontCare e) = C.DontCare <$> toConcreteTop e
{-
-- Andreas, 2010-09-21 abuse C.Underscore to print irrelevant things
toConcrete (A.DontCare) = return $ C.Underscore noRange Nothing
@@ -516,9 +513,9 @@ instance ToConcrete A.Expr C.Expr where
toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete n
makeDomainFree :: A.LamBinding -> A.LamBinding
-makeDomainFree b@(A.DomainFull (A.TypedBindings r (Common.Arg info (A.TBind _ [x] t)))) =
+makeDomainFree b@(A.DomainFull (A.TypedBindings r (Common.Arg info (A.TBind _ [WithHiding h x] t)))) =
case unScope t of
- A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree info x
+ A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree (mapHiding (mappend h) info) x
_ -> b
makeDomainFree b = b
@@ -547,20 +544,20 @@ instance ToConcrete A.TypedBindings [C.TypedBindings] where
tbinds r e xs = [ C.TBind r xs e ]
tbind r e xs =
- case span (\x -> boundLabel x == boundName x) xs of
+ case span ((\ x -> boundLabel x == boundName x) . dget) xs of
(xs, x:ys) -> tbinds r e xs ++ [ C.TBind r [x] e ] ++ tbind r e ys
(xs, []) -> tbinds r e xs
- label x y = y { boundLabel = nameConcrete x }
+ label x = fmap $ \ y -> y { boundLabel = nameConcrete $ dget x }
instance ToConcrete A.TypedBinding C.TypedBinding where
bindToConcrete (A.TBind r xs e) ret =
- bindToConcrete xs $ \xs -> do
- e <- toConcreteCtx TopCtx e
- ret (C.TBind r (map mkBoundName_ xs) e)
+ bindToConcrete xs $ \ xs -> do
+ e <- toConcreteTop e
+ ret $ C.TBind r (map (fmap mkBoundName_) xs) e
bindToConcrete (A.TLet r lbs) ret =
- bindToConcrete lbs $ \ds -> do
- ret (C.TLet r (concat ds))
+ bindToConcrete lbs $ \ ds -> do
+ ret $ C.TLet r $ concat ds
instance ToConcrete LetBinding [C.Declaration] where
bindToConcrete (LetBind i info x t e) ret =
@@ -637,12 +634,12 @@ instance ToConcrete A.RHS (C.RHS, [C.Expr], [C.Expr], [C.Declaration]) where
es <- toConcrete es
cs <- concat <$> toConcrete cs
return (C.AbsurdRHS, [], es, cs)
- toConcrete (A.RewriteRHS _ eqs rhs wh) = do
+ toConcrete (A.RewriteRHS xeqs rhs wh) = do
wh <- declsToConcrete wh
(rhs, eqs', es, whs) <- toConcrete rhs
unless (null eqs')
__IMPOSSIBLE__
- eqs <- toConcrete eqs
+ eqs <- toConcrete $ map snd xeqs
return (rhs, eqs, es, wh ++ whs)
instance ToConcrete (Maybe A.QName) (Maybe C.Name) where
@@ -669,7 +666,7 @@ instance ToConcrete (Constr A.Constructor) C.Declaration where
withScope scope $ toConcrete (Constr d)
toConcrete (Constr (A.Axiom _ i info x t)) = do
x' <- unsafeQNameToName <$> toConcrete x
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
info <- toConcrete info
return $ C.TypeSig info x' t'
toConcrete (Constr d) = head <$> toConcrete d
@@ -680,7 +677,7 @@ instance ToConcrete a C.LHS => ToConcrete (A.Clause' a) [C.Declaration] where
case lhs of
C.LHS p wps _ _ -> do
bindToConcrete (AsWhereDecls wh) $ \wh' -> do
- (rhs', eqs, with, wcs) <- toConcreteCtx TopCtx rhs
+ (rhs', eqs, with, wcs) <- toConcreteTop rhs
return $ FunClause (C.LHS p wps eqs with) rhs' wh' : wcs
C.Ellipsis {} -> __IMPOSSIBLE__
-- TODO: Is the case above impossible? Previously there was
@@ -691,9 +688,10 @@ instance ToConcrete A.ModuleApplication C.ModuleApplication where
toConcrete (A.SectionApp tel y es) = do
y <- toConcreteCtx FunctionCtx y
bindToConcrete tel $ \tel -> do
- es <- toConcreteCtx ArgumentCtx es
- let r = fuseRange y es
- return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es)
+ es <- toConcreteCtx ArgumentCtx es
+ let r = fuseRange y es
+ return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es)
+
toConcrete (A.RecordModuleIFS recm) = do
recm <- toConcrete recm
return $ C.RecordModuleIFS (getRange recm) recm
@@ -706,7 +704,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
info <- toConcrete info
return [C.Postulate (getRange i) [C.TypeSig info x' t']]
@@ -714,14 +712,14 @@ instance ToConcrete A.Declaration [C.Declaration] where
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [C.Field x' t']
toConcrete (A.Primitive i x t) = do
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [C.Primitive (getRange i) [C.TypeSig defaultArgInfo x' t']]
-- Primitives are always relevant.
@@ -732,7 +730,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
withAbstractPrivate i $
bindToConcrete bs $ \tel' -> do
x' <- unsafeQNameToName <$> toConcrete x
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [ C.DataSig (getRange i) Inductive x' (map C.DomainFull $ concat tel') t' ]
toConcrete (A.DataDef i x bs cs) =
@@ -745,7 +743,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
withAbstractPrivate i $
bindToConcrete bs $ \tel' -> do
x' <- unsafeQNameToName <$> toConcrete x
- t' <- toConcreteCtx TopCtx t
+ t' <- toConcreteTop t
return [ C.RecordSig (getRange i) x' (map C.DomainFull $ concat tel') t' ]
toConcrete (A.RecDef i x ind c bs t cs) =
@@ -759,8 +757,8 @@ instance ToConcrete A.Declaration [C.Declaration] where
toConcrete (A.Section i x tel ds) = do
x <- toConcrete x
bindToConcrete tel $ \tel -> do
- ds <- declsToConcrete ds
- return [ C.Module (getRange i) x (concat tel) ds ]
+ ds <- declsToConcrete ds
+ return [ C.Module (getRange i) x (concat tel) ds ]
toConcrete (A.Apply i x modapp _ _) = do
x <- unsafeQNameToName <$> toConcrete x
@@ -796,36 +794,32 @@ instance ToConcrete A.Declaration [C.Declaration] where
data RangeAndPragma = RangeAndPragma Range A.Pragma
instance ToConcrete RangeAndPragma C.Pragma where
- toConcrete (RangeAndPragma r p) = case p of
- A.OptionsPragma xs -> return $ C.OptionsPragma r xs
- A.BuiltinPragma b x -> do
- x <- toConcrete x
- return $ C.BuiltinPragma r b x
- A.RewritePragma x -> do
- x <- toConcrete x
- return $ C.RewritePragma r x
- A.CompiledTypePragma x hs -> do
- x <- toConcrete x
- return $ C.CompiledTypePragma r x hs
- A.CompiledDataPragma x hs hcs -> do
- x <- toConcrete x
- return $ C.CompiledDataPragma r x hs hcs
- A.CompiledPragma x hs -> do
- x <- toConcrete x
- return $ C.CompiledPragma r x hs
- A.CompiledExportPragma x hs -> do
- x <- toConcrete x
- return $ C.CompiledExportPragma r x hs
- A.CompiledEpicPragma x e -> do
- x <- toConcrete x
- return $ C.CompiledEpicPragma r x e
- A.CompiledJSPragma x e -> do
- x <- toConcrete x
- return $ C.CompiledJSPragma r x e
- A.StaticPragma x -> do
- x <- toConcrete x
- return $ C.StaticPragma r x
- A.EtaPragma x -> C.EtaPragma r <$> toConcrete x
+ toConcrete (RangeAndPragma r p) = case p of
+ A.OptionsPragma xs -> return $ C.OptionsPragma r xs
+ A.BuiltinPragma b e -> C.BuiltinPragma r b <$> toConcrete e
+ A.BuiltinNoDefPragma b x -> C.BuiltinPragma r b . C.Ident <$>
+ toConcrete x
+ A.RewritePragma x -> C.RewritePragma r <$> toConcrete x
+ A.CompiledTypePragma x hs -> do
+ x <- toConcrete x
+ return $ C.CompiledTypePragma r x hs
+ A.CompiledDataPragma x hs hcs -> do
+ x <- toConcrete x
+ return $ C.CompiledDataPragma r x hs hcs
+ A.CompiledPragma x hs -> do
+ x <- toConcrete x
+ return $ C.CompiledPragma r x hs
+ A.CompiledExportPragma x hs -> do
+ x <- toConcrete x
+ return $ C.CompiledExportPragma r x hs
+ A.CompiledEpicPragma x e -> do
+ x <- toConcrete x
+ return $ C.CompiledEpicPragma r x e
+ A.CompiledJSPragma x e -> do
+ x <- toConcrete x
+ return $ C.CompiledJSPragma r x e
+ A.StaticPragma x -> C.StaticPragma r <$> toConcrete x
+ A.EtaPragma x -> C.EtaPragma r <$> toConcrete x
-- Left hand sides --------------------------------------------------------
@@ -847,28 +841,9 @@ instance ToConcrete A.LHS C.LHS where
bindToConcreteCtx TopCtx lhscore $ \lhs ->
bindToConcreteCtx TopCtx (noImplicitPats wps) $ \wps ->
ret $ C.LHS lhs wps [] []
-{-
- bindToConcrete (A.LHS i (A.LHSHead x args) wps) ret = do
- bindToConcreteCtx TopCtx (A.DefP info x args) $ \lhs ->
- bindToConcreteCtx TopCtx (noImplicitPats wps) $ \wps ->
- ret $ C.LHS lhs wps [] []
- where info = PatRange (getRange i)
--}
instance ToConcrete A.LHSCore C.Pattern where
bindToConcrete = bindToConcrete . lhsCoreToPattern
-{-
- bindToConcrete (A.LHSHead x args) ret = do
- bindToConcreteCtx TopCtx (A.DefP info x args) $ \ lhs ->
- ret $ lhs
- where info = PatRange noRange -- seems to be unused anyway
- bindToConcrete (A.LHSProj d ps1 lhscore ps2) ret = do
- d <- toConcrete d
- bindToConcrete ps1 $ \ ps1 ->
- bindToConcrete lhscore $ \ p ->
- bindToConcrete ps2 $ \ ps2 ->
- ret $ makePattern d ps1 p ps2
- -}
appBrackets' :: [arg] -> Precedence -> Bool
appBrackets' [] _ = False
@@ -912,8 +887,9 @@ instance ToConcrete A.Pattern C.Pattern where
data Hd = HdVar A.Name | HdCon A.QName | HdDef A.QName
-cOpApp :: Range -> C.QName -> [C.Expr] -> C.Expr
-cOpApp r n es = C.OpApp r n (map (defaultNamedArg . Ordinary) es)
+cOpApp :: Range -> C.QName -> A.Name -> [C.Expr] -> C.Expr
+cOpApp r x n es =
+ C.OpApp r x (Set.singleton n) (map (defaultNamedArg . Ordinary) es)
tryToRecoverOpApp :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr
tryToRecoverOpApp e def = recoverOpApp bracket cOpApp view e def
@@ -930,7 +906,9 @@ tryToRecoverOpApp e def = recoverOpApp bracket cOpApp view e def
tryToRecoverOpAppP :: A.Pattern -> AbsToCon C.Pattern -> AbsToCon C.Pattern
tryToRecoverOpAppP p def = recoverOpApp bracketP_ opApp view p def
where
- opApp r x ps = C.OpAppP r x (map defaultNamedArg ps)
+ opApp r x n ps =
+ C.OpAppP r x (Set.singleton n) (map defaultNamedArg ps)
+
view p = case p of
ConP _ (AmbQ (c:_)) ps -> Just (HdCon c, ps)
DefP _ f ps -> Just (HdDef f, ps)
@@ -938,7 +916,7 @@ tryToRecoverOpAppP p def = recoverOpApp bracketP_ opApp view p def
recoverOpApp :: (ToConcrete a c, HasRange c)
=> ((Precedence -> Bool) -> AbsToCon c -> AbsToCon c)
- -> (Range -> C.QName -> [c] -> c)
+ -> (Range -> C.QName -> A.Name -> [c] -> c)
-> (a -> Maybe (Hd, [A.NamedArg a]))
-> a
-> AbsToCon c
@@ -959,19 +937,20 @@ recoverOpApp bracket opApp view e mDefault = case view e of
doQNameHelper fixityHelper conHelper n as = do
x <- toConcrete n
- doQName (theFixity $ nameFixity $ fixityHelper n) (conHelper x) as
+ doQName (theFixity $ nameFixity n') (conHelper x) n' as
+ where n' = fixityHelper n
-- fall-back (wrong number of arguments or no holes)
- doQName _ n es
+ doQName _ x _ es
| length xs == 1 = mDefault
| length es /= numHoles = mDefault
| null es = mDefault
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
numHoles = length (filter (== Hole) xs)
-- binary case
- doQName fixity n as
+ doQName fixity x n as
| Hole <- head xs
, Hole <- last xs = do
let a1 = head as
@@ -983,12 +962,12 @@ recoverOpApp bracket opApp view e mDefault = case view e of
es <- mapM (toConcreteCtx InsideOperandCtx) as'
en <- toConcreteCtx (RightOperandCtx fixity) an
bracket (opBrackets fixity)
- $ return $ opApp (getRange (e1, en)) n ([e1] ++ es ++ [en])
+ $ return $ opApp (getRange (e1, en)) x n ([e1] ++ es ++ [en])
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
-- prefix
- doQName fixity n as
+ doQName fixity x n as
| Hole <- last xs = do
let an = last as
as' = case as of
@@ -997,24 +976,24 @@ recoverOpApp bracket opApp view e mDefault = case view e of
es <- mapM (toConcreteCtx InsideOperandCtx) as'
en <- toConcreteCtx (RightOperandCtx fixity) an
bracket (opBrackets fixity)
- $ return $ opApp (getRange (n, en)) n (es ++ [en])
+ $ return $ opApp (getRange (n, en)) x n (es ++ [en])
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
-- postfix
- doQName fixity n as
+ doQName fixity x n as
| Hole <- head xs = do
let a1 = head as
as' = tail as
e1 <- toConcreteCtx (LeftOperandCtx fixity) a1
es <- mapM (toConcreteCtx InsideOperandCtx) as'
bracket (opBrackets fixity)
- $ return $ opApp (getRange (e1, n)) n ([e1] ++ es)
+ $ return $ opApp (getRange (e1, n)) x n ([e1] ++ es)
where
- xs = C.nameParts $ C.unqualify n
+ xs = C.nameParts $ C.unqualify x
-- roundfix
- doQName _ n as = do
+ doQName _ x n as = do
es <- mapM (toConcreteCtx InsideOperandCtx) as
bracket roundFixBrackets
- $ return $ opApp (getRange n) n es
+ $ return $ opApp (getRange x) x n es