{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.
--
--   * Attach fixity and syntax declarations to the definition they refer to.
--
--   * Distribute the following attributes to the individual definitions:
--       @abstract@,
--       @instance@,
--       @postulate@,
--       @primitive@,
--       @private@,
--       termination pragmas.
--
--   * Gather the function clauses belonging to one function definition.
--
--   * Expand ellipsis @...@ in function clauses following @with@.
--
--   * Infer mutual blocks.
--     A block starts when a lone signature is encountered, and ends when
--     all lone signatures have seen their definition.
--
--   * Report basic well-formedness error,
--     when one of the above transformation fails.
--     When possible, errors should be deferred to the scope checking phase
--     (ConcreteToAbstract), where we are in the TCM and can produce more
--     informative error messages.


module Agda.Syntax.Concrete.Definitions
    ( NiceDeclaration(..)
    , NiceConstructor, NiceTypeSignature
    , Clause(..)
    , DeclarationException(..)
    , DeclarationWarning(..), unsafeDeclarationWarning
    , Nice, runNice
    , niceDeclarations
    , notSoNiceDeclarations
    , niceHasAbstract
    , Measure
    , declarationWarningName
    ) where

import Prelude hiding (null)

import Control.Arrow ((&&&), (***), second)
import Control.Monad.Except
import Control.Monad.State

import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import qualified Data.List as List
import qualified Data.Foldable as Fold
import Data.Traversable (Traversable, traverse)
import qualified Data.Traversable as Trav

import Data.Data (Data)

import Agda.Syntax.Concrete
import Agda.Syntax.Concrete.Pattern
import Agda.Syntax.Common hiding (TerminationCheck())
import qualified Agda.Syntax.Common as Common
import Agda.Syntax.Position
import Agda.Syntax.Notation
import Agda.Syntax.Concrete.Pretty () --instance only
import Agda.Syntax.Concrete.Fixity

import Agda.Interaction.Options.Warnings

import Agda.Utils.AffineHole
import Agda.Utils.Except ( MonadError(throwError) )
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List (isSublistOf)
import Agda.Utils.Maybe
import Agda.Utils.Null
import qualified Agda.Utils.Pretty as Pretty
import Agda.Utils.Pretty
import Agda.Utils.Singleton
import Agda.Utils.Three
import Agda.Utils.Tuple
import Agda.Utils.Update

import Agda.Utils.Impossible

{--------------------------------------------------------------------------
    Types
 --------------------------------------------------------------------------}

{-| The nice declarations. No fixity declarations and function definitions are
    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 Access IsAbstract IsInstance ArgInfo 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'.)
  | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr)
  | PrimitiveFunction Range Access IsAbstract Name Expr
  | NiceMutual Range TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration]
  | NiceModule Range Access IsAbstract QName Telescope [Declaration]
  | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective
  | NiceOpen Range QName ImportDirective
  | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective
  | NicePragma Range Pragma
  | NiceRecSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] Expr
  | NiceDataSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] Expr
  | NiceFunClause Range Access IsAbstract TerminationCheck CoverageCheck 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 Access IsAbstract IsInstance IsMacro ArgInfo TerminationCheck CoverageCheck Name Expr
  | FunDef Range [Declaration] IsAbstract IsInstance TerminationCheck CoverageCheck 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'.
      --   Andreas, 2017-01-01: Because of issue #2372, we add 'IsInstance' here.
      --   An alias should know that it is an instance.
  | NiceDataDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [LamBinding] [NiceConstructor]
  | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name (Maybe (Ranged Induction)) (Maybe HasEta)
           (Maybe (Name, IsInstance)) [LamBinding] [Declaration]
  | NicePatternSyn Range Access Name [Arg Name] Pattern
  | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr
  | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr
  | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr
  deriving (Typeable NiceDeclaration
DataType
Constr
Typeable NiceDeclaration
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> NiceDeclaration -> c NiceDeclaration)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c NiceDeclaration)
-> (NiceDeclaration -> Constr)
-> (NiceDeclaration -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c NiceDeclaration))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c NiceDeclaration))
-> ((forall b. Data b => b -> b)
    -> NiceDeclaration -> NiceDeclaration)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> NiceDeclaration -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> NiceDeclaration -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> NiceDeclaration -> m NiceDeclaration)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> NiceDeclaration -> m NiceDeclaration)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> NiceDeclaration -> m NiceDeclaration)
-> Data NiceDeclaration
NiceDeclaration -> DataType
NiceDeclaration -> Constr
(forall b. Data b => b -> b) -> NiceDeclaration -> NiceDeclaration
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NiceDeclaration -> c NiceDeclaration
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NiceDeclaration
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> NiceDeclaration -> u
forall u. (forall d. Data d => d -> u) -> NiceDeclaration -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NiceDeclaration
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NiceDeclaration -> c NiceDeclaration
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NiceDeclaration)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NiceDeclaration)
$cNiceUnquoteDef :: Constr
$cNiceUnquoteDecl :: Constr
$cNiceGeneralize :: Constr
$cNicePatternSyn :: Constr
$cNiceRecDef :: Constr
$cNiceDataDef :: Constr
$cFunDef :: Constr
$cFunSig :: Constr
$cNiceFunClause :: Constr
$cNiceDataSig :: Constr
$cNiceRecSig :: Constr
$cNicePragma :: Constr
$cNiceImport :: Constr
$cNiceOpen :: Constr
$cNiceModuleMacro :: Constr
$cNiceModule :: Constr
$cNiceMutual :: Constr
$cPrimitiveFunction :: Constr
$cNiceField :: Constr
$cAxiom :: Constr
$tNiceDeclaration :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
gmapMp :: (forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
gmapM :: (forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NiceDeclaration -> m NiceDeclaration
gmapQi :: Int -> (forall d. Data d => d -> u) -> NiceDeclaration -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> NiceDeclaration -> u
gmapQ :: (forall d. Data d => d -> u) -> NiceDeclaration -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> NiceDeclaration -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NiceDeclaration -> r
gmapT :: (forall b. Data b => b -> b) -> NiceDeclaration -> NiceDeclaration
$cgmapT :: (forall b. Data b => b -> b) -> NiceDeclaration -> NiceDeclaration
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NiceDeclaration)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NiceDeclaration)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c NiceDeclaration)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NiceDeclaration)
dataTypeOf :: NiceDeclaration -> DataType
$cdataTypeOf :: NiceDeclaration -> DataType
toConstr :: NiceDeclaration -> Constr
$ctoConstr :: NiceDeclaration -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NiceDeclaration
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NiceDeclaration
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NiceDeclaration -> c NiceDeclaration
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NiceDeclaration -> c NiceDeclaration
$cp1Data :: Typeable NiceDeclaration
Data, Int -> NiceDeclaration -> ShowS
[NiceDeclaration] -> ShowS
NiceDeclaration -> String
(Int -> NiceDeclaration -> ShowS)
-> (NiceDeclaration -> String)
-> ([NiceDeclaration] -> ShowS)
-> Show NiceDeclaration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NiceDeclaration] -> ShowS
$cshowList :: [NiceDeclaration] -> ShowS
show :: NiceDeclaration -> String
$cshow :: NiceDeclaration -> String
showsPrec :: Int -> NiceDeclaration -> ShowS
$cshowsPrec :: Int -> NiceDeclaration -> ShowS
Show)

type TerminationCheck = Common.TerminationCheck Measure

-- | Termination measure is, for now, a variable name.
type Measure = Name

type Catchall = Bool

-- | Only 'Axiom's.
type NiceConstructor = NiceTypeSignature

-- | Only 'Axiom's.
type NiceTypeSignature  = NiceDeclaration

-- | One clause in a function definition. There is no guarantee that the 'LHS'
--   actually declares the 'Name'. We will have to check that later.
data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]
    deriving (Typeable Clause
DataType
Constr
Typeable Clause
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Clause -> c Clause)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Clause)
-> (Clause -> Constr)
-> (Clause -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Clause))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Clause))
-> ((forall b. Data b => b -> b) -> Clause -> Clause)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Clause -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Clause -> r)
-> (forall u. (forall d. Data d => d -> u) -> Clause -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Clause -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Clause -> m Clause)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Clause -> m Clause)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Clause -> m Clause)
-> Data Clause
Clause -> DataType
Clause -> Constr
(forall b. Data b => b -> b) -> Clause -> Clause
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Clause -> c Clause
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Clause
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Clause -> u
forall u. (forall d. Data d => d -> u) -> Clause -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Clause -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Clause -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Clause -> m Clause
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Clause -> m Clause
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Clause
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Clause -> c Clause
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Clause)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Clause)
$cClause :: Constr
$tClause :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Clause -> m Clause
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Clause -> m Clause
gmapMp :: (forall d. Data d => d -> m d) -> Clause -> m Clause
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Clause -> m Clause
gmapM :: (forall d. Data d => d -> m d) -> Clause -> m Clause
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Clause -> m Clause
gmapQi :: Int -> (forall d. Data d => d -> u) -> Clause -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Clause -> u
gmapQ :: (forall d. Data d => d -> u) -> Clause -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Clause -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Clause -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Clause -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Clause -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Clause -> r
gmapT :: (forall b. Data b => b -> b) -> Clause -> Clause
$cgmapT :: (forall b. Data b => b -> b) -> Clause -> Clause
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Clause)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Clause)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Clause)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Clause)
dataTypeOf :: Clause -> DataType
$cdataTypeOf :: Clause -> DataType
toConstr :: Clause -> Constr
$ctoConstr :: Clause -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Clause
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Clause
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Clause -> c Clause
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Clause -> c Clause
$cp1Data :: Typeable Clause
Data, Int -> Clause -> ShowS
[Clause] -> ShowS
Clause -> String
(Int -> Clause -> ShowS)
-> (Clause -> String) -> ([Clause] -> ShowS) -> Show Clause
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Clause] -> ShowS
$cshowList :: [Clause] -> ShowS
show :: Clause -> String
$cshow :: Clause -> String
showsPrec :: Int -> Clause -> ShowS
$cshowsPrec :: Int -> Clause -> ShowS
Show)

-- | The exception type.
data DeclarationException
        = MultipleEllipses Pattern
        | InvalidName Name
        | DuplicateDefinition Name
        | MissingWithClauses Name LHS
        | WrongDefinition Name DataRecOrFun DataRecOrFun
        | DeclarationPanic String
        | WrongContentBlock KindOfBlock Range
        | AmbiguousFunClauses LHS [Name] -- ^ in a mutual block, a clause could belong to any of the @[Name]@ type signatures
        | InvalidMeasureMutual Range
          -- ^ In a mutual block, all or none need a MEASURE pragma.
          --   Range is of mutual block.
        | UnquoteDefRequiresSignature [Name]
        | BadMacroDef NiceDeclaration
    deriving (Typeable DeclarationException
DataType
Constr
Typeable DeclarationException
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> DeclarationException
    -> c DeclarationException)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DeclarationException)
-> (DeclarationException -> Constr)
-> (DeclarationException -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DeclarationException))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DeclarationException))
-> ((forall b. Data b => b -> b)
    -> DeclarationException -> DeclarationException)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DeclarationException -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DeclarationException -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> DeclarationException -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DeclarationException -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> DeclarationException -> m DeclarationException)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DeclarationException -> m DeclarationException)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DeclarationException -> m DeclarationException)
-> Data DeclarationException
DeclarationException -> DataType
DeclarationException -> Constr
(forall b. Data b => b -> b)
-> DeclarationException -> DeclarationException
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationException
-> c DeclarationException
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationException
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> DeclarationException -> u
forall u.
(forall d. Data d => d -> u) -> DeclarationException -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationException -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationException -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationException
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationException
-> c DeclarationException
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeclarationException)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DeclarationException)
$cBadMacroDef :: Constr
$cUnquoteDefRequiresSignature :: Constr
$cInvalidMeasureMutual :: Constr
$cAmbiguousFunClauses :: Constr
$cWrongContentBlock :: Constr
$cDeclarationPanic :: Constr
$cWrongDefinition :: Constr
$cMissingWithClauses :: Constr
$cDuplicateDefinition :: Constr
$cInvalidName :: Constr
$cMultipleEllipses :: Constr
$tDeclarationException :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
gmapMp :: (forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
gmapM :: (forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DeclarationException -> m DeclarationException
gmapQi :: Int -> (forall d. Data d => d -> u) -> DeclarationException -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DeclarationException -> u
gmapQ :: (forall d. Data d => d -> u) -> DeclarationException -> [u]
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> DeclarationException -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationException -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationException -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationException -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationException -> r
gmapT :: (forall b. Data b => b -> b)
-> DeclarationException -> DeclarationException
$cgmapT :: (forall b. Data b => b -> b)
-> DeclarationException -> DeclarationException
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DeclarationException)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DeclarationException)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DeclarationException)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeclarationException)
dataTypeOf :: DeclarationException -> DataType
$cdataTypeOf :: DeclarationException -> DataType
toConstr :: DeclarationException -> Constr
$ctoConstr :: DeclarationException -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationException
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationException
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationException
-> c DeclarationException
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationException
-> c DeclarationException
$cp1Data :: Typeable DeclarationException
Data, Int -> DeclarationException -> ShowS
[DeclarationException] -> ShowS
DeclarationException -> String
(Int -> DeclarationException -> ShowS)
-> (DeclarationException -> String)
-> ([DeclarationException] -> ShowS)
-> Show DeclarationException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeclarationException] -> ShowS
$cshowList :: [DeclarationException] -> ShowS
show :: DeclarationException -> String
$cshow :: DeclarationException -> String
showsPrec :: Int -> DeclarationException -> ShowS
$cshowsPrec :: Int -> DeclarationException -> ShowS
Show)


-- | Non-fatal errors encountered in the Nicifier.
data DeclarationWarning
  -- Please keep in alphabetical order.
  = EmptyAbstract Range   -- ^ Empty @abstract@  block.
  | EmptyField Range      -- ^ Empty @field@     block.
  | EmptyGeneralize Range -- ^ Empty @variable@  block.
  | EmptyInstance Range   -- ^ Empty @instance@  block
  | EmptyMacro Range      -- ^ Empty @macro@     block.
  | EmptyMutual Range     -- ^ Empty @mutual@    block.
  | EmptyPostulate Range  -- ^ Empty @postulate@ block.
  | EmptyPrivate Range    -- ^ Empty @private@   block.
  | EmptyPrimitive Range  -- ^ Empty @primitive@ block.
  | InvalidCatchallPragma Range
      -- ^ A {-\# CATCHALL \#-} pragma
      --   that does not precede a function clause.
  | InvalidCoverageCheckPragma Range
      -- ^ A {-\# NON_COVERING \#-} pragma that does not apply to any function.
  | InvalidNoPositivityCheckPragma Range
      -- ^ A {-\# NO_POSITIVITY_CHECK \#-} pragma
      --   that does not apply to any data or record type.
  | InvalidNoUniverseCheckPragma Range
      -- ^ A {-\# NO_UNIVERSE_CHECK \#-} pragma
      --   that does not apply to a data or record type.
  | InvalidTerminationCheckPragma Range
      -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma
      --   that does not apply to any function.
  | MissingDefinitions [(Name, Range)]
      -- ^ Declarations (e.g. type signatures) without a definition.
  | NotAllowedInMutual Range String
  | OpenPublicPrivate Range
      -- ^ @private@ has no effect on @open public@.  (But the user might think so.)
  | OpenPublicAbstract Range
      -- ^ @abstract@ has no effect on @open public@.  (But the user might think so.)
  | PolarityPragmasButNotPostulates [Name]
  | PragmaNoTerminationCheck Range
  -- ^ Pragma @{-\# NO_TERMINATION_CHECK \#-}@ has been replaced
  --   by @{-\# TERMINATING \#-}@ and @{-\# NON_TERMINATING \#-}@.
  | PragmaCompiled Range
  -- ^ @COMPILE@ pragmas are not allowed in safe mode
  | ShadowingInTelescope [(Name, [Range])]
  | UnknownFixityInMixfixDecl [Name]
  | UnknownNamesInFixityDecl [Name]
  | UnknownNamesInPolarityPragmas [Name]
  | UselessAbstract Range
      -- ^ @abstract@ block with nothing that can (newly) be made abstract.
  | UselessInstance Range
      -- ^ @instance@ block with nothing that can (newly) become an instance.
  | UselessPrivate Range
      -- ^ @private@ block with nothing that can (newly) be made private.
  deriving (Typeable DeclarationWarning
DataType
Constr
Typeable DeclarationWarning
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> DeclarationWarning
    -> c DeclarationWarning)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DeclarationWarning)
-> (DeclarationWarning -> Constr)
-> (DeclarationWarning -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DeclarationWarning))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DeclarationWarning))
-> ((forall b. Data b => b -> b)
    -> DeclarationWarning -> DeclarationWarning)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> DeclarationWarning -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DeclarationWarning -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> DeclarationWarning -> m DeclarationWarning)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DeclarationWarning -> m DeclarationWarning)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DeclarationWarning -> m DeclarationWarning)
-> Data DeclarationWarning
DeclarationWarning -> DataType
DeclarationWarning -> Constr
(forall b. Data b => b -> b)
-> DeclarationWarning -> DeclarationWarning
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationWarning
-> c DeclarationWarning
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationWarning
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> DeclarationWarning -> u
forall u. (forall d. Data d => d -> u) -> DeclarationWarning -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationWarning
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationWarning
-> c DeclarationWarning
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeclarationWarning)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DeclarationWarning)
$cUselessPrivate :: Constr
$cUselessInstance :: Constr
$cUselessAbstract :: Constr
$cUnknownNamesInPolarityPragmas :: Constr
$cUnknownNamesInFixityDecl :: Constr
$cUnknownFixityInMixfixDecl :: Constr
$cShadowingInTelescope :: Constr
$cPragmaCompiled :: Constr
$cPragmaNoTerminationCheck :: Constr
$cPolarityPragmasButNotPostulates :: Constr
$cOpenPublicAbstract :: Constr
$cOpenPublicPrivate :: Constr
$cNotAllowedInMutual :: Constr
$cMissingDefinitions :: Constr
$cInvalidTerminationCheckPragma :: Constr
$cInvalidNoUniverseCheckPragma :: Constr
$cInvalidNoPositivityCheckPragma :: Constr
$cInvalidCoverageCheckPragma :: Constr
$cInvalidCatchallPragma :: Constr
$cEmptyPrimitive :: Constr
$cEmptyPrivate :: Constr
$cEmptyPostulate :: Constr
$cEmptyMutual :: Constr
$cEmptyMacro :: Constr
$cEmptyInstance :: Constr
$cEmptyGeneralize :: Constr
$cEmptyField :: Constr
$cEmptyAbstract :: Constr
$tDeclarationWarning :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
gmapMp :: (forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
gmapM :: (forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DeclarationWarning -> m DeclarationWarning
gmapQi :: Int -> (forall d. Data d => d -> u) -> DeclarationWarning -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DeclarationWarning -> u
gmapQ :: (forall d. Data d => d -> u) -> DeclarationWarning -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DeclarationWarning -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DeclarationWarning -> r
gmapT :: (forall b. Data b => b -> b)
-> DeclarationWarning -> DeclarationWarning
$cgmapT :: (forall b. Data b => b -> b)
-> DeclarationWarning -> DeclarationWarning
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DeclarationWarning)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DeclarationWarning)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DeclarationWarning)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DeclarationWarning)
dataTypeOf :: DeclarationWarning -> DataType
$cdataTypeOf :: DeclarationWarning -> DataType
toConstr :: DeclarationWarning -> Constr
$ctoConstr :: DeclarationWarning -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationWarning
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DeclarationWarning
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationWarning
-> c DeclarationWarning
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> DeclarationWarning
-> c DeclarationWarning
$cp1Data :: Typeable DeclarationWarning
Data, Int -> DeclarationWarning -> ShowS
[DeclarationWarning] -> ShowS
DeclarationWarning -> String
(Int -> DeclarationWarning -> ShowS)
-> (DeclarationWarning -> String)
-> ([DeclarationWarning] -> ShowS)
-> Show DeclarationWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeclarationWarning] -> ShowS
$cshowList :: [DeclarationWarning] -> ShowS
show :: DeclarationWarning -> String
$cshow :: DeclarationWarning -> String
showsPrec :: Int -> DeclarationWarning -> ShowS
$cshowsPrec :: Int -> DeclarationWarning -> ShowS
Show)

declarationWarningName :: DeclarationWarning -> WarningName
declarationWarningName :: DeclarationWarning -> WarningName
declarationWarningName = \case
  -- Please keep in alphabetical order.
  EmptyAbstract{}                   -> WarningName
EmptyAbstract_
  EmptyField{}                      -> WarningName
EmptyField_
  EmptyGeneralize{}                 -> WarningName
EmptyGeneralize_
  EmptyInstance{}                   -> WarningName
EmptyInstance_
  EmptyMacro{}                      -> WarningName
EmptyMacro_
  EmptyMutual{}                     -> WarningName
EmptyMutual_
  EmptyPrivate{}                    -> WarningName
EmptyPrivate_
  EmptyPostulate{}                  -> WarningName
EmptyPostulate_
  EmptyPrimitive{}                  -> WarningName
EmptyPrimitive_
  InvalidCatchallPragma{}           -> WarningName
InvalidCatchallPragma_
  InvalidNoPositivityCheckPragma{}  -> WarningName
InvalidNoPositivityCheckPragma_
  InvalidNoUniverseCheckPragma{}    -> WarningName
InvalidNoUniverseCheckPragma_
  InvalidTerminationCheckPragma{}   -> WarningName
InvalidTerminationCheckPragma_
  InvalidCoverageCheckPragma{}      -> WarningName
InvalidCoverageCheckPragma_
  MissingDefinitions{}              -> WarningName
MissingDefinitions_
  NotAllowedInMutual{}              -> WarningName
NotAllowedInMutual_
  OpenPublicPrivate{}               -> WarningName
OpenPublicPrivate_
  OpenPublicAbstract{}              -> WarningName
OpenPublicAbstract_
  PolarityPragmasButNotPostulates{} -> WarningName
PolarityPragmasButNotPostulates_
  PragmaNoTerminationCheck{}        -> WarningName
PragmaNoTerminationCheck_
  PragmaCompiled{}                  -> WarningName
PragmaCompiled_
  ShadowingInTelescope{}            -> WarningName
ShadowingInTelescope_
  UnknownFixityInMixfixDecl{}       -> WarningName
UnknownFixityInMixfixDecl_
  UnknownNamesInFixityDecl{}        -> WarningName
UnknownNamesInFixityDecl_
  UnknownNamesInPolarityPragmas{}   -> WarningName
UnknownNamesInPolarityPragmas_
  UselessAbstract{}                 -> WarningName
UselessAbstract_
  UselessInstance{}                 -> WarningName
UselessInstance_
  UselessPrivate{}                  -> WarningName
UselessPrivate_

-- | Nicifier warnings turned into errors in @--safe@ mode.
unsafeDeclarationWarning :: DeclarationWarning -> Bool
unsafeDeclarationWarning :: DeclarationWarning -> Bool
unsafeDeclarationWarning = \case
  -- Please keep in alphabetical order.
  EmptyAbstract{}                   -> Bool
False
  EmptyField{}                      -> Bool
False
  EmptyGeneralize{}                 -> Bool
False
  EmptyInstance{}                   -> Bool
False
  EmptyMacro{}                      -> Bool
False
  EmptyMutual{}                     -> Bool
False
  EmptyPrivate{}                    -> Bool
False
  EmptyPostulate{}                  -> Bool
False
  EmptyPrimitive{}                  -> Bool
False
  InvalidCatchallPragma{}           -> Bool
False
  InvalidNoPositivityCheckPragma{}  -> Bool
False
  InvalidNoUniverseCheckPragma{}    -> Bool
False
  InvalidTerminationCheckPragma{}   -> Bool
False
  InvalidCoverageCheckPragma{}      -> Bool
False
  MissingDefinitions{}              -> Bool
True  -- not safe
  NotAllowedInMutual{}              -> Bool
False -- really safe?
  OpenPublicPrivate{}               -> Bool
False
  OpenPublicAbstract{}              -> Bool
False
  PolarityPragmasButNotPostulates{} -> Bool
False
  PragmaNoTerminationCheck{}        -> Bool
True  -- not safe
  PragmaCompiled{}                  -> Bool
True  -- not safe
  ShadowingInTelescope{}            -> Bool
False
  UnknownFixityInMixfixDecl{}       -> Bool
False
  UnknownNamesInFixityDecl{}        -> Bool
False
  UnknownNamesInPolarityPragmas{}   -> Bool
False
  UselessAbstract{}                 -> Bool
False
  UselessInstance{}                 -> Bool
False
  UselessPrivate{}                  -> Bool
False

