summaryrefslogtreecommitdiff
path: root/src/full/Agda/Syntax
diff options
context:
space:
mode:
Diffstat (limited to 'src/full/Agda/Syntax')
-rw-r--r--src/full/Agda/Syntax/Abstract.hs275
-rw-r--r--src/full/Agda/Syntax/Abstract/Copatterns.hs55
-rw-r--r--src/full/Agda/Syntax/Abstract/Name.hs52
-rw-r--r--src/full/Agda/Syntax/Abstract/Pretty.hs1
-rw-r--r--src/full/Agda/Syntax/Abstract/Views.hs33
-rw-r--r--src/full/Agda/Syntax/Common.hs188
-rw-r--r--src/full/Agda/Syntax/Concrete.hs66
-rw-r--r--src/full/Agda/Syntax/Concrete/Definitions.hs1034
-rw-r--r--src/full/Agda/Syntax/Concrete/Generic.hs4
-rw-r--r--src/full/Agda/Syntax/Concrete/Name.hs57
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators.hs101
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators/Parser.hs101
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs100
-rw-r--r--src/full/Agda/Syntax/Concrete/Pretty.hs53
-rw-r--r--src/full/Agda/Syntax/Fixity.hs37
-rw-r--r--src/full/Agda/Syntax/IdiomBrackets.hs48
-rw-r--r--src/full/Agda/Syntax/Info.hs10
-rw-r--r--src/full/Agda/Syntax/Internal.hs326
-rw-r--r--src/full/Agda/Syntax/Internal/Defs.hs9
-rw-r--r--src/full/Agda/Syntax/Internal/Generic.hs12
-rw-r--r--src/full/Agda/Syntax/Internal/Names.hs18
-rw-r--r--src/full/Agda/Syntax/Internal/Pattern.hs104
-rw-r--r--src/full/Agda/Syntax/Internal/SanityCheck.hs72
-rw-r--r--src/full/Agda/Syntax/Literal.hs27
-rw-r--r--src/full/Agda/Syntax/Parser.hs151
-rw-r--r--src/full/Agda/Syntax/Parser/LexActions.hs2
-rw-r--r--src/full/Agda/Syntax/Parser/Lexer.x23
-rw-r--r--src/full/Agda/Syntax/Parser/Literate.hs219
-rw-r--r--src/full/Agda/Syntax/Parser/LookAhead.hs1
-rw-r--r--src/full/Agda/Syntax/Parser/Monad.hs113
-rw-r--r--src/full/Agda/Syntax/Parser/Parser.y121
-rw-r--r--src/full/Agda/Syntax/Parser/Tokens.hs6
-rw-r--r--src/full/Agda/Syntax/Position.hs275
-rw-r--r--src/full/Agda/Syntax/Scope/Base.hs29
-rw-r--r--src/full/Agda/Syntax/Scope/Monad.hs197
-rw-r--r--src/full/Agda/Syntax/Translation/AbstractToConcrete.hs142
-rw-r--r--src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs454
-rw-r--r--src/full/Agda/Syntax/Translation/InternalToAbstract.hs961
-rw-r--r--src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs44
-rw-r--r--src/full/Agda/Syntax/Treeless.hs49
40 files changed, 3369 insertions, 2201 deletions
diff --git a/src/full/Agda/Syntax/Abstract.hs b/src/full/Agda/Syntax/Abstract.hs
index 91a59cf..e58a222 100644
--- a/src/full/Agda/Syntax/Abstract.hs
+++ b/src/full/Agda/Syntax/Abstract.hs
@@ -1,10 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-| The abstract syntax. This is what you get after desugaring and scope
@@ -16,11 +11,12 @@ module Agda.Syntax.Abstract
, module Agda.Syntax.Abstract.Name
) where
-import Prelude hiding (foldl, foldr)
+import Prelude
import Control.Arrow (first)
import Control.Applicative
-import Data.Foldable as Fold
+import Data.Foldable (Foldable)
+import qualified Data.Foldable as Fold
import Data.Map (Map)
import Data.Maybe
import Data.Sequence (Seq, (<|), (><))
@@ -29,6 +25,7 @@ import Data.Traversable
import Data.Typeable (Typeable)
import Data.Void
+import Agda.Syntax.Concrete.Name (NumHoles(..))
import Agda.Syntax.Concrete (FieldAssignment'(..), exprFieldA)
import qualified Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Pretty ()
@@ -39,9 +36,14 @@ import Agda.Syntax.Abstract.Name
import Agda.Syntax.Abstract.Name as A (QNamed)
import Agda.Syntax.Literal
import Agda.Syntax.Scope.Base
+import qualified Agda.Syntax.Internal as I
+import Agda.TypeChecking.Positivity.Occurrence
+
+import Agda.Utils.Functor
import Agda.Utils.Geniplate
import Agda.Utils.Lens
+import Agda.Utils.Pretty
#include "undefined.h"
import Agda.Utils.Impossible
@@ -52,8 +54,8 @@ type Args = [NamedArg Expr]
data Expr
= Var Name -- ^ Bound variable.
| Def QName -- ^ Constant: axiom, function, data or record type.
- | Proj QName -- ^ Projection.
- | Con AmbiguousQName -- ^ Constructor.
+ | Proj ProjOrigin AmbiguousQName -- ^ Projection (overloaded).
+ | Con AmbiguousQName -- ^ Constructor (overloaded).
| PatternSyn QName -- ^ Pattern synonym.
| Macro QName -- ^ Macro.
| Lit Literal -- ^ Literal.
@@ -66,6 +68,7 @@ data Expr
-- 'metaNumber' to 'Nothing' while keeping the 'InteractionId'.
| Underscore MetaInfo
-- ^ Meta variable for hidden argument (must be inferred locally).
+ | Dot ExprInfo Expr -- ^ @.e@, for postfix projection.
| App ExprInfo Expr (NamedArg Expr) -- ^ Ordinary (binary) application.
| WithApp ExprInfo Expr [Expr] -- ^ With application.
| Lam ExprInfo LamBinding Expr -- ^ @λ bs → e@.
@@ -106,13 +109,35 @@ data Axiom
-- | Renaming (generic).
type Ren a = [(a, a)]
+data ScopeCopyInfo = ScopeCopyInfo
+ { renModules :: Ren ModuleName
+ , renNames :: Ren QName }
+ deriving (Eq, Show)
+
+initCopyInfo :: ScopeCopyInfo
+initCopyInfo = ScopeCopyInfo
+ { renModules = []
+ , renNames = []
+ }
+
+instance Pretty ScopeCopyInfo where
+ pretty i = vcat [ prRen "renModules =" (renModules i)
+ , prRen "renNames =" (renNames i) ]
+ where
+ prRen s r = sep [ text s, nest 2 $ vcat (map pr r) ]
+ pr (x, y) = pretty x <+> text "->" <+> pretty y
+
data Declaration
- = Axiom Axiom DefInfo ArgInfo QName Expr -- ^ type signature (can be irrelevant and colored, but not hidden)
+ = Axiom Axiom DefInfo ArgInfo (Maybe [Occurrence]) QName Expr
+ -- ^ Type signature (can be irrelevant, but not hidden).
+ --
+ -- The fourth argument contains an optional assignment of
+ -- polarities to arguments.
| Field DefInfo QName (Arg Expr) -- ^ record field
| Primitive DefInfo QName Expr -- ^ primitive function
| Mutual MutualInfo [Declaration] -- ^ a bunch of mutually recursive definitions
| Section ModuleInfo ModuleName [TypedBindings] [Declaration]
- | Apply ModuleInfo ModuleName ModuleApplication (Ren QName) (Ren ModuleName) ImportDirective
+ | Apply ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective
-- ^ The @ImportDirective@ is for highlighting purposes.
| Import ModuleInfo ModuleName ImportDirective
-- ^ The @ImportDirective@ is for highlighting purposes.
@@ -139,7 +164,7 @@ class GetDefInfo a where
getDefInfo :: a -> Maybe DefInfo
instance GetDefInfo Declaration where
- getDefInfo (Axiom _ i _ _ _) = Just i
+ getDefInfo (Axiom _ i _ _ _ _) = Just i
getDefInfo (Field i _ _) = Just i
getDefInfo (Primitive i _ _) = Just i
getDefInfo (ScopedDecl _ (d:_)) = getDefInfo d
@@ -177,7 +202,6 @@ data Pragma
| CompiledJSPragma QName String
| CompiledUHCPragma QName String
| CompiledDataUHCPragma QName String [String]
- | NoSmashingPragma QName
| StaticPragma QName
| InlinePragma QName
| DisplayPragma QName [NamedArg Pattern] Expr
@@ -189,8 +213,8 @@ data LetBinding
-- ^ @LetBind info rel name type defn@
| LetPatBind LetInfo Pattern Expr
-- ^ Irrefutable pattern binding.
- | LetApply ModuleInfo ModuleName ModuleApplication (Ren QName) (Ren ModuleName) ImportDirective
- -- ^ @LetApply mi newM (oldM args) renaming moduleRenaming dir@.
+ | LetApply ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective
+ -- ^ @LetApply mi newM (oldM args) renamings dir@.
-- The @ImportDirective@ is for highlighting purposes.
| LetOpen ModuleInfo ModuleName ImportDirective
-- ^ only for highlighting and abstractToConcrete
@@ -238,11 +262,20 @@ data TypedBinding
type Telescope = [TypedBindings]
+data NamedDotPattern = NamedDot Name I.Term I.Type
+ deriving (Typeable, Show)
+
+instance Eq NamedDotPattern where
+ _ == _ = True -- These are not relevant for caching purposes
+
-- | We could throw away @where@ clauses at this point and translate them to
-- @let@. It's not obvious how to remember that the @let@ was really a
-- @where@ clause though, so for the time being we keep it here.
data Clause' lhs = Clause
{ clauseLHS :: lhs
+ , clauseNamedDots :: [NamedDotPattern]
+ -- ^ Only in with-clauses where we inherit some already checked dot patterns from the parent.
+ -- These live in the context of the parent clause left-hand side.
, clauseRHS :: RHS
, clauseWhereDecls :: [Declaration]
, clauseCatchall :: Bool
@@ -252,19 +285,38 @@ type Clause = Clause' LHS
type SpineClause = Clause' SpineLHS
data RHS
- = RHS Expr
+ = RHS
+ { rhsExpr :: Expr
+ , rhsConcrete :: Maybe C.Expr
+ -- ^ We store the original concrete expression in case
+ -- we have to reproduce it during interactive case splitting.
+ -- 'Nothing' for internally generated rhss.
+ }
| AbsurdRHS
| WithRHS QName [Expr] [Clause]
-- ^ The 'QName' is the name of the with function.
- | RewriteRHS [(QName, Expr)] RHS [Declaration]
- -- ^ The 'QName's are the names of the generated with functions.
- -- One for each 'Expr'.
- -- The RHS shouldn't be another @RewriteRHS@.
- deriving (Typeable, Show, Eq)
+ | RewriteRHS
+ { rewriteExprs :: [(QName, Expr)]
+ -- ^ The 'QName's are the names of the generated with functions,
+ -- one for each 'Expr'.
+ , rewriteRHS :: RHS
+ -- ^ The RHS should not be another @RewriteRHS@.
+ , rewriteWhereDecls :: [Declaration]
+ -- ^ The where clauses are attached to the @RewriteRHS@ by
+ --- the scope checker (instead of to the clause).
+ }
+ deriving (Typeable, Show)
+
+instance Eq RHS where
+ RHS e _ == RHS e' _ = e == e'
+ AbsurdRHS == AbsurdRHS = True
+ WithRHS a b c == WithRHS a' b' c' = and [ a == a', b == b', c == c' ]
+ RewriteRHS a b c == RewriteRHS a' b' c' = and [ a == a', b == b', c == c' ]
+ _ == _ = False
-- | The lhs of a clause in spine view (inside-out).
-- Projection patterns are contained in @spLhsPats@,
--- represented as @DefP d []@.
+-- represented as @ProjP d@.
data SpineLHS = SpineLHS
{ spLhsInfo :: LHSInfo -- ^ Range.
, spLhsDefName :: QName -- ^ Name of function we are defining.
@@ -294,11 +346,8 @@ data LHSCore' e
, lhsPats :: [NamedArg (Pattern' e)] -- ^ Applied to patterns @ps@.
}
-- | Projection
- | LHSProj { lhsDestructor :: QName
+ | LHSProj { lhsDestructor :: AmbiguousQName
-- ^ Record projection identifier.
- , lhsPatsLeft :: [NamedArg (Pattern' e)]
- -- ^ Indices of the projection.
- -- Currently none @[]@, since we do not have indexed records.
, lhsFocus :: NamedArg (LHSCore' e)
-- ^ Main branch.
, lhsPatsRight :: [NamedArg (Pattern' e)]
@@ -331,29 +380,33 @@ instance LHSToSpine LHS SpineLHS where
lhsCoreToSpine :: LHSCore' e -> A.QNamed [NamedArg (Pattern' e)]
lhsCoreToSpine (LHSHead f ps) = QNamed f ps
-lhsCoreToSpine (LHSProj d ps1 h ps2) = (++ (p : ps2)) <$> lhsCoreToSpine (namedArg h)
- where p = updateNamedArg (const $ DefP patNoRange d ps1) h
+lhsCoreToSpine (LHSProj d h ps) = (++ (p : ps)) <$> lhsCoreToSpine (namedArg h)
+ where p = updateNamedArg (const $ ProjP patNoRange ProjPrefix d) h
-spineToLhsCore :: QNamed [NamedArg (Pattern' e)] -> LHSCore' e
+spineToLhsCore :: IsProjP e => QNamed [NamedArg (Pattern' e)] -> LHSCore' e
spineToLhsCore (QNamed f ps) = lhsCoreAddSpine (LHSHead f []) ps
-- | Add applicative patterns (non-projection patterns) to the right.
-lhsCoreApp :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
-lhsCoreApp (LHSHead f ps) ps' = LHSHead f $ ps ++ ps'
-lhsCoreApp (LHSProj d ps1 h ps2) ps' = LHSProj d ps1 h $ ps2 ++ ps'
+lhsCoreApp :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
+lhsCoreApp (LHSHead f ps) ps' = LHSHead f $ ps ++ ps'
+lhsCoreApp (LHSProj d h ps) ps' = LHSProj d h $ ps ++ ps'
-- | Add projection and applicative patterns to the right.
-lhsCoreAddSpine :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
+lhsCoreAddSpine :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
lhsCoreAddSpine core ps = case ps2 of
- (Arg info (Named n (DefP i d ps0)) : ps2') ->
- LHSProj d ps0 (Arg info $ Named n $ lhsCoreApp core ps1) []
- `lhsCoreAddSpine` ps2'
[] -> lhsCoreApp core ps
+ p@(Arg info (Named n (ProjP i o d))) : ps2' | let nh = numHoles d->
+ -- Andreas, 2016-06-13
+ -- If the projection was written prefix by the user
+ -- or it is fully applied an operator
+ -- we turn it to prefix projection form.
+ (if o == ProjPrefix || nh > 0 && nh <= 1 + length ps2' then
+ LHSProj d (Arg info $ Named n $ lhsCoreApp core ps1) []
+ else lhsCoreApp core $ ps1 ++ [p])
+ `lhsCoreAddSpine` ps2'
_ -> __IMPOSSIBLE__
where
- (ps1, ps2) = break (isDefP . namedArg) ps
- isDefP DefP{} = True
- isDefP _ = False
+ (ps1, ps2) = break (isJust . isProjP) ps
-- | Used for checking pattern linearity.
lhsCoreAllPatterns :: LHSCore' e -> [Pattern' e]
@@ -363,15 +416,14 @@ lhsCoreAllPatterns = map namedArg . qnamed . lhsCoreToSpine
lhsCoreToPattern :: LHSCore -> Pattern
lhsCoreToPattern lc =
case lc of
- LHSHead f aps -> DefP noInfo f aps
- LHSProj d aps1 lhscore aps2 -> DefP noInfo d $
- aps1 ++ fmap (fmap lhsCoreToPattern) lhscore : aps2
+ LHSHead f aps -> DefP noInfo (AmbQ [f]) aps
+ LHSProj d lhscore aps -> DefP noInfo d $
+ fmap (fmap lhsCoreToPattern) lhscore : aps
where noInfo = patNoRange -- TODO, preserve range!
mapLHSHead :: (QName -> [NamedArg Pattern] -> LHSCore) -> LHSCore -> LHSCore
-mapLHSHead f (LHSHead x ps) = f x ps
-mapLHSHead f (LHSProj d ps1 l ps2) =
- LHSProj d ps1 (fmap (fmap (mapLHSHead f)) l) ps2
+mapLHSHead f (LHSHead x ps) = f x ps
+mapLHSHead f (LHSProj d l ps) = LHSProj d (fmap (fmap (mapLHSHead f)) l) ps
---------------------------------------------------------------------------
-- * Patterns
@@ -381,13 +433,17 @@ mapLHSHead f (LHSProj d ps1 l ps2) =
data Pattern' e
= VarP Name
| ConP ConPatInfo AmbiguousQName [NamedArg (Pattern' e)]
- | DefP PatInfo QName [NamedArg (Pattern' e)]
- -- ^ Defined pattern: function definition @f ps@ or destructor pattern @d p ps@.
+ | ProjP PatInfo ProjOrigin AmbiguousQName
+ -- ^ Destructor pattern @d@.
+ | DefP PatInfo AmbiguousQName [NamedArg (Pattern' e)]
+ -- ^ Defined pattern: function definition @f ps@.
+ -- It is also abused to convert destructor patterns into concrete syntax
+ -- thus, we put AmbiguousQName here as well.
| WildP PatInfo
-- ^ Underscore pattern entered by user.
-- Or generated at type checking for implicit arguments.
| AsP PatInfo Name (Pattern' e)
- | DotP PatInfo e
+ | DotP PatInfo Origin e
| AbsurdP PatInfo
| LitP Literal
| PatternSynP PatInfo QName [NamedArg (Pattern' e)]
@@ -397,38 +453,49 @@ data Pattern' e
type Pattern = Pattern' Expr
type Patterns = [NamedArg Pattern]
--- | Check whether we are a projection pattern.
-class IsProjP a where
- isProjP :: a -> Maybe QName
-
instance IsProjP (Pattern' e) where
- isProjP (DefP _ d []) = Just d
- isProjP _ = Nothing
+ isProjP (ProjP _ o d) = Just (o, d)
+ isProjP _ = Nothing
+
+instance IsProjP Expr where
+ isProjP (Proj o ds) = Just (o, ds)
+ isProjP (ScopedExpr _ e) = isProjP e
+ isProjP _ = Nothing
-instance IsProjP a => IsProjP (Arg a) where
- isProjP = isProjP . unArg
+class MaybePostfixProjP a where
+ maybePostfixProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)
-instance IsProjP a => IsProjP (Named n a) where
- isProjP = isProjP . namedThing
+instance IsProjP e => MaybePostfixProjP (Pattern' e) where
+ maybePostfixProjP (DotP _ _ e) = isProjP e <&> \ (_o, d) -> (ProjPostfix, d)
+ maybePostfixProjP (ProjP _ o d) = Just (o, d)
+ maybePostfixProjP _ = Nothing
+
+instance MaybePostfixProjP a => MaybePostfixProjP (Arg a) where
+ maybePostfixProjP = maybePostfixProjP . unArg
+
+instance MaybePostfixProjP a => MaybePostfixProjP (Named n a) where
+ maybePostfixProjP = maybePostfixProjP . namedThing
{--------------------------------------------------------------------------
Instances
--------------------------------------------------------------------------}
-- | Does not compare 'ScopeInfo' fields.
+-- Does not distinguish between prefix and postfix projections.
instance Eq Expr where
ScopedExpr _ a1 == ScopedExpr _ a2 = a1 == a2
Var a1 == Var a2 = a1 == a2
Def a1 == Def a2 = a1 == a2
- Proj a1 == Proj a2 = a1 == a2
+ Proj _ a1 == Proj _ a2 = a1 == a2
Con a1 == Con a2 = a1 == a2
PatternSyn a1 == PatternSyn a2 = a1 == a2
Macro a1 == Macro a2 = a1 == a2
Lit a1 == Lit a2 = a1 == a2
QuestionMark a1 b1 == QuestionMark a2 b2 = (a1, b1) == (a2, b2)
Underscore a1 == Underscore a2 = a1 == a2
+ Dot r1 e1 == Dot r2 e2 = (r1, e1) == (r2, e2)
App a1 b1 c1 == App a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
WithApp a1 b1 c1 == WithApp a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Lam a1 b1 c1 == Lam a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
@@ -457,12 +524,12 @@ instance Eq Expr where
instance Eq Declaration where
ScopedDecl _ a1 == ScopedDecl _ a2 = a1 == a2
- Axiom a1 b1 c1 d1 e1 == Axiom a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)
+ Axiom a1 b1 c1 d1 e1 f1 == Axiom a2 b2 c2 d2 e2 f2 = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)
Field a1 b1 c1 == Field a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Primitive a1 b1 c1 == Primitive a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Mutual a1 b1 == Mutual a2 b2 = (a1, b1) == (a2, b2)
Section a1 b1 c1 d1 == Section a2 b2 c2 d2 = (a1, b1, c1, d1) == (a2, b2, c2, d2)
- Apply a1 b1 c1 d1 e1 f1 == Apply a2 b2 c2 d2 e2 f2 = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)
+ Apply a1 b1 c1 d1 e1 == Apply a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)
Import a1 b1 c1 == Import a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Pragma a1 b1 == Pragma a2 b2 = (a1, b1) == (a2, b2)
Open a1 b1 c1 == Open a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
@@ -505,11 +572,12 @@ instance HasRange TypedBinding where
instance HasRange Expr where
getRange (Var x) = getRange x
getRange (Def x) = getRange x
- getRange (Proj x) = getRange x
+ getRange (Proj _ x) = getRange x
getRange (Con x) = getRange x
getRange (Lit l) = getRange l
getRange (QuestionMark i _) = getRange i
getRange (Underscore i) = getRange i
+ getRange (Dot i _) = getRange i
getRange (App i _ _) = getRange i
getRange (WithApp i _ _) = getRange i
getRange (Lam i _ _) = getRange i
@@ -535,11 +603,11 @@ instance HasRange Expr where
getRange (Macro x) = getRange x
instance HasRange Declaration where
- getRange (Axiom _ i _ _ _ ) = getRange i
+ getRange (Axiom _ i _ _ _ _ ) = getRange i
getRange (Field i _ _ ) = getRange i
getRange (Mutual i _ ) = getRange i
getRange (Section i _ _ _ ) = getRange i
- getRange (Apply i _ _ _ _ _) = getRange i
+ getRange (Apply i _ _ _ _) = getRange i
getRange (Import i _ _ ) = getRange i
getRange (Primitive i _ _ ) = getRange i
getRange (Pragma i _ ) = getRange i
@@ -557,10 +625,11 @@ instance HasRange Declaration where
instance HasRange (Pattern' e) where
getRange (VarP x) = getRange x
getRange (ConP i _ _) = getRange i
+ getRange (ProjP i _ _) = getRange i
getRange (DefP i _ _) = getRange i
getRange (WildP i) = getRange i
getRange (AsP i _ _) = getRange i
- getRange (DotP i _) = getRange i
+ getRange (DotP i _ _) = getRange i
getRange (AbsurdP i) = getRange i
getRange (LitP l) = getRange l
getRange (PatternSynP i _ _) = getRange i
@@ -574,21 +643,21 @@ instance HasRange LHS where
instance HasRange (LHSCore' e) where
getRange (LHSHead f ps) = fuseRange f ps
- getRange (LHSProj d ps1 lhscore ps2) = d `fuseRange` ps1 `fuseRange` lhscore `fuseRange` ps2
+ getRange (LHSProj d lhscore ps) = d `fuseRange` lhscore `fuseRange` ps
instance HasRange a => HasRange (Clause' a) where
- getRange (Clause lhs rhs ds catchall) = getRange (lhs,rhs,ds)
+ getRange (Clause lhs _ rhs ds catchall) = getRange (lhs,rhs,ds)
instance HasRange RHS where
getRange AbsurdRHS = noRange
- getRange (RHS e) = getRange e
+ getRange (RHS e _) = getRange e
getRange (WithRHS _ e cs) = fuseRange e cs
getRange (RewriteRHS xes rhs wh) = getRange (map snd xes, rhs, wh)
instance HasRange LetBinding where
getRange (LetBind i _ _ _ _ ) = getRange i
getRange (LetPatBind i _ _ ) = getRange i
- getRange (LetApply i _ _ _ _ _ ) = getRange i
+ getRange (LetApply i _ _ _ _ ) = getRange i
getRange (LetOpen i _ _ ) = getRange i
getRange (LetDeclaredVariable x) = getRange x
@@ -596,10 +665,11 @@ instance HasRange LetBinding where
instance SetRange (Pattern' a) where
setRange r (VarP x) = VarP (setRange r x)
setRange r (ConP i ns as) = ConP (setRange r i) ns as
- setRange r (DefP _ n as) = DefP (PatRange r) (setRange r n) as
+ setRange r (ProjP _ o ns) = ProjP (PatRange r) o ns
+ setRange r (DefP _ ns as) = DefP (PatRange r) ns as -- (setRange r n) as
setRange r (WildP _) = WildP (PatRange r)
setRange r (AsP _ n p) = AsP (PatRange r) (setRange r n) p
- setRange r (DotP _ e) = DotP (PatRange r) e
+ setRange r (DotP _ o e) = DotP (PatRange r) o e
setRange r (AbsurdP _) = AbsurdP (PatRange r)
setRange r (LitP l) = LitP (setRange r l)
setRange r (PatternSynP _ n as) = PatternSynP (PatRange r) (setRange r n) as
@@ -619,11 +689,12 @@ instance KillRange TypedBinding where
instance KillRange Expr where
killRange (Var x) = killRange1 Var x
killRange (Def x) = killRange1 Def x
- killRange (Proj x) = killRange1 Proj x
+ killRange (Proj o x) = killRange1 (Proj o) x
killRange (Con x) = killRange1 Con x
killRange (Lit l) = killRange1 Lit l
killRange (QuestionMark i ii) = killRange2 QuestionMark i ii
killRange (Underscore i) = killRange1 Underscore i
+ killRange (Dot i e) = killRange2 Dot i e
killRange (App i e1 e2) = killRange3 App i e1 e2
killRange (WithApp i e es) = killRange3 WithApp i e es
killRange (Lam i b e) = killRange3 Lam i b e
@@ -649,13 +720,11 @@ instance KillRange Expr where
killRange (Macro x) = killRange1 Macro x
instance KillRange Declaration where
- killRange (Axiom p i rel a b ) = killRange4 (Axiom p) i rel a b
+ killRange (Axiom p i a b c d ) = killRange4 (\i a c d -> Axiom p i a b c d) i a c d
killRange (Field i a b ) = killRange3 Field i a b
killRange (Mutual i a ) = killRange2 Mutual i a
killRange (Section i a b c ) = killRange4 Section i a b c
- killRange (Apply i a b c d e ) = killRange3 Apply i a b c d (killRange e)
- -- the arguments c and d of Apply are name maps, so nothing to kill
- -- Andreas, 2016-01-24 really?
+ killRange (Apply i a b c d ) = killRange5 Apply i a b c d
killRange (Import i a b ) = killRange3 Import i a b
killRange (Primitive i a b ) = killRange3 Primitive i a b
killRange (Pragma i a ) = Pragma (killRange i) a
@@ -674,13 +743,17 @@ instance KillRange ModuleApplication where
killRange (SectionApp a b c ) = killRange3 SectionApp a b c
killRange (RecordModuleIFS a ) = killRange1 RecordModuleIFS a
+instance KillRange ScopeCopyInfo where
+ killRange (ScopeCopyInfo a b) = killRange2 ScopeCopyInfo a b
+
instance KillRange e => KillRange (Pattern' e) where
killRange (VarP x) = killRange1 VarP x
killRange (ConP i a b) = killRange3 ConP i a b
+ killRange (ProjP i o a) = killRange3 ProjP i o a
killRange (DefP i a b) = killRange3 DefP i a b
killRange (WildP i) = killRange1 WildP i
killRange (AsP i a b) = killRange3 AsP i a b
- killRange (DotP i a) = killRange2 DotP i a
+ killRange (DotP i o a) = killRange3 DotP i o a
killRange (AbsurdP i) = killRange1 AbsurdP i
killRange (LitP l) = killRange1 LitP l
killRange (PatternSynP i a p) = killRange3 PatternSynP i a p
@@ -693,22 +766,25 @@ instance KillRange LHS where
killRange (LHS i a b) = killRange3 LHS i a b
instance KillRange e => KillRange (LHSCore' e) where
- killRange (LHSHead a b) = killRange2 LHSHead a b
- killRange (LHSProj a b c d) = killRange4 LHSProj a b c d
+ killRange (LHSHead a b) = killRange2 LHSHead a b
+ killRange (LHSProj a b c) = killRange3 LHSProj a b c
instance KillRange a => KillRange (Clause' a) where
- killRange (Clause lhs rhs ds catchall) = killRange4 Clause lhs rhs ds catchall
+ killRange (Clause lhs dots rhs ds catchall) = killRange5 Clause lhs dots rhs ds catchall
+
+instance KillRange NamedDotPattern where
+ killRange (NamedDot a b c) = killRange3 NamedDot a b c
instance KillRange RHS where
killRange AbsurdRHS = AbsurdRHS
- killRange (RHS e) = killRange1 RHS e
+ killRange (RHS e c) = killRange2 RHS e c
killRange (WithRHS q e cs) = killRange3 WithRHS q e cs
killRange (RewriteRHS xes rhs wh) = killRange3 RewriteRHS xes rhs wh
instance KillRange LetBinding where
killRange (LetBind i info a b c) = killRange5 LetBind i info a b c
killRange (LetPatBind i a b ) = killRange3 LetPatBind i a b
- killRange (LetApply i a b c d e ) = killRange3 LetApply i a b c d (killRange e)
+ killRange (LetApply i a b c d ) = killRange5 LetApply i a b c d
killRange (LetOpen i x dir ) = killRange3 LetOpen i x dir
killRange (LetDeclaredVariable x) = killRange1 LetDeclaredVariable x
@@ -760,7 +836,7 @@ instance AllNames QName where
allNames q = Seq.singleton q
instance AllNames Declaration where
- allNames (Axiom _ _ _ q _) = Seq.singleton q
+ allNames (Axiom _ _ _ _ q _) = Seq.singleton q
allNames (Field _ q _) = Seq.singleton q
allNames (Primitive _ q _) = Seq.singleton q
allNames (Mutual _ defs) = allNames defs
@@ -780,10 +856,10 @@ instance AllNames Declaration where
allNames (ScopedDecl _ decls) = allNames decls
instance AllNames Clause where
- allNames (Clause _ rhs decls _) = allNames rhs >< allNames decls
+ allNames (Clause _ _ rhs decls _) = allNames rhs >< allNames decls
instance AllNames RHS where
- allNames (RHS e) = allNames e
+ allNames (RHS e _) = allNames e
allNames AbsurdRHS{} = Seq.empty
allNames (WithRHS q _ cls) = q <| allNames cls
allNames (RewriteRHS qes rhs cls) = Seq.fromList (map fst qes) >< allNames rhs >< allNames cls
@@ -796,6 +872,7 @@ instance AllNames Expr where
allNames Lit{} = Seq.empty
allNames QuestionMark{} = Seq.empty
allNames Underscore{} = Seq.empty
+ allNames (Dot _ e) = allNames e
allNames (App _ e1 e2) = allNames e1 >< allNames e2
allNames (WithApp _ e es) = allNames e >< allNames es
allNames (Lam _ b e) = allNames b >< allNames e
@@ -832,11 +909,11 @@ instance AllNames TypedBinding where
allNames (TLet _ lbs) = allNames lbs
instance AllNames LetBinding where
- allNames (LetBind _ _ _ e1 e2) = allNames e1 >< allNames e2
- allNames (LetPatBind _ _ e) = allNames e
- allNames (LetApply _ _ app _ _ _) = allNames app
- allNames LetOpen{} = Seq.empty
- allNames (LetDeclaredVariable _) = Seq.empty
+ allNames (LetBind _ _ _ e1 e2) = allNames e1 >< allNames e2
+ allNames (LetPatBind _ _ e) = allNames e
+ allNames (LetApply _ _ app _ _) = allNames app
+ allNames LetOpen{} = Seq.empty
+ allNames (LetDeclaredVariable _) = Seq.empty
instance AllNames ModuleApplication where
allNames (SectionApp bindss _ es) = allNames bindss >< allNames es
@@ -847,7 +924,7 @@ instance AllNames ModuleApplication where
-- Precondition: The declaration has to be a (scoped) 'Axiom'.
axiomName :: Declaration -> QName
-axiomName (Axiom _ _ _ q _) = q
+axiomName (Axiom _ _ _ _ q _) = q
axiomName (ScopedDecl _ (d:_)) = axiomName d
axiomName _ = __IMPOSSIBLE__
@@ -861,7 +938,7 @@ instance AnyAbstract a => AnyAbstract [a] where
anyAbstract = Fold.any anyAbstract
instance AnyAbstract Declaration where
- anyAbstract (Axiom _ i _ _ _) = defAbstract i == AbstractDef
+ anyAbstract (Axiom _ i _ _ _ _) = defAbstract i == AbstractDef
anyAbstract (Field i _ _) = defAbstract i == AbstractDef
anyAbstract (Mutual _ ds) = anyAbstract ds
anyAbstract (ScopedDecl _ ds) = anyAbstract ds
@@ -878,7 +955,7 @@ nameExpr :: AbstractName -> Expr
nameExpr d = mk (anameKind d) $ anameName d
where
mk DefName x = Def x
- mk FldName x = Proj x
+ mk FldName x = Proj ProjSystem $ AmbQ [x]
mk ConName x = Con $ AmbQ [x]
mk PatternSynName x = PatternSyn x
mk MacroName x = Macro x
@@ -896,11 +973,13 @@ patternToExpr :: Pattern -> Expr
patternToExpr (VarP x) = Var x
patternToExpr (ConP _ c ps) =
Con c `app` map (fmap (fmap patternToExpr)) ps
-patternToExpr (DefP _ f ps) =
+patternToExpr (ProjP _ o ds) = Proj o ds
+patternToExpr (DefP _ (AmbQ [f]) ps) =
Def f `app` map (fmap (fmap patternToExpr)) ps
+patternToExpr (DefP _ (AmbQ _) ps) = __IMPOSSIBLE__
patternToExpr (WildP _) = Underscore emptyMetaInfo
patternToExpr (AsP _ _ p) = patternToExpr p
-patternToExpr (DotP _ e) = e
+patternToExpr (DotP _ _ e) = e
patternToExpr (AbsurdP _) = Underscore emptyMetaInfo -- TODO: could this happen?
patternToExpr (LitP l) = Lit l
patternToExpr (PatternSynP _ _ _) = __IMPOSSIBLE__
@@ -919,12 +998,13 @@ substPattern s p = case p of
VarP z -> fromMaybe p (lookup z s)
ConP i q ps -> ConP i q (map (fmap (fmap (substPattern s))) ps)
RecP i ps -> RecP i (map (fmap (substPattern s)) ps)
+ ProjP{} -> p
WildP i -> p
- DotP i e -> DotP i (substExpr (map (fmap patternToExpr) s) e)
+ DotP i o e -> DotP i o (substExpr (map (fmap patternToExpr) s) e)
AbsurdP i -> p
LitP l -> p
DefP{} -> p -- destructor pattern
- AsP{} -> __IMPOSSIBLE__ -- @-patterns (not supported anyways)
+ AsP i x p -> AsP i x (substPattern s p) -- Note: cannot substitute into as-variable
PatternSynP{} -> __IMPOSSIBLE__ -- pattern synonyms (already gone)
class SubstExpr a where
@@ -964,6 +1044,7 @@ instance SubstExpr Expr where
Lit _ -> e
QuestionMark{} -> e
Underscore _ -> e
+ Dot i e -> Dot i (substExpr s e)
App i e e' -> App i (substExpr s e) (substExpr s e')
WithApp i e es -> WithApp i (substExpr s e) (substExpr s es)
Lam i lb e -> Lam i lb (substExpr s e)
diff --git a/src/full/Agda/Syntax/Abstract/Copatterns.hs b/src/full/Agda/Syntax/Abstract/Copatterns.hs
index 0600c9b..7c420e2 100644
--- a/src/full/Agda/Syntax/Abstract/Copatterns.hs
+++ b/src/full/Agda/Syntax/Abstract/Copatterns.hs
@@ -1,11 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
module Agda.Syntax.Abstract.Copatterns (translateCopatternClauses) where
@@ -30,6 +24,7 @@ import Agda.Syntax.Scope.Monad
import Agda.TypeChecking.Monad.Base (TypeError(..), typeError)
import Agda.Utils.Either
+import Agda.Utils.Maybe
import Agda.Utils.Tuple
#include "undefined.h"
@@ -139,18 +134,12 @@ translateCopatternClauses cs = if all noCopats cs then return (NotDelayed, cs) e
pcs :: [ProjPath Clause] <- mapM clauseToPath cs
let cps :: [(Clause, [ProjPath Expr])]
cps = groupClauses pcs
-{-
- cps = map ((theContent . head) /\ map (fmap (rhsExpr . clauseRHS))) $
- groupBy ((==) `on` clauseLHS . theContent) pcs
--}
ces <- mapM (mapSndM pathToRecord) $
map (mapSnd $ sortBy (compare `on` thePath)) cps
- return $ map (\ (c, e) -> c { clauseRHS = RHS e }) ces
+ return $ map (\ (c, e) -> c { clauseRHS = RHS e Nothing }) ces -- TODO: preserve C.Expr
where
noCopats Clause{ clauseLHS = LHS _ LHSHead{} _ } = True
noCopats _ = False
- rhsExpr (RHS e) = e
- rhsExpr _ = __IMPOSSIBLE__
-- | A sequence of decisions @b@ leading to a head @a@.
data Path a b = Path
@@ -162,7 +151,7 @@ mapContent :: (b -> c) -> Path a b -> Path a c
mapContent f (Path p c) = Path p (f c)
data ProjEntry = ProjEntry
- { projPE :: QName
+ { projPE :: AmbiguousQName
, patsPE :: [NamedArg Name] -- ^ currently we only support variable patterns
} deriving (Eq, Ord)
@@ -187,24 +176,23 @@ groupClauses (pc@(Path p c) : pcs) = (c, Path p (rhs c) : grp) : groupClauses re
collect [] = ([], [])
rhs = rhsExpr . clauseRHS
- rhsExpr (RHS e) = e
+ rhsExpr (RHS e _ ) = e -- TODO: preserve C.Expr
rhsExpr _ = __IMPOSSIBLE__
clauseToPath :: Clause -> ScopeM (ProjPath Clause)
-clauseToPath (Clause (LHS i lhs wps) (RHS e) [] catchall) =
- fmap (\ lhs -> Clause (LHS i lhs wps) (RHS e) [] catchall) <$> lhsToPath [] lhs
-clauseToPath (Clause lhs (RHS e) (_:_) _) = typeError $ NotImplemented $ "copattern clauses with where declarations"
-clauseToPath (Clause lhs _ wheredecls _) = typeError $ NotImplemented $ "copattern clauses with absurd, with or rewrite right hand side"
+clauseToPath (Clause (LHS i lhs wps) dots (RHS e c) [] catchall) =
+ fmap (\ lhs -> Clause (LHS i lhs wps) dots (RHS e c) [] catchall) <$> lhsToPath [] lhs
+clauseToPath (Clause lhs _ (RHS e _) (_:_) _) = typeError $ NotImplemented $ "copattern clauses with where declarations"
+clauseToPath (Clause lhs _ _ wheredecls _) = typeError $ NotImplemented $ "copattern clauses with absurd, with or rewrite right hand side"
lhsToPath :: [ProjEntry] -> LHSCore -> ScopeM (ProjPath LHSCore)
lhsToPath acc lhs@LHSHead{} = return $ Path acc lhs
-lhsToPath acc (LHSProj f [] lhs ps) | Just xs <- mapM (T.mapM (T.mapM fromVarP)) ps =
+lhsToPath acc (LHSProj f lhs ps) = do
+ let xs = fromMaybe __IMPOSSIBLE__ $ mapM (T.mapM (T.mapM fromVarP)) ps
lhsToPath (ProjEntry f xs : acc) $ namedArg lhs
where fromVarP :: Pattern -> Maybe Name
fromVarP (VarP n) = Just n
fromVarP _ = Nothing
-lhsToPath acc (LHSProj f _ lhs _) = typeError $ NotImplemented $
- "copatterns with patterns before the principal argument"
-- | Expects a sorted list.
pathToRecord :: [ProjPath Expr] -> ScopeM Expr
@@ -220,7 +208,8 @@ pathToRecord pps =
where
abstractions :: (ProjEntry, Expr) -> ScopeM RecordAssign
- abstractions (ProjEntry p xs, e) = Left . FieldAssignment (C.unqualify $ qnameToConcrete p) <$>
+ abstractions (ProjEntry (AmbQ []) xs, e) = __IMPOSSIBLE__
+ abstractions (ProjEntry (AmbQ (p:_)) xs, e) = Left . FieldAssignment (C.unqualify $ qnameToConcrete p) <$>
foldr abstract (return e) xs
abstract :: NamedArg Name -> ScopeM Expr -> ScopeM Expr
@@ -267,18 +256,19 @@ instance Rename QName where
rename _ q = q
instance Rename Name where
- rename rho x = maybe x id (rho x)
+ rename rho x = fromMaybe x (rho x)
instance Rename Expr where
rename rho e =
case e of
Var x -> Var (rename rho x)
Def f -> e
- Proj f -> e
+ Proj{} -> e
Con c -> e
Lit l -> e
QuestionMark{} -> e
Underscore i -> e
+ Dot i e -> Dot i (rename rho e)
App i e es -> App i (rename rho e) (rename rho es)
WithApp i e es -> WithApp i (rename rho e) (rename rho es)
Lam i lb e -> Lam i (rename rho lb) (rename rho e)
@@ -332,12 +322,15 @@ instance Rename TypedBinding where
rename rho (TLet r lbs) = TLet r (rename rho lbs)
instance Rename Clause where
- rename rho (Clause lhs rhs wheredecls catchall) =
- Clause (rename rho lhs) (rename rho rhs) (rename rho wheredecls) catchall
+ rename rho (Clause lhs dots rhs wheredecls catchall) =
+ Clause (rename rho lhs) (rename rho dots) (rename rho rhs) (rename rho wheredecls) catchall
+
+instance Rename NamedDotPattern where
+ rename rho (NamedDot x v t) = NamedDot (rename rho x) v t
instance Rename RHS where
rename rho e = case e of
- RHS e -> RHS (rename rho e)
+ RHS e c -> RHS (rename rho e) c
AbsurdRHS -> e
WithRHS n es cs -> WithRHS n (rename rho es) (rename rho cs)
RewriteRHS nes r ds -> RewriteRHS (rename rho nes) (rename rho r) (rename rho ds)
@@ -389,7 +382,7 @@ instance Alpha (Pattern' e) where
((DefP _ x ps) , (DefP _ x' ps') ) -> guard (x == x') >> alpha' ps ps'
((WildP _) , (WildP _) ) -> return ()
((AsP _ x p) , (AsP _ x' p') ) -> tell1 (x, x') >> alpha' p p'
- ((DotP _ _) , (DotP _ _) ) -> return ()
+ ((DotP _ _ _) , (DotP _ _ _) ) -> return ()
(AbsurdP{} , AbsurdP{} ) -> return ()
((LitP l) , (LitP l') ) -> guard (l == l')
((PatternSynP _ x ps) , (PatternSynP _ x' ps')) -> guard (x == x') >> alpha' ps ps'
@@ -400,8 +393,8 @@ tell1 a = tell [a]
instance Alpha (LHSCore' e) where
alpha' (LHSHead f ps) (LHSHead f' ps') = guard (f == f') >> alpha' ps ps'
- alpha' (LHSProj d ps1 lhs ps2) (LHSProj d' ps1' lhs' ps2') =
- guard (d == d') >> alpha' ps1 ps1' >> alpha' lhs lhs' >> alpha' ps2 ps2'
+ alpha' (LHSProj d lhs ps) (LHSProj d' lhs' ps') =
+ guard (d == d') >> alpha' lhs lhs' >> alpha' ps ps'
alpha' _ _ = fail "not alpha equivalent"
instance Alpha LHS where
diff --git a/src/full/Agda/Syntax/Abstract/Name.hs b/src/full/Agda/Syntax/Abstract/Name.hs
index 95259bc..2e51e46 100644
--- a/src/full/Agda/Syntax/Abstract/Name.hs
+++ b/src/full/Agda/Syntax/Abstract/Name.hs
@@ -1,12 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-| Abstract names carry unique identifiers and stuff.
-}
@@ -24,8 +18,6 @@ import Data.List
import Data.Function
import Data.Hashable
-import Test.QuickCheck
-
import Agda.Syntax.Position
import Agda.Syntax.Common
import {-# SOURCE #-} Agda.Syntax.Fixity
@@ -33,6 +25,7 @@ import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..))
import qualified Agda.Syntax.Concrete.Name as C
import Agda.Utils.List
+import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Pretty
import Agda.Utils.Size
@@ -81,7 +74,17 @@ newtype ModuleName = MName { mnameToList :: [Name] }
-- Invariant: All the names in the list must have the same concrete,
-- unqualified name. (This implies that they all have the same 'Range').
newtype AmbiguousQName = AmbQ { unAmbQ :: [QName] }
- deriving (Eq, Typeable)
+ deriving (Eq, Ord, Typeable)
+
+-- | Check whether we are a projection pattern.
+class IsProjP a where
+ isProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)
+
+instance IsProjP a => IsProjP (Arg a) where
+ isProjP = isProjP . unArg
+
+instance IsProjP a => IsProjP (Named n a) where
+ isProjP = isProjP . namedThing
-- | A module is anonymous if the qualification path ends in an underscore.
isAnonymousModuleName :: ModuleName -> Bool
@@ -262,6 +265,10 @@ instance NumHoles Name where
instance NumHoles QName where
numHoles = numHoles . qnameName
+-- | We can have an instance for ambiguous names as all share a common concrete name.
+instance NumHoles AmbiguousQName where
+ numHoles (AmbQ qs) = numHoles $ fromMaybe __IMPOSSIBLE__ $ headMaybe qs
+
------------------------------------------------------------------------
-- * Show instances
------------------------------------------------------------------------
@@ -382,29 +389,6 @@ instance Sized ModuleName where
size = size . mnameToList
------------------------------------------------------------------------
--- * Arbitrary instances
-------------------------------------------------------------------------
-
--- | The generated names all have the same 'Fixity'': 'noFixity''.
-
-instance Arbitrary Name where
- arbitrary =
- Name <$> arbitrary <*> arbitrary <*> arbitrary
- <*> return noFixity'
-
-instance CoArbitrary Name where
- coarbitrary = coarbitrary . nameId
-
-instance Arbitrary QName where
- arbitrary = do
- ms <- arbitrary
- n <- arbitrary
- return (QName (MName ms) n)
-
-instance CoArbitrary QName where
- coarbitrary = coarbitrary . qnameName
-
-------------------------------------------------------------------------
-- * NFData instances
------------------------------------------------------------------------
diff --git a/src/full/Agda/Syntax/Abstract/Pretty.hs b/src/full/Agda/Syntax/Abstract/Pretty.hs
index cedacae..dbd813e 100644
--- a/src/full/Agda/Syntax/Abstract/Pretty.hs
+++ b/src/full/Agda/Syntax/Abstract/Pretty.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
module Agda.Syntax.Abstract.Pretty where
diff --git a/src/full/Agda/Syntax/Abstract/Views.hs b/src/full/Agda/Syntax/Abstract/Views.hs
index ef0957e..961aae8 100644
--- a/src/full/Agda/Syntax/Abstract/Views.hs
+++ b/src/full/Agda/Syntax/Abstract/Views.hs
@@ -1,14 +1,7 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ <= 706
-{-# LANGUAGE FlexibleContexts #-}
-#endif
module Agda.Syntax.Abstract.Views where
@@ -39,11 +32,23 @@ data AppView = Application Expr [NamedArg Expr]
appView :: Expr -> AppView
appView e =
case e of
- App i e1 arg | Application hd es <- appView e1
+ App _ e1 e2
+ | Dot _ e2' <- unScope $ namedArg e2
+ , Just f <- maybeProjTurnPostfix e2'
+ -> Application f [defaultNamedArg e1]
+ App i e1 arg
+ | Application hd es <- appView e1
-> Application hd $ es ++ [arg]
ScopedExpr _ e -> appView e
_ -> Application e []
+maybeProjTurnPostfix :: Expr -> Maybe Expr
+maybeProjTurnPostfix e =
+ case e of
+ ScopedExpr i e' -> ScopedExpr i <$> maybeProjTurnPostfix e'
+ Proj _ x -> return $ Proj ProjPostfix x
+ _ -> Nothing
+
unAppView :: AppView -> Expr
unAppView (Application h es) =
foldl (App (ExprRange noRange)) h es
@@ -122,6 +127,7 @@ instance ExprLike Expr where
Lit{} -> pure e0
QuestionMark{} -> pure e0
Underscore{} -> pure e0
+ Dot ei e -> Dot ei <$> recurse e
App ei e arg -> App ei <$> recurse e <*> recurse arg
WithApp ei e es -> WithApp ei <$> recurse e <*> recurse es
Lam ei b e -> Lam ei <$> recurse b <*> recurse e
@@ -157,6 +163,7 @@ instance ExprLike Expr where
Lit{} -> m
QuestionMark{} -> m
Underscore{} -> m
+ Dot _ e -> m `mappend` fold e
App _ e e' -> m `mappend` fold e `mappend` fold e'
WithApp _ e es -> m `mappend` fold e `mappend` fold es
Lam _ b e -> m `mappend` fold b `mappend` fold e
@@ -192,6 +199,7 @@ instance ExprLike Expr where
Lit{} -> f e
QuestionMark{} -> f e
Underscore{} -> f e
+ Dot ei e -> f =<< Dot ei <$> trav e
App ei e arg -> f =<< App ei <$> trav e <*> trav arg
WithApp ei e es -> f =<< WithApp ei <$> trav e <*> trav es
Lam ei b e -> f =<< Lam ei <$> trav b <*> trav e
@@ -303,13 +311,13 @@ instance ExprLike LetBinding where
instance ExprLike a => ExprLike (Pattern' a) where
instance ExprLike a => ExprLike (Clause' a) where
- recurseExpr f (Clause lhs rhs ds ca) = Clause <$> rec lhs <*> rec rhs <*> rec ds <*> pure ca
+ recurseExpr f (Clause lhs dots rhs ds ca) = Clause <$> rec lhs <*> pure dots <*> rec rhs <*> rec ds <*> pure ca
where rec = recurseExpr f
instance ExprLike RHS where
recurseExpr f rhs =
case rhs of
- RHS e -> RHS <$> rec e
+ RHS e c -> RHS <$> rec e <*> pure c
AbsurdRHS{} -> pure rhs
WithRHS x es cs -> WithRHS x <$> rec es <*> rec cs
RewriteRHS xes rhs ds -> RewriteRHS <$> rec xes <*> rec rhs <*> rec ds
@@ -338,7 +346,6 @@ instance ExprLike Pragma where
CompiledJSPragma{} -> pure p
CompiledUHCPragma{} -> pure p
CompiledDataUHCPragma{} -> pure p
- NoSmashingPragma{} -> pure p
StaticPragma{} -> pure p
InlinePragma{} -> pure p
DisplayPragma f xs e -> DisplayPragma f <$> rec xs <*> rec e
@@ -355,12 +362,12 @@ instance ExprLike SpineLHS where
instance ExprLike Declaration where
recurseExpr f d =
case d of
- Axiom a d i x e -> Axiom a d i x <$> rec e
+ Axiom a d i mp x e -> Axiom a d i mp x <$> rec e
Field i x e -> Field i x <$> rec e
Primitive i x e -> Primitive i x <$> rec e
Mutual i ds -> Mutual i <$> rec ds
Section i m tel ds -> Section i m <$> rec tel <*> rec ds
- Apply i m a rd rm d -> (\ a -> Apply i m a rd rm d) <$> rec a
+ Apply i m a ci d -> (\ a -> Apply i m a ci d) <$> rec a
Import{} -> pure d
Pragma i p -> Pragma i <$> rec p
Open{} -> pure d
diff --git a/src/full/Agda/Syntax/Common.hs b/src/full/Agda/Syntax/Common.hs
index f1ac5d7..2ed6406 100644
--- a/src/full/Agda/Syntax/Common.hs
+++ b/src/full/Agda/Syntax/Common.hs
@@ -1,10 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| Some common syntactic entities are defined in this module.
@@ -19,18 +15,17 @@ import qualified Data.ByteString.Char8 as ByteString
import Data.Foldable
import Data.Hashable
import qualified Data.Strict.Maybe as Strict
-import Data.Monoid
+import Data.Semigroup hiding (Arg)
import Data.Traversable
import Data.Typeable (Typeable)
+import Data.Word
import GHC.Generics (Generic)
-import Test.QuickCheck hiding (Small)
-
import Agda.Syntax.Position
import Agda.Utils.Functor
-import Agda.Utils.Pretty
+import Agda.Utils.Pretty hiding ((<>))
#include "undefined.h"
import Agda.Utils.Impossible
@@ -63,13 +58,6 @@ instance HasRange Induction where
instance KillRange Induction where
killRange = id
-instance Arbitrary Induction where
- arbitrary = elements [Inductive, CoInductive]
-
-instance CoArbitrary Induction where
- coarbitrary Inductive = variant 0
- coarbitrary CoInductive = variant 1
-
instance NFData Induction where
rnf Inductive = ()
rnf CoInductive = ()
@@ -83,13 +71,16 @@ data Hiding = Hidden | Instance | NotHidden
-- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'.
-- 'Instance' and 'NotHidden' are incompatible.
+instance Semigroup Hiding where
+ NotHidden <> h = h
+ h <> NotHidden = h
+ Hidden <> Hidden = Hidden
+ Instance <> Instance = Instance
+ _ <> _ = __IMPOSSIBLE__
+
instance Monoid Hiding where
mempty = NotHidden
- mappend NotHidden h = h
- mappend h NotHidden = h
- mappend Hidden Hidden = Hidden
- mappend Instance Instance = Instance
- mappend _ _ = __IMPOSSIBLE__
+ mappend = (<>)
instance KillRange Hiding where
killRange = id
@@ -148,10 +139,6 @@ instance LensHiding (WithHiding a) where
mergeHiding :: LensHiding a => WithHiding a -> a
mergeHiding (WithHiding h a) = mapHiding (mappend h) a
--- | @isHidden@ does not apply to 'Instance', only to 'Hidden'.
-isHidden :: LensHiding a => a -> Bool
-isHidden a = getHiding a == Hidden
-
-- | Visible ('NotHidden') arguments are @notHidden@. (DEPRECATED, use 'visible'.)
notHidden :: LensHiding a => a -> Bool
notHidden a = getHiding a == NotHidden
@@ -232,9 +219,6 @@ allRelevances =
instance KillRange Relevance where
killRange rel = rel -- no range to kill
-instance Arbitrary Relevance where
- arbitrary = elements allRelevances
-
instance Ord Relevance where
(<=) = moreRelevant
@@ -350,26 +334,63 @@ ignoreForced Irrelevant = Irrelevant
-- | Irrelevant function arguments may appear non-strictly in the codomain type.
irrToNonStrict :: Relevance -> Relevance
irrToNonStrict Irrelevant = NonStrict
--- irrToNonStrict NonStrict = Relevant -- TODO: is that what we want (OR: NonStrict) -- better be more conservative
+-- irrToNonStrict NonStrict = Relevant -- TODO: this is bad if we apply irrToNonStrict several times!
irrToNonStrict rel = rel
+-- | Applied when working on types (unless --experimental-irrelevance).
+nonStrictToRel :: Relevance -> Relevance
+nonStrictToRel NonStrict = Relevant
+nonStrictToRel rel = rel
+
nonStrictToIrr :: Relevance -> Relevance
nonStrictToIrr NonStrict = Irrelevant
nonStrictToIrr rel = rel
---------------------------------------------------------------------------
+-- * Origin of arguments (user-written, inserted or reflected)
+---------------------------------------------------------------------------
+
+data Origin = UserWritten | Inserted | Reflected
+ deriving (Typeable, Show, Eq, Ord)
+
+instance KillRange Origin where
+ killRange = id
+
+instance NFData Origin where
+ rnf UserWritten = ()
+ rnf Inserted = ()
+ rnf Reflected = ()
+
+class LensOrigin a where
+
+ getOrigin :: a -> Origin
+
+ setOrigin :: Origin -> a -> a
+ setOrigin o = mapOrigin (const o)
+
+ mapOrigin :: (Origin -> Origin) -> a -> a
+ mapOrigin f a = setOrigin (f $ getOrigin a) a
+
+instance LensOrigin Origin where
+ getOrigin = id
+ setOrigin = const
+ mapOrigin = id
+
+---------------------------------------------------------------------------
-- * Argument decoration
---------------------------------------------------------------------------
-- | A function argument can be hidden and/or irrelevant.
data ArgInfo = ArgInfo
- { argInfoHiding :: Hiding
- , argInfoRelevance :: Relevance
+ { argInfoHiding :: Hiding
+ , argInfoRelevance :: Relevance
+ , argInfoOrigin :: Origin
+ , argInfoOverlappable :: Bool
} deriving (Typeable, Eq, Ord, Show)
instance KillRange ArgInfo where
- killRange (ArgInfo h r) = killRange2 ArgInfo h r
+ killRange (ArgInfo h r o v) = killRange3 ArgInfo h r o v
class LensArgInfo a where
getArgInfo :: a -> ArgInfo
@@ -384,7 +405,7 @@ instance LensArgInfo ArgInfo where
mapArgInfo = id
instance NFData ArgInfo where
- rnf (ArgInfo a b) = rnf a `seq` rnf b
+ rnf (ArgInfo a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
instance LensHiding ArgInfo where
getHiding = argInfoHiding
@@ -396,9 +417,16 @@ instance LensRelevance ArgInfo where
setRelevance h ai = ai { argInfoRelevance = h }
mapRelevance f ai = ai { argInfoRelevance = f (argInfoRelevance ai) }
+instance LensOrigin ArgInfo where
+ getOrigin = argInfoOrigin
+ setOrigin o ai = ai { argInfoOrigin = o }
+ mapOrigin f ai = ai { argInfoOrigin = f (argInfoOrigin ai) }
+
defaultArgInfo :: ArgInfo
-defaultArgInfo = ArgInfo { argInfoHiding = NotHidden
- , argInfoRelevance = Relevant }
+defaultArgInfo = ArgInfo { argInfoHiding = NotHidden
+ , argInfoRelevance = Relevant
+ , argInfoOrigin = UserWritten
+ , argInfoOverlappable = False }
---------------------------------------------------------------------------
@@ -423,14 +451,14 @@ instance KillRange a => KillRange (Arg a) where
killRange (Arg info a) = killRange2 Arg info a
instance Eq a => Eq (Arg a) where
- Arg (ArgInfo h1 _) x1 == Arg (ArgInfo h2 _) x2 = (h1, x1) == (h2, x2)
+ Arg (ArgInfo h1 _ _ _) x1 == Arg (ArgInfo h2 _ _ _) x2 = (h1, x1) == (h2, x2)
instance Show a => Show (Arg a) where
- show (Arg (ArgInfo h r) x) = showR r $ showH h $ show x
+ show (Arg (ArgInfo h r o v) x) = showR r $ showO o $ showH h $ show x
where
showH Hidden s = "{" ++ s ++ "}"
showH NotHidden s = "(" ++ s ++ ")"
- showH Instance s = "{{" ++ s ++ "}}"
+ showH Instance s = (if v then "overlap " else "") ++ "{{" ++ s ++ "}}"
showR r s = case r of
Irrelevant -> "." ++ s
NonStrict -> "?" ++ s
@@ -438,6 +466,10 @@ instance Show a => Show (Arg a) where
Forced Small -> "!" ++ s
UnusedArg -> "k" ++ s -- constant
Relevant -> "r" ++ s -- Andreas: I want to see it explicitly
+ showO o s = case o of
+ UserWritten -> "u" ++ s
+ Inserted -> "i" ++ s
+ Reflected -> "g" ++ s -- generated by reflection
instance NFData e => NFData (Arg e) where
rnf (Arg a b) = rnf a `seq` rnf b
@@ -450,16 +482,9 @@ instance LensRelevance (Arg e) where
getRelevance = getRelevance . argInfo
mapRelevance = mapArgInfo . mapRelevance
-{- RETIRED
-hide :: Arg a -> Arg a
-hide = setArgHiding Hidden
-
-makeInstance :: Arg a -> Arg a
-makeInstance = setHiding Instance
-
-isHiddenArg :: Arg a -> Bool
-isHiddenArg arg = argHiding arg /= NotHidden
--}
+instance LensOrigin (Arg e) where
+ getOrigin = getOrigin . argInfo
+ mapOrigin = mapArgInfo . mapOrigin
instance LensArgInfo (Arg a) where
getArgInfo = argInfo
@@ -514,7 +539,7 @@ instance Underscore Doc where
data Dom e = Dom
{ domInfo :: ArgInfo
, unDom :: e
- } deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable)
+ } deriving (Typeable, Ord, Functor, Foldable, Traversable)
instance Decoration Dom where
traverseF f (Dom ai a) = Dom ai <$> f a
@@ -525,6 +550,10 @@ instance HasRange a => HasRange (Dom a) where
instance KillRange a => KillRange (Dom a) where
killRange (Dom info a) = killRange2 Dom info a
+instance Eq a => Eq (Dom a) where
+ Dom (ArgInfo h1 r1 _ _) x1 == Dom (ArgInfo h2 r2 _ _) x2 =
+ (h1, ignoreForced r1, x1) == (h2, ignoreForced r2, x2)
+
instance Show a => Show (Dom a) where
show = show . argFromDom
@@ -658,16 +687,34 @@ stringToRawName = id
type RString = Ranged RawName
---------------------------------------------------------------------------
--- * Constructor pattern info
+-- * Further constructor and projection info
---------------------------------------------------------------------------
--- | Where does the 'ConP' of come from?
-data ConPOrigin
- = ConPImplicit -- ^ Expanded from an implicit pattern.
- | ConPCon -- ^ User wrote a constructor pattern.
- | ConPRec -- ^ User wrote a record pattern.
+-- | Where does the 'ConP' or 'Con' come from?
+data ConOrigin
+ = ConOSystem -- ^ Inserted by system or expanded from an implicit pattern.
+ | ConOCon -- ^ User wrote a constructor (pattern).
+ | ConORec -- ^ User wrote a record (pattern).
+ deriving (Typeable, Show, Eq, Ord, Enum, Bounded)
+
+instance KillRange ConOrigin where
+ killRange = id
+
+-- | Prefer user-written over system-inserted.
+bestConInfo :: ConOrigin -> ConOrigin -> ConOrigin
+bestConInfo ConOSystem o = o
+bestConInfo o _ = o
+
+-- | Where does a projection come from?
+data ProjOrigin
+ = ProjPrefix -- ^ User wrote a prefix projection.
+ | ProjPostfix -- ^ User wrote a postfix projection.
+ | ProjSystem -- ^ Projection was generated by the system.
deriving (Typeable, Show, Eq, Ord, Enum, Bounded)
+instance KillRange ProjOrigin where
+ killRange = id
+
---------------------------------------------------------------------------
-- * Infixity, access, abstract, etc.
---------------------------------------------------------------------------
@@ -678,11 +725,24 @@ data IsInfix = InfixDef | PrefixDef
deriving (Typeable, Show, Eq, Ord)
-- | Access modifier.
-data Access = PrivateAccess | PublicAccess
- | OnlyQualified -- ^ Visible from outside, but not exported when opening the module
+data Access
+ = PrivateAccess Origin
+ -- ^ Store the 'Origin' of the private block that lead to this qualifier.
+ -- This is needed for more faithful printing of declarations.
+ | PublicAccess
+ | OnlyQualified -- ^ Visible from outside, but not exported when opening the module
-- Used for qualified constructors.
deriving (Typeable, Show, Eq, Ord)
+instance NFData Access where
+ rnf _ = ()
+
+instance HasRange Access where
+ getRange _ = noRange
+
+instance KillRange Access where
+ killRange = id
+
-- | Abstract or concrete
data IsAbstract = AbstractDef | ConcreteDef
deriving (Typeable, Show, Eq, Ord)
@@ -720,7 +780,7 @@ type Arity = Nat
-- | The unique identifier of a name. Second argument is the top-level module
-- identifier.
-data NameId = NameId !Integer !Integer
+data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
deriving (Eq, Ord, Typeable, Generic)
instance KillRange NameId where
@@ -742,11 +802,6 @@ instance Hashable NameId where
{-# INLINE hashWithSalt #-}
hashWithSalt salt (NameId n m) = hashWithSalt salt (n, m)
-instance Arbitrary NameId where
- arbitrary = elements [ NameId x y | x <- [-1, 1], y <- [-1, 1] ]
-
-instance CoArbitrary NameId
-
---------------------------------------------------------------------------
-- * Meta variables
---------------------------------------------------------------------------
@@ -843,11 +898,14 @@ data ImportDirective' a b = ImportDirective
data Using' a b = UseEverything | Using [ImportedName' a b]
deriving (Typeable, Eq)
+instance Semigroup (Using' a b) where
+ UseEverything <> u = u
+ u <> UseEverything = u
+ Using xs <> Using ys = Using (xs ++ ys)
+
instance Monoid (Using' a b) where
mempty = UseEverything
- mappend UseEverything u = u
- mappend u UseEverything = u
- mappend (Using xs) (Using ys) = Using (xs ++ ys)
+ mappend = (<>)
-- | Default is directive is @private@ (use everything, but do not export).
defaultImportDir :: ImportDirective' a b
diff --git a/src/full/Agda/Syntax/Concrete.hs b/src/full/Agda/Syntax/Concrete.hs
index 201fcc3..dacb521 100644
--- a/src/full/Agda/Syntax/Concrete.hs
+++ b/src/full/Agda/Syntax/Concrete.hs
@@ -1,9 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-| The concrete syntax is a raw representation of the program text
without any desugaring at all. This is what the parser produces.
@@ -72,6 +68,8 @@ import Agda.Syntax.Literal
import Agda.Syntax.Concrete.Name
import qualified Agda.Syntax.Abstract.Name as A
+import Agda.TypeChecking.Positivity.Occurrence
+
import Agda.Utils.Lens
import Agda.Utils.Null
@@ -150,6 +148,7 @@ data Expr
| RecUpdate Range Expr [FieldAssignment] -- ^ ex: @record e {x = a; y = b}@
| Let Range [Declaration] Expr -- ^ ex: @let Ds in e@
| Paren Range Expr -- ^ ex: @(e)@
+ | IdiomBrackets Range Expr -- ^ ex: @(| e |)@
| Absurd Range -- ^ ex: @()@ or @{}@, only in patterns
| As Range Name Expr -- ^ ex: @x\@p@, only in patterns
| Dot Range Expr -- ^ ex: @.p@, only in patterns
@@ -182,7 +181,7 @@ data Pattern
| WildP Range -- ^ @_@
| AbsurdP Range -- ^ @()@
| AsP Range Name Pattern -- ^ @x\@p@ unused
- | DotP Range Expr -- ^ @.e@
+ | DotP Range Origin Expr -- ^ @.e@
| LitP Literal -- ^ @0@, @1@, etc.
| RecP Range [FieldAssignment' Pattern] -- ^ @record {x = p; y = q}@
deriving (Typeable)
@@ -285,7 +284,10 @@ type WhereClause = WhereClause' [Declaration]
data WhereClause' decls
= NoWhere -- ^ No @where@ clauses.
| AnyWhere decls -- ^ Ordinary @where@.
- | SomeWhere Name decls -- ^ Named where: @module M where@.
+ | SomeWhere Name Access decls
+ -- ^ Named where: @module M where@.
+ -- The 'Access' flag applies to the 'Name' (not the module contents!)
+ -- and is propagated from the parent function.
deriving (Typeable, Functor, Foldable, Traversable)
-- | An expression followed by a where clause.
@@ -338,7 +340,10 @@ data Declaration
| PatternSyn Range Name [Arg Name] Pattern
| Mutual Range [Declaration]
| Abstract Range [Declaration]
- | Private Range [Declaration]
+ | Private Range Origin [Declaration]
+ -- ^ In "Agda.Syntax.Concrete.Definitions" we generate private blocks
+ -- temporarily, which should be treated different that user-declared
+ -- private blocks. Thus the 'Origin'.
| InstanceB Range [Declaration]
| Macro Range [Declaration]
| Postulate Range [TypeSignatureOrInstanceBlock]
@@ -367,7 +372,7 @@ data OpenShortHand = DoOpen | DontOpen
data Pragma
= OptionsPragma Range [String]
| BuiltinPragma Range String Expr
- | RewritePragma Range QName
+ | RewritePragma Range [QName]
| CompiledDataPragma Range QName String [String]
| CompiledDeclareDataPragma Range QName String
| CompiledTypePragma Range QName String
@@ -378,7 +383,6 @@ data Pragma
| CompiledUHCPragma Range QName String
| CompiledDataUHCPragma Range QName String [String]
| HaskellCodePragma Range String
- | NoSmashingPragma Range QName
| StaticPragma Range QName
| InlinePragma Range QName
| ImportPragma Range String
@@ -390,6 +394,7 @@ data Pragma
| CatchallPragma Range
| DisplayPragma Range Pattern Expr
| NoPositivityCheckPragma Range
+ | PolarityPragma Range Name [Occurrence]
deriving (Typeable)
---------------------------------------------------------------------------
@@ -419,7 +424,7 @@ spanAllowedBeforeModule :: [Declaration] -> ([Declaration], [Declaration])
spanAllowedBeforeModule = span isAllowedBeforeModule
where
isAllowedBeforeModule (Pragma OptionsPragma{}) = True
- isAllowedBeforeModule (Private _ ds) = all isAllowedBeforeModule ds
+ isAllowedBeforeModule (Private _ _ ds) = all isAllowedBeforeModule ds
isAllowedBeforeModule Import{} = True
isAllowedBeforeModule ModuleMacro{} = True
isAllowedBeforeModule Open{} = True
@@ -442,15 +447,17 @@ mapLhsOriginalPattern f lhs@LHS{ lhsOriginalPattern = p } =
data AppView = AppView Expr [NamedArg Expr]
appView :: Expr -> AppView
-appView (App r e1 e2) = vApp (appView e1) e2
+appView e =
+ case e of
+ App r e1 e2 -> vApp (appView e1) e2
+ RawApp _ (e:es) -> AppView e $ map arg es
+ _ -> AppView e []
where
vApp (AppView e es) arg = AppView e (es ++ [arg])
-appView (RawApp _ (e:es)) = AppView e $ map arg es
- where
+
arg (HiddenArg _ e) = setHiding Hidden $ defaultArg e
arg (InstanceArg _ e) = setHiding Instance $ defaultArg e
arg e = defaultArg (unnamed e)
-appView e = AppView e []
{--------------------------------------------------------------------------
Patterns
@@ -541,6 +548,7 @@ instance HasRange Expr where
SetN r _ -> r
Let r _ _ -> r
Paren r _ -> r
+ IdiomBrackets r _ -> r
As r _ _ -> r
Dot r _ -> r
Absurd r -> r
@@ -579,7 +587,7 @@ instance HasRange BoundName where
instance HasRange WhereClause where
getRange NoWhere = noRange
getRange (AnyWhere ds) = getRange ds
- getRange (SomeWhere _ ds) = getRange ds
+ getRange (SomeWhere _ _ ds) = getRange ds
instance HasRange ModuleApplication where
getRange (SectionApp r _ _) = r
@@ -606,7 +614,7 @@ instance HasRange Declaration where
getRange (Import r _ _ _ _) = r
getRange (InstanceB r _) = r
getRange (Macro r _) = r
- getRange (Private r _) = r
+ getRange (Private r _ _) = r
getRange (Postulate r _) = r
getRange (Primitive r _) = r
getRange (Module r _ _ _) = r
@@ -643,7 +651,6 @@ instance HasRange Pragma where
getRange (CompiledUHCPragma r _ _) = r
getRange (CompiledDataUHCPragma r _ _ _) = r
getRange (HaskellCodePragma r _) = r
- getRange (NoSmashingPragma r _) = r
getRange (StaticPragma r _) = r
getRange (InlinePragma r _) = r
getRange (ImportPragma r _) = r
@@ -653,6 +660,7 @@ instance HasRange Pragma where
getRange (CatchallPragma r) = r
getRange (DisplayPragma r _ _) = r
getRange (NoPositivityCheckPragma r) = r
+ getRange (PolarityPragma r _ _) = r
instance HasRange AsName where
getRange a = getRange (asRange a, asName a)
@@ -670,7 +678,7 @@ instance HasRange Pattern where
getRange (QuoteP r) = r
getRange (HiddenP r _) = r
getRange (InstanceP r _) = r
- getRange (DotP r _) = r
+ getRange (DotP r _ _) = r
getRange (RecP r _) = r
-- SetRange instances
@@ -692,7 +700,7 @@ instance SetRange Pattern where
setRange r (QuoteP _) = QuoteP r
setRange r (HiddenP _ p) = HiddenP r p
setRange r (InstanceP _ p) = InstanceP r p
- setRange r (DotP _ e) = DotP r e
+ setRange r (DotP _ o e) = DotP r o e
setRange r (RecP _ fs) = RecP r fs
-- KillRange instances
@@ -723,7 +731,7 @@ instance KillRange Declaration where
killRange (PatternSyn _ n ns p) = killRange3 (PatternSyn noRange) n ns p
killRange (Mutual _ d) = killRange1 (Mutual noRange) d
killRange (Abstract _ d) = killRange1 (Abstract noRange) d
- killRange (Private _ d) = killRange1 (Private noRange) d
+ killRange (Private _ o d) = killRange2 (Private noRange) o d
killRange (InstanceB _ d) = killRange1 (InstanceB noRange) d
killRange (Macro _ d) = killRange1 (Macro noRange) d
killRange (Postulate _ t) = killRange1 (Postulate noRange) t
@@ -759,6 +767,7 @@ instance KillRange Expr where
killRange (RecUpdate _ e ne) = killRange2 (RecUpdate noRange) e ne
killRange (Let _ d e) = killRange2 (Let noRange) d e
killRange (Paren _ e) = killRange1 (Paren noRange) e
+ killRange (IdiomBrackets _ e) = killRange1 (IdiomBrackets noRange) e
killRange (Absurd _) = Absurd noRange
killRange (As _ n e) = killRange2 (As noRange) n e
killRange (Dot _ e) = killRange1 (Dot noRange) e
@@ -799,7 +808,7 @@ instance KillRange Pattern where
killRange (WildP _) = WildP noRange
killRange (AbsurdP _) = AbsurdP noRange
killRange (AsP _ n p) = killRange2 (AsP noRange) n p
- killRange (DotP _ e) = killRange1 (DotP noRange) e
+ killRange (DotP _ o e) = killRange1 (DotP noRange) o e
killRange (LitP l) = killRange1 LitP l
killRange (QuoteP _) = QuoteP noRange
killRange (RecP _ fs) = killRange1 (RecP noRange) fs
@@ -807,7 +816,7 @@ instance KillRange Pattern where
instance KillRange Pragma where
killRange (OptionsPragma _ s) = OptionsPragma noRange s
killRange (BuiltinPragma _ s e) = killRange1 (BuiltinPragma noRange s) e
- killRange (RewritePragma _ q) = killRange1 (RewritePragma noRange) q
+ killRange (RewritePragma _ qs) = killRange1 (RewritePragma noRange) qs
killRange (CompiledDataPragma _ q s ss) = killRange1 (\q -> CompiledDataPragma noRange q s ss) q
killRange (CompiledDeclareDataPragma _ q s) = killRange1 (\q -> CompiledDeclareDataPragma noRange q s) q
killRange (CompiledTypePragma _ q s) = killRange1 (\q -> CompiledTypePragma noRange q s) q
@@ -818,7 +827,6 @@ instance KillRange Pragma where
killRange (CompiledUHCPragma _ q s) = killRange1 (\q -> CompiledUHCPragma noRange q s) q
killRange (CompiledDataUHCPragma _ q s ss) = killRange1 (\q -> CompiledDataUHCPragma noRange q s ss) q
killRange (HaskellCodePragma _ s) = HaskellCodePragma noRange s
- killRange (NoSmashingPragma _ q) = killRange1 (NoSmashingPragma noRange) q
killRange (StaticPragma _ q) = killRange1 (StaticPragma noRange) q
killRange (InlinePragma _ q) = killRange1 (InlinePragma noRange) q
killRange (ImportPragma _ s) = ImportPragma noRange s
@@ -828,6 +836,7 @@ instance KillRange Pragma where
killRange (CatchallPragma _) = CatchallPragma noRange
killRange (DisplayPragma _ lhs rhs) = killRange2 (DisplayPragma noRange) lhs rhs
killRange (NoPositivityCheckPragma _) = NoPositivityCheckPragma noRange
+ killRange (PolarityPragma _ q occs) = killRange1 (\q -> PolarityPragma noRange q occs) q
instance KillRange RHS where
killRange AbsurdRHS = AbsurdRHS
@@ -843,7 +852,7 @@ instance KillRange TypedBindings where
instance KillRange WhereClause where
killRange NoWhere = NoWhere
killRange (AnyWhere d) = killRange1 AnyWhere d
- killRange (SomeWhere n d) = killRange2 SomeWhere n d
+ killRange (SomeWhere n a d) = killRange3 SomeWhere n a d
------------------------------------------------------------------------
-- NFData instances
@@ -873,6 +882,7 @@ instance NFData Expr where
rnf (RecUpdate _ a b) = rnf a `seq` rnf b
rnf (Let _ a b) = rnf a `seq` rnf b
rnf (Paren _ a) = rnf a
+ rnf (IdiomBrackets _ a)= rnf a
rnf (Absurd _) = ()
rnf (As _ a b) = rnf a `seq` rnf b
rnf (Dot _ a) = rnf a
@@ -900,7 +910,7 @@ instance NFData Pattern where
rnf (WildP _) = ()
rnf (AbsurdP _) = ()
rnf (AsP _ a b) = rnf a `seq` rnf b
- rnf (DotP _ a) = rnf a
+ rnf (DotP _ a b) = rnf a `seq` rnf b
rnf (LitP a) = rnf a
rnf (RecP _ a) = rnf a
@@ -919,7 +929,7 @@ instance NFData Declaration where
rnf (PatternSyn _ a b c) = rnf a `seq` rnf b `seq` rnf c
rnf (Mutual _ a) = rnf a
rnf (Abstract _ a) = rnf a
- rnf (Private _ a) = rnf a
+ rnf (Private _ _ a) = rnf a
rnf (InstanceB _ a) = rnf a
rnf (Macro _ a) = rnf a
rnf (Postulate _ a) = rnf a
@@ -948,7 +958,6 @@ instance NFData Pragma where
rnf (CompiledUHCPragma _ a b) = rnf a `seq` rnf b
rnf (CompiledDataUHCPragma _ a b c) = rnf a `seq` rnf b `seq` rnf c
rnf (HaskellCodePragma _ s) = rnf s
- rnf (NoSmashingPragma _ a) = rnf a
rnf (StaticPragma _ a) = rnf a
rnf (InlinePragma _ a) = rnf a
rnf (ImportPragma _ a) = rnf a
@@ -958,6 +967,7 @@ instance NFData Pragma where
rnf (CatchallPragma _) = ()
rnf (DisplayPragma _ a b) = rnf a `seq` rnf b
rnf (NoPositivityCheckPragma _) = ()
+ rnf (PolarityPragma _ a b) = rnf a `seq` rnf b
-- | Ranges are not forced.
@@ -1002,7 +1012,7 @@ instance NFData ModuleAssignment where
instance NFData a => NFData (WhereClause' a) where
rnf NoWhere = ()
rnf (AnyWhere a) = rnf a
- rnf (SomeWhere a b) = rnf a `seq` rnf b
+ rnf (SomeWhere a b c) = rnf a `seq` rnf b `seq` rnf c
instance NFData a => NFData (LamBinding' a) where
rnf (DomainFree a b) = rnf a `seq` rnf b
diff --git a/src/full/Agda/Syntax/Concrete/Definitions.hs b/src/full/Agda/Syntax/Concrete/Definitions.hs
index 413cf48..020234e 100644
--- a/src/full/Agda/Syntax/Concrete/Definitions.hs
+++ b/src/full/Agda/Syntax/Concrete/Definitions.hs
@@ -1,13 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.
--
@@ -39,7 +33,7 @@ module Agda.Syntax.Concrete.Definitions
, DeclarationException(..)
, Nice, runNice
, niceDeclarations
- , notSoNiceDeclaration
+ , notSoNiceDeclarations
, niceHasAbstract
, Measure
) where
@@ -57,9 +51,10 @@ import Data.Foldable ( foldMap )
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
-import Data.Monoid ( Monoid(mappend, mempty) )
+import Data.Semigroup ( Semigroup, Monoid, (<>), mempty, mappend )
import Data.List as List hiding (null)
-import Data.Traversable (traverse)
+import qualified Data.Set as Set
+import Data.Traversable (Traversable, traverse)
import Data.Typeable (Typeable)
import Agda.Syntax.Concrete
@@ -70,12 +65,17 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Concrete.Pretty ()
+import Agda.TypeChecking.Positivity.Occurrence
+
import Agda.Utils.Except ( Error(strMsg), MonadError(throwError) )
+import Agda.Utils.Functor
import Agda.Utils.Lens
-import Agda.Utils.List (headMaybe, isSublistOf)
+import Agda.Utils.List (caseList, headMaybe, isSublistOf)
import Agda.Utils.Monad
import Agda.Utils.Null
-import Agda.Utils.Pretty
+import qualified Agda.Utils.Pretty as Pretty
+import Agda.Utils.Pretty hiding ((<>))
+import Agda.Utils.Singleton
import Agda.Utils.Tuple
import Agda.Utils.Update
@@ -90,11 +90,32 @@ import Agda.Utils.Impossible
contained in a single constructor instead of spread out between type
signatures and clauses. The @private@, @postulate@, @abstract@ and @instance@
modifiers have been distributed to the individual declarations.
+
+ Observe the order of components:
+
+ Range
+ Fixity'
+ Access
+ IsAbstract
+ IsInstance
+ TerminationCheck
+ PositivityCheck
+
+ further attributes
+
+ (Q)Name
+
+ content (Expr, Declaration ...)
-}
data NiceDeclaration
- = Axiom Range Fixity' Access IsInstance ArgInfo Name Expr
- -- ^ Axioms and functions can be declared irrelevant. (Hiding should be NotHidden)
- | NiceField Range IsInstance Fixity' Access IsAbstract Name (Arg Expr)
+ = Axiom Range Fixity' Access IsAbstract IsInstance ArgInfo (Maybe [Occurrence]) Name Expr
+ -- ^ 'IsAbstract' argument: We record whether a declaration was made in an @abstract@ block.
+ --
+ -- 'ArgInfo' argument: Axioms and functions can be declared irrelevant.
+ -- ('Hiding' should be 'NotHidden'.)
+ --
+ -- @Maybe [Occurrence]@ argument: Polarities can be assigned to identifiers.
+ | NiceField Range Fixity' Access IsAbstract IsInstance Name (Arg Expr)
| PrimitiveFunction Range Fixity' Access IsAbstract Name Expr
| NiceMutual Range TerminationCheck PositivityCheck [NiceDeclaration]
| NiceModule Range Access IsAbstract QName Telescope [Declaration]
@@ -102,21 +123,21 @@ data NiceDeclaration
| NiceOpen Range QName ImportDirective
| NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective
| NicePragma Range Pragma
- | NiceRecSig Range Fixity' Access Name [LamBinding] Expr PositivityCheck
- | NiceDataSig Range Fixity' Access Name [LamBinding] Expr PositivityCheck
+ | NiceRecSig Range Fixity' Access IsAbstract PositivityCheck Name [LamBinding] Expr
+ | NiceDataSig Range Fixity' Access IsAbstract PositivityCheck Name [LamBinding] Expr
| NiceFunClause Range Access IsAbstract TerminationCheck Catchall Declaration
-- ^ An uncategorized function clause, could be a function clause
-- without type signature or a pattern lhs (e.g. for irrefutable let).
-- The 'Declaration' is the actual 'FunClause'.
- | FunSig Range Fixity' Access IsInstance IsMacro ArgInfo TerminationCheck Name Expr
- | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause]
+ | FunSig Range Fixity' Access IsAbstract IsInstance IsMacro ArgInfo TerminationCheck Name Expr
+ | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause]
-- ^ Block of function clauses (we have seen the type signature before).
-- The 'Declaration's are the original declarations that were processed
-- into this 'FunDef' and are only used in 'notSoNiceDeclaration'.
- | DataDef Range Fixity' IsAbstract Name [LamBinding] PositivityCheck [NiceConstructor]
- | RecDef Range Fixity' IsAbstract Name (Maybe (Ranged Induction)) (Maybe Bool) (Maybe (ThingWithFixity Name, IsInstance)) [LamBinding] PositivityCheck [NiceDeclaration]
+ | DataDef Range Fixity' IsAbstract PositivityCheck Name [LamBinding] [NiceConstructor]
+ | RecDef Range Fixity' IsAbstract PositivityCheck Name (Maybe (Ranged Induction)) (Maybe Bool) (Maybe (ThingWithFixity Name, IsInstance)) [LamBinding] [NiceDeclaration]
| NicePatternSyn Range Fixity' Name [Arg Name] Pattern
- | NiceUnquoteDecl Range [Fixity'] Access IsInstance IsAbstract TerminationCheck [Name] Expr
+ | NiceUnquoteDecl Range [Fixity'] Access IsAbstract IsInstance TerminationCheck [Name] Expr
| NiceUnquoteDef Range [Fixity'] Access IsAbstract TerminationCheck [Name] Expr
deriving (Typeable, Show)
@@ -141,6 +162,7 @@ data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]
-- | The exception type.
data DeclarationException
= MultipleFixityDecls [(Name, [Fixity'])]
+ | MultiplePolarityPragmas [Name]
| InvalidName Name
| DuplicateDefinition Name
| MissingDefinition Name
@@ -151,6 +173,8 @@ data DeclarationException
| WrongParameters Name
| NotAllowedInMutual NiceDeclaration
| UnknownNamesInFixityDecl [Name]
+ | UnknownNamesInPolarityPragmas [Name]
+ | PolarityPragmasButNotPostulates [Name]
| Codata Range
| DeclarationPanic String
| UselessPrivate Range
@@ -169,6 +193,7 @@ data DeclarationException
| UnquoteDefRequiresSignature [Name]
| BadMacroDef NiceDeclaration
| InvalidNoPositivityCheckPragma Range
+
deriving (Typeable)
-- | Several declarations expect only type signatures as sub-declarations. These are:
@@ -182,34 +207,37 @@ data KindOfBlock
instance HasRange DeclarationException where
- getRange (MultipleFixityDecls xs) = getRange (fst $ head xs)
- getRange (InvalidName x) = getRange x
- getRange (DuplicateDefinition x) = getRange x
- getRange (MissingDefinition x) = getRange x
- getRange (MissingWithClauses x) = getRange x
- getRange (MissingTypeSignature x) = getRange x
- getRange (MissingDataSignature x) = getRange x
- getRange (WrongDefinition x k k') = getRange x
- getRange (WrongParameters x) = getRange x
- getRange (AmbiguousFunClauses lhs xs) = getRange lhs
- getRange (NotAllowedInMutual x) = getRange x
- getRange (UnknownNamesInFixityDecl xs) = getRange . head $ xs
- getRange (Codata r) = r
- getRange (DeclarationPanic _) = noRange
- getRange (UselessPrivate r) = r
- getRange (UselessAbstract r) = r
- getRange (UselessInstance r) = r
- getRange (WrongContentBlock _ r) = r
- getRange (InvalidTerminationCheckPragma r) = r
- getRange (InvalidMeasureMutual r) = r
- getRange (PragmaNoTerminationCheck r) = r
- getRange (InvalidCatchallPragma r) = r
- getRange (UnquoteDefRequiresSignature x) = getRange x
- getRange (BadMacroDef d) = getRange d
- getRange (InvalidNoPositivityCheckPragma r) = r
+ getRange (MultipleFixityDecls xs) = getRange (fst $ head xs)
+ getRange (MultiplePolarityPragmas xs) = getRange (head xs)
+ getRange (InvalidName x) = getRange x
+ getRange (DuplicateDefinition x) = getRange x
+ getRange (MissingDefinition x) = getRange x
+ getRange (MissingWithClauses x) = getRange x
+ getRange (MissingTypeSignature x) = getRange x
+ getRange (MissingDataSignature x) = getRange x
+ getRange (WrongDefinition x k k') = getRange x
+ getRange (WrongParameters x) = getRange x
+ getRange (AmbiguousFunClauses lhs xs) = getRange lhs
+ getRange (NotAllowedInMutual x) = getRange x
+ getRange (UnknownNamesInFixityDecl xs) = getRange . head $ xs
+ getRange (UnknownNamesInPolarityPragmas xs) = getRange . head $ xs
+ getRange (PolarityPragmasButNotPostulates xs) = getRange . head $ xs
+ getRange (Codata r) = r
+ getRange (DeclarationPanic _) = noRange
+ getRange (UselessPrivate r) = r
+ getRange (UselessAbstract r) = r
+ getRange (UselessInstance r) = r
+ getRange (WrongContentBlock _ r) = r
+ getRange (InvalidTerminationCheckPragma r) = r
+ getRange (InvalidMeasureMutual r) = r
+ getRange (PragmaNoTerminationCheck r) = r
+ getRange (InvalidCatchallPragma r) = r
+ getRange (UnquoteDefRequiresSignature x) = getRange x
+ getRange (BadMacroDef d) = getRange d
+ getRange (InvalidNoPositivityCheckPragma r) = r
instance HasRange NiceDeclaration where
- getRange (Axiom r _ _ _ _ _ _) = r
+ getRange (Axiom r _ _ _ _ _ _ _ _) = r
getRange (NiceField r _ _ _ _ _ _) = r
getRange (NiceMutual r _ _ _) = r
getRange (NiceModule r _ _ _ _ _ ) = r
@@ -218,12 +246,12 @@ instance HasRange NiceDeclaration where
getRange (NiceImport r _ _ _ _) = r
getRange (NicePragma r _) = r
getRange (PrimitiveFunction r _ _ _ _ _) = r
- getRange (FunSig r _ _ _ _ _ _ _ _) = r
+ getRange (FunSig r _ _ _ _ _ _ _ _ _) = r
getRange (FunDef r _ _ _ _ _ _) = r
getRange (DataDef r _ _ _ _ _ _) = r
getRange (RecDef r _ _ _ _ _ _ _ _ _) = r
- getRange (NiceRecSig r _ _ _ _ _ _) = r
- getRange (NiceDataSig r _ _ _ _ _ _) = r
+ getRange (NiceRecSig r _ _ _ _ _ _ _) = r
+ getRange (NiceDataSig r _ _ _ _ _ _ _) = r
getRange (NicePatternSyn r _ _ _ _) = r
getRange (NiceFunClause r _ _ _ _ _) = r
getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r
@@ -240,7 +268,9 @@ instance Pretty DeclarationException where
, vcat $ map f xs
]
where
- f (x, fs) = pretty x <> text ": " <+> fsep (map pretty fs)
+ f (x, fs) = pretty x Pretty.<> text ": " <+> fsep (map pretty fs)
+ pretty (MultiplePolarityPragmas xs) = fsep $
+ pwords "Multiple polarity pragmas for" ++ map pretty xs
pretty (InvalidName x) = fsep $
pwords "Invalid name:" ++ [pretty x]
pretty (DuplicateDefinition x) = fsep $
@@ -266,6 +296,10 @@ instance Pretty DeclarationException where
]
pretty (UnknownNamesInFixityDecl xs) = fsep $
pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):" ++ map pretty xs
+ pretty (UnknownNamesInPolarityPragmas xs) = fsep $
+ pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):" ++ map pretty xs
+ pretty (PolarityPragmasButNotPostulates xs) = fsep $
+ pwords "Polarity pragmas have been given for the following identifiers which are not postulates:" ++ map pretty xs
pretty (UselessPrivate _) = fsep $
pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."
pretty (UselessAbstract _) = fsep $
@@ -407,18 +441,30 @@ type Nice = StateT NiceEnv (Either DeclarationException)
data NiceEnv = NiceEnv
{ _loneSigs :: LoneSigs
-- ^ Lone type signatures that wait for their definition.
+ , _termChk :: TerminationCheck
+ -- ^ Termination checking pragma waiting for a definition.
+ , _posChk :: PositivityCheck
+ -- ^ Positivity checking pragma waiting for a definition.
+ , _catchall :: Catchall
+ -- ^ Catchall pragma waiting for a function clause.
, fixs :: Fixities
+ , pols :: Polarities
}
-type LoneSigs = Map Name DataRecOrFun
-type Fixities = Map Name Fixity'
+type LoneSigs = Map Name DataRecOrFun
+type Fixities = Map Name Fixity'
+type Polarities = Map Name [Occurrence]
-- | Initial nicifier state.
initNiceEnv :: NiceEnv
initNiceEnv = NiceEnv
{ _loneSigs = empty
+ , _termChk = TerminationCheck
+ , _posChk = True
+ , _catchall = False
, fixs = empty
+ , pols = empty
}
-- * Handling the lone signatures, stored to infer mutual blocks.
@@ -460,11 +506,64 @@ checkLoneSigs xs =
[] -> return ()
(x, _):_ -> throwError $ MissingDefinition x
+-- | Lens for field '_termChk'.
+
+terminationCheckPragma :: Lens' TerminationCheck NiceEnv
+terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }
+
+withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a
+withTerminationCheckPragma tc f = do
+ tc_old <- use terminationCheckPragma
+ terminationCheckPragma .= tc
+ result <- f
+ terminationCheckPragma .= tc_old
+ return result
+
+-- | Lens for field '_posChk'.
+
+positivityCheckPragma :: Lens' PositivityCheck NiceEnv
+positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }
+
+withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a
+withPositivityCheckPragma pc f = do
+ pc_old <- use positivityCheckPragma
+ positivityCheckPragma .= pc
+ result <- f
+ positivityCheckPragma .= pc_old
+ return result
+
+-- | Lens for field '_catchall'.
+
+catchallPragma :: Lens' Catchall NiceEnv
+catchallPragma f e = f (_catchall e) <&> \ s -> e { _catchall = s }
+
+-- | Get current catchall pragma, and reset it for the next clause.
+
+popCatchallPragma :: Nice Catchall
+popCatchallPragma = do
+ ca <- use catchallPragma
+ catchallPragma .= False
+ return ca
+
+withCatchallPragma :: Catchall -> Nice a -> Nice a
+withCatchallPragma ca f = do
+ ca_old <- use catchallPragma
+ catchallPragma .= ca
+ result <- f
+ catchallPragma .= ca_old
+ return result
+
-- | Check whether name is not "_" and return its fixity.
getFixity :: Name -> Nice Fixity'
-getFixity x = do
- when (isUnderscore x) $ throwError $ InvalidName x
- Map.findWithDefault noFixity' x <$> gets fixs -- WAS: defaultFixity'
+getFixity x = Map.findWithDefault noFixity' x <$> gets fixs -- WAS: defaultFixity'
+
+-- | Fail if the name is @_@. Otherwise the name's polarity, if any,
+-- is removed from the state and returned.
+getPolarity :: Name -> Nice (Maybe [Occurrence])
+getPolarity x = do
+ p <- gets (Map.lookup x . pols)
+ modify (\s -> s { pols = Map.delete x (pols s) })
+ return p
runNice :: Nice a -> Either DeclarationException a
runNice nice = nice `evalStateT` initNiceEnv
@@ -476,12 +575,12 @@ data DeclKind
deriving (Eq, Show)
declKind :: NiceDeclaration -> DeclKind
-declKind (FunSig _ _ _ _ _ _ tc x _) = LoneSig (FunName tc) x
-declKind (NiceRecSig _ _ _ x pars _ pc) = LoneSig (RecName pc $ parameters pars) x
-declKind (NiceDataSig _ _ _ x pars _ pc) = LoneSig (DataName pc $ parameters pars) x
+declKind (FunSig _ _ _ _ _ _ _ tc x _) = LoneSig (FunName tc) x
+declKind (NiceRecSig _ _ _ _ pc x pars _) = LoneSig (RecName pc $ parameters pars) x
+declKind (NiceDataSig _ _ _ _ pc x pars _)= LoneSig (DataName pc $ parameters pars) x
declKind (FunDef _ _ _ _ tc x _) = LoneDefs (FunName tc) [x]
-declKind (DataDef _ _ _ x pars pc _) = LoneDefs (DataName pc $ parameters pars) [x]
-declKind (RecDef _ _ _ x _ _ _ pars pc _) = LoneDefs (RecName pc $ parameters pars) [x]
+declKind (DataDef _ _ _ pc x pars _) = LoneDefs (DataName pc $ parameters pars) [x]
+declKind (RecDef _ _ _ pc x _ _ _ pars _) = LoneDefs (RecName pc $ parameters pars) [x]
declKind (NiceUnquoteDef _ _ _ _ tc xs _) = LoneDefs (FunName tc) xs
declKind Axiom{} = OtherDecl
declKind NiceField{} = OtherDecl
@@ -507,15 +606,27 @@ parameters = List.concat . List.map numP where
niceDeclarations :: [Declaration] -> Nice [NiceDeclaration]
niceDeclarations ds = do
-- Get fixity and syntax declarations.
- fixs <- fixities ds
- case Map.keys fixs \\ concatMap declaredNames ds of
+ (fixs, polarities) <- fixitiesAndPolarities ds
+ let declared = Set.fromList (concatMap declaredNames ds)
+ unknownFixs = Map.keysSet fixs Set.\\ declared
+ unknownPols = Map.keysSet polarities Set.\\ declared
+ case (Set.null unknownFixs, Set.null unknownPols) of
-- If we have fixity/syntax decls for names not declared
-- in the current scope, fail.
- xs@(_:_) -> throwError $ UnknownNamesInFixityDecl xs
- [] -> localState $ do
- -- Run the nicifier in an initial environment of fixity decls.
- put $ initNiceEnv { fixs = fixs }
+ (False, _) -> throwError $ UnknownNamesInFixityDecl
+ (Set.toList unknownFixs)
+ -- Fail if there are polarity pragmas with undeclared names.
+ (_, False) -> throwError $ UnknownNamesInPolarityPragmas
+ (Set.toList unknownPols)
+ (True, True) -> localState $ do
+ -- Run the nicifier in an initial environment of fixity decls
+ -- and polarities.
+ put $ initNiceEnv { fixs = fixs, pols = polarities }
ds <- nice ds
+ -- Check that every polarity pragma was used.
+ unusedPolarities <- gets (Map.keys . pols)
+ unless (null unusedPolarities) $ do
+ throwError $ PolarityPragmasButNotPostulates unusedPolarities
-- Check that every signature got its definition.
checkLoneSigs . Map.toList =<< use loneSigs
-- Note that loneSigs is ensured to be empty.
@@ -541,7 +652,7 @@ niceDeclarations ds = do
PatternSyn _ x _ _ -> [x]
Mutual _ ds -> concatMap declaredNames ds
Abstract _ ds -> concatMap declaredNames ds
- Private _ ds -> concatMap declaredNames ds
+ Private _ _ ds -> concatMap declaredNames ds
InstanceB _ ds -> concatMap declaredNames ds
Macro _ ds -> concatMap declaredNames ds
Postulate _ ds -> concatMap declaredNames ds
@@ -573,7 +684,7 @@ niceDeclarations ds = do
-- block. See Issue 1760.
let prefix :: [NiceDeclaration] -> [NiceDeclaration]
prefix = case (d, ds0) of
- (NiceRecSig{}, [r@(RecDef _ _ _ _ _ _ _ _ True _)]) -> ([d, r] ++)
+ (NiceRecSig{}, [r@(RecDef _ _ _ True _ _ _ _ _ _)]) -> ([d, r] ++)
_ ->
(NiceMutual (getRange (d : ds0)) tc (and pcs) (d : ds0) :)
@@ -607,116 +718,137 @@ niceDeclarations ds = do
nice :: [Declaration] -> Nice [NiceDeclaration]
nice [] = return []
+ nice ds = do
+ (xs , ys) <- nice1 ds
+ (xs ++) <$> nice ys
+
+ nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])
+ nice1 [] = __IMPOSSIBLE__
+ nice1 (d:ds) = case d of
+
+ (TypeSig info x t) -> do
+ termCheck <- use terminationCheckPragma
+ fx <- getFixity x
+ -- register x as lone type signature, to recognize clauses later
+ addLoneSig x (FunName termCheck)
+ return ([FunSig (getRange d) fx PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck x t] , ds)
+
+ (FunClause lhs _ _ _) -> do
+ termCheck <- use terminationCheckPragma
+ catchall <- popCatchallPragma
+ xs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs
+ -- for each type signature 'x' waiting for clauses, we try
+ -- if we have some clauses for 'x'
+ fixs <- gets fixs
+ case [ (x, (fits, rest))
+ | x <- xs
+ , let (fits, rest) =
+ -- Anonymous declarations only have 1 clause each!
+ if isNoName x then ([d], ds)
+ else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)
+ , not (null fits)
+ ] of
- nice (Pragma (TerminationCheckPragma r NoTerminationCheck) : _) =
- throwError $ PragmaNoTerminationCheck r
-
- nice (Pragma (TerminationCheckPragma r tc) : ds@(Mutual{} : _)) | notMeasure tc = do
- ds <- nice ds
- case ds of
- NiceMutual r _ pc ds' : ds -> return $ NiceMutual r tc pc ds' : ds
- _ -> __IMPOSSIBLE__
-
- nice (Pragma (TerminationCheckPragma r tc) : d@TypeSig{} : ds) =
- niceTypeSig tc d ds
-
- nice (Pragma (TerminationCheckPragma r tc) : d@FunClause{} : ds) | notMeasure tc =
- niceFunClause tc False d ds
-
- nice (Pragma (TerminationCheckPragma r tc) : ds@(UnquoteDecl{} : _)) | notMeasure tc = do
- NiceUnquoteDecl r f p a i _ x e : ds <- nice ds
- return $ NiceUnquoteDecl r f p a i tc x e : ds
-
- nice (Pragma (TerminationCheckPragma r tc) : d@(Pragma (NoPositivityCheckPragma _)) : ds@(Mutual{} : _)) | notMeasure tc = do
- ds <- nice (d : ds)
- case ds of
- NiceMutual r _ pc ds' : ds -> return $ NiceMutual r tc pc ds' : ds
- _ -> __IMPOSSIBLE__
-
- nice (Pragma (CatchallPragma r) : d@FunClause{} : ds) =
- niceFunClause TerminationCheck True d ds
-
- nice (d@TypeSig{} : Pragma (TerminationCheckPragma r (TerminationMeasure _ x)) : ds) =
- niceTypeSig (TerminationMeasure r x) d ds
-
- -- nice (Pragma (MeasurePragma r x) : d@FunClause{} : ds) =
- -- niceFunClause (TerminationMeasure r x) d ds
-
- nice (Pragma (NoPositivityCheckPragma _) : ds@(Mutual{} : _)) = do
- ds <- nice ds
- case ds of
- NiceMutual r tc _ ds' : ds -> return $ NiceMutual r tc False ds' : ds
- _ -> __IMPOSSIBLE__
-
- nice (Pragma (NoPositivityCheckPragma _) : d@(Data _ Inductive _ _ _ _) : ds) =
- niceDataDef False d ds
-
- nice (Pragma (NoPositivityCheckPragma _) : d@(DataSig _ Inductive _ _ _) : ds) =
- niceDataSig False d ds
-
- nice (Pragma (NoPositivityCheckPragma _) : d@Record{} : ds) =
- niceRecord False d ds
+ -- case: clauses match none of the sigs
+ [] -> case lhs of
+ -- Subcase: The lhs is single identifier (potentially anonymous).
+ -- Treat it as a function clause without a type signature.
+ LHS p [] [] [] | Just x <- isSingleIdentifierP p -> do
+ d <- mkFunDef defaultArgInfo termCheck x Nothing [d] -- fun def without type signature is relevant
+ return (d , ds)
+ -- Subcase: The lhs is a proper pattern.
+ -- This could be a let-pattern binding. Pass it on.
+ -- A missing type signature error might be raise in ConcreteToAbstract
+ _ -> do
+ return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck catchall d] , ds)
- nice (Pragma (NoPositivityCheckPragma _) : d@RecordSig{} : ds) =
- niceRecordSig False d ds
+ -- case: clauses match exactly one of the sigs
+ [(x,(fits,rest))] -> do
+ removeLoneSig x
+ cs <- mkClauses x (expandEllipsis fits) False
+ fx <- getFixity x
+ return ([FunDef (getRange fits) fits fx ConcreteDef termCheck x cs] , rest)
- nice (Pragma (NoPositivityCheckPragma _) : d@(Pragma (TerminationCheckPragma _ _)) : ds@(Mutual{} : _)) = do
- ds <- nice (d : ds)
- case ds of
- NiceMutual r tc _ ds' : ds -> return $ NiceMutual r tc False ds' : ds
- _ -> __IMPOSSIBLE__
+ -- case: clauses match more than one sigs (ambiguity)
+ l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature"
- nice (d:ds) = do
- case d of
- TypeSig{} -> niceTypeSig TerminationCheck d ds
- FunClause{} -> niceFunClause TerminationCheck False d ds
- Field{} -> (++) <$> niceAxioms FieldBlock [ d ] <*> nice ds
+ Field{} -> (,ds) <$> niceAxioms FieldBlock [ d ]
DataSig r CoInductive _ _ _ -> throwError (Codata r)
Data r CoInductive _ _ _ _ -> throwError (Codata r)
- d@(DataSig _ Inductive _ _ _) -> niceDataSig True d ds
- d@(Data _ Inductive _ _ _ _) -> niceDataDef True d ds
- d@RecordSig{} -> niceRecordSig True d ds
- d@Record{} -> niceRecord True d ds
+
+ (DataSig r Inductive x tel t) -> do
+ pc <- use positivityCheckPragma
+ addLoneSig x (DataName pc $ parameters tel)
+ (,) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel (Just t) Nothing
+ <*> return ds
+
+ (Data r Inductive x tel t cs) -> do
+ pc <- use positivityCheckPragma
+ t <- defaultTypeSig (DataName pc $ parameters tel) x t
+ (,) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel t (Just cs)
+ <*> return ds
+
+ (RecordSig r x tel t) -> do
+ pc <- use positivityCheckPragma
+ addLoneSig x (RecName pc $ parameters tel)
+ fx <- getFixity x
+ return ([NiceRecSig r fx PublicAccess ConcreteDef pc x tel t] , ds)
+
+ (Record r x i e c tel t cs) -> do
+ pc <- use positivityCheckPragma
+ t <- defaultTypeSig (RecName pc $ parameters tel) x t
+ c <- traverse (\(cname, cinst) -> do fix <- getFixity cname; return (ThingWithFixity cname fix, cinst)) c
+ (,) <$> dataOrRec pc (\ r f a pc x tel cs -> RecDef r f a pc x i e c tel cs) NiceRecSig
+ niceDeclarations r x tel t (Just cs)
+ <*> return ds
Mutual r ds' ->
- (:) <$> (mkOldMutual r =<< nice ds') <*> nice ds
+ (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))
Abstract r ds' ->
- (++) <$> (abstractBlock r =<< nice ds') <*> nice ds
+ (,ds) <$> (abstractBlock r =<< nice ds')
- Private r ds' ->
- (++) <$> (privateBlock r =<< nice ds') <*> nice ds
+ Private r o ds' ->
+ (,ds) <$> (privateBlock r o =<< nice ds')
InstanceB r ds' ->
- (++) <$> (instanceBlock r =<< nice ds') <*> nice ds
+ (,ds) <$> (instanceBlock r =<< nice ds')
Macro r ds' ->
- (++) <$> (macroBlock r =<< nice ds') <*> nice ds
+ (,ds) <$> (macroBlock r =<< nice ds')
- Postulate _ ds' -> (++) <$> niceAxioms PostulateBlock ds' <*> nice ds
+ Postulate _ ds' ->
+ (,ds) <$> (mapM setPolarity =<< niceAxioms PostulateBlock ds')
+ where
+ setPolarity (Axiom r f acc a i arg Nothing x e) = do
+ mp <- getPolarity x
+ return (Axiom r f acc a i arg mp x e)
+ setPolarity (Axiom _ _ _ _ _ _ (Just _) _ _) = __IMPOSSIBLE__
+ setPolarity d = return d
- Primitive _ ds' -> (++) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds') <*> nice ds
+ Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')
- Module r x tel ds' ->
- (NiceModule r PublicAccess ConcreteDef x tel ds' :) <$> nice ds
+ Module r x tel ds' -> return $
+ ([NiceModule r PublicAccess ConcreteDef x tel ds'] , ds)
- ModuleMacro r x modapp op is ->
- (NiceModuleMacro r PublicAccess x modapp op is :)
- <$> nice ds
+ ModuleMacro r x modapp op is -> return $
+ ([NiceModuleMacro r PublicAccess x modapp op is] , ds)
- -- Fixity and syntax declarations have been looked at already.
- Infix _ _ -> nice ds
- Syntax _ _ -> nice ds
+ -- Fixity and syntax declarations and polarity pragmas have
+ -- already been processed.
+ Infix _ _ -> return ([], ds)
+ Syntax _ _ -> return ([], ds)
PatternSyn r n as p -> do
fx <- getFixity n
- (NicePatternSyn r fx n as p :) <$> nice ds
- Open r x is -> (NiceOpen r x is :) <$> nice ds
- Import r x as op is -> (NiceImport r x as op is :) <$> nice ds
+ return ([NicePatternSyn r fx n as p] , ds)
+ Open r x is -> return ([NiceOpen r x is] , ds)
+ Import r x as op is -> return ([NiceImport r x as op is] , ds)
UnquoteDecl r xs e -> do
fxs <- mapM getFixity xs
- (NiceUnquoteDecl r fxs PublicAccess NotInstanceDef ConcreteDef TerminationCheck xs e :) <$> nice ds
+ tc <- use terminationCheckPragma
+ return ([NiceUnquoteDecl r fxs PublicAccess ConcreteDef NotInstanceDef tc xs e] , ds)
UnquoteDef r xs e -> do
fxs <- mapM getFixity xs
@@ -725,105 +857,85 @@ niceDeclarations ds = do
if null missing
then do
mapM_ removeLoneSig xs
- (NiceUnquoteDef r fxs PublicAccess ConcreteDef TerminationCheck xs e :) <$> nice ds
+ return ([NiceUnquoteDef r fxs PublicAccess ConcreteDef TerminationCheck xs e] , ds)
else throwError $ UnquoteDefRequiresSignature missing
- Pragma (TerminationCheckPragma r NoTerminationCheck) ->
- throwError $ PragmaNoTerminationCheck r
- Pragma (TerminationCheckPragma r _) ->
- throwError $ InvalidTerminationCheckPragma r
-
- Pragma (CatchallPragma r) ->
- throwError $ InvalidCatchallPragma r
-
- Pragma (NoPositivityCheckPragma r) ->
- throwError $ InvalidNoPositivityCheckPragma r
-
- Pragma p -> (NicePragma (getRange p) p :) <$> nice ds
-
- niceFunClause :: TerminationCheck -> Catchall -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
- niceFunClause termCheck catchall d@(FunClause lhs _ _ _) ds = do
- xs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs
- -- for each type signature 'x' waiting for clauses, we try
- -- if we have some clauses for 'x'
- fixs <- gets fixs
- case [ (x, (fits, rest))
- | x <- xs
- , let (fits, rest) =
- span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)
- , not (null fits)
- ] of
+ Pragma p -> nicePragma p ds
- -- case: clauses match none of the sigs
- [] -> case lhs of
- -- Subcase: The lhs is single identifier.
- -- Treat it as a function clause without a type signature.
- LHS p [] [] [] | IdentP (QName x) <- removeSingletonRawAppP p -> do
- ds <- nice ds
- d <- mkFunDef defaultArgInfo termCheck x Nothing [d] -- fun def without type signature is relevant
- return $ d ++ ds
- -- Subcase: The lhs is a proper pattern.
- -- This could be a let-pattern binding. Pass it on.
- -- A missing type signature error might be raise in ConcreteToAbstract
- _ -> do
- ds <- nice ds
- return $ NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck catchall d : ds
+ nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])
- -- case: clauses match exactly one of the sigs
- [(x,(fits,rest))] -> do
- removeLoneSig x
- cs <- mkClauses x (expandEllipsis fits) False
- ds1 <- nice rest
- fx <- getFixity x
- d <- return $ FunDef (getRange fits) fits fx ConcreteDef termCheck x cs
- return $ d : ds1
+ nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =
+ if canHaveTerminationMeasure ds then
+ withTerminationCheckPragma (TerminationMeasure r x) $ nice1 ds
+ else
+ throwError $ InvalidTerminationCheckPragma r
- -- case: clauses match more than one sigs (ambiguity)
- l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature"
- niceFunClause _ _ _ _ = __IMPOSSIBLE__
+ nicePragma (TerminationCheckPragma r NoTerminationCheck) ds =
+ throwError $ PragmaNoTerminationCheck r
- niceTypeSig :: TerminationCheck -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
- niceTypeSig termCheck d@(TypeSig info x t) ds = do
- fx <- getFixity x
- -- register x as lone type signature, to recognize clauses later
- addLoneSig x (FunName termCheck)
- ds <- nice ds
- return $ FunSig (getRange d) fx PublicAccess NotInstanceDef NotMacroDef info termCheck x t : ds
- niceTypeSig _ _ _ = __IMPOSSIBLE__
-
- niceDataDef :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceDataDef pc (Data r Inductive x tel t cs) ds = do
- t <- defaultTypeSig (DataName pc $ parameters tel) x t
- (++) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel t (Just cs)
- <*> nice ds
- niceDataDef _ _ _ = __IMPOSSIBLE__
-
- niceDataSig :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceDataSig pc (DataSig r Inductive x tel t) ds = do
- addLoneSig x (DataName pc $ parameters tel)
- (++) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel (Just t) Nothing
- <*> nice ds
- niceDataSig _ _ _ = __IMPOSSIBLE__
-
- niceRecord :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceRecord pc (Record r x i e c tel t cs) ds = do
- t <- defaultTypeSig (RecName pc $ parameters tel) x t
- c <- traverse (\(cname, cinst) -> do fix <- getFixity cname; return (ThingWithFixity cname fix, cinst)) c
- (++) <$> dataOrRec pc (\x1 x2 x3 x4 -> RecDef x1 x2 x3 x4 i e c) NiceRecSig
- niceDeclarations r x tel t (Just cs)
- <*> nice ds
- niceRecord _ _ _ = __IMPOSSIBLE__
-
- niceRecordSig :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceRecordSig pc (RecordSig r x tel t) ds = do
- addLoneSig x (RecName pc $ parameters tel)
- fx <- getFixity x
- (NiceRecSig r fx PublicAccess x tel t pc :) <$> nice ds
- niceRecordSig _ _ _ = __IMPOSSIBLE__
+ nicePragma (TerminationCheckPragma r tc) ds =
+ if canHaveTerminationCheckPragma ds then
+ withTerminationCheckPragma tc $ nice1 ds
+ else
+ throwError $ InvalidTerminationCheckPragma r
+
+ nicePragma (CatchallPragma r) ds =
+ if canHaveCatchallPragma ds then
+ withCatchallPragma True $ nice1 ds
+ else
+ throwError $ InvalidCatchallPragma r
+
+ nicePragma (NoPositivityCheckPragma r) ds =
+ if canHaveNoPositivityCheckPragma ds then
+ withPositivityCheckPragma False $ nice1 ds
+ else
+ throwError $ InvalidNoPositivityCheckPragma r
+
+ nicePragma (PolarityPragma{}) ds = return ([], ds)
+
+ nicePragma p ds = return ([NicePragma (getRange p) p], ds)
+
+ canHaveTerminationMeasure :: [Declaration] -> Bool
+ canHaveTerminationMeasure [] = False
+ canHaveTerminationMeasure (d:ds) = case d of
+ TypeSig{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveTerminationMeasure ds
+ _ -> False
+
+ canHaveTerminationCheckPragma :: [Declaration] -> Bool
+ canHaveTerminationCheckPragma [] = False
+ canHaveTerminationCheckPragma (d:ds) = case d of
+ Mutual{} -> True
+ TypeSig{} -> True
+ FunClause{} -> True
+ UnquoteDecl{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveTerminationCheckPragma ds
+ _ -> False
+
+ canHaveCatchallPragma :: [Declaration] -> Bool
+ canHaveCatchallPragma [] = False
+ canHaveCatchallPragma (d:ds) = case d of
+ FunClause{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveCatchallPragma ds
+ _ -> False
+
+ canHaveNoPositivityCheckPragma :: [Declaration] -> Bool
+ canHaveNoPositivityCheckPragma [] = False
+ canHaveNoPositivityCheckPragma (d:ds) = case d of
+ Mutual{} -> True
+ (Data _ Inductive _ _ _ _) -> True
+ (DataSig _ Inductive _ _ _) -> True
+ Record{} -> True
+ RecordSig{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds
+ _ -> False
+
+ isAttachedPragma :: Pragma -> Bool
+ isAttachedPragma p = case p of
+ TerminationCheckPragma{} -> True
+ CatchallPragma{} -> True
+ NoPositivityCheckPragma{} -> True
+ _ -> False
-- We could add a default type signature here, but at the moment we can't
-- infer the type of a record or datatype, so better to just fail here.
@@ -839,10 +951,10 @@ niceDeclarations ds = do
dataOrRec :: forall a .
PositivityCheck ->
- (Range -> Fixity' -> IsAbstract -> Name -> [LamBinding] ->
- PositivityCheck -> [NiceConstructor] -> NiceDeclaration) ->
- (Range -> Fixity' -> Access -> Name -> [LamBinding] -> Expr ->
- PositivityCheck -> NiceDeclaration) ->
+ (Range -> Fixity' -> IsAbstract -> PositivityCheck -> Name -> [LamBinding] ->
+ [NiceConstructor] -> NiceDeclaration) ->
+ (Range -> Fixity' -> Access -> IsAbstract -> PositivityCheck -> Name -> [LamBinding] -> Expr ->
+ NiceDeclaration) ->
([a] -> Nice [NiceDeclaration]) ->
Range ->
Name ->
@@ -854,8 +966,8 @@ niceDeclarations ds = do
mds <- traverse niceD mcs
f <- getFixity x
return $ catMaybes $
- [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess x tel t pc
- , mkDef r f ConcreteDef x (concatMap dropType tel) pc <$> mds
+ [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess ConcreteDef pc x tel t
+ , mkDef r f ConcreteDef pc x (concatMap dropType tel) <$> mds
]
where
dropType :: LamBinding -> [LamBinding]
@@ -872,10 +984,10 @@ niceDeclarations ds = do
niceAxiom b d = case d of
TypeSig rel x t -> do
fx <- getFixity x
- return [ Axiom (getRange d) fx PublicAccess NotInstanceDef rel x t ]
+ return [ Axiom (getRange d) fx PublicAccess ConcreteDef NotInstanceDef rel Nothing x t ]
Field i x argt -> do
fx <- getFixity x
- return [ NiceField (getRange d) i fx PublicAccess ConcreteDef x argt ]
+ return [ NiceField (getRange d) fx PublicAccess ConcreteDef i x argt ]
InstanceB r decls -> do
instanceBlock r =<< niceAxioms InstanceBlock decls
Pragma p@(RewritePragma r _) -> do
@@ -883,14 +995,14 @@ niceDeclarations ds = do
_ -> throwError $ WrongContentBlock b $ getRange d
toPrim :: NiceDeclaration -> NiceDeclaration
- toPrim (Axiom r f a i rel x t) = PrimitiveFunction r f a ConcreteDef x t
- toPrim _ = __IMPOSSIBLE__
+ toPrim (Axiom r f p a i rel Nothing x t) = PrimitiveFunction r f p a x t
+ toPrim _ = __IMPOSSIBLE__
-- Create a function definition.
mkFunDef info termCheck x mt ds0 = do
cs <- mkClauses x (expandEllipsis ds0) False
f <- getFixity x
- return [ FunSig (fuseRange x t) f PublicAccess NotInstanceDef NotMacroDef info termCheck x t
+ return [ FunSig (fuseRange x t) f PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck x t
, FunDef (getRange ds0) ds0 f ConcreteDef termCheck x cs ]
where
t = case mt of
@@ -905,7 +1017,7 @@ niceDeclarations ds = do
expandEllipsis (d@(FunClause Ellipsis{} _ _ _) : ds) =
d : expandEllipsis ds
expandEllipsis (d@(FunClause lhs@(LHS p ps _ _) _ _ _) : ds) =
- d : expand p ps ds
+ d : expand (setInserted p) (map setInserted ps) ds
where
expand _ _ [] = []
expand p ps (d@(Pragma (CatchallPragma r)) : ds) = d : expand p ps ds
@@ -920,6 +1032,23 @@ niceDeclarations ds = do
expand _ _ (_ : ds) = __IMPOSSIBLE__
expandEllipsis (_ : ds) = __IMPOSSIBLE__
+ setInserted :: Pattern -> Pattern
+ setInserted p = case p of
+ IdentP{} -> p
+ QuoteP{} -> p
+ AppP p q -> AppP (setInserted p) (fmap (fmap setInserted) q)
+ RawAppP r ps -> RawAppP r (map setInserted ps)
+ OpAppP r c ns ps -> OpAppP r c ns (map (fmap $ fmap setInserted) ps)
+ HiddenP r p -> HiddenP r (fmap setInserted p)
+ InstanceP r p -> InstanceP r (fmap setInserted p)
+ ParenP r p -> ParenP r (setInserted p)
+ WildP{} -> p
+ AbsurdP{} -> p
+ AsP r n p -> AsP r n (setInserted p)
+ DotP r _ e -> DotP r Inserted e
+ LitP{} -> p
+ RecP r fs -> RecP r (map (fmap setInserted) fs)
+
-- Turn function clauses into nice function clauses.
mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]
mkClauses _ [] _ = return []
@@ -998,9 +1127,14 @@ niceDeclarations ds = do
-- -- it's part of the current definition
-- isFunClauseOf _ _ = False
+ isSingleIdentifierP :: Pattern -> Maybe Name
+ isSingleIdentifierP p = case removeSingletonRawAppP p of
+ IdentP (QName x) -> Just x
+ WildP r -> Just $ noName r
+ _ -> Nothing
+
removeSingletonRawAppP :: Pattern -> Pattern
- removeSingletonRawAppP p =
- case p of
+ removeSingletonRawAppP p = case p of
RawAppP _ [p'] -> removeSingletonRawAppP p'
ParenP _ p' -> removeSingletonRawAppP p'
_ -> p
@@ -1015,11 +1149,13 @@ niceDeclarations ds = do
[] -> return ()
(NiceFunClause _ _ _ _ s_ (FunClause lhs _ _ _)):_ -> throwError $ MissingTypeSignature lhs
d:_ -> throwError $ NotAllowedInMutual d
+ tc0 <- use terminationCheckPragma
let tcs = map termCheck ds
- tc <- combineTermChecks r tcs
+ tc <- combineTermChecks r (tc0:tcs)
+ pc0 <- use positivityCheckPragma
let pc :: PositivityCheck
- pc = all positivityCheckOldMutual ds
+ pc = pc0 && all positivityCheckOldMutual ds
return $ NiceMutual r tc pc $ sigs ++ other
where
@@ -1040,7 +1176,7 @@ niceDeclarations ds = do
-- Andreas, 2013-02-28 (issue 804):
-- do not termination check a mutual block if any of its
-- inner declarations comes with a {-# NO_TERMINATION_CHECK #-}
- termCheck (FunSig _ _ _ _ _ _ tc _ _) = tc
+ termCheck (FunSig _ _ _ _ _ _ _ tc _ _) = tc
termCheck (FunDef _ _ _ _ tc _ _) = tc
-- ASR (28 December 2015): Is this equation necessary?
termCheck (NiceMutual _ tc _ _) = __IMPOSSIBLE__
@@ -1065,11 +1201,11 @@ niceDeclarations ds = do
-- block if any of its inner declarations comes with a
-- NO_POSITIVITY_CHECK pragma. See Issue 1614.
positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck
- positivityCheckOldMutual (DataDef _ _ _ _ _ pc _) = pc
- positivityCheckOldMutual (NiceDataSig _ _ _ _ _ _ pc) = pc
+ positivityCheckOldMutual (DataDef _ _ _ pc _ _ _) = pc
+ positivityCheckOldMutual (NiceDataSig _ _ _ _ pc _ _ _)= pc
positivityCheckOldMutual (NiceMutual _ _ pc _) = __IMPOSSIBLE__
- positivityCheckOldMutual (NiceRecSig _ _ _ _ _ _ pc) = pc
- positivityCheckOldMutual (RecDef _ _ _ _ _ _ _ _ pc _) = pc
+ positivityCheckOldMutual (NiceRecSig _ _ _ _ pc _ _ _) = pc
+ positivityCheckOldMutual (RecDef _ _ _ pc _ _ _ _ _ _) = pc
positivityCheckOldMutual _ = True
-- A mutual block cannot have a measure,
@@ -1077,101 +1213,16 @@ niceDeclarations ds = do
abstractBlock _ [] = return []
abstractBlock r ds = do
- let (ds', anyChange) = runChange $ mapM mkAbstract ds
+ let (ds', anyChange) = runChange $ mkAbstract ds
inherited = r == noRange
-- hack to avoid failing on inherited abstract blocks in where clauses
if anyChange || inherited then return ds' else throwError $ UselessAbstract r
- -- Make a declaration abstract
- mkAbstract :: Updater NiceDeclaration
- mkAbstract d =
- case d of
- NiceMutual r termCheck pc ds -> NiceMutual r termCheck pc <$> mapM mkAbstract ds
- FunDef r ds f a tc x cs -> (\ a -> FunDef r ds f a tc x) <$> setAbstract a <*> mapM mkAbstractClause cs
- DataDef r f a x ps pc cs -> (\ a -> DataDef r f a x ps pc) <$> setAbstract a <*> mapM mkAbstract cs
- RecDef r f a x i e c ps pc cs -> (\ a -> RecDef r f a x i e c ps pc) <$> setAbstract a <*> mapM mkAbstract cs
- NiceFunClause r p a termCheck catchall d -> (\ a -> NiceFunClause r p a termCheck catchall d) <$> setAbstract a
- -- no effect on fields or primitives, the InAbstract field there is unused
- NiceField r i f p _ x e -> return $ NiceField r i f p AbstractDef x e
- PrimitiveFunction r f p _ x e -> return $ PrimitiveFunction r f p AbstractDef x e
- NiceUnquoteDecl r f p i _ t x e -> return $ NiceUnquoteDecl r f p i AbstractDef t x e
- NiceUnquoteDef r f p _ t x e -> return $ NiceUnquoteDef r f p AbstractDef t x e
- NiceModule{} -> return d
- NiceModuleMacro{} -> return d
- Axiom{} -> return d
- NicePragma{} -> return d
- NiceOpen{} -> return d
- NiceImport{} -> return d
- FunSig{} -> return d
- NiceRecSig{} -> return d
- NiceDataSig{} -> return d
- NicePatternSyn{} -> return d
-
- setAbstract :: Updater IsAbstract
- setAbstract a = case a of
- AbstractDef -> return a
- ConcreteDef -> dirty $ AbstractDef
-
- mkAbstractClause :: Updater Clause
- mkAbstractClause (Clause x catchall lhs rhs wh with) = do
- wh <- mkAbstractWhere wh
- Clause x catchall lhs rhs wh <$> mapM mkAbstractClause with
-
- mkAbstractWhere :: Updater WhereClause
- mkAbstractWhere NoWhere = return $ NoWhere
- mkAbstractWhere (AnyWhere ds) = dirty $ AnyWhere [Abstract noRange ds]
- mkAbstractWhere (SomeWhere m ds) = dirty $SomeWhere m [Abstract noRange ds]
-
- privateBlock _ [] = return []
- privateBlock r ds = do
- let (ds', anyChange) = runChange $ mapM mkPrivate ds
- if anyChange then return ds' else throwError $ UselessPrivate r
-
- -- Make a declaration private.
- -- Andreas, 2012-11-17:
- -- Mark computation 'dirty' if there was a declaration that could be privatized.
- -- If no privatization is taking place, we want to complain about 'UselessPrivate'.
- -- Alternatively, we could only dirty if a non-private thing was privatized.
- -- Then, nested 'private's would sometimes also be complained about.
- mkPrivate :: Updater NiceDeclaration
- mkPrivate d =
- case d of
- Axiom r f p i rel x e -> (\ p -> Axiom r f p i rel x e) <$> setPrivate p
- NiceField r i f p a x e -> (\ p -> NiceField r i f p a x e) <$> setPrivate p
- PrimitiveFunction r f p a x e -> (\ p -> PrimitiveFunction r f p a x e) <$> setPrivate p
- NiceMutual r termCheck pc ds -> NiceMutual r termCheck pc <$> mapM mkPrivate ds
- NiceModule r p a x tel ds -> (\ p -> NiceModule r p a x tel ds) <$> setPrivate p
- NiceModuleMacro r p x ma op is -> (\ p -> NiceModuleMacro r p x ma op is) <$> setPrivate p
- FunSig r f p i m rel tc x e -> (\ p -> FunSig r f p i m rel tc x e) <$> setPrivate p
- NiceRecSig r f p x ls t pc -> (\ p -> NiceRecSig r f p x ls t pc) <$> setPrivate p
- NiceDataSig r f p x ls t pc -> (\ p -> NiceDataSig r f p x ls t pc) <$> setPrivate p
- NiceFunClause r p a termCheck catchall d -> (\ p -> NiceFunClause r p a termCheck catchall d) <$> setPrivate p
- NiceUnquoteDecl r f p i a t x e -> (\ p -> NiceUnquoteDecl r f p i a t x e) <$> setPrivate p
- NiceUnquoteDef r f p a t x e -> (\ p -> NiceUnquoteDef r f p a t x e) <$> setPrivate p
- NicePragma _ _ -> return $ d
- NiceOpen _ _ _ -> return $ d
- NiceImport _ _ _ _ _ -> return $ d
- FunDef{} -> return $ d
- DataDef{} -> return $ d
- RecDef{} -> return $ d
- NicePatternSyn _ _ _ _ _ -> return $ d
-
- setPrivate :: Updater Access
- setPrivate p = case p of
- PrivateAccess -> return p
- _ -> dirty $ PrivateAccess
-
- -- Andreas, 2012-11-22: Q: is this necessary?
- -- Are where clauses not always private?
- mkPrivateClause :: Updater Clause
- mkPrivateClause (Clause x catchall lhs rhs wh with) = do
- wh <- mkPrivateWhere wh
- Clause x catchall lhs rhs wh <$> mapM mkPrivateClause with
-
- mkPrivateWhere :: Updater WhereClause
- mkPrivateWhere NoWhere = return $ NoWhere
- mkPrivateWhere (AnyWhere ds) = dirty $ AnyWhere [Private (getRange ds) ds]
- mkPrivateWhere (SomeWhere m ds) = dirty $ SomeWhere m [Private (getRange ds) ds]
+ privateBlock _ _ [] = return []
+ privateBlock r o ds = do
+ let (ds', anyChange) = runChange $ mkPrivate o ds
+ if anyChange then return ds' else
+ if o == UserWritten then throwError $ UselessPrivate r else return ds -- no change!
instanceBlock _ [] = return []
instanceBlock r ds = do
@@ -1182,9 +1233,9 @@ niceDeclarations ds = do
mkInstance :: Updater NiceDeclaration
mkInstance d =
case d of
- Axiom r f p i rel x e -> (\ i -> Axiom r f p i rel x e) <$> setInstance i
- FunSig r f p i m rel tc x e -> (\ i -> FunSig r f p i m rel tc x e) <$> setInstance i
- NiceUnquoteDecl r f p i a tc x e -> (\ i -> NiceUnquoteDecl r f p i a tc x e) <$> setInstance i
+ Axiom r f p a i rel mp x e -> (\ i -> Axiom r f p a i rel mp x e) <$> setInstance i
+ FunSig r f p a i m rel tc x e -> (\ i -> FunSig r f p a i m rel tc x e) <$> setInstance i
+ NiceUnquoteDecl r f p a i tc x e -> (\ i -> NiceUnquoteDecl r f p a i tc x e) <$> setInstance i
NiceMutual{} -> return d
NiceFunClause{} -> return d
FunDef{} -> return d
@@ -1212,10 +1263,142 @@ niceDeclarations ds = do
mkMacro :: NiceDeclaration -> Nice NiceDeclaration
mkMacro d =
case d of
- FunSig r f p i _ rel tc x e -> return $ FunSig r f p i MacroDef rel tc x e
+ FunSig r f p a i _ rel tc x e -> return $ FunSig r f p a i MacroDef rel tc x e
FunDef{} -> return d
_ -> throwError (BadMacroDef d)
+-- | Make a declaration abstract.
+--
+-- Mark computation as 'dirty' if there was a declaration that could be made abstract.
+-- If no abstraction is taking place, we want to complain about 'UselessAbstract'.
+--
+-- Alternatively, we could only flag 'dirty' if a non-abstract thing was abstracted.
+-- Then, nested @abstract@s would sometimes also be complained about.
+
+class MakeAbstract a where
+ mkAbstract :: Updater a
+ default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => Updater a
+ mkAbstract = traverse mkAbstract
+
+instance MakeAbstract a => MakeAbstract [a] where
+ -- Default definition kicks in here!
+ -- But note that we still have to declare the instance!
+
+-- Leads to overlap with 'WhereClause':
+-- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where
+-- mkAbstract = traverse mkAbstract
+
+instance MakeAbstract IsAbstract where
+ mkAbstract a = case a of
+ AbstractDef -> return a
+ ConcreteDef -> dirty $ AbstractDef
+
+instance MakeAbstract NiceDeclaration where
+ mkAbstract d =
+ case d of
+ NiceMutual r termCheck pc ds -> NiceMutual r termCheck pc <$> mkAbstract ds
+ FunDef r ds f a tc x cs -> (\ a -> FunDef r ds f a tc x) <$> mkAbstract a <*> mkAbstract cs
+ DataDef r f a pc x ps cs -> (\ a -> DataDef r f a pc x ps) <$> mkAbstract a <*> mkAbstract cs
+ RecDef r f a pc x i e c ps cs -> (\ a -> RecDef r f a pc x i e c ps) <$> mkAbstract a <*> mkAbstract cs
+ NiceFunClause r p a termCheck catchall d -> (\ a -> NiceFunClause r p a termCheck catchall d) <$> mkAbstract a
+ -- The following declarations have an @InAbstract@ field
+ -- but are not really definitions, so we do count them into
+ -- the declarations which can be made abstract
+ -- (thus, do not notify progress with @dirty@).
+ Axiom r f p a i rel mp x e -> return $ Axiom r f p AbstractDef i rel mp x e
+ FunSig r f p a i m rel tc x e -> return $ FunSig r f p AbstractDef i m rel tc x e
+ NiceRecSig r f p a pc x ls t -> return $ NiceRecSig r f p AbstractDef pc x ls t
+ NiceDataSig r f p a pc x ls t -> return $ NiceDataSig r f p AbstractDef pc x ls t
+ NiceField r f p _ i x e -> return $ NiceField r f p AbstractDef i x e
+ PrimitiveFunction r f p _ x e -> return $ PrimitiveFunction r f p AbstractDef x e
+ -- Andreas, 2016-07-17 it does have effect on unquoted defs.
+ -- Need to set updater state to dirty!
+ NiceUnquoteDecl r f p _ i t x e -> dirty $ NiceUnquoteDecl r f p AbstractDef i t x e
+ NiceUnquoteDef r f p _ t x e -> dirty $ NiceUnquoteDef r f p AbstractDef t x e
+ NiceModule{} -> return d
+ NiceModuleMacro{} -> return d
+ NicePragma{} -> return d
+ NiceOpen{} -> return d
+ NiceImport{} -> return d
+ NicePatternSyn{} -> return d
+
+instance MakeAbstract Clause where
+ mkAbstract (Clause x catchall lhs rhs wh with) = do
+ Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with
+
+-- | Contents of a @where@ clause are abstract if the parent is.
+instance MakeAbstract WhereClause where
+ mkAbstract NoWhere = return $ NoWhere
+ mkAbstract (AnyWhere ds) = dirty $ AnyWhere [Abstract noRange ds]
+ mkAbstract (SomeWhere m a ds) = dirty $ SomeWhere m a [Abstract noRange ds]
+
+-- | Make a declaration private.
+--
+-- Andreas, 2012-11-17:
+-- Mark computation as 'dirty' if there was a declaration that could be privatized.
+-- If no privatization is taking place, we want to complain about 'UselessPrivate'.
+--
+-- Alternatively, we could only flag 'dirty' if a non-private thing was privatized.
+-- Then, nested @private@s would sometimes also be complained about.
+
+class MakePrivate a where
+ mkPrivate :: Origin -> Updater a
+ default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> Updater a
+ mkPrivate o = traverse $ mkPrivate o
+
+instance MakePrivate a => MakePrivate [a] where
+ -- Default definition kicks in here!
+ -- But note that we still have to declare the instance!
+
+-- Leads to overlap with 'WhereClause':
+-- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where
+-- mkPrivate = traverse mkPrivate
+
+instance MakePrivate Access where
+ mkPrivate o p = case p of
+ PrivateAccess{} -> return p -- OR? return $ PrivateAccess o
+ _ -> dirty $ PrivateAccess o
+
+instance MakePrivate NiceDeclaration where
+ mkPrivate o d =
+ case d of
+ Axiom r f p a i rel mp x e -> (\ p -> Axiom r f p a i rel mp x e) <$> mkPrivate o p
+ NiceField r f p a i x e -> (\ p -> NiceField r f p a i x e) <$> mkPrivate o p
+ PrimitiveFunction r f p a x e -> (\ p -> PrimitiveFunction r f p a x e) <$> mkPrivate o p
+ NiceMutual r termCheck pc ds -> (\ p -> NiceMutual r termCheck pc p) <$> mkPrivate o ds
+ NiceModule r p a x tel ds -> (\ p -> NiceModule r p a x tel ds) <$> mkPrivate o p
+ NiceModuleMacro r p x ma op is -> (\ p -> NiceModuleMacro r p x ma op is) <$> mkPrivate o p
+ FunSig r f p a i m rel tc x e -> (\ p -> FunSig r f p a i m rel tc x e) <$> mkPrivate o p
+ NiceRecSig r f p a pc x ls t -> (\ p -> NiceRecSig r f p a pc x ls t) <$> mkPrivate o p
+ NiceDataSig r f p a pc x ls t -> (\ p -> NiceDataSig r f p a pc x ls t) <$> mkPrivate o p
+ NiceFunClause r p a termCheck catchall d -> (\ p -> NiceFunClause r p a termCheck catchall d) <$> mkPrivate o p
+ NiceUnquoteDecl r f p a i t x e -> (\ p -> NiceUnquoteDecl r f p a i t x e) <$> mkPrivate o p
+ NiceUnquoteDef r f p a t x e -> (\ p -> NiceUnquoteDef r f p a t x e) <$> mkPrivate o p
+ NicePragma _ _ -> return $ d
+ NiceOpen _ _ _ -> return $ d
+ NiceImport _ _ _ _ _ -> return $ d
+ -- Andreas, 2016-07-08, issue #2089
+ -- we need to propagate 'private' to the named where modules
+ FunDef r ds f a tc x cls -> FunDef r ds f a tc x <$> mkPrivate o cls
+ DataDef{} -> return $ d
+ RecDef{} -> return $ d
+ NicePatternSyn _ _ _ _ _ -> return $ d
+
+instance MakePrivate Clause where
+ mkPrivate o (Clause x catchall lhs rhs wh with) = do
+ Clause x catchall lhs rhs <$> mkPrivate o wh <*> mkPrivate o with
+
+instance MakePrivate WhereClause where
+ mkPrivate o NoWhere = return $ NoWhere
+ -- @where@-declarations are protected behind an anonymous module,
+ -- thus, they are effectively private by default.
+ mkPrivate o (AnyWhere ds) = return $ AnyWhere ds
+ -- Andreas, 2016-07-08
+ -- A @where@-module is private if the parent function is private.
+ -- The contents of this module are not private, unless declared so!
+ -- Thus, we do not recurse into the @ds@ (could not anyway).
+ mkPrivate o (SomeWhere m a ds) = mkPrivate o a <&> \ a' -> SomeWhere m a' ds
+
-- | Add more fixities. Throw an exception for multiple fixity declarations.
-- OR: Disjoint union of fixity maps. Throws exception if not disjoint.
@@ -1227,7 +1410,7 @@ plusFixities m1 m2
| otherwise = return $ Map.unionWithKey mergeFixites m1 m2
where
-- Merge two fixities, assuming there is no conflict
- mergeFixites name (Fixity' f1 s1) (Fixity' f2 s2) = Fixity' f s
+ mergeFixites name (Fixity' f1 s1 r1) (Fixity' f2 s2 r2) = Fixity' f s $ fuseRange r1 r2
where f | f1 == noFixity = f2
| f2 == noFixity = f1
| otherwise = __IMPOSSIBLE__
@@ -1240,32 +1423,54 @@ plusFixities m1 m2
| (x, False) <- Map.assocs $ Map.intersectionWith compatible m1 m2 ]
-- Check for no conflict.
- compatible (Fixity' f1 s1) (Fixity' f2 s2) = (f1 == noFixity || f2 == noFixity) &&
- (s1 == noNotation || s2 == noNotation)
+ compatible (Fixity' f1 s1 _) (Fixity' f2 s2 _) =
+ (f1 == noFixity || f2 == noFixity ) &&
+ (s1 == noNotation || s2 == noNotation)
+
+-- | While 'Fixities' and Polarities are not semigroups under disjoint
+-- union (which might fail), we get a semigroup instance for the
+-- monadic @Nice (Fixities, Polarities)@ which propagates the first
+-- error.
+instance Semigroup (Nice (Fixities, Polarities)) where
+ c1 <> c2 = do
+ (f1, p1) <- c1
+ (f2, p2) <- c2
+ f <- plusFixities f1 f2
+ p <- mergePolarities p1 p2
+ return (f, p)
+ where
+ mergePolarities p1 p2
+ | Set.null i = return (Map.union p1 p2)
+ | otherwise = throwError $ MultiplePolarityPragmas (Set.toList i)
+ where
+ i = Set.intersection (Map.keysSet p1) (Map.keysSet p2)
--- | While 'Fixities' is not a monoid under disjoint union (which might fail),
--- we get the monoid instance for the monadic @Nice Fixities@ which propagates
--- the first error.
-instance Monoid (Nice Fixities) where
- mempty = return $ Map.empty
- mappend c1 c2 = plusFixities ==<< (c1, c2)
+instance Monoid (Nice (Fixities, Polarities)) where
+ mempty = return (Map.empty, Map.empty)
+ mappend = (<>)
--- | Get the fixities from the current block.
+-- | Get the fixities and polarity pragmas from the current block.
-- Doesn't go inside modules and where blocks.
--- The reason for this is that fixity declarations have to appear at the same
--- level (or possibly outside an abstract or mutual block) as its target
+-- The reason for this is that these declarations have to appear at the same
+-- level (or possibly outside an abstract or mutual block) as their target
-- declaration.
-fixities :: [Declaration] -> Nice Fixities
-fixities = foldMap $ \ d -> case d of
+fixitiesAndPolarities :: [Declaration] -> Nice (Fixities, Polarities)
+fixitiesAndPolarities = foldMap $ \ d -> case d of
+ -- These declarations define polarities:
+ Pragma (PolarityPragma _ x occs) -> return (Map.empty, Map.singleton x occs)
-- These declarations define fixities:
- Syntax x syn -> return $ Map.singleton x $ Fixity' noFixity syn
- Infix f xs -> return $ Map.fromList $ map (,Fixity' f noNotation) xs
+ Syntax x syn -> return ( Map.singleton x (Fixity' noFixity syn $ getRange x)
+ , Map.empty
+ )
+ Infix f xs -> return ( Map.fromList $ for xs $ \ x -> (x, Fixity' f noNotation$ getRange x)
+ , Map.empty
+ )
-- We look into these blocks:
- Mutual _ ds' -> fixities ds'
- Abstract _ ds' -> fixities ds'
- Private _ ds' -> fixities ds'
- InstanceB _ ds' -> fixities ds'
- Macro _ ds' -> fixities ds'
+ Mutual _ ds' -> fixitiesAndPolarities ds'
+ Abstract _ ds' -> fixitiesAndPolarities ds'
+ Private _ _ ds' -> fixitiesAndPolarities ds'
+ InstanceB _ ds' -> fixitiesAndPolarities ds'
+ Macro _ ds' -> fixitiesAndPolarities ds'
-- All other declarations are ignored.
-- We expand these boring cases to trigger a revisit
-- in case the @Declaration@ type is extended in the future.
@@ -1288,42 +1493,47 @@ fixities = foldMap $ \ d -> case d of
Pragma {} -> mempty
--- Andreas, 2012-04-07
--- The following function is only used twice, for building a Let, and for
--- printing an error message.
+-- The following function is (at the time of writing) only used three
+-- times: for building Lets, and for printing error messages.
--- | (Approximately) convert a 'NiceDeclaration' back to a 'Declaration'.
-notSoNiceDeclaration :: NiceDeclaration -> Declaration
-notSoNiceDeclaration d =
+-- | (Approximately) convert a 'NiceDeclaration' back to a list of
+-- 'Declaration's.
+notSoNiceDeclarations :: NiceDeclaration -> [Declaration]
+notSoNiceDeclarations d =
case d of
- Axiom _ _ _ _ rel x e -> TypeSig rel x e
- NiceField _ i _ _ _ x argt -> Field i x argt
- PrimitiveFunction r _ _ _ x e -> Primitive r [TypeSig defaultArgInfo x e]
- NiceMutual r _ _ ds -> Mutual r $ map notSoNiceDeclaration ds
- NiceModule r _ _ x tel ds -> Module r x tel ds
- NiceModuleMacro r _ x ma o dir -> ModuleMacro r x ma o dir
- NiceOpen r x dir -> Open r x dir
- NiceImport r x as o dir -> Import r x as o dir
- NicePragma _ p -> Pragma p
- NiceRecSig r _ _ x bs e _ -> RecordSig r x bs e
- NiceDataSig r _ _ x bs e _ -> DataSig r Inductive x bs e
- NiceFunClause _ _ _ _ _ d -> d
- FunSig _ _ _ _ _ rel tc x e -> TypeSig rel x e
- FunDef r [d] _ _ _ _ _ -> d
- FunDef r ds _ _ _ _ _ -> Mutual r ds -- Andreas, 2012-04-07 Hack!
- DataDef r _ _ x bs _ cs -> Data r Inductive x bs Nothing $ map notSoNiceDeclaration cs
- RecDef r _ _ x i e c bs _ ds -> Record r x i e (unThing <$> c) bs Nothing $ map notSoNiceDeclaration ds
+ Axiom _ _ _ _ i rel mp x e -> (case mp of
+ Nothing -> []
+ Just occs -> [Pragma (PolarityPragma noRange x occs)]) ++
+ inst i [TypeSig rel x e]
+ NiceField _ _ _ _ i x argt -> [Field i x argt]
+ PrimitiveFunction r _ _ _ x e -> [Primitive r [TypeSig defaultArgInfo x e]]
+ NiceMutual r _ _ ds -> [Mutual r $ concatMap notSoNiceDeclarations ds]
+ NiceModule r _ _ x tel ds -> [Module r x tel ds]
+ NiceModuleMacro r _ x ma o dir -> [ModuleMacro r x ma o dir]
+ NiceOpen r x dir -> [Open r x dir]
+ NiceImport r x as o dir -> [Import r x as o dir]
+ NicePragma _ p -> [Pragma p]
+ NiceRecSig r _ _ _ _ x bs e -> [RecordSig r x bs e]
+ NiceDataSig r _ _ _ _ x bs e -> [DataSig r Inductive x bs e]
+ NiceFunClause _ _ _ _ _ d -> [d]
+ FunSig _ _ _ _ i _ rel tc x e -> inst i [TypeSig rel x e]
+ FunDef _r ds _ _ _ _ _ -> ds
+ DataDef r _ _ _ x bs cs -> [Data r Inductive x bs Nothing $ concatMap notSoNiceDeclarations cs]
+ RecDef r _ _ _ x i e c bs ds -> [Record r x i e (unThing <$> c) bs Nothing $ concatMap notSoNiceDeclarations ds]
where unThing (ThingWithFixity c _, inst) = (c, inst)
- NicePatternSyn r _ n as p -> PatternSyn r n as p
- NiceUnquoteDecl r _ _ _ _ _ x e -> UnquoteDecl r x e
- NiceUnquoteDef r _ _ _ _ x e -> UnquoteDef r x e
+ NicePatternSyn r _ n as p -> [PatternSyn r n as p]
+ NiceUnquoteDecl r _ _ _ i _ x e -> inst i [UnquoteDecl r x e]
+ NiceUnquoteDef r _ _ _ _ x e -> [UnquoteDef r x e]
+ where
+ inst InstanceDef ds = [InstanceB (getRange ds) ds]
+ inst NotInstanceDef ds = ds
-- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?
niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract
niceHasAbstract d =
case d of
Axiom{} -> Nothing
- NiceField _ _ _ _ a _ _ -> Just a
+ NiceField _ _ _ a _ _ _ -> Just a
PrimitiveFunction _ _ _ a _ _ -> Just a
NiceMutual{} -> Nothing
NiceModule _ _ a _ _ _ -> Just a
@@ -1339,5 +1549,5 @@ niceHasAbstract d =
DataDef _ _ a _ _ _ _ -> Just a
RecDef _ _ a _ _ _ _ _ _ _ -> Just a
NicePatternSyn{} -> Nothing
- NiceUnquoteDecl _ _ _ _ a _ _ _ -> Just a
+ NiceUnquoteDecl _ _ _ a _ _ _ _ -> Just a
NiceUnquoteDef _ _ _ a _ _ _ -> Just a
diff --git a/src/full/Agda/Syntax/Concrete/Generic.hs b/src/full/Agda/Syntax/Concrete/Generic.hs
index f9066e3..66990ad 100644
--- a/src/full/Agda/Syntax/Concrete/Generic.hs
+++ b/src/full/Agda/Syntax/Concrete/Generic.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-- | Generic traversal and reduce for concrete syntax,
-- in the style of "Agda.Syntax.Internal.Generic".
@@ -143,6 +142,7 @@ instance ExprLike Expr where
RecUpdate r e es -> f $ RecUpdate r (mapE e) $ mapE es
Let r ds e -> f $ Let r (mapE ds) $ mapE e
Paren r e -> f $ Paren r $ mapE e
+ IdiomBrackets r e -> f $ IdiomBrackets r $ mapE e
Absurd{} -> f $ e0
As r x e -> f $ As r x $ mapE e
Dot r e -> f $ Dot r $ mapE e
@@ -210,7 +210,7 @@ instance ExprLike Declaration where
PatternSyn{} -> e0
Mutual r ds -> Mutual r $ mapE ds
Abstract r ds -> Abstract r $ mapE ds
- Private r ds -> Private r $ mapE ds
+ Private r o ds -> Private r o $ mapE ds
InstanceB r ds -> InstanceB r $ mapE ds
Macro r ds -> Macro r $ mapE ds
Postulate r ds -> Postulate r $ mapE ds
diff --git a/src/full/Agda/Syntax/Concrete/Name.hs b/src/full/Agda/Syntax/Concrete/Name.hs
index df2a945..0a22253 100644
--- a/src/full/Agda/Syntax/Concrete/Name.hs
+++ b/src/full/Agda/Syntax/Concrete/Name.hs
@@ -1,9 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| Names in the concrete syntax are just strings (or lists of strings for
qualified names).
@@ -21,12 +19,12 @@ import GHC.Generics (Generic)
import System.FilePath
-import Test.QuickCheck
-
import Agda.Syntax.Common
import Agda.Syntax.Position
+
import Agda.Utils.FileName
import Agda.Utils.Pretty
+import Agda.Utils.Size
#include "undefined.h"
import Agda.Utils.Impossible
@@ -111,7 +109,7 @@ instance Underscore QName where
newtype TopLevelModuleName
= TopLevelModuleName { moduleNameParts :: [String] }
- deriving (Show, Eq, Ord, Typeable)
+ deriving (Show, Eq, Ord, Typeable, Sized)
------------------------------------------------------------------------
-- * Operations on 'Name' and 'NamePart'
@@ -202,6 +200,17 @@ qnameParts (QName x) = [x]
toTopLevelModuleName :: QName -> TopLevelModuleName
toTopLevelModuleName = TopLevelModuleName . map prettyShow . qnameParts
+-- | Turns a top level module into a qualified name with 'noRange'.
+
+fromTopLevelModuleName :: TopLevelModuleName -> QName
+fromTopLevelModuleName (TopLevelModuleName []) = __IMPOSSIBLE__
+fromTopLevelModuleName (TopLevelModuleName (x:xs)) = loop x xs
+ where
+ loop x [] = QName (mk x)
+ loop x (y : ys) = Qual (mk x) $ loop y ys
+ mk :: String -> Name
+ mk x = Name noRange [Id x]
+
-- | Turns a top-level module name into a file name with the given
-- suffix.
@@ -250,6 +259,7 @@ instance IsNoName Name where
isNoName (NoName _ _) = True
isNoName (Name _ [Hole]) = True -- TODO: Track down where these come from
isNoName (Name _ []) = True
+ isNoName (Name _ [Id x]) = isNoName x
isNoName _ = False
instance IsNoName QName where
@@ -292,44 +302,15 @@ instance Pretty NamePart where
pretty (Id s) = text $ rawNameToString s
instance Pretty QName where
- pretty (Qual m x) = pretty m <> pretty "." <> pretty x
+ pretty (Qual m x)
+ | isUnderscore m = pretty x -- don't print anonymous modules
+ | otherwise = pretty m <> pretty "." <> pretty x
pretty (QName x) = pretty x
instance Pretty TopLevelModuleName where
pretty (TopLevelModuleName ms) = text $ intercalate "." ms
------------------------------------------------------------------------
--- * QuickCheck instances
-------------------------------------------------------------------------
-
-instance Arbitrary TopLevelModuleName where
- arbitrary = TopLevelModuleName <$> listOf1 (listOf1 $ elements "AB")
-
-instance CoArbitrary TopLevelModuleName where
- coarbitrary (TopLevelModuleName m) = coarbitrary m
-
-instance Arbitrary Name where
- arbitrary = oneof
- [ Name <$> arbitrary <*> parts
- , NoName <$> arbitrary <*> arbitrary
- ]
- where
- parts = do
- parts <- listOf1 (elements ["x", "y", "z"])
- startWithHole <- arbitrary
- endWithHole <- arbitrary
- return $
- (if startWithHole then (Hole :) else id) $
- (if endWithHole then (++ [Hole]) else id) $
- intersperse Hole (map Id parts)
-
-instance CoArbitrary NamePart
-
-instance CoArbitrary Name where
- coarbitrary (Name _ ns) = variant 0 . coarbitrary ns
- coarbitrary (NoName _ i) = variant 1 . coarbitrary i
-
-------------------------------------------------------------------------
-- * Range instances
------------------------------------------------------------------------
diff --git a/src/full/Agda/Syntax/Concrete/Operators.hs b/src/full/Agda/Syntax/Concrete/Operators.hs
index 246ce8f..5b4210c 100644
--- a/src/full/Agda/Syntax/Concrete/Operators.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -40,6 +39,7 @@ import Agda.Syntax.Concrete.Pretty ()
import Agda.Syntax.Common
import Agda.Syntax.Concrete hiding (appView)
import Agda.Syntax.Concrete.Operators.Parser
+import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse)
import qualified Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Position
import Agda.Syntax.Fixity
@@ -53,7 +53,6 @@ import Agda.TypeChecking.Monad.State (getScope)
import Agda.TypeChecking.Monad.Options
import Agda.Utils.Either
-import Agda.Utils.Parser.MemoisedCPS (memoise)
import Agda.Utils.Pretty
#if MIN_VERSION_base(4,8,0)
import Agda.Utils.List hiding ( uncons )
@@ -346,44 +345,49 @@ buildParsers r flat kind exprNames = do
, "relatedOperators = " ++ show relatedOperators
]
- return (parseSections, everything, Data.Function.fix $ \p -> Parsers
- { pTop = memoise TopK $
- Fold.asum $
- foldr ($) (pApp p)
- (map (\(l, ns) higher ->
- mkP (Right l) parseSections
- (pTop p) ns higher True)
- relatedOperators) :
- map (\(k, n) ->
- mkP (Left k) parseSections
- (pTop p) [n] (pApp p) False)
- (zip [0..] unrelatedOperators)
- , pApp = memoise AppK $ appP (pNonfix p) (pArgs p)
- , pArgs = argsP (pNonfix p)
- , pNonfix = memoise NonfixK $
- Fold.asum $
- pAtom p :
- flip map nonWithSections (\sect ->
- let n = sectNotation sect
-
- inner :: forall k. NK k ->
- Parser e (OperatorType k e)
- inner = opP parseSections (pTop p) n
- in
- case notationKind (notation n) of
- InfixNotation ->
- flip ($) <$> placeholder Beginning
- <*> inner In
- <*> placeholder End
- PrefixNotation ->
- inner Pre <*> placeholder End
- PostfixNotation ->
- flip ($) <$> placeholder Beginning
- <*> inner Post
- NonfixNotation -> inner Non
- NoNotation -> __IMPOSSIBLE__)
- , pAtom = atomP isAtom
- })
+ let g = Data.Function.fix $ \p -> Parsers
+ { pTop = memoise TopK $
+ Fold.asum $
+ foldr ($) (pApp p)
+ (map (\(l, ns) higher ->
+ mkP (Right l) parseSections
+ (pTop p) ns higher True)
+ relatedOperators) :
+ map (\(k, n) ->
+ mkP (Left k) parseSections
+ (pTop p) [n] (pApp p) False)
+ (zip [0..] unrelatedOperators)
+ , pApp = memoise AppK $ appP (pNonfix p) (pArgs p)
+ , pArgs = argsP (pNonfix p)
+ , pNonfix = memoise NonfixK $
+ Fold.asum $
+ pAtom p :
+ flip map nonWithSections (\sect ->
+ let n = sectNotation sect
+
+ inner :: forall k. NK k ->
+ Parser e (OperatorType k e)
+ inner = opP parseSections (pTop p) n
+ in
+ case notationKind (notation n) of
+ InfixNotation ->
+ flip ($) <$> placeholder Beginning
+ <*> inner In
+ <*> placeholder End
+ PrefixNotation ->
+ inner Pre <*> placeholder End
+ PostfixNotation ->
+ flip ($) <$> placeholder Beginning
+ <*> inner Post
+ NonfixNotation -> inner Non
+ NoNotation -> __IMPOSSIBLE__)
+ , pAtom = atomP isAtom
+ }
+
+ reportSDoc "scope.grammar" 10 $ return $
+ text "Operator grammar:" $$ nest 2 (grammar (pTop g))
+
+ return (parseSections, everything, g)
where
level :: NewNotation -> PrecedenceLevel
level = fixityLevel . notaFixity
@@ -451,11 +455,11 @@ buildParsers r flat kind exprNames = do
nonAssoc :: Maybe (Parser e e)
nonAssoc = case filter (isInfix NonAssoc) ops of
[] -> Nothing
- ops -> Just $ do
- x <- noPlaceholder <$> higher
- f <- choice In ops
- y <- noPlaceholder <$> higher
- return (f x y)
+ ops -> Just $
+ (\x f y -> f (noPlaceholder x) (noPlaceholder y))
+ <$> higher
+ <*> choice In ops
+ <*> higher
or p1 [] p2 [] = Nothing
or p1 [] p2 ops2 = Just (p2 ops2)
@@ -474,7 +478,8 @@ buildParsers r flat kind exprNames = do
preRights = do
preRight <- preRight
return $ Data.Function.fix $ \preRights ->
- preRight <*> (noPlaceholder <$> (preRights <|> higher))
+ memoiseIfPrinting (PreRightsK key) $
+ preRight <*> (noPlaceholder <$> (preRights <|> higher))
postLeft :: Maybe (Parser e (MaybePlaceholder e -> e))
postLeft =
@@ -524,7 +529,7 @@ parsePat prs p = case p of
HiddenP _ _ -> fail "bad hidden argument"
InstanceP _ _ -> fail "bad instance argument"
AsP r x p -> AsP r x <$> parsePat prs p
- DotP r e -> return $ DotP r e
+ DotP r o e -> return $ DotP r o e
ParenP r p -> fullParen' <$> parsePat prs p
WildP _ -> return p
AbsurdP _ -> return p
@@ -578,6 +583,8 @@ type ParseLHS = Either Pattern (QName, LHSCore)
parseLHS' ::
LHSOrPatSyn -> Maybe QName -> Pattern ->
ScopeM (ParseLHS, [NotationSection])
+parseLHS' IsLHS (Just qn) (RawAppP _ [WildP{}]) =
+ return (Right (qn, LHSHead qn []), [])
parseLHS' lhsOrPatSyn top p = do
let names = patternQNames p
ms = qualifierModules names
diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
index 79596b7..b8a15fc 100644
--- a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -15,7 +13,7 @@ import Data.Maybe
import qualified Data.Strict.Maybe as Strict
import Data.Set (Set)
-import GHC.Generics (Generic)
+import Text.PrettyPrint.HughesPJ hiding (empty)
import Agda.Syntax.Position
import qualified Agda.Syntax.Abstract.Name as A
@@ -23,28 +21,16 @@ import Agda.Syntax.Common
import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Concrete
-
-import qualified Agda.Utils.Parser.MemoisedCPS as MemoisedCPS
-import Agda.Utils.Parser.MemoisedCPS hiding (Parser, parse)
-import qualified Agda.Utils.Parser.MemoisedCPS as Parser
+import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse)
+import qualified Agda.Syntax.Concrete.Operators.Parser.Monad as P
#include "undefined.h"
import Agda.Utils.Impossible
-data MemoKey = NodeK (Either Integer Integer)
- | PostLeftsK (Either Integer Integer)
- | TopK
- | AppK
- | NonfixK
- deriving (Eq, Generic)
-
-instance Hashable MemoKey
-
-type Parser tok a =
- MemoisedCPS.Parser MemoKey tok (MaybePlaceholder tok) a
-
placeholder :: PositionInName -> Parser e (MaybePlaceholder e)
-placeholder p = sat $ \t ->
+placeholder p =
+ annotate (const $ text ("_" ++ show p)) $
+ sat $ \t ->
case t of
Placeholder p' | p' == p -> True
_ -> False
@@ -150,9 +136,8 @@ data ParseSections = ParseSections | DoNotParseSections
-- within their respective identifiers.
parse :: IsExpr e => (ParseSections, Parser e a) -> [e] -> [a]
-parse (DoNotParseSections, p) es = Parser.parse p (map noPlaceholder es)
-parse (ParseSections, p) es = Parser.parse p
- (concat $ map splitExpr es)
+parse (DoNotParseSections, p) es = P.parse p (map noPlaceholder es)
+parse (ParseSections, p) es = P.parse p (concat $ map splitExpr es)
where
splitExpr :: IsExpr e => e -> [MaybePlaceholder e]
splitExpr e = case exprView e of
@@ -194,7 +179,7 @@ parse (ParseSections, p) es = Parser.parse p
-- | Parse a specific identifier as a NamePart
partP :: IsExpr e => [Name] -> RawName -> Parser e Range
-partP ms s = do
+partP ms s = annotate (const $ text (show str)) $ do
tok <- notPlaceholder
case isLocal tok of
Just p -> return p
@@ -277,9 +262,9 @@ data NK (k :: NotationKind) :: * where
opP :: forall e k. IsExpr e
=> ParseSections
-> Parser e e -> NewNotation -> NK k -> Parser e (OperatorType k e)
-opP parseSections p (NewNotation q names _ syn isOp) kind = do
-
- (range, hs) <- worker (init $ qnameParts q) withoutExternalHoles
+opP parseSections p (NewNotation q names _ syn isOp) kind =
+ flip fmap (worker (init $ qnameParts q)
+ withoutExternalHoles) $ \(range, hs) ->
let (normal, binders) = partitionEithers hs
lastHole = maximum $ mapMaybe holeTarget syn
@@ -299,8 +284,9 @@ opP parseSections p (NewNotation q names _ syn isOp) kind = do
where
args = map (findExprFor (f normal) binders) [0..lastHole]
q' = setRange range q
+ in
- return $ case kind of
+ case kind of
In -> \x y -> app (\es -> (x, leadingHole) : es ++ [(y, trailingHole)])
Pre -> \ y -> app (\es -> es ++ [(y, trailingHole)])
Post -> \x -> app (\es -> (x, leadingHole) : es)
@@ -325,32 +311,31 @@ opP parseSections p (NewNotation q names _ syn isOp) kind = do
Parser e (Range, [Either (MaybePlaceholder e, NamedArg Int)
(LamBinding, Int)])
worker ms [] = return (noRange, [])
- worker ms (IdPart x : xs) = do
- r1 <- partP ms x
- (r2, es) <- worker [] xs
- -- Only the first
- -- part is qualified.
- return (fuseRanges r1 r2, es)
- worker ms (NormalHole h : xs) = do
- e <- maybePlaceholder
- (if isOp && parseSections == ParseSections
- then Just Middle else Nothing)
- p
- (r, es) <- worker ms xs
- return (r, Left (e, h) : es)
- worker ms (WildHole h : xs) = do
- (r, es) <- worker ms xs
- return (r, Right (mkBinding h $ Name noRange [Hole]) : es)
+ worker ms (IdPart x : xs) =
+ (\r1 (r2, es) -> (fuseRanges r1 r2, es))
+ <$> partP ms x
+ <*> worker [] xs
+ -- Only the first part is qualified.
+ worker ms (NormalHole h : xs) =
+ (\e (r, es) -> (r, Left (e, h) : es))
+ <$> maybePlaceholder
+ (if isOp && parseSections == ParseSections
+ then Just Middle else Nothing)
+ p
+ <*> worker ms xs
+ worker ms (WildHole h : xs) =
+ (\(r, es) -> (r, Right (mkBinding h $ Name noRange [Hole]) : es))
+ <$> worker ms xs
worker ms (BindHole h : xs) = do
- e <- wildOrUnqualifiedName
- case e of
- Just name -> ret name
- Nothing -> ret (Name noRange [Hole])
- where
- ret x = do
- (r, es) <- worker ms xs
- return (r, Right (mkBinding h x) : es)
- -- Andreas, 2011-04-07 put just 'Relevant' here, is this correct?
+ (\e (r, es) ->
+ let x = case e of
+ Just name -> name
+ Nothing -> Name noRange [Hole]
+ in (r, Right (mkBinding h x) : es))
+ -- Andreas, 2011-04-07 put just 'Relevant' here, is this
+ -- correct?
+ <$> wildOrUnqualifiedName
+ <*> worker ms xs
mkBinding h x = (DomainFree defaultArgInfo $ mkBoundName_ x, h)
@@ -375,7 +360,8 @@ opP parseSections p (NewNotation q names _ syn isOp) kind = do
isPlaceholder Placeholder{} = 1
argsP :: IsExpr e => Parser e e -> Parser e [NamedArg e]
-argsP p = many (nothidden <|> hidden <|> instanceH)
+argsP p = many (annotate (const $ text "<argument>") $
+ nothidden <|> hidden <|> instanceH)
where
isHidden (HiddenArgV _) = True
isHidden _ = False
@@ -399,15 +385,12 @@ argsP p = many (nothidden <|> hidden <|> instanceH)
return $ hide $ defaultArg e
appP :: IsExpr e => Parser e e -> Parser e [NamedArg e] -> Parser e e
-appP p pa = do
- h <- p
- es <- pa
- return $ foldl app h es
+appP p pa = foldl app <$> p <*> pa
where
app e = unExprView . AppV e
atomP :: IsExpr e => (QName -> Bool) -> Parser e e
-atomP p = do
+atomP p = annotate (const $ text "<atom>") $ do
e <- notPlaceholder
case exprView e of
LocalV x | not (p x) -> empty
diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs
new file mode 100644
index 0000000..2c0dfc6
--- /dev/null
+++ b/src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs
@@ -0,0 +1,100 @@
+------------------------------------------------------------------------
+-- | The parser monad used by the operator parser
+------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Agda.Syntax.Concrete.Operators.Parser.Monad
+ ( MemoKey(..)
+ , Parser
+ , parse
+ , token
+ , sat
+ , tok
+ , annotate
+ , memoise
+ , memoiseIfPrinting
+ , grammar
+ ) where
+
+import Data.Hashable
+import GHC.Generics (Generic)
+import Text.PrettyPrint.HughesPJ
+
+import Agda.Syntax.Common
+import qualified Agda.Utils.Parser.MemoisedCPS as Parser
+
+-- | Memoisation keys.
+
+data MemoKey = NodeK (Either Integer Integer)
+ | PostLeftsK (Either Integer Integer)
+ | PreRightsK (Either Integer Integer)
+ | TopK
+ | AppK
+ | NonfixK
+ deriving (Eq, Show, Generic)
+
+instance Hashable MemoKey
+
+-- | The parser monad.
+
+type Parser tok a =
+#ifdef DEBUG
+ Parser.ParserWithGrammar
+#else
+ Parser.Parser
+#endif
+ MemoKey tok (MaybePlaceholder tok) a
+
+-- | Runs the parser.
+
+parse :: forall tok a. Parser tok a -> [MaybePlaceholder tok] -> [a]
+parse = Parser.parse
+
+-- | Parses a single token.
+
+token :: Parser tok (MaybePlaceholder tok)
+token = Parser.token
+
+-- | Parses a token satisfying the given predicate.
+
+sat :: (MaybePlaceholder tok -> Bool) ->
+ Parser tok (MaybePlaceholder tok)
+sat = Parser.sat
+
+-- | Parses a given token.
+
+tok :: (Eq tok, Show tok) =>
+ MaybePlaceholder tok -> Parser tok (MaybePlaceholder tok)
+tok = Parser.tok
+
+-- | Uses the given function to modify the printed representation (if
+-- any) of the given parser.
+
+annotate :: (Doc -> Doc) -> Parser tok a -> Parser tok a
+annotate = Parser.annotate
+
+-- | Memoises the given parser.
+--
+-- Every memoised parser must be annotated with a /unique/ key.
+-- (Parametrised parsers must use distinct keys for distinct inputs.)
+
+memoise :: MemoKey -> Parser tok tok -> Parser tok tok
+memoise = Parser.memoise
+
+-- | Memoises the given parser, but only if printing, not if parsing.
+--
+-- Every memoised parser must be annotated with a /unique/ key.
+-- (Parametrised parsers must use distinct keys for distinct inputs.)
+
+memoiseIfPrinting :: MemoKey -> Parser tok tok -> Parser tok tok
+memoiseIfPrinting = Parser.memoiseIfPrinting
+
+-- | Tries to print the parser, or returns 'empty', depending on the
+-- implementation. This function might not terminate.
+
+grammar :: Parser tok a -> Doc
+grammar = Parser.grammar
diff --git a/src/full/Agda/Syntax/Concrete/Pretty.hs b/src/full/Agda/Syntax/Concrete/Pretty.hs
index 6683057..92922a4 100644
--- a/src/full/Agda/Syntax/Concrete/Pretty.hs
+++ b/src/full/Agda/Syntax/Concrete/Pretty.hs
@@ -1,8 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
{-| Pretty printer for the concrete syntax.
-}
@@ -20,6 +18,9 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Position
+import Agda.TypeChecking.Positivity.Occurrence
+
+import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Null
import Agda.Utils.Pretty
@@ -162,6 +163,7 @@ instance Pretty Expr where
, text "in" <+> pretty e
]
Paren _ e -> parens $ pretty e
+ IdiomBrackets _ e -> text "(|" <+> pretty e <+> text "|)"
As _ x e -> pretty x <> text "@" <> pretty e
Dot _ e -> text "." <> pretty e
Absurd _ -> text "()"
@@ -255,8 +257,9 @@ instance Pretty WhereClause where
pretty (AnyWhere [Module _ x [] ds]) | isNoName (unqualify x)
= vcat [ text "where", nest 2 (vcat $ map pretty ds) ]
pretty (AnyWhere ds) = vcat [ text "where", nest 2 (vcat $ map pretty ds) ]
- pretty (SomeWhere m ds) =
- vcat [ hsep [ text "module", pretty m, text "where" ]
+ pretty (SomeWhere m a ds) =
+ vcat [ hsep $ applyWhen (a == PrivateAccess UserWritten) (text "private" :)
+ [ text "module", pretty m, text "where" ]
, nest 2 (vcat $ map pretty ds)
]
@@ -300,13 +303,16 @@ instance Pretty Declaration where
]
Field inst x (Arg i e) ->
sep [ text "field"
- , nest 2 $ mkInst inst $
+ , nest 2 $ mkInst inst $ mkOverlap i $
prettyRelevance i $ prettyHiding i id $
pretty $ TypeSig (i {argInfoRelevance = Relevant}) x e
]
where
mkInst InstanceDef d = sep [ text "instance", nest 2 d ]
mkInst NotInstanceDef d = d
+
+ mkOverlap i d | argInfoOverlappable i = text "overlap" <+> d
+ | otherwise = d
FunClause lhs rhs wh _ ->
sep [ pretty lhs
, nest 2 $ pretty rhs
@@ -376,7 +382,7 @@ instance Pretty Declaration where
<+> text "=" <+> pretty p
Mutual _ ds -> namedBlock "mutual" ds
Abstract _ ds -> namedBlock "abstract" ds
- Private _ ds -> namedBlock "private" ds
+ Private _ _ ds -> namedBlock "private" ds
InstanceB _ ds -> namedBlock "instance" ds
Macro _ ds -> namedBlock "macro" ds
Postulate _ ds -> namedBlock "postulate" ds
@@ -424,8 +430,8 @@ instance Pretty OpenShortHand where
instance Pretty Pragma where
pretty (OptionsPragma _ opts) = fsep $ map text $ "OPTIONS" : opts
pretty (BuiltinPragma _ b x) = hsep [ text "BUILTIN", text b, pretty x ]
- pretty (RewritePragma _ x) =
- hsep [ text "REWRITE", pretty x ]
+ pretty (RewritePragma _ xs) =
+ hsep [ text "REWRITE", hsep $ map pretty xs ]
pretty (CompiledPragma _ x hs) =
hsep [ text "COMPILED", pretty x, text hs ]
pretty (CompiledExportPragma _ x hs) =
@@ -446,8 +452,6 @@ instance Pretty Pragma where
hsep $ [ text "COMPILED_DATA_UHC", pretty x] ++ map text (crd : crcs)
pretty (HaskellCodePragma _ s) =
vcat (text "HASKELL" : map text (lines s))
- pretty (NoSmashingPragma _ i) =
- hsep $ [text "NO_SMASHING", pretty i]
pretty (StaticPragma _ i) =
hsep $ [text "STATIC", pretty i]
pretty (InlinePragma _ i) =
@@ -468,6 +472,8 @@ instance Pretty Pragma where
pretty (CatchallPragma _) = text "CATCHALL"
pretty (DisplayPragma _ lhs rhs) = text "DISPLAY" <+> sep [ pretty lhs <+> text "=", nest 2 $ pretty rhs ]
pretty (NoPositivityCheckPragma _) = text "NO_POSITIVITY_CHECK"
+ pretty (PolarityPragma _ q occs) =
+ hsep (text "NO_POSITIVITY_CHECK" : pretty q : map pretty occs)
instance Pretty Fixity where
pretty (Fixity _ Unrelated _) = __IMPOSSIBLE__
@@ -478,6 +484,17 @@ instance Pretty Fixity where
RightAssoc -> "infixr"
NonAssoc -> "infix"
+instance Pretty Occurrence where
+ pretty Unused = text "_"
+ pretty Mixed = text "*"
+ pretty JustNeg = text "-"
+ pretty JustPos = text "+"
+ pretty StrictPos = text "++"
+
+ -- No syntax has been assigned to GuardPos.
+
+ pretty GuardPos = __IMPOSSIBLE__
+
instance Pretty GenPart where
pretty (IdPart x) = text x
pretty BindHole{} = underscore
@@ -488,20 +505,20 @@ instance Pretty Notation where
pretty = hcat . map pretty
instance Pretty Fixity' where
- pretty (Fixity' fix nota)
+ pretty (Fixity' fix nota _)
| nota == noNotation = pretty fix
| otherwise = text "syntax" <+> pretty nota
-instance Pretty e => Pretty (Arg e) where
-- Andreas 2010-09-21: do not print relevance in general, only in function types!
-- Andreas 2010-09-24: and in record fields
- pretty a = -- pRelevance r $
- -- TODO guilhem: print colors
- prettyHiding (argInfo a) id $ pretty $ unArg a
+instance Pretty a => Pretty (Arg a) where
+ prettyPrec p (Arg ai e) = prettyHiding ai id $ prettyPrec p' e
+ where p' | getHiding ai == NotHidden = p
+ | otherwise = 0
instance Pretty e => Pretty (Named_ e) where
- pretty (Named Nothing e) = pretty e
- pretty (Named (Just s) e) = sep [ text (rawNameToString $ rangedThing s) <+> text "=", pretty e ]
+ prettyPrec p (Named Nothing e) = prettyPrec p e
+ prettyPrec p (Named (Just s) e) = mparens (p > 0) $ sep [ text (rawNameToString $ rangedThing s) <+> text "=", pretty e ]
instance Pretty [Pattern] where
pretty = fsep . map pretty
@@ -518,7 +535,7 @@ instance Pretty Pattern where
ParenP _ p -> parens $ pretty p
WildP _ -> underscore
AsP _ x p -> pretty x <> text "@" <> pretty p
- DotP _ p -> text "." <> pretty p
+ DotP _ _ p -> text "." <> pretty p
AbsurdP _ -> text "()"
LitP l -> pretty l
QuoteP _ -> text "quote"
diff --git a/src/full/Agda/Syntax/Fixity.hs b/src/full/Agda/Syntax/Fixity.hs
index d83fec0..dd65d28 100644
--- a/src/full/Agda/Syntax/Fixity.hs
+++ b/src/full/Agda/Syntax/Fixity.hs
@@ -1,9 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE PatternGuards #-}
{-| Definitions for fixity, precedence levels, and declared syntax.
-}
@@ -41,8 +37,14 @@ import Agda.Utils.Impossible
data Fixity' = Fixity'
{ theFixity :: !Fixity
, theNotation :: Notation
+ , theNameRange :: Range
+ -- ^ Range of the name in the fixity declaration
+ -- (used for correct highlighting, see issue #2140).
}
- deriving (Typeable, Show, Eq)
+ deriving (Typeable, Show)
+
+instance Eq Fixity' where
+ Fixity' f n _ == Fixity' f' n' _ = f == f' && n == n'
-- | Decorating something with @Fixity'@.
data ThingWithFixity x = ThingWithFixity x Fixity'
@@ -75,7 +77,7 @@ namesToNotation q n = NewNotation
, notation = if null syn then syntaxOf (unqualify q) else syn
, notaIsOperator = null syn
}
- where Fixity' f syn = A.nameFixity n
+ where Fixity' f syn _ = A.nameFixity n
-- | Replace 'noFixity' by 'defaultFixity'.
useDefaultFixity :: NewNotation -> NewNotation
@@ -114,7 +116,7 @@ syntaxOf (Name _ xs) = mkSyn 0 xs
mkSyn n (Id x : xs) = IdPart x : mkSyn n xs
noFixity' :: Fixity'
-noFixity' = Fixity' noFixity noNotation
+noFixity' = Fixity' noFixity noNotation noRange
-- | Merges 'NewNotation's that have the same precedence level and
-- notation, with two exceptions:
@@ -208,7 +210,11 @@ noSection n = NotationSection
-- | Precedence levels for operators.
-data PrecedenceLevel = Unrelated | Related !Integer
+data PrecedenceLevel
+ = Unrelated
+ -- ^ No fixity declared.
+ | Related !Integer
+ -- ^ Fixity level declared as the @Integer@.
deriving (Eq, Ord, Show, Typeable)
-- | Associativity.
@@ -218,11 +224,12 @@ data Associativity = NonAssoc | LeftAssoc | RightAssoc
-- | Fixity of operators.
-data Fixity =
- Fixity { fixityRange :: Range
- , fixityLevel :: !PrecedenceLevel
- , fixityAssoc :: !Associativity
- }
+data Fixity = Fixity
+ { fixityRange :: Range
+ -- ^ Range of the whole fixity declaration.
+ , fixityLevel :: !PrecedenceLevel
+ , fixityAssoc :: !Associativity
+ }
deriving (Typeable, Show)
instance Eq Fixity where
@@ -318,7 +325,7 @@ instance KillRange Fixity where
killRange f = f { fixityRange = noRange }
instance KillRange Fixity' where
- killRange (Fixity' f n) = killRange2 Fixity' f n
+ killRange (Fixity' f n r) = killRange3 Fixity' f n r
instance KillRange x => KillRange (ThingWithFixity x) where
killRange (ThingWithFixity c f) = ThingWithFixity (killRange c) f
@@ -345,7 +352,7 @@ _fixityLevel f r = f (fixityLevel r) <&> \x -> r { fixityLevel = x }
------------------------------------------------------------------------
instance NFData Fixity' where
- rnf (Fixity' _ a) = rnf a
+ rnf (Fixity' _ a _) = rnf a
-- | Ranges are not forced.
diff --git a/src/full/Agda/Syntax/IdiomBrackets.hs b/src/full/Agda/Syntax/IdiomBrackets.hs
new file mode 100644
index 0000000..4fc4121
--- /dev/null
+++ b/src/full/Agda/Syntax/IdiomBrackets.hs
@@ -0,0 +1,48 @@
+module Agda.Syntax.IdiomBrackets (parseIdiomBrackets) where
+
+import Control.Applicative
+import Control.Monad
+
+import Agda.Syntax.Common
+import Agda.Syntax.Position
+import Agda.Syntax.Concrete
+import Agda.Syntax.Concrete.Operators
+
+import Agda.Syntax.Scope.Monad
+import Agda.TypeChecking.Monad
+
+parseIdiomBrackets :: Range -> Expr -> ScopeM Expr
+parseIdiomBrackets r e = do
+ let qPure = QName $ Name noRange [Id "pure"]
+ qAp = QName $ Name noRange [Hole, Id "<*>", Hole]
+ ePure = App r (Ident qPure) . defaultNamedArg
+ eAp a b = App r (App r (Ident qAp) (defaultNamedArg a)) (defaultNamedArg b)
+ mapM_ ensureInScope [qPure, qAp]
+ case e of
+ RawApp _ es -> do
+ e : es <- appViewM =<< parseApplication es
+ return $ foldl eAp (ePure e) es
+ _ -> return $ ePure e
+
+appViewM :: Expr -> ScopeM [Expr]
+appViewM e =
+ case e of
+ App{} -> let AppView e' es = appView e in (e' :) <$> mapM onlyVisible es
+ OpApp _ op _ es -> (Ident op :) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es
+ _ -> return [e]
+ where
+ onlyVisible a
+ | defaultNamedArg () == (fmap (() <$) a) = return $ namedArg a
+ | otherwise = genericError $ "Only regular arguments are allowed in idiom brackets (no implicit or instance arguments)"
+ noPlaceholder Placeholder{} = genericError "Naked sections are not allowed in idiom brackets"
+ noPlaceholder (NoPlaceholder _ x) = return x
+
+ ordinary (Ordinary a) = return a
+ ordinary _ = genericError "Binding syntax is not allowed in idiom brackets"
+
+ensureInScope :: QName -> ScopeM ()
+ensureInScope q = do
+ r <- resolveName q
+ case r of
+ UnknownName -> genericError $ show q ++ " needs to be in scope to use idiom brackets (| ... |)"
+ _ -> return ()
diff --git a/src/full/Agda/Syntax/Info.hs b/src/full/Agda/Syntax/Info.hs
index 53f990f..abc766e 100644
--- a/src/full/Agda/Syntax/Info.hs
+++ b/src/full/Agda/Syntax/Info.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-| An info object contains additional information about a piece of abstract
@@ -169,6 +167,10 @@ data MutualInfo = MutualInfo
}
deriving (Typeable, Show, Eq)
+-- | Default value for 'MutualInfo'.
+instance Null MutualInfo where
+ empty = MutualInfo TerminationCheck True noRange
+
instance HasRange MutualInfo where
getRange = mutualRange
@@ -203,7 +205,7 @@ patNoRange = PatRange noRange
-- | Constructor pattern info.
data ConPatInfo = ConPatInfo
- { patOrigin :: ConPOrigin
+ { patOrigin :: ConOrigin
-- ^ Does this pattern come form the eta-expansion of an implicit pattern?
--- Or from a user written constructor or record pattern?
, patInfo :: PatInfo
@@ -211,7 +213,7 @@ data ConPatInfo = ConPatInfo
deriving (Typeable, Eq)
instance Show ConPatInfo where
- show (ConPatInfo po i) = applyWhen (po == ConPImplicit) ("implicit " ++) $ show i
+ show (ConPatInfo po i) = applyWhen (po == ConOSystem) ("implicit " ++) $ show i
instance HasRange ConPatInfo where
getRange = getRange . patInfo
diff --git a/src/full/Agda/Syntax/Internal.hs b/src/full/Agda/Syntax/Internal.hs
index 50a78fc..a39c4fe 100644
--- a/src/full/Agda/Syntax/Internal.hs
+++ b/src/full/Agda/Syntax/Internal.hs
@@ -1,15 +1,8 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
#if __GLASGOW_HASKELL__ <= 708
{-# LANGUAGE OverlappingInstances #-}
#endif
@@ -25,12 +18,13 @@ import Prelude hiding (foldr, mapM, null)
import Control.Applicative hiding (empty)
import Control.Monad.Identity hiding (mapM)
+import Control.DeepSeq
import Data.Foldable ( Foldable, foldMap )
import Data.Function
import qualified Data.List as List
import Data.Maybe
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Sum(..))
-- base-4.7 defines the Num instance for Sum
#if !(MIN_VERSION_base(4,7,0))
@@ -43,7 +37,7 @@ import Data.Typeable (Typeable)
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Literal
-import Agda.Syntax.Abstract (IsProjP(..))
+import Agda.Syntax.Concrete.Pretty (prettyHiding)
import Agda.Syntax.Abstract.Name
import Agda.Utils.Empty
@@ -62,7 +56,8 @@ import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Pointer
import Agda.Utils.Size
-import Agda.Utils.Pretty as P
+import qualified Agda.Utils.Pretty as P
+import Agda.Utils.Pretty hiding ((<>))
import Agda.Utils.Tuple
#include "undefined.h"
@@ -123,7 +118,7 @@ data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral
| Lam ArgInfo (Abs Term) -- ^ Terms are beta normal. Relevance is ignored
| Lit Literal
| Def QName Elims -- ^ @f es@, possibly a delta/iota-redex
- | Con ConHead Args -- ^ @c vs@
+ | Con ConHead ConInfo Args -- ^ @c vs@ or @record { fs = vs }@
| Pi (Dom Type) (Abs Type) -- ^ dependent or non-dependent function space
| Sort Sort
| Level Level
@@ -136,9 +131,13 @@ data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral
-- ^ Explicit sharing
deriving (Typeable, Show)
+type ConInfo = ConOrigin
+
-- | Eliminations, subsuming applications and projections.
--
-data Elim' a = Apply (Arg a) | Proj QName -- ^ name of a record projection
+data Elim' a
+ = Apply (Arg a) -- ^ Application.
+ | Proj ProjOrigin QName -- ^ Projection. 'QName' is name of a record projection.
deriving (Typeable, Show, Functor, Foldable, Traversable)
type Elim = Elim' Term
@@ -295,17 +294,20 @@ data NotBlocked
-- | 'ReallyNotBlocked' is the unit.
-- 'MissingClauses' is dominant.
-- @'StuckOn'{}@ should be propagated, if tied, we take the left.
-instance Monoid NotBlocked where
- -- ReallyNotBlocked is neutral
- mempty = ReallyNotBlocked
- ReallyNotBlocked `mappend` b = b
+instance Semigroup NotBlocked where
+ ReallyNotBlocked <> b = b
-- MissingClauses is dominant (absorptive)
- b@MissingClauses `mappend` _ = b
- _ `mappend` b@MissingClauses = b
+ b@MissingClauses <> _ = b
+ _ <> b@MissingClauses = b
-- StuckOn is second strongest
- b@StuckOn{} `mappend` _ = b
- _ `mappend` b@StuckOn{} = b
- b `mappend` _ = b
+ b@StuckOn{} <> _ = b
+ _ <> b@StuckOn{} = b
+ b <> _ = b
+
+instance Monoid NotBlocked where
+ -- ReallyNotBlocked is neutral
+ mempty = ReallyNotBlocked
+ mappend = (<>)
-- | Something where a meta variable may block reduction.
data Blocked t
@@ -329,11 +331,14 @@ instance Applicative Blocked where
-- | @'Blocked' t@ without the @t@.
type Blocked_ = Blocked ()
+instance Semigroup Blocked_ where
+ b@Blocked{} <> _ = b
+ _ <> b@Blocked{} = b
+ NotBlocked x _ <> NotBlocked y _ = NotBlocked (x <> y) ()
+
instance Monoid Blocked_ where
mempty = notBlocked ()
- b@Blocked{} `mappend` _ = b
- _ `mappend` b@Blocked{} = b
- NotBlocked x _ `mappend` NotBlocked y _ = NotBlocked (x `mappend` y) ()
+ mappend = (<>)
-- See issues 1573 and 1674.
#if !MIN_VERSION_transformers(0,4,1)
@@ -379,12 +384,12 @@ stuckOn e r =
-- * Definitions
---------------------------------------------------------------------------
--- | A clause is a list of patterns and the clause body should @Bind@.
+-- | A clause is a list of patterns and the clause body.
--
-- The telescope contains the types of the pattern variables and the
-- de Bruijn indices say how to get from the order the variables occur in
-- the patterns to the order they occur in the telescope. The body
--- binds the variables in the order they appear in the patterns.
+-- binds the variables in the order they appear in the telescope.
--
-- @clauseTel ~ permute clausePerm (patternVars namedClausePats)@
--
@@ -395,37 +400,25 @@ stuckOn e r =
data Clause = Clause
{ clauseRange :: Range
, clauseTel :: Telescope
- -- ^ @Δ@: The types of the pattern variables.
+ -- ^ @Δ@: The types of the pattern variables in dependency order.
, namedClausePats :: [NamedArg DeBruijnPattern]
- -- ^ @let Γ = patternVars namedClausePats@
- , clauseBody :: ClauseBody
- -- ^ @λΓ.v@
+ -- ^ @Δ ⊢ ps@. The de Bruijn indices refer to @Δ@.
+ , clauseBody :: Maybe Term
+ -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an
+ -- absurd one.
, clauseType :: Maybe (Arg Type)
-- ^ @Δ ⊢ t@. The type of the rhs under @clauseTel@.
-- Used, e.g., by @TermCheck@.
-- Can be 'Irrelevant' if we encountered an irrelevant projection
-- pattern on the lhs.
, clauseCatchall :: Bool
+ -- ^ Clause has been labelled as CATCHALL.
}
deriving (Typeable, Show)
clausePats :: Clause -> [Arg DeBruijnPattern]
clausePats = map (fmap namedThing) . namedClausePats
-data ClauseBodyF a = Body a
- | Bind (Abs (ClauseBodyF a))
- | NoBody -- ^ for absurd clauses.
- deriving (Typeable, Show, Functor, Foldable, Traversable)
-
-type ClauseBody = ClauseBodyF Term
-
-imapClauseBody :: (Nat -> a -> b) -> ClauseBodyF a -> ClauseBodyF b
-imapClauseBody f b = go 0 b
- where
- go i (Body x) = Body (f i x)
- go _ NoBody = NoBody
- go !i (Bind b) = Bind $ go (i + 1) <$> b
-
instance HasRange Clause where
getRange = clauseRange
@@ -454,22 +447,30 @@ data Pattern' x
-- The subpatterns do not contain any projection copatterns.
| LitP Literal
-- ^ E.g. @5@, @"hello"@.
- | ProjP QName
+ | ProjP ProjOrigin QName
-- ^ Projection copattern. Can only appear by itself.
deriving (Typeable, Show, Functor, Foldable, Traversable)
type Pattern = Pattern' PatVarName
-- ^ The @PatVarName@ is a name suggestion.
+varP :: ArgName -> Pattern
+varP = VarP
+
-- | Type used when numbering pattern variables.
-type DeBruijnPattern = Pattern' (Int, PatVarName)
+data DBPatVar = DBPatVar
+ { dbPatVarName :: PatVarName
+ , dbPatVarIndex :: Int
+ } deriving (Typeable, Show)
-namedVarP :: PatVarName -> Named (Ranged PatVarName) Pattern
-namedVarP x = Named named $ VarP x
+type DeBruijnPattern = Pattern' DBPatVar
+
+namedVarP :: PatVarName -> Named_ Pattern
+namedVarP x = Named named $ varP x
where named = if isUnderscore x then Nothing else Just $ unranged x
-namedDBVarP :: Int -> PatVarName -> Named (Ranged PatVarName) DeBruijnPattern
-namedDBVarP m = (fmap . fmap) (m,) . namedVarP
+namedDBVarP :: Int -> PatVarName -> Named_ DeBruijnPattern
+namedDBVarP m = (fmap . fmap) (\x -> DBPatVar x m) . namedVarP
-- | The @ConPatternInfo@ states whether the constructor belongs to
-- a record type (@Just@) or data type (@Nothing@).
@@ -479,7 +480,7 @@ namedDBVarP m = (fmap . fmap) (m,) . namedVarP
-- The scope used for the type is given by any outer scope
-- plus the clause's telescope ('clauseTel').
data ConPatternInfo = ConPatternInfo
- { conPRecord :: Maybe ConPOrigin
+ { conPRecord :: Maybe ConOrigin
-- ^ @Nothing@ if data constructor.
-- @Just@ if record constructor.
, conPType :: Maybe (Arg Type)
@@ -495,6 +496,15 @@ data ConPatternInfo = ConPatternInfo
noConPatternInfo :: ConPatternInfo
noConPatternInfo = ConPatternInfo Nothing Nothing
+-- | Build partial 'ConPatternInfo' from 'ConInfo'
+toConPatternInfo :: ConInfo -> ConPatternInfo
+toConPatternInfo ConORec = ConPatternInfo (Just ConORec) Nothing
+toConPatternInfo _ = noConPatternInfo
+
+-- | Build 'ConInfo' from 'ConPatternInfo'.
+fromConPatternInfo :: ConPatternInfo -> ConInfo
+fromConPatternInfo = fromMaybe ConOSystem . conPRecord
+
-- | Extract pattern variables in left-to-right order.
-- A 'DotP' is also treated as variable (see docu for 'Clause').
patternVars :: Arg (Pattern' a) -> [Arg (Either a Term)]
@@ -505,8 +515,8 @@ patternVars (Arg i (LitP l) ) = []
patternVars (Arg i ProjP{} ) = []
-- | Does the pattern perform a match that could fail?
-properlyMatching :: Pattern' a -> Bool
-properlyMatching VarP{} = False
+properlyMatching :: DeBruijnPattern -> Bool
+properlyMatching (VarP x) = isAbsurdPatternName $ dbPatVarName x
properlyMatching DotP{} = False
properlyMatching LitP{} = True
properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record cons
@@ -514,8 +524,8 @@ properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record c
properlyMatching ProjP{} = True
instance IsProjP (Pattern' a) where
- isProjP (ProjP d) = Just d
- isProjP _ = Nothing
+ isProjP (ProjP o d) = Just (o, AmbQ [d])
+ isProjP _ = Nothing
-----------------------------------------------------------------------------
-- * Explicit substitutions
@@ -577,6 +587,11 @@ type PatternSubstitution = Substitution' DeBruijnPattern
infixr 4 :#
+instance Null (Substitution' a) where
+ empty = IdS
+ null IdS = True
+ null _ = False
+
---------------------------------------------------------------------------
-- * Views
@@ -635,7 +650,7 @@ ignoreSharingType (El s v) = El s (ignoreSharing v)
shared_ :: Term -> Term
shared_ v@Shared{} = v
shared_ v@(Var _ []) = v
-shared_ v@(Con _ []) = v -- Issue 1691: sharing (zero : Nat) destroys constructorForm
+shared_ v@(Con _ _ []) = v -- Issue 1691: sharing (zero : Nat) destroys constructorForm
shared_ v = Shared (newPtr v)
-- | Typically m would be TCM and f would be Blocked.
@@ -817,17 +832,23 @@ instance Suggest Name (Abs b) where
-- | Convert top-level postfix projections into prefix projections.
unSpine :: Term -> Term
-unSpine v =
+unSpine = unSpine' $ const True
+
+-- | Convert 'Proj' projection eliminations
+-- according to their 'ProjOrigin' into
+-- 'Def' projection applications.
+unSpine' :: (ProjOrigin -> Bool) -> Term -> Term
+unSpine' p v =
case hasElims v of
- Just (h, es) -> unSpine' h [] es
+ Just (h, es) -> loop h [] es
Nothing -> v
where
- unSpine' :: (Elims -> Term) -> Elims -> Elims -> Term
- unSpine' h res es =
+ loop :: (Elims -> Term) -> Elims -> Elims -> Term
+ loop h res es =
case es of
- [] -> v
- e@(Apply a) : es' -> unSpine' h (e : res) es'
- Proj f : es' -> unSpine' (Def f) [Apply (defaultArg v)] es'
+ [] -> v
+ Proj o f : es' | p o -> loop (Def f) [Apply (defaultArg v)] es'
+ e : es' -> loop h (e : res) es'
where v = h $ reverse res
-- | A view distinguishing the neutrals @Var@, @Def@, and @MetaV@ which
@@ -842,8 +863,8 @@ hasElims v =
Lit{} -> Nothing
-- Andreas, 2016-04-13, Issue 1932: We convert λ x → x .f into f
Lam _ (Abs _ v) -> case ignoreSharing v of
- Var 0 [Proj f] -> Just (Def f, [])
- _ -> Nothing
+ Var 0 [Proj _o f] -> Just (Def f, [])
+ _ -> Nothing
Lam{} -> Nothing
Pi{} -> Nothing
Sort{} -> Nothing
@@ -859,30 +880,30 @@ getElims v = maybe default id $ hasElims v
-}
-- | Drop 'Apply' constructor. (Unsafe!)
-argFromElim :: Elim -> Arg Term
+argFromElim :: Elim' a -> Arg a
argFromElim (Apply u) = u
argFromElim Proj{} = __IMPOSSIBLE__
-- | Drop 'Apply' constructor. (Safe)
-isApplyElim :: Elim -> Maybe (Arg Term)
+isApplyElim :: Elim' a -> Maybe (Arg a)
isApplyElim (Apply u) = Just u
isApplyElim Proj{} = Nothing
-- | Drop 'Apply' constructors. (Safe)
-allApplyElims :: Elims -> Maybe Args
+allApplyElims :: [Elim' a] -> Maybe [Arg a]
allApplyElims = mapM isApplyElim
-- | Split at first non-'Apply'
-splitApplyElims :: Elims -> (Args, Elims)
+splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])
splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es
splitApplyElims es = ([], es)
class IsProjElim e where
- isProjElim :: e -> Maybe QName
+ isProjElim :: e -> Maybe (ProjOrigin, QName)
instance IsProjElim Elim where
- isProjElim (Proj d) = Just d
- isProjElim Apply{} = Nothing
+ isProjElim (Proj o d) = Just (o, d)
+ isProjElim Apply{} = Nothing
-- | Discard @Proj f@ entries.
dropProjElims :: IsProjElim e => [e] -> [e]
@@ -893,23 +914,9 @@ argsFromElims :: Elims -> Args
argsFromElims = map argFromElim . dropProjElims
-- | Drop 'Proj' constructors. (Safe)
-allProjElims :: Elims -> Maybe [QName]
+allProjElims :: Elims -> Maybe [(ProjOrigin, QName)]
allProjElims = mapM isProjElim
-{- NOTE: Elim' already contains Arg.
-
--- | Commute functors 'Arg' and 'Elim\''.
-swapArgElim :: Arg (Elim' a) -> Elim' (Arg a)
-
-swapArgElim (Arg ai (Apply a)) = Apply (Arg ai a)
-swapArgElim (Arg ai (Proj d)) = Proj d
-
--- IMPOSSIBLE TO DEFINE
-swapElimArg :: Elim' (Arg a) -> Arg (Elim' a)
-swapElimArg (Apply (Arg ai a)) = Arg ai (Apply a)
-swapElimArg (Proj d) = defaultArg (Proj d)
--}
-
---------------------------------------------------------------------------
-- * Null instances.
---------------------------------------------------------------------------
@@ -919,11 +926,6 @@ instance Null (Tele a) where
null EmptyTel = True
null ExtendTel{} = False
-instance Null ClauseBody where
- empty = NoBody
- null NoBody = True
- null _ = False
-
-- | A 'null' clause is one with no patterns and no rhs.
-- Should not exist in practice.
instance Null Clause where
@@ -988,7 +990,7 @@ instance TermSize Term where
tsize v = case v of
Var _ vs -> 1 + tsize vs
Def _ vs -> 1 + tsize vs
- Con _ vs -> 1 + tsize vs
+ Con _ _ vs -> 1 + tsize vs
MetaV _ vs -> 1 + tsize vs
Level l -> tsize l
Lam _ f -> 1 + tsize f
@@ -1038,7 +1040,7 @@ instance KillRange Term where
killRange v = case v of
Var i vs -> killRange1 (Var i) vs
Def c vs -> killRange2 Def c vs
- Con c vs -> killRange2 Con c vs
+ Con c ci vs -> killRange3 Con c ci vs
MetaV m vs -> killRange1 (MetaV m) vs
Lam i f -> killRange2 Lam i f
Lit l -> killRange1 Lit l
@@ -1083,6 +1085,9 @@ instance KillRange Substitution where
instance KillRange ConPatternInfo where
killRange (ConPatternInfo mr mt) = killRange1 (ConPatternInfo mr) mt
+instance KillRange DBPatVar where
+ killRange (DBPatVar x i) = killRange2 DBPatVar x i
+
instance KillRange a => KillRange (Pattern' a) where
killRange p =
case p of
@@ -1090,14 +1095,11 @@ instance KillRange a => KillRange (Pattern' a) where
DotP v -> killRange1 DotP v
ConP con info ps -> killRange3 ConP con info ps
LitP l -> killRange1 LitP l
- ProjP q -> killRange1 ProjP q
+ ProjP o q -> killRange1 (ProjP o) q
instance KillRange Clause where
killRange (Clause r tel ps body t catchall) = killRange6 Clause r tel ps body t catchall
-instance KillRange a => KillRange (ClauseBodyF a) where
- killRange = fmap killRange
-
instance KillRange a => KillRange (Tele a) where
killRange = fmap killRange
@@ -1126,48 +1128,65 @@ instanceUniverseBiT' [] [t| ([Term], Term) |]
-- * Simple pretty printing
-----------------------------------------------------------------------------
-instance Pretty Substitution where
- prettyPrec p rho = brackets $ pr rho
+instance Pretty a => Pretty (Substitution' a) where
+ prettyPrec p rho = pr p rho
where
- pr rho = case rho of
+ pr p rho = case rho of
IdS -> text "idS"
- EmptyS -> text "ε"
- t :# rho -> prettyPrec 1 t <+> text ":#" <+> pr rho
- Strengthen _ rho -> text "↓" <+> pr rho
- Wk n rho -> text ("↑" ++ show n) <+> pr rho
- Lift n rho -> text ("⇑" ++ show n) <+> pr rho
+ EmptyS -> text "emptyS"
+ t :# rho -> mparens (p > 2) $ sep [ pr 2 rho P.<> text ",", prettyPrec 3 t ]
+ Strengthen _ rho -> mparens (p > 9) $ text "strS" <+> pr 10 rho
+ Wk n rho -> mparens (p > 9) $ text ("wkS " ++ show n) <+> pr 10 rho
+ Lift n rho -> mparens (p > 9) $ text ("liftS " ++ show n) <+> pr 10 rho
instance Pretty Term where
prettyPrec p v =
case ignoreSharing v of
Var x els -> text ("@" ++ show x) `pApp` els
- Lam _ b ->
+ Lam ai b ->
mparens (p > 0) $
- sep [ text ("λ " ++ show (absName b) ++ " ->")
+ sep [ text "λ" <+> prettyHiding ai id (text . show . absName $ b) <+> text "->"
, nest 2 $ pretty (unAbs b) ]
Lit l -> pretty l
Def q els -> text (show q) `pApp` els
- Con c vs -> text (show $ conName c) `pApp` map Apply vs
+ Con c ci vs -> text (show $ conName c) `pApp` map Apply vs
Pi a (NoAbs _ b) -> mparens (p > 0) $
sep [ prettyPrec 1 (unDom a) <+> text "->"
, nest 2 $ pretty b ]
Pi a b -> mparens (p > 0) $
sep [ pDom (domInfo a) (text (absName b) <+> text ":" <+> pretty (unDom a)) <+> text "->"
, nest 2 $ pretty (unAbs b) ]
- Sort s -> pretty s
- Level l -> pretty l
+ Sort s -> prettyPrec p s
+ Level l -> prettyPrec p l
MetaV x els -> pretty x `pApp` els
- DontCare v -> pretty v
+ DontCare v -> prettyPrec p v
Shared{} -> __IMPOSSIBLE__
where
pApp d els = mparens (not (null els) && p > 9) $
- d <+> fsep (map (prettyPrec 10) els)
+ sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]
+
+pDom :: LensHiding a => a -> Doc -> Doc
+pDom i =
+ case getHiding i of
+ NotHidden -> parens
+ Hidden -> braces
+ Instance -> braces . braces
+
+instance Pretty Clause where
+ pretty Clause{clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t} =
+ sep [ pretty tel <+> text "|-"
+ , nest 2 $ sep [ fsep (map (prettyPrec 10) ps) <+> text "="
+ , nest 2 $ pBody b t ] ]
+ where
+ pBody Nothing _ = text "(absurd)"
+ pBody (Just b) Nothing = pretty b
+ pBody (Just b) (Just t) = sep [ pretty b <+> text ":", nest 2 $ pretty t ]
- pDom i =
- case getHiding i of
- NotHidden -> parens
- Hidden -> braces
- Instance -> braces . braces
+instance Pretty a => Pretty (Tele (Dom a)) where
+ pretty tel = fsep [ pDom a (text x <+> text ":" <+> pretty (unDom a)) | (x, a) <- telToList tel ]
+ where
+ telToList EmptyTel = []
+ telToList (ExtendTel a tel) = (absName tel, a) : telToList (unAbs tel)
instance Pretty Level where
prettyPrec p (Max as) =
@@ -1211,26 +1230,71 @@ instance Pretty Type where
prettyPrec p (El _ a) = prettyPrec p a
instance Pretty Elim where
- prettyPrec p (Apply v) = prettyPrec p v
- prettyPrec _ (Proj x) = text ("." ++ show x)
+ prettyPrec p (Apply v) = prettyPrec p v
+ prettyPrec _ (Proj _o x) = text ("." ++ show x)
+
+instance Pretty DBPatVar where
+ prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x)
instance Pretty a => Pretty (Pattern' a) where
prettyPrec n (VarP x) = prettyPrec n x
prettyPrec _ (DotP t) = text "." P.<> prettyPrec 10 t
- prettyPrec n (ConP c i ps) = mparens (n > 0) $
- text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)
+ prettyPrec n (ConP c i nps)= mparens (n > 0) $
+ text (show $ conName c) <+> fsep (map pretty ps)
+ where ps = map (fmap namedThing) nps
-- -- Version with printing record type:
-- prettyPrec _ (ConP c i ps) = (if b then braces else parens) $ prTy $
-- text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)
-- where
- -- b = maybe False (== ConPImplicit) $ conPRecord i
+ -- b = maybe False (== ConOSystem) $ conPRecord i
-- prTy d = caseMaybe (conPType i) d $ \ t -> d <+> text ":" <+> pretty t
prettyPrec _ (LitP l) = text (show l)
- prettyPrec _ (ProjP q) = text (show q)
-
-instance Pretty a => Pretty (ClauseBodyF a) where
- pretty b = case b of
- Bind (NoAbs _ b) -> pretty b
- Bind (Abs x b) -> text (show x ++ ".") <+> pretty b
- Body t -> pretty t
- NoBody -> text "()"
+ prettyPrec _ (ProjP _o q) = text ("." ++ show q)
+
+-----------------------------------------------------------------------------
+-- * NFData instances
+-----------------------------------------------------------------------------
+
+-- Note: only strict in the shape of the terms.
+
+instance NFData Term where
+ rnf v = case v of
+ Var _ es -> rnf es
+ Lam _ b -> rnf (unAbs b)
+ Lit l -> rnf l
+ Def _ es -> rnf es
+ Con _ _ vs -> rnf vs
+ Pi a b -> rnf (unDom a, unAbs b)
+ Sort s -> rnf s
+ Level l -> rnf l
+ MetaV _ es -> rnf es
+ DontCare v -> rnf v
+ Shared{} -> ()
+
+instance NFData Type where
+ rnf (El s v) = rnf (s, v)
+
+instance NFData Sort where
+ rnf s = case s of
+ Type l -> rnf l
+ Prop -> ()
+ Inf -> ()
+ SizeUniv -> ()
+ DLub a b -> rnf (a, unAbs b)
+
+instance NFData Level where
+ rnf (Max as) = rnf as
+
+instance NFData PlusLevel where
+ rnf (ClosedLevel n) = rnf n
+ rnf (Plus n l) = rnf (n, l)
+
+instance NFData LevelAtom where
+ rnf (MetaLevel _ es) = rnf es
+ rnf (BlockedLevel _ v) = rnf v
+ rnf (NeutralLevel _ v) = rnf v
+ rnf (UnreducedLevel v) = rnf v
+
+instance NFData a => NFData (Elim' a) where
+ rnf (Apply x) = rnf x
+ rnf Proj{} = ()
diff --git a/src/full/Agda/Syntax/Internal/Defs.hs b/src/full/Agda/Syntax/Internal/Defs.hs
index 3faaec8..e66626d 100644
--- a/src/full/Agda/Syntax/Internal/Defs.hs
+++ b/src/full/Agda/Syntax/Internal/Defs.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-- | Extract used definitions from terms.
module Agda.Syntax.Internal.Defs where
@@ -45,16 +44,10 @@ class GetDefs a where
instance GetDefs Clause where
getDefs = getDefs . clauseBody
-instance GetDefs ClauseBody where
- getDefs b = case b of
- Body v -> getDefs v
- Bind b -> getDefs b
- NoBody -> return ()
-
instance GetDefs Term where
getDefs v = case v of
Def d vs -> doDef d >> getDefs vs
- Con c vs -> getDefs vs
+ Con _ _ vs -> getDefs vs
Lit l -> return ()
Var i vs -> getDefs vs
Lam _ v -> getDefs v
diff --git a/src/full/Agda/Syntax/Internal/Generic.hs b/src/full/Agda/Syntax/Internal/Generic.hs
index 6aed85a..57f7f15 100644
--- a/src/full/Agda/Syntax/Internal/Generic.hs
+++ b/src/full/Agda/Syntax/Internal/Generic.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
module Agda.Syntax.Internal.Generic where
@@ -100,13 +99,18 @@ instance TermLike a => TermLike (Ptr a) where
traverseTermM f = traverse (traverseTermM f)
foldTerm f = foldMap (foldTerm f)
+instance TermLike a => TermLike (Blocked a) where
+ traverseTerm f = fmap (traverseTerm f)
+ traverseTermM f = traverse (traverseTermM f)
+ foldTerm f = foldMap (foldTerm f)
+
-- * Real terms
instance TermLike Term where
traverseTerm f t = case t of
Var i xs -> f $ Var i $ traverseTerm f xs
Def c xs -> f $ Def c $ traverseTerm f xs
- Con c xs -> f $ Con c $ traverseTerm f xs
+ Con c ci xs -> f $ Con c ci $ traverseTerm f xs
Lam h b -> f $ Lam h $ traverseTerm f b
Pi a b -> f $ uncurry Pi $ traverseTerm f (a, b)
MetaV m xs -> f $ MetaV m $ traverseTerm f xs
@@ -119,7 +123,7 @@ instance TermLike Term where
traverseTermM f t = case t of
Var i xs -> f =<< Var i <$> traverseTermM f xs
Def c xs -> f =<< Def c <$> traverseTermM f xs
- Con c xs -> f =<< Con c <$> traverseTermM f xs
+ Con c ci xs -> f =<< Con c ci <$> traverseTermM f xs
Lam h b -> f =<< Lam h <$> traverseTermM f b
Pi a b -> f =<< uncurry Pi <$> traverseTermM f (a, b)
MetaV m xs -> f =<< MetaV m <$> traverseTermM f xs
@@ -132,7 +136,7 @@ instance TermLike Term where
foldTerm f t = f t `mappend` case t of
Var i xs -> foldTerm f xs
Def c xs -> foldTerm f xs
- Con c xs -> foldTerm f xs
+ Con c ci xs -> foldTerm f xs
Lam h b -> foldTerm f b
Pi a b -> foldTerm f (a, b)
MetaV m xs -> foldTerm f xs
diff --git a/src/full/Agda/Syntax/Internal/Names.hs b/src/full/Agda/Syntax/Internal/Names.hs
index 7bac092..eb9d023 100644
--- a/src/full/Agda/Syntax/Internal/Names.hs
+++ b/src/full/Agda/Syntax/Internal/Names.hs
@@ -19,6 +19,7 @@ import qualified Agda.Syntax.Abstract as A
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.CompiledClause
+import Agda.Utils.Functor
import Agda.Utils.Impossible
#include "undefined.h"
@@ -36,7 +37,6 @@ instance NamesIn a => NamesIn (Named n a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (Abs a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (WithArity a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (Tele a) where namesIn = namesInFoldable
-instance NamesIn a => NamesIn (ClauseBodyF a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (C.FieldAssignment' a) where namesIn = namesInFoldable
@@ -55,9 +55,10 @@ instance NamesIn Defn where
Function { funClauses = cl, funCompiled = cc } -> namesIn (cl, cc)
Datatype { dataClause = cl, dataCons = cs, dataSort = s } -> namesIn (cl, cs, s)
Record { recClause = cl, recConHead = c, recFields = fs } -> namesIn (cl, c, fs)
- -- Don't need recTel or recConType since those will be reachable from the constructor
+ -- Don't need recTel since those will be reachable from the constructor
Constructor { conSrcCon = c, conData = d } -> namesIn (c, d)
Primitive { primClauses = cl, primCompiled = cc } -> namesIn (cl, cc)
+ AbstractDefn -> __IMPOSSIBLE__
instance NamesIn Clause where
namesIn Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =
@@ -78,7 +79,7 @@ instance NamesIn (Pattern' a) where
LitP l -> namesIn l
DotP v -> namesIn v
ConP c _ args -> namesIn (c, args)
- ProjP f -> namesIn f
+ ProjP _ f -> namesIn f
instance NamesIn a => NamesIn (Type' a) where
namesIn (El s t) = namesIn (s, t)
@@ -97,7 +98,7 @@ instance NamesIn Term where
Lam _ b -> namesIn b
Lit l -> namesIn l
Def f args -> namesIn (f, args)
- Con c args -> namesIn (c, args)
+ Con c _ args -> namesIn (c, args)
Pi a b -> namesIn (a, b)
Sort s -> namesIn s
Level l -> namesIn l
@@ -131,7 +132,7 @@ instance NamesIn Literal where
instance NamesIn a => NamesIn (Elim' a) where
namesIn (Apply arg) = namesIn arg
- namesIn (Proj f) = namesIn f
+ namesIn (Proj _ f) = namesIn f
instance NamesIn QName where namesIn x = Set.singleton x
instance NamesIn ConHead where namesIn h = namesIn (conName h)
@@ -139,13 +140,15 @@ instance NamesIn ConHead where namesIn h = namesIn (conName h)
instance NamesIn a => NamesIn (Open a) where
namesIn = namesIn . openThing
+instance NamesIn a => NamesIn (Local a) where namesIn = namesIn . dget
+
instance NamesIn DisplayForm where
namesIn (Display _ ps v) = namesIn (ps, v)
instance NamesIn DisplayTerm where
namesIn v = case v of
- DWithApp v us vs -> namesIn (v, us, vs)
- DCon c vs -> namesIn (c, vs)
+ DWithApp v us es -> namesIn (v, us, es)
+ DCon c _ vs -> namesIn (c, vs)
DDef f es -> namesIn (f, es)
DDot v -> namesIn v
DTerm v -> namesIn v
@@ -160,6 +163,7 @@ instance NamesIn (A.Pattern' a) where
namesIn p = case p of
A.VarP{} -> Set.empty
A.ConP _ c args -> namesIn (c, args)
+ A.ProjP _ _ d -> namesIn d
A.DefP _ f args -> namesIn (f, args)
A.WildP{} -> Set.empty
A.AsP _ _ p -> namesIn p
diff --git a/src/full/Agda/Syntax/Internal/Pattern.hs b/src/full/Agda/Syntax/Internal/Pattern.hs
index b8a3526..40b7234 100644
--- a/src/full/Agda/Syntax/Internal/Pattern.hs
+++ b/src/full/Agda/Syntax/Internal/Pattern.hs
@@ -1,9 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-} -- because of func. deps.
#if __GLASGOW_HASKELL__ <= 708
@@ -24,6 +19,7 @@ import Agda.Syntax.Abstract (IsProjP(..))
import Agda.Syntax.Internal
import qualified Agda.Syntax.Internal as I
+import Agda.Utils.Empty
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Permutation
@@ -62,7 +58,7 @@ instance IsProjP p => FunArity [p] where
-- | Get the number of initial 'Apply' patterns in a clause.
instance FunArity Clause where
- funArity = funArity . clausePats
+ funArity = funArity . namedClausePats
-- | Get the number of common initial 'Apply' patterns in a list of clauses.
#if __GLASGOW_HASKELL__ >= 710
@@ -95,20 +91,20 @@ instance LabelPatVars a b i => LabelPatVars [a] [b] i where
labelPatVars = traverse labelPatVars
unlabelPatVars = fmap unlabelPatVars
-instance LabelPatVars (Pattern' x) (Pattern' (i,x)) i where
+instance LabelPatVars Pattern DeBruijnPattern Int where
labelPatVars p =
case p of
- VarP x -> VarP . (,x) <$> next
+ VarP x -> do i <- next
+ return $ VarP (DBPatVar x i)
DotP t -> DotP t <$ next
ConP c mt ps -> ConP c mt <$> labelPatVars ps
LitP l -> return $ LitP l
- ProjP q -> return $ ProjP q
+ ProjP o q -> return $ ProjP o q
where next = do (x:xs) <- get; put xs; return x
- unlabelPatVars = fmap snd
+ unlabelPatVars = fmap dbPatVarName
-- | Augment pattern variables with their de Bruijn index.
-{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [NamedArg (Pattern' (Int, x))] #-}
-{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg Pattern] -> [NamedArg DeBruijnPattern] #-}
+{-# SPECIALIZE numberPatVars :: Int -> Permutation -> [NamedArg Pattern] -> [NamedArg DeBruijnPattern] #-}
--
-- Example:
-- @
@@ -123,38 +119,58 @@ instance LabelPatVars (Pattern' x) (Pattern' (i,x)) i where
-- dBpats = 3 .(suc 2) (cons 2 1 0 )
-- @
--
-numberPatVars :: LabelPatVars a b Int => Permutation -> a -> b
-numberPatVars perm ps = evalState (labelPatVars ps) $
- permPicks $ flipP $ invertP __IMPOSSIBLE__ perm
+numberPatVars :: LabelPatVars a b Int => Int -> Permutation -> a -> b
+numberPatVars err perm ps = evalState (labelPatVars ps) $
+ permPicks $ flipP $ invertP err perm
unnumberPatVars :: LabelPatVars a b i => b -> a
unnumberPatVars = unlabelPatVars
-dbPatPerm :: [NamedArg DeBruijnPattern] -> Permutation
-dbPatPerm ps = Perm (size ixs) picks
+dbPatPerm :: [NamedArg DeBruijnPattern] -> Maybe Permutation
+dbPatPerm = dbPatPerm' True
+
+-- | Computes the permutation from the clause telescope
+-- to the pattern variables.
+--
+-- Use as @fromMaybe __IMPOSSIBLE__ . dbPatPerm@ to crash
+-- in a controlled way if a de Bruijn index is out of scope here.
+--
+-- The first argument controls whether dot patterns counts as variables or
+-- not.
+dbPatPerm' :: Bool -> [NamedArg DeBruijnPattern] -> Maybe Permutation
+dbPatPerm' countDots ps = Perm (size ixs) <$> picks
where
ixs = concatMap (getIndices . namedThing . unArg) ps
n = size $ catMaybes ixs
- picks = for (downFrom n) $ \i ->
- fromMaybe __IMPOSSIBLE__ $ findIndex (Just i ==) ixs
+ picks = forM (downFrom n) $ \ i -> findIndex (Just i ==) ixs
getIndices :: DeBruijnPattern -> [Maybe Int]
- getIndices (VarP (i,_)) = [Just i]
+ getIndices (VarP x) = [Just $ dbPatVarIndex x]
getIndices (ConP c _ ps) = concatMap (getIndices . namedThing . unArg) ps
- getIndices (DotP _) = [Nothing]
+ getIndices (DotP _) = [Nothing | countDots]
getIndices (LitP _) = []
- getIndices (ProjP _) = []
+ getIndices ProjP{} = []
-clausePerm :: Clause -> Permutation
+
+-- | Computes the permutation from the clause telescope
+-- to the pattern variables.
+--
+-- Use as @fromMaybe __IMPOSSIBLE__ . clausePerm@ to crash
+-- in a controlled way if a de Bruijn index is out of scope here.
+clausePerm :: Clause -> Maybe Permutation
clausePerm = dbPatPerm . namedClausePats
+-- | Turn a pattern into a term.
+-- Projection patterns are turned into projection eliminations,
+-- other patterns into apply elimination.
patternToElim :: Arg DeBruijnPattern -> Elim
-patternToElim (Arg ai (VarP (i, _))) = Apply $ Arg ai $ var i
-patternToElim (Arg ai (ConP c _ ps)) = Apply $ Arg ai $ Con c $
+patternToElim (Arg ai (VarP x)) = Apply $ Arg ai $ var $ dbPatVarIndex x
+patternToElim (Arg ai (ConP c cpi ps)) = Apply $ Arg ai $ Con c ci $
map (argFromElim . patternToElim . fmap namedThing) ps
+ where ci = fromConPatternInfo cpi
patternToElim (Arg ai (DotP t) ) = Apply $ Arg ai t
patternToElim (Arg ai (LitP l) ) = Apply $ Arg ai $ Lit l
-patternToElim (Arg ai (ProjP dest) ) = Proj $ dest
+patternToElim (Arg ai (ProjP o dest)) = Proj o dest
patternsToElims :: [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims ps = map build ps
@@ -165,23 +181,19 @@ patternsToElims ps = map build ps
patternToTerm :: DeBruijnPattern -> Term
patternToTerm p = case patternToElim (defaultArg p) of
Apply x -> unArg x
- Proj f -> __IMPOSSIBLE__
-
--- patternsToElims :: Permutation -> [NamedArg Pattern] -> [Elim]
--- patternsToElims perm ps = evalState (mapM build' ps) xs
--- where
--- xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm)
-
--- tick :: State [Int] Int
--- tick = do x : xs <- get; put xs; return x
-
--- build' :: NamedArg Pattern -> State [Int] Elim
--- build' = build . fmap namedThing
-
--- build :: Arg Pattern -> State [Int] Elim
--- build (Arg ai (VarP _) ) = Apply . Arg ai . var <$> tick
--- build (Arg ai (ConP c _ ps)) =
--- Apply . Arg ai . Con c <$> mapM (argFromElim <.> build') ps
--- build (Arg ai (DotP t) ) = Apply (Arg ai t) <$ tick
--- build (Arg ai (LitP l) ) = return $ Apply $ Arg ai $ Lit l
--- build (Arg ai (ProjP dest) ) = return $ Proj $ dest
+ Proj{} -> __IMPOSSIBLE__
+
+class MapNamedArg f where
+ mapNamedArg :: (NamedArg a -> NamedArg b) -> NamedArg (f a) -> NamedArg (f b)
+
+instance MapNamedArg Pattern' where
+ mapNamedArg f np =
+ case namedArg np of
+ VarP x -> map2 VarP $ f $ map2 (const x) np
+ DotP t -> map2 (const $ DotP t) np -- just Haskell type conversion
+ LitP l -> map2 (const $ LitP l) np -- ditto
+ ProjP o q -> map2 (const $ ProjP o q) np -- ditto
+ ConP c i ps -> map2 (const $ ConP c i $ map (mapNamedArg f) ps) np
+ where
+ map2 :: (a -> b) -> NamedArg a -> NamedArg b
+ map2 = fmap . fmap
diff --git a/src/full/Agda/Syntax/Internal/SanityCheck.hs b/src/full/Agda/Syntax/Internal/SanityCheck.hs
new file mode 100644
index 0000000..6a5dd68
--- /dev/null
+++ b/src/full/Agda/Syntax/Internal/SanityCheck.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE CPP #-}
+-- | Sanity checking for internal syntax. Mostly checking variable scoping.
+module Agda.Syntax.Internal.SanityCheck where
+
+import Control.Monad
+import qualified Data.IntSet as Set
+
+import Text.PrettyPrint (empty)
+
+import Agda.Syntax.Internal
+import Agda.TypeChecking.Free
+import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Substitute
+
+import Agda.Utils.Pretty
+import Agda.Utils.Size
+import Agda.Utils.Impossible
+
+#include "undefined.h"
+
+sanityCheckVars :: (Pretty a, FreeVS a) => Telescope -> a -> TCM ()
+sanityCheckVars tel v =
+ case filter bad (Set.toList $ allFreeVars v) of
+ [] -> return ()
+ xs -> do
+ reportSDoc "impossible" 1 . return $
+ sep [ hang (text "Sanity check failed for") 2
+ (hang (pretty tel <+> text "|-") 2 (pretty v))
+ , text $ "out of scope: " ++ show xs ]
+ __IMPOSSIBLE__
+ where
+ n = size tel
+ bad x = x < 0 || x >= n
+
+-- | Check that @Γ ⊢ ρ : Δ@.
+sanityCheckSubst :: (Pretty a, FreeVS a) => Telescope -> Substitution' a -> Telescope -> TCM ()
+sanityCheckSubst gamma rho delta = go gamma rho delta
+ where
+ go gamma rho delta =
+ case rho of
+ IdS -> unless (size gamma == size delta) $ err $ text "idS:" <+> hang (pretty gamma <+> text "/=") 2 (pretty delta)
+ EmptyS -> unless (size delta == 0) $ err $ text "emptyS:" <+> pretty delta <+> text "is not empty"
+ v :# rho -> do
+ unless (size delta > 0) $ err $ text "consS: empty target"
+ sanityCheckVars gamma v
+ sanityCheckSubst gamma rho (dropLast delta)
+ Strengthen _ rho -> do
+ unless (size delta > 0) $ err $ text "strS: empty target"
+ sanityCheckSubst gamma rho (dropLast delta)
+ Wk n rho -> do
+ unless (size gamma >= n) $ err $ text "wkS:" <+> sep [ text "|" <> pretty gamma <> text "|"
+ , text $ "< " ++ show n ]
+ sanityCheckSubst (dropLastN n gamma) rho delta
+ Lift n rho -> do
+ unless (size gamma >= n) $ err $ text "liftS: source" <+> sep [ text "|" <> pretty gamma <> text "|"
+ , text $ "< " ++ show n ]
+ unless (size delta >= n) $ err $ text "liftS: target" <+> sep [ text "|" <> pretty delta <> text "|"
+ , text $ "< " ++ show n ]
+ sanityCheckSubst (dropLastN n gamma) rho (dropLastN n delta)
+
+ dropLast = telFromList . init . telToList
+ dropLastN n = telFromList . reverse . drop n . reverse . telToList
+
+ err reason = do
+ reportSDoc "impossible" 1 . return $
+ sep [ hang (text "Sanity check failed for") 2 $
+ hang (pretty gamma <+> text "|-") 2 $
+ hang (pretty rho <+> text ":") 2 $
+ pretty delta
+ , reason ]
+ __IMPOSSIBLE__
+
diff --git a/src/full/Agda/Syntax/Literal.hs b/src/full/Agda/Syntax/Literal.hs
index 0733004..ee1359c 100644
--- a/src/full/Agda/Syntax/Literal.hs
+++ b/src/full/Agda/Syntax/Literal.hs
@@ -5,6 +5,9 @@ module Agda.Syntax.Literal where
import Control.DeepSeq
import Data.Char
import Data.Typeable (Typeable)
+
+import Numeric.IEEE ( IEEE(identicalIEEE) )
+
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Abstract.Name
@@ -53,7 +56,10 @@ showChar' c
instance Eq Literal where
LitNat _ n == LitNat _ m = n == m
- LitFloat _ x == LitFloat _ y = x == y
+ -- ASR (2016-09-29). We use bitwise equality for comparing Double
+ -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove
+ -- a contradiction (see Issue #2169).
+ LitFloat _ x == LitFloat _ y = identicalIEEE x y || (isNaN x && isNaN y)
LitString _ s == LitString _ t = s == t
LitChar _ c == LitChar _ d = c == d
LitQName _ x == LitQName _ y = x == y
@@ -62,7 +68,7 @@ instance Eq Literal where
instance Ord Literal where
LitNat _ n `compare` LitNat _ m = n `compare` m
- LitFloat _ x `compare` LitFloat _ y = x `compare` y
+ LitFloat _ x `compare` LitFloat _ y = compareFloat x y
LitString _ s `compare` LitString _ t = s `compare` t
LitChar _ c `compare` LitChar _ d = c `compare` d
LitQName _ x `compare` LitQName _ y = x `compare` y
@@ -80,6 +86,23 @@ instance Ord Literal where
-- compare LitMeta{} _ = LT
-- compare _ LitMeta{} = GT
+-- NOTE: This is not the same ordering as primFloatNumericalEquality!
+-- This ordering must be a total order of all allowed float values,
+-- while primFloatNumericalEquality is only a preorder
+compareFloat :: Double -> Double -> Ordering
+compareFloat x y
+ | identicalIEEE x y = EQ
+ | isNegInf x = LT
+ | isNegInf y = GT
+ | isNaN x && isNaN y = EQ
+ | isNaN x = LT
+ | isNaN y = GT
+ | isNegativeZero x && x == y = LT
+ | isNegativeZero y && x == y = GT
+ | otherwise = compare x y
+ where
+ isNegInf z = z < 0 && isInfinite z
+
instance HasRange Literal where
getRange (LitNat r _) = r
getRange (LitFloat r _) = r
diff --git a/src/full/Agda/Syntax/Parser.hs b/src/full/Agda/Syntax/Parser.hs
index dc917f9..2e1e7bb 100644
--- a/src/full/Agda/Syntax/Parser.hs
+++ b/src/full/Agda/Syntax/Parser.hs
@@ -1,10 +1,12 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Agda.Syntax.Parser
( -- * Types
Parser
-- * Parse functions
, Agda.Syntax.Parser.parse
- , Agda.Syntax.Parser.parseLiterate
, Agda.Syntax.Parser.parsePosString
, parseFile'
-- * Parsers
@@ -15,34 +17,77 @@ module Agda.Syntax.Parser
, tokensParser
-- * Parse errors
, ParseError(..)
+ , ParseWarning(..)
+ , PM(..)
+ , runPMIO
) where
+import Control.Arrow (second)
import Control.Exception
+import Control.Monad ((>=>), forM_)
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Monad.Writer hiding ((<>))
import Data.List
+import Data.Typeable ( Typeable )
import Agda.Syntax.Position
import Agda.Syntax.Parser.Monad as M hiding (Parser, parseFlags)
import qualified Agda.Syntax.Parser.Monad as M
import qualified Agda.Syntax.Parser.Parser as P
import Agda.Syntax.Parser.Lexer
+import Agda.Syntax.Parser.Literate
import Agda.Syntax.Concrete
+import Agda.Syntax.Concrete.Definitions
import Agda.Syntax.Parser.Tokens
+import Agda.Utils.Except
+ ( Error(strMsg)
+ , ExceptT
+ , MonadError(catchError, throwError)
+ , runExceptT
+ )
import Agda.Utils.FileName
+import qualified Agda.Utils.Maybe.Strict as Strict
+import Agda.Utils.Pretty
+
+
+
+
+#if __GLASGOW_HASKELL__ <= 708
+import Control.Applicative ((<$>), Applicative)
+#endif
+
+#include "undefined.h"
+import Agda.Utils.Impossible
------------------------------------------------------------------------
-- Wrapping parse results
-wrap :: ParseResult a -> a
-wrap (ParseOk _ x) = x
-wrap (ParseFailed err) = throw err
+wrap :: ParseResult a -> PM a
+wrap (ParseOk _ x) = return x
+wrap (ParseFailed err) = throwError err
+
+wrapIOM :: (MonadError e m, MonadIO m) => (IOError -> e) -> IO a -> m a
+wrapIOM f m = do
+ a <- liftIO$ (Right <$> m) `catch` (\err -> return$ Left (err :: IOError))
+ case a of
+ Right x -> return x
+ Left err -> throwError (f err)
+
+wrapM :: IO (ParseResult a) -> PM a
+wrapM m = liftIO m >>= wrap
+
+-- | A monad for handling parse results
+newtype PM a = PM { unPM :: ExceptT ParseError (StateT [ParseWarning] IO) a }
+ deriving (Functor, Applicative, Monad,
+ MonadError ParseError, MonadIO)
-wrapM:: Monad m => m (ParseResult a) -> m a
-wrapM m =
- do r <- m
- case r of
- ParseOk _ x -> return x
- ParseFailed err -> throw err
+warning :: ParseWarning -> PM ()
+warning w = PM (modify (w:))
+
+runPMIO :: (MonadIO m) => PM a -> m (Either ParseError a, [ParseWarning])
+runPMIO = liftIO . fmap (second reverse) . flip runStateT [] . runExceptT . unPM
------------------------------------------------------------------------
-- Parse functions
@@ -50,34 +95,69 @@ wrapM m =
-- | Wrapped Parser type.
data Parser a = Parser
- { parser :: M.Parser a
- , parseFlags :: ParseFlags
+ { parser :: M.Parser a
+ , parseFlags :: ParseFlags
+ , parseLiterate :: LiterateParser a
}
-parse :: Parser a -> String -> IO a
+type LiterateParser a = Parser a -> [Layer] -> PM a
+
+parse :: Parser a -> String -> PM a
parse p = wrapM . return . M.parse (parseFlags p) [normal] (parser p)
-parseFile :: Parser a -> AbsolutePath -> IO a
+parseFile :: Parser a -> AbsolutePath -> PM a
parseFile p = wrapM . M.parseFile (parseFlags p) [layout, normal] (parser p)
-parseLiterate :: Parser a -> String -> IO a
-parseLiterate p =
- wrapM . return . M.parse (parseFlags p) [literate, layout, code] (parser p)
+parseString :: Parser a -> String -> PM a
+parseString = parseStringFromFile Strict.Nothing
+
+parseStringFromFile :: SrcFile -> Parser a -> String -> PM a
+parseStringFromFile src p = wrapM . return . M.parseFromSrc (parseFlags p) [layout, normal] (parser p) src
+
+parseLiterateWithoutComments :: LiterateParser a
+parseLiterateWithoutComments p layers = parseStringFromFile (literateSrcFile layers) p $ illiterate layers
+
+parseLiterateWithComments :: LiterateParser [Token]
+parseLiterateWithComments p layers = do
+ code <- map Left <$> parseLiterateWithoutComments p layers
+ let literate = Right <$> filter (not . isCode) layers
+ let (terms, overlaps) = interleaveRanges code literate
+ forM_ (map fst overlaps) $ \c ->
+ warning$ OverlappingTokensWarning { warnRange = getRange c }
+
+ return$ concat [ case m of
+ Left t -> [t]
+ Right (Layer Comment interval s) -> [TokTeX (interval, s)]
+ Right (Layer Markup _ _) -> []
+ Right (Layer Code _ _) -> []
+ | m <- terms ]
+
+readFilePM :: AbsolutePath -> PM String
+readFilePM path = wrapIOM (ReadFileError path) (readFile (filePath path))
+
+parseLiterateFile :: Processor -> Parser a -> AbsolutePath -> PM a
+parseLiterateFile po p path = readFilePM path >>= parseLiterate p p . po (startPos (Just path))
-parseLiterateFile :: Parser a -> AbsolutePath -> IO a
-parseLiterateFile p =
- wrapM . M.parseFile (parseFlags p) [literate, layout, code] (parser p)
+parsePosString :: Parser a -> Position -> String -> PM a
+parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) [normal] (parser p)
-parsePosString :: Parser a -> Position -> String -> IO a
-parsePosString p pos =
- wrapM . return . M.parsePosString pos (parseFlags p) [normal] (parser p)
+-- | Extensions supported by `parseFile'`
+parseFileExts :: [String]
+parseFileExts = ".agda":literateExts
-parseFile' :: Parser a -> AbsolutePath -> IO a
+parseFile' :: (Show a) => Parser a -> AbsolutePath -> PM a
parseFile' p file =
- if "lagda" `isSuffixOf` filePath file then
- Agda.Syntax.Parser.parseLiterateFile p file
- else
+ if ".agda" `isSuffixOf` filePath file then
Agda.Syntax.Parser.parseFile p file
+ else
+ go literateProcessors
+ where
+ go [] = throwError InvalidExtensionError {
+ errPath = file
+ , errValidExts = parseFileExts
+ }
+ go ((ext, po):pos) | ext `isSuffixOf` filePath file = parseLiterateFile po p file
+ go (_:pos) = go pos
------------------------------------------------------------------------
-- Specific parsers
@@ -86,19 +166,25 @@ parseFile' p file =
moduleParser :: Parser Module
moduleParser = Parser { parser = P.moduleParser
- , parseFlags = withoutComments }
+ , parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
+ }
-- | Parses a module name.
moduleNameParser :: Parser QName
moduleNameParser = Parser { parser = P.moduleNameParser
- , parseFlags = withoutComments }
+ , parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
+ }
-- | Parses an expression.
exprParser :: Parser Expr
exprParser = Parser { parser = P.exprParser
- , parseFlags = withoutComments }
+ , parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
+ }
-- | Parses an expression followed by a where clause.
@@ -106,13 +192,16 @@ exprWhereParser :: Parser ExprWhere
exprWhereParser = Parser
{ parser = P.exprWhereParser
, parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
}
-- | Gives the parsed token stream (including comments).
tokensParser :: Parser [Token]
tokensParser = Parser { parser = P.tokensParser
- , parseFlags = withComments }
+ , parseFlags = withComments
+ , parseLiterate = parseLiterateWithComments
+ }
-- | Keep comments in the token stream generated by the lexer.
diff --git a/src/full/Agda/Syntax/Parser/LexActions.hs b/src/full/Agda/Syntax/Parser/LexActions.hs
index df79d20..28e6539 100644
--- a/src/full/Agda/Syntax/Parser/LexActions.hs
+++ b/src/full/Agda/Syntax/Parser/LexActions.hs
@@ -72,6 +72,8 @@ postToken (TokId (r, "\x2026")) = TokSymbol SymEllipsis r
postToken (TokId (r, "\x2192")) = TokSymbol SymArrow r
postToken (TokId (r, "\x2983")) = TokSymbol SymDoubleOpenBrace r
postToken (TokId (r, "\x2984")) = TokSymbol SymDoubleCloseBrace r
+postToken (TokId (r, "\x2987")) = TokSymbol SymOpenIdiomBracket r
+postToken (TokId (r, "\x2988")) = TokSymbol SymCloseIdiomBracket r
postToken (TokId (r, "\x2200")) = TokKeyword KwForall r
postToken (TokId (r, s))
| set == "Set" && all isSub n = TokSetN (r, readSubscript n)
diff --git a/src/full/Agda/Syntax/Parser/Lexer.x b/src/full/Agda/Syntax/Parser/Lexer.x
index bdb592c..966aa80 100644
--- a/src/full/Agda/Syntax/Parser/Lexer.x
+++ b/src/full/Agda/Syntax/Parser/Lexer.x
@@ -14,7 +14,7 @@ module Agda.Syntax.Parser.Lexer
( -- * The main function
lexer
-- * Lex states
- , normal, literate, code
+ , normal, code
, layout, empty_layout, bol, imp_dir
-- * Alex generated functions
, AlexReturn(..), alexScanUser
@@ -65,16 +65,6 @@ $white_nonl = $white_notab # \n
tokens :-
--- Lexing literate files
-<tex> $white_nonl* \\ "begin{code}" $white_nonl* $ { end_ }
-<tex> .+ / { keepComments } { withInterval TokTeX }
-<tex> .+ ;
-<tex> \n ;
-<tex> () / { eof } { end_ }
-<bol_,layout_>
- \\ "end{code}" / { inState code } { begin_ tex }
- -- \end{code} should only be recognized if the bottom of the stack is <code>
-
-- White space
<0,code,bol_,layout_,empty_layout_,imp_dir_>
$white_nonl+ ;
@@ -105,10 +95,10 @@ tokens :-
<pragma_> "LINE" { keyword KwLINE }
<pragma_> "MEASURE" { keyword KwMEASURE }
<pragma_> "NO_POSITIVITY_CHECK" { keyword KwNO_POSITIVITY_CHECK }
-<pragma_> "NO_SMASHING" { keyword KwNO_SMASHING }
<pragma_> "NO_TERMINATION_CHECK" { keyword KwNO_TERMINATION_CHECK }
<pragma_> "NON_TERMINATING" { keyword KwNON_TERMINATING }
<pragma_> "OPTIONS" { keyword KwOPTIONS }
+<pragma_> "POLARITY" { keyword KwPOLARITY }
<pragma_> "REWRITE" { keyword KwREWRITE }
<pragma_> "STATIC" { keyword KwSTATIC }
<pragma_> "TERMINATING" { keyword KwTERMINATING }
@@ -179,6 +169,7 @@ tokens :-
<0,code> abstract { keyword KwAbstract }
<0,code> private { keyword KwPrivate }
<0,code> instance { keyword KwInstance }
+<0,code> overlap { keyword KwOverlap }
<0,code> macro { keyword KwMacro }
<0,code> Set { keyword KwSet }
<0,code> forall { keyword KwForall }
@@ -216,6 +207,8 @@ tokens :-
<0,code> "_" { symbol SymUnderscore }
<0,code> "?" { symbol SymQuestionMark }
<0,code> "|" { symbol SymBar }
+<0,code> "(|" /[$white] { symbol SymOpenIdiomBracket }
+<0,code> "|)" { symbol SymCloseIdiomBracket }
<0,code> "(" { symbol SymOpenParen }
<0,code> ")" { symbol SymCloseParen }
<0,code> "->" { symbol SymArrow }
@@ -248,12 +241,6 @@ tokens :-
{
--- | This is the initial state for parsing a literate file. Code blocks
--- should be enclosed in @\\begin{code}@ @\\end{code}@ pairs.
-literate :: LexState
-literate = tex
-
-
-- | This is the initial state for parsing a regular, non-literate file.
normal :: LexState
normal = 0
diff --git a/src/full/Agda/Syntax/Parser/Literate.hs b/src/full/Agda/Syntax/Parser/Literate.hs
new file mode 100644
index 0000000..f997af7
--- /dev/null
+++ b/src/full/Agda/Syntax/Parser/Literate.hs
@@ -0,0 +1,219 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+-- | Preprocessors for literate code formats
+module Agda.Syntax.Parser.Literate (
+ literateProcessors,
+ literateExts,
+ literateExtsShortList,
+ literateSrcFile,
+ literateTeX,
+ literateRsT,
+ illiterate,
+ isCode,
+ Processor,
+ Layer(..),
+ LayerType(..)
+ )
+ where
+
+import Prelude hiding (getLine)
+import Data.Char (isSpace, isControl)
+import Data.List (isPrefixOf)
+import Agda.Syntax.Position
+import Text.Regex.TDFA
+
+#if __GLASGOW_HASKELL__ <= 708
+import Control.Applicative ((<$>),(<*>))
+#endif
+
+#include "undefined.h"
+import Agda.Utils.Impossible
+
+data LayerType = Markup | Comment | Code
+ deriving (Show, Eq)
+
+data Layer = Layer {
+ layerType :: LayerType
+ ,interval :: Interval
+ ,layerContent :: String
+} deriving (Show)
+
+instance HasRange Layer where
+ getRange = getRange . interval
+
+-- | Annotates a tokenized string with position information.
+mkLayers :: Position -> [(LayerType, String)] -> [Layer]
+mkLayers pos [] = emptyLiterate pos
+mkLayers pos ((_,""):xs) = mkLayers pos xs
+mkLayers pos ((ty,s):xs) = let next = movePosByString pos s in
+ (Layer ty (Interval pos next) s):(mkLayers next xs)
+
+-- | Checks if a layer corresponds to Agda code
+isCode :: Layer -> Bool
+isCode Layer{layerType=Code} = True
+isCode Layer{layerType=Markup } = False
+isCode Layer{layerType=Comment} = False
+
+-- | Type of a literate preprocessor:
+-- Invariants:
+--
+-- > f : Processor
+--
+-- prop> f pos s /= []
+--
+-- prop> f pos s >>= layerContent == s
+type Processor = Position -> String -> [Layer]
+
+literateSrcFile :: [Layer] -> SrcFile
+literateSrcFile [] = __IMPOSSIBLE__
+literateSrcFile (Layer{interval}:_) = getIntervalFile interval
+
+-- | List of valid extensions for literate Agda files, and their corresponding
+-- preprocessors.
+--
+-- If you add new extensions, remember to update test/Utils.hs so that test
+-- cases ending in the new extensions are found.
+literateProcessors :: [(String, Processor)]
+literateProcessors = map ((,) <$> (".lagda" ++) . fst <*> snd)
+ [("" , literateTeX)
+ ,(".rst", literateRsT)
+ ,(".tex", literateTeX)
+ ]
+
+-- | Blanks the non-code parts of a given file, preserving positions of
+-- characters corresponding to code. This way, there is a direct
+-- correspondence between source positions and positions in the
+-- processed result.
+illiterate :: [Layer] -> String
+illiterate xs = concat [
+ (if isCode m then id else bleach) layerContent
+ | m@Layer{layerContent} <- xs]
+
+-- | Replaces non-space characters in a string with spaces.
+bleach :: String -> String
+bleach s = map go s
+ where
+ go c | isSpace c = c
+ go _ = ' '
+
+-- | Check if a character is a blank character.
+isBlank :: Char -> Bool
+isBlank = (&&) <$> isSpace <*> not . (== '\n')
+
+-- | Possible extensions for a literate Agda file
+literateExts :: [String]
+literateExts = map fst literateProcessors
+
+-- | Short list of extensions for literate Agda files
+-- For display purposes.
+literateExtsShortList :: [String]
+literateExtsShortList = [".lagda"]
+
+-- | break a list just *after* an element satisfying the predicate is found
+--
+-- >>> break1 even [1,3,5,2,4,7,8]
+-- ([1,3,5,2],[4,7,8])
+--
+break1 :: (a -> Bool) -> [a] -> ([a],[a])
+break1 _ [] = ([], [])
+break1 p (x:xs) | p x = (x:[],xs)
+break1 p (x:xs) = let (ys,zs) = break1 p xs in (x:ys,zs)
+
+-- | Returns a tuple consisting of the first line of the input, and the rest
+-- of the input.
+getLine :: String -> (String, String)
+getLine = break1 (== '\n')
+
+-- | Canonical decomposition of an empty literate file
+emptyLiterate :: Position -> [Layer]
+emptyLiterate pos = [Layer (Markup) (Interval pos pos) ""]
+
+-- | Create a regular expression that:
+-- - Must match the whole string
+-- - Works across line boundaries
+rex :: String -> Regex
+rex s = makeRegexOpts blankCompOpt{newSyntax = True} blankExecOpt$ "\\`" ++ s ++ "\\'"
+
+-- | Preprocessor for literate TeX
+literateTeX :: Position -> String -> [Layer]
+literateTeX pos s = mkLayers pos$ tex s
+ where
+ tex :: String -> [(LayerType, String)]
+ tex [] = []
+ tex s = let (line, rest) = getLine s in
+ case r_begin `matchM` line of
+ Just (getAllTextSubmatches -> [_, pre, markup]) ->
+ (Comment, pre):(Markup, markup):code rest
+ Just _ -> __IMPOSSIBLE__
+ Nothing -> (Comment, line):tex rest
+
+ r_begin = rex "(.*)([[:space:]]*\\\\begin\\{code\\}[[:space:]]*)"
+
+
+ code :: String -> [(LayerType, String)]
+ code [] = []
+ code s = let (line, rest) = getLine s in
+ case r_end `matchM` line of
+ Just (getAllTextSubmatches -> [_, markup, post]) ->
+ (Markup, markup):(Comment, post):tex rest
+ Just _ -> __IMPOSSIBLE__
+ Nothing -> (Code, line):code rest
+
+ r_end = rex "([[:space:]]*\\\\end\\{code\\}[[:space:]]*)(.*)"
+
+
+-- | Preprocessor for reStructuredText
+literateRsT :: Position -> String -> [Layer]
+literateRsT pos s = mkLayers pos$ rst s
+ where
+ rst :: String -> [(LayerType, String)]
+ rst [] = []
+ rst s = maybe_code s
+
+ maybe_code s =
+ if r_comment `match` line then
+ not_code
+ else case r_code `match` line of
+ [] -> not_code
+ [[_, before, "::", after]] ->
+ -- Code starts
+ if null before || isBlank (last before) then
+ (Markup, line):code rest
+ else
+ (Comment, before ++ ":"):(Markup, ':':after):code rest
+
+ _ -> __IMPOSSIBLE__
+ where
+ (line, rest) = getLine s
+ not_code = (Comment, line):rst rest
+
+
+ -- | Finds the next indented block in the input
+ code :: String -> [(LayerType, String)]
+ code [] = []
+ code s = let (line, rest) = getLine s in
+ if all isSpace line then
+ (Markup, line):(code rest)
+ else
+ let (xs,ys) = span isBlank line in
+ case xs of
+ [] -> maybe_code s
+ _ -> (Code, line):
+ (indented xs rest)
+
+ -- | Process an indented block
+ indented :: String -> String -> [(LayerType, String)]
+ indented _ [] = []
+ indented ind s = let (line, rest) = getLine s in
+ if all isSpace line then
+ (Code, line):(indented ind rest)
+ else if ind `isPrefixOf` line then
+ (Code, line):(indented ind rest)
+ else
+ maybe_code s
+
+ -- | Beginning of a code block
+ r_code = rex "(.*)(::)([[:space:]]*)"
+
+ -- | Beginning of a comment block
+ r_comment = rex "[[:space:]]*\\.\\.([[:space:]].*)?"
diff --git a/src/full/Agda/Syntax/Parser/LookAhead.hs b/src/full/Agda/Syntax/Parser/LookAhead.hs
index d0bad54..8b286d2 100644
--- a/src/full/Agda/Syntax/Parser/LookAhead.hs
+++ b/src/full/Agda/Syntax/Parser/LookAhead.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE Rank2Types #-}
{-| When lexing by hands (for instance string literals) we need to do some
looking ahead. The 'LookAhead' monad keeps track of the position we are
diff --git a/src/full/Agda/Syntax/Parser/Monad.hs b/src/full/Agda/Syntax/Parser/Monad.hs
index b8f1add..1cd289a 100644
--- a/src/full/Agda/Syntax/Parser/Monad.hs
+++ b/src/full/Agda/Syntax/Parser/Monad.hs
@@ -1,12 +1,12 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
module Agda.Syntax.Parser.Monad
( -- * The parser monad
Parser
, ParseResult(..)
, ParseState(..)
- , ParseError(..)
+ , ParseError(..), ParseWarning(..)
, LexState
, LayoutContext(..)
, ParseFlags (..)
@@ -14,8 +14,9 @@ module Agda.Syntax.Parser.Monad
, initState
, defaultParseFlags
, parse
- , parsePosString
, parseFile
+ , parsePosString
+ , parseFromSrc
-- * Manipulating the state
, setParsePos, setLastPos, getParseInterval
, setPrevToken
@@ -30,7 +31,7 @@ module Agda.Syntax.Parser.Monad
)
where
-import Control.Exception
+import Control.Exception (catch)
import Data.Int
import Data.Typeable ( Typeable )
@@ -40,12 +41,19 @@ import Control.Applicative
import Agda.Syntax.Position
import Agda.Utils.Except ( MonadError(catchError, throwError) )
+#if !(MIN_VERSION_mtl(2,2,1))
+import Agda.Utils.Except ( Error(noMsg) )
+#endif
import Agda.Utils.FileName
import qualified Agda.Utils.IO.UTF8 as UTF8
+import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Pretty
+#include "undefined.h"
+import Agda.Utils.Impossible
+
{--------------------------------------------------------------------------
The parse monad
--------------------------------------------------------------------------}
@@ -92,7 +100,9 @@ data ParseFlags = ParseFlags
deriving Show
-- | What you get if parsing fails.
-data ParseError = ParseError
+data ParseError =
+ -- | Errors that arise at a specific position in the file
+ ParseError
{ errSrcFile :: !SrcFile
-- ^ The file in which the error occurred.
, errPos :: !PositionWithoutFile
@@ -103,10 +113,31 @@ data ParseError = ParseError
-- ^ The previous token.
, errMsg :: String
-- ^ Hopefully an explanation of what happened.
+ } |
+ -- | Parse errors that concern a range in a file.
+ OverlappingTokensError
+ { errRange :: !(Range' SrcFile)
+ -- ^ The range of the bigger overlapping token
+ } |
+ -- | Parse errors that concern a whole file.
+ InvalidExtensionError
+ { errPath :: !AbsolutePath
+ -- ^ The file which the error concerns.
+ , errValidExts :: [String]
+ } |
+ ReadFileError
+ { errPath :: !AbsolutePath
+ , errIOError :: IOError
+ }
+ deriving (Typeable)
+
+-- | Warnings for parsing
+data ParseWarning =
+ -- | Parse errors that concern a range in a file.
+ OverlappingTokensWarning
+ { warnRange :: !(Range' SrcFile)
+ -- ^ The range of the bigger overlapping token
}
- deriving (Typeable)
-
-instance Exception ParseError
-- | The result of parsing something.
data ParseResult a = ParseOk ParseState a
@@ -153,16 +184,52 @@ instance Show ParseError where
show = prettyShow
instance Pretty ParseError where
- pretty err = vcat
- [ pretty ((errPos err) { srcFile = errSrcFile err }) <> colon <+>
- text (errMsg err)
- , text $ errPrevToken err ++ "<ERROR>"
- , text $ take 30 (errInput err) ++ "..."
+ pretty ParseError{errPos,errSrcFile,errMsg,errPrevToken,errInput} = vcat
+ [ pretty (errPos { srcFile = errSrcFile }) <> colon <+>
+ text errMsg
+ , text $ errPrevToken ++ "<ERROR>"
+ , text $ take 30 errInput ++ "..."
+ ]
+ pretty OverlappingTokensError{errRange} = vcat
+ [ pretty errRange <> colon <+>
+ text "Multi-line comment spans one or more literate text blocks."
+ ]
+ pretty InvalidExtensionError{errPath,errValidExts} = vcat
+ [ pretty errPath <> colon <+>
+ text "Unsupported extension."
+ , text "Supported extensions are:" <+> prettyList errValidExts
+ ]
+ pretty ReadFileError{errPath,errIOError} = vcat
+ [ text "Cannot read file" <+> pretty errPath
+ -- TODO: `show` should be replaced by `displayException` once we
+ -- cease to support versions of GHC under 7.10.
+ , text "Error:" <+> text (show errIOError)
]
instance HasRange ParseError where
- getRange err = posToRange' (errSrcFile err) p p
- where p = errPos err
+ getRange ParseError{errSrcFile,errPos=p} = posToRange' errSrcFile p p
+ getRange OverlappingTokensError{errRange} = errRange
+ getRange InvalidExtensionError{errPath} = posToRange p p
+ where p = startPos (Just errPath)
+ getRange ReadFileError{errPath} = posToRange p p
+ where p = startPos (Just errPath)
+
+#if !(MIN_VERSION_mtl(2,2,1))
+-- Stupid ErrorT!
+instance Error ParseError where
+ noMsg = __IMPOSSIBLE__
+#endif
+
+instance Show ParseWarning where
+ show = prettyShow
+
+instance Pretty ParseWarning where
+ pretty OverlappingTokensWarning{warnRange} = vcat
+ [ pretty warnRange <> colon <+>
+ text "Multi-line comment spans one or more literate text blocks."
+ ]
+instance HasRange ParseWarning where
+ getRange OverlappingTokensWarning{warnRange} = warnRange
{--------------------------------------------------------------------------
Running the parser
@@ -198,7 +265,7 @@ defaultParseFlags = ParseFlags { parseKeepComments = False }
-- more specialised functions that supply the 'ParseFlags' and the
-- 'LexState'.
parse :: ParseFlags -> [LexState] -> Parser a -> String -> ParseResult a
-parse flags st p input = unP p (initState Nothing flags input st)
+parse flags st p input = parseFromSrc flags st p Strict.Nothing input
-- | The even more general way of parsing a string.
parsePosString :: Position -> ParseFlags -> [LexState] -> Parser a -> String ->
@@ -214,8 +281,18 @@ parsePosString pos flags st p input = unP p (initStatePos pos flags input st)
parseFile :: ParseFlags -> [LexState] -> Parser a -> AbsolutePath
-> IO (ParseResult a)
parseFile flags st p file =
- do input <- liftIO $ UTF8.readTextFile $ filePath file
- return $ unP p (initState (Just file) flags input st)
+ do res <- (Right <$> (UTF8.readTextFile (filePath file))) `catch`
+ (return . Left . ReadFileError file)
+ case res of
+ Left error -> return$ ParseFailed error
+ Right input -> return$ parseFromSrc flags st p (Strict.Just file) input
+
+-- | Parses a string as if it were the contents of the given file
+-- Useful for integrating preprocessors.
+parseFromSrc :: ParseFlags -> [LexState] -> Parser a -> SrcFile -> String
+ -> ParseResult a
+parseFromSrc flags st p src input = unP p (initState (Strict.toLazy src) flags input st)
+
{--------------------------------------------------------------------------
Manipulating the state
diff --git a/src/full/Agda/Syntax/Parser/Parser.y b/src/full/Agda/Syntax/Parser/Parser.y
index 2146e22..78c3b1e 100644
--- a/src/full/Agda/Syntax/Parser/Parser.y
+++ b/src/full/Agda/Syntax/Parser/Parser.y
@@ -20,7 +20,7 @@ module Agda.Syntax.Parser.Parser (
, exprParser
, exprWhereParser
, tokensParser
- , tests
+ , splitOnDots -- only used by the internal test-suite
) where
import Control.Monad
@@ -45,14 +45,14 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Literal
+import Agda.TypeChecking.Positivity.Occurrence hiding (tests)
+
import Agda.Utils.Either hiding (tests)
import Agda.Utils.Hash
-import Agda.Utils.List (spanJust)
+import Agda.Utils.List ( spanJust, chopWhen )
import Agda.Utils.Monad
import Agda.Utils.Pretty
-import Agda.Utils.QuickCheck
import Agda.Utils.Singleton
-import Agda.Utils.TestHelpers
import Agda.Utils.Tuple
import Agda.Utils.Impossible
@@ -97,6 +97,7 @@ import Agda.Utils.Impossible
'infixl' { TokKeyword KwInfixL $$ }
'infixr' { TokKeyword KwInfixR $$ }
'instance' { TokKeyword KwInstance $$ }
+ 'overlap' { TokKeyword KwOverlap $$ }
'let' { TokKeyword KwLet $$ }
'macro' { TokKeyword KwMacro $$ }
'module' { TokKeyword KwModule $$ }
@@ -145,11 +146,11 @@ import Agda.Utils.Impossible
'IMPOSSIBLE' { TokKeyword KwIMPOSSIBLE $$ }
'INLINE' { TokKeyword KwINLINE $$ }
'MEASURE' { TokKeyword KwMEASURE $$ }
- 'NO_SMASHING' { TokKeyword KwNO_SMASHING $$ }
'NO_TERMINATION_CHECK' { TokKeyword KwNO_TERMINATION_CHECK $$ }
'NO_POSITIVITY_CHECK' { TokKeyword KwNO_POSITIVITY_CHECK $$ }
'NON_TERMINATING' { TokKeyword KwNON_TERMINATING $$ }
'OPTIONS' { TokKeyword KwOPTIONS $$ }
+ 'POLARITY' { TokKeyword KwPOLARITY $$ }
'REWRITE' { TokKeyword KwREWRITE $$ }
'STATIC' { TokKeyword KwSTATIC $$ }
'TERMINATING' { TokKeyword KwTERMINATING $$ }
@@ -172,6 +173,8 @@ import Agda.Utils.Impossible
'|' { TokSymbol SymBar $$ }
'(' { TokSymbol SymOpenParen $$ }
')' { TokSymbol SymCloseParen $$ }
+ '(|' { TokSymbol SymOpenIdiomBracket $$ }
+ '|)' { TokSymbol SymCloseIdiomBracket $$ }
'{{' { TokSymbol SymDoubleOpenBrace $$ }
'}}' { TokSymbol SymDoubleCloseBrace $$ }
'{' { TokSymbol SymOpenBrace $$ }
@@ -224,6 +227,7 @@ Token
| 'infixl' { TokKeyword KwInfixL $1 }
| 'infixr' { TokKeyword KwInfixR $1 }
| 'instance' { TokKeyword KwInstance $1 }
+ | 'overlap' { TokKeyword KwOverlap $1 }
| 'let' { TokKeyword KwLet $1 }
| 'macro' { TokKeyword KwMacro $1 }
| 'module' { TokKeyword KwModule $1 }
@@ -272,11 +276,11 @@ Token
| 'IMPOSSIBLE' { TokKeyword KwIMPOSSIBLE $1 }
| 'INLINE' { TokKeyword KwINLINE $1 }
| 'MEASURE' { TokKeyword KwMEASURE $1 }
- | 'NO_SMASHING' { TokKeyword KwNO_SMASHING $1 }
| 'NO_TERMINATION_CHECK' { TokKeyword KwNO_TERMINATION_CHECK $1 }
| 'NO_POSITIVITY_CHECK' { TokKeyword KwNO_POSITIVITY_CHECK $1 }
| 'NON_TERMINATING' { TokKeyword KwNON_TERMINATING $1 }
| 'OPTIONS' { TokKeyword KwOPTIONS $1 }
+ | 'POLARITY' { TokKeyword KwPOLARITY $1 }
| 'REWRITE' { TokKeyword KwREWRITE $1 }
| 'STATIC' { TokKeyword KwSTATIC $1 }
| 'TERMINATING' { TokKeyword KwTERMINATING $1 }
@@ -299,6 +303,8 @@ Token
| '|' { TokSymbol SymBar $1 }
| '(' { TokSymbol SymOpenParen $1 }
| ')' { TokSymbol SymCloseParen $1 }
+ | '(|' { TokSymbol SymOpenIdiomBracket $1 }
+ | '|)' { TokSymbol SymCloseIdiomBracket $1 }
| '{{' { TokSymbol SymDoubleOpenBrace $1 }
| '}}' { TokSymbol SymDoubleCloseBrace $1 }
| '{' { TokSymbol SymOpenBrace $1 }
@@ -405,8 +411,9 @@ DoubleCloseBrace
-- A possibly dotted identifier.
MaybeDottedId :: { Arg Name }
MaybeDottedId
- : '.' Id { setRelevance Irrelevant $ defaultArg $2 }
- | Id { defaultArg $1 }
+ : '..' Id { setRelevance NonStrict $ defaultArg $2 }
+ | '.' Id { setRelevance Irrelevant $ defaultArg $2 }
+ | Id { defaultArg $1 }
-- Space separated list of one or more possibly dotted identifiers.
MaybeDottedIds :: { [Arg Name] }
@@ -563,7 +570,10 @@ PragmaName :: { Name }
PragmaName : string {% mkName $1 }
PragmaQName :: { QName }
-PragmaQName : string {% fmap QName (mkName $1) }
+PragmaQName : string {% pragmaQName $1 } -- Issue 2125. WAS: string {% fmap QName (mkName $1) }
+
+PragmaQNames :: { [QName] }
+PragmaQNames : Strings {% mapM pragmaQName $1 }
{--------------------------------------------------------------------------
Expressions (terms and types)
@@ -628,6 +638,7 @@ Expr2
ExtendedOrAbsurdLam :: { Expr }
ExtendedOrAbsurdLam
: '\\' '{' LamClauses '}' { ExtendedLam (getRange ($1,$2,$3,$4)) (reverse $3) }
+ | '\\' 'where' vopen LamClauses close { ExtendedLam (getRange ($1, $2, $4)) (reverse $4) }
| '\\' AbsurdLamBindings {% case $2 of
Left (bs, h) -> if null bs then return $ AbsurdLam r h else
return $ Lam r bs (AbsurdLam r h)
@@ -663,6 +674,7 @@ Expr3NoCurly
| '{{' Expr DoubleCloseBrace { InstanceArg (getRange ($1,$2,$3))
(maybeNamed $2) }
| '(' Expr ')' { Paren (getRange ($1,$2,$3)) $2 }
+ | '(|' Expr '|)' { IdiomBrackets (getRange ($1,$2,$3)) $2 }
| '(' ')' { Absurd (fuseRange $1 $2) }
| '{{' DoubleCloseBrace { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }
| Id '@' Expr3 { As (getRange ($1,$2,$3)) $1 $3 }
@@ -1018,8 +1030,8 @@ WhereClause :: { WhereClause }
WhereClause
: {- empty -} { NoWhere }
| 'where' Declarations0 { AnyWhere $2 }
- | 'module' Id 'where' Declarations0 { SomeWhere $2 $4 }
- | 'module' Underscore 'where' Declarations0 { SomeWhere $2 $4 }
+ | 'module' Id 'where' Declarations0 { SomeWhere $2 PublicAccess $4 }
+ | 'module' Underscore 'where' Declarations0 { SomeWhere $2 PublicAccess $4 }
ExprWhere :: { ExprWhere }
ExprWhere : Expr WhereClause { ExprWhere $1 $2 }
@@ -1070,6 +1082,9 @@ TypeSigs : SpaceIds ':' Expr { map (\ x -> TypeSig defaultArgInfo x $3) $1 }
ArgTypeSigs :: { [Arg Declaration] }
ArgTypeSigs
: ArgIds ':' Expr { map (fmap (\ x -> TypeSig defaultArgInfo x $3)) $1 }
+ | 'overlap' ArgIds ':' Expr {
+ let setOverlap (Arg i x) = Arg i{ argInfoOverlappable = True } x in
+ map (setOverlap . fmap (\ x -> TypeSig defaultArgInfo x $4)) $2 }
| 'instance' ArgTypeSignatures {
let
setInstance (TypeSig info x t) = TypeSig (setHiding Instance info) x t
@@ -1155,7 +1170,7 @@ Abstract : 'abstract' Declarations { Abstract (fuseRange $1 $2) $2 }
-- Private can only appear on the top-level (or rather the module level).
Private :: { Declaration }
-Private : 'private' Declarations { Private (fuseRange $1 $2) $2 }
+Private : 'private' Declarations { Private (fuseRange $1 $2) UserWritten $2 }
-- Instance declarations.
@@ -1261,7 +1276,7 @@ Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%
; impStm asR = Import mr m (Just (AsName fresh asR)) DontOpen defaultImportDir
; appStm m' es =
let r = getRange (m, es) in
- Private r
+ Private r Inserted
[ ModuleMacro r m'
(SectionApp (getRange es) []
(RawApp (getRange es) (Ident (QName fresh) : es)))
@@ -1299,18 +1314,19 @@ Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%
} in
[ case es of
{ [] -> Open r m dir
- ; _ -> Private r [ ModuleMacro r (noName $ beginningOf $ getRange m)
+ ; _ -> Private r Inserted
+ [ ModuleMacro r (noName $ beginningOf $ getRange m)
(SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))
DoOpen dir
- ]
+ ]
}
]
}
| 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {
let r = getRange $2 in
- [ Private r [ ModuleMacro r (noName $ beginningOf $ getRange $2)
- (RecordModuleIFS r $2) DoOpen $6
- ]
+ [ Private r Inserted
+ [ ModuleMacro r (noName $ beginningOf $ getRange $2) (RecordModuleIFS r $2) DoOpen $6
+ ]
]
}
@@ -1366,7 +1382,6 @@ DeclarationPragma
| CompiledUHCPragma { $1 }
| CompiledDataUHCPragma { $1 }
| HaskellPragma { $1 }
- | NoSmashingPragma { $1 }
| StaticPragma { $1 }
| InlinePragma { $1 }
| ImportPragma { $1 }
@@ -1379,6 +1394,7 @@ DeclarationPragma
| CatchallPragma { $1 }
| DisplayPragma { $1 }
| NoPositivityCheckPragma { $1 }
+ | PolarityPragma { $1 }
| OptionsPragma { $1 }
-- Andreas, 2014-03-06
-- OPTIONS pragma not allowed everywhere, but don't give parse error.
@@ -1397,7 +1413,7 @@ BuiltinPragma
RewritePragma :: { Pragma }
RewritePragma
- : '{-#' 'REWRITE' PragmaQName '#-}'
+ : '{-#' 'REWRITE' PragmaQNames '#-}'
{ RewritePragma (getRange ($1,$2,$3,$4)) $3 }
CompiledPragma :: { Pragma }
@@ -1449,11 +1465,6 @@ HaskellPragma :: { Pragma }
HaskellPragma
: '{-#' 'HASKELL' Strings '#-}' { HaskellCodePragma (getRange ($1, $2, $4)) (recoverLayout $3) }
-NoSmashingPragma :: { Pragma }
-NoSmashingPragma
- : '{-#' 'NO_SMASHING' PragmaQName '#-}'
- { NoSmashingPragma (getRange ($1,$2,$3,$4)) $3 }
-
StaticPragma :: { Pragma }
StaticPragma
: '{-#' 'STATIC' PragmaQName '#-}'
@@ -1524,6 +1535,20 @@ NoPositivityCheckPragma
: '{-#' 'NO_POSITIVITY_CHECK' '#-}'
{ NoPositivityCheckPragma (getRange ($1,$2,$3)) }
+PolarityPragma :: { Pragma }
+PolarityPragma
+ : '{-#' 'POLARITY' PragmaName Polarities '#-}'
+ { let (rs, occs) = unzip (reverse $4) in
+ PolarityPragma (getRange ($1,$2,$3,rs,$5)) $3 occs }
+
+-- Possibly empty list of polarities. Reversed.
+Polarities :: { [(Range, Occurrence)] }
+Polarities : {- empty -} { [] }
+ | Polarities Polarity { $2 : $1 }
+
+Polarity :: { (Range, Occurrence) }
+Polarity : string {% polarity $1 }
+
{--------------------------------------------------------------------------
Sequences of declarations
--------------------------------------------------------------------------}
@@ -1692,6 +1717,29 @@ mkQName ss = do
xs <- mapM mkName ss
return $ foldr Qual (QName $ last xs) (init xs)
+-- | Create a qualified name from a string (used in pragmas).
+-- Range of each name component is range of whole string.
+-- TODO: precise ranges!
+
+pragmaQName :: (Interval, String) -> Parser QName
+pragmaQName (r, s) = do
+ let ss = chopWhen (== '.') s
+ mkQName $ map (r,) ss
+
+-- | Polarity parser.
+
+polarity :: (Interval, String) -> Parser (Range, Occurrence)
+polarity (i, s) =
+ case s of
+ "_" -> ret Unused
+ "++" -> ret StrictPos
+ "+" -> ret JustPos
+ "-" -> ret JustNeg
+ "*" -> ret Mixed
+ _ -> fail $ "Not a valid polarity: " ++ s
+ where
+ ret x = return (getRange i, x)
+
recoverLayout :: [(Interval, String)] -> String
recoverLayout [] = ""
recoverLayout xs@((i, _) : _) = go (iStart i) xs
@@ -1804,13 +1852,6 @@ splitOnDots ('.' : s) = [] : splitOnDots s
splitOnDots (c : s) = case splitOnDots s of
p : ps -> (c : p) : ps
-prop_splitOnDots = and
- [ splitOnDots "" == [""]
- , splitOnDots "foo.bar" == ["foo", "bar"]
- , splitOnDots ".foo.bar" == ["", "foo", "bar"]
- , splitOnDots "foo.bar." == ["foo", "bar", ""]
- , splitOnDots "foo..bar" == ["foo", "", "bar"]
- ]
-- | Returns 'True' iff the name is a valid Haskell (hierarchical)
-- module name.
@@ -1853,8 +1894,8 @@ exprToPattern e = do
Underscore r _ -> return $ WildP r
Absurd r -> return $ AbsurdP r
As r x e -> AsP r x <$> exprToPattern e
- Dot r (HiddenArg _ e) -> return $ HiddenP r $ fmap (DotP r) e
- Dot r e -> return $ DotP r e
+ Dot r (HiddenArg _ e) -> return $ HiddenP r $ fmap (DotP r UserWritten) e
+ Dot r e -> return $ DotP r UserWritten e
Lit l -> return $ LitP l
HiddenArg r e -> HiddenP r <$> T.mapM exprToPattern e
InstanceArg r e -> InstanceP r <$> T.mapM exprToPattern e
@@ -1916,7 +1957,7 @@ patternToNames p =
case p of
IdentP (QName i) -> return [(defaultArgInfo, i)]
WildP r -> return [(defaultArgInfo, C.noName r)]
- DotP _ (Ident (QName i)) -> return [(setRelevance Irrelevant defaultArgInfo, i)]
+ DotP _ _ (Ident (QName i)) -> return [(setRelevance Irrelevant defaultArgInfo, i)]
RawAppP _ ps -> concat <$> mapM patternToNames ps
_ -> parseError $
"Illegal name in type signature: " ++ prettyShow p
@@ -1942,14 +1983,4 @@ parseDisplayPragma r pos s =
return $ DisplayPragma r lhs rhs
_ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."
-{--------------------------------------------------------------------------
- Tests
- --------------------------------------------------------------------------}
-
--- | Test suite.
-tests :: IO Bool
-tests = runTests "Agda.Syntax.Parser.Parser"
- [ quickCheck' prop_splitOnDots
- ]
-
}
diff --git a/src/full/Agda/Syntax/Parser/Tokens.hs b/src/full/Agda/Syntax/Parser/Tokens.hs
index 201c0c0..e109deb 100644
--- a/src/full/Agda/Syntax/Parser/Tokens.hs
+++ b/src/full/Agda/Syntax/Parser/Tokens.hs
@@ -11,6 +11,7 @@ import Agda.Syntax.Position
data Keyword
= KwLet | KwIn | KwWhere | KwData | KwCoData
| KwPostulate | KwMutual | KwAbstract | KwPrivate | KwInstance
+ | KwOverlap
| KwOpen | KwImport | KwModule | KwPrimitive | KwMacro
| KwInfix | KwInfixL | KwInfixR | KwWith | KwRewrite
| KwSet | KwProp | KwForall | KwRecord | KwConstructor | KwField
@@ -21,7 +22,7 @@ data Keyword
| KwCOMPILED_DATA | KwCOMPILED_DECLARE_DATA | KwCOMPILED_TYPE | KwCOMPILED | KwCOMPILED_EXPORT
| KwHASKELL
| KwCOMPILED_EPIC | KwCOMPILED_JS | KwCOMPILED_UHC | KwCOMPILED_DATA_UHC
- | KwIMPORT | KwIMPORT_UHC | KwIMPOSSIBLE | KwSTATIC | KwINLINE | KwNO_SMASHING
+ | KwIMPORT | KwIMPORT_UHC | KwIMPOSSIBLE | KwSTATIC | KwINLINE
| KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING
| KwMEASURE | KwDISPLAY
| KwREWRITE
@@ -29,7 +30,7 @@ data Keyword
| KwUnquote | KwUnquoteDecl | KwUnquoteDef
| KwSyntax
| KwPatternSyn | KwTactic | KwCATCHALL
- | KwNO_POSITIVITY_CHECK
+ | KwNO_POSITIVITY_CHECK | KwPOLARITY
deriving (Eq, Show)
layoutKeywords :: [Keyword]
@@ -41,6 +42,7 @@ data Symbol
| SymColon | SymArrow | SymEqual | SymLambda
| SymUnderscore | SymQuestionMark | SymAs
| SymOpenParen | SymCloseParen
+ | SymOpenIdiomBracket | SymCloseIdiomBracket
| SymDoubleOpenBrace | SymDoubleCloseBrace
| SymOpenBrace | SymCloseBrace
| SymOpenVirtualBrace | SymCloseVirtualBrace
diff --git a/src/full/Agda/Syntax/Position.hs b/src/full/Agda/Syntax/Position.hs
index 54bbcbe..eaf9153 100644
--- a/src/full/Agda/Syntax/Position.hs
+++ b/src/full/Agda/Syntax/Position.hs
@@ -1,14 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
#if __GLASGOW_HASKELL__ <= 708
{-# LANGUAGE OverlappingInstances #-}
@@ -28,6 +23,7 @@ module Agda.Syntax.Position
, movePos
, movePosByString
, backupPos
+ , startPos'
-- * Intervals
, Interval
@@ -37,13 +33,18 @@ module Agda.Syntax.Position
, posToInterval
, takeI
, dropI
+ , getIntervalFile
+ , iLength
+ , fuseIntervals
+ , setIntervalFile
-- * Ranges
, Range
- , Range'
+ , Range'(..)
, rangeInvariant
, consecutiveAndSeparated
, intervalsToRange
+ , intervalToRange
, rangeIntervals
, rangeFile
, rightMargin
@@ -52,6 +53,7 @@ module Agda.Syntax.Position
, rStart, rStart'
, rEnd, rEnd'
, rangeToInterval
+ , rangeToIntervalWithFile
, continuous
, continuousPerLine
, PrintRange(..)
@@ -68,15 +70,14 @@ module Agda.Syntax.Position
, fuseRanges
, beginningOf
, beginningOfFile
-
- -- * Tests
- , tests
+ , interleaveRanges
) where
import Prelude hiding (null)
import Control.Applicative hiding (empty)
import Control.Monad
+import Control.Monad.Writer (runWriter, Writer, tell)
import Data.Foldable (Foldable)
import qualified Data.Foldable as Fold
@@ -95,14 +96,11 @@ import Data.Void
import GHC.Generics (Generic)
-import Test.QuickCheck.All
-
-import Agda.Utils.FileName hiding (tests)
-import Agda.Utils.List hiding (tests)
+import Agda.Utils.FileName
+import Agda.Utils.List
import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Null
import Agda.Utils.Pretty
-import Agda.Utils.QuickCheck
#include "undefined.h"
import Agda.Utils.Impossible
@@ -173,6 +171,11 @@ setIntervalFile :: a -> Interval' b -> Interval' a
setIntervalFile f (Interval p1 p2) =
Interval (p1 { srcFile = f }) (p2 { srcFile = f })
+-- | Gets the 'srcFile' component of the interval. Because of the invariant,
+-- they are both the same.
+getIntervalFile :: Interval' a -> a
+getIntervalFile = srcFile . iStart
+
-- | Converts a file name and two positions to an interval.
posToInterval ::
a -> PositionWithoutFile -> PositionWithoutFile -> Interval' a
@@ -615,7 +618,7 @@ instance (Pretty a, HasRange a) => Pretty (PrintRange a) where
pretty (PrintRange a) = pretty a <+> parens (text "at" <+> pretty (getRange a))
{--------------------------------------------------------------------------
- Functions on postitions and ranges
+ Functions on positions and ranges
--------------------------------------------------------------------------}
-- | The first position in a file: position 1, line 1, column 1.
@@ -825,216 +828,36 @@ beginningOfFile (Range f _) = posToRange' f p p
withRangeOf :: (SetRange t, HasRange u) => t -> u -> t
x `withRangeOf` y = setRange (getRange y) x
-------------------------------------------------------------------------
--- Test suite
-
--- | The positions corresponding to the interval. The positions do not
--- refer to characters, but to the positions between characters, with
--- zero pointing to the position before the first character.
-iPositions :: Interval' a -> Set Int32
-iPositions i = Set.fromList [posPos (iStart i) .. posPos (iEnd i)]
-
--- | The positions corresponding to the range, including the
--- end-points.
-rPositions :: Range' a -> Set Int32
-rPositions r = Set.unions (map iPositions $ rangeIntervals r)
-
--- | Constructs the least interval containing all the elements in the
--- set.
-makeInterval :: Set Int32 -> Set Int32
-makeInterval s
- | Set.null s = Set.empty
- | otherwise = Set.fromList [Set.findMin s .. Set.findMax s]
-
-prop_iLength :: Interval' Integer -> Bool
-prop_iLength i = iLength i >= 0
-
-prop_startPos' :: Bool
-prop_startPos' = positionInvariant (startPos' ())
-
-prop_startPos :: Maybe AbsolutePath -> Bool
-prop_startPos = positionInvariant . startPos
-
-prop_noRange :: Bool
-prop_noRange = rangeInvariant (noRange :: Range)
-
-prop_takeI_dropI :: Interval' Integer -> Property
-prop_takeI_dropI i =
- forAll (choose (0, toInteger $ iLength i)) $ \n ->
- let s = genericReplicate n ' '
- t = takeI s i
- d = dropI s i
- in
- intervalInvariant t &&
- intervalInvariant d &&
- fuseIntervals t d == i
-
-prop_posToRange' ::
- Integer -> PositionWithoutFile -> PositionWithoutFile -> Bool
-prop_posToRange' f p1 p2 =
- rangeInvariant (posToRange' f p1 p2)
-
-prop_posToRange :: Position' Integer -> Position' Integer -> Bool
-prop_posToRange p1 p2 =
- rangeInvariant (posToRange p1 (p2 { srcFile = srcFile p1 }))
-
-prop_intervalToRange :: Integer -> IntervalWithoutFile -> Bool
-prop_intervalToRange f i = rangeInvariant (intervalToRange f i)
-
-rangeToIntervalPropertyTemplate ::
- Ord a =>
- (Range' Integer -> Maybe (Interval' a)) ->
- Range' Integer -> Bool
-rangeToIntervalPropertyTemplate r2i r = case r2i r of
- Nothing -> r == noRange
- Just i ->
- r /= noRange
- &&
- intervalInvariant i
- &&
- iPositions i == makeInterval (rPositions r)
-
-prop_rangeToIntervalWithFile :: Range' Integer -> Bool
-prop_rangeToIntervalWithFile =
- rangeToIntervalPropertyTemplate rangeToIntervalWithFile
-
-prop_rangeToInterval :: Range' Integer -> Bool
-prop_rangeToInterval =
- rangeToIntervalPropertyTemplate rangeToInterval
-
-prop_continuous :: Range -> Bool
-prop_continuous r =
- rangeInvariant cr &&
- rPositions cr == makeInterval (rPositions r)
- where cr = continuous r
-
-prop_continuousPerLine :: Range -> Bool
-prop_continuousPerLine r =
- rangeInvariant r'
- &&
- distinct lineNumbers
- &&
- rangeFile r' == rangeFile r
+-- | Interleaves two streams of ranged elements
+--
+-- It will report the conflicts as a list of conflicting pairs.
+-- In case of conflict, the element with the earliest start position
+-- is placed first. In case of a tie, the element with the earliest
+-- ending position is placed first. If both tie, the element from the
+-- first list is placed first.
+interleaveRanges :: (HasRange a) => [a] -> [a] -> ([a], [(a,a)])
+interleaveRanges as bs = runWriter$ go as bs
where
- r' = continuousPerLine r
-
- lineNumbers = concatMap lines (rangeIntervals r')
- where
- lines i | s == e = [s]
- | otherwise = [s, e]
- where
- s = posLine (iStart i)
- e = posLine (iEnd i)
-
-prop_fuseIntervals :: Interval' Integer -> Property
-prop_fuseIntervals i1 =
- forAll (intervalInSameFileAs i1) $ \i2 ->
- let i = fuseIntervals i1 i2 in
- intervalInvariant i &&
- iPositions i ==
- makeInterval (Set.union (iPositions i1) (iPositions i2))
-
-prop_fuseRanges :: Range -> Property
-prop_fuseRanges r1 =
- forAll (rangeInSameFileAs r1) $ \r2 ->
- let r = fuseRanges r1 r2 in
- rangeInvariant r
- &&
- rPositions r == Set.union (rPositions r1) (rPositions r2)
-
-prop_beginningOf :: Range -> Bool
-prop_beginningOf r = rangeInvariant (beginningOf r)
-
-prop_beginningOfFile :: Range -> Bool
-prop_beginningOfFile r = rangeInvariant (beginningOfFile r)
-
-instance Arbitrary a => Arbitrary (Position' a) where
- arbitrary = do
- srcFile <- arbitrary
- Positive pos' <- arbitrary
- let pos = fromInteger pos'
- line = pred pos `div` 10 + 1
- col = pred pos `mod` 10 + 1
- return (Pn {srcFile = srcFile, posPos = pos,
- posLine = line, posCol = col })
-
--- | Generates an interval located in the same file as the given
--- interval.
-
-intervalInSameFileAs ::
- (Arbitrary a, Ord a) => Interval' a -> Gen (Interval' a)
-intervalInSameFileAs i =
- setIntervalFile (srcFile $ iStart i) <$>
- (arbitrary :: Gen IntervalWithoutFile)
-
-prop_intervalInSameFileAs :: Interval' Integer -> Property
-prop_intervalInSameFileAs i =
- forAll (intervalInSameFileAs i) $ \i' ->
- intervalInvariant i' &&
- srcFile (iStart i) == srcFile (iStart i')
-
--- | Generates a range located in the same file as the given
--- range (if possible).
-
-rangeInSameFileAs :: (Arbitrary a, Ord a) => Range' a -> Gen (Range' a)
-rangeInSameFileAs NoRange = arbitrary
-rangeInSameFileAs (Range f is) = do
- Range _f is <- arbitrary `suchThat` (not . null)
- return $ Range (f `asTypeOf` _f) is
-
-prop_rangeInSameFileAs :: Range' Integer -> Property
-prop_rangeInSameFileAs r =
- forAll (rangeInSameFileAs r) $ \r' ->
- rangeInvariant r'
- &&
- case (r, r') of
- (NoRange, _) -> True
- (Range f _, Range f' _) -> f == f'
- (Range _ _, NoRange) -> False
-
-instance (Arbitrary a, Ord a) => Arbitrary (Interval' a) where
- arbitrary = do
- (p1, p2 :: Position' a) <- liftM2 (,) arbitrary arbitrary
- let [p1', p2'] = sort [p1, p2 { srcFile = srcFile p1 }]
- return (Interval p1' p2')
-
-instance (Ord a, Arbitrary a) => Arbitrary (Range' a) where
- arbitrary = do
- f <- arbitrary
- intervalsToRange f . fuse . sort <$> arbitrary
- where
- fuse (i1 : i2 : is)
- | iEnd i1 >= iStart i2 = fuse (fuseIntervals i1 i2 : is)
- | otherwise = i1 : fuse (i2 : is)
- fuse is = is
-
-instance CoArbitrary a => CoArbitrary (Position' a)
-instance CoArbitrary a => CoArbitrary (Interval' a)
-instance CoArbitrary a => CoArbitrary (Range' a)
-
-prop_positionInvariant :: Position' Integer -> Bool
-prop_positionInvariant = positionInvariant
-
-prop_intervalInvariant :: Interval' Integer -> Bool
-prop_intervalInvariant = intervalInvariant
-
-prop_rangeInvariant :: Range -> Bool
-prop_rangeInvariant = rangeInvariant
-
-instance Show (Position' Integer) where show = show . fmap Strict.Just
-instance Show (Interval' Integer) where show = show . fmap Strict.Just
-instance Show (Range' Integer) where show = show . fmap Strict.Just
-
-------------------------------------------------------------------------
--- * All tests
-------------------------------------------------------------------------
-
--- Template Haskell hack to make the following $quickCheckAll work
--- under ghc-7.8.
-return [] -- KEEP!
+ go [] as = return as
+ go as [] = return as
+ go as@(a:as') bs@(b:bs') =
+ let ra = getRange a
+ rb = getRange b
+
+ ra0 = rStart ra
+ rb0 = rStart rb
+
+ ra1 = rEnd ra
+ rb1 = rEnd rb
+ in
+ if ra1 <= rb0 then
+ (a:) <$> go as' bs
+ else if rb1 <= ra0 then
+ (b:) <$> go as bs'
+ else do
+ tell [(a,b)]
+ if ra0 < rb0 || (ra0 == rb0 && ra1 <= rb1) then
+ (a:) <$> go as' bs
+ else
+ (b:) <$> go as bs'
--- | Test suite.
-tests :: IO Bool
-tests = do
- putStrLn "Agda.Syntax.Position"
- $quickCheckAll
diff --git a/src/full/Agda/Syntax/Scope/Base.hs b/src/full/Agda/Syntax/Scope/Base.hs
index f84b55a..685db0e 100644
--- a/src/full/Agda/Syntax/Scope/Base.hs
+++ b/src/full/Agda/Syntax/Scope/Base.hs
@@ -1,10 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-| This module defines the notion of a scope and operations on scopes.
-}
@@ -73,12 +70,12 @@ data NameSpaceId
type ScopeNameSpaces = [(NameSpaceId, NameSpace)]
localNameSpace :: Access -> NameSpaceId
-localNameSpace PublicAccess = PublicNS
-localNameSpace PrivateAccess = PrivateNS
-localNameSpace OnlyQualified = OnlyQualifiedNS
+localNameSpace PublicAccess = PublicNS
+localNameSpace PrivateAccess{} = PrivateNS
+localNameSpace OnlyQualified = OnlyQualifiedNS
nameSpaceAccess :: NameSpaceId -> Access
-nameSpaceAccess PrivateNS = PrivateAccess
+nameSpaceAccess PrivateNS = PrivateAccess Inserted
nameSpaceAccess _ = PublicAccess
-- | Get a 'NameSpace' from 'Scope'.
@@ -662,7 +659,7 @@ flattenScope ms scope =
[ qual c (build ms' exportedNamesInScope $ moduleScope a)
| (c, a) <- Map.toList $ scopeImports root
, let -- get the suffixes of c in ms
- ms' = mapMaybe (maybePrefixMatch $ C.qnameParts c) ms
+ ms' = mapMaybe (List.stripPrefix $ C.qnameParts c) ms
, not $ null ms' ]
qual c = Map.mapKeys (q c)
where
@@ -791,7 +788,13 @@ scopeLookup' q scope = nubBy ((==) `on` fst) $ findName q root ++ maybeToList to
-- * Inverse look-up
-data AllowAmbiguousNames = AmbiguousAnything | AmbiguousConstructors | AmbiguousNothing
+data AllowAmbiguousNames
+ = AmbiguousAnything
+ -- ^ Used for instance arguments to check whether a name is in scope,
+ -- but we do not care whether is is ambiguous
+ | AmbiguousConProjs
+ -- ^ Ambiguous constructors or projections.
+ | AmbiguousNothing
deriving (Eq)
isNameInScope :: A.QName -> ScopeInfo -> Bool
@@ -803,7 +806,7 @@ isNameInScope q scope =
-- Sort by length, shortest first.
inverseScopeLookup :: Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]
-inverseScopeLookup = inverseScopeLookup' AmbiguousConstructors
+inverseScopeLookup = inverseScopeLookup' AmbiguousConProjs
inverseScopeLookup' :: AllowAmbiguousNames -> Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]
inverseScopeLookup' amb name scope = billToPure [ Scoping , InverseScopeLookup ] $
@@ -829,7 +832,11 @@ inverseScopeLookup' amb name scope = billToPure [ Scoping , InverseScopeLookup ]
unique (_:_:_) = False
unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule])
- unambiguousName q = amb == AmbiguousAnything || unique xs || amb == AmbiguousConstructors && all ((ConName ==) . anameKind) xs
+ unambiguousName q = amb == AmbiguousAnything
+ || unique xs
+ || amb == AmbiguousConProjs
+ && (all ((ConName ==) . anameKind) xs
+ || all ((FldName ==) . anameKind) xs)
where xs = scopeLookup q scope
recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo
diff --git a/src/full/Agda/Syntax/Scope/Monad.hs b/src/full/Agda/Syntax/Scope/Monad.hs
index 04dc98e..a3d00ab 100644
--- a/src/full/Agda/Syntax/Scope/Monad.hs
+++ b/src/full/Agda/Syntax/Scope/Monad.hs
@@ -1,11 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
{-| The scope monad with operations.
-}
@@ -13,7 +7,7 @@
module Agda.Syntax.Scope.Monad where
import Prelude hiding (mapM)
-import Control.Arrow (first, second)
+import Control.Arrow (first, second, (***))
import Control.Applicative
import Control.Monad hiding (mapM, forM)
import Control.Monad.Writer hiding (mapM, forM)
@@ -32,6 +26,7 @@ import Agda.Syntax.Position
import Agda.Syntax.Fixity
import Agda.Syntax.Abstract.Name as A
import qualified Agda.Syntax.Abstract as A
+import Agda.Syntax.Abstract (ScopeCopyInfo(..), initCopyInfo)
import Agda.Syntax.Concrete as C
import Agda.Syntax.Scope.Base
@@ -205,12 +200,14 @@ freshAbstractQName fx x = do
-- * Resolving names
-data ResolvedName = VarName A.Name
- | DefinedName Access AbstractName
- | FieldName AbstractName -- ^ record fields names need to be distinguished to parse copatterns
- | ConstructorName [AbstractName]
- | PatternSynResName AbstractName
- | UnknownName
+data ResolvedName
+ = VarName A.Name
+ | DefinedName Access AbstractName
+ | FieldName [AbstractName]
+ -- ^ record fields names need to be distinguished to parse copatterns
+ | ConstructorName [AbstractName]
+ | PatternSynResName AbstractName
+ | UnknownName
deriving (Show, Eq)
-- | Look up the abstract name referred to by a given concrete name.
@@ -254,8 +251,8 @@ resolveName' kinds names x = do
ds | all ((==ConName) . anameKind . fst) ds ->
return $ ConstructorName $ map (upd . fst) ds
- [(d, a)] | anameKind d == FldName ->
- return $ FieldName $ upd d
+ ds | all ((==FldName) . anameKind . fst) ds ->
+ return $ FieldName $ map (upd . fst) ds
[(d, a)] | anameKind d == PatternSynName ->
return $ PatternSynResName $ upd d
@@ -290,14 +287,16 @@ getNotation x ns = do
case r of
VarName y -> return $ namesToNotation x y
DefinedName _ d -> return $ notation d
- FieldName d -> return $ notation d
- ConstructorName ds -> case mergeNotations $ map notation ds of
- [n] -> return n
- _ -> __IMPOSSIBLE__
+ FieldName ds -> return $ oneNotation ds
+ ConstructorName ds -> return $ oneNotation ds
PatternSynResName n -> return $ notation n
UnknownName -> __IMPOSSIBLE__
where
notation = namesToNotation x . qnameName . anameName
+ oneNotation ds =
+ case mergeNotations $ map notation ds of
+ [n] -> n
+ _ -> __IMPOSSIBLE__
-- * Binding names
@@ -310,16 +309,26 @@ bindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()
bindName acc kind x y = do
r <- resolveName (C.QName x)
ys <- case r of
- FieldName d -> typeError $ ClashingDefinition (C.QName x) $ anameName d
- DefinedName _ d -> typeError $ ClashingDefinition (C.QName x) $ anameName d
- VarName z -> typeError $ ClashingDefinition (C.QName x) $ A.qualify (mnameFromList []) z
- ConstructorName [] -> __IMPOSSIBLE__
- ConstructorName ds
- | kind == ConName && all ((==ConName) . anameKind) ds -> return [ AbsName y kind Defined ]
- | otherwise -> typeError $ ClashingDefinition (C.QName x) $ anameName (headWithDefault __IMPOSSIBLE__ ds)
- PatternSynResName n -> typeError $ ClashingDefinition (C.QName x) $ anameName n
- UnknownName -> return [AbsName y kind Defined]
- modifyCurrentScope $ addNamesToScope (localNameSpace acc) x ys
+ -- Binding an anonymous declaration always succeeds.
+ -- In case it's not the first one, we simply remove the one that came before
+ UnknownName | isNoName x -> success
+ DefinedName{} | isNoName x -> success <* modifyCurrentScope (removeNameFromScope PrivateNS x)
+ DefinedName _ d -> clash $ anameName d
+ VarName z -> clash $ A.qualify (mnameFromList []) z
+ FieldName ds -> ambiguous FldName ds
+ ConstructorName ds -> ambiguous ConName ds
+ PatternSynResName n -> clash $ anameName n
+ UnknownName -> success
+ let ns = if isNoName x then PrivateNS else localNameSpace acc
+ modifyCurrentScope $ addNamesToScope ns x ys
+ where
+ success = return [ AbsName y kind Defined ]
+ clash = typeError . ClashingDefinition (C.QName x)
+
+ ambiguous k ds@(d:_) =
+ if kind == k && all ((==k) . anameKind) ds
+ then success else clash $ anameName d
+ ambiguous k [] = __IMPOSSIBLE__
-- | Rebind a name. Use with care!
-- Ulf, 2014-06-29: Currently used to rebind the name defined by an
@@ -348,16 +357,28 @@ stripNoNames = modifyScopes $ Map.map $ mapScope_ stripN stripN id
where
stripN = Map.filterWithKey $ const . not . isNoName
-type Out = (A.Ren A.ModuleName, A.Ren A.QName)
-type WSM = StateT Out ScopeM
+type WSM = StateT ScopeMemo ScopeM
+
+data ScopeMemo = ScopeMemo
+ { memoNames :: A.Ren A.QName
+ , memoModules :: [(ModuleName, (ModuleName, Bool))]
+ -- ^ Bool: did we copy recursively? We need to track this because we don't
+ -- copy recursively when creating new modules for reexported functions
+ -- (issue1985), but we might need to copy recursively later.
+ }
+
+memoToScopeInfo :: ScopeMemo -> ScopeCopyInfo
+memoToScopeInfo (ScopeMemo names mods) =
+ ScopeCopyInfo { renNames = names
+ , renModules = [ (x, y) | (x, (y, _)) <- mods ] }
-- | Create a new scope with the given name from an old scope. Renames
-- public names in the old scope to match the new name and returns the
-- renamings.
-copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, (A.Ren A.ModuleName, A.Ren A.QName))
-copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy new s) ([], [])
+copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)
+copyScope oldc new0 s = (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$> runStateT (copy new0 s) (ScopeMemo [] [])
where
- copy :: A.ModuleName -> Scope -> StateT (A.Ren A.ModuleName, A.Ren A.QName) ScopeM Scope
+ copy :: A.ModuleName -> Scope -> WSM Scope
copy new s = do
lift $ reportSLn "scope.copy" 20 $ "Copying scope " ++ show old ++ " to " ++ show new
lift $ reportSLn "scope.copy" 50 $ show s
@@ -388,12 +409,12 @@ copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy
_ -> lensAnameName f d
-- Adding to memo structure.
- addName x y = modify $ second $ ((x, y):)
- addMod x y = modify $ first $ ((x, y):)
+ addName x y = modify $ \ i -> i { memoNames = (x, y) : memoNames i }
+ addMod x y rec = modify $ \ i -> i { memoModules = (x, (y, rec)) : filter ((/= x) . fst) (memoModules i) }
-- Querying the memo structure.
- findName x = lookup x <$> gets snd
- findMod x = lookup x <$> gets fst
+ findName x = lookup x <$> gets memoNames
+ findMod x = lookup x <$> gets memoModules
refresh :: A.Name -> WSM A.Name
refresh x = do
@@ -403,49 +424,84 @@ copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy
-- Change a binding M.x -> old.M'.y to M.x -> new.M'.y
renName :: A.QName -> WSM A.QName
renName x = do
+ -- Issue 1985: For re-exported names we can't use new' as the
+ -- module, since it has the wrong telescope. Example:
+ --
+ -- module M1 (A : Set) where
+ -- module M2 (B : Set) where
+ -- postulate X : Set
+ -- module M3 (C : Set) where
+ -- module M4 (D E : Set) where
+ -- open M2 public
+ --
+ -- module M = M1.M3 A C
+ --
+ -- Here we can't copy M1.M2.X to M.M4.X since we need
+ -- X : (B : Set) → Set, but M.M4 has telescope (D E : Set). Thus, we
+ -- would break the invariant that all functions in a module share the
+ -- module telescope. Instead we copy M1.M2.X to M.M2.X for a fresh
+ -- module M2 that gets the right telescope.
+ m <- case x `isInModule` old of
+ True -> return new'
+ False -> renMod' False (qnameModule x)
+ -- Don't copy recursively here, we only know that the
+ -- current name x should be copied.
-- Generate a fresh name for the target.
- y <- A.qualify new' <$> refresh (qnameName x)
- lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x ++ " to " ++ show y
-- Andreas, 2015-08-11 Issue 1619:
-- Names copied by a module macro should get the module macro's
-- range as declaration range
-- (maybe rather the one of the open statement).
-- For now, we just set their range
-- to the new module name's one, which fixes issue 1619.
- y <- return $ setRange rnew y
+ y <- setRange rnew . A.qualify m <$> refresh (qnameName x)
+ lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x ++ " to " ++ show y
addName x y
return y
-- Change a binding M.x -> old.M'.y to M.x -> new.M'.y
renMod :: A.ModuleName -> WSM A.ModuleName
- renMod x = do
+ renMod = renMod' True
+
+ renMod' rec x = do
-- Andreas, issue 1607:
-- If we have already copied this module, return the copy.
- ifJustM (findMod x) return $ {- else -} do
-
- y <- do
- -- Andreas, Jesper, 2015-07-02: Issue 1597
- -- Don't blindly drop a prefix of length of the old qualifier.
- -- If things are imported by open public they do not have the old qualifier
- -- as prefix. Those need just to be linked, not copied.
- -- return $ A.mnameFromList $ (newL ++) $ drop (size old) $ A.mnameToList x
- -- caseMaybe (maybePrefixMatch (A.mnameToList old) (A.mnameToList x)) (return x) $ \ suffix -> do
- -- return $ A.mnameFromList $ newL ++ suffix
- -- Ulf, 2016-02-22: #1726
- -- We still need to copy modules from 'open public'. Same as in renName.
- y <- refresh (last $ A.mnameToList x)
- return $ A.mnameFromList $ newL ++ [y]
- -- Andreas, Jesper, 2015-07-02: Issue 1597
- -- Don't copy a module over itself, it will just be emptied of its contents.
- if (x == y) then return x else do
- lift $ reportSLn "scope.copy" 50 $ " Copying module " ++ show x ++ " to " ++ show y
- addMod x y
- -- We need to copy the contents of included modules recursively
- lift $ createModule False y
- s0 <- lift $ getNamedScope x
- s <- withCurrentModule' y $ copy y s0
- lift $ modifyNamedScope y (const s)
- return y
+ z <- findMod x
+ case z of
+ Just (y, False) | rec -> y <$ copyRec x y
+ Just (y, _) -> return y
+ Nothing -> do
+ -- Ulf (issue 1985): If copying a reexported module we put it at the
+ -- top-level, to make sure we don't mess up the invariant that all
+ -- (abstract) names M.f share the argument telescope of M.
+ let newM | x `isSubModuleOf` old = newL
+ | otherwise = mnameToList new0
+
+ y <- do
+ -- Andreas, Jesper, 2015-07-02: Issue 1597
+ -- Don't blindly drop a prefix of length of the old qualifier.
+ -- If things are imported by open public they do not have the old qualifier
+ -- as prefix. Those need just to be linked, not copied.
+ -- return $ A.mnameFromList $ (newL ++) $ drop (size old) $ A.mnameToList x
+ -- caseMaybe (stripPrefix (A.mnameToList old) (A.mnameToList x)) (return x) $ \ suffix -> do
+ -- return $ A.mnameFromList $ newL ++ suffix
+ -- Ulf, 2016-02-22: #1726
+ -- We still need to copy modules from 'open public'. Same as in renName.
+ y <- refresh (last $ A.mnameToList x)
+ return $ A.mnameFromList $ newM ++ [y]
+ -- Andreas, Jesper, 2015-07-02: Issue 1597
+ -- Don't copy a module over itself, it will just be emptied of its contents.
+ if (x == y) then return x else do
+ lift $ reportSLn "scope.copy" 50 $ " Copying module " ++ show x ++ " to " ++ show y
+ addMod x y rec
+ lift $ createModule False y
+ -- We need to copy the contents of included modules recursively (only when 'rec')
+ when rec $ copyRec x y
+ return y
+ where
+ copyRec x y = do
+ s0 <- lift $ getNamedScope x
+ s <- withCurrentModule' y $ copy y s0
+ lift $ modifyNamedScope y (const s)
-- | Apply an import directive and check that all the names mentioned actually
-- exist.
@@ -648,10 +704,9 @@ openModule_ cm dir = do
realClash _ = True
-- No ambiguity if concrete identifier is only mapped to
- -- constructor names.
- defClash (_, (qs0, qs1)) =
- any ((/= ConName) . anameKind) (qs0 ++ qs1)
-
+ -- constructor names or only to projection names.
+ defClash (_, (qs0, qs1)) = not $ all (== ConName) ks || all (==FldName) ks
+ where ks = map anameKind $ qs0 ++ qs1
-- We report the first clashing exported identifier.
unlessNull (filter (\ x -> realClash x && defClash x) defClashes) $
\ ((x, (_, q:_)) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q)
diff --git a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
index 0b856ed..6c26509 100644
--- a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
+++ b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
@@ -1,16 +1,6 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-
-- {-# OPTIONS -fwarn-unused-binds #-}
{-| The translation of abstract syntax to concrete syntax has two purposes.
@@ -67,6 +57,7 @@ import Agda.Utils.Functor
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
+import Agda.Utils.Singleton
import Agda.Utils.Tuple
import Agda.Utils.Pretty (prettyShow)
@@ -155,11 +146,18 @@ lookupQName ambCon x = do
[] -> do
let y = qnameToConcrete x
if isUnderscore y
+ -- -- || any (isUnderscore . A.nameConcrete) (A.mnameToList $ A.qnameModule x)
then return y
else return $ C.Qual (C.Name noRange [Id empty]) y
-- this is what happens for names that are not in scope (private names)
lookupModule :: A.ModuleName -> AbsToCon C.QName
+lookupModule (A.MName []) = return $ C.QName $ C.Name noRange [Id "-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 x =
do scope <- asks currentScope
case inverseScopeLookupModule x scope of
@@ -233,18 +231,23 @@ withInfixDecls = foldr (.) id . map (uncurry withInfixDecl)
-- Dealing with private definitions ---------------------------------------
+-- | Add @abstract@, @private@, @instance@ modifiers.
withAbstractPrivate :: DefInfo -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]
withAbstractPrivate i m =
- case (defAccess i, defAbstract i) of
- (PublicAccess, ConcreteDef) -> m
- (p,a) ->
- do ds <- m
- return $ abst a $ priv p $ ds
+ priv (defAccess i)
+ . abst (defAbstract i)
+ . addInstanceB (defInstance i == InstanceDef)
+ <$> m
where
- priv PrivateAccess ds = [ C.Private (getRange ds) ds ]
- priv _ ds = ds
- abst AbstractDef ds = [ C.Abstract (getRange ds) ds ]
- abst _ ds = ds
+ priv (PrivateAccess UserWritten)
+ ds = [ C.Private (getRange ds) UserWritten ds ]
+ priv _ ds = ds
+ abst AbstractDef ds = [ C.Abstract (getRange ds) ds ]
+ abst ConcreteDef ds = ds
+
+addInstanceB :: Bool -> [C.Declaration] -> [C.Declaration]
+addInstanceB True ds = [ C.InstanceB (getRange ds) ds ]
+addInstanceB False ds = ds
-- The To Concrete Class --------------------------------------------------
@@ -347,7 +350,7 @@ instance ToConcrete A.Name C.Name where
bindToConcrete x = bindName x
instance ToConcrete A.QName C.QName where
- toConcrete = lookupQName AmbiguousConstructors
+ toConcrete = lookupQName AmbiguousConProjs
instance ToConcrete A.ModuleName C.QName where
toConcrete = lookupModule
@@ -357,7 +360,10 @@ instance ToConcrete A.ModuleName C.QName where
instance ToConcrete A.Expr C.Expr where
toConcrete (Var x) = Ident . C.QName <$> toConcrete x
toConcrete (Def x) = Ident <$> toConcrete x
- toConcrete (Proj x) = Ident <$> toConcrete x
+ toConcrete (Proj ProjPrefix (AmbQ (x:_))) = Ident <$> toConcrete x
+ toConcrete (Proj _ (AmbQ (x:_))) =
+ C.Dot (getRange x) . Ident <$> toConcrete x
+ toConcrete Proj{} = __IMPOSSIBLE__
toConcrete (A.Macro x) = Ident <$> toConcrete x
toConcrete (Con (AmbQ (x:_))) = Ident <$> toConcrete x
toConcrete (Con (AmbQ [])) = __IMPOSSIBLE__
@@ -380,6 +386,9 @@ instance ToConcrete A.Expr C.Expr where
C.Underscore (getRange i) $
prettyShow . NamedMeta (metaNameSuggestion i) . MetaId . metaId <$> metaNumber i
+ toConcrete (A.Dot i e) =
+ C.Dot (getRange i) <$> toConcrete e
+
toConcrete e@(A.App i e1 e2) =
tryToRecoverOpApp e
-- or fallback to App
@@ -462,7 +471,7 @@ instance ToConcrete A.Expr C.Expr where
Irrelevant -> addDot a e
NonStrict -> addDot a (addDot a e)
_ -> e
- addDot a e = Dot (getRange a) e
+ addDot a e = C.Dot (getRange a) e
mkArg (Arg info e) = case getHiding info of
Hidden -> HiddenArg (getRange e) (unnamed e)
Instance -> InstanceArg (getRange e) (unnamed e)
@@ -567,8 +576,9 @@ instance ToConcrete A.TypedBinding C.TypedBinding where
instance ToConcrete LetBinding [C.Declaration] where
bindToConcrete (LetBind i info x t e) ret =
bindToConcrete x $ \x ->
- do (t,(e, [], [], [])) <- toConcrete (t, A.RHS e)
- ret [ C.TypeSig info x t
+ do (t,(e, [], [], [])) <- toConcrete (t, A.RHS e Nothing)
+ ret $ addInstanceB (getHiding info == Instance) $
+ [ C.TypeSig info x t
, C.FunClause (C.LHS (C.IdentP $ C.QName x) [] [] [])
e C.NoWhere False
]
@@ -577,7 +587,7 @@ instance ToConcrete LetBinding [C.Declaration] where
p <- toConcrete p
e <- toConcrete e
ret [ C.FunClause (C.LHS p [] [] []) (C.RHS e) NoWhere False ]
- bindToConcrete (LetApply i x modapp _ _ _) ret = do
+ bindToConcrete (LetApply i x modapp _ _) ret = do
x' <- unqualify <$> toConcrete x
modapp <- toConcrete modapp
let r = getRange modapp
@@ -602,7 +612,9 @@ instance ToConcrete AsWhereDecls WhereClause where
bindToConcrete (AsWhereDecls ds@[Section _ am _ _]) ret = do
ds' <- declsToConcrete ds
cm <- unqualify <$> lookupModule am
- let wh' = (if isNoName cm then AnyWhere else SomeWhere cm) $ ds'
+ -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere
+ -- Should not really matter for printing...
+ let wh' = (if isNoName cm then AnyWhere else SomeWhere cm PublicAccess) $ ds'
local (openModule' am defaultImportDir id) $ ret wh'
bindToConcrete (AsWhereDecls ds) ret =
ret . AnyWhere =<< declsToConcrete ds
@@ -633,7 +645,8 @@ declsToConcrete :: [A.Declaration] -> AbsToCon [C.Declaration]
declsToConcrete ds = mergeSigAndDef . concat <$> toConcrete ds
instance ToConcrete A.RHS (C.RHS, [C.Expr], [C.Expr], [C.Declaration]) where
- toConcrete (A.RHS e) = do
+ toConcrete (A.RHS e (Just c)) = return (C.RHS c, [], [], [])
+ toConcrete (A.RHS e Nothing) = do
e <- toConcrete e
return (C.RHS e, [], [], [])
toConcrete A.AbsurdRHS = return (C.AbsurdRHS, [], [], [])
@@ -658,14 +671,15 @@ instance ToConcrete (Maybe A.QName) (Maybe C.Name) where
instance ToConcrete (Constr A.Constructor) C.Declaration where
toConcrete (Constr (A.ScopedDecl scope [d])) =
withScope scope $ toConcrete (Constr d)
- toConcrete (Constr (A.Axiom _ i info x t)) = do
+ toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do
x' <- unsafeQNameToName <$> toConcrete x
t' <- toConcreteTop t
return $ C.TypeSig info x' t'
+ toConcrete (Constr (A.Axiom _ _ _ (Just _) _ _)) = __IMPOSSIBLE__
toConcrete (Constr d) = head <$> toConcrete d
instance ToConcrete a C.LHS => ToConcrete (A.Clause' a) [C.Declaration] where
- toConcrete (A.Clause lhs rhs wh catchall) =
+ toConcrete (A.Clause lhs _ rhs wh catchall) =
bindToConcrete lhs $ \lhs ->
case lhs of
C.LHS p wps _ _ -> do
@@ -693,12 +707,16 @@ instance ToConcrete A.Declaration [C.Declaration] where
toConcrete (ScopedDecl scope ds) =
withScope scope (declsToConcrete ds)
- toConcrete (Axiom _ i info x t) = do
+ toConcrete (Axiom _ i info mp x t) = do
x' <- unsafeQNameToName <$> toConcrete x
withAbstractPrivate i $
withInfixDecl i x' $ do
t' <- toConcreteTop t
- return [C.Postulate (getRange i) [C.TypeSig info x' t']]
+ return $
+ (case mp of
+ Nothing -> []
+ Just occs -> [C.Pragma (PolarityPragma noRange x' occs)]) ++
+ [C.Postulate (getRange i) [C.TypeSig info x' t']]
toConcrete (A.Field i x t) = do
x' <- unsafeQNameToName <$> toConcrete x
@@ -752,7 +770,7 @@ instance ToConcrete A.Declaration [C.Declaration] where
ds <- declsToConcrete ds
return [ C.Module (getRange i) x (concat tel) ds ]
- toConcrete (A.Apply i x modapp _ _ _) = do
+ toConcrete (A.Apply i x modapp _ _) = do
x <- unsafeQNameToName <$> toConcrete x
modapp <- toConcrete modapp
let r = getRange modapp
@@ -799,7 +817,7 @@ instance ToConcrete RangeAndPragma C.Pragma where
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.RewritePragma x -> C.RewritePragma r . singleton <$> toConcrete x
A.CompiledTypePragma x hs -> do
x <- toConcrete x
return $ C.CompiledTypePragma r x hs
@@ -827,11 +845,10 @@ instance ToConcrete RangeAndPragma C.Pragma where
A.CompiledDataUHCPragma x crd crcs -> do
x <- toConcrete x
return $ C.CompiledDataUHCPragma r x crd crcs
- A.NoSmashingPragma x -> C.NoSmashingPragma r <$> toConcrete x
A.StaticPragma x -> C.StaticPragma r <$> toConcrete x
A.InlinePragma x -> C.InlinePragma r <$> toConcrete x
A.DisplayPragma f ps rhs ->
- C.DisplayPragma r <$> toConcrete (A.DefP (PatRange noRange) f ps) <*> toConcrete rhs
+ C.DisplayPragma r <$> toConcrete (A.DefP (PatRange noRange) (AmbQ [f]) ps) <*> toConcrete rhs
-- Left hand sides --------------------------------------------------------
@@ -845,14 +862,41 @@ instance ToConcrete A.LHS C.LHS where
ret $ C.LHS lhs wps [] []
instance ToConcrete A.LHSCore C.Pattern where
- bindToConcrete = bindToConcrete . lhsCoreToPattern
+ bindToConcrete = bindToConcrete . lhsCoreToPattern
appBrackets' :: [arg] -> Precedence -> Bool
appBrackets' [] _ = False
appBrackets' (_:_) ctx = appBrackets ctx
--- TODO: bind variables properly
+newtype BindingPattern = BindingPat A.Pattern
+newtype FreshName = FreshenName A.Name
+
+instance ToConcrete FreshName A.Name where
+ bindToConcrete (FreshenName x) ret = bindToConcrete x $ \ y -> ret x{ nameConcrete = y }
+
+-- Takes care of freshening and binding pattern variables, but doesn't actually
+-- translate anything to Concrete.
+instance ToConcrete BindingPattern A.Pattern where
+ bindToConcrete (BindingPat p) ret =
+ case p of
+ A.VarP x -> bindToConcrete (FreshenName x) $ ret . A.VarP
+ A.WildP{} -> ret p
+ A.ProjP{} -> ret p
+ A.AbsurdP{} -> ret p
+ A.LitP{} -> ret p
+ A.DotP{} -> ret p
+ A.ConP i c args -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.ConP i c
+ A.DefP i f args -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.DefP i f
+ A.PatternSynP i f args -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.PatternSynP i f
+ A.RecP i args -> bindToConcrete ((map . fmap) BindingPat args) $ ret . A.RecP i
+ A.AsP i x p -> bindToConcrete (FreshenName x) $ \ x ->
+ bindToConcrete (BindingPat p) $ \ p ->
+ ret (A.AsP i x p)
+
instance ToConcrete A.Pattern C.Pattern where
+ bindToConcrete p ret = do
+ prec <- currentPrecedence
+ bindToConcrete (BindingPat p) (ret <=< withPrecedence prec . toConcrete)
toConcrete p =
case p of
A.VarP x ->
@@ -862,8 +906,14 @@ instance ToConcrete A.Pattern C.Pattern where
return $ C.WildP (getRange i)
A.ConP i (AmbQ []) args -> __IMPOSSIBLE__
- p@(A.ConP i xs@(AmbQ (x:_)) args) -> tryOp x (A.ConP i xs) args
- p@(A.DefP i x args) -> tryOp x (A.DefP i x) args
+ A.ConP i xs@(AmbQ (x:_)) args -> tryOp x (A.ConP i xs) args
+
+ A.ProjP _ _ (AmbQ []) -> __IMPOSSIBLE__
+ A.ProjP i ProjPrefix xs@(AmbQ (x:_)) -> C.IdentP <$> toConcrete x
+ A.ProjP i _ xs@(AmbQ (x:_)) -> C.DotP (getRange x) UserWritten . C.Ident <$> toConcrete x
+
+ A.DefP i (AmbQ []) _ -> __IMPOSSIBLE__
+ A.DefP i xs@(AmbQ (x:_)) args -> tryOp x (A.DefP i xs) args
A.AsP i x p -> do
(x, p) <- toConcreteCtx ArgumentCtx (x,p)
@@ -878,20 +928,24 @@ instance ToConcrete A.Pattern C.Pattern where
A.LitP l ->
return $ C.LitP l
- A.DotP i e -> do
+ A.DotP i o e -> do
c <- toConcreteCtx DotPatternCtx e
case c of
-- Andreas, 2016-02-04 print ._ pattern as _ pattern,
-- following the fusing of WildP and ImplicitP.
C.Underscore{} -> return $ C.WildP $ getRange i
- _ -> return $ C.DotP (getRange i) c
+ _ -> return $ C.DotP (getRange i) o c
A.PatternSynP i n _ ->
+ -- Ulf, 2016-11-29: This doesn't seem right. The underscore is a list
+ -- of arguments, which we shouldn't really throw away! I guess this
+ -- case is __IMPOSSIBLE__?
C.IdentP <$> toConcrete n
A.RecP i as ->
C.RecP (getRange i) <$> mapM (traverse toConcrete) as
where
+ tryOp :: A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> AbsToCon C.Pattern
tryOp x f args = do
-- Andreas, 2016-02-04, Issue #1792
-- To prevent failing of tryToRecoverOpAppP for overapplied operators,
@@ -936,8 +990,10 @@ tryToRecoverOpAppP = recoverOpApp bracketP_ opApp view
view p = case p of
ConP _ (AmbQ (c:_)) ps -> Just (HdCon c, ps)
- DefP _ f ps -> Just (HdDef f, ps)
- _ -> Nothing
+ DefP _ (AmbQ (f:_)) ps -> Just (HdDef f, ps)
+ _ -> __IMPOSSIBLE__
+ -- ProjP _ _ (AmbQ (d:_)) -> Just (HdDef d, []) -- ? Andreas, 2016-04-21
+ -- _ -> Nothing
recoverOpApp :: (ToConcrete a c, HasRange c)
=> ((Precedence -> Bool) -> AbsToCon c -> AbsToCon c)
diff --git a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
index ecbb14b..c4b2802 100644
--- a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
@@ -1,11 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ <= 708
@@ -60,13 +54,9 @@ import Agda.Syntax.Notation
import Agda.Syntax.Scope.Base
import Agda.Syntax.Scope.Monad
import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete)
+import Agda.Syntax.IdiomBrackets
-import Agda.TypeChecking.Monad.Base
- ( TypeError(..) , Call(..) , typeError , genericError , TCErr(..)
- , fresh , freshName , freshName_ , freshNoName , extendedLambdaName
- , envAbstractMode , AbstractMode(..)
- , TCM
- )
+import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)
@@ -76,6 +66,7 @@ import Agda.TypeChecking.Monad.Options
import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern)
import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin)
+import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)
import Agda.TypeChecking.Pretty hiding (pretty, prettyA)
import Agda.Interaction.FindFile (checkModuleName)
@@ -95,6 +86,7 @@ import Agda.Utils.Null
import qualified Agda.Utils.Pretty as P
import Agda.Utils.Pretty (render, Pretty, pretty, prettyShow)
import Agda.Utils.Tuple
+import Agda.Interaction.FindFile ( rootNameModule )
#include "undefined.h"
import Agda.Utils.Impossible
@@ -146,24 +138,41 @@ annotateExpr m = do
-- | Make sure that each variable occurs only once.
checkPatternLinearity :: [A.Pattern' e] -> ScopeM ()
-checkPatternLinearity ps = unlessNull (duplicates xs) $ \ ys -> do
- typeError $ RepeatedVariablesInPattern ys
- where
- xs = concatMap vars ps
- vars :: A.Pattern' e -> [C.Name]
- vars p = case p of
- A.VarP x -> [nameConcrete x]
- A.ConP _ _ args -> concatMap (vars . namedArg) args
+checkPatternLinearity ps = do
+ unlessNull (duplicates $ map nameConcrete $ patternVars ps) $ \ ys -> do
+ typeError $ RepeatedVariablesInPattern ys
+
+class PatternVars a where
+ patternVars :: a -> [A.Name]
+
+instance PatternVars a => PatternVars [a] where
+ patternVars = concatMap patternVars
+
+instance PatternVars a => PatternVars (Arg a) where
+ patternVars = patternVars . unArg
+
+instance PatternVars a => PatternVars (Named n a) where
+ patternVars = patternVars . namedThing
+
+instance PatternVars a => PatternVars (C.FieldAssignment' a) where
+ patternVars = patternVars . (^. exprFieldA)
+
+instance PatternVars (A.Pattern' e) where
+ patternVars p = case p of
+ A.VarP x -> [x]
+ A.ConP _ _ args -> patternVars args
+ A.ProjP _ _ _ -> []
A.WildP _ -> []
- A.AsP _ x p -> nameConcrete x : vars p
- A.DotP _ _ -> []
+ A.AsP _ x p -> x : patternVars p
+ A.DotP _ _ _ -> []
A.AbsurdP _ -> []
A.LitP _ -> []
- A.DefP _ _ args -> concatMap (vars . namedArg) args
+ A.DefP _ _ args -> patternVars args
-- Projection pattern, @args@ should be empty unless we have
-- indexed records.
- A.PatternSynP _ _ args -> concatMap (vars . namedArg) args
- A.RecP _ fs -> concatMap (vars . (^. exprFieldA)) fs
+ A.PatternSynP _ _ args -> patternVars args
+ A.RecP _ fs -> patternVars fs
+
-- | Make sure that there are no dot patterns (called on pattern synonyms).
noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)
@@ -173,6 +182,7 @@ noDotPattern err = dot
dot p = case p of
A.VarP x -> pure $ A.VarP x
A.ConP i c args -> A.ConP i c <$> (traverse $ traverse $ traverse dot) args
+ A.ProjP i o d -> pure $ A.ProjP i o d
A.WildP i -> pure $ A.WildP i
A.AsP i x p -> A.AsP i x <$> dot p
A.DotP{} -> typeError $ GenericError err
@@ -183,8 +193,8 @@ noDotPattern err = dot
A.RecP i fs -> A.RecP i <$> (traverse $ traverse dot) fs
-- | Compute the type of the record constructor (with bogus target type)
-recordConstructorType :: [NiceDeclaration] -> C.Expr
-recordConstructorType fields = build fs
+recordConstructorType :: [NiceDeclaration] -> ScopeM C.Expr
+recordConstructorType fields = build <$> mapM validForLet fs
where
-- drop all declarations after the last field declaration
fs = reverse $ dropWhile notField $ reverse fields
@@ -192,33 +202,77 @@ recordConstructorType fields = build fs
notField NiceField{} = False
notField _ = True
- -- Andreas, 2013-11-08
- -- Turn @open public@ into just @open@, since we cannot have an
- -- @open public@ in a @let@. Fixes issue 532.
- build (NiceOpen r m dir@ImportDirective{ publicOpen = True } : fs) =
- build (NiceOpen r m dir{ publicOpen = False } : fs)
-
- build (NiceModuleMacro r p x modapp open dir@ImportDirective{ publicOpen = True } : fs) =
- build (NiceModuleMacro r p x modapp open dir{ publicOpen = False } : fs)
-
- build (NiceField r _ f _ _ x (Arg info e) : fs) =
+ -- | Check that declarations before last field can be handled
+ -- by current translation into let.
+ --
+ -- Sometimes a declaration is valid with minor modifications.
+ validForLet :: NiceDeclaration -> ScopeM NiceDeclaration
+ validForLet d = do
+ let failure = traceCall (SetRange $ getRange d) $
+ typeError $ NotValidBeforeField d
+ case d of
+
+ -- Andreas, 2013-11-08
+ -- Turn @open public@ into just @open@, since we cannot have an
+ -- @open public@ in a @let@. Fixes issue #532.
+ C.NiceOpen r m dir ->
+ return $ C.NiceOpen r m dir{ publicOpen = False }
+
+ C.NiceModuleMacro r p x modapp open dir ->
+ return $ C.NiceModuleMacro r p x modapp open dir{ publicOpen = False }
+
+ C.NiceField{} ->
+ return d
+
+ C.NiceMutual _ _ _
+ [ C.FunSig _ _ _ _ _instanc macro _info _ _ _
+ , C.FunDef _ _ _ abstract _ _
+ [ C.Clause _top _catchall (C.LHS _p [] [] []) (C.RHS _rhs) NoWhere [] ]
+ ] | abstract /= AbstractDef && macro /= MacroDef ->
+ -- TODO: this is still too generous, we also need to check that _p
+ -- is only variable patterns.
+ return d
+
+ C.NiceMutual{} -> failure
+ -- TODO: some of these cases might be __IMPOSSIBLE__
+ C.Axiom{} -> failure
+ C.PrimitiveFunction{} -> failure
+ C.NiceModule{} -> failure
+ C.NiceImport{} -> failure
+ C.NicePragma{} -> failure
+ C.NiceRecSig{} -> failure
+ C.NiceDataSig{} -> failure
+ C.NiceFunClause{} -> failure
+ C.FunSig{} -> failure -- Note: these are bundled with FunDef in NiceMutual
+ C.FunDef{} -> failure
+ C.DataDef{} -> failure
+ C.RecDef{} -> failure
+ C.NicePatternSyn{} -> failure
+ C.NiceUnquoteDecl{} -> failure
+ C.NiceUnquoteDef{} -> failure
+
+ build fs =
+ let (ds1, ds2) = span notField fs
+ in lets (concatMap notSoNiceDeclarations ds1) $ fld ds2
+
+ -- Turn a field declaration into a the domain of a Pi-type
+ fld [] = C.SetN noRange 0 -- todo: nicer
+ fld (NiceField r f _ _ _ x (Arg info e) : fs) =
C.Pi [C.TypedBindings r $ Arg info (C.TBind r [pure $ mkBoundName x f] e)] $ build fs
where r = getRange x
- build (d : fs) = C.Let (getRange d) [notSoNiceDeclaration d] $
- build fs
- build [] = C.SetN noRange 0 -- todo: nicer
+ fld _ = __IMPOSSIBLE__
+ -- Turn non-field declarations into a let binding.
+ -- Smart constructor for C.Let:
+ lets [] c = c
+ lets ds c = C.Let (getRange ds) ds c
--- | @checkModuleApplication modapp m0 x dir = return (modapp', renD, renM)@
---
--- @m0@ is the new (abstract) module name and
--- @x@ its concrete form (used for error messages).
checkModuleApplication
:: C.ModuleApplication
-> ModuleName
-> C.Name
-> C.ImportDirective
- -> ScopeM (A.ModuleApplication, Ren A.QName, Ren ModuleName, A.ImportDirective)
+ -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)
checkModuleApplication (C.SectionApp _ tel e) m0 x dir' = do
reportSDoc "scope.decl" 70 $ vcat $
@@ -239,11 +293,11 @@ checkModuleApplication (C.SectionApp _ tel e) m0 x dir' = do
| otherwise = removeOnlyQualified
-- Copy the scope associated with m and take the parts actually imported.
(adir, s) <- applyImportDirectiveM (C.QName x) dir' =<< getNamedScope m1
- (s', (renM, renD)) <- copyScope m m0 (noRecConstr s)
+ (s', copyInfo) <- copyScope m m0 (noRecConstr s)
-- Set the current scope to @s'@
modifyCurrentScope $ const s'
printScope "mod.inst" 20 "copied source module"
- reportSLn "scope.mod.inst" 30 $ "renamings:\n " ++ show renD ++ "\n " ++ show renM
+ reportSLn "scope.mod.inst" 30 $ show (pretty copyInfo)
let amodapp = A.SectionApp tel' m1 args'
reportSDoc "scope.decl" 70 $ vcat $
[ text $ "scope checked ModuleApplication " ++ prettyShow x
@@ -251,18 +305,18 @@ checkModuleApplication (C.SectionApp _ tel e) m0 x dir' = do
reportSDoc "scope.decl" 70 $ vcat $
[ nest 2 $ prettyA amodapp
]
- return (amodapp, renD, renM, adir)
+ return (amodapp, copyInfo, adir)
checkModuleApplication (C.RecordModuleIFS _ recN) m0 x dir' =
withCurrentModule m0 $ do
m1 <- toAbstract $ OldModuleName recN
s <- getNamedScope m1
(adir, s) <- applyImportDirectiveM recN dir' s
- (s', (renM, renD)) <- copyScope recN m0 s
+ (s', copyInfo) <- copyScope recN m0 (removeOnlyQualified s)
modifyCurrentScope $ const s'
printScope "mod.inst" 20 "copied record module"
- return (A.RecordModuleIFS m1, renD, renM, adir)
+ return (A.RecordModuleIFS m1, copyInfo, adir)
-- | @checkModuleMacro mkApply range access concreteName modapp open dir@
--
@@ -273,8 +327,7 @@ checkModuleMacro
=> (ModuleInfo
-> ModuleName
-> A.ModuleApplication
- -> Ren A.QName
- -> Ren ModuleName
+ -> ScopeCopyInfo
-> A.ImportDirective
-> a)
-> Range
@@ -306,7 +359,7 @@ checkModuleMacro apply r p x modapp open dir = do
(DontOpen, _) -> (dir, defaultImportDir)
-- Restore the locals after module application has been checked.
- (modapp', renD, renM, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir
+ (modapp', copyInfo, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir
printScope "mod.inst.app" 20 "checkModuleMacro, after checkModuleApplication"
reportSDoc "scope.decl" 90 $ text "after mod app: trying to print m0 ..."
@@ -330,7 +383,7 @@ checkModuleMacro apply r p x modapp open dir = do
reportSDoc "scope.decl" 90 $ text "after stripNo: m0 =" <+> prettyA m0
let m = m0 `withRangesOf` [x]
- adecls = [ apply info m modapp' renD renM adir ]
+ adecls = [ apply info m modapp' copyInfo adir ]
reportSDoc "scope.decl" 70 $ vcat $
[ text $ "scope checked ModuleMacro " ++ prettyShow x
@@ -338,8 +391,7 @@ checkModuleMacro apply r p x modapp open dir = do
reportSLn "scope.decl" 90 $ "info = " ++ show info
reportSLn "scope.decl" 90 $ "m = " ++ show m
reportSLn "scope.decl" 90 $ "modapp' = " ++ show modapp'
- reportSLn "scope.decl" 90 $ "renD = " ++ show renD
- reportSLn "scope.decl" 90 $ "renM = " ++ show renM
+ reportSLn "scope.decl" 90 $ show $ pretty copyInfo
reportSDoc "scope.decl" 70 $ vcat $
map (nest 2 . prettyA) adecls
return adecls
@@ -494,7 +546,7 @@ instance ToAbstract OldQName A.Expr where
case qx of
VarName x' -> return $ A.Var x'
DefinedName _ d -> return $ nameExpr d
- FieldName d -> return $ nameExpr d
+ FieldName ds -> return $ A.Proj ProjPrefix $ AmbQ (map anameName ds)
ConstructorName ds -> return $ A.Con $ AmbQ (map anameName ds)
UnknownName -> notInScope x
PatternSynResName d -> return $ nameExpr d
@@ -546,7 +598,8 @@ instance (Show a, ToQName a) => ToAbstract (OldName a) A.QName where
-- We can get the cases below for DISPLAY pragmas
ConstructorName (d : _) -> return $ anameName d -- We'll throw out this one, so it doesn't matter which one we pick
ConstructorName [] -> __IMPOSSIBLE__
- FieldName d -> return $ anameName d
+ FieldName (d:_) -> return $ anameName d
+ FieldName [] -> __IMPOSSIBLE__
PatternSynResName d -> return $ anameName d
VarName x -> typeError $ GenericError $ "Not a defined name: " ++ show x
UnknownName -> notInScope (toQName x)
@@ -654,7 +707,7 @@ scopeCheckExtendedLam r cs = do
name <- freshAbstractName_ cname
reportSLn "scope.extendedLambda" 10 $ "new extended lambda name: " ++ show name
qname <- qualifyName_ name
- bindName PrivateAccess DefName cname qname
+ bindName (PrivateAccess Inserted) DefName cname qname
-- Compose a function definition an scope check it.
a <- aModeToDef <$> asks envAbstractMode
@@ -718,7 +771,7 @@ instance ToAbstract C.Expr A.Expr where
C.QuestionMark r n -> do
scope <- getScope
-- Andreas, 2014-04-06 create interaction point.
- ii <- registerInteractionPoint r n
+ ii <- registerInteractionPoint True r n
let info = MetaInfo
{ metaRange = r
, metaScope = scope
@@ -809,8 +862,14 @@ instance ToAbstract C.Expr A.Expr where
-- Parenthesis
C.Paren _ e -> toAbstractCtx TopCtx e
+ -- Idiom brackets
+ C.IdiomBrackets r e ->
+ toAbstractCtx TopCtx =<< parseIdiomBrackets r e
+
+ -- Post-fix projections
+ C.Dot r e -> A.Dot (ExprRange r) <$> toAbstract e
+
-- Pattern things
- C.Dot _ _ -> notAnExpression e
C.As _ _ _ -> notAnExpression e
C.Absurd _ -> notAnExpression e
@@ -846,7 +905,7 @@ instance ToAbstract C.ModuleAssignment (A.ModuleName, [A.LetBinding]) where
(C.SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))
DontOpen i
case r of
- (LetApply _ m' _ _ _ _ : _) -> return (m', r)
+ (LetApply _ m' _ _ _ : _) -> return (m', r)
_ -> __IMPOSSIBLE__
instance ToAbstract c a => ToAbstract (FieldAssignment' c) (FieldAssignment' a) where
@@ -902,23 +961,24 @@ scopeCheckNiceModule r p name tel checkDs
-- Check whether we are dealing with an anonymous module.
-- This corresponds to a Coq/LEGO section.
- (name, p, open) <- do
+ (name, p', open) <- do
if isNoName name then do
(i :: NameId) <- fresh
- return (C.NoName (getRange name) i, PrivateAccess, True)
+ return (C.NoName (getRange name) i, PrivateAccess Inserted, True)
else return (name, p, False)
-- Check and bind the module, using the supplied check for its contents.
aname <- toAbstract (NewModuleName name)
ds <- snd <$> do
scopeCheckModule r (C.QName name) aname tel checkDs
- bindModule p name aname
+ bindModule p' name aname
- -- If the module was anonymous open it public.
+ -- If the module was anonymous open it public
+ -- unless it's private, in which case we just open it (#2099)
when open $
void $ -- We can discard the returned default A.ImportDirective.
openModule_ (C.QName name) $
- defaultImportDir { publicOpen = True }
+ defaultImportDir { publicOpen = p == PublicAccess }
return ds
-- | Check whether a telescope has open declarations or module macros.
@@ -936,7 +996,7 @@ telHasOpenStmsOrModuleMacros = any yesBinds
-- (Andreas, 2015-11-17)
yes (C.Mutual _ ds) = any yes ds
yes (C.Abstract _ ds) = any yes ds
- yes (C.Private _ ds) = any yes ds
+ yes (C.Private _ _ ds) = any yes ds
yes _ = False
{- UNUSED
@@ -1014,6 +1074,9 @@ scopeCheckModule r x qm tel checkDs = do
data TopLevel a = TopLevel
{ topLevelPath :: AbsolutePath
-- ^ The file path from which we loaded this module.
+ , topLevelExpectedName :: C.TopLevelModuleName
+ -- ^ The expected module name
+ -- (coming from the import statement that triggered scope checking this file).
, topLevelTheThing :: a
-- ^ The file content.
}
@@ -1034,7 +1097,7 @@ topLevelModuleName topLevel = scopeCurrent (topLevelScope topLevel)
-- module ThisModule ... -- the top-level module of this file
-- @
instance ToAbstract (TopLevel [C.Declaration]) TopLevelInfo where
- toAbstract (TopLevel file ds) =
+ toAbstract (TopLevel file expectedMName ds) =
-- A file is a bunch of preliminary decls (imports etc.)
-- plus a single module decl.
case C.spanAllowedBeforeModule ds of
@@ -1048,13 +1111,21 @@ instance ToAbstract (TopLevel [C.Declaration]) TopLevelInfo where
(outsideDecls, [ C.Module r m0 tel insideDecls ]) -> do
-- If the module name is _ compute the name from the file path
m <- if isNoName m0
- then return $ C.QName $ C.Name noRange [Id $ stringToRawName $ rootName file]
+ then return $ C.QName $ C.Name noRange [Id $ stringToRawName $ rootNameModule file]
+ -- Andreas, 2016-07-12, ALTERNATIVE:
+ -- -- We assign an anonymous file module the name expected from
+ -- -- its import. For flat file structures, this is the same.
+ -- -- For hierarchical file structures, this reverses the behavior:
+ -- -- Loading the file by itself will fail, but it can be imported.
+ -- -- The previous behavior is: it can be loaded by itself, but not
+ -- -- be imported
+ -- then return $ C.fromTopLevelModuleName expectedMName
else do
-- Andreas, 2014-03-28 Issue 1078
-- We need to check the module name against the file name here.
-- Otherwise one could sneak in a lie and confuse the scope
-- checker.
- checkModuleName (C.toTopLevelModuleName m0) file
+ checkModuleName (C.toTopLevelModuleName m0) file $ Just expectedMName
return m0
setTopLevelModule m
am <- toAbstract (NewModuleQName m)
@@ -1083,10 +1154,11 @@ instance {-# OVERLAPPING #-} ToAbstract [C.Declaration] [A.Declaration] where
instance ToAbstract [C.Declaration] [A.Declaration] where
#endif
toAbstract ds = do
- -- Don't allow to switch off termination checker (Issue 586) or
- -- positivity checker (Issue 1614) in --safe mode.
+ -- When --safe is active the termination checker (Issue 586) and
+ -- positivity checker (Issue 1614) may not be switched off, and
+ -- polarities may not be assigned.
ds <- ifM (optSafe <$> commandLineOptions)
- (mapM (noNoTermCheck >=> noNoPositivityCheck) ds)
+ (mapM (noNoTermCheck >=> noNoPositivityCheck >=> noPolarity) ds)
(return ds)
toAbstract =<< niceDecls ds
where
@@ -1105,6 +1177,10 @@ instance ToAbstract [C.Declaration] [A.Declaration] where
typeError $ SafeFlagNoPositivityCheck
noNoPositivityCheck d = return d
+ noPolarity :: C.Declaration -> TCM C.Declaration
+ noPolarity (C.Pragma C.PolarityPragma{}) = typeError SafeFlagPolarity
+ noPolarity d = return d
+
newtype LetDefs = LetDefs [C.Declaration]
newtype LetDef = LetDef NiceDeclaration
@@ -1115,7 +1191,7 @@ instance ToAbstract LetDefs [A.LetBinding] where
instance ToAbstract LetDef [A.LetBinding] where
toAbstract (LetDef d) =
case d of
- NiceMutual _ _ _ d@[C.FunSig _ fx _ instanc macro info _ x t, C.FunDef _ _ _ abstract _ _ [cl]] ->
+ NiceMutual _ _ _ d@[C.FunSig _ fx _ _ instanc macro info _ x t, C.FunDef _ _ _ abstract _ _ [cl]] ->
do when (abstract == AbstractDef) $ do
genericError $ "abstract not allowed in let expressions"
when (macro == MacroDef) $ do
@@ -1153,7 +1229,7 @@ instance ToAbstract LetDef [A.LetBinding] where
case definedName p of
Nothing -> throwError err
Just x -> toAbstract $ LetDef $ NiceMutual r termCheck True
- [ C.FunSig r noFixity' PublicAccess NotInstanceDef NotMacroDef defaultArgInfo termCheck x (C.Underscore (getRange x) Nothing)
+ [ C.FunSig r noFixity' PublicAccess ConcreteDef NotInstanceDef NotMacroDef defaultArgInfo termCheck x (C.Underscore (getRange x) Nothing)
, C.FunDef r __IMPOSSIBLE__ __IMPOSSIBLE__ ConcreteDef __IMPOSSIBLE__ __IMPOSSIBLE__
[C.Clause x (ca || catchall) lhs (C.RHS rhs) NoWhere []]
]
@@ -1169,8 +1245,8 @@ instance ToAbstract LetDef [A.LetBinding] where
definedName C.LitP{} = Nothing
definedName C.RecP{} = Nothing
definedName C.QuoteP{} = Nothing
- definedName C.HiddenP{} = __IMPOSSIBLE__
- definedName C.InstanceP{} = __IMPOSSIBLE__
+ definedName C.HiddenP{} = Nothing -- Not impossible, see issue #2291
+ definedName C.InstanceP{} = Nothing
definedName C.RawAppP{} = __IMPOSSIBLE__
definedName C.AppP{} = __IMPOSSIBLE__
definedName C.OpAppP{} = __IMPOSSIBLE__
@@ -1191,7 +1267,7 @@ instance ToAbstract LetDef [A.LetBinding] where
NiceModuleMacro r p x modapp open dir | not (publicOpen dir) ->
-- Andreas, 2014-10-09, Issue 1299: module macros in lets need
-- to be private
- checkModuleMacro LetApply r PrivateAccess x modapp open dir
+ checkModuleMacro LetApply r (PrivateAccess Inserted) x modapp open dir
_ -> notAValidLetBinding d
where
@@ -1229,15 +1305,6 @@ newtype Blind a = Blind { unBlind :: a }
instance ToAbstract (Blind a) (Blind a) where
toAbstract = return
-aDefToMode :: IsAbstract -> AbstractMode
-aDefToMode AbstractDef = AbstractMode
-aDefToMode ConcreteDef = ConcreteMode
-
-aModeToDef :: AbstractMode -> IsAbstract
-aModeToDef AbstractMode = AbstractDef
-aModeToDef ConcreteMode = ConcreteDef
-aModeToDef _ = __IMPOSSIBLE__
-
-- The only reason why we return a list is that open declarations disappears.
-- For every other declaration we get a singleton list.
instance ToAbstract NiceDeclaration A.Declaration where
@@ -1252,7 +1319,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
case d of
-- Axiom (actual postulate)
- C.Axiom r f p i rel x t -> do
+ C.Axiom r f p a i rel _ x t -> do
-- check that we do not postulate in --safe mode
clo <- commandLineOptions
when (optSafe clo) (typeError (SafeFlagPostulate x))
@@ -1260,7 +1327,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
toAbstractNiceAxiom A.NoFunSig NotMacroDef d
-- Fields
- C.NiceField r i f p a x t -> do
+ C.NiceField r f p a i x t -> do
unless (p == PublicAccess) $ genericError "Record fields can not be private"
-- Interaction points for record fields have already been introduced
-- when checking the type of the record constructor.
@@ -1276,6 +1343,8 @@ instance ToAbstract NiceDeclaration A.Declaration where
-- this ensures that projections out of irrelevant fields cannot occur
-- Ulf: unless you turn on --irrelevant-projections
bindName p FldName x y
+ when (getHiding t /= Instance && argInfoOverlappable (argInfo t)) $
+ genericError "The 'overlap' keyword only applies to instance fields (fields marked with {{ }})"
return [ A.Field (mkDefInfoInstance x f p a i NotMacroDef r) y t' ]
-- Primitive function
@@ -1291,27 +1360,30 @@ instance ToAbstract NiceDeclaration A.Declaration where
-- We only termination check blocks that do not have a measure.
return [ A.Mutual (MutualInfo termCheck pc r) ds' ]
- C.NiceRecSig r f a x ls t _ -> do
+ C.NiceRecSig r f p a _pc x ls t -> do
ensureNoLetStms ls
withLocalVars $ do
ls' <- toAbstract (map makeDomainFull ls)
+ t' <- toAbstract t
x' <- freshAbstractQName f x
- bindName a DefName x x'
- t' <- toAbstract t
- return [ A.RecSig (mkDefInfo x f a ConcreteDef r) x' ls' t' ]
+ bindName p DefName x x'
+ return [ A.RecSig (mkDefInfo x f p a r) x' ls' t' ]
- C.NiceDataSig r f a x ls t _ -> withLocalVars $ do
+ C.NiceDataSig r f p a _pc x ls t -> withLocalVars $ do
printScope "scope.data.sig" 20 ("checking DataSig for " ++ show x)
ensureNoLetStms ls
ls' <- toAbstract (map makeDomainFull ls)
+ t' <- toAbstract t
x' <- freshAbstractQName f x
{- -- Andreas, 2012-01-16: remember number of parameters
- bindName a (DataName (length ls)) x x' -}
- bindName a DefName x x'
- t' <- toAbstract t
- return [ A.DataSig (mkDefInfo x f a ConcreteDef r) x' ls' t' ]
+ bindName p (DataName (length ls)) x x' -}
+ bindName p DefName x x'
+ return [ A.DataSig (mkDefInfo x f p a r) x' ls' t' ]
+
-- Type signatures
- C.FunSig r f p i m rel tc x t -> toAbstractNiceAxiom A.FunSig m (C.Axiom r f p i rel x t)
+ C.FunSig r f p a i m rel tc x t ->
+ toAbstractNiceAxiom A.FunSig m (C.Axiom r f p a i rel Nothing x t)
+
-- Function definitions
C.FunDef r ds f a tc x cs -> do
printLocals 10 $ "checking def " ++ show x
@@ -1327,12 +1399,12 @@ instance ToAbstract NiceDeclaration A.Declaration where
C.NiceFunClause{} -> __IMPOSSIBLE__
-- Data definitions
- C.DataDef r f a x pars _ cons -> withLocalVars $ do
+ C.DataDef r f a _ x pars cons -> withLocalVars $ do
printScope "scope.data.def" 20 ("checking DataDef for " ++ show x)
ensureNoLetStms pars
-- Check for duplicate constructors
- do let cs = map conName cons
- dups = nub $ cs \\ nub cs
+ do cs <- mapM conName cons
+ let dups = nub $ cs \\ nub cs
bad = filter (`elem` dups) cs
unless (distinct cs) $
setCurrentRange bad $
@@ -1352,11 +1424,11 @@ instance ToAbstract NiceDeclaration A.Declaration where
printScope "data" 20 $ "Checked data " ++ show x
return [ A.DataDef (mkDefInfo x f PublicAccess a r) x' pars cons ]
where
- conName (C.Axiom _ _ _ _ _ c _) = c
- conName _ = __IMPOSSIBLE__
+ conName (C.Axiom _ _ _ _ _ _ _ c _) = return c
+ conName d = errorNotConstrDecl d
-- Record definitions (mucho interesting)
- C.RecDef r f a x ind eta cm pars _ fields -> do
+ C.RecDef r f a _ x ind eta cm pars fields -> do
ensureNoLetStms pars
withLocalVars $ do
-- Check that the generated module doesn't clash with a previously
@@ -1367,9 +1439,9 @@ instance ToAbstract NiceDeclaration A.Declaration where
let x' = anameName ax
-- We scope check the fields a first time when putting together
-- the type of the constructor.
- contel <- toAbstract $ recordConstructorType fields
+ contel <- toAbstract =<< recordConstructorType fields
m0 <- getCurrentModule
- let m = A.qualifyM m0 $ mnameFromList $ (:[]) $ last $ qnameToList x'
+ let m = A.qualifyM m0 $ mnameFromList [ last $ qnameToList x' ]
printScope "rec" 15 "before record"
createModule False m
-- We scope check the fields a second time, as actual fields.
@@ -1442,8 +1514,8 @@ instance ToAbstract NiceDeclaration A.Declaration where
-- Bind the desired module name to the right abstract name.
case as of
- Nothing -> bindQModule PrivateAccess x m
- Just y -> bindModule PrivateAccess (asName y) m
+ Nothing -> bindQModule (PrivateAccess Inserted) x m
+ Just y -> bindModule (PrivateAccess Inserted) (asName y) m
printScope "import" 10 "merged imported sig:"
@@ -1466,7 +1538,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
}
return [ A.Import minfo m adir ]
- NiceUnquoteDecl r fxs p i a tc xs e -> do
+ NiceUnquoteDecl r fxs p a i tc xs e -> do
ys <- zipWithM freshAbstractQName fxs xs
zipWithM_ (bindName p QuotableName) xs ys
e <- toAbstract e
@@ -1483,17 +1555,19 @@ instance ToAbstract NiceDeclaration A.Declaration where
NicePatternSyn r fx n as p -> do
reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ show r
-
- y <- freshAbstractQName fx n
- bindName PublicAccess PatternSynName n y
defn@(as, p) <- withLocalVars $ do
p <- toAbstract =<< parsePatternSyn p
checkPatternLinearity [p]
let err = "Dot patterns are not allowed in pattern synonyms. Use '_' instead."
p <- noDotPattern err p
as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as
- as <- (map . fmap) unBlind <$> toAbstract ((map . fmap) Blind as)
+ unlessNull (patternVars p \\ map unArg as) $ \ xs -> do
+ typeError . GenericDocError =<< do
+ text "Unbound variables in pattern synonym: " <+>
+ sep (map prettyA xs)
return (as, p)
+ y <- freshAbstractQName fx n
+ bindName PublicAccess PatternSynName n y
modifyPatternSyns (Map.insert y defn)
return [A.PatternSynDef y as p] -- only for highlighting
where unVarName (VarName a) = return a
@@ -1501,13 +1575,13 @@ instance ToAbstract NiceDeclaration A.Declaration where
where
-- checking postulate or type sig. without checking safe flag
- toAbstractNiceAxiom funSig isMacro (C.Axiom r f p i info x t) = do
+ toAbstractNiceAxiom funSig isMacro (C.Axiom r f p a i info mp x t) = do
t' <- toAbstractCtx TopCtx t
y <- freshAbstractQName f x
let kind | isMacro == MacroDef = MacroName
| otherwise = DefName
bindName p kind x y
- return [ A.Axiom funSig (mkDefInfoInstance x f p ConcreteDef i isMacro r) info y t' ]
+ return [ A.Axiom funSig (mkDefInfoInstance x f p a i isMacro r) info mp y t' ]
toAbstractNiceAxiom _ _ _ = __IMPOSSIBLE__
@@ -1527,35 +1601,45 @@ bindConstructorName m x f a p record = do
-- An abstract constructor is private (abstract constructor means
-- abstract datatype, so the constructor should not be exported).
p' = case a of
- AbstractDef -> PrivateAccess
+ AbstractDef -> PrivateAccess Inserted
_ -> p
p'' = case (a, record) of
- (AbstractDef, _) -> PrivateAccess
+ (AbstractDef, _) -> PrivateAccess Inserted
(_, YesRec) -> OnlyQualified -- record constructors aren't really in the record module
_ -> PublicAccess
instance ToAbstract ConstrDecl A.Declaration where
toAbstract (ConstrDecl record m a p d) = do
case d of
- C.Axiom r f _ i info x t -> do -- rel==Relevant
+ C.Axiom r f p1 a1 i info Nothing x t -> do -- rel==Relevant
+ -- unless (p1 == p) __IMPOSSIBLE__ -- This invariant is currently violated by test/Succeed/Issue282.agda
+ unless (a1 == a) __IMPOSSIBLE__
t' <- toAbstractCtx TopCtx t
-- The abstract name is the qualified one
-- Bind it twice, once unqualified and once qualified
y <- bindConstructorName m x f a p record
printScope "con" 15 "bound constructor"
- return $ A.Axiom NoFunSig (mkDefInfoInstance x f p ConcreteDef i NotMacroDef r) info y t'
- _ -> typeError . GenericDocError $
+ return $ A.Axiom NoFunSig (mkDefInfoInstance x f p a i NotMacroDef r)
+ info Nothing y t'
+ C.Axiom _ _ _ _ _ _ (Just _) _ _ -> __IMPOSSIBLE__
+ _ -> errorNotConstrDecl d
+
+errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a
+errorNotConstrDecl d = typeError . GenericDocError $
P.text "Illegal declaration in data type definition " P.$$
- P.nest 2 (pretty (notSoNiceDeclaration d))
+ P.nest 2 (P.vcat $ map pretty (notSoNiceDeclarations d))
instance ToAbstract C.Pragma [A.Pragma] where
toAbstract (C.ImpossiblePragma _) = impossibleTest
toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]
- toAbstract (C.RewritePragma _ x) = do
+ toAbstract (C.RewritePragma _ []) = [] <$ warning EmptyRewritePragma
+ toAbstract (C.RewritePragma _ xs) = concat <$> do
+ forM xs $ \ x -> do
e <- toAbstract $ OldQName x Nothing
case e of
A.Def x -> return [ A.RewritePragma x ]
- A.Proj x -> return [ A.RewritePragma x ]
+ A.Proj _ (AmbQ [x]) -> return [ A.RewritePragma x ]
+ A.Proj _ x -> genericError $ "REWRITE used on ambiguous name " ++ show x
A.Con (AmbQ [x]) -> return [ A.RewritePragma x ]
A.Con x -> genericError $ "REWRITE used on ambiguous name " ++ show x
A.Var x -> genericError $ "REWRITE used on parameter " ++ show x ++ " instead of on a defined symbol"
@@ -1579,7 +1663,8 @@ instance ToAbstract C.Pragma [A.Pragma] where
e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
- A.Proj x -> return x -- TODO: do we need to do s.th. special for projections? (Andreas, 2014-10-12)
+ A.Proj _ (AmbQ [x]) -> return x -- TODO: do we need to do s.th. special for projections? (Andreas, 2014-10-12)
+ A.Proj _ x -> genericError $ "COMPILED on ambiguous name " ++ show x
A.Con _ -> genericError "Use COMPILED_DATA for constructors" -- TODO
_ -> __IMPOSSIBLE__
return [ A.CompiledPragma y hs ]
@@ -1599,7 +1684,9 @@ instance ToAbstract C.Pragma [A.Pragma] where
e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
- A.Proj x -> return x
+ A.Proj _ (AmbQ [x]) -> return x
+ A.Proj _ x -> genericError $
+ "COMPILED_JS used on ambiguous name " ++ prettyShow x
A.Con (AmbQ [x]) -> return x
A.Con x -> genericError $
"COMPILED_JS used on ambiguous name " ++ prettyShow x
@@ -1616,25 +1703,22 @@ instance ToAbstract C.Pragma [A.Pragma] where
case e of
A.Def x -> return [ A.CompiledDataUHCPragma x crd crcs ]
_ -> fail $ "Bad compiled type: " ++ show x -- TODO: error message
- toAbstract (C.NoSmashingPragma _ x) = do
- e <- toAbstract $ OldQName x Nothing
- y <- case e of
- A.Def x -> return x
- A.Proj x -> return x
- _ -> genericError "Target of NO_SMASHING pragma should be a function"
- return [ A.NoSmashingPragma y ]
toAbstract (C.StaticPragma _ x) = do
e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
- A.Proj x -> return x
+ A.Proj _ (AmbQ [x]) -> return x
+ A.Proj _ x -> genericError $
+ "STATIC used on ambiguous name " ++ prettyShow x
_ -> genericError "Target of STATIC pragma should be a function"
return [ A.StaticPragma y ]
toAbstract (C.InlinePragma _ x) = do
e <- toAbstract $ OldQName x Nothing
y <- case e of
A.Def x -> return x
- A.Proj x -> return x
+ A.Proj _ (AmbQ [x]) -> return x
+ A.Proj _ x -> genericError $
+ "INLINE used on ambiguous name " ++ prettyShow x
_ -> genericError "Target of INLINE pragma should be a function"
return [ A.InlinePragma y ]
toAbstract (C.BuiltinPragma _ b e) | isUntypedBuiltin b = do
@@ -1676,21 +1760,35 @@ instance ToAbstract C.Pragma [A.Pragma] where
top <- getHead lhs
- hd <- do
+ (isPatSyn, hd) <- do
qx <- resolveName' allKindsOfNames Nothing top
case qx of
- VarName x' -> return $ A.qnameFromList [x']
- DefinedName _ d -> return $ anameName d
- FieldName d -> return $ anameName d
- ConstructorName [d] -> return $ anameName d
+ VarName x' -> return . (False,) $ A.qnameFromList [x']
+ DefinedName _ d -> return . (False,) $ anameName d
+ FieldName [d] -> return . (False,) $ anameName d
+ FieldName ds -> genericError $ "Ambiguous projection " ++ show top ++ ": " ++ show (map anameName ds)
+ ConstructorName [d] -> return . (False,) $ anameName d
ConstructorName ds -> genericError $ "Ambiguous constructor " ++ show top ++ ": " ++ show (map anameName ds)
UnknownName -> notInScope top
- PatternSynResName d -> return $ anameName d
+ PatternSynResName d -> return . (True,) $ anameName d
lhs <- toAbstract $ LeftHandSide top lhs []
ps <- case lhs of
A.LHS _ (A.LHSHead _ ps) [] -> return ps
_ -> err
+
+ -- Andreas, 2016-08-08, issue #2132
+ -- Remove pattern synonyms on lhs
+ (hd, ps) <- do
+ let mkP | isPatSyn = A.PatternSynP (PatRange $ getRange lhs) hd
+ | otherwise = A.DefP (PatRange $ getRange lhs) (A.AmbQ [hd])
+ p <- expandPatternSynonyms $ mkP ps
+ case p of
+ A.DefP _ (A.AmbQ [hd]) ps -> return (hd, ps)
+ A.ConP _ (A.AmbQ [hd]) ps -> return (hd, ps)
+ A.PatternSynP{} -> __IMPOSSIBLE__
+ _ -> err
+
rhs <- toAbstract rhs
return [A.DisplayPragma hd ps rhs]
@@ -1702,6 +1800,9 @@ instance ToAbstract C.Pragma [A.Pragma] where
-- No positivity checking pragmas are handled by the nicifier.
toAbstract C.NoPositivityCheckPragma{} = __IMPOSSIBLE__
+ -- Polarity pragmas are handled by the niceifier.
+ toAbstract C.PolarityPragma{} = __IMPOSSIBLE__
+
instance ToAbstract C.Clause A.Clause where
toAbstract (C.Clause top _ C.Ellipsis{} _ _ _) = genericError "bad '...'" -- TODO: error message
toAbstract (C.Clause top catchall lhs@(C.LHS p wps eqs with) rhs wh wcs) = withLocalVars $ do
@@ -1712,17 +1813,22 @@ instance ToAbstract C.Clause A.Clause where
printLocals 10 "after lhs:"
let (whname, whds) = case wh of
NoWhere -> (Nothing, [])
- AnyWhere ds -> (Nothing, ds)
- SomeWhere m ds -> (Just m, ds)
+ -- Andreas, 2016-07-17 issues #2081 and #2101
+ -- where-declarations are automatically private.
+ -- This allows their type signature to be checked InAbstractMode.
+ AnyWhere ds -> (Nothing, [C.Private noRange Inserted ds])
+ -- Named where-modules do not default to private.
+ SomeWhere m a ds -> (Just (m, a), ds)
let isTerminationPragma :: C.Declaration -> Bool
+ isTerminationPragma (C.Private _ _ ds) = any isTerminationPragma ds
isTerminationPragma (C.Pragma (TerminationCheckPragma _ _)) = True
isTerminationPragma _ = False
if not (null eqs)
then do
rhs <- toAbstract =<< toAbstractCtx TopCtx (RightHandSide eqs with wcs' rhs whds)
- return $ A.Clause lhs' rhs [] catchall
+ return $ A.Clause lhs' [] rhs [] catchall
else do
-- ASR (16 November 2015) Issue 1137: We ban termination
-- pragmas inside `where` clause.
@@ -1733,16 +1839,17 @@ instance ToAbstract C.Clause A.Clause where
(rhs, ds) <- whereToAbstract (getRange wh) whname whds $
toAbstractCtx TopCtx (RightHandSide eqs with wcs' rhs [])
rhs <- toAbstract rhs
- return $ A.Clause lhs' rhs ds catchall
+ return $ A.Clause lhs' [] rhs ds catchall
-whereToAbstract :: Range -> Maybe C.Name -> [C.Declaration] -> ScopeM a -> ScopeM (a, [A.Declaration])
+whereToAbstract :: Range -> Maybe (C.Name, Access) -> [C.Declaration] -> ScopeM a -> ScopeM (a, [A.Declaration])
whereToAbstract _ _ [] inner = (,[]) <$> inner
whereToAbstract r whname whds inner = do
-- Create a fresh concrete name if there isn't (a proper) one.
- m <- case whname of
- Just m | not (isNoName m) -> return m
- _ -> C.NoName (getRange whname) <$> fresh
- let acc = maybe PrivateAccess (const PublicAccess) whname -- unnamed where's are private
+ (m, acc) <- do
+ case whname of
+ Just (m, acc) | not (isNoName m) -> return (m, acc)
+ _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, PrivateAccess Inserted)
+ -- unnamed where's are private
let tel = []
old <- getCurrentModule
am <- toAbstract (NewModuleName m)
@@ -1752,8 +1859,8 @@ whereToAbstract r whname whds inner = do
setCurrentModule old
bindModule acc m am
-- Issue 848: if the module was anonymous (module _ where) open it public
- let anonymous = maybe False isNoName whname
- when anonymous $
+ let anonymousSomeWhere = maybe False (isNoName . fst) whname
+ when anonymousSomeWhere $
void $ -- We can ignore the returned default A.ImportDirective.
openModule_ (C.QName m) $
defaultImportDir { publicOpen = True }
@@ -1770,7 +1877,7 @@ data RightHandSide = RightHandSide
data AbstractRHS
= AbsurdRHS'
| WithRHS' [A.Expr] [ScopeM C.Clause] -- ^ The with clauses haven't been translated yet
- | RHS' A.Expr
+ | RHS' A.Expr C.Expr
| RewriteRHS' [A.Expr] AbstractRHS [A.Declaration]
qualifyName_ :: A.Name -> ScopeM A.QName
@@ -1785,7 +1892,7 @@ withFunctionName s = do
instance ToAbstract AbstractRHS A.RHS where
toAbstract AbsurdRHS' = return A.AbsurdRHS
- toAbstract (RHS' e) = return $ A.RHS e
+ toAbstract (RHS' e c) = return $ A.RHS e $ Just c
toAbstract (RewriteRHS' eqs rhs wh) = do
auxs <- replicateM (length eqs) $ withFunctionName "rewrite-"
rhs <- toAbstract rhs
@@ -1814,7 +1921,7 @@ instance ToAbstract RightHandSide AbstractRHS where
instance ToAbstract C.RHS AbstractRHS where
toAbstract C.AbsurdRHS = return $ AbsurdRHS'
- toAbstract (C.RHS e) = RHS' <$> toAbstract e
+ toAbstract (C.RHS e) = RHS' <$> toAbstract e <*> pure e
data LeftHandSide = LeftHandSide C.QName C.Pattern [C.Pattern]
@@ -1848,18 +1955,18 @@ instance ToAbstract C.LHSCore (A.LHSCore' C.Expr) where
x <- withLocalVars $ setLocalVars [] >> toAbstract (OldName x)
args <- toAbstract ps
return $ A.LHSHead x args
- toAbstract (C.LHSProj d ps1 l ps2) = do
+ toAbstract c@(C.LHSProj d ps1 l ps2) = do
+ unless (null ps1) $ typeError $ GenericDocError $
+ P.text "Ill-formed projection pattern" P.<+> P.pretty (foldl C.AppP (C.IdentP d) ps1)
qx <- resolveName d
- d <- case qx of
- FieldName d -> return $ anameName d
+ ds <- case qx of
+ FieldName [] -> __IMPOSSIBLE__
+ FieldName ds -> return $ map anameName ds
UnknownName -> notInScope d
_ -> genericError $
"head of copattern needs to be a field identifier, but "
++ show d ++ " isn't one"
- args1 <- toAbstract ps1
- l <- toAbstract l
- args2 <- toAbstract ps2
- return $ A.LHSProj d args1 l args2
+ A.LHSProj (AmbQ ds) <$> toAbstract l <*> toAbstract ps2
instance ToAbstract c a => ToAbstract (WithHiding c) (WithHiding a) where
toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a
@@ -1877,9 +1984,8 @@ instance ToAbstract c a => ToAbstract (A.LHSCore' c) (A.LHSCore' a) where
-}
instance ToAbstract (A.LHSCore' C.Expr) (A.LHSCore' A.Expr) where
- toAbstract (A.LHSHead f ps) = A.LHSHead f <$> mapM toAbstract ps
- toAbstract (A.LHSProj d ps lhscore ps') = A.LHSProj d <$> mapM toAbstract ps
- <*> mapM toAbstract lhscore <*> mapM toAbstract ps'
+ toAbstract (A.LHSHead f ps) = A.LHSHead f <$> mapM toAbstract ps
+ toAbstract (A.LHSProj d lhscore ps) = A.LHSProj d <$> mapM toAbstract lhscore <*> mapM toAbstract ps
-- Patterns are done in two phases. First everything but the dot patterns, and
-- then the dot patterns. This is because dot patterns can refer to variables
@@ -1888,10 +1994,11 @@ instance ToAbstract (A.LHSCore' C.Expr) (A.LHSCore' A.Expr) where
instance ToAbstract (A.Pattern' C.Expr) (A.Pattern' A.Expr) where
toAbstract (A.VarP x) = return $ A.VarP x
toAbstract (A.ConP i ds as) = A.ConP i ds <$> mapM toAbstract as
+ toAbstract (A.ProjP i o ds) = return $ A.ProjP i o ds
toAbstract (A.DefP i x as) = A.DefP i x <$> mapM toAbstract as
toAbstract (A.WildP i) = return $ A.WildP i
toAbstract (A.AsP i x p) = A.AsP i x <$> toAbstract p
- toAbstract (A.DotP i e) = A.DotP i <$> insideDotPattern (toAbstract e)
+ toAbstract (A.DotP i o e) = A.DotP i o <$> insideDotPattern (toAbstract e)
toAbstract (A.AbsurdP i) = return $ A.AbsurdP i
toAbstract (A.LitP l) = return $ A.LitP l
toAbstract (A.PatternSynP i x as) = A.PatternSynP i x <$> mapM toAbstract as
@@ -1903,7 +2010,7 @@ resolvePatternIdentifier r x ns = do
px <- toAbstract (PatName x ns)
case px of
VarPatName y -> return $ VarP y
- ConPatName ds -> return $ ConP (ConPatInfo ConPCon $ PatRange r)
+ ConPatName ds -> return $ ConP (ConPatInfo ConOCon $ PatRange r)
(AmbQ $ map anameName ds)
[]
PatternSynPatName d -> return $ PatternSynP (PatRange r)
@@ -1919,7 +2026,9 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
getHiding p == NotHidden = do
e <- toAbstract (OldQName x Nothing)
let quoted (A.Def x) = return x
- quoted (A.Proj x) = return x
+ quoted (A.Macro x) = return x
+ quoted (A.Proj _ (AmbQ [x])) = return x
+ quoted (A.Proj _ (AmbQ xs)) = genericError $ "quote: Ambigous name: " ++ show xs
quoted (A.Con (AmbQ [x])) = return x
quoted (A.Con (AmbQ xs)) = genericError $ "quote: Ambigous name: " ++ show xs
quoted (A.ScopedExpr _ e) = quoted e
@@ -1933,6 +2042,7 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
(p', q') <- toAbstract (p, q)
case p' of
ConP i x as -> return $ ConP (i {patInfo = info}) x (as ++ [q'])
+ ProjP i o x -> typeError $ InvalidPattern p0
DefP _ x as -> return $ DefP info x (as ++ [q'])
PatternSynP _ x as -> return $ PatternSynP info x (as ++ [q'])
_ -> typeError $ InvalidPattern p0
@@ -1961,16 +2071,14 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
-- toAbstract p@(C.WildP r) = A.VarP <$> freshName r "_"
toAbstract (C.ParenP _ p) = toAbstract p
toAbstract (C.LitP l) = return $ A.LitP l
- toAbstract p0@(C.AsP r x p) = typeError $ NotSupported "@-patterns"
- {- do
+ toAbstract p0@(C.AsP r x p) = do
x <- toAbstract (NewName x)
p <- toAbstract p
return $ A.AsP info x p
where
info = PatRange r
- -}
-- we have to do dot patterns at the end
- toAbstract p0@(C.DotP r e) = return $ A.DotP info e
+ toAbstract p0@(C.DotP r o e) = return $ A.DotP info o e
where info = PatRange r
toAbstract p0@(C.AbsurdP r) = return $ A.AbsurdP info
where info = PatRange r
diff --git a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
index 2091338..ef2664f 100644
--- a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
@@ -1,11 +1,7 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
@@ -21,23 +17,24 @@
-}
module Agda.Syntax.Translation.InternalToAbstract
( Reify(..)
- , NamedClause
+ , NamedClause(..)
, reifyPatterns
) where
-import Prelude hiding (mapM_, mapM)
-import Control.Applicative
+import Prelude hiding (mapM_, mapM, null)
+import Control.Applicative hiding (empty)
import Control.Monad.State hiding (mapM_, mapM)
import Control.Monad.Reader hiding (mapM_, mapM)
import Data.Foldable (foldMap)
-import Data.List hiding (sort)
+import Data.List hiding (null, sort)
import qualified Data.Map as Map
import Data.Maybe
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend)
import Data.Set (Set)
import qualified Data.Set as Set
-import Data.Traversable as Trav
+import Data.Traversable (traverse, mapM)
+import qualified Data.Traversable as Trav
import Agda.Syntax.Literal
import Agda.Syntax.Position
@@ -51,7 +48,7 @@ import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Pattern as I
import Agda.Syntax.Scope.Base (isNameInScope, inverseScopeLookupName)
-import Agda.TypeChecking.Monad as M hiding (MetaInfo, tick)
+import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Reduce
import {-# SOURCE #-} Agda.TypeChecking.Records
@@ -64,13 +61,19 @@ import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.DropArgs
+import Agda.Interaction.Options ( optPostfixProjections )
+
import Agda.Utils.Except ( MonadError(catchError) )
+import Agda.Utils.Function
+import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Permutation
-import Agda.Utils.Pretty
+import Agda.Utils.Pretty hiding ((<>))
+import Agda.Utils.Singleton
import Agda.Utils.Size
import Agda.Utils.Tuple
@@ -79,44 +82,38 @@ import Agda.Utils.Impossible
-- Composition of reified applications ------------------------------------
+-- | Drops hidden arguments unless --show-implicit.
napps :: Expr -> [NamedArg Expr] -> TCM Expr
-napps e args = do
- dontShowImp <- not <$> showImplicitArguments
- let apply1 e arg | notVisible arg && dontShowImp = e
- | otherwise = App exprInfo e arg
- foldl' apply1 e <$> reify args
+napps e = nelims e . map I.Apply
+-- | Drops hidden arguments unless --show-implicit.
apps :: Expr -> [Arg Expr] -> TCM Expr
-apps e args = napps e $ map (fmap unnamed) args
-
-reifyApp :: Expr -> [Arg Term] -> TCM Expr
-reifyApp e vs = apps e =<< reifyIArgs vs
-
-reifyIArg :: Reify i a => Arg i -> TCM (Arg a)
-reifyIArg i = Arg (argInfo i) <$> reify (unArg i)
-
-reifyIArgs :: Reify i a => [Arg i] -> TCM [Arg a]
-reifyIArgs = mapM reifyIArg
+apps e = elims e . map I.Apply
-- Composition of reified eliminations ------------------------------------
+-- | Drops hidden arguments unless --show-implicit.
+nelims :: Expr -> [I.Elim' (Named_ Expr)] -> TCM Expr
+nelims e [] = return e
+nelims e (I.Apply arg : es) = do
+ arg <- reify arg -- This replaces the arg by _ if irrelevant
+ dontShowImp <- not <$> showImplicitArguments
+ let hd | notVisible arg && dontShowImp = e
+ | otherwise = A.App noExprInfo e arg
+ nelims hd es
+nelims e (I.Proj o@ProjPrefix d : es) =
+ nelims (A.App noExprInfo (A.Proj o $ AmbQ [d]) $ defaultNamedArg e) es
+nelims e (I.Proj o d : es) =
+ nelims (A.App noExprInfo e (defaultNamedArg $ A.Proj o $ AmbQ [d])) es
+
+-- | Drops hidden arguments unless --show-implicit.
elims :: Expr -> [I.Elim' Expr] -> TCM Expr
-elims e [] = return e
-elims e (I.Apply arg : es) =
- elims (A.App exprInfo e $ fmap unnamed arg) es
-elims e (I.Proj d : es) = elims (A.App exprInfo (A.Proj d) $ defaultNamedArg e) es
-
-reifyIElim :: Reify i a => I.Elim' i -> TCM (I.Elim' a)
-reifyIElim (I.Apply i) = I.Apply <$> traverse reify i
-reifyIElim (I.Proj d) = return $ I.Proj d
-
-reifyIElims :: Reify i a => [I.Elim' i] -> TCM [I.Elim' a]
-reifyIElims = mapM reifyIElim
+elims e = nelims e . map (fmap unnamed)
-- Omitting information ---------------------------------------------------
-exprInfo :: ExprInfo
-exprInfo = ExprRange noRange
+noExprInfo :: ExprInfo
+noExprInfo = ExprRange noRange
-- Conditional reification to omit terms that are not shown --------------
@@ -144,16 +141,16 @@ instance Reify Expr Expr where
instance Reify MetaId Expr where
reifyWhen = reifyWhenE
reify x@(MetaId n) = liftTCM $ do
+ b <- asks envPrintMetasBare
mi <- mvInfo <$> lookupMeta x
let mi' = Info.MetaInfo
{ metaRange = getRange $ miClosRange mi
- , metaScope = M.clScope $ miClosRange mi
- , metaNumber = Just x
- , metaNameSuggestion = miNameSuggestion mi
+ , metaScope = clScope $ miClosRange mi
+ , metaNumber = if b then Nothing else Just x
+ , metaNameSuggestion = if b then "" else miNameSuggestion mi
}
underscore = return $ A.Underscore mi'
- ifNotM shouldReifyInteractionPoints underscore $ {- else -}
- caseMaybeM (isInteractionMeta x) underscore $ \ ii@InteractionId{} ->
+ caseMaybeM (isInteractionMeta x) underscore $ \ ii@InteractionId{} ->
return $ A.QuestionMark mi' ii
-- Does not print with-applications correctly:
@@ -166,20 +163,20 @@ instance Reify DisplayTerm Expr where
reify d = case d of
DTerm v -> reifyTerm False v
DDot v -> reify v
- DCon c vs -> apps (A.Con (AmbQ [conName c])) =<< reifyIArgs vs
- DDef f es -> elims (A.Def f) =<< reifyIElims es
- DWithApp u us vs -> do
+ DCon c ci vs -> apps (A.Con (AmbQ [conName c])) =<< reify vs
+ DDef f es -> elims (A.Def f) =<< reify es
+ DWithApp u us es0 -> do
(e, es) <- reify (u, us)
- reifyApp (if null es then e else A.WithApp exprInfo e es) vs
+ elims (if null es then e else A.WithApp noExprInfo e es) =<< reify es0
-- | @reifyDisplayForm f vs fallback@
-- tries to rewrite @f vs@ with a display form for @f@.
-- If successful, reifies the resulting display term,
-- otherwise, does @fallback@.
-reifyDisplayForm :: QName -> I.Args -> TCM A.Expr -> TCM A.Expr
-reifyDisplayForm f vs fallback = do
+reifyDisplayForm :: QName -> I.Elims -> TCM A.Expr -> TCM A.Expr
+reifyDisplayForm f es fallback = do
ifNotM displayFormsEnabled fallback $ {- else -} do
- caseMaybeM (liftTCM $ displayForm f vs) fallback reify
+ caseMaybeM (liftTCM $ displayForm f es) fallback reify
-- | @reifyDisplayFormP@ tries to recursively
-- rewrite a lhs with a display form.
@@ -188,9 +185,6 @@ reifyDisplayForm f vs fallback = do
reifyDisplayFormP :: A.SpineLHS -> TCM A.SpineLHS
reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
ifNotM displayFormsEnabled (return lhs) $ {- else -} do
- let vs = [ setHiding h $ defaultArg $ I.var i
- | (i, h) <- zip [0..] $ map getHiding ps
- ]
-- Try to rewrite @f 0 1 2 ... |ps|-1@ to a dt.
-- Andreas, 2014-06-11 Issue 1177:
-- I thought we need to add the placeholders for ps to the context,
@@ -199,7 +193,7 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
-- But apparently, it has no influence...
-- Ulf, can you add an explanation?
md <- liftTCM $ -- addContext (replicate (length ps) "x") $
- displayForm f vs
+ displayForm f $ zipWith (\ p i -> I.Apply $ p $> I.var i) ps [0..]
reportSLn "reify.display" 60 $
"display form of " ++ show f ++ " " ++ show ps ++ " " ++ show wps ++ ":\n " ++ show md
case md of
@@ -226,8 +220,8 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
-- can serve as a valid left-hand side. That means checking that it is a
-- defined name applied to valid lhs eliminators (projections or
-- applications to constructor patterns).
- okDisplayForm (DWithApp d ds args) =
- okDisplayForm d && all okDisplayTerm ds && all okToDrop args
+ okDisplayForm (DWithApp d ds es) =
+ okDisplayForm d && all okDisplayTerm ds && all okToDropE es
-- Andreas, 2016-05-03, issue #1950.
-- We might drop trailing hidden trivial (=variable) patterns.
okDisplayForm (DTerm (I.Def f vs)) = all okElim vs
@@ -245,6 +239,9 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
okDElim (I.Apply v) = okDisplayTerm $ unArg v
okDElim I.Proj{} = True
+ okToDropE (I.Apply v) = okToDrop v
+ okToDropE I.Proj{} = False
+
okToDrop arg = notVisible arg && case ignoreSharing $ unArg arg of
I.Var _ [] -> True
I.DontCare{} -> True -- no matching on irrelevant things. __IMPOSSIBLE__ anyway?
@@ -257,30 +254,29 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
okElim (I.Proj{}) = True
okTerm (I.Var _ []) = True
- okTerm (I.Con c vs) = all okArg vs
+ okTerm (I.Con c ci vs) = all okArg vs
okTerm (I.Def x []) = isNoName $ qnameToConcrete x -- Handling wildcards in display forms
okTerm _ = False
-- Flatten a dt into (parentName, parentElims, withArgs).
- flattenWith :: DisplayTerm -> (QName, [I.Elim' DisplayTerm], [DisplayTerm])
- flattenWith (DWithApp d ds1 ds2) = case flattenWith d of
- (f, es, ds0) -> (f, es, ds0 ++ ds1 ++ map (DTerm . unArg) ds2)
+ flattenWith :: DisplayTerm -> (QName, [I.Elim' DisplayTerm], [I.Elim' DisplayTerm])
+ flattenWith (DWithApp d ds1 es2) =
+ let (f, es, ds0) = flattenWith d
+ in (f, es, ds0 ++ map (I.Apply . defaultArg) ds1 ++ map (fmap DTerm) es2)
flattenWith (DDef f es) = (f, es, []) -- .^ hacky, but we should only hit this when printing debug info
flattenWith (DTerm (I.Def f es)) = (f, map (fmap DTerm) es, [])
flattenWith _ = __IMPOSSIBLE__
displayLHS :: [A.Pattern] -> [A.Pattern] -> DisplayTerm -> TCM A.SpineLHS
- displayLHS ps wps d = case flattenWith d of
- (f, vs, ds) -> do
- ds <- mapM termToPat ds
+ displayLHS ps wps d = do
+ let (f, vs, es) = flattenWith d
+ ds <- mapM (namedArg <.> elimToPat) es
vs <- mapM elimToPat vs
return $ SpineLHS i f vs (ds ++ wps)
where
- ci = ConPatInfo ConPCon patNoRange
-
argToPat arg = fmap unnamed <$> traverse termToPat arg
elimToPat (I.Apply arg) = argToPat arg
- elimToPat (I.Proj d) = return $ defaultNamedArg $ A.DefP patNoRange d []
+ elimToPat (I.Proj o d) = return $ defaultNamedArg $ A.ProjP patNoRange o $ AmbQ [d]
termToPat :: DisplayTerm -> TCM A.Pattern
@@ -288,17 +284,17 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
Nothing -> __IMPOSSIBLE__
Just p -> p
- termToPat (DCon c vs) = tryRecPFromConP =<< do
- A.ConP ci (AmbQ [conName c]) <$> mapM argToPat vs
+ termToPat (DCon c ci vs) = tryRecPFromConP =<< do
+ A.ConP (ConPatInfo ci patNoRange) (AmbQ [conName c]) <$> mapM argToPat vs
- termToPat (DTerm (I.Con c vs)) = tryRecPFromConP =<< do
- A.ConP ci (AmbQ [conName c]) <$> mapM (argToPat . fmap DTerm) vs
+ termToPat (DTerm (I.Con c ci vs)) = tryRecPFromConP =<< do
+ A.ConP (ConPatInfo ci patNoRange) (AmbQ [conName c]) <$> mapM (argToPat . fmap DTerm) vs
termToPat (DTerm (I.Def _ [])) = return $ A.WildP patNoRange
termToPat (DDef _ []) = return $ A.WildP patNoRange
- termToPat (DDot v) = A.DotP patNoRange <$> termToExpr v
- termToPat v = A.DotP patNoRange <$> reify v -- __IMPOSSIBLE__
+ termToPat (DDot v) = A.DotP patNoRange Inserted <$> termToExpr v
+ termToPat v = A.DotP patNoRange Inserted <$> reify v -- __IMPOSSIBLE__
len = genericLength ps
@@ -310,7 +306,7 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
reportSLn "reify.display" 60 $ "termToExpr " ++ show v
-- After unSpine, a Proj elimination is __IMPOSSIBLE__!
case unSpine v of
- I.Con c vs ->
+ I.Con c ci vs ->
apps (A.Con (AmbQ [conName c])) =<< argsToExpr vs
I.Def f es -> do
let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es
@@ -337,32 +333,35 @@ instance Reify Term Expr where
reifyTerm :: Bool -> Term -> TCM Expr
reifyTerm expandAnonDefs0 v = do
+ metasBare <- asks envPrintMetasBare
-- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled
-- (i.e. when we don't care about nice printing)
expandAnonDefs <- return expandAnonDefs0 `and2M` displayFormsEnabled
- v <- unSpine <$> instantiate v
- case v of
+ -- Andreas, 2016-07-21 if --postfix-projections
+ -- then we print system-generated projections as postfix, else prefix.
+ havePfp <- optPostfixProjections <$> pragmaOptions
+ let pred = if havePfp then (== ProjPrefix) else (/= ProjPostfix)
+ v <- ignoreSharing <$> instantiate v
+ case applyUnless metasBare (unSpine' pred) v of
I.Var n es -> do
- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
x <- liftTCM $ nameOfBV n `catchError` \_ -> freshName_ ("@" ++ show n)
- reifyApp (A.Var x) vs
+ elims (A.Var x) =<< reify es
I.Def x es -> do
- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- reifyDisplayForm x vs $ reifyDef expandAnonDefs x vs
- I.Con c vs -> do
+ reifyDisplayForm x es $ reifyDef expandAnonDefs x es
+ I.Con c ci vs -> do
let x = conName c
isR <- isGeneratedRecordConstructor x
- case isR of
+ case isR || ci == ConORec of
True -> do
showImp <- showImplicitArguments
let keep (a, v) = showImp || notHidden a
r <- getConstructorData x
xs <- getRecordFieldNames r
- vs <- map unArg <$> reifyIArgs vs
- return $ A.Rec exprInfo $ map (Left . uncurry FieldAssignment . mapFst unArg) $ filter keep $ zip xs vs
- False -> reifyDisplayForm x vs $ do
- ci <- getConstInfo x
- let Constructor{conPars = np} = theDef ci
+ vs <- map unArg <$> reify vs
+ return $ A.Rec noExprInfo $ map (Left . uncurry FieldAssignment . mapFst unArg) $ filter keep $ zip xs vs
+ False -> reifyDisplayForm x (map I.Apply vs) $ do
+ def <- getConstInfo x
+ let Constructor{conPars = np} = theDef def
-- if we are the the module that defines constructor x
-- then we have to drop at least the n module parameters
n <- getDefFreeVars x
@@ -371,7 +370,7 @@ reifyTerm expandAnonDefs0 v = do
when (n > np) __IMPOSSIBLE__
let h = A.Con (AmbQ [x])
if null vs then return h else do
- es <- reifyIArgs vs
+ es <- reify vs
-- Andreas, 2012-04-20: do not reify parameter arguments of constructor
-- if the first regular constructor argument is hidden
-- we turn it into a named argument, in order to avoid confusion
@@ -387,38 +386,30 @@ reifyTerm expandAnonDefs0 v = do
-- Here, we need the reducing version of @telView@
-- because target of constructor could be a definition
-- expanding into a function type. See test/succeed/NameFirstIfHidden.agda.
- TelV tel _ <- telView (defType ci)
- case genericDrop np $ telToList tel of
+ TelV tel _ <- telView (defType def)
+ let (pars, rest) = splitAt np $ telToList tel
+ case rest of
-- Andreas, 2012-09-18
-- If the first regular constructor argument is hidden,
-- we keep the parameters to avoid confusion.
- (Dom info _ : _) | isHidden info -> do
- let us = genericReplicate (np - n) $
- setRelevance Relevant $ Arg info underscore
- apps h $ us ++ es
+ (Dom info _ : _) | notVisible info -> do
+ let us = for (drop n pars) $ \ (Dom ai _) ->
+ -- setRelevance Relevant $
+ hideOrKeepInstance $ Arg ai underscore
+ apps h $ us ++ es -- Note: unless --show-implicit, @apps@ will drop @us@.
-- otherwise, we drop all parameters
_ -> apps h es
-{- CODE FROM 2012-04-xx
- let doms = genericDrop np $ telToList tel
- reportSLn "syntax.reify.con" 30 $ unlines
- [ "calling nameFirstIfHidden"
- , "doms = " ++ show doms
- , "es = " ++ show es
- , "n = " ++ show n
- , "np = " ++ show np
- ]
- napps h $ genericDrop (n - np) $ nameFirstIfHidden doms es
--}
--- I.Lam info b | isAbsurdBody b -> return $ A.AbsurdLam exprInfo $ getHiding info
+
+-- I.Lam info b | isAbsurdBody b -> return $ A. AbsurdLam noExprInfo $ getHiding info
I.Lam info b -> do
(x,e) <- reify b
- return $ A.Lam exprInfo (DomainFree info x) e
+ return $ A.Lam noExprInfo (DomainFree info x) e
-- Andreas, 2011-04-07 we do not need relevance information at internal Lambda
I.Lit l -> reify l
I.Level l -> reify l
I.Pi a b -> case b of
NoAbs _ b'
- | notHidden a -> uncurry (A.Fun $ exprInfo) <$> reify (a, b')
+ | notHidden a -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b')
-- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi
-- since (a) the syntax {A} -> B or {{A}} -> B is not legal
-- and (b) the name of the binder might matter.
@@ -431,7 +422,7 @@ reifyTerm expandAnonDefs0 v = do
where
mkPi b (Arg info a) = do
(x, b) <- reify b
- return $ A.Pi exprInfo [TypedBindings noRange $ Arg info (TBind noRange [pure x] a)] b
+ return $ A.Pi noExprInfo [TypedBindings noRange $ Arg info (TBind noRange [pure x] a)] b
-- We can omit the domain type if it doesn't have any free variables
-- and it's mentioned in the target type.
domainFree a b = do
@@ -440,9 +431,9 @@ reifyTerm expandAnonDefs0 v = do
I.Sort s -> reify s
I.MetaV x es -> do
- let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
x' <- reify x
- apps x' =<< reifyIArgs vs
+ ifM (asks envPrintMetasBare) {-then-} (return x') {-else-} $
+ elims x' =<< reify es
I.DontCare v -> A.DontCare <$> reifyTerm expandAnonDefs v
I.Shared p -> reifyTerm expandAnonDefs $ derefPtr p
where
@@ -450,10 +441,10 @@ reifyTerm expandAnonDefs0 v = do
-- to improve error messages.
-- Don't do this if we have just expanded into a display form,
-- otherwise we loop!
- reifyDef :: Bool -> QName -> I.Args -> TCM Expr
- reifyDef True x vs =
- ifM (not . null . inverseScopeLookupName x <$> getScope) (reifyDef' x vs) $ do
- r <- reduceDefCopy x vs
+ reifyDef :: Bool -> QName -> I.Elims -> TCM Expr
+ reifyDef True x es =
+ ifM (not . null . inverseScopeLookupName x <$> getScope) (reifyDef' x es) $ do
+ r <- reduceDefCopy x es
case r of
YesReduction _ v -> do
reportSLn "reify.anon" 60 $ unlines
@@ -466,31 +457,53 @@ reifyTerm expandAnonDefs0 v = do
reportSLn "reify.anon" 60 $ unlines
[ "no reduction on defined ident. in anonymous module"
, "x = " ++ show x
- , "vs = " ++ show vs
+ , "es = " ++ show es
]
- reifyDef' x vs
- reifyDef _ x vs = reifyDef' x vs
+ reifyDef' x es
+ reifyDef _ x es = reifyDef' x es
- reifyDef' :: QName -> I.Args -> TCM Expr
- reifyDef' x@(QName _ name) vs = do
+ reifyDef' :: QName -> I.Elims -> TCM Expr
+ reifyDef' x es = do
+ reportSLn "reify.def" 60 $ "reifying call to " ++ show x
-- We should drop this many arguments from the local context.
n <- getDefFreeVars x
- mdefn <- liftTCM $ (Just <$> getConstInfo x) `catchError` \_ -> return Nothing
- -- check if we have an absurd lambda
- let reifyAbsurdLambda cont =
- case theDef <$> mdefn of
- Just Function{ funCompiled = Just Fail, funClauses = [cl] }
+ -- If the definition is not (yet) in the signature,
+ -- we just do the obvious.
+ let fallback = elims (A.Def x) =<< reify (drop n es)
+ caseMaybeM (tryMaybe $ getConstInfo x) fallback $ \ defn -> do
+ let def = theDef defn
+
+ -- Check if we have an absurd lambda.
+ case def of
+ Function{ funCompiled = Just Fail, funClauses = [cl] }
| isAbsurdLambdaName x -> do
-- get hiding info from last pattern, which should be ()
- let h = getHiding $ last (clausePats cl)
- apps (A.AbsurdLam exprInfo h) =<< reifyIArgs vs
- _ -> cont
- reifyAbsurdLambda $ do
- (pad, vs :: [NamedArg Term]) <- do
- case mdefn of
- Nothing -> return ([], map (fmap unnamed) $ genericDrop n vs)
- Just defn -> do
- let def = theDef defn
+ let h = getHiding $ last $ namedClausePats cl
+ elims (A.AbsurdLam noExprInfo h) =<< reify (drop n es)
+
+ -- Otherwise (no absurd lambda):
+ _ -> do
+
+ -- Andrea(s), 2016-07-06
+ -- Extended lambdas are not considered to be projection like,
+ -- as they are mutually recursive with their parent.
+ -- Thus we do not have to consider padding them.
+
+ -- Check whether we have an extended lambda and display forms are on.
+ df <- displayFormsEnabled
+ toppars <- size <$> do lookupSection $ qnameModule x
+ let extLam = case def of
+ Function{ funExtLam = Just{}, funProjection = Just{} } -> __IMPOSSIBLE__
+ Function{ funExtLam = Just (ExtLamInfo h nh) } -> Just (toppars + h + nh)
+ _ -> Nothing
+ case extLam of
+ Just pars | df -> reifyExtLam x pars (defClauses defn) es
+
+ -- Otherwise (ordinary function call):
+ _ -> do
+ (pad, nes :: [Elim' (Named_ Term)]) <- case def of
+
+ Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do
-- This is tricky:
-- * getDefFreeVars x tells us how many arguments
-- are part of the local context
@@ -499,57 +512,99 @@ reifyTerm expandAnonDefs0 v = do
-- * when showImplicits is on we'd like to see the dropped
-- projection arguments
+ TelV tel _ <- telViewUpTo np (defType defn)
+ let (as, rest) = splitAt (np - 1) $ telToList tel
+ dom = fromMaybe __IMPOSSIBLE__ $ headMaybe rest
+
-- These are the dropped projection arguments
- (np, pad, dom) <-
- case def of
- Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do
- TelV tel _ <- telView (defType defn)
- scope <- getScope
- let (as, dom:_) = splitAt (np - 1) $ telToList tel
- whocares = A.Underscore $ Info.emptyMetaInfo { metaScope = scope }
- return (np, map (argFromDom . (fmap $ const whocares)) as, dom)
- _ -> return (0, [], __IMPOSSIBLE__)
- -- Now pad' ++ vs' = drop n (pad ++ vs)
- let pad' = genericDrop n pad
- vs' = genericDrop (max 0 (n - size pad)) vs
- -- Andreas, 2012-04-21: get rid of hidden underscores {_}
- -- Keep non-hidden arguments of the padding
+ scope <- getScope
+ let underscore = A.Underscore $ Info.emptyMetaInfo { metaScope = scope }
+ let pad = for as $ \ (Dom ai (x, _)) ->
+ Arg ai $ Named (Just $ unranged x) underscore
+
+ -- Now pad' ++ es' = drop n (pad ++ es)
+ let pad' = drop n pad
+ es' = drop (max 0 (n - size pad)) es
+ -- Andreas, 2012-04-21: get rid of hidden underscores {_} and {{_}}
+ -- Keep non-hidden arguments of the padding.
+ --
+ -- Andreas, 2016-12-20, issue #2348:
+ -- Let @padTail@ be the list of arguments of the padding
+ -- (*) after the last visible argument of the padding, and
+ -- (*) with the same visibility as the first regular argument.
+ -- If @padTail@ is not empty, we need to
+ -- print the first regular argument with name.
+ -- We further have to print all elements of @padTail@
+ -- which have the same name and visibility of the
+ -- first regular argument.
showImp <- showImplicitArguments
- return (filter visible pad',
- if not (null pad) && showImp && notVisible (last pad)
- then nameFirstIfHidden [dom] vs'
- else map (fmap unnamed) vs')
- df <- displayFormsEnabled
- let extLam = case mdefn of
- Nothing -> Nothing
- Just defn -> case theDef defn of
- Function{ funExtLam = Just (ExtLamInfo h nh) } -> Just (h + nh)
- _ -> Nothing
- case extLam of
- Just pars | df -> do
- info <- getConstInfo x
- reifyExtLam x pars (defClauses info) vs
- _ -> do
- let apps = foldl' (\e a -> A.App exprInfo e (fmap unnamed a))
- napps (A.Def x `apps` pad) =<< reifyIArgs vs
-
- reifyExtLam :: QName -> Int -> [I.Clause] -> [NamedArg Term] -> TCM Expr
- reifyExtLam x n cls vs = do
- reportSLn "reify.def" 10 $ "reifying extended lambda with definition: x = " ++ show x
- -- drop lambda lifted arguments
- cls <- mapM (reify . QNamed x . dropArgs n) $ cls
+
+ -- Get the visible arguments of the padding and the rest
+ -- after the last visible argument.
+ let (padVisNamed, padRest) = filterAndRest visible pad'
+
+ -- Remove the names from the visible arguments.
+ let padVis = map (fmap (unnamed . namedThing)) padVisNamed
+
+ -- Keep only the rest with the same visibility of @dom@...
+ let padTail = filter ((getHiding dom ==) . getHiding) padRest
+
+ -- ... and even the same name.
+ let padSame = filter ((Just (fst (unDom dom)) ==) . fmap rangedThing . nameOf . unArg) padTail
+
+ return $ if null padTail || not showImp
+ then (padVis , map (fmap unnamed) es')
+ else (padVis ++ padSame, nameFirstIfHidden dom es')
+
+ -- If it is not a projection(-like) function, we need no padding.
+ _ -> return ([], map (fmap unnamed) $ drop n es)
+ let hd = foldl' (A.App noExprInfo) (A.Def x) pad
+ nelims hd =<< reify nes
+
+ -- Andreas, 2016-07-06 Issue #2047
+
+ -- With parameter refinement, the "parameter" patterns of an extended
+ -- lambda can now be different from variable patterns. If we just drop
+ -- them (plus the associated arguments to the extended lambda), we produce
+ -- something
+
+ -- * that violates internal invariants. In particular, the permutation
+ -- dbPatPerm from the patterns to the telescope can no longer be
+ -- computed. (And in fact, dropping from the start of the telescope is
+ -- just plainly unsound then.)
+
+ -- * prints the wrong thing (old fix for #2047)
+
+ -- What we do now, is more sound, although not entirely satisfying:
+ -- When the "parameter" patterns of an external lambdas are not variable
+ -- patterns, we fall back to printing the internal function created for the
+ -- extended lambda, instead trying to construct the nice syntax.
+
+ reifyExtLam :: QName -> Int -> [I.Clause] -> I.Elims -> TCM Expr
+ reifyExtLam x npars cls es = do
+ reportSLn "reify.def" 10 $ "reifying extended lambda " ++ show x
+ reportSLn "reify.def" 50 $ show $ nest 2 $ vcat
+ [ text "npars =" <+> pretty npars
+ , text "es =" <+> fsep (map (prettyPrec 10) es)
+ , text "def =" <+> vcat (map pretty cls) ]
+ -- As extended lambda clauses live in the top level, we add the whole
+ -- section telescope to the number of parameters.
+ let (pars, rest) = splitAt npars es
+ -- Since we applying the clauses to the parameters,
+ -- we do not need to drop their initial "parameter" patterns
+ -- (this is taken care of by @apply@).
+ cls <- mapM (reify . NamedClause x False . (`applyE` pars)) cls
let cx = nameConcrete $ qnameName x
dInfo = mkDefInfo cx noFixity' PublicAccess ConcreteDef (getRange x)
- napps (A.ExtendedLam exprInfo dInfo x cls) =<< reifyIArgs vs
-
--- | @nameFirstIfHidden n (a1->...an->{x:a}->b) ({e} es) = {x = e} es@
-nameFirstIfHidden :: [Dom (ArgName, t)] -> [Arg a] -> [NamedArg a]
-nameFirstIfHidden _ [] = []
-nameFirstIfHidden [] (_ : _) = __IMPOSSIBLE__
-nameFirstIfHidden (dom : _) (Arg info e : es) | isHidden info =
- Arg info (Named (Just $ unranged $ fst $ unDom dom) e) :
+ elims (A.ExtendedLam noExprInfo dInfo x cls) =<< reify rest
+
+-- | @nameFirstIfHidden (x:a) ({e} es) = {x = e} es@
+nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)]
+nameFirstIfHidden dom (I.Apply (Arg info e) : es) | notVisible info =
+ I.Apply (Arg info (Named (Just $ unranged $ fst $ unDom dom) e)) :
+ map (fmap unnamed) es
+nameFirstIfHidden _ es =
map (fmap unnamed) es
-nameFirstIfHidden _ es = map (fmap unnamed) es
instance Reify i a => Reify (Named n i) (Named n a) where
reify = traverse reify
@@ -562,124 +617,35 @@ instance (Reify i a) => Reify (Arg i) (Arg a) where
`and2M` (return (argInfoRelevance info /= Irrelevant) `or2M` showIrrelevantArguments)
reifyWhen b i = traverse (reifyWhen b) i
-instance Reify Elim Expr where
- reifyWhen = reifyWhenE
- reify e = case e of
- I.Apply v -> appl "apply" <$> reify v
- I.Proj f -> appl "proj" <$> reify ((defaultArg $ I.Def f []) :: Arg Term)
- where
- appl :: String -> Arg Expr -> Expr
- appl s v = A.App exprInfo (A.Lit (LitString noRange s)) $ fmap unnamed v
-
-type NamedClause = QNamed I.Clause
--- data NamedClause = NamedClause QName I.Clause
-
-instance Reify ClauseBody RHS where
- reify NoBody = return AbsurdRHS
- reify (Body v) = RHS <$> reify v
- reify (Bind b) = reify $ absBody b -- the variables should already be bound
--- Local data types to shuffleDots
-data DotBind = BindFirstExplicit | BindFirstImplicit | AlreadyBound deriving (Show)
-data DoBind = YesBind | NoBind | DontTouch deriving (Eq, Show)
+data NamedClause = NamedClause QName Bool I.Clause
+ -- ^ Also tracks whether module parameters should be dropped from the patterns.
-- The Monoid instance for Data.Map doesn't require that the values are a
-- monoid.
newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map.Map k v }
+instance (Ord k, Monoid v) => Semigroup (MonoidMap k v) where
+ MonoidMap m1 <> MonoidMap m2 = MonoidMap (Map.unionWith mappend m1 m2)
+
instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
mempty = MonoidMap Map.empty
- mappend (MonoidMap m1) (MonoidMap m2) = MonoidMap (Map.unionWith mappend m1 m2)
-
--- | Move dots on variables so that each variable is bound at its first
--- non-hidden occurrence (if any). If all occurrences are hidden it's bound
--- at the first occurrence.
-shuffleDots :: ([NamedArg A.Pattern], [A.Pattern]) -> TCM ([NamedArg A.Pattern], [A.Pattern])
-shuffleDots (ps, wps) = do
- return $ (`evalState` xs)
- $ (`runReaderT` NotHidden)
- $ (,) <$> redotArgs ps <*> redotPats wps
- where
- -- An argument is explicit if _all_ Arg's on the way are explicit. In the
- -- map we store if _any_ of the variable occurrences were explicit.
- implicit = All False
- explicit = All True
- -- compute binding strategy
- xs = Map.map (\(_, h) -> if getAny h then BindFirstExplicit else BindFirstImplicit)
- $ Map.filter (getAny . fst) -- remove vars that don't appear dotted
- $ unMonoidMap
- $ argsVars explicit ps `mappend` foldMap (patVars explicit) wps
-
- -- Compute a map from pattern vars to (AppearsDotted, AppearsInANonHiddenPosition)
- argsVars h = foldMap (argVars h)
- argVars h a = (foldMap $ foldMap $ patVars (h `mappend` h')) a
- where h' = if getHiding a == NotHidden then explicit else implicit
- patVars h p = case p of
- A.VarP x -> MonoidMap $ Map.singleton x (Any False, Any $ getAll h)
- A.DotP _ (A.Var x) -> MonoidMap $ Map.singleton x (Any True, Any $ getAll h)
- A.DotP{} -> mempty
- A.ConP _ _ ps -> argsVars h ps
- A.DefP _ _ ps -> argsVars h ps
- A.PatternSynP _ _ ps -> argsVars h ps
- A.WildP{} -> mempty
- A.AbsurdP{} -> mempty
- A.LitP{} -> mempty
- A.AsP{} -> __IMPOSSIBLE__
- A.RecP _ as -> foldMap (foldMap (patVars h)) as
-
- shouldBind x = do
- xs <- get
- h <- ask
- let b = case Map.lookup x xs of
- Nothing -> DontTouch
- Just s -> case s of
- BindFirstExplicit | h == NotHidden -> YesBind
- | otherwise -> NoBind
- BindFirstImplicit -> YesBind -- in this case we know h isn't NotHidden
- AlreadyBound -> NoBind
- when (b == YesBind) $ put $ Map.adjust (const AlreadyBound) x xs
- return b
-
- redotArgs = traverse redotArg
- redotArg a = hide $ traverse (traverse redotPat) a
- where hide | getHiding a /= NotHidden = local (const Hidden)
- | otherwise = id
- redotPats = traverse redotPat
- redotPat p = case p of
- A.VarP x -> redotVar p x
- A.DotP _ (A.Var x) -> redotVar p x
- A.DotP{} -> pure p
- A.ConP i c ps -> A.ConP i c <$> redotArgs ps
- A.DefP i f ps -> A.DefP i f <$> redotArgs ps
- A.PatternSynP i x ps -> A.PatternSynP i x <$> redotArgs ps
- A.WildP{} -> pure p
- A.AbsurdP{} -> pure p
- A.LitP{} -> pure p
- A.AsP{} -> __IMPOSSIBLE__
- A.RecP i as -> A.RecP i <$> traverse (traverse redotPat) as
-
- redotVar p x = do
- b <- shouldBind x
- return $ case b of
- DontTouch -> p
- YesBind -> A.VarP x
- NoBind -> A.DotP (Info.PatRange $ getRange p) (A.Var x)
+ mappend = (<>)
-- | Removes implicit arguments that are not needed, that is, that don't bind
-- any variables that are actually used and doesn't do pattern matching.
+-- Doesn't strip any arguments that were written explicitly by the user.
stripImplicits :: ([NamedArg A.Pattern], [A.Pattern]) ->
TCM ([NamedArg A.Pattern], [A.Pattern])
stripImplicits (ps, wps) = do -- v if show-implicit we don't need the names
ifM showImplicitArguments (return (map (unnamed . namedThing <$>) ps, wps)) $ do
- let vars = dotVars (ps, wps)
reportSLn "reify.implicit" 30 $ unlines
[ "stripping implicits"
, " ps = " ++ show ps
, " wps = " ++ show wps
- , " vars = " ++ show vars
]
let allps = ps ++ map defaultNamedArg wps
- sps = blankDots $ foldl (.) (strip Set.empty) (map rearrangeBinding $ Set.toList vars) $ allps
+ sps = blankDots $ strip allps
(ps', wps') = splitAt (length sps - length wps) sps
reportSLn "reify.implicit" 30 $ unlines
[ " ps' = " ++ show ps'
@@ -687,64 +653,40 @@ stripImplicits (ps, wps) = do -- v if show-implicit we don't need the n
]
return (ps', map namedArg wps')
where
- argsVars = Set.unions . map argVars
- argVars = patVars . namedArg
- patVars p = case p of
- A.VarP x -> Set.singleton x
- A.ConP _ _ ps -> argsVars ps
- A.DefP _ _ ps -> Set.empty
- A.DotP _ e -> Set.empty
- A.WildP _ -> Set.empty
- A.AbsurdP _ -> Set.empty
- A.LitP _ -> Set.empty
- A.AsP _ _ p -> patVars p
- A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- Set.empty
- A.RecP _ as -> foldMap (foldMap patVars) as
-
- -- Replace dot variables by ._ if they use implicitly bound variables. This
- -- is slightly nicer than making the implicts explicit.
- blankDots ps = (map . fmap . fmap . fmap) blank ps
- where
- bound = argsVars ps
- blank e | Set.null (Set.difference (dotVars e) bound) = e
- | otherwise = A.Underscore emptyMetaInfo
-
- -- Pick the "best" place to bind the variable. Best in this case
- -- is the left-most explicit binding site. But, of course we can't
- -- do this since binding site might be forced by a parent clause.
- -- Why? Because the binding site we pick might not exist in the
- -- generated with function if it corresponds to a dot pattern.
- rearrangeBinding x ps = ps
-
- strip dvs ps = stripArgs True ps
+ -- Replace variables in dot patterns by an underscore _ if they are hidden
+ -- in the pattern. This is slightly nicer than making the implicts explicit.
+ blankDots ps = blank (varsBoundIn ps) ps
+
+ strip ps = stripArgs True ps
where
stripArgs _ [] = []
stripArgs fixedPos (a : as) =
- case getHiding a of
- Hidden | canStrip a as -> stripArgs False as
- Instance | canStrip a as -> stripArgs False as
- _ -> stripName fixedPos (stripArg a) :
- stripArgs True as
+ if canStrip a
+ then if all canStrip $ takeWhile isUnnamedHidden as
+ then stripArgs False as
+ else let a' = fmap ($> A.WildP (Info.PatRange $ getRange a)) a
+ in stripName fixedPos a' : stripArgs True as
+ else stripName fixedPos (stripArg a) : stripArgs True as
stripName True = fmap (unnamed . namedThing)
stripName False = id
- canStrip a as = and
- [ varOrDot p
- , noInterestingBindings p
- , all (flip canStrip []) $ takeWhile isUnnamedHidden as
+ canStrip a = and
+ [ notVisible a
+ , getOrigin a /= UserWritten
+ , varOrDot (namedArg a)
]
- where p = namedArg a
- isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing
+ isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing && isNothing (isProjP x)
stripArg a = fmap (fmap stripPat) a
stripPat p = case p of
A.VarP _ -> p
A.ConP i c ps -> A.ConP i c $ stripArgs True ps
+ A.ProjP{} -> p
A.DefP _ _ _ -> p
- A.DotP _ e -> p
+ A.DotP _ _ e -> p
A.WildP _ -> p
A.AbsurdP _ -> p
A.LitP _ -> p
@@ -752,88 +694,94 @@ stripImplicits (ps, wps) = do -- v if show-implicit we don't need the n
A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p
A.RecP i fs -> A.RecP i $ map (fmap stripPat) fs -- TODO Andreas: is this right?
- noInterestingBindings p =
- Set.null $ dvs `Set.intersection` patVars p
-
varOrDot A.VarP{} = True
varOrDot A.WildP{} = True
varOrDot A.DotP{} = True
+ varOrDot (A.ConP cpi _ ps) | patOrigin cpi == ConOSystem
+ = all varOrDot $ map namedArg ps
varOrDot _ = False
--- | @dotVars ps@ gives all the variables inside of dot patterns of @ps@
--- It is only invoked for patternish things. (Ulf O-tone!)
--- Use it for printing l.h.sides: which of the implicit arguments
--- have to be made explicit.
-class DotVars a where
- dotVars :: a -> Set Name
- isConPat :: a -> Bool
- isConPat _ = False
-
-instance DotVars a => DotVars (Arg a) where
- dotVars a = if notVisible a && not (isConPat a) -- Hidden constructor patterns are visible!
- then Set.empty
- else dotVars (unArg a)
- isConPat = isConPat . unArg
-
-instance DotVars a => DotVars (Named s a) where
- dotVars = dotVars . namedThing
- isConPat = isConPat . namedThing
-
-instance DotVars a => DotVars [a] where
- dotVars = Set.unions . map dotVars
-
-instance (DotVars a, DotVars b) => DotVars (a, b) where
- dotVars (x, y) = Set.union (dotVars x) (dotVars y)
-
-instance (DotVars a, DotVars b) => DotVars (Either a b) where
- dotVars = either dotVars dotVars
-
-instance DotVars A.Clause where
- dotVars (A.Clause _ rhs [] _) = dotVars rhs
- dotVars (A.Clause _ rhs (_:_) _) = __IMPOSSIBLE__ -- cannot contain where clauses?
-
-instance DotVars A.Pattern where
- dotVars p = case p of
- A.VarP _ -> Set.empty -- do not add pattern vars
- A.ConP _ _ ps -> dotVars ps
- A.DefP _ _ ps -> dotVars ps
- A.DotP _ e -> dotVars e
- A.WildP _ -> Set.empty
- A.AbsurdP _ -> Set.empty
- A.LitP _ -> Set.empty
- A.AsP _ _ p -> dotVars p
- A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- Set.empty
- A.RecP _ fs -> dotVars fs
-
- isConPat A.ConP{} = True
- isConPat A.LitP{} = True
- isConPat _ = False
-
--- | Getting all(!) variables of an expression.
--- It should only get free ones, but it does not matter to include
--- the bound ones.
-instance DotVars A.Expr where
- dotVars e = case e of
- A.ScopedExpr _ e -> dotVars e
- A.Var x -> Set.singleton x -- add any expression variable
- A.Def _ -> Set.empty
- A.Proj _ -> Set.empty
- A.Con _ -> Set.empty
- A.Lit _ -> Set.empty
- A.QuestionMark{} -> Set.empty
- A.Underscore _ -> Set.empty
- A.App _ e1 e2 -> dotVars (e1, e2)
- A.WithApp _ e es -> dotVars (e, es)
- A.Lam _ _ e -> dotVars e
- A.AbsurdLam _ _ -> Set.empty
- A.ExtendedLam _ _ _ cs -> dotVars cs
- A.Pi _ tel e -> dotVars (tel, e)
- A.Fun _ a b -> dotVars (a, b)
- A.Set _ _ -> Set.empty
- A.Prop _ -> Set.empty
+-- | @blank bound x@ replaces all variables in @x@ that are not in @bound@ by
+-- an underscore @_@. It is used for printing dot patterns: we don't want to
+-- make implicit variables explicit, so we blank them out in the dot patterns
+-- instead (this is fine since dot patterns can be inferred anyway).
+class BlankVars a where
+ blank :: Set Name -> a -> a
+
+instance BlankVars a => BlankVars (Arg a) where
+ blank bound = fmap $ blank bound
+
+instance BlankVars a => BlankVars (Named s a) where
+ blank bound = fmap $ blank bound
+
+instance BlankVars a => BlankVars [a] where
+ blank bound = fmap $ blank bound
+
+instance (BlankVars a, BlankVars b) => BlankVars (a, b) where
+ blank bound (x, y) = (blank bound x, blank bound y)
+
+instance (BlankVars a, BlankVars b) => BlankVars (Either a b) where
+ blank bound (Left x) = Left $ blank bound x
+ blank bound (Right y) = Right $ blank bound y
+
+instance BlankVars A.NamedDotPattern where
+ blank bound = id
+
+instance BlankVars A.Clause where
+ blank bound (A.Clause lhs namedDots rhs [] ca) =
+ let bound' = varsBoundIn lhs `Set.union` bound
+ in A.Clause (blank bound' lhs)
+ (blank bound' namedDots)
+ (blank bound' rhs) [] ca
+ blank bound (A.Clause lhs namedDots rhs (_:_) ca) = __IMPOSSIBLE__
+
+instance BlankVars A.LHS where
+ blank bound (A.LHS i core wps) = uncurry (A.LHS i) $ blank bound (core, wps)
+
+instance BlankVars A.LHSCore where
+ blank bound (A.LHSHead f ps) = A.LHSHead f $ blank bound ps
+ blank bound (A.LHSProj p b ps) = uncurry (A.LHSProj p) $ blank bound (b, ps)
+
+instance BlankVars A.Pattern where
+ blank bound p = case p of
+ A.VarP _ -> p -- do not blank pattern vars
+ A.ConP c i ps -> A.ConP c i $ blank bound ps
+ A.ProjP{} -> p
+ A.DefP i f ps -> A.DefP i f $ blank bound ps
+ A.DotP i o e -> A.DotP i o $ blank bound e
+ A.WildP _ -> p
+ A.AbsurdP _ -> p
+ A.LitP _ -> p
+ A.AsP i n p -> A.AsP i n $ blank bound p
+ A.PatternSynP _ _ _ -> __IMPOSSIBLE__
+ A.RecP i fs -> A.RecP i $ blank bound fs
+
+instance BlankVars A.Expr where
+ blank bound e = case e of
+ A.ScopedExpr i e -> A.ScopedExpr i $ blank bound e
+ A.Var x -> if x `Set.member` bound then e
+ else A.Underscore emptyMetaInfo
+ A.Def _ -> e
+ A.Proj{} -> e
+ A.Con _ -> e
+ A.Lit _ -> e
+ A.QuestionMark{} -> e
+ A.Underscore _ -> e
+ A.Dot i e -> A.Dot i $ blank bound e
+ A.App i e1 e2 -> uncurry (A.App i) $ blank bound (e1, e2)
+ A.WithApp i e es -> uncurry (A.WithApp i) $ blank bound (e, es)
+ A.Lam i b e -> let bound' = varsBoundIn b `Set.union` bound
+ in A.Lam i (blank bound b) (blank bound' e)
+ A.AbsurdLam _ _ -> e
+ A.ExtendedLam i d f cs -> A.ExtendedLam i d f $ blank bound cs
+ A.Pi i tel e -> let bound' = varsBoundIn tel `Set.union` bound
+ in uncurry (A.Pi i) $ blank bound' (tel, e)
+ A.Fun i a b -> uncurry (A.Fun i) $ blank bound (a, b)
+ A.Set _ _ -> e
+ A.Prop _ -> e
A.Let _ _ _ -> __IMPOSSIBLE__
- A.Rec _ es -> dotVars es
- A.RecUpdate _ e es -> dotVars (e, es)
+ A.Rec i es -> A.Rec i $ blank bound es
+ A.RecUpdate i e es -> uncurry (A.RecUpdate i) $ blank bound (e, es)
A.ETel _ -> __IMPOSSIBLE__
A.QuoteGoal {} -> __IMPOSSIBLE__
A.QuoteContext {} -> __IMPOSSIBLE__
@@ -841,89 +789,122 @@ instance DotVars A.Expr where
A.QuoteTerm {} -> __IMPOSSIBLE__
A.Unquote {} -> __IMPOSSIBLE__
A.Tactic {} -> __IMPOSSIBLE__
- A.DontCare v -> dotVars v
- A.PatternSyn {} -> Set.empty
- A.Macro {} -> Set.empty
-
-instance DotVars a => DotVars (FieldAssignment' a) where
- dotVars a = dotVars (a ^. exprFieldA)
-
-instance DotVars A.ModuleName where
- dotVars _ = Set.empty
-
-instance DotVars RHS where
- dotVars (RHS e) = dotVars e
- dotVars AbsurdRHS = Set.empty
- dotVars (WithRHS _ es clauses) = __IMPOSSIBLE__ -- NZ
- dotVars (RewriteRHS xes rhs _) = __IMPOSSIBLE__ -- NZ
-
-instance DotVars TypedBindings where
- dotVars (TypedBindings _ bs) = dotVars bs
-
-instance DotVars TypedBinding where
- dotVars (TBind _ _ e) = dotVars e
- dotVars (TLet _ _) = __IMPOSSIBLE__ -- Since the internal syntax has no let bindings left
-
-class MonadTick m where
- tick :: m Nat
-
-newtype TickT m a = TickT { unTickT :: StateT Nat m a }
- deriving (Functor, Applicative, Monad, MonadReader r, MonadTrans, MonadIO) -- MonadExcept e,
-
-instance Monad m => MonadTick (TickT m) where
- tick = TickT $ do i <- get; put (i + 1); return i
-
-instance MonadState s m => MonadState s (TickT m) where
- state f = lift $ state f -- TickT $ StateT $ \ n -> (,n) <$> state f
-
-instance MonadTCM tcm => MonadTCM (TickT tcm) where
- liftTCM = lift . liftTCM
-
-runTickT :: Monad m => TickT m a -> m a
-runTickT m = evalStateT (unTickT m) 0
-
--- TODO: implement reifyPatterns on de Bruijn patterns ( numberPatVars )
-reifyPatterns :: I.Telescope -> Permutation -> [NamedArg I.Pattern] -> TCM [NamedArg A.Pattern]
-reifyPatterns tel perm ps = runTickT (reifyArgs ps)
+ A.DontCare v -> A.DontCare $ blank bound v
+ A.PatternSyn {} -> e
+ A.Macro {} -> e
+
+instance BlankVars a => BlankVars (FieldAssignment' a) where
+ blank bound = over exprFieldA (blank bound)
+
+instance BlankVars A.ModuleName where
+ blank bound = id
+
+instance BlankVars RHS where
+ blank bound (RHS e mc) = RHS (blank bound e) mc
+ blank bound AbsurdRHS = AbsurdRHS
+ blank bound (WithRHS _ es clauses) = __IMPOSSIBLE__ -- NZ
+ blank bound (RewriteRHS xes rhs _) = __IMPOSSIBLE__ -- NZ
+
+instance BlankVars A.LamBinding where
+ blank bound b@A.DomainFree{} = b
+ blank bound (A.DomainFull bs) = A.DomainFull $ blank bound bs
+
+instance BlankVars TypedBindings where
+ blank bound (TypedBindings r bs) = TypedBindings r $ blank bound bs
+
+instance BlankVars TypedBinding where
+ blank bound (TBind r n e) = TBind r n $ blank bound e
+ blank bound (TLet _ _) = __IMPOSSIBLE__ -- Since the internal syntax has no let bindings left
+
+class Binder a where
+ varsBoundIn :: a -> Set Name
+
+instance Binder A.LHS where
+ varsBoundIn (A.LHS _ core ps) = varsBoundIn (core, ps)
+
+instance Binder A.LHSCore where
+ varsBoundIn (A.LHSHead _ ps) = varsBoundIn ps
+ varsBoundIn (A.LHSProj _ b ps) = varsBoundIn (b, ps)
+
+instance Binder A.Pattern where
+ varsBoundIn p = case p of
+ A.VarP x -> if show x == "()" then empty else singleton x
+ A.ConP _ _ ps -> varsBoundIn ps
+ A.ProjP{} -> empty
+ A.DefP _ _ ps -> varsBoundIn ps
+ A.WildP{} -> empty
+ A.AsP _ _ p -> varsBoundIn p
+ A.DotP{} -> empty
+ A.AbsurdP{} -> empty
+ A.LitP{} -> empty
+ A.PatternSynP _ _ ps -> varsBoundIn ps
+ A.RecP _ fs -> varsBoundIn fs
+
+instance Binder A.LamBinding where
+ varsBoundIn (A.DomainFree _ x) = singleton x
+ varsBoundIn (A.DomainFull b) = varsBoundIn b
+
+instance Binder TypedBindings where
+ varsBoundIn (TypedBindings _ b) = varsBoundIn b
+
+instance Binder TypedBinding where
+ varsBoundIn (TBind _ xs _) = varsBoundIn xs
+ varsBoundIn (TLet _ bs) = varsBoundIn bs
+
+instance Binder LetBinding where
+ varsBoundIn (LetBind _ _ x _ _) = singleton x
+ varsBoundIn (LetPatBind _ p _) = varsBoundIn p
+ varsBoundIn LetApply{} = empty
+ varsBoundIn LetOpen{} = empty
+ varsBoundIn LetDeclaredVariable{} = empty
+
+instance Binder a => Binder (FieldAssignment' a) where
+ varsBoundIn = varsBoundIn . (^. exprFieldA)
+
+instance Binder a => Binder (Arg a) where
+ varsBoundIn = varsBoundIn . unArg
+
+instance Binder a => Binder (Named x a) where
+ varsBoundIn = varsBoundIn . namedThing
+
+instance Binder (WithHiding Name) where
+ varsBoundIn (WithHiding _ x) = singleton x
+
+instance Binder a => Binder [a] where
+ varsBoundIn xs = Set.unions $ map varsBoundIn xs
+
+instance (Binder a, Binder b) => Binder (a, b) where
+ varsBoundIn (x, y) = varsBoundIn x `Set.union` varsBoundIn y
+
+
+-- | Assumes that pattern variables have been added to the context already.
+-- Picks pattern variable names from context.
+reifyPatterns :: MonadTCM tcm => [NamedArg I.DeBruijnPattern] -> tcm [NamedArg A.Pattern]
+reifyPatterns = mapM $ stripNameFromExplicit <.> traverse (traverse reifyPat)
where
- reifyArgs :: [NamedArg I.Pattern] -> TickT TCM [NamedArg A.Pattern]
- reifyArgs is = mapM reifyArg is
-
- reifyArg :: NamedArg I.Pattern -> TickT TCM (NamedArg A.Pattern)
- reifyArg i = stripNameFromExplicit <$>
- traverse (traverse reifyPat) i
-
+ stripNameFromExplicit :: NamedArg p -> NamedArg p
stripNameFromExplicit a
| getHiding a == NotHidden = fmap (unnamed . namedThing) a
| otherwise = a
- translate n = fromMaybe __IMPOSSIBLE__ $ vars !!! n
- where
- vars = permPicks $ invertP __IMPOSSIBLE__ perm
-
- reifyPat :: I.Pattern -> TickT TCM A.Pattern
+ reifyPat :: MonadTCM tcm => I.DeBruijnPattern -> tcm A.Pattern
reifyPat p = do
liftTCM $ reportSLn "reify.pat" 80 $ "reifying pattern " ++ show p
case p of
- I.VarP "()" -> A.AbsurdP patNoRange <$ tick -- HACK
- I.VarP s -> do
- i <- tick
- let j = translate i
- liftTCM $ A.VarP <$> nameOfBV (size tel - 1 - j)
+ I.VarP x | isAbsurdPatternName (dbPatVarName x)
+ -> return $ A.AbsurdP patNoRange -- HACK
+ I.VarP x -> liftTCM $ A.VarP <$> nameOfBV (dbPatVarIndex x)
I.DotP v -> do
t <- liftTCM $ reify v
- _ <- tick
- let vars = Set.map show (dotVars t)
- t' = if Set.member "()" vars then underscore else t
- return $ A.DotP patNoRange t'
+ return $ A.DotP patNoRange Inserted t
I.LitP l -> return $ A.LitP l
- I.ProjP d -> return $ A.DefP patNoRange d []
+ I.ProjP o d -> return $ A.ProjP patNoRange o $ AmbQ [d]
I.ConP c cpi ps -> do
liftTCM $ reportSLn "reify.pat" 60 $ "reifying pattern " ++ show p
- tryRecPFromConP =<< do A.ConP ci (AmbQ [conName c]) <$> reifyArgs ps
+ tryRecPFromConP =<< do A.ConP ci (AmbQ [conName c]) <$> reifyPatterns ps
where
- origin = fromMaybe ConPCon $ I.conPRecord cpi
ci = ConPatInfo origin patNoRange
+ origin = fromMaybe ConOCon $ I.conPRecord cpi
-- | If the record constructor is generated or the user wrote a record pattern,
-- turn constructor pattern into record pattern.
@@ -937,7 +918,7 @@ tryRecPFromConP p = do
-- If the record constructor is generated or the user wrote a record pattern,
-- print record pattern.
-- Otherwise, print constructor pattern.
- if recNamedCon def && patOrigin ci /= ConPRec then fallback else do
+ if recNamedCon def && patOrigin ci /= ConORec then fallback else do
fs <- liftTCM $ getRecordFieldNames r
unless (length fs == length ps) __IMPOSSIBLE__
return $ A.RecP patNoRange $ zipWith mkFA fs ps
@@ -945,26 +926,37 @@ tryRecPFromConP p = do
mkFA ax nap = FieldAssignment (unArg ax) (namedArg nap)
_ -> __IMPOSSIBLE__
+instance Reify (QNamed I.Clause) A.Clause where
+ reify (QNamed f cl) = reify (NamedClause f True cl)
+
instance Reify NamedClause A.Clause where
- reify (QNamed f (I.Clause _ tel ps' body _ catchall)) = addCtxTel tel $ do
- ps <- reifyPatterns tel perm ps
+ reify (NamedClause f toDrop cl) = addContext (clauseTel cl) $ do
+ reportSLn "reify.clause" 60 $ "reifying NamedClause"
+ ++ "\n f = " ++ show f
+ ++ "\n toDrop = " ++ show toDrop
+ ++ "\n cl = " ++ show cl
+ ps <- reifyPatterns $ namedClausePats cl
lhs <- liftTCM $ reifyDisplayFormP $ SpineLHS info f ps [] -- LHS info (LHSHead f ps) []
- nfv <- getDefFreeVars f `catchError` \_ -> return 0
- lhs <- stripImps $ dropParams nfv lhs
+ -- Unless @toDrop@ we have already dropped the module patterns from the clauses
+ -- (e.g. for extended lambdas).
+ lhs <- if not toDrop then return lhs else do
+ nfv <- getDefFreeVars f `catchError` \_ -> return 0
+ return $ dropParams nfv lhs
+ lhs <- stripImps lhs
reportSLn "reify.clause" 60 $ "reifying NamedClause, lhs = " ++ show lhs
- rhs <- reify $ renameP (reverseP perm) <$> body
+ rhs <- caseMaybe (clauseBody cl) (return AbsurdRHS) $ \ e -> do
+ RHS <$> reify e <*> pure Nothing
reportSLn "reify.clause" 60 $ "reifying NamedClause, rhs = " ++ show rhs
- let result = A.Clause (spineToLhs lhs) rhs [] catchall
+ let result = A.Clause (spineToLhs lhs) [] rhs [] (I.clauseCatchall cl)
reportSLn "reify.clause" 60 $ "reified NamedClause, result = " ++ show result
return result
where
+ perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl
info = LHSRange noRange
- ps = unnumberPatVars ps'
- perm = dbPatPerm ps'
dropParams n (SpineLHS i f ps wps) = SpineLHS i f (genericDrop n ps) wps
stripImps (SpineLHS i f ps wps) = do
- (ps, wps) <- stripImplicits =<< shuffleDots (ps, wps)
+ (ps, wps) <- stripImplicits (ps, wps)
return $ SpineLHS i f ps wps
instance Reify Type Expr where
@@ -976,12 +968,12 @@ instance Reify Sort Expr where
reify s = do
s <- instantiateFull s
case s of
- I.Type (I.Max []) -> return $ A.Set exprInfo 0
- I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set exprInfo n
+ I.Type (I.Max []) -> return $ A.Set noExprInfo 0
+ I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set noExprInfo n
I.Type a -> do
a <- reify a
- return $ A.App exprInfo (A.Set exprInfo 0) (defaultNamedArg a)
- I.Prop -> return $ A.Prop exprInfo
+ return $ A.App noExprInfo (A.Set noExprInfo 0) (defaultNamedArg a)
+ I.Prop -> return $ A.Prop noExprInfo
I.Inf -> A.Var <$> freshName_ ("Setω" :: String)
I.SizeUniv -> do
I.Def sizeU [] <- primSizeUniv
@@ -989,7 +981,7 @@ instance Reify Sort Expr where
I.DLub s1 s2 -> do
lub <- freshName_ ("dLub" :: String) -- TODO: hack
(e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2)
- let app x y = A.App exprInfo x (defaultNamedArg y)
+ let app x y = A.App noExprInfo x (defaultNamedArg y)
return $ A.Var lub `app` e1 `app` e2
instance Reify Level Expr where
@@ -1005,7 +997,7 @@ instance (Free i, Reify i a) => Reify (Abs i) (Name, a) where
s <- return $ if isUnderscore s && 0 `freeIn` v then "z" else s
x <- freshName_ s
- e <- addContext x -- type doesn't matter
+ e <- addContext' x -- type doesn't matter
$ reify v
return (x,e)
@@ -1020,8 +1012,13 @@ instance Reify I.Telescope A.Telescope where
instance Reify i a => Reify (Dom i) (Arg a) where
reify (Dom info i) = Arg info <$> reify i
+instance Reify i a => Reify (I.Elim' i) (I.Elim' a) where
+ reify = traverse reify
+ reifyWhen b = traverse (reifyWhen b)
+
instance Reify i a => Reify [i] [a] where
- reify = traverse reify
+ reify = traverse reify
+ reifyWhen b = traverse (reifyWhen b)
instance (Reify i1 a1, Reify i2 a2) => Reify (i1,i2) (a1,a2) where
reify (x,y) = (,) <$> reify x <*> reify y
diff --git a/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs b/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs
index 260e74a..d0b7a90 100644
--- a/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -25,8 +22,10 @@ import Agda.TypeChecking.Monad as M hiding (MetaInfo)
import Agda.Syntax.Scope.Monad (getCurrentModule)
import Agda.Utils.Maybe
+import Agda.Utils.Monad
import Agda.Utils.List
import Agda.Utils.Functor
+import Agda.Utils.Size
type Names = [Name]
@@ -93,14 +92,20 @@ instance ToAbstract Literal Expr where
instance ToAbstract Term Expr where
toAbstract t = case t of
R.Var i es -> do
- let fallback = withName ("@" ++ show i) return
- name <- fromMaybeM fallback $ askName i
- toAbstract (A.Var name, es)
+ mname <- askName i
+ case mname of
+ Nothing -> do
+ cxt <- lift $ getContextTelescope
+ names <- asks $ drop (size cxt) . reverse
+ lift $ withShowAllArguments' False $ typeError $ DeBruijnIndexOutOfScope i cxt names
+ Just name -> toAbstract (A.Var name, es)
R.Con c es -> toAbstract (A.Con (AmbQ [killRange c]), es)
- R.Def f es -> toAbstract (A.Def (killRange f), es)
+ R.Def f es -> do
+ af <- lift $ mkDef (killRange f)
+ toAbstract (af, es)
R.Lam h t -> do
(e, name) <- toAbstract t
- let info = setHiding h defaultArgInfo
+ let info = setHiding h $ setOrigin Reflected defaultArgInfo
return $ A.Lam exprNoRange (DomainFree info name) e
R.ExtLam cs es -> do
name <- freshName_ extendedLambdaName
@@ -120,6 +125,12 @@ instance ToAbstract Term Expr where
where info = emptyMetaInfo{ metaNumber = Just x }
R.Unknown -> return $ Underscore emptyMetaInfo
+mkDef :: QName -> TCM A.Expr
+mkDef f =
+ ifM (isMacro . theDef <$> getConstInfo f)
+ (return $ A.Macro f)
+ (return $ A.Def f)
+
mkSet :: Expr -> Expr
mkSet e = App exprNoRange (A.Set exprNoRange 0) $ defaultNamedArg e
@@ -132,13 +143,16 @@ instance ToAbstract R.Pattern (Names, A.Pattern) where
toAbstract pat = case pat of
R.ConP c args -> do
(names, args) <- toAbstractPats args
- return (names, A.ConP (ConPatInfo ConPCon patNoRange) (AmbQ [killRange c]) args)
- R.DotP -> return ([], A.DotP patNoRange (Underscore emptyMetaInfo))
- R.VarP s -> withName s' $ \name -> return ([name], A.VarP name)
- where s' = if (isNoName s) then "z" else s --TODO: only do this when var is free
+ return (names, A.ConP (ConPatInfo ConOCon patNoRange) (AmbQ [killRange c]) args)
+ R.DotP -> return ([], A.WildP patNoRange)
+ R.VarP s | isNoName s -> withName "z" $ \ name -> return ([name], A.VarP name)
+ -- Ulf, 2016-08-09: Also bind noNames (#2129). This to make the
+ -- behaviour consistent with lambda and pi.
+ -- return ([], A.WildP patNoRange)
+ R.VarP s -> withName s $ \ name -> return ([name], A.VarP name)
R.LitP l -> return ([], A.LitP l)
R.AbsurdP -> return ([], A.AbsurdP patNoRange)
- R.ProjP p -> return ([], A.DefP patNoRange p [])
+ R.ProjP d -> return ([], A.ProjP patNoRange ProjSystem $ AmbQ [killRange d])
toAbstractPats :: [Arg R.Pattern] -> WithNames (Names, [NamedArg A.Pattern])
toAbstractPats pats = case pats of
@@ -153,11 +167,11 @@ instance ToAbstract (QNamed R.Clause) A.Clause where
(names, pats) <- toAbstractPats pats
rhs <- local (names++) $ toAbstract rhs
let lhs = spineToLhs $ SpineLHS (LHSRange noRange) name pats []
- return $ A.Clause lhs (RHS rhs) [] False
+ return $ A.Clause lhs [] (RHS rhs Nothing) [] False
toAbstract (QNamed name (R.AbsurdClause pats)) = do
(_, pats) <- toAbstractPats pats
let lhs = spineToLhs $ SpineLHS (LHSRange noRange) name pats []
- return $ A.Clause lhs AbsurdRHS [] False
+ return $ A.Clause lhs [] AbsurdRHS [] False
instance ToAbstract [QNamed R.Clause] [A.Clause] where
toAbstract = traverse toAbstract
diff --git a/src/full/Agda/Syntax/Treeless.hs b/src/full/Agda/Syntax/Treeless.hs
index 2d6c427..c31d50f 100644
--- a/src/full/Agda/Syntax/Treeless.hs
+++ b/src/full/Agda/Syntax/Treeless.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE PatternGuards #-}
-- | The treeless syntax is intended to be used as input for the compiler backends.
-- It is more low-level than Internal syntax and is not used for type checking.
@@ -12,7 +11,7 @@ module Agda.Syntax.Treeless
, module Agda.Syntax.Treeless
) where
-import Prelude
+import Control.Arrow (first, second)
import Data.Map (Map)
import Data.Typeable (Typeable)
@@ -58,9 +57,34 @@ data TTerm = TVar Int
-- | Compiler-related primitives. This are NOT the same thing as primitives
-- in Agda's surface or internal syntax!
-data TPrim = PAdd | PSub | PMul | PQuot | PRem | PGeq | PLt | PEq | PIf | PSeq
+-- Some of the primitives have a suffix indicating which type of arguments they take,
+-- using the following naming convention:
+-- Char | Type
+-- C | Character
+-- F | Float
+-- I | Integer
+-- Q | QName
+-- S | String
+data TPrim
+ = PAdd
+ | PSub
+ | PMul
+ | PQuot
+ | PRem
+ | PGeq
+ | PLt
+ | PEqI
+ | PEqF
+ | PEqS
+ | PEqC
+ | PEqQ
+ | PIf
+ | PSeq
deriving (Typeable, Show, Eq, Ord)
+isPrimEq :: TPrim -> Bool
+isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ]
+
mkTApp :: TTerm -> Args -> TTerm
mkTApp x [] = x
mkTApp (TApp x as) bs = TApp x (as ++ bs)
@@ -73,6 +97,18 @@ tAppView = view
TApp a bs -> view a ++ bs
_ -> [t]
+tLetView :: TTerm -> ([TTerm], TTerm)
+tLetView (TLet e b) = first (e :) $ tLetView b
+tLetView e = ([], e)
+
+tLamView :: TTerm -> (Int, TTerm)
+tLamView = go 0
+ where go n (TLam b) = go (n + 1) b
+ go n t = (n, t)
+
+mkTLam :: Int -> TTerm -> TTerm
+mkTLam n b = foldr ($) b $ replicate n TLam
+
-- | Introduces a new binding
mkLet :: TTerm -> TTerm -> TTerm
mkLet x body = TLet x body
@@ -95,6 +131,7 @@ tNegPlusK k n = tOp PSub (tInt (-k)) n
plusKView :: TTerm -> Maybe (Integer, TTerm)
plusKView (TApp (TPrim PAdd) [k, n]) | Just k <- intView k = Just (k, n)
+plusKView (TApp (TPrim PSub) [n, k]) | Just k <- intView k = Just (-k, n)
plusKView _ = Nothing
negPlusKView :: TTerm -> Maybe (Integer, TTerm)
@@ -107,10 +144,16 @@ tOp op a b = TApp (TPrim op) [a, b]
tUnreachable :: TTerm
tUnreachable = TError TUnreachable
+tIfThenElse :: TTerm -> TTerm -> TTerm -> TTerm
+tIfThenElse c i e = TApp (TPrim PIf) [c, i, e]
+
data CaseType
= CTData QName -- case on datatype
+ | CTNat
+ | CTInt
| CTChar
| CTString
+ | CTFloat
| CTQName
deriving (Typeable, Show, Eq, Ord)