-- | Several declarations expect only type signatures as sub-declarations.  These are:
data KindOfBlock
  = PostulateBlock  -- ^ @postulate@
  | PrimitiveBlock  -- ^ @primitive@.  Ensured by parser.
  | InstanceBlock   -- ^ @instance@.  Actually, here all kinds of sub-declarations are allowed a priori.
  | FieldBlock      -- ^ @field@.  Ensured by parser.
  | DataBlock       -- ^ @data ... where@.  Here we got a bad error message for Agda-2.5 (Issue 1698).
  deriving (Typeable KindOfBlock
DataType
Constr
Typeable KindOfBlock
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> KindOfBlock -> c KindOfBlock)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c KindOfBlock)
-> (KindOfBlock -> Constr)
-> (KindOfBlock -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c KindOfBlock))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c KindOfBlock))
-> ((forall b. Data b => b -> b) -> KindOfBlock -> KindOfBlock)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r)
-> (forall u. (forall d. Data d => d -> u) -> KindOfBlock -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> KindOfBlock -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock)
-> Data KindOfBlock
KindOfBlock -> DataType
KindOfBlock -> Constr
(forall b. Data b => b -> b) -> KindOfBlock -> KindOfBlock
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KindOfBlock -> c KindOfBlock
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KindOfBlock
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> KindOfBlock -> u
forall u. (forall d. Data d => d -> u) -> KindOfBlock -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KindOfBlock
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KindOfBlock -> c KindOfBlock
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c KindOfBlock)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c KindOfBlock)
$cDataBlock :: Constr
$cFieldBlock :: Constr
$cInstanceBlock :: Constr
$cPrimitiveBlock :: Constr
$cPostulateBlock :: Constr
$tKindOfBlock :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
gmapMp :: (forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
gmapM :: (forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> KindOfBlock -> m KindOfBlock
gmapQi :: Int -> (forall d. Data d => d -> u) -> KindOfBlock -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> KindOfBlock -> u
gmapQ :: (forall d. Data d => d -> u) -> KindOfBlock -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> KindOfBlock -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> KindOfBlock -> r
gmapT :: (forall b. Data b => b -> b) -> KindOfBlock -> KindOfBlock
$cgmapT :: (forall b. Data b => b -> b) -> KindOfBlock -> KindOfBlock
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c KindOfBlock)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c KindOfBlock)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c KindOfBlock)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c KindOfBlock)
dataTypeOf :: KindOfBlock -> DataType
$cdataTypeOf :: KindOfBlock -> DataType
toConstr :: KindOfBlock -> Constr
$ctoConstr :: KindOfBlock -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KindOfBlock
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KindOfBlock
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KindOfBlock -> c KindOfBlock
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KindOfBlock -> c KindOfBlock
$cp1Data :: Typeable KindOfBlock
Data, KindOfBlock -> KindOfBlock -> Bool
(KindOfBlock -> KindOfBlock -> Bool)
-> (KindOfBlock -> KindOfBlock -> Bool) -> Eq KindOfBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KindOfBlock -> KindOfBlock -> Bool
$c/= :: KindOfBlock -> KindOfBlock -> Bool
== :: KindOfBlock -> KindOfBlock -> Bool
$c== :: KindOfBlock -> KindOfBlock -> Bool
Eq, Eq KindOfBlock
Eq KindOfBlock
-> (KindOfBlock -> KindOfBlock -> Ordering)
-> (KindOfBlock -> KindOfBlock -> Bool)
-> (KindOfBlock -> KindOfBlock -> Bool)
-> (KindOfBlock -> KindOfBlock -> Bool)
-> (KindOfBlock -> KindOfBlock -> Bool)
-> (KindOfBlock -> KindOfBlock -> KindOfBlock)
-> (KindOfBlock -> KindOfBlock -> KindOfBlock)
-> Ord KindOfBlock
KindOfBlock -> KindOfBlock -> Bool
KindOfBlock -> KindOfBlock -> Ordering
KindOfBlock -> KindOfBlock -> KindOfBlock
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KindOfBlock -> KindOfBlock -> KindOfBlock
$cmin :: KindOfBlock -> KindOfBlock -> KindOfBlock
max :: KindOfBlock -> KindOfBlock -> KindOfBlock
$cmax :: KindOfBlock -> KindOfBlock -> KindOfBlock
>= :: KindOfBlock -> KindOfBlock -> Bool
$c>= :: KindOfBlock -> KindOfBlock -> Bool
> :: KindOfBlock -> KindOfBlock -> Bool
$c> :: KindOfBlock -> KindOfBlock -> Bool
<= :: KindOfBlock -> KindOfBlock -> Bool
$c<= :: KindOfBlock -> KindOfBlock -> Bool
< :: KindOfBlock -> KindOfBlock -> Bool
$c< :: KindOfBlock -> KindOfBlock -> Bool
compare :: KindOfBlock -> KindOfBlock -> Ordering
$ccompare :: KindOfBlock -> KindOfBlock -> Ordering
$cp1Ord :: Eq KindOfBlock
Ord, Int -> KindOfBlock -> ShowS
[KindOfBlock] -> ShowS
KindOfBlock -> String
(Int -> KindOfBlock -> ShowS)
-> (KindOfBlock -> String)
-> ([KindOfBlock] -> ShowS)
-> Show KindOfBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KindOfBlock] -> ShowS
$cshowList :: [KindOfBlock] -> ShowS
show :: KindOfBlock -> String
$cshow :: KindOfBlock -> String
showsPrec :: Int -> KindOfBlock -> ShowS
$cshowsPrec :: Int -> KindOfBlock -> ShowS
Show)


instance HasRange DeclarationException where
  getRange :: DeclarationException -> Range
getRange (MultipleEllipses Pattern
d)                 = Pattern -> Range
forall t. HasRange t => t -> Range
getRange Pattern
d
  getRange (InvalidName Name
x)                      = Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x
  getRange (DuplicateDefinition Name
x)              = Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x
  getRange (MissingWithClauses Name
x LHS
lhs)           = LHS -> Range
forall t. HasRange t => t -> Range
getRange LHS
lhs
  getRange (WrongDefinition Name
x DataRecOrFun
k DataRecOrFun
k')             = Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x
  getRange (AmbiguousFunClauses LHS
lhs [Name]
xs)         = LHS -> Range
forall t. HasRange t => t -> Range
getRange LHS
lhs
  getRange (DeclarationPanic String
_)                 = Range
forall a. Range' a
noRange
  getRange (WrongContentBlock KindOfBlock
_ Range
r)              = Range
r
  getRange (InvalidMeasureMutual Range
r)             = Range
r
  getRange (UnquoteDefRequiresSignature [Name]
x)      = [Name] -> Range
forall t. HasRange t => t -> Range
getRange [Name]
x
  getRange (BadMacroDef NiceDeclaration
d)                      = NiceDeclaration -> Range
forall t. HasRange t => t -> Range
getRange NiceDeclaration
d

instance HasRange DeclarationWarning where
  getRange :: DeclarationWarning -> Range
getRange (UnknownNamesInFixityDecl [Name]
xs)        = [Name] -> Range
forall t. HasRange t => t -> Range
getRange [Name]
xs
  getRange (UnknownFixityInMixfixDecl [Name]
xs)       = [Name] -> Range
forall t. HasRange t => t -> Range
getRange [Name]
xs
  getRange (UnknownNamesInPolarityPragmas [Name]
xs)   = [Name] -> Range
forall t. HasRange t => t -> Range
getRange [Name]
xs
  getRange (PolarityPragmasButNotPostulates [Name]
xs) = [Name] -> Range
forall t. HasRange t => t -> Range
getRange [Name]
xs
  getRange (MissingDefinitions [(Name, Range)]
xs)              = [(Name, Range)] -> Range
forall t. HasRange t => t -> Range
getRange [(Name, Range)]
xs
  getRange (UselessPrivate Range
r)                   = Range
r
  getRange (NotAllowedInMutual Range
r String
x)             = Range
r
  getRange (UselessAbstract Range
r)                  = Range
r
  getRange (UselessInstance Range
r)                  = Range
r
  getRange (EmptyMutual Range
r)                      = Range
r
  getRange (EmptyAbstract Range
r)                    = Range
r
  getRange (EmptyPrivate Range
r)                     = Range
r
  getRange (EmptyInstance Range
r)                    = Range
r
  getRange (EmptyMacro Range
r)                       = Range
r
  getRange (EmptyPostulate Range
r)                   = Range
r
  getRange (EmptyGeneralize Range
r)                  = Range
r
  getRange (EmptyPrimitive Range
r)                   = Range
r
  getRange (EmptyField Range
r)                       = Range
r
  getRange (InvalidTerminationCheckPragma Range
r)    = Range
r
  getRange (InvalidCoverageCheckPragma Range
r)       = Range
r
  getRange (InvalidNoPositivityCheckPragma Range
r)   = Range
r
  getRange (InvalidCatchallPragma Range
r)            = Range
r
  getRange (InvalidNoUniverseCheckPragma Range
r)     = Range
r
  getRange (PragmaNoTerminationCheck Range
r)         = Range
r
  getRange (PragmaCompiled Range
r)                   = Range
r
  getRange (OpenPublicAbstract Range
r)               = Range
r
  getRange (OpenPublicPrivate Range
r)                = Range
r
  getRange (ShadowingInTelescope [(Name, [Range])]
ns)            = [(Name, [Range])] -> Range
forall t. HasRange t => t -> Range
getRange [(Name, [Range])]
ns

instance HasRange NiceDeclaration where
  getRange :: NiceDeclaration -> Range
getRange (Axiom Range
r Access
_ IsAbstract
_ IsInstance
_ ArgInfo
_ Name
_ Expr
_)           = Range
r
  getRange (NiceField Range
r Access
_ IsAbstract
_ IsInstance
_ TacticAttribute
_ Name
_ Arg Expr
_)       = Range
r
  getRange (NiceMutual Range
r TerminationCheck
_ CoverageCheck
_ PositivityCheck
_ [NiceDeclaration]
_)          = Range
r
  getRange (NiceModule Range
r Access
_ IsAbstract
_ QName
_ Telescope
_ [Declaration]
_ )       = Range
r
  getRange (NiceModuleMacro Range
r Access
_ Name
_ ModuleApplication
_ OpenShortHand
_ ImportDirective
_)   = Range
r
  getRange (NiceOpen Range
r QName
_ ImportDirective
_)                = Range
r
  getRange (NiceImport Range
r QName
_ Maybe AsName
_ OpenShortHand
_ ImportDirective
_)          = Range
r
  getRange (NicePragma Range
r Pragma
_)                = Range
r
  getRange (PrimitiveFunction Range
r Access
_ IsAbstract
_ Name
_ Expr
_)   = Range
r
  getRange (FunSig Range
r Access
_ IsAbstract
_ IsInstance
_ IsMacro
_ ArgInfo
_ TerminationCheck
_ CoverageCheck
_ Name
_ Expr
_)    = Range
r
  getRange (FunDef Range
r [Declaration]
_ IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_ [Clause]
_)        = Range
r
  getRange (NiceDataDef Range
r Origin
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
_ [LamBinding]
_ [NiceDeclaration]
_)   = Range
r
  getRange (NiceRecDef Range
r Origin
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
_ Maybe (Ranged Induction)
_ Maybe HasEta
_ Maybe (Name, IsInstance)
_ [LamBinding]
_ [Declaration]
_)  = Range
r
  getRange (NiceRecSig Range
r Access
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
_ [LamBinding]
_ Expr
_)    = Range
r
  getRange (NiceDataSig Range
r Access
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
_ [LamBinding]
_ Expr
_)   = Range
r
  getRange (NicePatternSyn Range
r Access
_ Name
_ [Arg Name]
_ Pattern
_)      = Range
r
  getRange (NiceGeneralize Range
r Access
_ ArgInfo
_ TacticAttribute
_ Name
_ Expr
_)    = Range
r
  getRange (NiceFunClause Range
r Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ Bool
_ Declaration
_)   = Range
r
  getRange (NiceUnquoteDecl Range
r Access
_ IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
_ [Name]
_ Expr
_) = Range
r
  getRange (NiceUnquoteDef Range
r Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ [Name]
_ Expr
_)    = Range
r

instance Pretty NiceDeclaration where
  pretty :: NiceDeclaration -> Doc
pretty = \case
    Axiom Range
_ Access
_ IsAbstract
_ IsInstance
_ ArgInfo
_ Name
x Expr
_            -> String -> Doc
text String
"postulate" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text String
"_"
    NiceField Range
_ Access
_ IsAbstract
_ IsInstance
_ TacticAttribute
_ Name
x Arg Expr
_        -> String -> Doc
text String
"field" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
    PrimitiveFunction Range
_ Access
_ IsAbstract
_ Name
x Expr
_    -> String -> Doc
text String
"primitive" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
    NiceMutual{}                   -> String -> Doc
text String
"mutual"
    NiceModule Range
_ Access
_ IsAbstract
_ QName
x Telescope
_ [Declaration]
_         -> String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
    NiceModuleMacro Range
_ Access
_ Name
x ModuleApplication
_ OpenShortHand
_ ImportDirective
_    -> String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"= ..."
    NiceOpen Range
_ QName
x ImportDirective
_                 -> String -> Doc
text String
"open" Doc -> Doc -> Doc
<+> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x
    NiceImport Range
_ QName
x Maybe AsName
_ OpenShortHand
_ ImportDirective
_           -> String -> Doc
text String
"import" Doc -> Doc -> Doc
<+> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x
    NicePragma{}                   -> String -> Doc
text String
"{-# ... #-}"
    NiceRecSig Range
_ Access
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
_ Expr
_     -> String -> Doc
text String
"record" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
    NiceDataSig Range
_ Access
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
_ Expr
_    -> String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
    NiceFunClause{}                -> String -> Doc
text String
"<function clause>"
    FunSig Range
_ Access
_ IsAbstract
_ IsInstance
_ IsMacro
_ ArgInfo
_ TerminationCheck
_ CoverageCheck
_ Name
x Expr
_     -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> String -> Doc
text String
"_"
    FunDef Range
_ [Declaration]
_ IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
x [Clause]
_         -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"= _"
    NiceDataDef Range
_ Origin
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
_ [NiceDeclaration]
_    -> String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
    NiceRecDef Range
_ Origin
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x Maybe (Ranged Induction)
_ Maybe HasEta
_ Maybe (Name, IsInstance)
_ [LamBinding]
_ [Declaration]
_   -> String -> Doc
text String
"record" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
    NicePatternSyn Range
_ Access
_ Name
x [Arg Name]
_ Pattern
_       -> String -> Doc
text String
"pattern" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
    NiceGeneralize Range
_ Access
_ ArgInfo
_ TacticAttribute
_ Name
x Expr
_     -> String -> Doc
text String
"variable" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
    NiceUnquoteDecl Range
_ Access
_ IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
_ [Name]
xs Expr
_ -> String -> Doc
text String
"<unquote declarations>"
    NiceUnquoteDef Range
_ Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ [Name]
xs Expr
_    -> String -> Doc
text String
"<unquote definitions>"

-- These error messages can (should) be terminated by a dot ".",
-- there is no error context printed after them.
instance Pretty DeclarationException where
  pretty :: DeclarationException -> Doc
pretty (MultipleEllipses Pattern
p) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Multiple ellipses in left-hand side" [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Pattern -> Doc
forall a. Pretty a => a -> Doc
pretty Pattern
p]
  pretty (InvalidName Name
x) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Invalid name:" [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x]
  pretty (DuplicateDefinition Name
x) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Duplicate definition of" [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x]
  pretty (MissingWithClauses Name
x LHS
lhs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Missing with-clauses for function" [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x]

  pretty (WrongDefinition Name
x DataRecOrFun
k DataRecOrFun
k') = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
    String -> [Doc]
pwords (String
"has been declared as a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DataRecOrFun -> String
forall a. Show a => a -> String
show DataRecOrFun
k String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
", but is being defined as a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DataRecOrFun -> String
forall a. Show a => a -> String
show DataRecOrFun
k')
  pretty (AmbiguousFunClauses LHS
lhs [Name]
xs) = [Doc] -> Doc
sep
    [ [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
        String -> [Doc]
pwords String
"More than one matching type signature for left hand side " [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [LHS -> Doc
forall a. Pretty a => a -> Doc
pretty LHS
lhs] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
        String -> [Doc]
pwords String
"it could belong to any of:"
    , [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrintRange Name -> Doc
forall a. Pretty a => a -> Doc
pretty (PrintRange Name -> Doc)
-> (Name -> PrintRange Name) -> Name -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PrintRange Name
forall a. a -> PrintRange a
PrintRange) [Name]
xs
    ]
  pretty (WrongContentBlock KindOfBlock
b Range
_)      = [Doc] -> Doc
fsep ([Doc] -> Doc) -> (String -> [Doc]) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Doc]
pwords (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
    case KindOfBlock
b of
      KindOfBlock
PostulateBlock -> String
"A postulate block can only contain type signatures, possibly under keyword instance"
      KindOfBlock
DataBlock -> String
"A data definition can only contain type signatures, possibly under keyword instance"
      KindOfBlock
_ -> String
"Unexpected declaration"
  pretty (InvalidMeasureMutual Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"In a mutual block, either all functions must have the same (or no) termination checking pragma."
  pretty (UnquoteDefRequiresSignature [Name]
xs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Missing type signatures for unquoteDef" [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
xs
  pretty (BadMacroDef NiceDeclaration
nd) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    [String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ NiceDeclaration -> String
declName NiceDeclaration
nd] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ String -> [Doc]
pwords String
"are not allowed in macro blocks"
  pretty (DeclarationPanic String
s) = String -> Doc
text String
s

instance Pretty DeclarationWarning where
  pretty :: DeclarationWarning -> Doc
pretty (UnknownNamesInFixityDecl [Name]
xs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"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):"
    [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
xs)
  pretty (UnknownFixityInMixfixDecl [Name]
xs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"The following mixfix names do not have an associated fixity declaration:"
    [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
xs)
  pretty (UnknownNamesInPolarityPragmas [Name]
xs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"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):"
    [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ Doc -> [Doc] -> [Doc]
punctuate Doc
comma  ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
xs)
  pretty (MissingDefinitions [(Name, Range)]
xs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
   String -> [Doc]
pwords String
"The following names are declared but not accompanied by a definition:"
   [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ Doc -> [Doc] -> [Doc]
punctuate Doc
comma (((Name, Range) -> Doc) -> [(Name, Range)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Doc
forall a. Pretty a => a -> Doc
pretty (Name -> Doc) -> ((Name, Range) -> Name) -> (Name, Range) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Range) -> Name
forall a b. (a, b) -> a
fst) [(Name, Range)]
xs)
  pretty (NotAllowedInMutual Range
r String
nd) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    [String -> Doc
text String
nd] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ String -> [Doc]
pwords String
"in mutual blocks are not supported.  Suggestion: get rid of the mutual block by manually ordering declarations"
  pretty (PolarityPragmasButNotPostulates [Name]
xs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Polarity pragmas have been given for the following identifiers which are not postulates:"
    [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
xs)
  pretty (UselessPrivate Range
_)      = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"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 Range
_)      = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Using abstract here has no effect. Abstract applies to only definitions like data definitions, record type definitions and function clauses."
  pretty (UselessInstance Range
_)      = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."
  pretty (EmptyMutual    Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty mutual block."
  pretty (EmptyAbstract  Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty abstract block."
  pretty (EmptyPrivate   Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty private block."
  pretty (EmptyInstance  Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty instance block."
  pretty (EmptyMacro     Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty macro block."
  pretty (EmptyPostulate Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty postulate block."
  pretty (EmptyGeneralize Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty variable block."
  pretty (EmptyPrimitive Range
_)  = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty primitive block."
  pretty (EmptyField Range
_)      = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [Doc]
pwords String
"Empty field block."
  pretty (InvalidTerminationCheckPragma Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."
  pretty (InvalidCoverageCheckPragma Range
_)    = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Coverage checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."
  pretty (InvalidNoPositivityCheckPragma Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"NO_POSITIVITY_CHECKING pragmas can only precede a data/record definition or a mutual block (that contains a data/record definition)."
  pretty (InvalidCatchallPragma Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"The CATCHALL pragma can only precede a function clause."
  pretty (InvalidNoUniverseCheckPragma Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"NO_UNIVERSE_CHECKING pragmas can only precede a data/record definition."
  pretty (PragmaNoTerminationCheck Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Pragma {-# NO_TERMINATION_CHECK #-} has been removed.  To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."
  pretty (PragmaCompiled Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"COMPILE pragma not allowed in safe mode."
  pretty (OpenPublicAbstract Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"public does not have any effect in an abstract block."
  pretty (OpenPublicPrivate Range
_) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"public does not have any effect in a private block."
  pretty (ShadowingInTelescope [(Name, [Range])]
nrs) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> [Doc]
pwords String
"Shadowing in telescope, repeated variable names:"
    [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ Doc -> [Doc] -> [Doc]
punctuate Doc
comma (((Name, [Range]) -> Doc) -> [(Name, [Range])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Doc
forall a. Pretty a => a -> Doc
pretty (Name -> Doc)
-> ((Name, [Range]) -> Name) -> (Name, [Range]) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Range]) -> Name
forall a b. (a, b) -> a
fst) [(Name, [Range])]
nrs)

declName :: NiceDeclaration -> String
declName :: NiceDeclaration -> String
declName Axiom{}             = String
"Postulates"
declName NiceField{}         = String
"Fields"
declName NiceMutual{}        = String
"Mutual blocks"
declName NiceModule{}        = String
"Modules"
declName NiceModuleMacro{}   = String
"Modules"
declName NiceOpen{}          = String
"Open declarations"
declName NiceImport{}        = String
"Import statements"
declName NicePragma{}        = String
"Pragmas"
declName PrimitiveFunction{} = String
"Primitive declarations"
declName NicePatternSyn{}    = String
"Pattern synonyms"
declName NiceGeneralize{}    = String
"Generalized variables"
declName NiceUnquoteDecl{}   = String
"Unquoted declarations"
declName NiceUnquoteDef{}    = String
"Unquoted definitions"
declName NiceRecSig{}        = String
"Records"
declName NiceDataSig{}       = String
"Data types"
declName NiceFunClause{}     = String
"Functions without a type signature"
declName FunSig{}            = String
"Type signatures"
declName FunDef{}            = String
"Function definitions"
declName NiceRecDef{}            = String
"Records"
declName NiceDataDef{}       = String
"Data types"

{--------------------------------------------------------------------------
    The niceifier
 --------------------------------------------------------------------------}

data InMutual
  = InMutual    -- ^ we are nicifying a mutual block
  | NotInMutual -- ^ we are nicifying decls not in a mutual block
    deriving (InMutual -> InMutual -> Bool
(InMutual -> InMutual -> Bool)
-> (InMutual -> InMutual -> Bool) -> Eq InMutual
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InMutual -> InMutual -> Bool
$c/= :: InMutual -> InMutual -> Bool
== :: InMutual -> InMutual -> Bool
$c== :: InMutual -> InMutual -> Bool
Eq, Int -> InMutual -> ShowS
[InMutual] -> ShowS
InMutual -> String
(Int -> InMutual -> ShowS)
-> (InMutual -> String) -> ([InMutual] -> ShowS) -> Show InMutual
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InMutual] -> ShowS
$cshowList :: [InMutual] -> ShowS
show :: InMutual -> String
$cshow :: InMutual -> String
showsPrec :: Int -> InMutual -> ShowS
$cshowsPrec :: Int -> InMutual -> ShowS
Show)

-- | The kind of the forward declaration.

data DataRecOrFun
  = DataName
    { DataRecOrFun -> PositivityCheck
_kindPosCheck :: PositivityCheck
    , DataRecOrFun -> UniverseCheck
_kindUniCheck :: UniverseCheck
    }
    -- ^ Name of a data type
  | RecName
    { _kindPosCheck :: PositivityCheck
    , _kindUniCheck :: UniverseCheck
    }
    -- ^ Name of a record type
  | FunName TerminationCheck CoverageCheck
    -- ^ Name of a function.
  deriving Typeable DataRecOrFun
DataType
Constr
Typeable DataRecOrFun
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> DataRecOrFun -> c DataRecOrFun)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DataRecOrFun)
-> (DataRecOrFun -> Constr)
-> (DataRecOrFun -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DataRecOrFun))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DataRecOrFun))
-> ((forall b. Data b => b -> b) -> DataRecOrFun -> DataRecOrFun)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r)
-> (forall u. (forall d. Data d => d -> u) -> DataRecOrFun -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DataRecOrFun -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun)
-> Data DataRecOrFun
DataRecOrFun -> DataType
DataRecOrFun -> Constr
(forall b. Data b => b -> b) -> DataRecOrFun -> DataRecOrFun
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DataRecOrFun -> c DataRecOrFun
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DataRecOrFun
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DataRecOrFun -> u
forall u. (forall d. Data d => d -> u) -> DataRecOrFun -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DataRecOrFun
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DataRecOrFun -> c DataRecOrFun
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DataRecOrFun)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DataRecOrFun)
$cFunName :: Constr
$cRecName :: Constr
$cDataName :: Constr
$tDataRecOrFun :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
gmapMp :: (forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
gmapM :: (forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DataRecOrFun -> m DataRecOrFun
gmapQi :: Int -> (forall d. Data d => d -> u) -> DataRecOrFun -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DataRecOrFun -> u
gmapQ :: (forall d. Data d => d -> u) -> DataRecOrFun -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DataRecOrFun -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DataRecOrFun -> r
gmapT :: (forall b. Data b => b -> b) -> DataRecOrFun -> DataRecOrFun
$cgmapT :: (forall b. Data b => b -> b) -> DataRecOrFun -> DataRecOrFun
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DataRecOrFun)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DataRecOrFun)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DataRecOrFun)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DataRecOrFun)
dataTypeOf :: DataRecOrFun -> DataType
$cdataTypeOf :: DataRecOrFun -> DataType
toConstr :: DataRecOrFun -> Constr
$ctoConstr :: DataRecOrFun -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DataRecOrFun
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DataRecOrFun
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DataRecOrFun -> c DataRecOrFun
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DataRecOrFun -> c DataRecOrFun
$cp1Data :: Typeable DataRecOrFun
Data

-- Ignore pragmas when checking equality
instance Eq DataRecOrFun where
  DataName{} == :: DataRecOrFun -> DataRecOrFun -> Bool
== DataName{} = Bool
True
  RecName{}  == RecName{}  = Bool
True
  FunName{}  == FunName{}  = Bool
True
  DataRecOrFun
_          == DataRecOrFun
_          = Bool
False

instance Show DataRecOrFun where
  show :: DataRecOrFun -> String
show DataName{} = String
"data type"
  show RecName{}  = String
"record type"
  show FunName{}  = String
"function"

isFunName :: DataRecOrFun -> Bool
isFunName :: DataRecOrFun -> Bool
isFunName (FunName{}) = Bool
True
isFunName DataRecOrFun
_           = Bool
False

sameKind :: DataRecOrFun -> DataRecOrFun -> Bool
sameKind :: DataRecOrFun -> DataRecOrFun -> Bool
sameKind = DataRecOrFun -> DataRecOrFun -> Bool
forall a. Eq a => a -> a -> Bool
(==)

terminationCheck :: DataRecOrFun -> TerminationCheck
terminationCheck :: DataRecOrFun -> TerminationCheck
terminationCheck (FunName TerminationCheck
tc CoverageCheck
_) = TerminationCheck
tc
terminationCheck DataRecOrFun
_ = TerminationCheck
forall m. TerminationCheck m
TerminationCheck

coverageCheck :: DataRecOrFun -> CoverageCheck
coverageCheck :: DataRecOrFun -> CoverageCheck
coverageCheck (FunName TerminationCheck
_ CoverageCheck
cc) = CoverageCheck
cc
coverageCheck DataRecOrFun
_ = CoverageCheck
YesCoverageCheck

positivityCheck :: DataRecOrFun -> PositivityCheck
positivityCheck :: DataRecOrFun -> PositivityCheck
positivityCheck (DataName PositivityCheck
pc UniverseCheck
_) = PositivityCheck
pc
positivityCheck (RecName PositivityCheck
pc UniverseCheck
_)  = PositivityCheck
pc
positivityCheck DataRecOrFun
_               = PositivityCheck
YesPositivityCheck

universeCheck :: DataRecOrFun -> UniverseCheck
universeCheck :: DataRecOrFun -> UniverseCheck
universeCheck (DataName PositivityCheck
_ UniverseCheck
uc) = UniverseCheck
uc
universeCheck (RecName PositivityCheck
_ UniverseCheck
uc)  = UniverseCheck
uc
universeCheck DataRecOrFun
_               = UniverseCheck
YesUniverseCheck

-- | Check that declarations in a mutual block are consistently
--   equipped with MEASURE pragmas, or whether there is a
--   NO_TERMINATION_CHECK pragma.
combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck
combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck
combineTerminationChecks Range
r [TerminationCheck]
tcs = [TerminationCheck] -> Nice TerminationCheck
loop [TerminationCheck]
tcs where
  loop :: [TerminationCheck] -> Nice TerminationCheck
  loop :: [TerminationCheck] -> Nice TerminationCheck
loop []         = TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
forall m. TerminationCheck m
TerminationCheck
  loop (TerminationCheck
tc : [TerminationCheck]
tcs) = do
    let failure :: Range -> m a
failure Range
r = DeclarationException -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> m a) -> DeclarationException -> m a
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationException
InvalidMeasureMutual Range
r
    TerminationCheck
tc' <- [TerminationCheck] -> Nice TerminationCheck
loop [TerminationCheck]
tcs
    case (TerminationCheck
tc, TerminationCheck
tc') of
      (TerminationCheck
TerminationCheck      , TerminationCheck
tc'                   ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
tc'
      (TerminationCheck
tc                    , TerminationCheck
TerminationCheck      ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
tc
      (TerminationCheck
NonTerminating        , TerminationCheck
NonTerminating        ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
forall m. TerminationCheck m
NonTerminating
      (TerminationCheck
NoTerminationCheck    , TerminationCheck
NoTerminationCheck    ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
forall m. TerminationCheck m
NoTerminationCheck
      (TerminationCheck
NoTerminationCheck    , TerminationCheck
Terminating           ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
forall m. TerminationCheck m
Terminating
      (TerminationCheck
Terminating           , TerminationCheck
NoTerminationCheck    ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
forall m. TerminationCheck m
Terminating
      (TerminationCheck
Terminating           , TerminationCheck
Terminating           ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
forall m. TerminationCheck m
Terminating
      (TerminationMeasure{}  , TerminationMeasure{}  ) -> TerminationCheck -> Nice TerminationCheck
forall (m :: * -> *) a. Monad m => a -> m a
return TerminationCheck
tc
      (TerminationMeasure Range
r Name
_, TerminationCheck
NoTerminationCheck    ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationMeasure Range
r Name
_, TerminationCheck
Terminating           ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
NoTerminationCheck    , TerminationMeasure Range
r Name
_) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
Terminating           , TerminationMeasure Range
r Name
_) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationMeasure Range
r Name
_, TerminationCheck
NonTerminating        ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
NonTerminating        , TerminationMeasure Range
r Name
_) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
NoTerminationCheck    , TerminationCheck
NonTerminating        ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
Terminating           , TerminationCheck
NonTerminating        ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
NonTerminating        , TerminationCheck
NoTerminationCheck    ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r
      (TerminationCheck
NonTerminating        , TerminationCheck
Terminating           ) -> Range -> Nice TerminationCheck
forall (m :: * -> *) a.
MonadError DeclarationException m =>
Range -> m a
failure Range
r

combineCoverageChecks :: [CoverageCheck] -> CoverageCheck
combineCoverageChecks :: [CoverageCheck] -> CoverageCheck
combineCoverageChecks = [CoverageCheck] -> CoverageCheck
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Fold.fold

combinePositivityChecks :: [PositivityCheck] -> PositivityCheck
combinePositivityChecks :: [PositivityCheck] -> PositivityCheck
combinePositivityChecks = [PositivityCheck] -> PositivityCheck
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Fold.fold

-- | Nicifier monad.
--   Preserve the state when throwing an exception.

newtype Nice a = Nice { Nice a -> ExceptT DeclarationException (State NiceEnv) a
unNice :: ExceptT DeclarationException (State NiceEnv) a }
  deriving ( a -> Nice b -> Nice a
(a -> b) -> Nice a -> Nice b
(forall a b. (a -> b) -> Nice a -> Nice b)
-> (forall a b. a -> Nice b -> Nice a) -> Functor Nice
forall a b. a -> Nice b -> Nice a
forall a b. (a -> b) -> Nice a -> Nice b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Nice b -> Nice a
$c<$ :: forall a b. a -> Nice b -> Nice a
fmap :: (a -> b) -> Nice a -> Nice b
$cfmap :: forall a b. (a -> b) -> Nice a -> Nice b
Functor, Functor Nice
a -> Nice a
Functor Nice
-> (forall a. a -> Nice a)
-> (forall a b. Nice (a -> b) -> Nice a -> Nice b)
-> (forall a b c. (a -> b -> c) -> Nice a -> Nice b -> Nice c)
-> (forall a b. Nice a -> Nice b -> Nice b)
-> (forall a b. Nice a -> Nice b -> Nice a)
-> Applicative Nice
Nice a -> Nice b -> Nice b
Nice a -> Nice b -> Nice a
Nice (a -> b) -> Nice a -> Nice b
(a -> b -> c) -> Nice a -> Nice b -> Nice c
forall a. a -> Nice a
forall a b. Nice a -> Nice b -> Nice a
forall a b. Nice a -> Nice b -> Nice b
forall a b. Nice (a -> b) -> Nice a -> Nice b
forall a b c. (a -> b -> c) -> Nice a -> Nice b -> Nice c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Nice a -> Nice b -> Nice a
$c<* :: forall a b. Nice a -> Nice b -> Nice a
*> :: Nice a -> Nice b -> Nice b
$c*> :: forall a b. Nice a -> Nice b -> Nice b
liftA2 :: (a -> b -> c) -> Nice a -> Nice b -> Nice c
$cliftA2 :: forall a b c. (a -> b -> c) -> Nice a -> Nice b -> Nice c
<*> :: Nice (a -> b) -> Nice a -> Nice b
$c<*> :: forall a b. Nice (a -> b) -> Nice a -> Nice b
pure :: a -> Nice a
$cpure :: forall a. a -> Nice a
$cp1Applicative :: Functor Nice
Applicative, Applicative Nice
a -> Nice a
Applicative Nice
-> (forall a b. Nice a -> (a -> Nice b) -> Nice b)
-> (forall a b. Nice a -> Nice b -> Nice b)
-> (forall a. a -> Nice a)
-> Monad Nice
Nice a -> (a -> Nice b) -> Nice b
Nice a -> Nice b -> Nice b
forall a. a -> Nice a
forall a b. Nice a -> Nice b -> Nice b
forall a b. Nice a -> (a -> Nice b) -> Nice b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Nice a
$creturn :: forall a. a -> Nice a
>> :: Nice a -> Nice b -> Nice b
$c>> :: forall a b. Nice a -> Nice b -> Nice b
>>= :: Nice a -> (a -> Nice b) -> Nice b
$c>>= :: forall a b. Nice a -> (a -> Nice b) -> Nice b
$cp1Monad :: Applicative Nice
Monad
           , MonadState NiceEnv, MonadError DeclarationException
           )

-- | Run a Nicifier computation, return result and warnings
--   (in chronological order).
runNice :: Nice a -> (Either DeclarationException a, NiceWarnings)
runNice :: Nice a -> (Either DeclarationException a, [DeclarationWarning])
runNice Nice a
m = (NiceEnv -> [DeclarationWarning])
-> (Either DeclarationException a, NiceEnv)
-> (Either DeclarationException a, [DeclarationWarning])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([DeclarationWarning] -> [DeclarationWarning]
forall a. [a] -> [a]
reverse ([DeclarationWarning] -> [DeclarationWarning])
-> (NiceEnv -> [DeclarationWarning])
-> NiceEnv
-> [DeclarationWarning]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NiceEnv -> [DeclarationWarning]
niceWarn) ((Either DeclarationException a, NiceEnv)
 -> (Either DeclarationException a, [DeclarationWarning]))
-> (Either DeclarationException a, NiceEnv)
-> (Either DeclarationException a, [DeclarationWarning])
forall a b. (a -> b) -> a -> b
$
  ExceptT DeclarationException (State NiceEnv) a
-> State NiceEnv (Either DeclarationException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Nice a -> ExceptT DeclarationException (State NiceEnv) a
forall a. Nice a -> ExceptT DeclarationException (State NiceEnv) a
unNice Nice a
m) State NiceEnv (Either DeclarationException a)
-> NiceEnv -> (Either DeclarationException a, NiceEnv)
forall s a. State s a -> s -> (a, s)
`runState` NiceEnv
initNiceEnv

-- | Nicifier state.

data NiceEnv = NiceEnv
  { NiceEnv -> LoneSigs
_loneSigs :: LoneSigs
    -- ^ Lone type signatures that wait for their definition.
  , NiceEnv -> TerminationCheck
_termChk  :: TerminationCheck
    -- ^ Termination checking pragma waiting for a definition.
  , NiceEnv -> PositivityCheck
_posChk   :: PositivityCheck
    -- ^ Positivity checking pragma waiting for a definition.
  , NiceEnv -> UniverseCheck
_uniChk   :: UniverseCheck
    -- ^ Universe checking pragma waiting for a data/rec signature or definition.
  , NiceEnv -> Bool
_catchall :: Catchall
    -- ^ Catchall pragma waiting for a function clause.
  , NiceEnv -> CoverageCheck
_covChk  :: CoverageCheck
    -- ^ Coverage pragma waiting for a definition.
  , NiceEnv -> [DeclarationWarning]
niceWarn :: NiceWarnings
    -- ^ Stack of warnings. Head is last warning.
  }

data LoneSig = LoneSig
  { LoneSig -> Range
loneSigRange :: Range
  , LoneSig -> Name
loneSigName  :: Name
  , LoneSig -> DataRecOrFun
loneSigKind  :: DataRecOrFun
  }

type LoneSigs     = Map Name LoneSig
     -- ^ We retain the 'Name' also in the codomain since
     --   'Name' as a key is up to @Eq Name@ which ignores the range.
     --   However, without range names are not unique in case the
     --   user gives a second definition of the same name.
     --   This causes then problems in 'replaceSigs' which might
     --   replace the wrong signature.
type NiceWarnings = [DeclarationWarning]
     -- ^ Stack of warnings. Head is last warning.

-- | Initial nicifier state.

initNiceEnv :: NiceEnv
initNiceEnv :: NiceEnv
initNiceEnv = NiceEnv :: LoneSigs
-> TerminationCheck
-> PositivityCheck
-> UniverseCheck
-> Bool
-> CoverageCheck
-> [DeclarationWarning]
-> NiceEnv
NiceEnv
  { _loneSigs :: LoneSigs
_loneSigs = LoneSigs
forall a. Null a => a
empty
  , _termChk :: TerminationCheck
_termChk  = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
  , _posChk :: PositivityCheck
_posChk   = PositivityCheck
YesPositivityCheck
  , _uniChk :: UniverseCheck
_uniChk   = UniverseCheck
YesUniverseCheck
  , _catchall :: Bool
_catchall = Bool
False
  , _covChk :: CoverageCheck
_covChk   = CoverageCheck
YesCoverageCheck
  , niceWarn :: [DeclarationWarning]
niceWarn  = []
  }

-- * Handling the lone signatures, stored to infer mutual blocks.

-- | Lens for field '_loneSigs'.

loneSigs :: Lens' LoneSigs NiceEnv
loneSigs :: (LoneSigs -> f LoneSigs) -> NiceEnv -> f NiceEnv
loneSigs LoneSigs -> f LoneSigs
f NiceEnv
e = LoneSigs -> f LoneSigs
f (NiceEnv -> LoneSigs
_loneSigs NiceEnv
e) f LoneSigs -> (LoneSigs -> NiceEnv) -> f NiceEnv
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ LoneSigs
s -> NiceEnv
e { _loneSigs :: LoneSigs
_loneSigs = LoneSigs
s }

-- | Adding a lone signature to the state.

addLoneSig :: Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig :: Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig Range
r Name
x DataRecOrFun
k = Lens' LoneSigs NiceEnv
loneSigs Lens' LoneSigs NiceEnv -> (LoneSigs -> Nice LoneSigs) -> Nice ()
forall o (m :: * -> *) i.
MonadState o m =>
Lens' i o -> (i -> m i) -> m ()
%== \ LoneSigs
s -> do
   let (Maybe LoneSig
mr, LoneSigs
s') = (Name -> LoneSig -> LoneSig -> LoneSig)
-> Name -> LoneSig -> LoneSigs -> (Maybe LoneSig, LoneSigs)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\ Name
_k LoneSig
new LoneSig
_old -> LoneSig
new) Name
x (Range -> Name -> DataRecOrFun -> LoneSig
LoneSig Range
r Name
x DataRecOrFun
k) LoneSigs
s
   case Maybe LoneSig
mr of
     Maybe LoneSig
Nothing -> LoneSigs -> Nice LoneSigs
forall (m :: * -> *) a. Monad m => a -> m a
return LoneSigs
s'
     Just{}  -> DeclarationException -> Nice LoneSigs
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice LoneSigs)
-> DeclarationException -> Nice LoneSigs
forall a b. (a -> b) -> a -> b
$ Name -> DeclarationException
DuplicateDefinition Name
x

-- | Remove a lone signature from the state.

removeLoneSig :: Name -> Nice ()
removeLoneSig :: Name -> Nice ()
removeLoneSig Name
x = Lens' LoneSigs NiceEnv
loneSigs Lens' LoneSigs NiceEnv -> (LoneSigs -> LoneSigs) -> Nice ()
forall o (m :: * -> *) i.
MonadState o m =>
Lens' i o -> (i -> i) -> m ()
%= Name -> LoneSigs -> LoneSigs
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
x

-- | Search for forward type signature.

getSig :: Name -> Nice (Maybe DataRecOrFun)
getSig :: Name -> Nice (Maybe DataRecOrFun)
getSig Name
x = (LoneSig -> DataRecOrFun) -> Maybe LoneSig -> Maybe DataRecOrFun
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LoneSig -> DataRecOrFun
loneSigKind (Maybe LoneSig -> Maybe DataRecOrFun)
-> (LoneSigs -> Maybe LoneSig) -> LoneSigs -> Maybe DataRecOrFun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> LoneSigs -> Maybe LoneSig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x (LoneSigs -> Maybe DataRecOrFun)
-> Nice LoneSigs -> Nice (Maybe DataRecOrFun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' LoneSigs NiceEnv -> Nice LoneSigs
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' LoneSigs NiceEnv
loneSigs

-- | Check that no lone signatures are left in the state.

noLoneSigs :: Nice Bool
noLoneSigs :: Nice Bool
noLoneSigs = LoneSigs -> Bool
forall a. Null a => a -> Bool
null (LoneSigs -> Bool) -> Nice LoneSigs -> Nice Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' LoneSigs NiceEnv -> Nice LoneSigs
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' LoneSigs NiceEnv
loneSigs

-- | Ensure that all forward declarations have been given a definition.

forgetLoneSigs :: Nice ()
forgetLoneSigs :: Nice ()
forgetLoneSigs = Lens' LoneSigs NiceEnv
loneSigs Lens' LoneSigs NiceEnv -> LoneSigs -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= LoneSigs
forall k a. Map k a
Map.empty

checkLoneSigs :: LoneSigs -> Nice ()
checkLoneSigs :: LoneSigs -> Nice ()
checkLoneSigs LoneSigs
xs = do
  Nice ()
forgetLoneSigs
  Bool -> Nice () -> Nice ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LoneSigs -> Bool
forall k a. Map k a -> Bool
Map.null LoneSigs
xs) (Nice () -> Nice ()) -> Nice () -> Nice ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ [(Name, Range)] -> DeclarationWarning
MissingDefinitions ([(Name, Range)] -> DeclarationWarning)
-> [(Name, Range)] -> DeclarationWarning
forall a b. (a -> b) -> a -> b
$
    (LoneSig -> (Name, Range)) -> [LoneSig] -> [(Name, Range)]
forall a b. (a -> b) -> [a] -> [b]
map (\LoneSig
s -> (LoneSig -> Name
loneSigName LoneSig
s , LoneSig -> Range
loneSigRange LoneSig
s)) ([LoneSig] -> [(Name, Range)]) -> [LoneSig] -> [(Name, Range)]
forall a b. (a -> b) -> a -> b
$ LoneSigs -> [LoneSig]
forall k a. Map k a -> [a]
Map.elems LoneSigs
xs

-- | Get names of lone function signatures.

loneFuns :: LoneSigs -> [Name]
loneFuns :: LoneSigs -> [Name]
loneFuns = ((Name, LoneSig) -> Name) -> [(Name, LoneSig)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, LoneSig) -> Name
forall a b. (a, b) -> a
fst ([(Name, LoneSig)] -> [Name])
-> (LoneSigs -> [(Name, LoneSig)]) -> LoneSigs -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, LoneSig) -> Bool) -> [(Name, LoneSig)] -> [(Name, LoneSig)]
forall a. (a -> Bool) -> [a] -> [a]
filter (DataRecOrFun -> Bool
isFunName (DataRecOrFun -> Bool)
-> ((Name, LoneSig) -> DataRecOrFun) -> (Name, LoneSig) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoneSig -> DataRecOrFun
loneSigKind (LoneSig -> DataRecOrFun)
-> ((Name, LoneSig) -> LoneSig) -> (Name, LoneSig) -> DataRecOrFun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, LoneSig) -> LoneSig
forall a b. (a, b) -> b
snd) ([(Name, LoneSig)] -> [(Name, LoneSig)])
-> (LoneSigs -> [(Name, LoneSig)]) -> LoneSigs -> [(Name, LoneSig)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoneSigs -> [(Name, LoneSig)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- | Create a 'LoneSigs' map from an association list.

loneSigsFromLoneNames :: [(Range, Name, DataRecOrFun)] -> LoneSigs
loneSigsFromLoneNames :: [(Range, Name, DataRecOrFun)] -> LoneSigs
loneSigsFromLoneNames = [(Name, LoneSig)] -> LoneSigs
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, LoneSig)] -> LoneSigs)
-> ([(Range, Name, DataRecOrFun)] -> [(Name, LoneSig)])
-> [(Range, Name, DataRecOrFun)]
-> LoneSigs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Range, Name, DataRecOrFun) -> (Name, LoneSig))
-> [(Range, Name, DataRecOrFun)] -> [(Name, LoneSig)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Range
r,Name
x,DataRecOrFun
k) -> (Name
x, Range -> Name -> DataRecOrFun -> LoneSig
LoneSig Range
r Name
x DataRecOrFun
k))

-- | Lens for field '_termChk'.

terminationCheckPragma :: Lens' TerminationCheck NiceEnv
terminationCheckPragma :: (TerminationCheck -> f TerminationCheck) -> NiceEnv -> f NiceEnv
terminationCheckPragma TerminationCheck -> f TerminationCheck
f NiceEnv
e = TerminationCheck -> f TerminationCheck
f (NiceEnv -> TerminationCheck
_termChk NiceEnv
e) f TerminationCheck -> (TerminationCheck -> NiceEnv) -> f NiceEnv
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ TerminationCheck
s -> NiceEnv
e { _termChk :: TerminationCheck
_termChk = TerminationCheck
s }

withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a
withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a
withTerminationCheckPragma TerminationCheck
tc Nice a
f = do
  TerminationCheck
tc_old <- Lens' TerminationCheck NiceEnv -> Nice TerminationCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' TerminationCheck NiceEnv
terminationCheckPragma
  Lens' TerminationCheck NiceEnv
terminationCheckPragma Lens' TerminationCheck NiceEnv -> TerminationCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= TerminationCheck
tc
  a
result <- Nice a
f
  Lens' TerminationCheck NiceEnv
terminationCheckPragma Lens' TerminationCheck NiceEnv -> TerminationCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= TerminationCheck
tc_old
  a -> Nice a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

coverageCheckPragma :: Lens' CoverageCheck NiceEnv
coverageCheckPragma :: (CoverageCheck -> f CoverageCheck) -> NiceEnv -> f NiceEnv
coverageCheckPragma CoverageCheck -> f CoverageCheck
f NiceEnv
e = CoverageCheck -> f CoverageCheck
f (NiceEnv -> CoverageCheck
_covChk NiceEnv
e) f CoverageCheck -> (CoverageCheck -> NiceEnv) -> f NiceEnv
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ CoverageCheck
s -> NiceEnv
e { _covChk :: CoverageCheck
_covChk = CoverageCheck
s }

withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a
withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a
withCoverageCheckPragma CoverageCheck
tc Nice a
f = do
  CoverageCheck
tc_old <- Lens' CoverageCheck NiceEnv -> Nice CoverageCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' CoverageCheck NiceEnv
coverageCheckPragma
  Lens' CoverageCheck NiceEnv
coverageCheckPragma Lens' CoverageCheck NiceEnv -> CoverageCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= CoverageCheck
tc
  a
result <- Nice a
f
  Lens' CoverageCheck NiceEnv
coverageCheckPragma Lens' CoverageCheck NiceEnv -> CoverageCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= CoverageCheck
tc_old
  a -> Nice a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | Lens for field '_posChk'.

positivityCheckPragma :: Lens' PositivityCheck NiceEnv
positivityCheckPragma :: (PositivityCheck -> f PositivityCheck) -> NiceEnv -> f NiceEnv
positivityCheckPragma PositivityCheck -> f PositivityCheck
f NiceEnv
e = PositivityCheck -> f PositivityCheck
f (NiceEnv -> PositivityCheck
_posChk NiceEnv
e) f PositivityCheck -> (PositivityCheck -> NiceEnv) -> f NiceEnv
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ PositivityCheck
s -> NiceEnv
e { _posChk :: PositivityCheck
_posChk = PositivityCheck
s }

withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a
withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a
withPositivityCheckPragma PositivityCheck
pc Nice a
f = do
  PositivityCheck
pc_old <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
  Lens' PositivityCheck NiceEnv
positivityCheckPragma Lens' PositivityCheck NiceEnv -> PositivityCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= PositivityCheck
pc
  a
result <- Nice a
f
  Lens' PositivityCheck NiceEnv
positivityCheckPragma Lens' PositivityCheck NiceEnv -> PositivityCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= PositivityCheck
pc_old
  a -> Nice a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | Lens for field '_uniChk'.

universeCheckPragma :: Lens' UniverseCheck NiceEnv
universeCheckPragma :: (UniverseCheck -> f UniverseCheck) -> NiceEnv -> f NiceEnv
universeCheckPragma UniverseCheck -> f UniverseCheck
f NiceEnv
e = UniverseCheck -> f UniverseCheck
f (NiceEnv -> UniverseCheck
_uniChk NiceEnv
e) f UniverseCheck -> (UniverseCheck -> NiceEnv) -> f NiceEnv
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ UniverseCheck
s -> NiceEnv
e { _uniChk :: UniverseCheck
_uniChk = UniverseCheck
s }

withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a
withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a
withUniverseCheckPragma UniverseCheck
uc Nice a
f = do
  UniverseCheck
uc_old <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
  Lens' UniverseCheck NiceEnv
universeCheckPragma Lens' UniverseCheck NiceEnv -> UniverseCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= UniverseCheck
uc
  a
result <- Nice a
f
  Lens' UniverseCheck NiceEnv
universeCheckPragma Lens' UniverseCheck NiceEnv -> UniverseCheck -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= UniverseCheck
uc_old
  a -> Nice a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | Get universe check pragma from a data/rec signature.
--   Defaults to 'YesUniverseCheck'.

getUniverseCheckFromSig :: Name -> Nice UniverseCheck
getUniverseCheckFromSig :: Name -> Nice UniverseCheck
getUniverseCheckFromSig Name
x = UniverseCheck
-> (DataRecOrFun -> UniverseCheck)
-> Maybe DataRecOrFun
-> UniverseCheck
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UniverseCheck
YesUniverseCheck DataRecOrFun -> UniverseCheck
universeCheck (Maybe DataRecOrFun -> UniverseCheck)
-> Nice (Maybe DataRecOrFun) -> Nice UniverseCheck
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Nice (Maybe DataRecOrFun)
getSig Name
x

-- | Lens for field '_catchall'.

catchallPragma :: Lens' Catchall NiceEnv
catchallPragma :: (Bool -> f Bool) -> NiceEnv -> f NiceEnv
catchallPragma Bool -> f Bool
f NiceEnv
e = Bool -> f Bool
f (NiceEnv -> Bool
_catchall NiceEnv
e) f Bool -> (Bool -> NiceEnv) -> f NiceEnv
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ Bool
s -> NiceEnv
e { _catchall :: Bool
_catchall = Bool
s }

-- | Get current catchall pragma, and reset it for the next clause.

popCatchallPragma :: Nice Catchall
popCatchallPragma :: Nice Bool
popCatchallPragma = do
  Bool
ca <- Lens' Bool NiceEnv -> Nice Bool
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' Bool NiceEnv
catchallPragma
  Lens' Bool NiceEnv
catchallPragma Lens' Bool NiceEnv -> Bool -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= Bool
False
  Bool -> Nice Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ca

withCatchallPragma :: Catchall -> Nice a -> Nice a
withCatchallPragma :: Bool -> Nice a -> Nice a
withCatchallPragma Bool
ca Nice a
f = do
  Bool
ca_old <- Lens' Bool NiceEnv -> Nice Bool
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' Bool NiceEnv
catchallPragma
  Lens' Bool NiceEnv
catchallPragma Lens' Bool NiceEnv -> Bool -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= Bool
ca
  a
result <- Nice a
f
  Lens' Bool NiceEnv
catchallPragma Lens' Bool NiceEnv -> Bool -> Nice ()
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> i -> m ()
.= Bool
ca_old
  a -> Nice a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | Add a new warning.
niceWarning :: DeclarationWarning -> Nice ()
niceWarning :: DeclarationWarning -> Nice ()
niceWarning DeclarationWarning
w = (NiceEnv -> NiceEnv) -> Nice ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((NiceEnv -> NiceEnv) -> Nice ())
-> (NiceEnv -> NiceEnv) -> Nice ()
forall a b. (a -> b) -> a -> b
$ \ NiceEnv
st -> NiceEnv
st { niceWarn :: [DeclarationWarning]
niceWarn = DeclarationWarning
w DeclarationWarning -> [DeclarationWarning] -> [DeclarationWarning]
forall a. a -> [a] -> [a]
: NiceEnv -> [DeclarationWarning]
niceWarn NiceEnv
st }

data DeclKind
    = LoneSigDecl Range DataRecOrFun Name
    | LoneDefs DataRecOrFun [Name]
    | OtherDecl
  deriving (DeclKind -> DeclKind -> Bool
(DeclKind -> DeclKind -> Bool)
-> (DeclKind -> DeclKind -> Bool) -> Eq DeclKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeclKind -> DeclKind -> Bool
$c/= :: DeclKind -> DeclKind -> Bool
== :: DeclKind -> DeclKind -> Bool
$c== :: DeclKind -> DeclKind -> Bool
Eq, Int -> DeclKind -> ShowS
[DeclKind] -> ShowS
DeclKind -> String
(Int -> DeclKind -> ShowS)
-> (DeclKind -> String) -> ([DeclKind] -> ShowS) -> Show DeclKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeclKind] -> ShowS
$cshowList :: [DeclKind] -> ShowS
show :: DeclKind -> String
$cshow :: DeclKind -> String
showsPrec :: Int -> DeclKind -> ShowS
$cshowsPrec :: Int -> DeclKind -> ShowS
Show)

declKind :: NiceDeclaration -> DeclKind
declKind :: NiceDeclaration -> DeclKind
declKind (FunSig Range
r Access
_ IsAbstract
_ IsInstance
_ IsMacro
_ ArgInfo
_ TerminationCheck
tc CoverageCheck
cc Name
x Expr
_)     = Range -> DataRecOrFun -> Name -> DeclKind
LoneSigDecl Range
r (TerminationCheck -> CoverageCheck -> DataRecOrFun
FunName TerminationCheck
tc CoverageCheck
cc) Name
x
declKind (NiceRecSig Range
r Access
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
pars Expr
_)  = Range -> DataRecOrFun -> Name -> DeclKind
LoneSigDecl Range
r (PositivityCheck -> UniverseCheck -> DataRecOrFun
RecName PositivityCheck
pc UniverseCheck
uc) Name
x
declKind (NiceDataSig Range
r Access
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
pars Expr
_) = Range -> DataRecOrFun -> Name -> DeclKind
LoneSigDecl Range
r (PositivityCheck -> UniverseCheck -> DataRecOrFun
DataName PositivityCheck
pc UniverseCheck
uc) Name
x
declKind (FunDef Range
r [Declaration]
_ IsAbstract
abs IsInstance
ins TerminationCheck
tc CoverageCheck
cc Name
x [Clause]
_)     = DataRecOrFun -> [Name] -> DeclKind
LoneDefs (TerminationCheck -> CoverageCheck -> DataRecOrFun
FunName TerminationCheck
tc CoverageCheck
cc) [Name
x]
declKind (NiceDataDef Range
_ Origin
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
pars [NiceDeclaration]
_) = DataRecOrFun -> [Name] -> DeclKind
LoneDefs (PositivityCheck -> UniverseCheck -> DataRecOrFun
DataName PositivityCheck
pc UniverseCheck
uc) [Name
x]
declKind (NiceRecDef Range
_ Origin
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
uc Name
x Maybe (Ranged Induction)
_ Maybe HasEta
_ Maybe (Name, IsInstance)
_ [LamBinding]
pars [Declaration]
_)= DataRecOrFun -> [Name] -> DeclKind
LoneDefs (PositivityCheck -> UniverseCheck -> DataRecOrFun
RecName PositivityCheck
pc UniverseCheck
uc) [Name
x]
declKind (NiceUnquoteDef Range
_ Access
_ IsAbstract
_ TerminationCheck
tc CoverageCheck
cc [Name]
xs Expr
_)  = DataRecOrFun -> [Name] -> DeclKind
LoneDefs (TerminationCheck -> CoverageCheck -> DataRecOrFun
FunName TerminationCheck
tc CoverageCheck
cc) [Name]
xs
declKind Axiom{}                            = DeclKind
OtherDecl
declKind NiceField{}                        = DeclKind
OtherDecl
declKind PrimitiveFunction{}                = DeclKind
OtherDecl
declKind NiceMutual{}                       = DeclKind
OtherDecl
declKind NiceModule{}                       = DeclKind
OtherDecl
declKind NiceModuleMacro{}                  = DeclKind
OtherDecl
declKind NiceOpen{}                         = DeclKind
OtherDecl
declKind NiceImport{}                       = DeclKind
OtherDecl
declKind NicePragma{}                       = DeclKind
OtherDecl
declKind NiceFunClause{}                    = DeclKind
OtherDecl
declKind NicePatternSyn{}                   = DeclKind
OtherDecl
declKind NiceGeneralize{}                   = DeclKind
OtherDecl
declKind NiceUnquoteDecl{}                  = DeclKind
OtherDecl

-- | Replace (Data/Rec/Fun)Sigs with Axioms for postulated names
--   The first argument is a list of axioms only.
replaceSigs
  :: LoneSigs               -- ^ Lone signatures to be turned into Axioms
  -> [NiceDeclaration]      -- ^ Declarations containing them
  -> [NiceDeclaration]      -- ^ In the output, everything should be defined
replaceSigs :: LoneSigs -> [NiceDeclaration] -> [NiceDeclaration]
replaceSigs LoneSigs
ps = if LoneSigs -> Bool
forall k a. Map k a -> Bool
Map.null LoneSigs
ps then [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> a
id else \case
  []     -> [NiceDeclaration]
forall a. HasCallStack => a
__IMPOSSIBLE__
  (NiceDeclaration
d:[NiceDeclaration]
ds) ->
    case NiceDeclaration -> Maybe (Name, NiceDeclaration)
replaceable NiceDeclaration
d of
      -- If declaration d of x is mentioned in the map of lone signatures then replace
      -- it with an axiom
      Just (Name
x, NiceDeclaration
axiom)
        | (Just (LoneSig Range
_ Name
x' DataRecOrFun
_), LoneSigs
ps') <- (Name -> LoneSig -> Maybe LoneSig)
-> Name -> LoneSigs -> (Maybe LoneSig, LoneSigs)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\ Name
_ LoneSig
_ -> Maybe LoneSig
forall a. Maybe a
Nothing) Name
x LoneSigs
ps
        , Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x'
            -- Use the range as UID to ensure we do not replace the wrong signature.
            -- This could happen if the user wrote a duplicate definition.
        -> NiceDeclaration
axiom NiceDeclaration -> [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> [a] -> [a]
: LoneSigs -> [NiceDeclaration] -> [NiceDeclaration]
replaceSigs LoneSigs
ps' [NiceDeclaration]
ds
      Maybe (Name, NiceDeclaration)
_ -> NiceDeclaration
d     NiceDeclaration -> [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> [a] -> [a]
: LoneSigs -> [NiceDeclaration] -> [NiceDeclaration]
replaceSigs LoneSigs
ps  [NiceDeclaration]
ds

  where

    -- A @replaceable@ declaration is a signature. It has a name and we can make an
    -- @Axiom@ out of it.
    replaceable :: NiceDeclaration -> Maybe (Name, NiceDeclaration)
    replaceable :: NiceDeclaration -> Maybe (Name, NiceDeclaration)
replaceable = \case
      FunSig Range
r Access
acc IsAbstract
abst IsInstance
inst IsMacro
_ ArgInfo
argi TerminationCheck
_ CoverageCheck
_ Name
x Expr
e ->
        (Name, NiceDeclaration) -> Maybe (Name, NiceDeclaration)
forall a. a -> Maybe a
Just (Name
x, Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom Range
r Access
acc IsAbstract
abst IsInstance
inst ArgInfo
argi Name
x Expr
e)
      NiceRecSig Range
r Access
acc IsAbstract
abst PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
pars Expr
t ->
        let e :: Expr
e = Expr -> Expr
Generalized (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
makePi (Range -> [LamBinding] -> Telescope
lamBindingsToTelescope Range
r [LamBinding]
pars) Expr
t in
        (Name, NiceDeclaration) -> Maybe (Name, NiceDeclaration)
forall a. a -> Maybe a
Just (Name
x, Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom Range
r Access
acc IsAbstract
abst IsInstance
NotInstanceDef ArgInfo
defaultArgInfo Name
x Expr
e)
      NiceDataSig Range
r Access
acc IsAbstract
abst PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
pars Expr
t ->
        let e :: Expr
e = Expr -> Expr
Generalized (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
makePi (Range -> [LamBinding] -> Telescope
lamBindingsToTelescope Range
r [LamBinding]
pars) Expr
t in
        (Name, NiceDeclaration) -> Maybe (Name, NiceDeclaration)
forall a. a -> Maybe a
Just (Name
x, Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom Range
r Access
acc IsAbstract
abst IsInstance
NotInstanceDef ArgInfo
defaultArgInfo Name
x Expr
e)
      NiceDeclaration
_ -> Maybe (Name, NiceDeclaration)
forall a. Maybe a
Nothing

-- | Main. Fixities (or more precisely syntax declarations) are needed when
--   grouping function clauses.
niceDeclarations :: Fixities -> [Declaration] -> Nice [NiceDeclaration]
niceDeclarations :: Fixities -> [Declaration] -> Nice [NiceDeclaration]
niceDeclarations Fixities
fixs [Declaration]
ds = do

  -- Run the nicifier in an initial environment. But keep the warnings.
  NiceEnv
st <- Nice NiceEnv
forall s (m :: * -> *). MonadState s m => m s
get
  NiceEnv -> Nice ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (NiceEnv -> Nice ()) -> NiceEnv -> Nice ()
forall a b. (a -> b) -> a -> b
$ NiceEnv
initNiceEnv { niceWarn :: [DeclarationWarning]
niceWarn = NiceEnv -> [DeclarationWarning]
niceWarn NiceEnv
st }
  [NiceDeclaration]
nds <- [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ds

  -- Check that every signature got its definition.
  LoneSigs
ps <- Lens' LoneSigs NiceEnv -> Nice LoneSigs
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' LoneSigs NiceEnv
loneSigs
  LoneSigs -> Nice ()
checkLoneSigs LoneSigs
ps
  -- We postulate the missing ones and insert them in place of the corresponding @FunSig@
  let ds :: [NiceDeclaration]
ds = LoneSigs -> [NiceDeclaration] -> [NiceDeclaration]
replaceSigs LoneSigs
ps [NiceDeclaration]
nds

  -- Note that loneSigs is ensured to be empty.
  -- (Important, since inferMutualBlocks also uses loneSigs state).
  [NiceDeclaration]
res <- [NiceDeclaration] -> Nice [NiceDeclaration]
inferMutualBlocks [NiceDeclaration]
ds

  -- Restore the old state, but keep the warnings.
  [DeclarationWarning]
warns <- (NiceEnv -> [DeclarationWarning]) -> Nice [DeclarationWarning]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets NiceEnv -> [DeclarationWarning]
niceWarn
  NiceEnv -> Nice ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (NiceEnv -> Nice ()) -> NiceEnv -> Nice ()
forall a b. (a -> b) -> a -> b
$ NiceEnv
st { niceWarn :: [DeclarationWarning]
niceWarn = [DeclarationWarning]
warns }
  [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [NiceDeclaration]
res

  where

    inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]
    inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]
inferMutualBlocks [] = [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    inferMutualBlocks (NiceDeclaration
d : [NiceDeclaration]
ds) =
      case NiceDeclaration -> DeclKind
declKind NiceDeclaration
d of
        DeclKind
OtherDecl    -> (NiceDeclaration
d NiceDeclaration -> [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> [a] -> [a]
:) ([NiceDeclaration] -> [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NiceDeclaration] -> Nice [NiceDeclaration]
inferMutualBlocks [NiceDeclaration]
ds
        LoneDefs{}   -> (NiceDeclaration
d NiceDeclaration -> [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> [a] -> [a]
:) ([NiceDeclaration] -> [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NiceDeclaration] -> Nice [NiceDeclaration]
inferMutualBlocks [NiceDeclaration]
ds  -- Andreas, 2017-10-09, issue #2576: report error in ConcreteToAbstract
        LoneSigDecl Range
r DataRecOrFun
k Name
x  -> do
          Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig Range
r Name
x DataRecOrFun
k
          let tcccpc :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc = ([DataRecOrFun -> TerminationCheck
terminationCheck DataRecOrFun
k], [DataRecOrFun -> CoverageCheck
coverageCheck DataRecOrFun
k], [DataRecOrFun -> PositivityCheck
positivityCheck DataRecOrFun
k])
          (([TerminationCheck]
tcs, [CoverageCheck]
ccs, [PositivityCheck]
pcs), ([NiceDeclaration]
nds0, [NiceDeclaration]
ds1)) <- ([TerminationCheck], [CoverageCheck], [PositivityCheck])
-> [NiceDeclaration]
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
untilAllDefined ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc [NiceDeclaration]
ds
          -- If we still have lone signatures without any accompanying definition,
          -- we postulate the definition and substitute the axiom for the lone signature
          LoneSigs
ps <- Lens' LoneSigs NiceEnv -> Nice LoneSigs
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' LoneSigs NiceEnv
loneSigs
          LoneSigs -> Nice ()
checkLoneSigs LoneSigs
ps
          let ds0 :: [NiceDeclaration]
ds0 = LoneSigs -> [NiceDeclaration] -> [NiceDeclaration]
replaceSigs LoneSigs
ps (NiceDeclaration
d NiceDeclaration -> [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> [a] -> [a]
: [NiceDeclaration]
nds0) -- NB: don't forget the LoneSig the block started with!
          -- We then keep processing the rest of the block
          TerminationCheck
tc <- Range -> [TerminationCheck] -> Nice TerminationCheck
combineTerminationChecks (NiceDeclaration -> Range
forall t. HasRange t => t -> Range
getRange NiceDeclaration
d) [TerminationCheck]
tcs
          let cc :: CoverageCheck
cc = [CoverageCheck] -> CoverageCheck
combineCoverageChecks [CoverageCheck]
ccs
          let pc :: PositivityCheck
pc = [PositivityCheck] -> PositivityCheck
combinePositivityChecks [PositivityCheck]
pcs
          (Range
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual ([NiceDeclaration] -> Range
forall t. HasRange t => t -> Range
getRange [NiceDeclaration]
ds0) TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds0 NiceDeclaration -> [NiceDeclaration] -> [NiceDeclaration]
forall a. a -> [a] -> [a]
:) ([NiceDeclaration] -> [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NiceDeclaration] -> Nice [NiceDeclaration]
inferMutualBlocks [NiceDeclaration]
ds1
      where
        untilAllDefined :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])
                        -> [NiceDeclaration]
                        -> Nice (([TerminationCheck], [CoverageCheck], [PositivityCheck]) -- checks for this block
                                , ([NiceDeclaration]                                      -- mutual block
                                , [NiceDeclaration])                                      -- leftovers
                                )
        untilAllDefined :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])
-> [NiceDeclaration]
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
untilAllDefined tcccpc :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc@([TerminationCheck]
tc, [CoverageCheck]
cc, [PositivityCheck]
pc) [NiceDeclaration]
ds = do
          Bool
done <- Nice Bool
noLoneSigs
          if Bool
done then (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
 ([NiceDeclaration], [NiceDeclaration]))
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
forall (m :: * -> *) a. Monad m => a -> m a
return (([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc, ([], [NiceDeclaration]
ds)) else
            case [NiceDeclaration]
ds of
              []     -> (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
 ([NiceDeclaration], [NiceDeclaration]))
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
forall (m :: * -> *) a. Monad m => a -> m a
return (([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc, ([], [NiceDeclaration]
ds))
              NiceDeclaration
d : [NiceDeclaration]
ds -> case NiceDeclaration -> DeclKind
declKind NiceDeclaration
d of
                LoneSigDecl Range
r DataRecOrFun
k Name
x -> do
                  Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig Range
r Name
x DataRecOrFun
k
                  let tcccpc' :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc' = (DataRecOrFun -> TerminationCheck
terminationCheck DataRecOrFun
k TerminationCheck -> [TerminationCheck] -> [TerminationCheck]
forall a. a -> [a] -> [a]
: [TerminationCheck]
tc, DataRecOrFun -> CoverageCheck
coverageCheck DataRecOrFun
k CoverageCheck -> [CoverageCheck] -> [CoverageCheck]
forall a. a -> [a] -> [a]
: [CoverageCheck]
cc, DataRecOrFun -> PositivityCheck
positivityCheck DataRecOrFun
k PositivityCheck -> [PositivityCheck] -> [PositivityCheck]
forall a. a -> [a] -> [a]
: [PositivityCheck]
pc)
                  NiceDeclaration
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
forall (f :: * -> *) a b b'.
Functor f =>
a -> f (b, ([a], b')) -> f (b, ([a], b'))
cons NiceDeclaration
d (([TerminationCheck], [CoverageCheck], [PositivityCheck])
-> [NiceDeclaration]
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
untilAllDefined ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc' [NiceDeclaration]
ds)
                LoneDefs DataRecOrFun
k [Name]
xs -> do
                  (Name -> Nice ()) -> [Name] -> Nice ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> Nice ()
removeLoneSig [Name]
xs
                  let tcccpc' :: ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc' = (DataRecOrFun -> TerminationCheck
terminationCheck DataRecOrFun
k TerminationCheck -> [TerminationCheck] -> [TerminationCheck]
forall a. a -> [a] -> [a]
: [TerminationCheck]
tc, DataRecOrFun -> CoverageCheck
coverageCheck DataRecOrFun
k CoverageCheck -> [CoverageCheck] -> [CoverageCheck]
forall a. a -> [a] -> [a]
: [CoverageCheck]
cc, DataRecOrFun -> PositivityCheck
positivityCheck DataRecOrFun
k PositivityCheck -> [PositivityCheck] -> [PositivityCheck]
forall a. a -> [a] -> [a]
: [PositivityCheck]
pc)
                  NiceDeclaration
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
forall (f :: * -> *) a b b'.
Functor f =>
a -> f (b, ([a], b')) -> f (b, ([a], b'))
cons NiceDeclaration
d (([TerminationCheck], [CoverageCheck], [PositivityCheck])
-> [NiceDeclaration]
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
untilAllDefined ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc' [NiceDeclaration]
ds)
                DeclKind
OtherDecl   -> NiceDeclaration
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
forall (f :: * -> *) a b b'.
Functor f =>
a -> f (b, ([a], b')) -> f (b, ([a], b'))
cons NiceDeclaration
d (([TerminationCheck], [CoverageCheck], [PositivityCheck])
-> [NiceDeclaration]
-> Nice
     (([TerminationCheck], [CoverageCheck], [PositivityCheck]),
      ([NiceDeclaration], [NiceDeclaration]))
untilAllDefined ([TerminationCheck], [CoverageCheck], [PositivityCheck])
tcccpc [NiceDeclaration]
ds)
          where
            -- ASR (26 December 2015): Type annotated version of the @cons@ function.
            -- cons d = fmap $
            --            (id :: (([TerminationCheck], [PositivityCheck]) -> ([TerminationCheck], [PositivityCheck])))
            --            *** (d :)
            --            *** (id :: [NiceDeclaration] -> [NiceDeclaration])
            cons :: a -> f (b, ([a], b')) -> f (b, ([a], b'))
cons a
d = ((b, ([a], b')) -> (b, ([a], b')))
-> f (b, ([a], b')) -> f (b, ([a], b'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> b
forall a. a -> a
id (b -> b)
-> (([a], b') -> ([a], b')) -> (b, ([a], b')) -> (b, ([a], b'))
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (a
d a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> (b' -> b') -> ([a], b') -> ([a], b')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** b' -> b'
forall a. a -> a
id)

    notMeasure :: TerminationCheck m -> Bool
notMeasure TerminationMeasure{} = Bool
False
    notMeasure TerminationCheck m
_ = Bool
True

    nice :: [Declaration] -> Nice [NiceDeclaration]
    nice :: [Declaration] -> Nice [NiceDeclaration]
nice [] = [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    nice [Declaration]
ds = do
      ([NiceDeclaration]
xs , [Declaration]
ys) <- [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      ([NiceDeclaration]
xs [NiceDeclaration] -> [NiceDeclaration] -> [NiceDeclaration]
forall a. [a] -> [a] -> [a]
++) ([NiceDeclaration] -> [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ys

    nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])
    nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 []     = ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], []) -- Andreas, 2017-09-16, issue #2759: no longer __IMPOSSIBLE__
    nice1 (Declaration
d:[Declaration]
ds) = do
      let justWarning :: DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning DeclarationWarning
w = do DeclarationWarning -> Nice ()
niceWarning DeclarationWarning
w; [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

      case Declaration
d of

        TypeSig ArgInfo
info TacticAttribute
_tac Name
x Expr
t -> do
          TerminationCheck
termCheck <- Lens' TerminationCheck NiceEnv -> Nice TerminationCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' TerminationCheck NiceEnv
terminationCheckPragma
          CoverageCheck
covCheck  <- Lens' CoverageCheck NiceEnv -> Nice CoverageCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' CoverageCheck NiceEnv
coverageCheckPragma
          let r :: Range
r = Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
d
          -- register x as lone type signature, to recognize clauses later
          Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig Range
r Name
x (DataRecOrFun -> Nice ()) -> DataRecOrFun -> Nice ()
forall a b. (a -> b) -> a -> b
$ TerminationCheck -> CoverageCheck -> DataRecOrFun
FunName TerminationCheck
termCheck CoverageCheck
covCheck
          ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
FunSig Range
r Access
PublicAccess IsAbstract
ConcreteDef IsInstance
NotInstanceDef IsMacro
NotMacroDef ArgInfo
info TerminationCheck
termCheck CoverageCheck
covCheck Name
x Expr
t] , [Declaration]
ds)

        -- Should not show up: all FieldSig are part of a Field block
        FieldSig{} -> Nice ([NiceDeclaration], [Declaration])
forall a. HasCallStack => a
__IMPOSSIBLE__

        Generalize Range
r [] -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyGeneralize Range
r
        Generalize Range
r [Declaration]
sigs -> do
          [NiceDeclaration]
gs <- [Declaration]
-> (Declaration -> Nice NiceDeclaration) -> Nice [NiceDeclaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Declaration]
sigs ((Declaration -> Nice NiceDeclaration) -> Nice [NiceDeclaration])
-> (Declaration -> Nice NiceDeclaration) -> Nice [NiceDeclaration]
forall a b. (a -> b) -> a -> b
$ \case
            sig :: Declaration
sig@(TypeSig ArgInfo
info TacticAttribute
tac Name
x Expr
t) -> do
              NiceDeclaration -> Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return (NiceDeclaration -> Nice NiceDeclaration)
-> NiceDeclaration -> Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> ArgInfo
-> TacticAttribute
-> Name
-> Expr
-> NiceDeclaration
NiceGeneralize (Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
sig) Access
PublicAccess ArgInfo
info TacticAttribute
tac Name
x Expr
t
            Declaration
_ -> Nice NiceDeclaration
forall a. HasCallStack => a
__IMPOSSIBLE__
          ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NiceDeclaration]
gs, [Declaration]
ds)

        (FunClause LHS
lhs RHS
_ WhereClause
_ Bool
_)         -> do
          TerminationCheck
termCheck <- Lens' TerminationCheck NiceEnv -> Nice TerminationCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' TerminationCheck NiceEnv
terminationCheckPragma
          CoverageCheck
covCheck  <- Lens' CoverageCheck NiceEnv -> Nice CoverageCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' CoverageCheck NiceEnv
coverageCheckPragma
          Bool
catchall  <- Nice Bool
popCatchallPragma
          [Name]
xs <- LoneSigs -> [Name]
loneFuns (LoneSigs -> [Name]) -> Nice LoneSigs -> Nice [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' LoneSigs NiceEnv -> Nice LoneSigs
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' LoneSigs NiceEnv
loneSigs
          -- for each type signature 'x' waiting for clauses, we try
          -- if we have some clauses for 'x'
          case [ (Name
x, ([Declaration]
fits, [Declaration]
rest))
               | Name
x <- [Name]
xs
               , let ([Declaration]
fits, [Declaration]
rest) =
                      -- Anonymous declarations only have 1 clause each!
                      if Name -> Bool
forall a. IsNoName a => a -> Bool
isNoName Name
x then ([Declaration
d], [Declaration]
ds)
                      else (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Maybe Fixity' -> Name -> Declaration -> Bool
couldBeFunClauseOf (Name -> Fixities -> Maybe Fixity'
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x Fixities
fixs) Name
x) (Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
ds)
               , Bool -> Bool
not ([Declaration] -> Bool
forall a. Null a => a -> Bool
null [Declaration]
fits)
               ] of

            -- case: clauses match none of the sigs
            [] -> case LHS
lhs of
              -- Subcase: The lhs is single identifier (potentially anonymous).
              -- Treat it as a function clause without a type signature.
              LHS Pattern
p [] [] ExpandedEllipsis
_ | Just Name
x <- Pattern -> Maybe Name
isSingleIdentifierP Pattern
p -> do
                [NiceDeclaration]
d  <- ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> TacticAttribute
-> [Declaration]
-> Nice [NiceDeclaration]
mkFunDef ArgInfo
defaultArgInfo TerminationCheck
termCheck CoverageCheck
covCheck Name
x TacticAttribute
forall a. Maybe a
Nothing [Declaration
d] -- fun def without type signature is relevant
                ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NiceDeclaration]
d , [Declaration]
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
              LHS
_ -> do
                ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> Access
-> IsAbstract
-> TerminationCheck
-> CoverageCheck
-> Bool
-> Declaration
-> NiceDeclaration
NiceFunClause (Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
d) Access
PublicAccess IsAbstract
ConcreteDef TerminationCheck
termCheck CoverageCheck
covCheck Bool
catchall Declaration
d] , [Declaration]
ds)

            -- case: clauses match exactly one of the sigs
            [(Name
x,([Declaration]
fits,[Declaration]
rest))] -> do
               Name -> Nice ()
removeLoneSig Name
x
               [Declaration]
ds  <- [Declaration] -> Nice [Declaration]
expandEllipsis [Declaration]
fits
               [Clause]
cs  <- Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
ds Bool
False
               ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
FunDef ([Declaration] -> Range
forall t. HasRange t => t -> Range
getRange [Declaration]
fits) [Declaration]
fits IsAbstract
ConcreteDef IsInstance
NotInstanceDef TerminationCheck
termCheck CoverageCheck
covCheck Name
x [Clause]
cs] , [Declaration]
rest)

            -- case: clauses match more than one sigs (ambiguity)
            [(Name, ([Declaration], [Declaration]))]
l -> DeclarationException -> Nice ([NiceDeclaration], [Declaration])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationException -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ LHS -> [Name] -> DeclarationException
AmbiguousFunClauses LHS
lhs ([Name] -> DeclarationException) -> [Name] -> DeclarationException
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((Name, ([Declaration], [Declaration])) -> Name)
-> [(Name, ([Declaration], [Declaration]))] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, ([Declaration], [Declaration])) -> Name
forall a b. (a, b) -> a
fst [(Name, ([Declaration], [Declaration]))]
l
                 -- "ambiguous function clause; cannot assign it uniquely to one type signature"

        Field Range
r [] -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyField Range
r
        Field Range
_ [Declaration]
fs -> (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
FieldBlock [Declaration]
fs

        DataSig Range
r Name
x [LamBinding]
tel Expr
t -> do
          PositivityCheck
pc <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
          UniverseCheck
uc <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
          Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig Range
r Name
x (DataRecOrFun -> Nice ()) -> DataRecOrFun -> Nice ()
forall a b. (a -> b) -> a -> b
$ PositivityCheck -> UniverseCheck -> DataRecOrFun
DataName PositivityCheck
pc UniverseCheck
uc
          (,) ([NiceDeclaration]
 -> [Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [NiceDeclaration]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([Declaration] -> Nice [NiceDeclaration])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [Declaration])
-> Nice [NiceDeclaration]
forall a decl.
PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [decl]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([a] -> Nice [decl])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [a])
-> Nice [NiceDeclaration]
dataOrRec PositivityCheck
pc UniverseCheck
uc Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> [NiceDeclaration]
-> NiceDeclaration
NiceDataDef Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceDataSig (KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
DataBlock) Range
r Name
x (([LamBinding], Expr) -> Maybe ([LamBinding], Expr)
forall a. a -> Maybe a
Just ([LamBinding]
tel, Expr
t)) Maybe ([LamBinding], [Declaration])
forall a. Maybe a
Nothing
              Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [Declaration] -> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds

        Data Range
r Name
x [LamBinding]
tel Expr
t [Declaration]
cs -> do
          PositivityCheck
pc <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
          -- Andreas, 2018-10-27, issue #3327
          -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.
          -- Universe check is performed if both the current value of
          -- 'universeCheckPragma' AND the one from the signature say so.
          UniverseCheck
uc <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
          UniverseCheck
uc <- if UniverseCheck
uc UniverseCheck -> UniverseCheck -> Bool
forall a. Eq a => a -> a -> Bool
== UniverseCheck
NoUniverseCheck then UniverseCheck -> Nice UniverseCheck
forall (m :: * -> *) a. Monad m => a -> m a
return UniverseCheck
uc else Name -> Nice UniverseCheck
getUniverseCheckFromSig Name
x
          TacticAttribute
mt <- DataRecOrFun -> Name -> TacticAttribute -> Nice TacticAttribute
defaultTypeSig (PositivityCheck -> UniverseCheck -> DataRecOrFun
DataName PositivityCheck
pc UniverseCheck
uc) Name
x (Expr -> TacticAttribute
forall a. a -> Maybe a
Just Expr
t)
          (,) ([NiceDeclaration]
 -> [Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [NiceDeclaration]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([Declaration] -> Nice [NiceDeclaration])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [Declaration])
-> Nice [NiceDeclaration]
forall a decl.
PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [decl]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([a] -> Nice [decl])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [a])
-> Nice [NiceDeclaration]
dataOrRec PositivityCheck
pc UniverseCheck
uc Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> [NiceDeclaration]
-> NiceDeclaration
NiceDataDef Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceDataSig (KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
DataBlock) Range
r Name
x (([LamBinding]
tel,) (Expr -> ([LamBinding], Expr))
-> TacticAttribute -> Maybe ([LamBinding], Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TacticAttribute
mt) (([LamBinding], [Declaration])
-> Maybe ([LamBinding], [Declaration])
forall a. a -> Maybe a
Just ([LamBinding]
tel, [Declaration]
cs))
              Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [Declaration] -> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds

        DataDef Range
r Name
x [LamBinding]
tel [Declaration]
cs -> do
          PositivityCheck
pc <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
          -- Andreas, 2018-10-27, issue #3327
          -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.
          -- Universe check is performed if both the current value of
          -- 'universeCheckPragma' AND the one from the signature say so.
          UniverseCheck
uc <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
          UniverseCheck
uc <- if UniverseCheck
uc UniverseCheck -> UniverseCheck -> Bool
forall a. Eq a => a -> a -> Bool
== UniverseCheck
NoUniverseCheck then UniverseCheck -> Nice UniverseCheck
forall (m :: * -> *) a. Monad m => a -> m a
return UniverseCheck
uc else Name -> Nice UniverseCheck
getUniverseCheckFromSig Name
x
          TacticAttribute
mt <- DataRecOrFun -> Name -> TacticAttribute -> Nice TacticAttribute
defaultTypeSig (PositivityCheck -> UniverseCheck -> DataRecOrFun
DataName PositivityCheck
pc UniverseCheck
uc) Name
x TacticAttribute
forall a. Maybe a
Nothing
          (,) ([NiceDeclaration]
 -> [Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [NiceDeclaration]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([Declaration] -> Nice [NiceDeclaration])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [Declaration])
-> Nice [NiceDeclaration]
forall a decl.
PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [decl]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([a] -> Nice [decl])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [a])
-> Nice [NiceDeclaration]
dataOrRec PositivityCheck
pc UniverseCheck
uc Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> [NiceDeclaration]
-> NiceDeclaration
NiceDataDef Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceDataSig (KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
DataBlock) Range
r Name
x (([LamBinding]
tel,) (Expr -> ([LamBinding], Expr))
-> TacticAttribute -> Maybe ([LamBinding], Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TacticAttribute
mt) (([LamBinding], [Declaration])
-> Maybe ([LamBinding], [Declaration])
forall a. a -> Maybe a
Just ([LamBinding]
tel, [Declaration]
cs))
              Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [Declaration] -> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds

        RecordSig Range
r Name
x [LamBinding]
tel Expr
t         -> do
          PositivityCheck
pc <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
          UniverseCheck
uc <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
          Range -> Name -> DataRecOrFun -> Nice ()
addLoneSig Range
r Name
x (DataRecOrFun -> Nice ()) -> DataRecOrFun -> Nice ()
forall a b. (a -> b) -> a -> b
$ PositivityCheck -> UniverseCheck -> DataRecOrFun
RecName PositivityCheck
pc UniverseCheck
uc
          ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceRecSig Range
r Access
PublicAccess IsAbstract
ConcreteDef PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
tel Expr
t] , [Declaration]
ds)

        Record Range
r Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
tel Expr
t [Declaration]
cs   -> do
          PositivityCheck
pc <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
          -- Andreas, 2018-10-27, issue #3327
          -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.
          -- Universe check is performed if both the current value of
          -- 'universeCheckPragma' AND the one from the signature say so.
          UniverseCheck
uc <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
          UniverseCheck
uc <- if UniverseCheck
uc UniverseCheck -> UniverseCheck -> Bool
forall a. Eq a => a -> a -> Bool
== UniverseCheck
NoUniverseCheck then UniverseCheck -> Nice UniverseCheck
forall (m :: * -> *) a. Monad m => a -> m a
return UniverseCheck
uc else Name -> Nice UniverseCheck
getUniverseCheckFromSig Name
x
          TacticAttribute
mt <- DataRecOrFun -> Name -> TacticAttribute -> Nice TacticAttribute
defaultTypeSig (PositivityCheck -> UniverseCheck -> DataRecOrFun
RecName PositivityCheck
pc UniverseCheck
uc) Name
x (Expr -> TacticAttribute
forall a. a -> Maybe a
Just Expr
t)
          (,) ([NiceDeclaration]
 -> [Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [Declaration]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([Declaration] -> Nice [Declaration])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [Declaration])
-> Nice [NiceDeclaration]
forall a decl.
PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [decl]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([a] -> Nice [decl])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [a])
-> Nice [NiceDeclaration]
dataOrRec PositivityCheck
pc UniverseCheck
uc (\ Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
tel [Declaration]
cs -> Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> [Declaration]
-> NiceDeclaration
NiceRecDef Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
tel [Declaration]
cs) Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceRecSig
                    [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return Range
r Name
x (([LamBinding]
tel,) (Expr -> ([LamBinding], Expr))
-> TacticAttribute -> Maybe ([LamBinding], Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TacticAttribute
mt) (([LamBinding], [Declaration])
-> Maybe ([LamBinding], [Declaration])
forall a. a -> Maybe a
Just ([LamBinding]
tel, [Declaration]
cs))
              Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [Declaration] -> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds

        RecordDef Range
r Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
tel [Declaration]
cs   -> do
          PositivityCheck
pc <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
          -- Andreas, 2018-10-27, issue #3327
          -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.
          -- Universe check is performed if both the current value of
          -- 'universeCheckPragma' AND the one from the signature say so.
          UniverseCheck
uc <- Lens' UniverseCheck NiceEnv -> Nice UniverseCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' UniverseCheck NiceEnv
universeCheckPragma
          UniverseCheck
uc <- if UniverseCheck
uc UniverseCheck -> UniverseCheck -> Bool
forall a. Eq a => a -> a -> Bool
== UniverseCheck
NoUniverseCheck then UniverseCheck -> Nice UniverseCheck
forall (m :: * -> *) a. Monad m => a -> m a
return UniverseCheck
uc else Name -> Nice UniverseCheck
getUniverseCheckFromSig Name
x
          TacticAttribute
mt <- DataRecOrFun -> Name -> TacticAttribute -> Nice TacticAttribute
defaultTypeSig (PositivityCheck -> UniverseCheck -> DataRecOrFun
RecName PositivityCheck
pc UniverseCheck
uc) Name
x TacticAttribute
forall a. Maybe a
Nothing
          (,) ([NiceDeclaration]
 -> [Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [Declaration]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([Declaration] -> Nice [Declaration])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [Declaration])
-> Nice [NiceDeclaration]
forall a decl.
PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [decl]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([a] -> Nice [decl])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [a])
-> Nice [NiceDeclaration]
dataOrRec PositivityCheck
pc UniverseCheck
uc (\ Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
tel [Declaration]
cs -> Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> [Declaration]
-> NiceDeclaration
NiceRecDef Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
tel [Declaration]
cs) Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceRecSig
                    [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return Range
r Name
x (([LamBinding]
tel,) (Expr -> ([LamBinding], Expr))
-> TacticAttribute -> Maybe ([LamBinding], Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TacticAttribute
mt) (([LamBinding], [Declaration])
-> Maybe ([LamBinding], [Declaration])
forall a. a -> Maybe a
Just ([LamBinding]
tel, [Declaration]
cs))
              Nice ([Declaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [Declaration] -> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds

        Mutual Range
r [Declaration]
ds' -> do
          -- The lone signatures encountered so far are not in scope
          -- for the mutual definition
          Nice ()
forgetLoneSigs
          case [Declaration]
ds' of
            [] -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyMutual Range
r
            [Declaration]
_  -> (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NiceDeclaration -> [NiceDeclaration]
forall el coll. Singleton el coll => el -> coll
singleton (NiceDeclaration -> [NiceDeclaration])
-> Nice NiceDeclaration -> Nice [NiceDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range -> [NiceDeclaration] -> Nice NiceDeclaration
mkOldMutual Range
r ([NiceDeclaration] -> Nice NiceDeclaration)
-> Nice [NiceDeclaration] -> Nice NiceDeclaration
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ds'))

        Abstract Range
r []  -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyAbstract Range
r
        Abstract Range
r [Declaration]
ds' ->
          (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range -> [NiceDeclaration] -> Nice [NiceDeclaration]
forall a. MakeAbstract a => Range -> [a] -> Nice [a]
abstractBlock Range
r ([NiceDeclaration] -> Nice [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ds')

        Private Range
r Origin
UserWritten []  -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyPrivate Range
r
        Private Range
r Origin
o [Declaration]
ds' ->
          (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range -> Origin -> [NiceDeclaration] -> Nice [NiceDeclaration]
forall a. MakePrivate a => Range -> Origin -> [a] -> Nice [a]
privateBlock Range
r Origin
o ([NiceDeclaration] -> Nice [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ds')

        InstanceB Range
r []  -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyInstance Range
r
        InstanceB Range
r [Declaration]
ds' ->
          (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range -> [NiceDeclaration] -> Nice [NiceDeclaration]
instanceBlock Range
r ([NiceDeclaration] -> Nice [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ds')

        Macro Range
r []  -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyMacro Range
r
        Macro Range
r [Declaration]
ds' ->
          (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range -> [NiceDeclaration] -> Nice [NiceDeclaration]
forall (t :: * -> *) p.
Traversable t =>
p -> t NiceDeclaration -> Nice (t NiceDeclaration)
macroBlock Range
r ([NiceDeclaration] -> Nice [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Declaration] -> Nice [NiceDeclaration]
nice [Declaration]
ds')

        Postulate Range
r []  -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyPostulate Range
r
        Postulate Range
_ [Declaration]
ds' ->
          (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
PostulateBlock [Declaration]
ds'

        Primitive Range
r []  -> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
justWarning (DeclarationWarning -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationWarning -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
EmptyPrimitive Range
r
        Primitive Range
_ [Declaration]
ds' -> (,[Declaration]
ds) ([NiceDeclaration] -> ([NiceDeclaration], [Declaration]))
-> Nice [NiceDeclaration]
-> Nice ([NiceDeclaration], [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NiceDeclaration -> NiceDeclaration)
-> [NiceDeclaration] -> [NiceDeclaration]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> NiceDeclaration
toPrim ([NiceDeclaration] -> [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
PrimitiveBlock [Declaration]
ds')

        Module Range
r QName
x Telescope
tel [Declaration]
ds' -> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$
          ([Range
-> Access
-> IsAbstract
-> QName
-> Telescope
-> [Declaration]
-> NiceDeclaration
NiceModule Range
r Access
PublicAccess IsAbstract
ConcreteDef QName
x Telescope
tel [Declaration]
ds'] , [Declaration]
ds)

        ModuleMacro Range
r Name
x ModuleApplication
modapp OpenShortHand
op ImportDirective
is -> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$
          ([Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
NiceModuleMacro Range
r Access
PublicAccess Name
x ModuleApplication
modapp OpenShortHand
op ImportDirective
is] , [Declaration]
ds)

        -- Fixity and syntax declarations and polarity pragmas have
        -- already been processed.
        Infix Fixity
_ [Name]
_  -> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Declaration]
ds)
        Syntax Name
_ Notation
_ -> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Declaration]
ds)

        PatternSyn Range
r Name
n [Arg Name]
as Pattern
p -> do
          ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range -> Access -> Name -> [Arg Name] -> Pattern -> NiceDeclaration
NicePatternSyn Range
r Access
PublicAccess Name
n [Arg Name]
as Pattern
p] , [Declaration]
ds)
        Open Range
r QName
x ImportDirective
is         -> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range -> QName -> ImportDirective -> NiceDeclaration
NiceOpen Range
r QName
x ImportDirective
is] , [Declaration]
ds)
        Import Range
r QName
x Maybe AsName
as OpenShortHand
op ImportDirective
is -> ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
NiceImport Range
r QName
x Maybe AsName
as OpenShortHand
op ImportDirective
is] , [Declaration]
ds)

        UnquoteDecl Range
r [Name]
xs Expr
e -> do
          TerminationCheck
tc <- Lens' TerminationCheck NiceEnv -> Nice TerminationCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' TerminationCheck NiceEnv
terminationCheckPragma
          CoverageCheck
cc <- Lens' CoverageCheck NiceEnv -> Nice CoverageCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' CoverageCheck NiceEnv
coverageCheckPragma
          ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> Access
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDecl Range
r Access
PublicAccess IsAbstract
ConcreteDef IsInstance
NotInstanceDef TerminationCheck
tc CoverageCheck
cc [Name]
xs Expr
e] , [Declaration]
ds)

        UnquoteDef Range
r [Name]
xs Expr
e -> do
          [Name]
sigs <- LoneSigs -> [Name]
loneFuns (LoneSigs -> [Name]) -> Nice LoneSigs -> Nice [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' LoneSigs NiceEnv -> Nice LoneSigs
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' LoneSigs NiceEnv
loneSigs
          let missing :: [Name]
missing = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
sigs) [Name]
xs
          if [Name] -> Bool
forall a. Null a => a -> Bool
null [Name]
missing
            then do
              (Name -> Nice ()) -> [Name] -> Nice ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> Nice ()
removeLoneSig [Name]
xs
              ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range
-> Access
-> IsAbstract
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDef Range
r Access
PublicAccess IsAbstract
ConcreteDef TerminationCheck
forall m. TerminationCheck m
TerminationCheck CoverageCheck
YesCoverageCheck [Name]
xs Expr
e] , [Declaration]
ds)
            else DeclarationException -> Nice ([NiceDeclaration], [Declaration])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice ([NiceDeclaration], [Declaration]))
-> DeclarationException -> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Name] -> DeclarationException
UnquoteDefRequiresSignature [Name]
missing

        Pragma Pragma
p -> Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nicePragma Pragma
p [Declaration]
ds

    nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])

    nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nicePragma (TerminationCheckPragma Range
r (TerminationMeasure Range
_ Name
x)) [Declaration]
ds =
      if [Declaration] -> Bool
canHaveTerminationMeasure [Declaration]
ds then
        TerminationCheck
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a. TerminationCheck -> Nice a -> Nice a
withTerminationCheckPragma (Range -> Name -> TerminationCheck
forall m. Range -> m -> TerminationCheck m
TerminationMeasure Range
r Name
x) (Nice ([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidTerminationCheckPragma Range
r
        [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

    nicePragma (TerminationCheckPragma Range
r TerminationCheck
NoTerminationCheck) [Declaration]
ds = do
      -- This PRAGMA has been deprecated in favour of (NON_)TERMINATING
      -- We warn the user about it and then assume the function is NON_TERMINATING.
      DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
PragmaNoTerminationCheck Range
r
      Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nicePragma (Range -> TerminationCheck -> Pragma
TerminationCheckPragma Range
r TerminationCheck
forall m. TerminationCheck m
NonTerminating) [Declaration]
ds

    nicePragma (TerminationCheckPragma Range
r TerminationCheck
tc) [Declaration]
ds =
      if [Declaration] -> Bool
canHaveTerminationCheckPragma [Declaration]
ds then
        TerminationCheck
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a. TerminationCheck -> Nice a -> Nice a
withTerminationCheckPragma TerminationCheck
tc (Nice ([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidTerminationCheckPragma Range
r
        [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

    nicePragma (NoCoverageCheckPragma Range
r) [Declaration]
ds =
      if [Declaration] -> Bool
canHaveCoverageCheckPragma [Declaration]
ds then
        CoverageCheck
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a. CoverageCheck -> Nice a -> Nice a
withCoverageCheckPragma CoverageCheck
NoCoverageCheck (Nice ([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidCoverageCheckPragma Range
r
        [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

    nicePragma (CatchallPragma Range
r) [Declaration]
ds =
      if [Declaration] -> Bool
canHaveCatchallPragma [Declaration]
ds then
        Bool
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a. Bool -> Nice a -> Nice a
withCatchallPragma Bool
True (Nice ([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidCatchallPragma Range
r
        [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

    nicePragma (NoPositivityCheckPragma Range
r) [Declaration]
ds =
      if [Declaration] -> Bool
canHaveNoPositivityCheckPragma [Declaration]
ds then
        PositivityCheck
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a. PositivityCheck -> Nice a -> Nice a
withPositivityCheckPragma PositivityCheck
NoPositivityCheck (Nice ([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidNoPositivityCheckPragma Range
r
        [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

    nicePragma (NoUniverseCheckPragma Range
r) [Declaration]
ds =
      if [Declaration] -> Bool
canHaveNoUniverseCheckPragma [Declaration]
ds then
        UniverseCheck
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a. UniverseCheck -> Nice a -> Nice a
withUniverseCheckPragma UniverseCheck
NoUniverseCheck (Nice ([NiceDeclaration], [Declaration])
 -> Nice ([NiceDeclaration], [Declaration]))
-> Nice ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall a b. (a -> b) -> a -> b
$ [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds
      else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidNoUniverseCheckPragma Range
r
        [Declaration] -> Nice ([NiceDeclaration], [Declaration])
nice1 [Declaration]
ds

    nicePragma p :: Pragma
p@CompilePragma{} [Declaration]
ds = do
      DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
PragmaCompiled (Pragma -> Range
forall t. HasRange t => t -> Range
getRange Pragma
p)
      ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range -> Pragma -> NiceDeclaration
NicePragma (Pragma -> Range
forall t. HasRange t => t -> Range
getRange Pragma
p) Pragma
p], [Declaration]
ds)

    nicePragma (PolarityPragma{}) [Declaration]
ds = ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Declaration]
ds)

    nicePragma (BuiltinPragma Range
r RString
str qn :: QName
qn@(QName Name
x)) [Declaration]
ds = do
      ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range -> Pragma -> NiceDeclaration
NicePragma Range
r (Range -> RString -> QName -> Pragma
BuiltinPragma Range
r RString
str QName
qn)], [Declaration]
ds)

    nicePragma Pragma
p [Declaration]
ds = ([NiceDeclaration], [Declaration])
-> Nice ([NiceDeclaration], [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Range -> Pragma -> NiceDeclaration
NicePragma (Pragma -> Range
forall t. HasRange t => t -> Range
getRange Pragma
p) Pragma
p], [Declaration]
ds)

    canHaveTerminationMeasure :: [Declaration] -> Bool
    canHaveTerminationMeasure :: [Declaration] -> Bool
canHaveTerminationMeasure [] = Bool
False
    canHaveTerminationMeasure (Declaration
d:[Declaration]
ds) = case Declaration
d of
      TypeSig{} -> Bool
True
      (Pragma Pragma
p) | Pragma -> Bool
isAttachedPragma Pragma
p -> [Declaration] -> Bool
canHaveTerminationMeasure [Declaration]
ds
      Declaration
_         -> Bool
False

    canHaveTerminationCheckPragma :: [Declaration] -> Bool
    canHaveTerminationCheckPragma :: [Declaration] -> Bool
canHaveTerminationCheckPragma []     = Bool
False
    canHaveTerminationCheckPragma (Declaration
d:[Declaration]
ds) = case Declaration
d of
      Mutual Range
_ [Declaration]
ds   -> (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Declaration] -> Bool
canHaveTerminationCheckPragma ([Declaration] -> Bool)
-> (Declaration -> [Declaration]) -> Declaration -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton) [Declaration]
ds
      TypeSig{}     -> Bool
True
      FunClause{}   -> Bool
True
      UnquoteDecl{} -> Bool
True
      (Pragma Pragma
p) | Pragma -> Bool
isAttachedPragma Pragma
p -> [Declaration] -> Bool
canHaveTerminationCheckPragma [Declaration]
ds
      Declaration
_             -> Bool
False

    canHaveCoverageCheckPragma :: [Declaration] -> Bool
    canHaveCoverageCheckPragma :: [Declaration] -> Bool
canHaveCoverageCheckPragma = [Declaration] -> Bool
canHaveTerminationCheckPragma

    canHaveCatchallPragma :: [Declaration] -> Bool
    canHaveCatchallPragma :: [Declaration] -> Bool
canHaveCatchallPragma []     = Bool
False
    canHaveCatchallPragma (Declaration
d:[Declaration]
ds) = case Declaration
d of
      FunClause{} -> Bool
True
      (Pragma Pragma
p) | Pragma -> Bool
isAttachedPragma Pragma
p -> [Declaration] -> Bool
canHaveCatchallPragma [Declaration]
ds
      Declaration
_           -> Bool
False

    canHaveNoPositivityCheckPragma :: [Declaration] -> Bool
    canHaveNoPositivityCheckPragma :: [Declaration] -> Bool
canHaveNoPositivityCheckPragma []     = Bool
False
    canHaveNoPositivityCheckPragma (Declaration
d:[Declaration]
ds) = case Declaration
d of
      Mutual Range
_ [Declaration]
ds                   -> (Declaration -> Bool) -> [Declaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Declaration] -> Bool
canHaveNoPositivityCheckPragma ([Declaration] -> Bool)
-> (Declaration -> [Declaration]) -> Declaration -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> [Declaration]
forall el coll. Singleton el coll => el -> coll
singleton) [Declaration]
ds
      Data{}                        -> Bool
True
      DataSig{}                     -> Bool
True
      DataDef{}                     -> Bool
True
      Record{}                      -> Bool
True
      RecordSig{}                   -> Bool
True
      RecordDef{}                   -> Bool
True
      Pragma Pragma
p | Pragma -> Bool
isAttachedPragma Pragma
p -> [Declaration] -> Bool
canHaveNoPositivityCheckPragma [Declaration]
ds
      Declaration
_                             -> Bool
False

    canHaveNoUniverseCheckPragma :: [Declaration] -> Bool
    canHaveNoUniverseCheckPragma :: [Declaration] -> Bool
canHaveNoUniverseCheckPragma []     = Bool
False
    canHaveNoUniverseCheckPragma (Declaration
d:[Declaration]
ds) = case Declaration
d of
      Data{}                        -> Bool
True
      DataSig{}                     -> Bool
True
      DataDef{}                     -> Bool
True
      Record{}                      -> Bool
True
      RecordSig{}                   -> Bool
True
      RecordDef{}                   -> Bool
True
      Pragma Pragma
p | Pragma -> Bool
isAttachedPragma Pragma
p -> [Declaration] -> Bool
canHaveNoPositivityCheckPragma [Declaration]
ds
      Declaration
_                             -> Bool
False

    -- Pragma that attaches to the following declaration.
    isAttachedPragma :: Pragma -> Bool
    isAttachedPragma :: Pragma -> Bool
isAttachedPragma Pragma
p = case Pragma
p of
      TerminationCheckPragma{}  -> Bool
True
      CatchallPragma{}          -> Bool
True
      NoPositivityCheckPragma{} -> Bool
True
      NoUniverseCheckPragma{}   -> Bool
True
      Pragma
_                         -> Bool
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.
    defaultTypeSig :: DataRecOrFun -> Name -> Maybe Expr -> Nice (Maybe Expr)
    defaultTypeSig :: DataRecOrFun -> Name -> TacticAttribute -> Nice TacticAttribute
defaultTypeSig DataRecOrFun
k Name
x t :: TacticAttribute
t@Just{} = TacticAttribute -> Nice TacticAttribute
forall (m :: * -> *) a. Monad m => a -> m a
return TacticAttribute
t
    defaultTypeSig DataRecOrFun
k Name
x TacticAttribute
Nothing  = do
      Nice (Maybe DataRecOrFun)
-> Nice TacticAttribute
-> (DataRecOrFun -> Nice TacticAttribute)
-> Nice TacticAttribute
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Name -> Nice (Maybe DataRecOrFun)
getSig Name
x) (TacticAttribute -> Nice TacticAttribute
forall (m :: * -> *) a. Monad m => a -> m a
return TacticAttribute
forall a. Maybe a
Nothing) ((DataRecOrFun -> Nice TacticAttribute) -> Nice TacticAttribute)
-> (DataRecOrFun -> Nice TacticAttribute) -> Nice TacticAttribute
forall a b. (a -> b) -> a -> b
$ \ DataRecOrFun
k' -> do
        Bool -> Nice () -> Nice ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DataRecOrFun -> DataRecOrFun -> Bool
sameKind DataRecOrFun
k DataRecOrFun
k') (Nice () -> Nice ()) -> Nice () -> Nice ()
forall a b. (a -> b) -> a -> b
$ DeclarationException -> Nice ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice ())
-> DeclarationException -> Nice ()
forall a b. (a -> b) -> a -> b
$ Name -> DataRecOrFun -> DataRecOrFun -> DeclarationException
WrongDefinition Name
x DataRecOrFun
k' DataRecOrFun
k
        TacticAttribute
forall a. Maybe a
Nothing TacticAttribute -> Nice () -> Nice TacticAttribute
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Nice ()
removeLoneSig Name
x

    dataOrRec
      :: forall a decl
      .  PositivityCheck
      -> UniverseCheck
      -> (Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [decl] -> NiceDeclaration)
         -- ^ Construct definition.
      -> (Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration)
         -- ^ Construct signature.
      -> ([a] -> Nice [decl])
         -- ^ Constructor checking.
      -> Range
      -> Name          -- ^ Data/record type name.
      -> Maybe ([LamBinding], Expr)    -- ^ Parameters and type.  If not @Nothing@ a signature is created.
      -> Maybe ([LamBinding], [a])     -- ^ Parameters and constructors.  If not @Nothing@, a definition body is created.
      -> Nice [NiceDeclaration]
    dataOrRec :: PositivityCheck
-> UniverseCheck
-> (Range
    -> Origin
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> [decl]
    -> NiceDeclaration)
-> (Range
    -> Access
    -> IsAbstract
    -> PositivityCheck
    -> UniverseCheck
    -> Name
    -> [LamBinding]
    -> Expr
    -> NiceDeclaration)
-> ([a] -> Nice [decl])
-> Range
-> Name
-> Maybe ([LamBinding], Expr)
-> Maybe ([LamBinding], [a])
-> Nice [NiceDeclaration]
dataOrRec PositivityCheck
pc UniverseCheck
uc Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> [decl]
-> NiceDeclaration
mkDef Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
mkSig [a] -> Nice [decl]
niceD Range
r Name
x Maybe ([LamBinding], Expr)
mt Maybe ([LamBinding], [a])
mcs = do
      Maybe ([LamBinding], [decl])
mds <- Maybe ([LamBinding], [a])
-> (([LamBinding], [a]) -> Nice ([LamBinding], [decl]))
-> Nice (Maybe ([LamBinding], [decl]))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Trav.forM Maybe ([LamBinding], [a])
mcs ((([LamBinding], [a]) -> Nice ([LamBinding], [decl]))
 -> Nice (Maybe ([LamBinding], [decl])))
-> (([LamBinding], [a]) -> Nice ([LamBinding], [decl]))
-> Nice (Maybe ([LamBinding], [decl]))
forall a b. (a -> b) -> a -> b
$ \ ([LamBinding]
tel, [a]
cs) -> ([LamBinding]
tel,) ([decl] -> ([LamBinding], [decl]))
-> Nice [decl] -> Nice ([LamBinding], [decl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Nice [decl]
niceD [a]
cs
      -- We set origin to UserWritten if the user split the data/rec herself,
      -- and to Inserted if the she wrote a single declaration that we're
      -- splitting up here. We distinguish these because the scoping rules for
      -- generalizable variables differ in these cases.
      let o :: Origin
o | Maybe ([LamBinding], Expr) -> Bool
forall a. Maybe a -> Bool
isJust Maybe ([LamBinding], Expr)
mt Bool -> Bool -> Bool
&& Maybe ([LamBinding], [a]) -> Bool
forall a. Maybe a -> Bool
isJust Maybe ([LamBinding], [a])
mcs = Origin
Inserted
            | Bool
otherwise               = Origin
UserWritten
      [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return ([NiceDeclaration] -> Nice [NiceDeclaration])
-> [NiceDeclaration] -> Nice [NiceDeclaration]
forall a b. (a -> b) -> a -> b
$ [Maybe NiceDeclaration] -> [NiceDeclaration]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe NiceDeclaration] -> [NiceDeclaration])
-> [Maybe NiceDeclaration] -> [NiceDeclaration]
forall a b. (a -> b) -> a -> b
$
        [ Maybe ([LamBinding], Expr)
mt  Maybe ([LamBinding], Expr)
-> (([LamBinding], Expr) -> NiceDeclaration)
-> Maybe NiceDeclaration
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ ([LamBinding]
tel, Expr
t)  -> Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
mkSig (Name -> Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange Name
x Expr
t) Access
PublicAccess IsAbstract
ConcreteDef PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
tel Expr
t
        , Maybe ([LamBinding], [decl])
mds Maybe ([LamBinding], [decl])
-> (([LamBinding], [decl]) -> NiceDeclaration)
-> Maybe NiceDeclaration
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ ([LamBinding]
tel, [decl]
ds) -> Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> [decl]
-> NiceDeclaration
mkDef Range
r Origin
o IsAbstract
ConcreteDef PositivityCheck
pc UniverseCheck
uc Name
x (Maybe ([LamBinding], Expr)
-> [LamBinding]
-> (([LamBinding], Expr) -> [LamBinding])
-> [LamBinding]
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ([LamBinding], Expr)
mt [LamBinding]
tel ((([LamBinding], Expr) -> [LamBinding]) -> [LamBinding])
-> (([LamBinding], Expr) -> [LamBinding]) -> [LamBinding]
forall a b. (a -> b) -> a -> b
$ [LamBinding] -> ([LamBinding], Expr) -> [LamBinding]
forall a b. a -> b -> a
const ([LamBinding] -> ([LamBinding], Expr) -> [LamBinding])
-> [LamBinding] -> ([LamBinding], Expr) -> [LamBinding]
forall a b. (a -> b) -> a -> b
$ (LamBinding -> [LamBinding]) -> [LamBinding] -> [LamBinding]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LamBinding -> [LamBinding]
dropTypeAndModality [LamBinding]
tel) [decl]
ds
          -- If a type is given (mt /= Nothing), we have to delete the types in @tel@
          -- for the data definition, lest we duplicate them. And also drop modalities (#1886).
        ]
      where
        -- | Drop type annotations and lets from bindings.
        dropTypeAndModality :: LamBinding -> [LamBinding]
        dropTypeAndModality :: LamBinding -> [LamBinding]
dropTypeAndModality (DomainFull (TBind Range
_ [NamedArg Binder]
xs Expr
_)) =
          (NamedArg Binder -> LamBinding)
-> [NamedArg Binder] -> [LamBinding]
forall a b. (a -> b) -> [a] -> [b]
map (NamedArg Binder -> LamBinding
forall a. NamedArg Binder -> LamBinding' a
DomainFree (NamedArg Binder -> LamBinding)
-> (NamedArg Binder -> NamedArg Binder)
-> NamedArg Binder
-> LamBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modality -> NamedArg Binder -> NamedArg Binder
forall a. LensModality a => Modality -> a -> a
setModality Modality
defaultModality) [NamedArg Binder]
xs
        dropTypeAndModality (DomainFull TLet{}) = []
        dropTypeAndModality (DomainFree NamedArg Binder
x) = [NamedArg Binder -> LamBinding
forall a. NamedArg Binder -> LamBinding' a
DomainFree (NamedArg Binder -> LamBinding) -> NamedArg Binder -> LamBinding
forall a b. (a -> b) -> a -> b
$ Modality -> NamedArg Binder -> NamedArg Binder
forall a. LensModality a => Modality -> a -> a
setModality Modality
defaultModality NamedArg Binder
x]

    -- Translate axioms
    niceAxioms :: KindOfBlock -> [TypeSignatureOrInstanceBlock] -> Nice [NiceDeclaration]
    niceAxioms :: KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
b [Declaration]
ds = ([[NiceDeclaration]] -> [NiceDeclaration])
-> Nice [[NiceDeclaration]] -> Nice [NiceDeclaration]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[NiceDeclaration]] -> [NiceDeclaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat (Nice [[NiceDeclaration]] -> Nice [NiceDeclaration])
-> Nice [[NiceDeclaration]] -> Nice [NiceDeclaration]
forall a b. (a -> b) -> a -> b
$ (Declaration -> Nice [NiceDeclaration])
-> [Declaration] -> Nice [[NiceDeclaration]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (KindOfBlock -> Declaration -> Nice [NiceDeclaration]
niceAxiom KindOfBlock
b) [Declaration]
ds

    niceAxiom :: KindOfBlock -> TypeSignatureOrInstanceBlock -> Nice [NiceDeclaration]
    niceAxiom :: KindOfBlock -> Declaration -> Nice [NiceDeclaration]
niceAxiom KindOfBlock
b Declaration
d = case Declaration
d of
      TypeSig ArgInfo
rel TacticAttribute
_tac Name
x Expr
t -> do
        [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom (Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
d) Access
PublicAccess IsAbstract
ConcreteDef IsInstance
NotInstanceDef ArgInfo
rel Name
x Expr
t ]
      FieldSig IsInstance
i TacticAttribute
tac Name
x Arg Expr
argt | KindOfBlock
b KindOfBlock -> KindOfBlock -> Bool
forall a. Eq a => a -> a -> Bool
== KindOfBlock
FieldBlock -> do
        [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> Access
-> IsAbstract
-> IsInstance
-> TacticAttribute
-> Name
-> Arg Expr
-> NiceDeclaration
NiceField (Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
d) Access
PublicAccess IsAbstract
ConcreteDef IsInstance
i TacticAttribute
tac Name
x Arg Expr
argt ]
      InstanceB Range
r [Declaration]
decls -> do
        Range -> [NiceDeclaration] -> Nice [NiceDeclaration]
instanceBlock Range
r ([NiceDeclaration] -> Nice [NiceDeclaration])
-> Nice [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KindOfBlock -> [Declaration] -> Nice [NiceDeclaration]
niceAxioms KindOfBlock
InstanceBlock [Declaration]
decls
      Pragma p :: Pragma
p@(RewritePragma Range
r Range
_ [QName]
_) -> do
        [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range -> Pragma -> NiceDeclaration
NicePragma Range
r Pragma
p ]
      Declaration
_ -> DeclarationException -> Nice [NiceDeclaration]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice [NiceDeclaration])
-> DeclarationException -> Nice [NiceDeclaration]
forall a b. (a -> b) -> a -> b
$ KindOfBlock -> Range -> DeclarationException
WrongContentBlock KindOfBlock
b (Range -> DeclarationException) -> Range -> DeclarationException
forall a b. (a -> b) -> a -> b
$ Declaration -> Range
forall t. HasRange t => t -> Range
getRange Declaration
d

    toPrim :: NiceDeclaration -> NiceDeclaration
    toPrim :: NiceDeclaration -> NiceDeclaration
toPrim (Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
t) = Range -> Access -> IsAbstract -> Name -> Expr -> NiceDeclaration
PrimitiveFunction Range
r Access
p IsAbstract
a Name
x Expr
t
    toPrim NiceDeclaration
_                       = NiceDeclaration
forall a. HasCallStack => a
__IMPOSSIBLE__

    -- Create a function definition.
    mkFunDef :: ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> TacticAttribute
-> [Declaration]
-> Nice [NiceDeclaration]
mkFunDef ArgInfo
info TerminationCheck
termCheck CoverageCheck
covCheck Name
x TacticAttribute
mt [Declaration]
ds0 = do
      [Declaration]
ds <- [Declaration] -> Nice [Declaration]
expandEllipsis [Declaration]
ds0
      [Clause]
cs <- Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
ds Bool
False
      [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
FunSig (Name -> Expr -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange Name
x Expr
t) Access
PublicAccess IsAbstract
ConcreteDef IsInstance
NotInstanceDef IsMacro
NotMacroDef ArgInfo
info TerminationCheck
termCheck CoverageCheck
covCheck Name
x Expr
t
             , Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
FunDef ([Declaration] -> Range
forall t. HasRange t => t -> Range
getRange [Declaration]
ds0) [Declaration]
ds0 IsAbstract
ConcreteDef IsInstance
NotInstanceDef TerminationCheck
termCheck CoverageCheck
covCheck Name
x [Clause]
cs ]
        where
          t :: Expr
t = case TacticAttribute
mt of
                Just Expr
t  -> Expr
t
                TacticAttribute
Nothing -> Range -> Expr
underscore (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x)

    underscore :: Range -> Expr
underscore Range
r = Range -> Maybe String -> Expr
Underscore Range
r Maybe String
forall a. Maybe a
Nothing


    expandEllipsis :: [Declaration] -> Nice [Declaration]
    expandEllipsis :: [Declaration] -> Nice [Declaration]
expandEllipsis [] = [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    expandEllipsis (d :: Declaration
d@(FunClause lhs :: LHS
lhs@(LHS Pattern
p [RewriteEqn]
_ [WithHiding Expr]
_ ExpandedEllipsis
ell) RHS
_ WhereClause
_ Bool
_) : [Declaration]
ds)
      | ExpandedEllipsis{} <- ExpandedEllipsis
ell = Nice [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__
      | Pattern -> Bool
forall a. HasEllipsis a => a -> Bool
hasEllipsis Pattern
p = (Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:) ([Declaration] -> [Declaration])
-> Nice [Declaration] -> Nice [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> Nice [Declaration]
expandEllipsis [Declaration]
ds
      | Bool
otherwise     = (Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:) ([Declaration] -> [Declaration])
-> Nice [Declaration] -> Nice [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Declaration] -> Nice [Declaration]
expand (KillRangeT Pattern
forall a. KillRange a => KillRangeT a
killRange Pattern
p) [Declaration]
ds
      where
        expand :: Pattern -> [Declaration] -> Nice [Declaration]
        expand :: Pattern -> [Declaration] -> Nice [Declaration]
expand Pattern
_ [] = [Declaration] -> Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        expand Pattern
p (Declaration
d : [Declaration]
ds) = do
          case Declaration
d of
            Pragma (CatchallPragma Range
_) -> do
                  (Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:) ([Declaration] -> [Declaration])
-> Nice [Declaration] -> Nice [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Declaration] -> Nice [Declaration]
expand Pattern
p [Declaration]
ds
            FunClause (LHS Pattern
p0 [RewriteEqn]
eqs [WithHiding Expr]
es ExpandedEllipsis
NoEllipsis) RHS
rhs WhereClause
wh Bool
ca -> do
              case Pattern -> AffineHole Pattern Pattern
forall p. CPatternLike p => p -> AffineHole Pattern p
hasEllipsis' Pattern
p0 of
                AffineHole Pattern Pattern
ManyHoles -> DeclarationException -> Nice [Declaration]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice [Declaration])
-> DeclarationException -> Nice [Declaration]
forall a b. (a -> b) -> a -> b
$ Pattern -> DeclarationException
MultipleEllipses Pattern
p0
                OneHole KillRangeT Pattern
cxt ~(EllipsisP Range
r) -> do
                  -- Replace the ellipsis by @p@.
                  let p1 :: Pattern
p1 = KillRangeT Pattern
cxt Pattern
p
                  let ell :: ExpandedEllipsis
ell = Range -> Int -> ExpandedEllipsis
ExpandedEllipsis Range
r (Pattern -> Int
forall p. CPatternLike p => p -> Int
numberOfWithPatterns Pattern
p)
                  let d' :: Declaration
d' = LHS -> RHS -> WhereClause -> Bool -> Declaration
FunClause (Pattern
-> [RewriteEqn] -> [WithHiding Expr] -> ExpandedEllipsis -> LHS
LHS Pattern
p1 [RewriteEqn]
eqs [WithHiding Expr]
es ExpandedEllipsis
ell) RHS
rhs WhereClause
wh Bool
ca
                  -- If we have with-expressions (es /= []) then the following
                  -- ellipses also get the additional patterns in p0.
                  (Declaration
d' Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:) ([Declaration] -> [Declaration])
-> Nice [Declaration] -> Nice [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Declaration] -> Nice [Declaration]
expand (if [WithHiding Expr] -> Bool
forall a. Null a => a -> Bool
null [WithHiding Expr]
es then Pattern
p else KillRangeT Pattern
forall a. KillRange a => KillRangeT a
killRange Pattern
p1) [Declaration]
ds
                ZeroHoles Pattern
_ -> do
                  -- We can have ellipses after a fun clause without.
                  -- They refer to the last clause that introduced new with-expressions.
                  -- Same here: If we have new with-expressions, the next ellipses will
                  -- refer to us.
                  -- Andreas, Jesper, 2017-05-13, issue #2578
                  -- Need to update the range also on the next with-patterns.
                  (Declaration
d Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:) ([Declaration] -> [Declaration])
-> Nice [Declaration] -> Nice [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Declaration] -> Nice [Declaration]
expand (if [WithHiding Expr] -> Bool
forall a. Null a => a -> Bool
null [WithHiding Expr]
es then Pattern
p else KillRangeT Pattern
forall a. KillRange a => KillRangeT a
killRange Pattern
p0) [Declaration]
ds
            Declaration
_ -> Nice [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__
    expandEllipsis [Declaration]
_ = Nice [Declaration]
forall a. HasCallStack => a
__IMPOSSIBLE__

    -- Turn function clauses into nice function clauses.
    mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]
    mkClauses :: Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
_ [] Bool
_ = [Clause] -> Nice [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    mkClauses Name
x (Pragma (CatchallPragma Range
r) : [Declaration]
cs) Bool
True  = do
      DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidCatchallPragma Range
r
      Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
cs Bool
True
    mkClauses Name
x (Pragma (CatchallPragma Range
r) : [Declaration]
cs) Bool
False = do
      Bool -> Nice () -> Nice ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Declaration] -> Bool
forall a. Null a => a -> Bool
null [Declaration]
cs) (Nice () -> Nice ()) -> Nice () -> Nice ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
InvalidCatchallPragma Range
r
      Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
cs Bool
True

    mkClauses Name
x (FunClause LHS
lhs RHS
rhs WhereClause
wh Bool
ca : [Declaration]
cs) Bool
catchall
      | [WithHiding Expr] -> Bool
forall a. Null a => a -> Bool
null (LHS -> [WithHiding Expr]
lhsWithExpr LHS
lhs) Bool -> Bool -> Bool
|| LHS -> Bool
forall a. HasEllipsis a => a -> Bool
hasEllipsis LHS
lhs  =
      (Name -> Bool -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
Clause Name
x (Bool
ca Bool -> Bool -> Bool
|| Bool
catchall) LHS
lhs RHS
rhs WhereClause
wh [] Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
:) ([Clause] -> [Clause]) -> Nice [Clause] -> Nice [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
cs Bool
False   -- Will result in an error later.

    mkClauses Name
x (FunClause LHS
lhs RHS
rhs WhereClause
wh Bool
ca : [Declaration]
cs) Bool
catchall = do
      Bool -> Nice () -> Nice ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Declaration] -> Bool
forall a. Null a => a -> Bool
null [Declaration]
withClauses) (Nice () -> Nice ()) -> Nice () -> Nice ()
forall a b. (a -> b) -> a -> b
$ DeclarationException -> Nice ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeclarationException -> Nice ())
-> DeclarationException -> Nice ()
forall a b. (a -> b) -> a -> b
$ Name -> LHS -> DeclarationException
MissingWithClauses Name
x LHS
lhs
      [Clause]
wcs <- Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
withClauses Bool
False
      (Name -> Bool -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
Clause Name
x (Bool
ca Bool -> Bool -> Bool
|| Bool
catchall) LHS
lhs RHS
rhs WhereClause
wh [Clause]
wcs Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
:) ([Clause] -> [Clause]) -> Nice [Clause] -> Nice [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Declaration] -> Bool -> Nice [Clause]
mkClauses Name
x [Declaration]
cs' Bool
False
      where
        ([Declaration]
withClauses, [Declaration]
cs') = [Declaration] -> ([Declaration], [Declaration])
subClauses [Declaration]
cs

        -- A clause is a subclause if the number of with-patterns is
        -- greater or equal to the current number of with-patterns plus the
        -- number of with arguments.
        numWith :: Int
numWith = Pattern -> Int
forall p. CPatternLike p => p -> Int
numberOfWithPatterns Pattern
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [WithHiding Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((WithHiding Expr -> Bool) -> [WithHiding Expr] -> [WithHiding Expr]
forall a. (a -> Bool) -> [a] -> [a]
filter WithHiding Expr -> Bool
forall a. LensHiding a => a -> Bool
visible [WithHiding Expr]
es) where LHS Pattern
p [RewriteEqn]
_ [WithHiding Expr]
es ExpandedEllipsis
_ = LHS
lhs

        subClauses :: [Declaration] -> ([Declaration],[Declaration])
        subClauses :: [Declaration] -> ([Declaration], [Declaration])
subClauses (c :: Declaration
c@(FunClause (LHS Pattern
p0 [RewriteEqn]
_ [WithHiding Expr]
_ ExpandedEllipsis
_) RHS
_ WhereClause
_ Bool
_) : [Declaration]
cs)
         | Pattern -> Bool
forall a. IsEllipsis a => a -> Bool
isEllipsis Pattern
p0 Bool -> Bool -> Bool
||
           Pattern -> Int
forall p. CPatternLike p => p -> Int
numberOfWithPatterns Pattern
p0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numWith = ([Declaration] -> [Declaration])
-> ([Declaration], [Declaration]) -> ([Declaration], [Declaration])
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Declaration
cDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:) ([Declaration] -> ([Declaration], [Declaration])
subClauses [Declaration]
cs)
         | Bool
otherwise                           = ([], Declaration
cDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
cs)
        subClauses (c :: Declaration
c@(Pragma (CatchallPragma Range
r)) : [Declaration]
cs) = case [Declaration] -> ([Declaration], [Declaration])
subClauses [Declaration]
cs of
          ([], [Declaration]
cs') -> ([], Declaration
cDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
cs')
          ([Declaration]
cs, [Declaration]
cs') -> (Declaration
cDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
cs, [Declaration]
cs')
        subClauses [] = ([],[])
        subClauses [Declaration]
_  = ([Declaration], [Declaration])
forall a. HasCallStack => a
__IMPOSSIBLE__
    mkClauses Name
_ [Declaration]
_ Bool
_ = Nice [Clause]
forall a. HasCallStack => a
__IMPOSSIBLE__

    -- for finding clauses for a type sig in mutual blocks
    couldBeFunClauseOf :: Maybe Fixity' -> Name -> Declaration -> Bool
    couldBeFunClauseOf :: Maybe Fixity' -> Name -> Declaration -> Bool
couldBeFunClauseOf Maybe Fixity'
mFixity Name
x (Pragma (CatchallPragma{})) = Bool
True
    couldBeFunClauseOf Maybe Fixity'
mFixity Name
x (FunClause (LHS Pattern
p [RewriteEqn]
_ [WithHiding Expr]
_ ExpandedEllipsis
_) RHS
_ WhereClause
_ Bool
_) = Pattern -> Bool
forall a. HasEllipsis a => a -> Bool
hasEllipsis Pattern
p Bool -> Bool -> Bool
||
      let
      pns :: [Name]
pns        = Pattern -> [Name]
patternNames Pattern
p
      xStrings :: [String]
xStrings   = Name -> [String]
nameStringParts Name
x
      patStrings :: [String]
patStrings = (Name -> [String]) -> [Name] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Name -> [String]
nameStringParts [Name]
pns
      in
--          trace ("x = " ++ prettyShow x) $
--          trace ("pns = " ++ show pns) $
--          trace ("xStrings = " ++ show xStrings) $
--          trace ("patStrings = " ++ show patStrings) $
--          trace ("mFixity = " ++ show mFixity) $
      case ([Name] -> Maybe Name
forall a. [a] -> Maybe a
listToMaybe [Name]
pns, Maybe Fixity'
mFixity) of
        -- first identifier in the patterns is the fun.symbol?
        (Just Name
y, Maybe Fixity'
_) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
y -> Bool
True -- trace ("couldBe since y = " ++ prettyShow y) $ True
        -- are the parts of x contained in p
        (Maybe Name, Maybe Fixity')
_ | [String]
xStrings [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSublistOf` [String]
patStrings -> Bool
True -- trace ("couldBe since isSublistOf") $ True
        -- looking for a mixfix fun.symb
        (Maybe Name
_, Just Fixity'
fix) ->  -- also matches in case of a postfix
           let notStrings :: [String]
notStrings = Notation -> [String]
stringParts (Fixity' -> Notation
theNotation Fixity'
fix)
           in  -- trace ("notStrings = " ++ show notStrings) $
               -- trace ("patStrings = " ++ show patStrings) $
               (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall a. Null a => a -> Bool
null [String]
notStrings) Bool -> Bool -> Bool
&& ([String]
notStrings [String] -> [String] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSublistOf` [String]
patStrings)
        -- not a notation, not first id: give up
        (Maybe Name, Maybe Fixity')
_ -> Bool
False -- trace ("couldBe not (case default)") $ False
    couldBeFunClauseOf Maybe Fixity'
_ Name
_ Declaration
_ = Bool
False -- trace ("couldBe not (fun default)") $ False

    -- | Turn an old-style mutual block into a new style mutual block
    --   by pushing the definitions to the end.
    mkOldMutual
      :: Range                -- ^ Range of the whole @mutual@ block.
      -> [NiceDeclaration]    -- ^ Declarations inside the block.
      -> Nice NiceDeclaration -- ^ Returns a 'NiceMutual'.
    mkOldMutual :: Range -> [NiceDeclaration] -> Nice NiceDeclaration
mkOldMutual Range
r [NiceDeclaration]
ds' = do
        -- Postulate the missing definitions
        let ps :: LoneSigs
ps = [(Range, Name, DataRecOrFun)] -> LoneSigs
loneSigsFromLoneNames [(Range, Name, DataRecOrFun)]
loneNames
        LoneSigs -> Nice ()
checkLoneSigs LoneSigs
ps
        let ds :: [NiceDeclaration]
ds = LoneSigs -> [NiceDeclaration] -> [NiceDeclaration]
replaceSigs LoneSigs
ps [NiceDeclaration]
ds'

        -- -- Remove the declarations that aren't allowed in old style mutual blocks
        -- ds <- fmap catMaybes $ forM ds $ \ d -> let success = pure (Just d) in case d of
        --   -- Andreas, 2013-11-23 allow postulates in mutual blocks
        --   Axiom{}          -> success
        --   -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature
        --   -- in ConcreteToAbstract rather than here.
        --   NiceFunClause{}  -> success
        --   -- Andreas, 2018-05-11, issue #3052, allow pat.syn.s in mutual blocks
        --   NicePatternSyn{} -> success
        --   -- Otherwise, only categorized signatures and definitions are allowed:
        --   -- Data, Record, Fun
        --   _ -> if (declKind d /= OtherDecl) then success
        --        else Nothing <$ niceWarning (NotAllowedInMutual (getRange d) $ declName d)
        -- Sort the declarations in the mutual block.
        -- Declarations of names go to the top.  (Includes module definitions.)
        -- Definitions of names go to the bottom.
        -- Some declarations are forbidden, as their positioning could confuse
        -- the user.
        ([NiceDeclaration]
top, [NiceDeclaration]
bottom, [NiceDeclaration]
invalid) <- [NiceDeclaration]
-> (NiceDeclaration
    -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration))
-> Nice ([NiceDeclaration], [NiceDeclaration], [NiceDeclaration])
forall (m :: * -> *) a b c d.
Applicative m =>
[a] -> (a -> m (Either3 b c d)) -> m ([b], [c], [d])
forEither3M [NiceDeclaration]
ds ((NiceDeclaration
  -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration))
 -> Nice ([NiceDeclaration], [NiceDeclaration], [NiceDeclaration]))
-> (NiceDeclaration
    -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration))
-> Nice ([NiceDeclaration], [NiceDeclaration], [NiceDeclaration])
forall a b. (a -> b) -> a -> b
$ \ NiceDeclaration
d -> do
          let top :: Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top       = Either3 NiceDeclaration NiceDeclaration NiceDeclaration
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall (m :: * -> *) a. Monad m => a -> m a
return (NiceDeclaration
-> Either3 NiceDeclaration NiceDeclaration NiceDeclaration
forall a b c. a -> Either3 a b c
In1 NiceDeclaration
d)
              bottom :: Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom    = Either3 NiceDeclaration NiceDeclaration NiceDeclaration
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall (m :: * -> *) a. Monad m => a -> m a
return (NiceDeclaration
-> Either3 NiceDeclaration NiceDeclaration NiceDeclaration
forall a b c. b -> Either3 a b c
In2 NiceDeclaration
d)
              invalid :: String
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
invalid String
s = NiceDeclaration
-> Either3 NiceDeclaration NiceDeclaration NiceDeclaration
forall a b c. c -> Either3 a b c
In3 NiceDeclaration
d Either3 NiceDeclaration NiceDeclaration NiceDeclaration
-> Nice ()
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> String -> DeclarationWarning
NotAllowedInMutual (NiceDeclaration -> Range
forall t. HasRange t => t -> Range
getRange NiceDeclaration
d) String
s
          case NiceDeclaration
d of
            -- Andreas, 2013-11-23 allow postulates in mutual blocks
            Axiom{}             -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceField{}         -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            PrimitiveFunction{} -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            -- Andreas, 2019-07-23 issue #3932:
            -- Nested mutual blocks are not supported.
            NiceMutual{}        -> String
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
invalid String
"mutual blocks"
            -- Andreas, 2018-10-29, issue #3246
            -- We could allow modules (top), but this is potentially confusing.
            NiceModule{}        -> String
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
invalid String
"Module definitions"
            NiceModuleMacro{}   -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceOpen{}          -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceImport{}        -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceRecSig{}        -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceDataSig{}       -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature
            -- in ConcreteToAbstract rather than here.
            NiceFunClause{}     -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
            FunSig{}            -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            FunDef{}            -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
            NiceDataDef{}       -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
            NiceRecDef{}        -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
            -- Andreas, 2018-05-11, issue #3051, allow pat.syn.s in mutual blocks
            -- Andreas, 2018-10-29: We shift pattern synonyms to the bottom
            -- since they might refer to constructors defined in a data types
            -- just above them.
            NicePatternSyn{}    -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
            NiceGeneralize{}    -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceUnquoteDecl{}   -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
            NiceUnquoteDef{}    -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
            NicePragma Range
r Pragma
pragma -> case Pragma
pragma of

              OptionsPragma{}           -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top     -- error thrown in the type checker

              -- Some builtins require a definition, and they affect type checking
              -- Thus, we do not handle BUILTINs in mutual blocks (at least for now).
              BuiltinPragma{}           -> String
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
invalid String
"BUILTIN pragmas"

              -- The REWRITE pragma behaves differently before or after the def.
              -- and affects type checking.  Thus, we refuse it here.
              RewritePragma{}           -> String
-> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
invalid String
"REWRITE pragmas"

              -- Compiler pragmas are not needed for type checking, thus,
              -- can go to the bottom.
              ForeignPragma{}           -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
              CompilePragma{}           -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom

              StaticPragma{}            -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom
              InlinePragma{}            -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom

              ImpossiblePragma{}        -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top     -- error thrown in scope checker
              EtaPragma{}               -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
bottom  -- needs record definition
              WarningOnUsage{}          -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
              WarningOnImport{}         -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top
              InjectivePragma{}         -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top     -- only needs name, not definition
              DisplayPragma{}           -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
top     -- only for printing

              -- The attached pragmas have already been handled at this point.
              CatchallPragma{}          -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall a. HasCallStack => a
__IMPOSSIBLE__
              TerminationCheckPragma{}  -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall a. HasCallStack => a
__IMPOSSIBLE__
              NoPositivityCheckPragma{} -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall a. HasCallStack => a
__IMPOSSIBLE__
              PolarityPragma{}          -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall a. HasCallStack => a
__IMPOSSIBLE__
              NoUniverseCheckPragma{}   -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall a. HasCallStack => a
__IMPOSSIBLE__
              NoCoverageCheckPragma{}   -> Nice (Either3 NiceDeclaration NiceDeclaration NiceDeclaration)
forall a. HasCallStack => a
__IMPOSSIBLE__

        -- -- Pull type signatures to the top
        -- let (sigs, other) = List.partition isTypeSig ds

        -- -- Push definitions to the bottom
        -- let (other, defs) = flip List.partition ds $ \case
        --       FunDef{}         -> False
        --       NiceDataDef{}    -> False
        --       NiceRecDef{}         -> False
        --       NiceFunClause{}  -> False
        --       NicePatternSyn{} -> False
        --       NiceUnquoteDef{} -> False
        --       _ -> True

        -- Compute termination checking flag for mutual block
        TerminationCheck
tc0 <- Lens' TerminationCheck NiceEnv -> Nice TerminationCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' TerminationCheck NiceEnv
terminationCheckPragma
        let tcs :: [TerminationCheck]
tcs = (NiceDeclaration -> TerminationCheck)
-> [NiceDeclaration] -> [TerminationCheck]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> TerminationCheck
termCheck [NiceDeclaration]
ds
        TerminationCheck
tc <- Range -> [TerminationCheck] -> Nice TerminationCheck
combineTerminationChecks Range
r (TerminationCheck
tc0TerminationCheck -> [TerminationCheck] -> [TerminationCheck]
forall a. a -> [a] -> [a]
:[TerminationCheck]
tcs)

        -- Compute coverage checking flag for mutual block
        CoverageCheck
cc0 <- Lens' CoverageCheck NiceEnv -> Nice CoverageCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' CoverageCheck NiceEnv
coverageCheckPragma
        let ccs :: [CoverageCheck]
ccs = (NiceDeclaration -> CoverageCheck)
-> [NiceDeclaration] -> [CoverageCheck]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> CoverageCheck
covCheck [NiceDeclaration]
ds
        let cc :: CoverageCheck
cc = [CoverageCheck] -> CoverageCheck
combineCoverageChecks (CoverageCheck
cc0CoverageCheck -> [CoverageCheck] -> [CoverageCheck]
forall a. a -> [a] -> [a]
:[CoverageCheck]
ccs)

        -- Compute positivity checking flag for mutual block
        PositivityCheck
pc0 <- Lens' PositivityCheck NiceEnv -> Nice PositivityCheck
forall o (m :: * -> *) i. MonadState o m => Lens' i o -> m i
use Lens' PositivityCheck NiceEnv
positivityCheckPragma
        let pcs :: [PositivityCheck]
pcs = (NiceDeclaration -> PositivityCheck)
-> [NiceDeclaration] -> [PositivityCheck]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> PositivityCheck
positivityCheckOldMutual [NiceDeclaration]
ds
        let pc :: PositivityCheck
pc = [PositivityCheck] -> PositivityCheck
combinePositivityChecks (PositivityCheck
pc0PositivityCheck -> [PositivityCheck] -> [PositivityCheck]
forall a. a -> [a] -> [a]
:[PositivityCheck]
pcs)

        NiceDeclaration -> Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return (NiceDeclaration -> Nice NiceDeclaration)
-> NiceDeclaration -> Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc ([NiceDeclaration] -> NiceDeclaration)
-> [NiceDeclaration] -> NiceDeclaration
forall a b. (a -> b) -> a -> b
$ [NiceDeclaration]
top [NiceDeclaration] -> [NiceDeclaration] -> [NiceDeclaration]
forall a. [a] -> [a] -> [a]
++ [NiceDeclaration]
bottom
        -- return $ NiceMutual r tc pc $ other ++ defs
        -- return $ NiceMutual r tc pc $ sigs ++ other
      where

        -- isTypeSig Axiom{}                     = True
        -- isTypeSig d | LoneSig{} <- declKind d = True
        -- isTypeSig _                           = False

        sigNames :: [(Range, Name, DataRecOrFun)]
sigNames  = [ (Range
r, Name
x, DataRecOrFun
k) | LoneSigDecl Range
r DataRecOrFun
k Name
x <- (NiceDeclaration -> DeclKind) -> [NiceDeclaration] -> [DeclKind]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> DeclKind
declKind [NiceDeclaration]
ds' ]
        defNames :: [(Name, DataRecOrFun)]
defNames  = [ (Name
x, DataRecOrFun
k) | LoneDefs DataRecOrFun
k [Name]
xs <- (NiceDeclaration -> DeclKind) -> [NiceDeclaration] -> [DeclKind]
forall a b. (a -> b) -> [a] -> [b]
map NiceDeclaration -> DeclKind
declKind [NiceDeclaration]
ds', Name
x <- [Name]
xs ]
        -- compute the set difference with equality just on names
        loneNames :: [(Range, Name, DataRecOrFun)]
loneNames = [ (Range
r, Name
x, DataRecOrFun
k) | (Range
r, Name
x, DataRecOrFun
k) <- [(Range, Name, DataRecOrFun)]
sigNames, ((Name, DataRecOrFun) -> Bool) -> [(Name, DataRecOrFun)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.all ((Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Name -> Bool)
-> ((Name, DataRecOrFun) -> Name) -> (Name, DataRecOrFun) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, DataRecOrFun) -> Name
forall a b. (a, b) -> a
fst) [(Name, DataRecOrFun)]
defNames ]

        termCheck :: NiceDeclaration -> TerminationCheck
        -- 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 :: NiceDeclaration -> TerminationCheck
termCheck (FunSig Range
_ Access
_ IsAbstract
_ IsInstance
_ IsMacro
_ ArgInfo
_ TerminationCheck
tc CoverageCheck
_ Name
_ Expr
_)      = TerminationCheck
tc
        termCheck (FunDef Range
_ [Declaration]
_ IsAbstract
_ IsInstance
_ TerminationCheck
tc CoverageCheck
_ Name
_ [Clause]
_)          = TerminationCheck
tc
        -- ASR (28 December 2015): Is this equation necessary?
        termCheck (NiceMutual Range
_ TerminationCheck
tc CoverageCheck
_ PositivityCheck
_ [NiceDeclaration]
_)            = TerminationCheck
tc
        termCheck (NiceUnquoteDecl Range
_ Access
_ IsAbstract
_ IsInstance
_ TerminationCheck
tc CoverageCheck
_ [Name]
_ Expr
_) = TerminationCheck
tc
        termCheck (NiceUnquoteDef Range
_ Access
_ IsAbstract
_ TerminationCheck
tc CoverageCheck
_ [Name]
_ Expr
_)    = TerminationCheck
tc
        termCheck Axiom{}             = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceField{}         = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck PrimitiveFunction{} = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceModule{}        = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceModuleMacro{}   = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceOpen{}          = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceImport{}        = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NicePragma{}        = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceRecSig{}        = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceDataSig{}       = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceFunClause{}     = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceDataDef{}       = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceRecDef{}        = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NicePatternSyn{}    = TerminationCheck
forall m. TerminationCheck m
TerminationCheck
        termCheck NiceGeneralize{}    = TerminationCheck
forall m. TerminationCheck m
TerminationCheck

        covCheck :: NiceDeclaration -> CoverageCheck
        covCheck :: NiceDeclaration -> CoverageCheck
covCheck (FunSig Range
_ Access
_ IsAbstract
_ IsInstance
_ IsMacro
_ ArgInfo
_ TerminationCheck
_ CoverageCheck
cc Name
_ Expr
_)      = CoverageCheck
cc
        covCheck (FunDef Range
_ [Declaration]
_ IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
cc Name
_ [Clause]
_)          = CoverageCheck
cc
        -- ASR (28 December 2015): Is this equation necessary?
        covCheck (NiceMutual Range
_ TerminationCheck
_ CoverageCheck
cc PositivityCheck
_ [NiceDeclaration]
_)            = CoverageCheck
cc
        covCheck (NiceUnquoteDecl Range
_ Access
_ IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
cc [Name]
_ Expr
_) = CoverageCheck
cc
        covCheck (NiceUnquoteDef Range
_ Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
cc [Name]
_ Expr
_)    = CoverageCheck
cc
        covCheck Axiom{}             = CoverageCheck
YesCoverageCheck
        covCheck NiceField{}         = CoverageCheck
YesCoverageCheck
        covCheck PrimitiveFunction{} = CoverageCheck
YesCoverageCheck
        covCheck NiceModule{}        = CoverageCheck
YesCoverageCheck
        covCheck NiceModuleMacro{}   = CoverageCheck
YesCoverageCheck
        covCheck NiceOpen{}          = CoverageCheck
YesCoverageCheck
        covCheck NiceImport{}        = CoverageCheck
YesCoverageCheck
        covCheck NicePragma{}        = CoverageCheck
YesCoverageCheck
        covCheck NiceRecSig{}        = CoverageCheck
YesCoverageCheck
        covCheck NiceDataSig{}       = CoverageCheck
YesCoverageCheck
        covCheck NiceFunClause{}     = CoverageCheck
YesCoverageCheck
        covCheck NiceDataDef{}       = CoverageCheck
YesCoverageCheck
        covCheck NiceRecDef{}        = CoverageCheck
YesCoverageCheck
        covCheck NicePatternSyn{}    = CoverageCheck
YesCoverageCheck
        covCheck NiceGeneralize{}    = CoverageCheck
YesCoverageCheck



        -- ASR (26 December 2015): Do not positivity check a mutual
        -- block if any of its inner declarations comes with a
        -- NO_POSITIVITY_CHECK pragma. See Issue 1614.
        positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck
        positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck
positivityCheckOldMutual (NiceDataDef Range
_ Origin
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
_ Name
_ [LamBinding]
_ [NiceDeclaration]
_) = PositivityCheck
pc
        positivityCheckOldMutual (NiceDataSig Range
_ Access
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
_ Name
_ [LamBinding]
_ Expr
_) = PositivityCheck
pc
        positivityCheckOldMutual (NiceMutual Range
_ TerminationCheck
_ CoverageCheck
_ PositivityCheck
pc [NiceDeclaration]
_)        = PositivityCheck
pc
        positivityCheckOldMutual (NiceRecSig Range
_ Access
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
_ Name
_ [LamBinding]
_ Expr
_)  = PositivityCheck
pc
        positivityCheckOldMutual (NiceRecDef Range
_ Origin
_ IsAbstract
_ PositivityCheck
pc UniverseCheck
_ Name
_ Maybe (Ranged Induction)
_ Maybe HasEta
_ Maybe (Name, IsInstance)
_ [LamBinding]
_ [Declaration]
_) = PositivityCheck
pc
        positivityCheckOldMutual NiceDeclaration
_                              = PositivityCheck
YesPositivityCheck

        -- A mutual block cannot have a measure,
        -- but it can skip termination check.

    abstractBlock :: Range -> [a] -> Nice [a]
abstractBlock Range
_ [] = [a] -> Nice [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    abstractBlock Range
r [a]
ds = do
      ([a]
ds', Bool
anyChange) <- ChangeT Nice [a] -> Nice ([a], Bool)
forall (m :: * -> *) a. Functor m => ChangeT m a -> m (a, Bool)
runChangeT (ChangeT Nice [a] -> Nice ([a], Bool))
-> ChangeT Nice [a] -> Nice ([a], Bool)
forall a b. (a -> b) -> a -> b
$ UpdaterT Nice [a]
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract [a]
ds
      let inherited :: Bool
inherited = Range
r Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
== Range
forall a. Range' a
noRange
      if Bool
anyChange then [a] -> Nice [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ds' else do
        -- hack to avoid failing on inherited abstract blocks in where clauses
        Bool -> Nice () -> Nice ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inherited (Nice () -> Nice ()) -> Nice () -> Nice ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
UselessAbstract Range
r
        [a] -> Nice [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ds -- no change!

    privateBlock :: Range -> Origin -> [a] -> Nice [a]
privateBlock Range
_ Origin
_ [] = [a] -> Nice [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    privateBlock Range
r Origin
o [a]
ds = do
      ([a]
ds', Bool
anyChange) <- ChangeT Nice [a] -> Nice ([a], Bool)
forall (m :: * -> *) a. Functor m => ChangeT m a -> m (a, Bool)
runChangeT (ChangeT Nice [a] -> Nice ([a], Bool))
-> ChangeT Nice [a] -> Nice ([a], Bool)
forall a b. (a -> b) -> a -> b
$ Origin -> UpdaterT Nice [a]
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o [a]
ds
      if Bool
anyChange then [a] -> Nice [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ds' else do
        Bool -> Nice () -> Nice ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Origin
o Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
UserWritten) (Nice () -> Nice ()) -> Nice () -> Nice ()
forall a b. (a -> b) -> a -> b
$ DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
UselessPrivate Range
r
        [a] -> Nice [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ds -- no change!

    instanceBlock
      :: Range  -- ^ Range of @instance@ keyword.
      -> [NiceDeclaration]
      -> Nice [NiceDeclaration]
    instanceBlock :: Range -> [NiceDeclaration] -> Nice [NiceDeclaration]
instanceBlock Range
_ [] = [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    instanceBlock Range
r [NiceDeclaration]
ds = do
      let ([NiceDeclaration]
ds', Bool
anyChange) = Change [NiceDeclaration] -> ([NiceDeclaration], Bool)
forall a. Change a -> (a, Bool)
runChange (Change [NiceDeclaration] -> ([NiceDeclaration], Bool))
-> Change [NiceDeclaration] -> ([NiceDeclaration], Bool)
forall a b. (a -> b) -> a -> b
$ (NiceDeclaration -> ChangeT Identity NiceDeclaration)
-> [NiceDeclaration] -> Change [NiceDeclaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> NiceDeclaration -> ChangeT Identity NiceDeclaration
mkInstance Range
r) [NiceDeclaration]
ds
      if Bool
anyChange then [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [NiceDeclaration]
ds' else do
        DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ()) -> DeclarationWarning -> Nice ()
forall a b. (a -> b) -> a -> b
$ Range -> DeclarationWarning
UselessInstance Range
r
        [NiceDeclaration] -> Nice [NiceDeclaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [NiceDeclaration]
ds -- no change!

    -- Make a declaration eligible for instance search.
    mkInstance
      :: Range  -- ^ Range of @instance@ keyword.
      -> Updater NiceDeclaration
    mkInstance :: Range -> NiceDeclaration -> ChangeT Identity NiceDeclaration
mkInstance Range
r0 = \case
        Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
e          -> (\ IsInstance
i -> Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
e) (IsInstance -> NiceDeclaration)
-> ChangeT Identity IsInstance -> ChangeT Identity NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Updater IsInstance
setInstance Range
r0 IsInstance
i
        FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e -> (\ IsInstance
i -> Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e) (IsInstance -> NiceDeclaration)
-> ChangeT Identity IsInstance -> ChangeT Identity NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Updater IsInstance
setInstance Range
r0 IsInstance
i
        NiceUnquoteDecl Range
r Access
p IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e -> (\ IsInstance
i -> Range
-> Access
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDecl Range
r Access
p IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e) (IsInstance -> NiceDeclaration)
-> ChangeT Identity IsInstance -> ChangeT Identity NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Updater IsInstance
setInstance Range
r0 IsInstance
i
        NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds        -> Range
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc ([NiceDeclaration] -> NiceDeclaration)
-> Change [NiceDeclaration] -> ChangeT Identity NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NiceDeclaration -> ChangeT Identity NiceDeclaration)
-> [NiceDeclaration] -> Change [NiceDeclaration]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> NiceDeclaration -> ChangeT Identity NiceDeclaration
mkInstance Range
r0) [NiceDeclaration]
ds
        d :: NiceDeclaration
d@NiceFunClause{}              -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc Name
x [Clause]
cs     -> (\ IsInstance
i -> Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc Name
x [Clause]
cs) (IsInstance -> NiceDeclaration)
-> ChangeT Identity IsInstance -> ChangeT Identity NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Updater IsInstance
setInstance Range
r0 IsInstance
i
        d :: NiceDeclaration
d@NiceField{}                  -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d  -- Field instance are handled by the parser
        d :: NiceDeclaration
d@PrimitiveFunction{}          -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceUnquoteDef{}             -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceRecSig{}                 -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceDataSig{}                -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceModuleMacro{}            -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceModule{}                 -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NicePragma{}                 -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceOpen{}                   -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceImport{}                 -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceDataDef{}                -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceRecDef{}                 -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NicePatternSyn{}             -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        d :: NiceDeclaration
d@NiceGeneralize{}             -> NiceDeclaration -> ChangeT Identity NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d

    setInstance
      :: Range  -- ^ Range of @instance@ keyword.
      -> Updater IsInstance
    setInstance :: Range -> Updater IsInstance
setInstance Range
r0 = \case
      i :: IsInstance
i@InstanceDef{} -> Updater IsInstance
forall (m :: * -> *) a. Monad m => a -> m a
return IsInstance
i
      IsInstance
_               -> Updater IsInstance
forall (m :: * -> *) a. Monad m => UpdaterT m a
dirty Updater IsInstance -> Updater IsInstance
forall a b. (a -> b) -> a -> b
$ Range -> IsInstance
InstanceDef Range
r0

    macroBlock :: p -> t NiceDeclaration -> Nice (t NiceDeclaration)
macroBlock p
r t NiceDeclaration
ds = (NiceDeclaration -> Nice NiceDeclaration)
-> t NiceDeclaration -> Nice (t NiceDeclaration)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NiceDeclaration -> Nice NiceDeclaration
mkMacro t NiceDeclaration
ds

    mkMacro :: NiceDeclaration -> Nice NiceDeclaration
    mkMacro :: NiceDeclaration -> Nice NiceDeclaration
mkMacro = \case
        FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
_ ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e -> NiceDeclaration -> Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return (NiceDeclaration -> Nice NiceDeclaration)
-> NiceDeclaration -> Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
MacroDef ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e
        d :: NiceDeclaration
d@FunDef{}                     -> NiceDeclaration -> Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
        NiceDeclaration
d                              -> DeclarationException -> Nice NiceDeclaration
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NiceDeclaration -> DeclarationException
BadMacroDef NiceDeclaration
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 :: UpdaterT Nice a
  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => UpdaterT Nice a
  mkAbstract = (a' -> ChangeT Nice a') -> f a' -> ChangeT Nice (f a')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a' -> ChangeT Nice a'
forall a. MakeAbstract a => UpdaterT Nice a
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 :: UpdaterT Nice IsAbstract
mkAbstract = \case
    a :: IsAbstract
a@IsAbstract
AbstractDef -> UpdaterT Nice IsAbstract
forall (m :: * -> *) a. Monad m => a -> m a
return IsAbstract
a
    IsAbstract
ConcreteDef -> UpdaterT Nice IsAbstract
forall (m :: * -> *) a. Monad m => UpdaterT m a
dirty UpdaterT Nice IsAbstract -> UpdaterT Nice IsAbstract
forall a b. (a -> b) -> a -> b
$ IsAbstract
AbstractDef

instance MakeAbstract NiceDeclaration where
  mkAbstract :: UpdaterT Nice NiceDeclaration
mkAbstract = \case
      NiceMutual Range
r TerminationCheck
termCheck CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds  -> Range
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual Range
r TerminationCheck
termCheck CoverageCheck
cc PositivityCheck
pc ([NiceDeclaration] -> NiceDeclaration)
-> ChangeT Nice [NiceDeclaration] -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdaterT Nice [NiceDeclaration]
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract [NiceDeclaration]
ds
      FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc Name
x [Clause]
cs       -> (\ IsAbstract
a -> Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc Name
x) (IsAbstract -> [Clause] -> NiceDeclaration)
-> ChangeT Nice IsAbstract
-> ChangeT Nice ([Clause] -> NiceDeclaration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdaterT Nice IsAbstract
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract IsAbstract
a ChangeT Nice ([Clause] -> NiceDeclaration)
-> ChangeT Nice [Clause] -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UpdaterT Nice [Clause]
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract [Clause]
cs
      NiceDataDef Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ps [NiceDeclaration]
cs  -> (\ IsAbstract
a -> Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> [NiceDeclaration]
-> NiceDeclaration
NiceDataDef Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ps) (IsAbstract -> [NiceDeclaration] -> NiceDeclaration)
-> ChangeT Nice IsAbstract
-> ChangeT Nice ([NiceDeclaration] -> NiceDeclaration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdaterT Nice IsAbstract
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract IsAbstract
a ChangeT Nice ([NiceDeclaration] -> NiceDeclaration)
-> ChangeT Nice [NiceDeclaration] -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UpdaterT Nice [NiceDeclaration]
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract [NiceDeclaration]
cs
      NiceRecDef Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
ps [Declaration]
cs -> (\ IsAbstract
a -> Range
-> Origin
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> [Declaration]
-> NiceDeclaration
NiceRecDef Range
r Origin
o IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
ps) (IsAbstract -> [Declaration] -> NiceDeclaration)
-> ChangeT Nice IsAbstract
-> ChangeT Nice ([Declaration] -> NiceDeclaration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdaterT Nice IsAbstract
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract IsAbstract
a ChangeT Nice ([Declaration] -> NiceDeclaration)
-> ChangeT Nice [Declaration] -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> ChangeT Nice [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
cs
      NiceFunClause Range
r Access
p IsAbstract
a TerminationCheck
tc CoverageCheck
cc Bool
catchall Declaration
d  -> (\ IsAbstract
a -> Range
-> Access
-> IsAbstract
-> TerminationCheck
-> CoverageCheck
-> Bool
-> Declaration
-> NiceDeclaration
NiceFunClause Range
r Access
p IsAbstract
a TerminationCheck
tc CoverageCheck
cc Bool
catchall Declaration
d) (IsAbstract -> NiceDeclaration)
-> ChangeT Nice IsAbstract -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdaterT Nice IsAbstract
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract IsAbstract
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 Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
e          -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice NiceDeclaration -> UpdaterT Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom             Range
r Access
p IsAbstract
AbstractDef IsInstance
i ArgInfo
rel Name
x Expr
e
      FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice NiceDeclaration -> UpdaterT Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
FunSig            Range
r Access
p IsAbstract
AbstractDef IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e
      NiceRecSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t  -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice NiceDeclaration -> UpdaterT Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceRecSig        Range
r Access
p IsAbstract
AbstractDef PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t
      NiceDataSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice NiceDeclaration -> UpdaterT Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceDataSig       Range
r Access
p IsAbstract
AbstractDef PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t
      NiceField Range
r Access
p IsAbstract
_ IsInstance
i TacticAttribute
tac Name
x Arg Expr
e      -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice NiceDeclaration -> UpdaterT Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range
-> Access
-> IsAbstract
-> IsInstance
-> TacticAttribute
-> Name
-> Arg Expr
-> NiceDeclaration
NiceField         Range
r Access
p IsAbstract
AbstractDef IsInstance
i TacticAttribute
tac Name
x Arg Expr
e
      PrimitiveFunction Range
r Access
p IsAbstract
_ Name
x Expr
e    -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice NiceDeclaration -> UpdaterT Nice NiceDeclaration
forall a b. (a -> b) -> a -> b
$ Range -> Access -> IsAbstract -> Name -> Expr -> NiceDeclaration
PrimitiveFunction Range
r Access
p IsAbstract
AbstractDef Name
x Expr
e
      -- Andreas, 2016-07-17 it does have effect on unquoted defs.
      -- Need to set updater state to dirty!
      NiceUnquoteDecl Range
r Access
p IsAbstract
_ IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e -> ChangeT Nice ()
forall (m :: * -> *). MonadChange m => m ()
tellDirty ChangeT Nice () -> UpdaterT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Range
-> Access
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDecl Range
r Access
p IsAbstract
AbstractDef IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e
      NiceUnquoteDef Range
r Access
p IsAbstract
_ TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e    -> ChangeT Nice ()
forall (m :: * -> *). MonadChange m => m ()
tellDirty ChangeT Nice () -> UpdaterT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Range
-> Access
-> IsAbstract
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDef Range
r Access
p IsAbstract
AbstractDef TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e
      d :: NiceDeclaration
d@NiceModule{}                 -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NiceModuleMacro{}            -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NicePragma{}                 -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@(NiceOpen Range
_ QName
_ ImportDirective
directives)              -> do
        Maybe Range -> (Range -> ChangeT Nice ()) -> ChangeT Nice ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe Range
forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
directives) ((Range -> ChangeT Nice ()) -> ChangeT Nice ())
-> (Range -> ChangeT Nice ()) -> ChangeT Nice ()
forall a b. (a -> b) -> a -> b
$ Nice () -> ChangeT Nice ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Nice () -> ChangeT Nice ())
-> (Range -> Nice ()) -> Range -> ChangeT Nice ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ())
-> (Range -> DeclarationWarning) -> Range -> Nice ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> DeclarationWarning
OpenPublicAbstract
        UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NiceImport{}                 -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NicePatternSyn{}             -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NiceGeneralize{}             -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d

instance MakeAbstract Clause where
  mkAbstract :: UpdaterT Nice Clause
mkAbstract (Clause Name
x Bool
catchall LHS
lhs RHS
rhs WhereClause
wh [Clause]
with) = do
    Name -> Bool -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
Clause Name
x Bool
catchall LHS
lhs RHS
rhs (WhereClause -> [Clause] -> Clause)
-> ChangeT Nice WhereClause -> ChangeT Nice ([Clause] -> Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdaterT Nice WhereClause
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract WhereClause
wh ChangeT Nice ([Clause] -> Clause)
-> ChangeT Nice [Clause] -> ChangeT Nice Clause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UpdaterT Nice [Clause]
forall a. MakeAbstract a => UpdaterT Nice a
mkAbstract [Clause]
with

-- | Contents of a @where@ clause are abstract if the parent is.
instance MakeAbstract WhereClause where
  mkAbstract :: UpdaterT Nice WhereClause
mkAbstract  WhereClause
NoWhere           = UpdaterT Nice WhereClause
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice WhereClause -> UpdaterT Nice WhereClause
forall a b. (a -> b) -> a -> b
$ WhereClause
forall decls. WhereClause' decls
NoWhere
  mkAbstract (AnyWhere [Declaration]
ds)      = UpdaterT Nice WhereClause
forall (m :: * -> *) a. Monad m => UpdaterT m a
dirty UpdaterT Nice WhereClause -> UpdaterT Nice WhereClause
forall a b. (a -> b) -> a -> b
$ [Declaration] -> WhereClause
forall decls. decls -> WhereClause' decls
AnyWhere [Range -> [Declaration] -> Declaration
Abstract Range
forall a. Range' a
noRange [Declaration]
ds]
  mkAbstract (SomeWhere Name
m Access
a [Declaration]
ds) = UpdaterT Nice WhereClause
forall (m :: * -> *) a. Monad m => UpdaterT m a
dirty UpdaterT Nice WhereClause -> UpdaterT Nice WhereClause
forall a b. (a -> b) -> a -> b
$ Name -> Access -> [Declaration] -> WhereClause
forall decls. Name -> Access -> decls -> WhereClause' decls
SomeWhere Name
m Access
a [Range -> [Declaration] -> Declaration
Abstract Range
forall a. Range' a
noRange [Declaration]
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 -> UpdaterT Nice a
  default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> UpdaterT Nice a
  mkPrivate Origin
o = (a' -> ChangeT Nice a') -> f a' -> ChangeT Nice (f a')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a' -> ChangeT Nice a') -> f a' -> ChangeT Nice (f a'))
-> (a' -> ChangeT Nice a') -> f a' -> ChangeT Nice (f a')
forall a b. (a -> b) -> a -> b
$ Origin -> a' -> ChangeT Nice a'
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
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 :: Origin -> UpdaterT Nice Access
mkPrivate Origin
o = \case
    p :: Access
p@PrivateAccess{} -> UpdaterT Nice Access
forall (m :: * -> *) a. Monad m => a -> m a
return Access
p  -- OR? return $ PrivateAccess o
    Access
_                 -> UpdaterT Nice Access
forall (m :: * -> *) a. Monad m => UpdaterT m a
dirty UpdaterT Nice Access -> UpdaterT Nice Access
forall a b. (a -> b) -> a -> b
$ Origin -> Access
PrivateAccess Origin
o

instance MakePrivate NiceDeclaration where
  mkPrivate :: Origin -> UpdaterT Nice NiceDeclaration
mkPrivate Origin
o = \case
      Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
e                    -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> IsInstance
-> ArgInfo
-> Name
-> Expr
-> NiceDeclaration
Axiom Range
r Access
p IsAbstract
a IsInstance
i ArgInfo
rel Name
x Expr
e)                (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceField Range
r Access
p IsAbstract
a IsInstance
i TacticAttribute
tac Name
x Arg Expr
e                -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> IsInstance
-> TacticAttribute
-> Name
-> Arg Expr
-> NiceDeclaration
NiceField Range
r Access
p IsAbstract
a IsInstance
i TacticAttribute
tac Name
x Arg Expr
e)            (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      PrimitiveFunction Range
r Access
p IsAbstract
a Name
x Expr
e              -> (\ Access
p -> Range -> Access -> IsAbstract -> Name -> Expr -> NiceDeclaration
PrimitiveFunction Range
r Access
p IsAbstract
a Name
x Expr
e)          (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds                 -> (\ [NiceDeclaration]
ds-> Range
-> TerminationCheck
-> CoverageCheck
-> PositivityCheck
-> [NiceDeclaration]
-> NiceDeclaration
NiceMutual Range
r TerminationCheck
tc CoverageCheck
cc PositivityCheck
pc [NiceDeclaration]
ds)             ([NiceDeclaration] -> NiceDeclaration)
-> ChangeT Nice [NiceDeclaration] -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice [NiceDeclaration]
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o [NiceDeclaration]
ds
      NiceModule Range
r Access
p IsAbstract
a QName
x Telescope
tel [Declaration]
ds                -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> QName
-> Telescope
-> [Declaration]
-> NiceDeclaration
NiceModule Range
r Access
p IsAbstract
a QName
x Telescope
tel [Declaration]
ds)            (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceModuleMacro Range
r Access
p Name
x ModuleApplication
ma OpenShortHand
op ImportDirective
is           -> (\ Access
p -> Range
-> Access
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> NiceDeclaration
NiceModuleMacro Range
r Access
p Name
x ModuleApplication
ma OpenShortHand
op ImportDirective
is)       (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e           -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> IsInstance
-> IsMacro
-> ArgInfo
-> TerminationCheck
-> CoverageCheck
-> Name
-> Expr
-> NiceDeclaration
FunSig Range
r Access
p IsAbstract
a IsInstance
i IsMacro
m ArgInfo
rel TerminationCheck
tc CoverageCheck
cc Name
x Expr
e)       (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceRecSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t            -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceRecSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t)        (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceDataSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t           -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> PositivityCheck
-> UniverseCheck
-> Name
-> [LamBinding]
-> Expr
-> NiceDeclaration
NiceDataSig Range
r Access
p IsAbstract
a PositivityCheck
pc UniverseCheck
uc Name
x [LamBinding]
ls Expr
t)       (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceFunClause Range
r Access
p IsAbstract
a TerminationCheck
tc CoverageCheck
cc Bool
catchall Declaration
d     -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> TerminationCheck
-> CoverageCheck
-> Bool
-> Declaration
-> NiceDeclaration
NiceFunClause Range
r Access
p IsAbstract
a TerminationCheck
tc CoverageCheck
cc Bool
catchall Declaration
d) (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceUnquoteDecl Range
r Access
p IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e        -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDecl Range
r Access
p IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e)    (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceUnquoteDef Range
r Access
p IsAbstract
a TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e           -> (\ Access
p -> Range
-> Access
-> IsAbstract
-> TerminationCheck
-> CoverageCheck
-> [Name]
-> Expr
-> NiceDeclaration
NiceUnquoteDef Range
r Access
p IsAbstract
a TerminationCheck
tc CoverageCheck
cc [Name]
x Expr
e)       (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NicePatternSyn Range
r Access
p Name
x [Arg Name]
xs Pattern
p'               -> (\ Access
p -> Range -> Access -> Name -> [Arg Name] -> Pattern -> NiceDeclaration
NicePatternSyn Range
r Access
p Name
x [Arg Name]
xs Pattern
p')           (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      NiceGeneralize Range
r Access
p ArgInfo
i TacticAttribute
tac Name
x Expr
t             -> (\ Access
p -> Range
-> Access
-> ArgInfo
-> TacticAttribute
-> Name
-> Expr
-> NiceDeclaration
NiceGeneralize Range
r Access
p ArgInfo
i TacticAttribute
tac Name
x Expr
t)         (Access -> NiceDeclaration)
-> ChangeT Nice Access -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
p
      d :: NiceDeclaration
d@NicePragma{}                           -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@(NiceOpen Range
_ QName
_ ImportDirective
directives)              -> do
        Maybe Range -> (Range -> ChangeT Nice ()) -> ChangeT Nice ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (ImportDirective -> Maybe Range
forall n m. ImportDirective' n m -> Maybe Range
publicOpen ImportDirective
directives) ((Range -> ChangeT Nice ()) -> ChangeT Nice ())
-> (Range -> ChangeT Nice ()) -> ChangeT Nice ()
forall a b. (a -> b) -> a -> b
$ Nice () -> ChangeT Nice ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Nice () -> ChangeT Nice ())
-> (Range -> Nice ()) -> Range -> ChangeT Nice ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationWarning -> Nice ()
niceWarning (DeclarationWarning -> Nice ())
-> (Range -> DeclarationWarning) -> Range -> Nice ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> DeclarationWarning
OpenPublicPrivate
        UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NiceImport{}                           -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      -- Andreas, 2016-07-08, issue #2089
      -- we need to propagate 'private' to the named where modules
      FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc Name
x [Clause]
cls              -> Range
-> [Declaration]
-> IsAbstract
-> IsInstance
-> TerminationCheck
-> CoverageCheck
-> Name
-> [Clause]
-> NiceDeclaration
FunDef Range
r [Declaration]
ds IsAbstract
a IsInstance
i TerminationCheck
tc CoverageCheck
cc Name
x ([Clause] -> NiceDeclaration)
-> ChangeT Nice [Clause] -> ChangeT Nice NiceDeclaration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice [Clause]
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o [Clause]
cls
      d :: NiceDeclaration
d@NiceDataDef{}                          -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d
      d :: NiceDeclaration
d@NiceRecDef{}                           -> UpdaterT Nice NiceDeclaration
forall (m :: * -> *) a. Monad m => a -> m a
return NiceDeclaration
d

instance MakePrivate Clause where
  mkPrivate :: Origin -> UpdaterT Nice Clause
mkPrivate Origin
o (Clause Name
x Bool
catchall LHS
lhs RHS
rhs WhereClause
wh [Clause]
with) = do
    Name -> Bool -> LHS -> RHS -> WhereClause -> [Clause] -> Clause
Clause Name
x Bool
catchall LHS
lhs RHS
rhs (WhereClause -> [Clause] -> Clause)
-> ChangeT Nice WhereClause -> ChangeT Nice ([Clause] -> Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Origin -> UpdaterT Nice WhereClause
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o WhereClause
wh ChangeT Nice ([Clause] -> Clause)
-> ChangeT Nice [Clause] -> ChangeT Nice Clause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Origin -> UpdaterT Nice [Clause]
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o [Clause]
with

instance MakePrivate WhereClause where
  mkPrivate :: Origin -> UpdaterT Nice WhereClause
mkPrivate Origin
o  WhereClause
NoWhere         = UpdaterT Nice WhereClause
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice WhereClause -> UpdaterT Nice WhereClause
forall a b. (a -> b) -> a -> b
$ WhereClause
forall decls. WhereClause' decls
NoWhere
  -- @where@-declarations are protected behind an anonymous module,
  -- thus, they are effectively private by default.
  mkPrivate Origin
o (AnyWhere [Declaration]
ds)    = UpdaterT Nice WhereClause
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT Nice WhereClause -> UpdaterT Nice WhereClause
forall a b. (a -> b) -> a -> b
$ [Declaration] -> WhereClause
forall decls. decls -> WhereClause' decls
AnyWhere [Declaration]
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 Origin
o (SomeWhere Name
m Access
a [Declaration]
ds) = Origin -> UpdaterT Nice Access
forall a. MakePrivate a => Origin -> UpdaterT Nice a
mkPrivate Origin
o Access
a ChangeT Nice Access
-> (Access -> WhereClause) -> ChangeT Nice WhereClause
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ Access
a' -> Name -> Access -> [Declaration] -> WhereClause
forall decls. Name -> Access -> decls -> WhereClause' decls
SomeWhere Name
m Access
a' [Declaration]
ds

-- 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 list of
-- 'Declaration's.
notSoNiceDeclarations :: NiceDeclaration -> [Declaration]
notSoNiceDeclarations :: NiceDeclaration -> [Declaration]
notSoNiceDeclarations = \case
    Axiom Range
_ Access
_ IsAbstract
_ IsInstance
i ArgInfo
rel Name
x Expr
e          -> IsInstance -> [Declaration] -> [Declaration]
inst IsInstance
i [ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration
TypeSig ArgInfo
rel TacticAttribute
forall a. Maybe a
Nothing Name
x Expr
e]
    NiceField Range
_ Access
_ IsAbstract
_ IsInstance
i TacticAttribute
tac Name
x Arg Expr
argt   -> [IsInstance -> TacticAttribute -> Name -> Arg Expr -> Declaration
FieldSig IsInstance
i TacticAttribute
tac Name
x Arg Expr
argt]
    PrimitiveFunction Range
r Access
_ IsAbstract
_ Name
x Expr
e    -> [Range -> [Declaration] -> Declaration
Primitive Range
r [ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration
TypeSig ArgInfo
defaultArgInfo TacticAttribute
forall a. Maybe a
Nothing Name
x Expr
e]]
    NiceMutual Range
r TerminationCheck
_ CoverageCheck
_ PositivityCheck
_ [NiceDeclaration]
ds          -> [Range -> [Declaration] -> Declaration
Mutual Range
r ([Declaration] -> Declaration) -> [Declaration] -> Declaration
forall a b. (a -> b) -> a -> b
$ (NiceDeclaration -> [Declaration])
-> [NiceDeclaration] -> [Declaration]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NiceDeclaration -> [Declaration]
notSoNiceDeclarations [NiceDeclaration]
ds]
    NiceModule Range
r Access
_ IsAbstract
_ QName
x Telescope
tel [Declaration]
ds      -> [Range -> QName -> Telescope -> [Declaration] -> Declaration
Module Range
r QName
x Telescope
tel [Declaration]
ds]
    NiceModuleMacro Range
r Access
_ Name
x ModuleApplication
ma OpenShortHand
o ImportDirective
dir -> [Range
-> Name
-> ModuleApplication
-> OpenShortHand
-> ImportDirective
-> Declaration
ModuleMacro Range
r Name
x ModuleApplication
ma OpenShortHand
o ImportDirective
dir]
    NiceOpen Range
r QName
x ImportDirective
dir               -> [Range -> QName -> ImportDirective -> Declaration
Open Range
r QName
x ImportDirective
dir]
    NiceImport Range
r QName
x Maybe AsName
as OpenShortHand
o ImportDirective
dir        -> [Range
-> QName
-> Maybe AsName
-> OpenShortHand
-> ImportDirective
-> Declaration
Import Range
r QName
x Maybe AsName
as OpenShortHand
o ImportDirective
dir]
    NicePragma Range
_ Pragma
p                 -> [Pragma -> Declaration
Pragma Pragma
p]
    NiceRecSig Range
r Access
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
bs Expr
e    -> [Range -> Name -> [LamBinding] -> Expr -> Declaration
RecordSig Range
r Name
x [LamBinding]
bs Expr
e]
    NiceDataSig Range
r Access
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
bs Expr
e   -> [Range -> Name -> [LamBinding] -> Expr -> Declaration
DataSig Range
r Name
x [LamBinding]
bs Expr
e]
    NiceFunClause Range
_ Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ Bool
_ Declaration
d    -> [Declaration
d]
    FunSig Range
_ Access
_ IsAbstract
_ IsInstance
i IsMacro
_ ArgInfo
rel TerminationCheck
_ CoverageCheck
_ Name
x Expr
e   -> IsInstance -> [Declaration] -> [Declaration]
inst IsInstance
i [ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration
TypeSig ArgInfo
rel TacticAttribute
forall a. Maybe a
Nothing Name
x Expr
e]
    FunDef Range
_ [Declaration]
ds IsAbstract
_ IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_ [Clause]
_        -> [Declaration]
ds
    NiceDataDef Range
r Origin
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x [LamBinding]
bs [NiceDeclaration]
cs  -> [Range -> Name -> [LamBinding] -> [Declaration] -> Declaration
DataDef Range
r Name
x [LamBinding]
bs ([Declaration] -> Declaration) -> [Declaration] -> Declaration
forall a b. (a -> b) -> a -> b
$ (NiceDeclaration -> [Declaration])
-> [NiceDeclaration] -> [Declaration]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NiceDeclaration -> [Declaration]
notSoNiceDeclarations [NiceDeclaration]
cs]
    NiceRecDef Range
r Origin
_ IsAbstract
_ PositivityCheck
_ UniverseCheck
_ Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
bs [Declaration]
ds -> [Range
-> Name
-> Maybe (Ranged Induction)
-> Maybe HasEta
-> Maybe (Name, IsInstance)
-> [LamBinding]
-> [Declaration]
-> Declaration
RecordDef Range
r Name
x Maybe (Ranged Induction)
i Maybe HasEta
e Maybe (Name, IsInstance)
c [LamBinding]
bs [Declaration]
ds]
    NicePatternSyn Range
r Access
_ Name
n [Arg Name]
as Pattern
p      -> [Range -> Name -> [Arg Name] -> Pattern -> Declaration
PatternSyn Range
r Name
n [Arg Name]
as Pattern
p]
    NiceGeneralize Range
r Access
_ ArgInfo
i TacticAttribute
tac Name
n Expr
e   -> [Range -> [Declaration] -> Declaration
Generalize Range
r [ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration
TypeSig ArgInfo
i TacticAttribute
tac Name
n Expr
e]]
    NiceUnquoteDecl Range
r Access
_ IsAbstract
_ IsInstance
i TerminationCheck
_ CoverageCheck
_ [Name]
x Expr
e -> IsInstance -> [Declaration] -> [Declaration]
inst IsInstance
i [Range -> [Name] -> Expr -> Declaration
UnquoteDecl Range
r [Name]
x Expr
e]
    NiceUnquoteDef Range
r Access
_ IsAbstract
_ TerminationCheck
_ CoverageCheck
_ [Name]
x Expr
e    -> [Range -> [Name] -> Expr -> Declaration
UnquoteDef Range
r [Name]
x Expr
e]
  where
    inst :: IsInstance -> [Declaration] -> [Declaration]
inst (InstanceDef Range
r) [Declaration]
ds = [Range -> [Declaration] -> Declaration
InstanceB Range
r [Declaration]
ds]
    inst IsInstance
NotInstanceDef  [Declaration]
ds = [Declaration]
ds

-- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?
niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract
niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract
niceHasAbstract = \case
    Axiom{}                       -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceField Range
_ Access
_ IsAbstract
a IsInstance
_ TacticAttribute
_ Name
_ Arg Expr
_       -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    PrimitiveFunction Range
_ Access
_ IsAbstract
a Name
_ Expr
_   -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    NiceMutual{}                  -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceModule Range
_ Access
_ IsAbstract
a QName
_ Telescope
_ [Declaration]
_        -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    NiceModuleMacro{}             -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceOpen{}                    -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceImport{}                  -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NicePragma{}                  -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceRecSig{}                  -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceDataSig{}                 -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceFunClause Range
_ Access
_ IsAbstract
a TerminationCheck
_ CoverageCheck
_ Bool
_ Declaration
_   -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    FunSig{}                      -> Maybe IsAbstract
forall a. Maybe a
Nothing
    FunDef Range
_ [Declaration]
_ IsAbstract
a IsInstance
_ TerminationCheck
_ CoverageCheck
_ Name
_ [Clause]
_        -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    NiceDataDef Range
_ Origin
_ IsAbstract
a PositivityCheck
_ UniverseCheck
_ Name
_ [LamBinding]
_ [NiceDeclaration]
_   -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    NiceRecDef Range
_ Origin
_ IsAbstract
a PositivityCheck
_ UniverseCheck
_ Name
_ Maybe (Ranged Induction)
_ Maybe HasEta
_ Maybe (Name, IsInstance)
_ [LamBinding]
_ [Declaration]
_ -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    NicePatternSyn{}              -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceGeneralize{}              -> Maybe IsAbstract
forall a. Maybe a
Nothing
    NiceUnquoteDecl Range
_ Access
_ IsAbstract
a IsInstance
_ TerminationCheck
_ CoverageCheck
_ [Name]
_ Expr
_ -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a
    NiceUnquoteDef Range
_ Access
_ IsAbstract
a TerminationCheck
_ CoverageCheck
_ [Name]
_ Expr
_    -> IsAbstract -> Maybe IsAbstract
forall a. a -> Maybe a
Just IsAbstract
a