-- Some optimizations (-O) destroy the expected behavior of unsafePerformIO
-- So, special options are needed, plus NOINLINE for the affected functions.
{-# OPTIONS -fno-cse -fno-full-laziness #-}

{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances,
  GeneralizedNewtypeDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable,
  NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Abstract where

import Prelude hiding (showList, map, concat, foldl, pi, null, (<>))

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, pure, (<*>), (<$>))
#endif
import Control.Monad.Writer (Writer, tell)
import Control.Monad.Trans

import Control.Arrow (first)
import Data.Monoid (All(..))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mempty, mconcat)
import Data.Foldable (Foldable, foldMap)
import Data.Traversable (Traversable)
#endif
import Data.Unique

import Data.List (map)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

-- import Debug.Trace
import Data.IORef
import System.IO.Unsafe

import Text.PrettyPrint as PP

import Collection (Collection)
import qualified Collection as Coll
import Polarity as Pol
import TreeShapedOrder (TSO)
import qualified TreeShapedOrder as TSO
import Util hiding (parens, brackets)
import qualified Util
import {-# SOURCE #-} Value (TeleVal)

-- * Names carry a name suggestion and a unique identifier

-- | Each Name is classified as "User", "EtaAlias", or "Quote".
data WhatName
  = UserName
  | EtaAliasName -- ^ a name for the eta-expanded name of a definition
  | QuoteName
    deriving (WhatName -> WhatName -> Bool
(WhatName -> WhatName -> Bool)
-> (WhatName -> WhatName -> Bool) -> Eq WhatName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WhatName -> WhatName -> Bool
== :: WhatName -> WhatName -> Bool
$c/= :: WhatName -> WhatName -> Bool
/= :: WhatName -> WhatName -> Bool
Eq, Eq WhatName
Eq WhatName =>
(WhatName -> WhatName -> Ordering)
-> (WhatName -> WhatName -> Bool)
-> (WhatName -> WhatName -> Bool)
-> (WhatName -> WhatName -> Bool)
-> (WhatName -> WhatName -> Bool)
-> (WhatName -> WhatName -> WhatName)
-> (WhatName -> WhatName -> WhatName)
-> Ord WhatName
WhatName -> WhatName -> Bool
WhatName -> WhatName -> Ordering
WhatName -> WhatName -> WhatName
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
$ccompare :: WhatName -> WhatName -> Ordering
compare :: WhatName -> WhatName -> Ordering
$c< :: WhatName -> WhatName -> Bool
< :: WhatName -> WhatName -> Bool
$c<= :: WhatName -> WhatName -> Bool
<= :: WhatName -> WhatName -> Bool
$c> :: WhatName -> WhatName -> Bool
> :: WhatName -> WhatName -> Bool
$c>= :: WhatName -> WhatName -> Bool
>= :: WhatName -> WhatName -> Bool
$cmax :: WhatName -> WhatName -> WhatName
max :: WhatName -> WhatName -> WhatName
$cmin :: WhatName -> WhatName -> WhatName
min :: WhatName -> WhatName -> WhatName
Ord, Int -> WhatName -> ShowS
[WhatName] -> ShowS
WhatName -> String
(Int -> WhatName -> ShowS)
-> (WhatName -> String) -> ([WhatName] -> ShowS) -> Show WhatName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WhatName -> ShowS
showsPrec :: Int -> WhatName -> ShowS
$cshow :: WhatName -> String
show :: WhatName -> String
$cshowList :: [WhatName] -> ShowS
showList :: [WhatName] -> ShowS
Show)

data Name = Name
  { Name -> String
suggestion :: String    -- ^ suggestion for printing the name.
  , Name -> WhatName
what       :: WhatName
  , Name -> Unique
uid        :: Unique -- !Unique
  }

-- | Names are compared according to their UID.
instance Eq Name where
  Name
x == :: Name -> Name -> Bool
== Name
x' = Name -> Unique
uid Name
x Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Unique
uid Name
x'

instance Ord Name where
  compare :: Name -> Name -> Ordering
compare Name
x Name
x' = Unique -> Unique -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Name -> Unique
uid Name
x) (Name -> Unique
uid Name
x')

instance Show Name where
  show :: Name -> String
show (Name String
n WhatName
_ Unique
_u) = String
n -- n ++ "`" ++ show (hashUnique u `mod` 13)

-- | @fresh s@ generates a new name with 'suggestion' @s@.
--
--   To a void a monad here, we use imperative features (@unsafePerformIO@).
fresh :: String -> Name
fresh :: String -> Name
fresh String
n = String -> WhatName -> Unique -> Name
Name String
n WhatName
UserName (Unique -> Name) -> Unique -> Name
forall a b. (a -> b) -> a -> b
$ IO Unique -> Unique
forall a. IO a -> a
unsafePerformIO IO Unique
newUnique
{-# NOINLINE fresh #-}

freshen :: Name -> Name
freshen :: Name -> Name
freshen Name
n = String -> Name
fresh (Name -> String
suggestion Name
n)

-- | A non-unique empty name.  Use only inconstant functions!
noName :: Name
noName :: Name
noName = String -> Name
fresh String
""

-- | Check whether name is @""@.
emptyName :: Name -> Bool
emptyName :: Name -> Bool
emptyName Name
n = String -> Bool
forall a. Null a => a -> Bool
null (Name -> String
suggestion Name
n)

nonEmptyName :: Name -> String -> Name
nonEmptyName :: Name -> String -> Name
nonEmptyName Name
n String
s | Name -> Bool
emptyName Name
n = Name
n { suggestion = s }
                 | Bool
otherwise   = Name
n

-- | Get the first non-empty name from a non-empty list of names.
bestName :: [Name] -> Name
bestName :: [Name] -> Name
bestName [Name
n]    = Name
n
bestName (Name
n:[Name]
ns)
  | Name -> Bool
emptyName Name
n = [Name] -> Name
bestName [Name]
ns
  | Bool
otherwise   = Name
n

-- temporary hack for reification

iAmNotUnique :: Unique
iAmNotUnique :: Unique
iAmNotUnique = IO Unique -> Unique
forall a. IO a -> a
unsafePerformIO IO Unique
newUnique
{-# NOINLINE iAmNotUnique #-}

unsafeName :: String -> Name
unsafeName :: String -> Name
unsafeName String
s = String -> WhatName -> Unique -> Name
Name String
s WhatName
QuoteName Unique
iAmNotUnique

-- | External reference to recursive function (outside of the body).
mkExtName :: Name -> Name
mkExtName :: Name -> Name
mkExtName Name
n = String -> WhatName -> Unique -> Name
Name (Name -> String
suggestion Name
n) WhatName
EtaAliasName (Unique -> Name) -> Unique -> Name
forall a b. (a -> b) -> a -> b
$ IO Unique -> Unique
forall a. IO a -> a
unsafePerformIO IO Unique
newUnique
-- mkExtName n = "_" ++ n
{-# NOINLINE mkExtName #-}

mkExtRef :: Name -> Expr
mkExtRef :: Name -> Expr
mkExtRef  Name
n = Name -> Expr
letdef (Name -> Name
mkExtName Name
n)

isEtaAlias :: Name -> Bool
isEtaAlias :: Name -> Bool
isEtaAlias Name
n = Name -> WhatName
what Name
n WhatName -> WhatName -> Bool
forall a. Eq a => a -> a -> Bool
== WhatName
EtaAliasName

-- | Internal name for compiler-generated stuff.
internal :: Name -> Name
internal :: Name -> Name
internal Name
n = Name -> Name
freshen Name
n
-- internal n = "__" ++ n
-- internal names are prefixed by a double underscore (not legal concrete syntax)

-- | Convert a dot pattern into an identifier which should not look too confusing.
spaceToUnderscore :: String -> String
spaceToUnderscore :: ShowS
spaceToUnderscore = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
List.map (\ Char
c -> if Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ' then Char
'_' else Char
c)
{-
exprToName e = spaceToUnderscore $ show e
patToName p  = spaceToUnderscore $ show p
-}

-- | Qualified name.
data QName
  = Qual  { QName -> Name
qual :: Name, QName -> Name
name :: Name }
  | QName { name :: Name }
  deriving (QName -> QName -> Bool
(QName -> QName -> Bool) -> (QName -> QName -> Bool) -> Eq QName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QName -> QName -> Bool
== :: QName -> QName -> Bool
$c/= :: QName -> QName -> Bool
/= :: QName -> QName -> Bool
Eq, Eq QName
Eq QName =>
(QName -> QName -> Ordering)
-> (QName -> QName -> Bool)
-> (QName -> QName -> Bool)
-> (QName -> QName -> Bool)
-> (QName -> QName -> Bool)
-> (QName -> QName -> QName)
-> (QName -> QName -> QName)
-> Ord QName
QName -> QName -> Bool
QName -> QName -> Ordering
QName -> QName -> QName
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
$ccompare :: QName -> QName -> Ordering
compare :: QName -> QName -> Ordering
$c< :: QName -> QName -> Bool
< :: QName -> QName -> Bool
$c<= :: QName -> QName -> Bool
<= :: QName -> QName -> Bool
$c> :: QName -> QName -> Bool
> :: QName -> QName -> Bool
$c>= :: QName -> QName -> Bool
>= :: QName -> QName -> Bool
$cmax :: QName -> QName -> QName
max :: QName -> QName -> QName
$cmin :: QName -> QName -> QName
min :: QName -> QName -> QName
Ord)

instance Show QName where
  show :: QName -> String
show (Qual Name
m Name
n) = Name -> String
forall a. Show a => a -> String
show Name
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
  show (QName Name
n)  = Name -> String
forall a. Show a => a -> String
show Name
n

-- | An unqualified name is an instance of a qualified name.
nameInstanceOf :: QName -> QName -> Bool
nameInstanceOf :: QName -> QName -> Bool
nameInstanceOf (QName Name
n) (Qual Name
_ Name
n') = Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n'
nameInstanceOf QName
n         QName
n'          = QName
n QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
n'

-- | Fails if qualified name.
unqual :: QName -> Name
unqual :: QName -> Name
unqual (QName Name
n) = Name
n
unqual QName
n         = String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Abstract.unqual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n

data Sized = Sized | NotSized
             deriving (Sized -> Sized -> Bool
(Sized -> Sized -> Bool) -> (Sized -> Sized -> Bool) -> Eq Sized
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sized -> Sized -> Bool
== :: Sized -> Sized -> Bool
$c/= :: Sized -> Sized -> Bool
/= :: Sized -> Sized -> Bool
Eq,Eq Sized
Eq Sized =>
(Sized -> Sized -> Ordering)
-> (Sized -> Sized -> Bool)
-> (Sized -> Sized -> Bool)
-> (Sized -> Sized -> Bool)
-> (Sized -> Sized -> Bool)
-> (Sized -> Sized -> Sized)
-> (Sized -> Sized -> Sized)
-> Ord Sized
Sized -> Sized -> Bool
Sized -> Sized -> Ordering
Sized -> Sized -> Sized
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
$ccompare :: Sized -> Sized -> Ordering
compare :: Sized -> Sized -> Ordering
$c< :: Sized -> Sized -> Bool
< :: Sized -> Sized -> Bool
$c<= :: Sized -> Sized -> Bool
<= :: Sized -> Sized -> Bool
$c> :: Sized -> Sized -> Bool
> :: Sized -> Sized -> Bool
$c>= :: Sized -> Sized -> Bool
>= :: Sized -> Sized -> Bool
$cmax :: Sized -> Sized -> Sized
max :: Sized -> Sized -> Sized
$cmin :: Sized -> Sized -> Sized
min :: Sized -> Sized -> Sized
Ord,Int -> Sized -> ShowS
[Sized] -> ShowS
Sized -> String
(Int -> Sized -> ShowS)
-> (Sized -> String) -> ([Sized] -> ShowS) -> Show Sized
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sized -> ShowS
showsPrec :: Int -> Sized -> ShowS
$cshow :: Sized -> String
show :: Sized -> String
$cshowList :: [Sized] -> ShowS
showList :: [Sized] -> ShowS
Show)

data Co = Ind
        | CoInd
          deriving (Co -> Co -> Bool
(Co -> Co -> Bool) -> (Co -> Co -> Bool) -> Eq Co
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Co -> Co -> Bool
== :: Co -> Co -> Bool
$c/= :: Co -> Co -> Bool
/= :: Co -> Co -> Bool
Eq,Eq Co
Eq Co =>
(Co -> Co -> Ordering)
-> (Co -> Co -> Bool)
-> (Co -> Co -> Bool)
-> (Co -> Co -> Bool)
-> (Co -> Co -> Bool)
-> (Co -> Co -> Co)
-> (Co -> Co -> Co)
-> Ord Co
Co -> Co -> Bool
Co -> Co -> Ordering
Co -> Co -> Co
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
$ccompare :: Co -> Co -> Ordering
compare :: Co -> Co -> Ordering
$c< :: Co -> Co -> Bool
< :: Co -> Co -> Bool
$c<= :: Co -> Co -> Bool
<= :: Co -> Co -> Bool
$c> :: Co -> Co -> Bool
> :: Co -> Co -> Bool
$c>= :: Co -> Co -> Bool
>= :: Co -> Co -> Bool
$cmax :: Co -> Co -> Co
max :: Co -> Co -> Co
$cmin :: Co -> Co -> Co
min :: Co -> Co -> Co
Ord,Int -> Co -> ShowS
[Co] -> ShowS
Co -> String
(Int -> Co -> ShowS)
-> (Co -> String) -> ([Co] -> ShowS) -> Show Co
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Co -> ShowS
showsPrec :: Int -> Co -> ShowS
$cshow :: Co -> String
show :: Co -> String
$cshowList :: [Co] -> ShowS
showList :: [Co] -> ShowS
Show)

showFun :: Co -> String
showFun :: Co -> String
showFun Co
Ind   = String
"fun"
showFun Co
CoInd = String
"cofun"

data LtLe = Lt | Le deriving (LtLe -> LtLe -> Bool
(LtLe -> LtLe -> Bool) -> (LtLe -> LtLe -> Bool) -> Eq LtLe
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LtLe -> LtLe -> Bool
== :: LtLe -> LtLe -> Bool
$c/= :: LtLe -> LtLe -> Bool
/= :: LtLe -> LtLe -> Bool
Eq,Eq LtLe
Eq LtLe =>
(LtLe -> LtLe -> Ordering)
-> (LtLe -> LtLe -> Bool)
-> (LtLe -> LtLe -> Bool)
-> (LtLe -> LtLe -> Bool)
-> (LtLe -> LtLe -> Bool)
-> (LtLe -> LtLe -> LtLe)
-> (LtLe -> LtLe -> LtLe)
-> Ord LtLe
LtLe -> LtLe -> Bool
LtLe -> LtLe -> Ordering
LtLe -> LtLe -> LtLe
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
$ccompare :: LtLe -> LtLe -> Ordering
compare :: LtLe -> LtLe -> Ordering
$c< :: LtLe -> LtLe -> Bool
< :: LtLe -> LtLe -> Bool
$c<= :: LtLe -> LtLe -> Bool
<= :: LtLe -> LtLe -> Bool
$c> :: LtLe -> LtLe -> Bool
> :: LtLe -> LtLe -> Bool
$c>= :: LtLe -> LtLe -> Bool
>= :: LtLe -> LtLe -> Bool
$cmax :: LtLe -> LtLe -> LtLe
max :: LtLe -> LtLe -> LtLe
$cmin :: LtLe -> LtLe -> LtLe
min :: LtLe -> LtLe -> LtLe
Ord)

instance Show LtLe where
  show :: LtLe -> String
show LtLe
Lt = String
"<"
  show LtLe
Le = String
"<="

-- decoration of Pi-types --------------------------------------------

-- 1. whether argument is irrelevant / its polarity
-- further possibilities:
-- 2. hidden

data Decoration pos
    = Dec { forall pos. Decoration pos -> pos
thePolarity :: pos }
    | Hidden
  deriving (Decoration pos -> Decoration pos -> Bool
(Decoration pos -> Decoration pos -> Bool)
-> (Decoration pos -> Decoration pos -> Bool)
-> Eq (Decoration pos)
forall pos. Eq pos => Decoration pos -> Decoration pos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall pos. Eq pos => Decoration pos -> Decoration pos -> Bool
== :: Decoration pos -> Decoration pos -> Bool
$c/= :: forall pos. Eq pos => Decoration pos -> Decoration pos -> Bool
/= :: Decoration pos -> Decoration pos -> Bool
Eq, Eq (Decoration pos)
Eq (Decoration pos) =>
(Decoration pos -> Decoration pos -> Ordering)
-> (Decoration pos -> Decoration pos -> Bool)
-> (Decoration pos -> Decoration pos -> Bool)
-> (Decoration pos -> Decoration pos -> Bool)
-> (Decoration pos -> Decoration pos -> Bool)
-> (Decoration pos -> Decoration pos -> Decoration pos)
-> (Decoration pos -> Decoration pos -> Decoration pos)
-> Ord (Decoration pos)
Decoration pos -> Decoration pos -> Bool
Decoration pos -> Decoration pos -> Ordering
Decoration pos -> Decoration pos -> Decoration pos
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
forall pos. Ord pos => Eq (Decoration pos)
forall pos. Ord pos => Decoration pos -> Decoration pos -> Bool
forall pos. Ord pos => Decoration pos -> Decoration pos -> Ordering
forall pos.
Ord pos =>
Decoration pos -> Decoration pos -> Decoration pos
$ccompare :: forall pos. Ord pos => Decoration pos -> Decoration pos -> Ordering
compare :: Decoration pos -> Decoration pos -> Ordering
$c< :: forall pos. Ord pos => Decoration pos -> Decoration pos -> Bool
< :: Decoration pos -> Decoration pos -> Bool
$c<= :: forall pos. Ord pos => Decoration pos -> Decoration pos -> Bool
<= :: Decoration pos -> Decoration pos -> Bool
$c> :: forall pos. Ord pos => Decoration pos -> Decoration pos -> Bool
> :: Decoration pos -> Decoration pos -> Bool
$c>= :: forall pos. Ord pos => Decoration pos -> Decoration pos -> Bool
>= :: Decoration pos -> Decoration pos -> Bool
$cmax :: forall pos.
Ord pos =>
Decoration pos -> Decoration pos -> Decoration pos
max :: Decoration pos -> Decoration pos -> Decoration pos
$cmin :: forall pos.
Ord pos =>
Decoration pos -> Decoration pos -> Decoration pos
min :: Decoration pos -> Decoration pos -> Decoration pos
Ord, (forall a b. (a -> b) -> Decoration a -> Decoration b)
-> (forall a b. a -> Decoration b -> Decoration a)
-> Functor Decoration
forall a b. a -> Decoration b -> Decoration a
forall a b. (a -> b) -> Decoration a -> Decoration b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Decoration a -> Decoration b
fmap :: forall a b. (a -> b) -> Decoration a -> Decoration b
$c<$ :: forall a b. a -> Decoration b -> Decoration a
<$ :: forall a b. a -> Decoration b -> Decoration a
Functor, (forall m. Monoid m => Decoration m -> m)
-> (forall m a. Monoid m => (a -> m) -> Decoration a -> m)
-> (forall m a. Monoid m => (a -> m) -> Decoration a -> m)
-> (forall a b. (a -> b -> b) -> b -> Decoration a -> b)
-> (forall a b. (a -> b -> b) -> b -> Decoration a -> b)
-> (forall b a. (b -> a -> b) -> b -> Decoration a -> b)
-> (forall b a. (b -> a -> b) -> b -> Decoration a -> b)
-> (forall a. (a -> a -> a) -> Decoration a -> a)
-> (forall a. (a -> a -> a) -> Decoration a -> a)
-> (forall a. Decoration a -> [a])
-> (forall a. Decoration a -> Bool)
-> (forall a. Decoration a -> Int)
-> (forall a. Eq a => a -> Decoration a -> Bool)
-> (forall a. Ord a => Decoration a -> a)
-> (forall a. Ord a => Decoration a -> a)
-> (forall a. Num a => Decoration a -> a)
-> (forall a. Num a => Decoration a -> a)
-> Foldable Decoration
forall a. Eq a => a -> Decoration a -> Bool
forall a. Num a => Decoration a -> a
forall a. Ord a => Decoration a -> a
forall m. Monoid m => Decoration m -> m
forall a. Decoration a -> Bool
forall a. Decoration a -> Int
forall a. Decoration a -> [a]
forall a. (a -> a -> a) -> Decoration a -> a
forall m a. Monoid m => (a -> m) -> Decoration a -> m
forall b a. (b -> a -> b) -> b -> Decoration a -> b
forall a b. (a -> b -> b) -> b -> Decoration a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Decoration m -> m
fold :: forall m. Monoid m => Decoration m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Decoration a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Decoration a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Decoration a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Decoration a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Decoration a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Decoration a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Decoration a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Decoration a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Decoration a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Decoration a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Decoration a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Decoration a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Decoration a -> a
foldr1 :: forall a. (a -> a -> a) -> Decoration a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Decoration a -> a
foldl1 :: forall a. (a -> a -> a) -> Decoration a -> a
$ctoList :: forall a. Decoration a -> [a]
toList :: forall a. Decoration a -> [a]
$cnull :: forall a. Decoration a -> Bool
null :: forall a. Decoration a -> Bool
$clength :: forall a. Decoration a -> Int
length :: forall a. Decoration a -> Int
$celem :: forall a. Eq a => a -> Decoration a -> Bool
elem :: forall a. Eq a => a -> Decoration a -> Bool
$cmaximum :: forall a. Ord a => Decoration a -> a
maximum :: forall a. Ord a => Decoration a -> a
$cminimum :: forall a. Ord a => Decoration a -> a
minimum :: forall a. Ord a => Decoration a -> a
$csum :: forall a. Num a => Decoration a -> a
sum :: forall a. Num a => Decoration a -> a
$cproduct :: forall a. Num a => Decoration a -> a
product :: forall a. Num a => Decoration a -> a
Foldable, Functor Decoration
Foldable Decoration
(Functor Decoration, Foldable Decoration) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Decoration a -> f (Decoration b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Decoration (f a) -> f (Decoration a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Decoration a -> m (Decoration b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Decoration (m a) -> m (Decoration a))
-> Traversable Decoration
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Decoration (m a) -> m (Decoration a)
forall (f :: * -> *) a.
Applicative f =>
Decoration (f a) -> f (Decoration a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Decoration a -> m (Decoration b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Decoration a -> f (Decoration b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Decoration a -> f (Decoration b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Decoration a -> f (Decoration b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Decoration (f a) -> f (Decoration a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Decoration (f a) -> f (Decoration a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Decoration a -> m (Decoration b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Decoration a -> m (Decoration b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Decoration (m a) -> m (Decoration a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Decoration (m a) -> m (Decoration a)
Traversable, Int -> Decoration pos -> ShowS
[Decoration pos] -> ShowS
Decoration pos -> String
(Int -> Decoration pos -> ShowS)
-> (Decoration pos -> String)
-> ([Decoration pos] -> ShowS)
-> Show (Decoration pos)
forall pos. Show pos => Int -> Decoration pos -> ShowS
forall pos. Show pos => [Decoration pos] -> ShowS
forall pos. Show pos => Decoration pos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall pos. Show pos => Int -> Decoration pos -> ShowS
showsPrec :: Int -> Decoration pos -> ShowS
$cshow :: forall pos. Show pos => Decoration pos -> String
show :: Decoration pos -> String
$cshowList :: forall pos. Show pos => [Decoration pos] -> ShowS
showList :: [Decoration pos] -> ShowS
Show)

polarity :: Polarity pol => Decoration pol -> pol
polarity :: forall pol. Polarity pol => Decoration pol -> pol
polarity Decoration pol
Hidden    = pol
forall pol. Polarity pol => pol
hidden
polarity (Dec pol
pol) = pol
pol

instance Polarity a => Polarity (Decoration a) where
  erased :: Decoration a -> Bool
erased        = a -> Bool
forall pol. Polarity pol => pol -> Bool
erased (a -> Bool) -> (Decoration a -> a) -> Decoration a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decoration a -> a
forall pol. Polarity pol => Decoration pol -> pol
polarity
  compose :: Decoration a -> Decoration a -> Decoration a
compose  Decoration a
p Decoration a
p' = a -> Decoration a
forall pos. pos -> Decoration pos
Dec (a -> Decoration a) -> a -> Decoration a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall pol. Polarity pol => pol -> pol -> pol
compose (Decoration a -> a
forall pol. Polarity pol => Decoration pol -> pol
polarity Decoration a
p) (Decoration a -> a
forall pol. Polarity pol => Decoration pol -> pol
polarity Decoration a
p')
  neutral :: Decoration a
neutral       = a -> Decoration a
forall pos. pos -> Decoration pos
Dec a
forall pol. Polarity pol => pol
neutral
  promote :: Decoration a -> Decoration a
promote       = a -> Decoration a
forall pos. pos -> Decoration pos
Dec (a -> Decoration a)
-> (Decoration a -> a) -> Decoration a -> Decoration a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall pol. Polarity pol => pol -> pol
promote (a -> a) -> (Decoration a -> a) -> Decoration a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decoration a -> a
forall pol. Polarity pol => Decoration pol -> pol
polarity
  demote :: Decoration a -> Decoration a
demote        = a -> Decoration a
forall pos. pos -> Decoration pos
Dec (a -> Decoration a)
-> (Decoration a -> a) -> Decoration a -> Decoration a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall pol. Polarity pol => pol -> pol
demote (a -> a) -> (Decoration a -> a) -> Decoration a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decoration a -> a
forall pol. Polarity pol => Decoration pol -> pol
polarity
  hidden :: Decoration a
hidden        = Decoration a
forall pos. Decoration pos
Hidden

type Dec = Decoration Pol
type UDec = Decoration PProd

class LensPol a where
  getPol :: a -> Pol
  setPol :: Pol -> a -> a
  setPol = (Pol -> Pol) -> a -> a
forall a. LensPol a => (Pol -> Pol) -> a -> a
mapPol ((Pol -> Pol) -> a -> a) -> (Pol -> Pol -> Pol) -> Pol -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pol -> Pol -> Pol
forall a b. a -> b -> a
const
  mapPol :: (Pol -> Pol) -> a -> a
  mapPol Pol -> Pol
f a
a = Pol -> a -> a
forall a. LensPol a => Pol -> a -> a
setPol (Pol -> Pol
f (a -> Pol
forall a. LensPol a => a -> Pol
getPol a
a)) a
a

instance LensPol Dec where
  getPol :: Dec -> Pol
getPol = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity
  setPol :: Pol -> Dec -> Dec
setPol Pol
_ Dec
Hidden = Dec
forall pos. Decoration pos
Hidden
  setPol Pol
p Dec
dec    = Dec
dec { thePolarity = p }

udec :: Dec -> UDec
udec :: Dec -> UDec
udec = (Pol -> PProd) -> Dec -> UDec
forall a b. (a -> b) -> Decoration a -> Decoration b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pol -> PProd
pprod

irrelevantDec, paramDec, defaultDec, neutralDec :: Decoration Pol
irrelevantDec :: Dec
irrelevantDec = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Pol.Const
paramDec :: Dec
paramDec = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Param
defaultDec :: Dec
defaultDec = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
defaultPol
-- defaultDec = paramDec -- TODO: Dec { polarity = Rec }

defaultUpperDec :: Decoration PProd
defaultUpperDec :: UDec
defaultUpperDec = PProd -> UDec
forall pos. pos -> Decoration pos
Dec (PProd -> UDec) -> PProd -> UDec
forall a b. (a -> b) -> a -> b
$ Pol -> PProd
pprod Pol
SPos
  -- a variable may not be erased and its polarity must be below SPos
-- notErased = Dec False
-- resurrectDec d = d { erased = False }

-- | Composing with 'neutralDec' should do nothing.
neutralDec :: Dec
neutralDec = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
SPos

coDomainDec :: Dec -> Dec
coDomainDec :: Dec -> Dec
coDomainDec Dec
Hidden = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Param -- REDUNDANT
coDomainDec Dec
dec
    | Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec Pol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
== Pol
Pol.Const = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Param
    | Bool
otherwise                 = Pol -> Dec
forall pos. pos -> Decoration pos
Dec Pol
Rec

-- compDec dec dec'
-- composition of decoration, used when type checking arguments
-- of functions decorated with dec
compDec :: Dec -> UDec -> UDec
compDec :: Dec -> UDec -> UDec
compDec Dec
dec UDec
dec' = UDec -> UDec -> UDec
forall pol. Polarity pol => pol -> pol -> pol
compose ((Pol -> PProd) -> Dec -> UDec
forall a b. (a -> b) -> Decoration a -> Decoration b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pol -> PProd
pprod Dec
dec) UDec
dec'

{-
instance Show pos => Show (Decoration pos) where
    show p =
      (if erased p then Util.brackets else Util.parens) $ show $ polarity p
-}


{- OLD CODE
data Decoration pos = Dec { erased :: Bool, polarity :: pos }
           deriving (Eq, Ord, Functor, Foldable, Traversable)

type Dec = Decoration Pol
type UDec = Decoration PProd

irrelevantDec = Dec { erased = True, polarity = Pol.Const }
defaultDec = Dec { erased = False, polarity = Rec }
defaultUpperDec = Dec { erased = False, polarity = pprod SPos }
  -- a variable may not be erased and its polarity must be below SPos
-- notErased = Dec False
resurrectDec d = d { erased = False }

{- RETIRED
-- invCompDec dec dec'
-- inverse composition of decoration, used when type checking arguments
-- of functions decorated with dec
invCompDec :: Dec -> Dec -> Dec
invCompDec (Dec er pol) (Dec er' pol') = Dec
  (if er then False else er')
  (invComp pol pol')
-}

-- compDec dec dec'
-- composition of decoration, used when type checking arguments
-- of functions decorated with dec
compDec :: Dec -> UDec -> UDec
compDec (Dec er pol) (Dec er' pol') = Dec
  (er || er')      -- erasing once is sufficient
  (polProd (pprod pol) pol')

instance Show pos => Show (Decoration pos) where
    show (Dec erased polarity) =
      (if erased then Util.brackets else Util.parens) $ show polarity
-}

-- size expressions --------------------------------------------------

class HasPred a where
  predecessor :: a -> Maybe a

instance HasPred Expr where
  predecessor :: Expr -> Maybe Expr
predecessor (Succ Expr
e) = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
  predecessor Expr
_ = Maybe Expr
forall a. Maybe a
Nothing

sizeSuccE :: Expr -> Expr
sizeSuccE :: Expr -> Expr
sizeSuccE Expr
Infty = Expr
Infty
sizeSuccE Expr
e     = Expr -> Expr
Succ Expr
e

minSizeE :: Expr -> Expr -> Expr
minSizeE :: Expr -> Expr -> Expr
minSizeE Expr
Infty Expr
e2 = Expr
e2
minSizeE Expr
e1 Expr
Infty = Expr
e1
minSizeE Expr
Zero  Expr
_  = Expr
Zero
minSizeE Expr
_  Expr
Zero  = Expr
Zero
minSizeE (Succ Expr
e1) (Succ Expr
e2) = Expr -> Expr
Succ (Expr -> Expr -> Expr
minSizeE Expr
e1 Expr
e2)
minSizeE Expr
e1 Expr
e2 = String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
"minSizeE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
Util.parens ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Expr -> String
forall a. Show a => a -> String
show Expr
e1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
Util.parens ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Expr -> String
forall a. Show a => a -> String
show Expr
e2)

maxSizeE :: Expr -> Expr -> Expr
maxSizeE :: Expr -> Expr -> Expr
maxSizeE Expr
Infty Expr
_  = Expr
Infty
maxSizeE Expr
_  Expr
Infty = Expr
Infty
maxSizeE Expr
Zero  Expr
e2 = Expr
e2
maxSizeE Expr
e1 Expr
Zero  = Expr
e1
maxSizeE (Succ Expr
e1) (Succ Expr
e2) = Expr -> Expr
Succ (Expr -> Expr -> Expr
maxSizeE Expr
e1 Expr
e2)
maxSizeE Expr
e1 Expr
e2 = [Expr] -> Expr
Max [Expr
e1, Expr
e2]
-- maxSizeE e1 e2 = error $ "maxSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2)

flattenMax :: Expr -> [Expr] -> [Expr]
flattenMax :: Expr -> [Expr] -> [Expr]
flattenMax Expr
Infty          [Expr]
_   = [Expr
Infty]
flattenMax Expr
Zero           [Expr]
acc = [Expr]
acc
flattenMax (Max [])       [Expr]
acc = [Expr]
acc
flattenMax (Max (Expr
e : [Expr]
es)) [Expr]
acc = Expr -> [Expr] -> [Expr]
flattenMax Expr
e ([Expr] -> [Expr]) -> [Expr] -> [Expr]
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> [Expr]
flattenMax ([Expr] -> Expr
Max [Expr]
es) [Expr]
acc
flattenMax Expr
e              [Expr]
acc = Expr
e Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr]
acc

-- smart constructor for MAX
maxE :: [Expr] -> Expr
maxE :: [Expr] -> Expr
maxE [Expr]
es = [Expr] -> Expr
Max ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> [Expr] -> [Expr]) -> [Expr] -> [Expr] -> [Expr]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Expr -> [Expr] -> [Expr]
flattenMax [] [Expr]
es

sizeVarsToInfty :: Expr -> Expr
sizeVarsToInfty :: Expr -> Expr
sizeVarsToInfty Expr
Zero = Expr
Zero
sizeVarsToInfty (Succ Expr
e) = Expr -> Expr
sizeSuccE (Expr -> Expr
sizeVarsToInfty Expr
e)
sizeVarsToInfty Expr
_ = Expr
Infty

leqSizeE :: Expr -> Expr -> Bool
leqSizeE :: Expr -> Expr -> Bool
leqSizeE Expr
Zero Expr
_  = Bool
True
leqSizeE Expr
_ Expr
Zero  = Bool
False
leqSizeE Expr
_ Expr
Infty = Bool
True
leqSizeE (Succ Expr
e) (Succ Expr
e') = Expr -> Expr -> Bool
leqSizeE Expr
e Expr
e'
leqSizeE Expr
Infty Expr
_ = Bool
False

-- sorts -------------------------------------------------------------

data Class
  = Tm      -- sort of terms, only needed for erasure
  -- -- | Ty    -- use Set 0!  -- sort of type(constructor)s, only needed for erasure
  -- -- | Ki      -- sort of kinds  -- use Set 0 ... for mor precision
  | Size    -- sort of sizes
  | TSize   -- sort of Size
  -- -- | Type    -- no longer used
    deriving (Class -> Class -> Bool
(Class -> Class -> Bool) -> (Class -> Class -> Bool) -> Eq Class
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
/= :: Class -> Class -> Bool
Eq, Eq Class
Eq Class =>
(Class -> Class -> Ordering)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Class)
-> (Class -> Class -> Class)
-> Ord Class
Class -> Class -> Bool
Class -> Class -> Ordering
Class -> Class -> Class
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
$ccompare :: Class -> Class -> Ordering
compare :: Class -> Class -> Ordering
$c< :: Class -> Class -> Bool
< :: Class -> Class -> Bool
$c<= :: Class -> Class -> Bool
<= :: Class -> Class -> Bool
$c> :: Class -> Class -> Bool
> :: Class -> Class -> Bool
$c>= :: Class -> Class -> Bool
>= :: Class -> Class -> Bool
$cmax :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
min :: Class -> Class -> Class
Ord, Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
(Int -> Class -> ShowS)
-> (Class -> String) -> ([Class] -> ShowS) -> Show Class
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Class -> ShowS
showsPrec :: Int -> Class -> ShowS
$cshow :: Class -> String
show :: Class -> String
$cshowList :: [Class] -> ShowS
showList :: [Class] -> ShowS
Show)

predClass :: Class -> Class
-- predClass Ty    = Tm
predClass :: Class -> Class
predClass Class
TSize = Class
Size
predClass Class
Tm    = Class
Tm
predClass Class
Size  = Class
Size

data Sort a
  = SortC Class -- sort constant (Size, TSize)
  | Set a       -- Set 0 = CoSet #, Set 1 = Type 1, Set 2 = Type 2, ...
  | CoSet a     -- sized version of Set
    deriving (Sort a -> Sort a -> Bool
(Sort a -> Sort a -> Bool)
-> (Sort a -> Sort a -> Bool) -> Eq (Sort a)
forall a. Eq a => Sort a -> Sort a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Sort a -> Sort a -> Bool
== :: Sort a -> Sort a -> Bool
$c/= :: forall a. Eq a => Sort a -> Sort a -> Bool
/= :: Sort a -> Sort a -> Bool
Eq, Eq (Sort a)
Eq (Sort a) =>
(Sort a -> Sort a -> Ordering)
-> (Sort a -> Sort a -> Bool)
-> (Sort a -> Sort a -> Bool)
-> (Sort a -> Sort a -> Bool)
-> (Sort a -> Sort a -> Bool)
-> (Sort a -> Sort a -> Sort a)
-> (Sort a -> Sort a -> Sort a)
-> Ord (Sort a)
Sort a -> Sort a -> Bool
Sort a -> Sort a -> Ordering
Sort a -> Sort a -> Sort a
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
forall a. Ord a => Eq (Sort a)
forall a. Ord a => Sort a -> Sort a -> Bool
forall a. Ord a => Sort a -> Sort a -> Ordering
forall a. Ord a => Sort a -> Sort a -> Sort a
$ccompare :: forall a. Ord a => Sort a -> Sort a -> Ordering
compare :: Sort a -> Sort a -> Ordering
$c< :: forall a. Ord a => Sort a -> Sort a -> Bool
< :: Sort a -> Sort a -> Bool
$c<= :: forall a. Ord a => Sort a -> Sort a -> Bool
<= :: Sort a -> Sort a -> Bool
$c> :: forall a. Ord a => Sort a -> Sort a -> Bool
> :: Sort a -> Sort a -> Bool
$c>= :: forall a. Ord a => Sort a -> Sort a -> Bool
>= :: Sort a -> Sort a -> Bool
$cmax :: forall a. Ord a => Sort a -> Sort a -> Sort a
max :: Sort a -> Sort a -> Sort a
$cmin :: forall a. Ord a => Sort a -> Sort a -> Sort a
min :: Sort a -> Sort a -> Sort a
Ord, (forall a b. (a -> b) -> Sort a -> Sort b)
-> (forall a b. a -> Sort b -> Sort a) -> Functor Sort
forall a b. a -> Sort b -> Sort a
forall a b. (a -> b) -> Sort a -> Sort b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Sort a -> Sort b
fmap :: forall a b. (a -> b) -> Sort a -> Sort b
$c<$ :: forall a b. a -> Sort b -> Sort a
<$ :: forall a b. a -> Sort b -> Sort a
Functor, (forall m. Monoid m => Sort m -> m)
-> (forall m a. Monoid m => (a -> m) -> Sort a -> m)
-> (forall m a. Monoid m => (a -> m) -> Sort a -> m)
-> (forall a b. (a -> b -> b) -> b -> Sort a -> b)
-> (forall a b. (a -> b -> b) -> b -> Sort a -> b)
-> (forall b a. (b -> a -> b) -> b -> Sort a -> b)
-> (forall b a. (b -> a -> b) -> b -> Sort a -> b)
-> (forall a. (a -> a -> a) -> Sort a -> a)
-> (forall a. (a -> a -> a) -> Sort a -> a)
-> (forall a. Sort a -> [a])
-> (forall a. Sort a -> Bool)
-> (forall a. Sort a -> Int)
-> (forall a. Eq a => a -> Sort a -> Bool)
-> (forall a. Ord a => Sort a -> a)
-> (forall a. Ord a => Sort a -> a)
-> (forall a. Num a => Sort a -> a)
-> (forall a. Num a => Sort a -> a)
-> Foldable Sort
forall a. Eq a => a -> Sort a -> Bool
forall a. Num a => Sort a -> a
forall a. Ord a => Sort a -> a
forall m. Monoid m => Sort m -> m
forall a. Sort a -> Bool
forall a. Sort a -> Int
forall a. Sort a -> [a]
forall a. (a -> a -> a) -> Sort a -> a
forall m a. Monoid m => (a -> m) -> Sort a -> m
forall b a. (b -> a -> b) -> b -> Sort a -> b
forall a b. (a -> b -> b) -> b -> Sort a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Sort m -> m
fold :: forall m. Monoid m => Sort m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Sort a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Sort a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Sort a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Sort a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Sort a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Sort a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Sort a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Sort a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Sort a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Sort a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Sort a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Sort a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Sort a -> a
foldr1 :: forall a. (a -> a -> a) -> Sort a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Sort a -> a
foldl1 :: forall a. (a -> a -> a) -> Sort a -> a
$ctoList :: forall a. Sort a -> [a]
toList :: forall a. Sort a -> [a]
$cnull :: forall a. Sort a -> Bool
null :: forall a. Sort a -> Bool
$clength :: forall a. Sort a -> Int
length :: forall a. Sort a -> Int
$celem :: forall a. Eq a => a -> Sort a -> Bool
elem :: forall a. Eq a => a -> Sort a -> Bool
$cmaximum :: forall a. Ord a => Sort a -> a
maximum :: forall a. Ord a => Sort a -> a
$cminimum :: forall a. Ord a => Sort a -> a
minimum :: forall a. Ord a => Sort a -> a
$csum :: forall a. Num a => Sort a -> a
sum :: forall a. Num a => Sort a -> a
$cproduct :: forall a. Num a => Sort a -> a
product :: forall a. Num a => Sort a -> a
Foldable, Functor Sort
Foldable Sort
(Functor Sort, Foldable Sort) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Sort a -> f (Sort b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Sort (f a) -> f (Sort a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Sort a -> m (Sort b))
-> (forall (m :: * -> *) a. Monad m => Sort (m a) -> m (Sort a))
-> Traversable Sort
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Sort (m a) -> m (Sort a)
forall (f :: * -> *) a. Applicative f => Sort (f a) -> f (Sort a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Sort a -> m (Sort b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Sort a -> f (Sort b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Sort a -> f (Sort b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Sort a -> f (Sort b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Sort (f a) -> f (Sort a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Sort (f a) -> f (Sort a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Sort a -> m (Sort b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Sort a -> m (Sort b)
$csequence :: forall (m :: * -> *) a. Monad m => Sort (m a) -> m (Sort a)
sequence :: forall (m :: * -> *) a. Monad m => Sort (m a) -> m (Sort a)
Traversable)

{-
instance Show a => Show (Sort a) where
  show (SortC c) = show c
  show (Set a)   = "Set " ++ show a
  show (CoSet a) = "CoSet " ++ show a
-}

instance Show (Sort Expr) where
  show :: Sort Expr -> String
show (SortC Class
c)     = Class -> String
forall a. Show a => a -> String
show Class
c
  show (Set Expr
Zero)    = String
"Set"
  show (CoSet Expr
Infty) = String
"Set"
  show (Set Expr
e)       = ShowS
Util.parens ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String
"Set " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e)
  show (CoSet Expr
e)     = ShowS
Util.parens ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String
"CoSet " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e)

topSort :: Sort Expr
topSort :: Sort Expr
topSort = Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Infty

-- | The expression representing the type Size.
tSize :: Expr
tSize :: Expr
tSize = Sort Expr -> Expr
Sort (Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Size)

-- | Checking whether an expression represents type Size.
isSize :: Expr -> Bool
isSize :: Expr -> Bool
isSize (Sort (SortC Class
Size)) = Bool
True
isSize (Below LtLe
Le Expr
Infty)    = Bool
True
isSize Expr
_                   = Bool
False

predSort :: Sort Expr -> Sort Expr
predSort :: Sort Expr -> Sort Expr
predSort (SortC  Class
c)     = Class -> Sort Expr
forall a. Class -> Sort a
SortC (Class -> Class
predClass Class
c)
predSort (CoSet  Expr
_)     = Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Tm
predSort (Set Expr
Zero)     = Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Tm
predSort (Set (Succ Expr
e)) = Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
e
predSort (Set Expr
Infty)    = Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Infty
predSort s :: Sort Expr
s@(Set Var{})  = Sort Expr
s
predSort Sort Expr
s = String -> Sort Expr
forall a. HasCallStack => String -> a
error (String -> Sort Expr) -> String -> Sort Expr
forall a b. (a -> b) -> a -> b
$ String
"internal error: predSort " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
s

-- only for sorts appearing in kinds:

succSort :: Sort Expr -> Sort Expr
succSort :: Sort Expr -> Sort Expr
succSort (SortC Class
Size) = Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
TSize
succSort (SortC Class
Tm)   = Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Zero
succSort (Set Expr
e)      = Expr -> Sort Expr
forall a. a -> Sort a
Set (Expr -> Expr
sizeSuccE Expr
e)

minSort :: Sort Expr -> Sort Expr -> Sort Expr
minSort :: Sort Expr -> Sort Expr -> Sort Expr
minSort (SortC Class
Tm) (Set Expr
_) = Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Tm
minSort (Set Expr
_) (SortC Class
Tm) = Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Tm
minSort (Set Expr
e) (Set Expr
e') = Expr -> Sort Expr
forall a. a -> Sort a
Set (Expr -> Expr -> Expr
minSizeE Expr
e Expr
e')
-- minSort (SortC c) (SortC c') | c == c' = SortC c
minSort (SortC Class
c) (SortC Class
c') = Class -> Sort Expr
forall a. Class -> Sort a
SortC (Class -> Sort Expr) -> Class -> Sort Expr
forall a b. (a -> b) -> a -> b
$ Class -> Class -> Class
minClass Class
c Class
c'
minSort Sort Expr
s Sort Expr
s' = String -> Sort Expr
forall a. HasCallStack => String -> a
error (String -> Sort Expr) -> String -> Sort Expr
forall a b. (a -> b) -> a -> b
$ String
"minSort (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
s' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") not implemented"

-- 2012-01-21: that should not be necessary, but to move on...
minClass :: Class -> Class -> Class
minClass :: Class -> Class -> Class
minClass Class
Tm Class
_ = Class
Tm
minClass Class
_ Class
Tm = Class
Tm
minClass Class
Size Class
_ = Class
Size
minClass Class
_ Class
Size = Class
Size
minClass Class
TSize Class
TSize = Class
TSize

maxClass :: Class -> Class -> Class
maxClass :: Class -> Class -> Class
maxClass Class
Tm Class
c = Class
c
maxClass Class
c Class
Tm = Class
c
maxClass Class
Size Class
c = Class
c
maxClass Class
c Class
Size = Class
c
maxClass Class
TSize Class
TSize = Class
TSize

maxSort :: Sort Expr -> Sort Expr -> Sort Expr
maxSort :: Sort Expr -> Sort Expr -> Sort Expr
maxSort (SortC Class
Tm) (Set Expr
e) = Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
e
maxSort (Set Expr
e) (SortC Class
Tm) = Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
e
maxSort (Set Expr
e) (Set Expr
e') = Expr -> Sort Expr
forall a. a -> Sort a
Set (Expr -> Expr -> Expr
maxSizeE Expr
e Expr
e')
-- maxSort (SortC c) (SortC c') | c == c' = SortC c
maxSort (SortC Class
c) (SortC Class
c') = Class -> Sort Expr
forall a. Class -> Sort a
SortC (Class -> Sort Expr) -> Class -> Sort Expr
forall a b. (a -> b) -> a -> b
$ Class -> Class -> Class
maxClass Class
c Class
c'
maxSort Sort Expr
s Sort Expr
s' = String -> Sort Expr
forall a. HasCallStack => String -> a
error (String -> Sort Expr) -> String -> Sort Expr
forall a b. (a -> b) -> a -> b
$ String
"maxSort (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
s' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") not implemented"

{-
leSort :: Sort -> Sort -> Bool
leSort _ Type = True
leSort Type _ = False
leSort s s'   = s == s'
-}

-- s `irrSortFor` s' if a variable of kind s cannot computationally
-- contribute to produce a value of kind s'
irrSortFor :: Sort Expr -> Sort Expr -> Bool
irrSortFor :: Sort Expr -> Sort Expr -> Bool
irrSortFor (SortC Class
Tm) Sort Expr
_          = Bool
False -- terms matter for terms and everything
irrSortFor Sort Expr
_          (SortC Class
Tm) = Bool
True  -- nothing else can be eliminated into a term
irrSortFor (SortC Class
Size) Sort Expr
_        = Bool
False -- sizes matter for everything but terms
irrSortFor Sort Expr
_        (SortC Class
Size) = Bool
True  -- nothing else can be eliminated into a size
irrSortFor (SortC Class
TSize) Sort Expr
_        = Bool
False -- sizes matter for everything but terms
irrSortFor Sort Expr
_        (SortC Class
TSize) = Bool
True  -- nothing else can be eliminated into a size
irrSortFor (Set Expr
e) (Set Expr
e')      = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Bool
leqSizeE Expr
e Expr
e'

-- kinds -------------------------------------------------------------

-- kinds classify expressions into terms, types, universes, ...
-- since the analysis is not precise, we give an interval of classes

data Kind
  = Kind { Kind -> Sort Expr
lowerKind :: Sort Expr , Kind -> Sort Expr
upperKind :: Sort Expr }
  | NoKind   -- absurd clauses, neutral wrt. union
  | AnyKind  -- not yet classified, neutral wrt. intersection
    deriving (Kind -> Kind -> Bool
(Kind -> Kind -> Bool) -> (Kind -> Kind -> Bool) -> Eq Kind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Kind -> Kind -> Bool
== :: Kind -> Kind -> Bool
$c/= :: Kind -> Kind -> Bool
/= :: Kind -> Kind -> Bool
Eq, Eq Kind
Eq Kind =>
(Kind -> Kind -> Ordering)
-> (Kind -> Kind -> Bool)
-> (Kind -> Kind -> Bool)
-> (Kind -> Kind -> Bool)
-> (Kind -> Kind -> Bool)
-> (Kind -> Kind -> Kind)
-> (Kind -> Kind -> Kind)
-> Ord Kind
Kind -> Kind -> Bool
Kind -> Kind -> Ordering
Kind -> Kind -> Kind
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
$ccompare :: Kind -> Kind -> Ordering
compare :: Kind -> Kind -> Ordering
$c< :: Kind -> Kind -> Bool
< :: Kind -> Kind -> Bool
$c<= :: Kind -> Kind -> Bool
<= :: Kind -> Kind -> Bool
$c> :: Kind -> Kind -> Bool
> :: Kind -> Kind -> Bool
$c>= :: Kind -> Kind -> Bool
>= :: Kind -> Kind -> Bool
$cmax :: Kind -> Kind -> Kind
max :: Kind -> Kind -> Kind
$cmin :: Kind -> Kind -> Kind
min :: Kind -> Kind -> Kind
Ord)

defaultKind, kSize, kTSize, kTerm, kType :: Kind
--defaultKind = Kind (SortC Tm) topSort -- no classification, could be anything
defaultKind :: Kind
defaultKind = Kind
AnyKind

preciseKind :: Sort Expr -> Kind
preciseKind :: Sort Expr -> Kind
preciseKind Sort Expr
s = Sort Expr -> Sort Expr -> Kind
Kind Sort Expr
s Sort Expr
s
kSize :: Kind
kSize   = Sort Expr -> Kind
preciseKind (Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Size)
kTSize :: Kind
kTSize  = Sort Expr -> Kind
preciseKind (Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
TSize)
kTerm :: Kind
kTerm   = Sort Expr -> Kind
preciseKind (Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Tm)
kType :: Kind
kType   = Sort Expr -> Kind
preciseKind (Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Zero)
kUniv :: Expr -> Kind
kUniv :: Expr -> Kind
kUniv Expr
e = Sort Expr -> Kind
preciseKind (Expr -> Sort Expr
forall a. a -> Sort a
Set (Expr -> Expr
Succ (Expr -> Expr
sizeVarsToInfty Expr
e))) -- used in TypeChecker

instance Show Kind where
  show :: Kind -> String
show Kind
NoKind = String
"()"
  show Kind
AnyKind = String
"?"
--  show k | k == defaultKind = "?"
  show (Kind Sort Expr
kl Sort Expr
ku) | Sort Expr
kl Sort Expr -> Sort Expr -> Bool
forall a. Eq a => a -> a -> Bool
== Sort Expr
ku = Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
kl
  show (Kind Sort Expr
kl Sort Expr
ku) = Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
kl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Sort Expr -> String
forall a. Show a => a -> String
show Sort Expr
ku

-- print kind in four letters
prettyKind :: Kind -> String
prettyKind :: Kind -> String
prettyKind Kind
NoKind                       = String
"none"
prettyKind Kind
AnyKind                      = String
"anyk"
-- prettyKind k | k == defaultKind         = "anyk"
prettyKind (Kind Sort Expr
_ (SortC Class
Tm))          = String
"term"
prettyKind (Kind Sort Expr
_ (SortC Class
Size))        = String
"size"
prettyKind Kind
k | Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
kType               = String
"type"
prettyKind (Kind (Set (Succ Expr
Zero)) Sort Expr
_)   = String
"univ"
prettyKind (Kind (Set Expr
Zero) Sort Expr
_)          = String
"ty-u"
prettyKind (Kind (SortC Class
Tm) (Set Expr
Zero)) = String
"tmty"
prettyKind Kind
_                            = String
"mixk"

-- if D : T and T has kind ki, then D has kind dataKind ki
dataKind :: Kind -> Kind
dataKind :: Kind -> Kind
dataKind (Kind Sort Expr
_ (Set (Succ Expr
e))) = Sort Expr -> Sort Expr -> Kind
Kind (Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Zero) (Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
e)

-- in (x : A) -> B, if x : A and A has kind ki, then x has kind argKind ki
argKind :: Kind -> Kind
argKind :: Kind -> Kind
argKind Kind
NoKind = Kind
NoKind
argKind Kind
AnyKind = Kind
AnyKind
argKind (Kind Sort Expr
s Sort Expr
s') = Sort Expr -> Sort Expr -> Kind
Kind (Sort Expr -> Sort Expr
predSort Sort Expr
s) (Sort Expr -> Sort Expr
predSort Sort Expr
s')

-- if e : A and A has kind ki, then e has kind predKind ki
predKind :: Kind -> Kind
predKind :: Kind -> Kind
predKind Kind
NoKind = Kind
NoKind
predKind Kind
AnyKind = Kind
AnyKind
-- predecessors in the kind hierarchy
predKind ki :: Kind
ki@(Kind Sort Expr
_ (SortC Class
Size))  = String -> Kind
forall a. HasCallStack => String -> a
error (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$ String
"predKind " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ki
predKind (Kind Sort Expr
_ (SortC Class
TSize)) = Kind
kSize
-- proper types are only inhabited by terms
predKind (Kind Sort Expr
_ (Set Expr
Zero)) = Kind
kTerm
-- proper universes are inhabited by types and universes
predKind (Kind (Set (Succ Expr
_)) Sort Expr
s) = Sort Expr -> Sort Expr -> Kind
Kind (Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Zero) (Sort Expr -> Sort Expr
predSort Sort Expr
s)
-- something which is a type or a universe can be inhabited by a term
predKind (Kind Sort Expr
_ Sort Expr
s) = Sort Expr -> Sort Expr -> Kind
Kind (Class -> Sort Expr
forall a. Class -> Sort a
SortC Class
Tm) (Sort Expr -> Sort Expr
predSort Sort Expr
s)

succKind :: Kind -> Kind
succKind :: Kind -> Kind
succKind Kind
AnyKind = Kind
AnyKind
succKind (Kind Sort Expr
_ (SortC Class
Tm)) = Kind
kType
succKind (Kind Sort Expr
_ (SortC Class
Size)) = Kind
kTSize
succKind (Kind Sort Expr
s Sort Expr
_) = Sort Expr -> Sort Expr -> Kind
Kind (Sort Expr -> Sort Expr
succSort Sort Expr
s) (Expr -> Sort Expr
forall a. a -> Sort a
Set Expr
Infty) -- no upper bound

-- partial operation!
intersectKind :: Kind -> Kind -> Kind
intersectKind :: Kind -> Kind -> Kind
intersectKind Kind
NoKind Kind
ki = Kind
ki -- NoKind means here "intersection is not happening"
intersectKind Kind
ki Kind
NoKind = Kind
ki
intersectKind Kind
AnyKind Kind
ki = Kind
ki
intersectKind Kind
ki Kind
AnyKind = Kind
ki
intersectKind (Kind Sort Expr
x1 Sort Expr
x2) (Kind Sort Expr
y1 Sort Expr
y2) =
  Sort Expr -> Sort Expr -> Kind
Kind (Sort Expr -> Sort Expr -> Sort Expr
maxSort Sort Expr
x1 Sort Expr
y1) (Sort Expr -> Sort Expr -> Sort Expr
minSort Sort Expr
x2 Sort Expr
y2)

unionKind :: Kind -> Kind -> Kind
unionKind :: Kind -> Kind -> Kind
unionKind Kind
ki1 Kind
ki2 = -- trace (show ki1 ++ " `unionKind` " ++ show ki2) $
  case (Kind
ki1,Kind
ki2) of
    (Kind
NoKind, Kind
ki) -> Kind
ki
    (Kind
ki, Kind
NoKind) -> Kind
ki
    (Kind
AnyKind, Kind
_) -> Kind
AnyKind
    (Kind
_, Kind
AnyKind) -> Kind
AnyKind
    (Kind Sort Expr
x1 Sort Expr
x2, Kind Sort Expr
y1 Sort Expr
y2) ->
      Sort Expr -> Sort Expr -> Kind
Kind (Sort Expr -> Sort Expr -> Sort Expr
minSort Sort Expr
x1 Sort Expr
y1) (Sort Expr -> Sort Expr -> Sort Expr
maxSort Sort Expr
x2 Sort Expr
y2)

-- ki `irrelevantFor` ki' if an argument of kind ki cannot
-- computationally contribute to a result of kind ki'
irrelevantFor :: Kind -> Kind -> Bool
irrelevantFor :: Kind -> Kind -> Bool
irrelevantFor Kind
NoKind Kind
_ = Bool
False -- do not make a statement if there is no info
irrelevantFor Kind
_ Kind
NoKind = Bool
False
irrelevantFor Kind
AnyKind Kind
_ = Bool
False
irrelevantFor Kind
_ Kind
AnyKind = Bool
False
irrelevantFor (Kind Sort Expr
s Sort Expr
_) (Kind Sort Expr
_ Sort Expr
s') = Sort Expr -> Sort Expr -> Bool
irrSortFor Sort Expr
s Sort Expr
s'
-- worst case szenario: the least kind of the argument is still
-- irrelevant for the biggest kind of the result

data Kinded a = Kinded { forall a. Kinded a -> Kind
kindOf :: Kind, forall a. Kinded a -> a
valueOf :: a }
                deriving (Kinded a -> Kinded a -> Bool
(Kinded a -> Kinded a -> Bool)
-> (Kinded a -> Kinded a -> Bool) -> Eq (Kinded a)
forall a. Eq a => Kinded a -> Kinded a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Kinded a -> Kinded a -> Bool
== :: Kinded a -> Kinded a -> Bool
$c/= :: forall a. Eq a => Kinded a -> Kinded a -> Bool
/= :: Kinded a -> Kinded a -> Bool
Eq, Eq (Kinded a)
Eq (Kinded a) =>
(Kinded a -> Kinded a -> Ordering)
-> (Kinded a -> Kinded a -> Bool)
-> (Kinded a -> Kinded a -> Bool)
-> (Kinded a -> Kinded a -> Bool)
-> (Kinded a -> Kinded a -> Bool)
-> (Kinded a -> Kinded a -> Kinded a)
-> (Kinded a -> Kinded a -> Kinded a)
-> Ord (Kinded a)
Kinded a -> Kinded a -> Bool
Kinded a -> Kinded a -> Ordering
Kinded a -> Kinded a -> Kinded a
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
forall a. Ord a => Eq (Kinded a)
forall a. Ord a => Kinded a -> Kinded a -> Bool
forall a. Ord a => Kinded a -> Kinded a -> Ordering
forall a. Ord a => Kinded a -> Kinded a -> Kinded a
$ccompare :: forall a. Ord a => Kinded a -> Kinded a -> Ordering
compare :: Kinded a -> Kinded a -> Ordering
$c< :: forall a. Ord a => Kinded a -> Kinded a -> Bool
< :: Kinded a -> Kinded a -> Bool
$c<= :: forall a. Ord a => Kinded a -> Kinded a -> Bool
<= :: Kinded a -> Kinded a -> Bool
$c> :: forall a. Ord a => Kinded a -> Kinded a -> Bool
> :: Kinded a -> Kinded a -> Bool
$c>= :: forall a. Ord a => Kinded a -> Kinded a -> Bool
>= :: Kinded a -> Kinded a -> Bool
$cmax :: forall a. Ord a => Kinded a -> Kinded a -> Kinded a
max :: Kinded a -> Kinded a -> Kinded a
$cmin :: forall a. Ord a => Kinded a -> Kinded a -> Kinded a
min :: Kinded a -> Kinded a -> Kinded a
Ord, (forall a b. (a -> b) -> Kinded a -> Kinded b)
-> (forall a b. a -> Kinded b -> Kinded a) -> Functor Kinded
forall a b. a -> Kinded b -> Kinded a
forall a b. (a -> b) -> Kinded a -> Kinded b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Kinded a -> Kinded b
fmap :: forall a b. (a -> b) -> Kinded a -> Kinded b
$c<$ :: forall a b. a -> Kinded b -> Kinded a
<$ :: forall a b. a -> Kinded b -> Kinded a
Functor, (forall m. Monoid m => Kinded m -> m)
-> (forall m a. Monoid m => (a -> m) -> Kinded a -> m)
-> (forall m a. Monoid m => (a -> m) -> Kinded a -> m)
-> (forall a b. (a -> b -> b) -> b -> Kinded a -> b)
-> (forall a b. (a -> b -> b) -> b -> Kinded a -> b)
-> (forall b a. (b -> a -> b) -> b -> Kinded a -> b)
-> (forall b a. (b -> a -> b) -> b -> Kinded a -> b)
-> (forall a. (a -> a -> a) -> Kinded a -> a)
-> (forall a. (a -> a -> a) -> Kinded a -> a)
-> (forall a. Kinded a -> [a])
-> (forall a. Kinded a -> Bool)
-> (forall a. Kinded a -> Int)
-> (forall a. Eq a => a -> Kinded a -> Bool)
-> (forall a. Ord a => Kinded a -> a)
-> (forall a. Ord a => Kinded a -> a)
-> (forall a. Num a => Kinded a -> a)
-> (forall a. Num a => Kinded a -> a)
-> Foldable Kinded
forall a. Eq a => a -> Kinded a -> Bool
forall a. Num a => Kinded a -> a
forall a. Ord a => Kinded a -> a
forall m. Monoid m => Kinded m -> m
forall a. Kinded a -> Bool
forall a. Kinded a -> Int
forall a. Kinded a -> [a]
forall a. (a -> a -> a) -> Kinded a -> a
forall m a. Monoid m => (a -> m) -> Kinded a -> m
forall b a. (b -> a -> b) -> b -> Kinded a -> b
forall a b. (a -> b -> b) -> b -> Kinded a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Kinded m -> m
fold :: forall m. Monoid m => Kinded m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Kinded a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Kinded a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Kinded a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Kinded a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Kinded a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Kinded a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Kinded a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Kinded a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Kinded a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Kinded a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Kinded a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Kinded a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Kinded a -> a
foldr1 :: forall a. (a -> a -> a) -> Kinded a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Kinded a -> a
foldl1 :: forall a. (a -> a -> a) -> Kinded a -> a
$ctoList :: forall a. Kinded a -> [a]
toList :: forall a. Kinded a -> [a]
$cnull :: forall a. Kinded a -> Bool
null :: forall a. Kinded a -> Bool
$clength :: forall a. Kinded a -> Int
length :: forall a. Kinded a -> Int
$celem :: forall a. Eq a => a -> Kinded a -> Bool
elem :: forall a. Eq a => a -> Kinded a -> Bool
$cmaximum :: forall a. Ord a => Kinded a -> a
maximum :: forall a. Ord a => Kinded a -> a
$cminimum :: forall a. Ord a => Kinded a -> a
minimum :: forall a. Ord a => Kinded a -> a
$csum :: forall a. Num a => Kinded a -> a
sum :: forall a. Num a => Kinded a -> a
$cproduct :: forall a. Num a => Kinded a -> a
product :: forall a. Num a => Kinded a -> a
Foldable, Functor Kinded
Foldable Kinded
(Functor Kinded, Foldable Kinded) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Kinded a -> f (Kinded b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Kinded (f a) -> f (Kinded a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Kinded a -> m (Kinded b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Kinded (m a) -> m (Kinded a))
-> Traversable Kinded
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Kinded (m a) -> m (Kinded a)
forall (f :: * -> *) a.
Applicative f =>
Kinded (f a) -> f (Kinded a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Kinded a -> m (Kinded b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Kinded a -> f (Kinded b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Kinded a -> f (Kinded b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Kinded a -> f (Kinded b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Kinded (f a) -> f (Kinded a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Kinded (f a) -> f (Kinded a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Kinded a -> m (Kinded b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Kinded a -> m (Kinded b)
$csequence :: forall (m :: * -> *) a. Monad m => Kinded (m a) -> m (Kinded a)
sequence :: forall (m :: * -> *) a. Monad m => Kinded (m a) -> m (Kinded a)
Traversable)

instance Show a => Show (Kinded a) where
--  show (Kinded ki a) | ki == defaultKind = show a
  show :: Kinded a -> String
show (Kinded Kind
ki a
a) = a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"::" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ki

-- function domains --------------------------------------------------

data Dom a = Domain { forall a. Dom a -> a
typ :: a, forall a. Dom a -> Kind
kind :: Kind, forall a. Dom a -> Dec
decor :: Dec }
             deriving (Dom a -> Dom a -> Bool
(Dom a -> Dom a -> Bool) -> (Dom a -> Dom a -> Bool) -> Eq (Dom a)
forall a. Eq a => Dom a -> Dom a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Dom a -> Dom a -> Bool
== :: Dom a -> Dom a -> Bool
$c/= :: forall a. Eq a => Dom a -> Dom a -> Bool
/= :: Dom a -> Dom a -> Bool
Eq, Eq (Dom a)
Eq (Dom a) =>
(Dom a -> Dom a -> Ordering)
-> (Dom a -> Dom a -> Bool)
-> (Dom a -> Dom a -> Bool)
-> (Dom a -> Dom a -> Bool)
-> (Dom a -> Dom a -> Bool)
-> (Dom a -> Dom a -> Dom a)
-> (Dom a -> Dom a -> Dom a)
-> Ord (Dom a)
Dom a -> Dom a -> Bool
Dom a -> Dom a -> Ordering
Dom a -> Dom a -> Dom a
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
forall a. Ord a => Eq (Dom a)
forall a. Ord a => Dom a -> Dom a -> Bool
forall a. Ord a => Dom a -> Dom a -> Ordering
forall a. Ord a => Dom a -> Dom a -> Dom a
$ccompare :: forall a. Ord a => Dom a -> Dom a -> Ordering
compare :: Dom a -> Dom a -> Ordering
$c< :: forall a. Ord a => Dom a -> Dom a -> Bool
< :: Dom a -> Dom a -> Bool
$c<= :: forall a. Ord a => Dom a -> Dom a -> Bool
<= :: Dom a -> Dom a -> Bool
$c> :: forall a. Ord a => Dom a -> Dom a -> Bool
> :: Dom a -> Dom a -> Bool
$c>= :: forall a. Ord a => Dom a -> Dom a -> Bool
>= :: Dom a -> Dom a -> Bool
$cmax :: forall a. Ord a => Dom a -> Dom a -> Dom a
max :: Dom a -> Dom a -> Dom a
$cmin :: forall a. Ord a => Dom a -> Dom a -> Dom a
min :: Dom a -> Dom a -> Dom a
Ord, (forall a b. (a -> b) -> Dom a -> Dom b)
-> (forall a b. a -> Dom b -> Dom a) -> Functor Dom
forall a b. a -> Dom b -> Dom a
forall a b. (a -> b) -> Dom a -> Dom b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Dom a -> Dom b
fmap :: forall a b. (a -> b) -> Dom a -> Dom b
$c<$ :: forall a b. a -> Dom b -> Dom a
<$ :: forall a b. a -> Dom b -> Dom a
Functor, (forall m. Monoid m => Dom m -> m)
-> (forall m a. Monoid m => (a -> m) -> Dom a -> m)
-> (forall m a. Monoid m => (a -> m) -> Dom a -> m)
-> (forall a b. (a -> b -> b) -> b -> Dom a -> b)
-> (forall a b. (a -> b -> b) -> b -> Dom a -> b)
-> (forall b a. (b -> a -> b) -> b -> Dom a -> b)
-> (forall b a. (b -> a -> b) -> b -> Dom a -> b)
-> (forall a. (a -> a -> a) -> Dom a -> a)
-> (forall a. (a -> a -> a) -> Dom a -> a)
-> (forall a. Dom a -> [a])
-> (forall a. Dom a -> Bool)
-> (forall a. Dom a -> Int)
-> (forall a. Eq a => a -> Dom a -> Bool)
-> (forall a. Ord a => Dom a -> a)
-> (forall a. Ord a => Dom a -> a)
-> (forall a. Num a => Dom a -> a)
-> (forall a. Num a => Dom a -> a)
-> Foldable Dom
forall a. Eq a => a -> Dom a -> Bool
forall a. Num a => Dom a -> a
forall a. Ord a => Dom a -> a
forall m. Monoid m => Dom m -> m
forall a. Dom a -> Bool
forall a. Dom a -> Int
forall a. Dom a -> [a]
forall a. (a -> a -> a) -> Dom a -> a
forall m a. Monoid m => (a -> m) -> Dom a -> m
forall b a. (b -> a -> b) -> b -> Dom a -> b
forall a b. (a -> b -> b) -> b -> Dom a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Dom m -> m
fold :: forall m. Monoid m => Dom m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Dom a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Dom a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Dom a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Dom a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Dom a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Dom a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Dom a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Dom a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Dom a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Dom a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Dom a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Dom a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Dom a -> a
foldr1 :: forall a. (a -> a -> a) -> Dom a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Dom a -> a
foldl1 :: forall a. (a -> a -> a) -> Dom a -> a
$ctoList :: forall a. Dom a -> [a]
toList :: forall a. Dom a -> [a]
$cnull :: forall a. Dom a -> Bool
null :: forall a. Dom a -> Bool
$clength :: forall a. Dom a -> Int
length :: forall a. Dom a -> Int
$celem :: forall a. Eq a => a -> Dom a -> Bool
elem :: forall a. Eq a => a -> Dom a -> Bool
$cmaximum :: forall a. Ord a => Dom a -> a
maximum :: forall a. Ord a => Dom a -> a
$cminimum :: forall a. Ord a => Dom a -> a
minimum :: forall a. Ord a => Dom a -> a
$csum :: forall a. Num a => Dom a -> a
sum :: forall a. Num a => Dom a -> a
$cproduct :: forall a. Num a => Dom a -> a
product :: forall a. Num a => Dom a -> a
Foldable, Functor Dom
Foldable Dom
(Functor Dom, Foldable Dom) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Dom a -> f (Dom b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Dom (f a) -> f (Dom a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Dom a -> m (Dom b))
-> (forall (m :: * -> *) a. Monad m => Dom (m a) -> m (Dom a))
-> Traversable Dom
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Dom (m a) -> m (Dom a)
forall (f :: * -> *) a. Applicative f => Dom (f a) -> f (Dom a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dom a -> m (Dom b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom a -> f (Dom b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom a -> f (Dom b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom a -> f (Dom b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Dom (f a) -> f (Dom a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Dom (f a) -> f (Dom a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dom a -> m (Dom b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Dom a -> m (Dom b)
$csequence :: forall (m :: * -> *) a. Monad m => Dom (m a) -> m (Dom a)
sequence :: forall (m :: * -> *) a. Monad m => Dom (m a) -> m (Dom a)
Traversable)

instance Show a => Show (Dom a) where
    show :: Dom a -> String
show (Domain a
ty Kind
ki Dec
dec) = Dec -> String
forall a. Show a => a -> String
show Dec
dec String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"::" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ki

defaultDomain :: a -> Dom a
defaultDomain :: forall a. a -> Dom a
defaultDomain a
a = a -> Kind -> Dec -> Dom a
forall a. a -> Kind -> Dec -> Dom a
Domain a
a Kind
defaultKind Dec
defaultDec

domFromKinded :: Kinded a -> Dom a
domFromKinded :: forall a. Kinded a -> Dom a
domFromKinded (Kinded Kind
ki a
t) = a -> Kind -> Dec -> Dom a
forall a. a -> Kind -> Dec -> Dom a
Domain a
t Kind
ki Dec
defaultDec

defaultIrrDom :: a -> Dom a
defaultIrrDom :: forall a. a -> Dom a
defaultIrrDom a
a = a -> Kind -> Dec -> Dom a
forall a. a -> Kind -> Dec -> Dom a
Domain a
a Kind
defaultKind Dec
irrelevantDec

sizeDomain :: Dec -> Dom Expr
sizeDomain :: Dec -> Dom Expr
sizeDomain Dec
dec = Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain Expr
tSize Kind
kTSize Dec
dec

belowDomain :: Dec -> LtLe -> Expr -> Dom Expr
belowDomain :: Dec -> LtLe -> Expr -> Dom Expr
belowDomain Dec
dec LtLe
ltle Expr
e = Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain (LtLe -> Expr -> Expr
Below LtLe
ltle Expr
e) Kind
kTSize Dec
dec

class LensDec a where
  getDec :: a -> Dec
  setDec :: Dec -> a -> a
  setDec Dec
d = (Dec -> Dec) -> a -> a
forall a. LensDec a => (Dec -> Dec) -> a -> a
mapDec ((Dec -> Dec) -> a -> a) -> (Dec -> Dec) -> a -> a
forall a b. (a -> b) -> a -> b
$ Dec -> Dec -> Dec
forall a b. a -> b -> a
const Dec
d
  mapDec :: (Dec -> Dec) -> a -> a
  mapDec Dec -> Dec
f a
a = Dec -> a -> a
forall a. LensDec a => Dec -> a -> a
setDec (Dec -> Dec
f (Dec -> Dec) -> Dec -> Dec
forall a b. (a -> b) -> a -> b
$ a -> Dec
forall a. LensDec a => a -> Dec
getDec a
a) a
a

instance LensDec (Dom a) where
  getDec :: Dom a -> Dec
getDec = Dom a -> Dec
forall a. Dom a -> Dec
decor
  setDec :: Dec -> Dom a -> Dom a
setDec Dec
d Dom a
dom = Dom a
dom { decor = d }

instance LensPol (Dom a) where
  getPol :: Dom a -> Pol
getPol = Dec -> Pol
forall a. LensPol a => a -> Pol
getPol (Dec -> Pol) -> (Dom a -> Dec) -> Dom a -> Pol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom a -> Dec
forall a. LensDec a => a -> Dec
getDec
  mapPol :: (Pol -> Pol) -> Dom a -> Dom a
mapPol = (Dec -> Dec) -> Dom a -> Dom a
forall a. LensDec a => (Dec -> Dec) -> a -> a
mapDec ((Dec -> Dec) -> Dom a -> Dom a)
-> ((Pol -> Pol) -> Dec -> Dec) -> (Pol -> Pol) -> Dom a -> Dom a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pol -> Pol) -> Dec -> Dec
forall a. LensPol a => (Pol -> Pol) -> a -> a
mapPol

-- identifiers -------------------------------------------------------

-- |
data ConK
  = Cons    -- ^ a constructor
  | CoCons  -- ^ a coconstructor
  | DefPat  -- ^ a defined pattern
    deriving (ConK -> ConK -> Bool
(ConK -> ConK -> Bool) -> (ConK -> ConK -> Bool) -> Eq ConK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConK -> ConK -> Bool
== :: ConK -> ConK -> Bool
$c/= :: ConK -> ConK -> Bool
/= :: ConK -> ConK -> Bool
Eq, Eq ConK
Eq ConK =>
(ConK -> ConK -> Ordering)
-> (ConK -> ConK -> Bool)
-> (ConK -> ConK -> Bool)
-> (ConK -> ConK -> Bool)
-> (ConK -> ConK -> Bool)
-> (ConK -> ConK -> ConK)
-> (ConK -> ConK -> ConK)
-> Ord ConK
ConK -> ConK -> Bool
ConK -> ConK -> Ordering
ConK -> ConK -> ConK
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
$ccompare :: ConK -> ConK -> Ordering
compare :: ConK -> ConK -> Ordering
$c< :: ConK -> ConK -> Bool
< :: ConK -> ConK -> Bool
$c<= :: ConK -> ConK -> Bool
<= :: ConK -> ConK -> Bool
$c> :: ConK -> ConK -> Bool
> :: ConK -> ConK -> Bool
$c>= :: ConK -> ConK -> Bool
>= :: ConK -> ConK -> Bool
$cmax :: ConK -> ConK -> ConK
max :: ConK -> ConK -> ConK
$cmin :: ConK -> ConK -> ConK
min :: ConK -> ConK -> ConK
Ord, Int -> ConK -> ShowS
[ConK] -> ShowS
ConK -> String
(Int -> ConK -> ShowS)
-> (ConK -> String) -> ([ConK] -> ShowS) -> Show ConK
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConK -> ShowS
showsPrec :: Int -> ConK -> ShowS
$cshow :: ConK -> String
show :: ConK -> String
$cshowList :: [ConK] -> ShowS
showList :: [ConK] -> ShowS
Show)

data IdKind
  = DatK       -- ^ data/codata
  | ConK ConK  -- ^ constructor (ind/coind/defined)
  | FunK       -- ^ fun/cofun
  | LetK       -- ^ let definition
    deriving (IdKind -> IdKind -> Bool
(IdKind -> IdKind -> Bool)
-> (IdKind -> IdKind -> Bool) -> Eq IdKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdKind -> IdKind -> Bool
== :: IdKind -> IdKind -> Bool
$c/= :: IdKind -> IdKind -> Bool
/= :: IdKind -> IdKind -> Bool
Eq, Eq IdKind
Eq IdKind =>
(IdKind -> IdKind -> Ordering)
-> (IdKind -> IdKind -> Bool)
-> (IdKind -> IdKind -> Bool)
-> (IdKind -> IdKind -> Bool)
-> (IdKind -> IdKind -> Bool)
-> (IdKind -> IdKind -> IdKind)
-> (IdKind -> IdKind -> IdKind)
-> Ord IdKind
IdKind -> IdKind -> Bool
IdKind -> IdKind -> Ordering
IdKind -> IdKind -> IdKind
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
$ccompare :: IdKind -> IdKind -> Ordering
compare :: IdKind -> IdKind -> Ordering
$c< :: IdKind -> IdKind -> Bool
< :: IdKind -> IdKind -> Bool
$c<= :: IdKind -> IdKind -> Bool
<= :: IdKind -> IdKind -> Bool
$c> :: IdKind -> IdKind -> Bool
> :: IdKind -> IdKind -> Bool
$c>= :: IdKind -> IdKind -> Bool
>= :: IdKind -> IdKind -> Bool
$cmax :: IdKind -> IdKind -> IdKind
max :: IdKind -> IdKind -> IdKind
$cmin :: IdKind -> IdKind -> IdKind
min :: IdKind -> IdKind -> IdKind
Ord)

instance Show IdKind where
    show :: IdKind -> String
show IdKind
DatK   = String
"data"
    show ConK{} = String
"con"
    show IdKind
FunK   = String
"fun"
    show IdKind
LetK   = String
"let"

conKind :: IdKind -> Bool
conKind :: IdKind -> Bool
conKind (ConK ConK
_) = Bool
True
conKind IdKind
_        = Bool
False

coToConK :: Co -> ConK
coToConK :: Co -> ConK
coToConK Co
Ind = ConK
Cons
coToConK Co
CoInd = ConK
CoCons

data DefId = DefId { DefId -> IdKind
idKind :: IdKind, DefId -> QName
idName :: QName }
           deriving (DefId -> DefId -> Bool
(DefId -> DefId -> Bool) -> (DefId -> DefId -> Bool) -> Eq DefId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DefId -> DefId -> Bool
== :: DefId -> DefId -> Bool
$c/= :: DefId -> DefId -> Bool
/= :: DefId -> DefId -> Bool
Eq, Eq DefId
Eq DefId =>
(DefId -> DefId -> Ordering)
-> (DefId -> DefId -> Bool)
-> (DefId -> DefId -> Bool)
-> (DefId -> DefId -> Bool)
-> (DefId -> DefId -> Bool)
-> (DefId -> DefId -> DefId)
-> (DefId -> DefId -> DefId)
-> Ord DefId
DefId -> DefId -> Bool
DefId -> DefId -> Ordering
DefId -> DefId -> DefId
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
$ccompare :: DefId -> DefId -> Ordering
compare :: DefId -> DefId -> Ordering
$c< :: DefId -> DefId -> Bool
< :: DefId -> DefId -> Bool
$c<= :: DefId -> DefId -> Bool
<= :: DefId -> DefId -> Bool
$c> :: DefId -> DefId -> Bool
> :: DefId -> DefId -> Bool
$c>= :: DefId -> DefId -> Bool
>= :: DefId -> DefId -> Bool
$cmax :: DefId -> DefId -> DefId
max :: DefId -> DefId -> DefId
$cmin :: DefId -> DefId -> DefId
min :: DefId -> DefId -> DefId
Ord)

instance Show DefId where
    show :: DefId -> String
show DefId
d = QName -> String
forall a. Show a => a -> String
show (DefId -> QName
idName DefId
d) -- ++ "@" ++ show (idKind d)

type MVar = Int -- metavariables are numbered

-- typed bindings in Pi, LLet, Telescope -----------------------------

data TBinding a = TBind
  { forall a. TBinding a -> Name
boundName :: Name        -- ^ @emptyName@ if non-dependent.
  , forall a. TBinding a -> Dom a
boundDom  :: Dom a       -- ^ @x : T@ or @i < j@.
  }
  | TMeasure (Measure Expr)  -- ^ Measure @|m|@.
  | TBound   (Bound Expr)    -- ^ Constraint @|m| <(=) |m'|@.
    deriving (TBinding a -> TBinding a -> Bool
(TBinding a -> TBinding a -> Bool)
-> (TBinding a -> TBinding a -> Bool) -> Eq (TBinding a)
forall a. Eq a => TBinding a -> TBinding a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TBinding a -> TBinding a -> Bool
== :: TBinding a -> TBinding a -> Bool
$c/= :: forall a. Eq a => TBinding a -> TBinding a -> Bool
/= :: TBinding a -> TBinding a -> Bool
Eq,Eq (TBinding a)
Eq (TBinding a) =>
(TBinding a -> TBinding a -> Ordering)
-> (TBinding a -> TBinding a -> Bool)
-> (TBinding a -> TBinding a -> Bool)
-> (TBinding a -> TBinding a -> Bool)
-> (TBinding a -> TBinding a -> Bool)
-> (TBinding a -> TBinding a -> TBinding a)
-> (TBinding a -> TBinding a -> TBinding a)
-> Ord (TBinding a)
TBinding a -> TBinding a -> Bool
TBinding a -> TBinding a -> Ordering
TBinding a -> TBinding a -> TBinding a
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
forall a. Ord a => Eq (TBinding a)
forall a. Ord a => TBinding a -> TBinding a -> Bool
forall a. Ord a => TBinding a -> TBinding a -> Ordering
forall a. Ord a => TBinding a -> TBinding a -> TBinding a
$ccompare :: forall a. Ord a => TBinding a -> TBinding a -> Ordering
compare :: TBinding a -> TBinding a -> Ordering
$c< :: forall a. Ord a => TBinding a -> TBinding a -> Bool
< :: TBinding a -> TBinding a -> Bool
$c<= :: forall a. Ord a => TBinding a -> TBinding a -> Bool
<= :: TBinding a -> TBinding a -> Bool
$c> :: forall a. Ord a => TBinding a -> TBinding a -> Bool
> :: TBinding a -> TBinding a -> Bool
$c>= :: forall a. Ord a => TBinding a -> TBinding a -> Bool
>= :: TBinding a -> TBinding a -> Bool
$cmax :: forall a. Ord a => TBinding a -> TBinding a -> TBinding a
max :: TBinding a -> TBinding a -> TBinding a
$cmin :: forall a. Ord a => TBinding a -> TBinding a -> TBinding a
min :: TBinding a -> TBinding a -> TBinding a
Ord,Int -> TBinding a -> ShowS
[TBinding a] -> ShowS
TBinding a -> String
(Int -> TBinding a -> ShowS)
-> (TBinding a -> String)
-> ([TBinding a] -> ShowS)
-> Show (TBinding a)
forall a. Show a => Int -> TBinding a -> ShowS
forall a. Show a => [TBinding a] -> ShowS
forall a. Show a => TBinding a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TBinding a -> ShowS
showsPrec :: Int -> TBinding a -> ShowS
$cshow :: forall a. Show a => TBinding a -> String
show :: TBinding a -> String
$cshowList :: forall a. Show a => [TBinding a] -> ShowS
showList :: [TBinding a] -> ShowS
Show,(forall a b. (a -> b) -> TBinding a -> TBinding b)
-> (forall a b. a -> TBinding b -> TBinding a) -> Functor TBinding
forall a b. a -> TBinding b -> TBinding a
forall a b. (a -> b) -> TBinding a -> TBinding b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TBinding a -> TBinding b
fmap :: forall a b. (a -> b) -> TBinding a -> TBinding b
$c<$ :: forall a b. a -> TBinding b -> TBinding a
<$ :: forall a b. a -> TBinding b -> TBinding a
Functor,(forall m. Monoid m => TBinding m -> m)
-> (forall m a. Monoid m => (a -> m) -> TBinding a -> m)
-> (forall m a. Monoid m => (a -> m) -> TBinding a -> m)
-> (forall a b. (a -> b -> b) -> b -> TBinding a -> b)
-> (forall a b. (a -> b -> b) -> b -> TBinding a -> b)
-> (forall b a. (b -> a -> b) -> b -> TBinding a -> b)
-> (forall b a. (b -> a -> b) -> b -> TBinding a -> b)
-> (forall a. (a -> a -> a) -> TBinding a -> a)
-> (forall a. (a -> a -> a) -> TBinding a -> a)
-> (forall a. TBinding a -> [a])
-> (forall a. TBinding a -> Bool)
-> (forall a. TBinding a -> Int)
-> (forall a. Eq a => a -> TBinding a -> Bool)
-> (forall a. Ord a => TBinding a -> a)
-> (forall a. Ord a => TBinding a -> a)
-> (forall a. Num a => TBinding a -> a)
-> (forall a. Num a => TBinding a -> a)
-> Foldable TBinding
forall a. Eq a => a -> TBinding a -> Bool
forall a. Num a => TBinding a -> a
forall a. Ord a => TBinding a -> a
forall m. Monoid m => TBinding m -> m
forall a. TBinding a -> Bool
forall a. TBinding a -> Int
forall a. TBinding a -> [a]
forall a. (a -> a -> a) -> TBinding a -> a
forall m a. Monoid m => (a -> m) -> TBinding a -> m
forall b a. (b -> a -> b) -> b -> TBinding a -> b
forall a b. (a -> b -> b) -> b -> TBinding a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => TBinding m -> m
fold :: forall m. Monoid m => TBinding m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TBinding a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TBinding a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TBinding a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> TBinding a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> TBinding a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TBinding a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TBinding a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TBinding a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TBinding a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TBinding a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TBinding a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> TBinding a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TBinding a -> a
foldr1 :: forall a. (a -> a -> a) -> TBinding a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TBinding a -> a
foldl1 :: forall a. (a -> a -> a) -> TBinding a -> a
$ctoList :: forall a. TBinding a -> [a]
toList :: forall a. TBinding a -> [a]
$cnull :: forall a. TBinding a -> Bool
null :: forall a. TBinding a -> Bool
$clength :: forall a. TBinding a -> Int
length :: forall a. TBinding a -> Int
$celem :: forall a. Eq a => a -> TBinding a -> Bool
elem :: forall a. Eq a => a -> TBinding a -> Bool
$cmaximum :: forall a. Ord a => TBinding a -> a
maximum :: forall a. Ord a => TBinding a -> a
$cminimum :: forall a. Ord a => TBinding a -> a
minimum :: forall a. Ord a => TBinding a -> a
$csum :: forall a. Num a => TBinding a -> a
sum :: forall a. Num a => TBinding a -> a
$cproduct :: forall a. Num a => TBinding a -> a
product :: forall a. Num a => TBinding a -> a
Foldable,Functor TBinding
Foldable TBinding
(Functor TBinding, Foldable TBinding) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> TBinding a -> f (TBinding b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    TBinding (f a) -> f (TBinding a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> TBinding a -> m (TBinding b))
-> (forall (m :: * -> *) a.
    Monad m =>
    TBinding (m a) -> m (TBinding a))
-> Traversable TBinding
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => TBinding (m a) -> m (TBinding a)
forall (f :: * -> *) a.
Applicative f =>
TBinding (f a) -> f (TBinding a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TBinding a -> m (TBinding b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TBinding a -> f (TBinding b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TBinding a -> f (TBinding b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TBinding a -> f (TBinding b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
TBinding (f a) -> f (TBinding a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
TBinding (f a) -> f (TBinding a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TBinding a -> m (TBinding b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TBinding a -> m (TBinding b)
$csequence :: forall (m :: * -> *) a. Monad m => TBinding (m a) -> m (TBinding a)
sequence :: forall (m :: * -> *) a. Monad m => TBinding (m a) -> m (TBinding a)
Traversable)

type LBind = TBinding (Maybe Type)
type TBind = TBinding Type

noBind :: Dom a -> TBinding a
noBind :: forall a. Dom a -> TBinding a
noBind = Name -> Dom a -> TBinding a
forall a. Name -> Dom a -> TBinding a
TBind (String -> Name
fresh String
"")

boundType :: TBind -> Type
boundType :: TBind -> Expr
boundType = Dom Expr -> Expr
forall a. Dom a -> a
typ (Dom Expr -> Expr) -> (TBind -> Dom Expr) -> TBind -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBind -> Dom Expr
forall a. TBinding a -> Dom a
boundDom

instance LensDec (TBinding a) where
  getDec :: TBinding a -> Dec
getDec = Dom a -> Dec
forall a. LensDec a => a -> Dec
getDec (Dom a -> Dec) -> (TBinding a -> Dom a) -> TBinding a -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBinding a -> Dom a
forall a. TBinding a -> Dom a
boundDom
  mapDec :: (Dec -> Dec) -> TBinding a -> TBinding a
mapDec Dec -> Dec
f (TBind Name
x Dom a
dom) = Name -> Dom a -> TBinding a
forall a. Name -> Dom a -> TBinding a
TBind Name
x (Dom a
dom { decor = f (decor dom) })
  mapDec Dec -> Dec
_ TBinding a
tb = TBinding a
tb

mapDecM :: (Applicative m) => (Dec -> m Dec) -> TBind -> m TBind
mapDecM :: forall (m :: * -> *).
Applicative m =>
(Dec -> m Dec) -> TBind -> m TBind
mapDecM Dec -> m Dec
f tb :: TBind
tb@TBind{} = (Dec -> TBind -> TBind) -> TBind -> Dec -> TBind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Dec -> TBind -> TBind
forall a. LensDec a => Dec -> a -> a
setDec TBind
tb (Dec -> TBind) -> m Dec -> m TBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dec -> m Dec
f (TBind -> Dec
forall a. LensDec a => a -> Dec
getDec TBind
tb)
mapDecM Dec -> m Dec
_ TBind
tb         = TBind -> m TBind
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TBind
tb

-- measures ----------------------------------------------------------

newtype Measure a = Measure { forall a. Measure a -> [a]
measure :: [a] }    -- mu
    deriving (Measure a -> Measure a -> Bool
(Measure a -> Measure a -> Bool)
-> (Measure a -> Measure a -> Bool) -> Eq (Measure a)
forall a. Eq a => Measure a -> Measure a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Measure a -> Measure a -> Bool
== :: Measure a -> Measure a -> Bool
$c/= :: forall a. Eq a => Measure a -> Measure a -> Bool
/= :: Measure a -> Measure a -> Bool
Eq,Eq (Measure a)
Eq (Measure a) =>
(Measure a -> Measure a -> Ordering)
-> (Measure a -> Measure a -> Bool)
-> (Measure a -> Measure a -> Bool)
-> (Measure a -> Measure a -> Bool)
-> (Measure a -> Measure a -> Bool)
-> (Measure a -> Measure a -> Measure a)
-> (Measure a -> Measure a -> Measure a)
-> Ord (Measure a)
Measure a -> Measure a -> Bool
Measure a -> Measure a -> Ordering
Measure a -> Measure a -> Measure a
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
forall a. Ord a => Eq (Measure a)
forall a. Ord a => Measure a -> Measure a -> Bool
forall a. Ord a => Measure a -> Measure a -> Ordering
forall a. Ord a => Measure a -> Measure a -> Measure a
$ccompare :: forall a. Ord a => Measure a -> Measure a -> Ordering
compare :: Measure a -> Measure a -> Ordering
$c< :: forall a. Ord a => Measure a -> Measure a -> Bool
< :: Measure a -> Measure a -> Bool
$c<= :: forall a. Ord a => Measure a -> Measure a -> Bool
<= :: Measure a -> Measure a -> Bool
$c> :: forall a. Ord a => Measure a -> Measure a -> Bool
> :: Measure a -> Measure a -> Bool
$c>= :: forall a. Ord a => Measure a -> Measure a -> Bool
>= :: Measure a -> Measure a -> Bool
$cmax :: forall a. Ord a => Measure a -> Measure a -> Measure a
max :: Measure a -> Measure a -> Measure a
$cmin :: forall a. Ord a => Measure a -> Measure a -> Measure a
min :: Measure a -> Measure a -> Measure a
Ord,(forall a b. (a -> b) -> Measure a -> Measure b)
-> (forall a b. a -> Measure b -> Measure a) -> Functor Measure
forall a b. a -> Measure b -> Measure a
forall a b. (a -> b) -> Measure a -> Measure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Measure a -> Measure b
fmap :: forall a b. (a -> b) -> Measure a -> Measure b
$c<$ :: forall a b. a -> Measure b -> Measure a
<$ :: forall a b. a -> Measure b -> Measure a
Functor,(forall m. Monoid m => Measure m -> m)
-> (forall m a. Monoid m => (a -> m) -> Measure a -> m)
-> (forall m a. Monoid m => (a -> m) -> Measure a -> m)
-> (forall a b. (a -> b -> b) -> b -> Measure a -> b)
-> (forall a b. (a -> b -> b) -> b -> Measure a -> b)
-> (forall b a. (b -> a -> b) -> b -> Measure a -> b)
-> (forall b a. (b -> a -> b) -> b -> Measure a -> b)
-> (forall a. (a -> a -> a) -> Measure a -> a)
-> (forall a. (a -> a -> a) -> Measure a -> a)
-> (forall a. Measure a -> [a])
-> (forall a. Measure a -> Bool)
-> (forall a. Measure a -> Int)
-> (forall a. Eq a => a -> Measure a -> Bool)
-> (forall a. Ord a => Measure a -> a)
-> (forall a. Ord a => Measure a -> a)
-> (forall a. Num a => Measure a -> a)
-> (forall a. Num a => Measure a -> a)
-> Foldable Measure
forall a. Eq a => a -> Measure a -> Bool
forall a. Num a => Measure a -> a
forall a. Ord a => Measure a -> a
forall m. Monoid m => Measure m -> m
forall a. Measure a -> Bool
forall a. Measure a -> Int
forall a. Measure a -> [a]
forall a. (a -> a -> a) -> Measure a -> a
forall m a. Monoid m => (a -> m) -> Measure a -> m
forall b a. (b -> a -> b) -> b -> Measure a -> b
forall a b. (a -> b -> b) -> b -> Measure a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Measure m -> m
fold :: forall m. Monoid m => Measure m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Measure a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Measure a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Measure a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Measure a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Measure a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Measure a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Measure a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Measure a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Measure a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Measure a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Measure a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Measure a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Measure a -> a
foldr1 :: forall a. (a -> a -> a) -> Measure a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Measure a -> a
foldl1 :: forall a. (a -> a -> a) -> Measure a -> a
$ctoList :: forall a. Measure a -> [a]
toList :: forall a. Measure a -> [a]
$cnull :: forall a. Measure a -> Bool
null :: forall a. Measure a -> Bool
$clength :: forall a. Measure a -> Int
length :: forall a. Measure a -> Int
$celem :: forall a. Eq a => a -> Measure a -> Bool
elem :: forall a. Eq a => a -> Measure a -> Bool
$cmaximum :: forall a. Ord a => Measure a -> a
maximum :: forall a. Ord a => Measure a -> a
$cminimum :: forall a. Ord a => Measure a -> a
minimum :: forall a. Ord a => Measure a -> a
$csum :: forall a. Num a => Measure a -> a
sum :: forall a. Num a => Measure a -> a
$cproduct :: forall a. Num a => Measure a -> a
product :: forall a. Num a => Measure a -> a
Foldable,Functor Measure
Foldable Measure
(Functor Measure, Foldable Measure) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Measure a -> f (Measure b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Measure (f a) -> f (Measure a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Measure a -> m (Measure b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Measure (m a) -> m (Measure a))
-> Traversable Measure
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Measure (m a) -> m (Measure a)
forall (f :: * -> *) a.
Applicative f =>
Measure (f a) -> f (Measure a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Measure a -> m (Measure b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Measure a -> f (Measure b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Measure a -> f (Measure b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Measure a -> f (Measure b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Measure (f a) -> f (Measure a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Measure (f a) -> f (Measure a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Measure a -> m (Measure b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Measure a -> m (Measure b)
$csequence :: forall (m :: * -> *) a. Monad m => Measure (m a) -> m (Measure a)
sequence :: forall (m :: * -> *) a. Monad m => Measure (m a) -> m (Measure a)
Traversable)

instance Show a => Show (Measure a) where
    show :: Measure a -> String
show (Measure [a]
l) = String
"|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> (a -> String) -> [a] -> String
forall a. String -> (a -> String) -> [a] -> String
showList String
"," a -> String
forall a. Show a => a -> String
show [a]
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|"

succMeasure :: (a -> a) -> Measure a -> Measure a
succMeasure :: forall a. (a -> a) -> Measure a -> Measure a
succMeasure a -> a
suc Measure a
mu = Measure a
-> (Measure a -> Measure a) -> Maybe (Measure a) -> Measure a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Measure a
forall a. HasCallStack => String -> a
error String
"cannot take successor of empty measure") Measure a -> Measure a
forall a. a -> a
id (Maybe (Measure a) -> Measure a) -> Maybe (Measure a) -> Measure a
forall a b. (a -> b) -> a -> b
$ (a -> Maybe a) -> Measure a -> Maybe (Measure a)
forall a. (a -> Maybe a) -> Measure a -> Maybe (Measure a)
applyLastM (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (a -> a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
suc) Measure a
mu

{-
succMeasure succ (Measure mu) = Measure (succMeas mu)
  where succMeas []     = error "cannot take successor of empty measure"
        succMeas [e]    = [succ e]
        succMeas (e:es) = e : succMeas es
-}

applyLastM :: (a -> Maybe a) -> Measure a -> Maybe (Measure a)
applyLastM :: forall a. (a -> Maybe a) -> Measure a -> Maybe (Measure a)
applyLastM a -> Maybe a
f (Measure [a]
mu) = [a] -> Measure a
forall a. [a] -> Measure a
Measure ([a] -> Measure a) -> Maybe [a] -> Maybe (Measure a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
loop [a]
mu
  where loop :: [a] -> Maybe [a]
loop []     = String -> Maybe [a]
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty measure"
        loop [a
e]    = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) (a -> [a]) -> Maybe a -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
f a
e
        loop (a
e:[a]
es) = (a
ea -> [a] -> [a]
forall a. a -> [a] -> [a]
:)  ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
loop [a]
es

instance HasPred a => HasPred (Measure a) where
  predecessor :: Measure a -> Maybe (Measure a)
predecessor Measure a
mu = (a -> Maybe a) -> Measure a -> Maybe (Measure a)
forall a. (a -> Maybe a) -> Measure a -> Maybe (Measure a)
applyLastM a -> Maybe a
forall a. HasPred a => a -> Maybe a
predecessor Measure a
mu

data Bound a = Bound { forall a. Bound a -> LtLe
ltle :: LtLe, forall a. Bound a -> Measure a
leftBound :: Measure a, forall a. Bound a -> Measure a
rightBound :: Measure a }  -- mu < mur  of mu <= mu'
    deriving (Bound a -> Bound a -> Bool
(Bound a -> Bound a -> Bool)
-> (Bound a -> Bound a -> Bool) -> Eq (Bound a)
forall a. Eq a => Bound a -> Bound a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Bound a -> Bound a -> Bool
== :: Bound a -> Bound a -> Bool
$c/= :: forall a. Eq a => Bound a -> Bound a -> Bool
/= :: Bound a -> Bound a -> Bool
Eq,Eq (Bound a)
Eq (Bound a) =>
(Bound a -> Bound a -> Ordering)
-> (Bound a -> Bound a -> Bool)
-> (Bound a -> Bound a -> Bool)
-> (Bound a -> Bound a -> Bool)
-> (Bound a -> Bound a -> Bool)
-> (Bound a -> Bound a -> Bound a)
-> (Bound a -> Bound a -> Bound a)
-> Ord (Bound a)
Bound a -> Bound a -> Bool
Bound a -> Bound a -> Ordering
Bound a -> Bound a -> Bound a
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
forall a. Ord a => Eq (Bound a)
forall a. Ord a => Bound a -> Bound a -> Bool
forall a. Ord a => Bound a -> Bound a -> Ordering
forall a. Ord a => Bound a -> Bound a -> Bound a
$ccompare :: forall a. Ord a => Bound a -> Bound a -> Ordering
compare :: Bound a -> Bound a -> Ordering
$c< :: forall a. Ord a => Bound a -> Bound a -> Bool
< :: Bound a -> Bound a -> Bool
$c<= :: forall a. Ord a => Bound a -> Bound a -> Bool
<= :: Bound a -> Bound a -> Bool
$c> :: forall a. Ord a => Bound a -> Bound a -> Bool
> :: Bound a -> Bound a -> Bool
$c>= :: forall a. Ord a => Bound a -> Bound a -> Bool
>= :: Bound a -> Bound a -> Bool
$cmax :: forall a. Ord a => Bound a -> Bound a -> Bound a
max :: Bound a -> Bound a -> Bound a
$cmin :: forall a. Ord a => Bound a -> Bound a -> Bound a
min :: Bound a -> Bound a -> Bound a
Ord,(forall a b. (a -> b) -> Bound a -> Bound b)
-> (forall a b. a -> Bound b -> Bound a) -> Functor Bound
forall a b. a -> Bound b -> Bound a
forall a b. (a -> b) -> Bound a -> Bound b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Bound a -> Bound b
fmap :: forall a b. (a -> b) -> Bound a -> Bound b
$c<$ :: forall a b. a -> Bound b -> Bound a
<$ :: forall a b. a -> Bound b -> Bound a
Functor,(forall m. Monoid m => Bound m -> m)
-> (forall m a. Monoid m => (a -> m) -> Bound a -> m)
-> (forall m a. Monoid m => (a -> m) -> Bound a -> m)
-> (forall a b. (a -> b -> b) -> b -> Bound a -> b)
-> (forall a b. (a -> b -> b) -> b -> Bound a -> b)
-> (forall b a. (b -> a -> b) -> b -> Bound a -> b)
-> (forall b a. (b -> a -> b) -> b -> Bound a -> b)
-> (forall a. (a -> a -> a) -> Bound a -> a)
-> (forall a. (a -> a -> a) -> Bound a -> a)
-> (forall a. Bound a -> [a])
-> (forall a. Bound a -> Bool)
-> (forall a. Bound a -> Int)
-> (forall a. Eq a => a -> Bound a -> Bool)
-> (forall a. Ord a => Bound a -> a)
-> (forall a. Ord a => Bound a -> a)
-> (forall a. Num a => Bound a -> a)
-> (forall a. Num a => Bound a -> a)
-> Foldable Bound
forall a. Eq a => a -> Bound a -> Bool
forall a. Num a => Bound a -> a
forall a. Ord a => Bound a -> a
forall m. Monoid m => Bound m -> m
forall a. Bound a -> Bool
forall a. Bound a -> Int
forall a. Bound a -> [a]
forall a. (a -> a -> a) -> Bound a -> a
forall m a. Monoid m => (a -> m) -> Bound a -> m
forall b a. (b -> a -> b) -> b -> Bound a -> b
forall a b. (a -> b -> b) -> b -> Bound a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Bound m -> m
fold :: forall m. Monoid m => Bound m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Bound a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Bound a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Bound a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Bound a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Bound a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Bound a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Bound a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Bound a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Bound a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Bound a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Bound a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Bound a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Bound a -> a
foldr1 :: forall a. (a -> a -> a) -> Bound a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Bound a -> a
foldl1 :: forall a. (a -> a -> a) -> Bound a -> a
$ctoList :: forall a. Bound a -> [a]
toList :: forall a. Bound a -> [a]
$cnull :: forall a. Bound a -> Bool
null :: forall a. Bound a -> Bool
$clength :: forall a. Bound a -> Int
length :: forall a. Bound a -> Int
$celem :: forall a. Eq a => a -> Bound a -> Bool
elem :: forall a. Eq a => a -> Bound a -> Bool
$cmaximum :: forall a. Ord a => Bound a -> a
maximum :: forall a. Ord a => Bound a -> a
$cminimum :: forall a. Ord a => Bound a -> a
minimum :: forall a. Ord a => Bound a -> a
$csum :: forall a. Num a => Bound a -> a
sum :: forall a. Num a => Bound a -> a
$cproduct :: forall a. Num a => Bound a -> a
product :: forall a. Num a => Bound a -> a
Foldable,Functor Bound
Foldable Bound
(Functor Bound, Foldable Bound) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Bound a -> f (Bound b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Bound (f a) -> f (Bound a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Bound a -> m (Bound b))
-> (forall (m :: * -> *) a. Monad m => Bound (m a) -> m (Bound a))
-> Traversable Bound
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Bound (m a) -> m (Bound a)
forall (f :: * -> *) a. Applicative f => Bound (f a) -> f (Bound a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bound a -> m (Bound b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Bound (f a) -> f (Bound a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Bound (f a) -> f (Bound a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bound a -> m (Bound b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bound a -> m (Bound b)
$csequence :: forall (m :: * -> *) a. Monad m => Bound (m a) -> m (Bound a)
sequence :: forall (m :: * -> *) a. Monad m => Bound (m a) -> m (Bound a)
Traversable)

instance Show a => Show (Bound a) where
  show :: Bound a -> String
show (Bound LtLe
Lt Measure a
mu1 Measure a
mu2) = Measure a -> String
forall a. Show a => a -> String
show Measure a
mu1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" < " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Measure a -> String
forall a. Show a => a -> String
show Measure a
mu2
  show (Bound LtLe
Le Measure a
mu1 Measure a
mu2) = Measure a -> String
forall a. Show a => a -> String
show Measure a
mu1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <= " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Measure a -> String
forall a. Show a => a -> String
show Measure a
mu2

{-
instance (HasPred a, Show a) => Show (Bound a) where
    show (Bound mu1 mu2) = case predecessor mu2 of
      Just mu2 -> show mu1 ++ " <= " ++ show mu2
      Nothing  -> show mu1 ++ " < " ++ show mu2
-}

-- TODO: properly implement bounds mu <= mu' such that mu <= # is
-- represented correctly

-- tagging expressions -----------------------------------------------

data Tag
  = Erased -- ^ Expression will be erased.
  | Cast   -- ^ Expression will need to be casted.
  deriving (Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
/= :: Tag -> Tag -> Bool
Eq,Eq Tag
Eq Tag =>
(Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
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
$ccompare :: Tag -> Tag -> Ordering
compare :: Tag -> Tag -> Ordering
$c< :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
>= :: Tag -> Tag -> Bool
$cmax :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
min :: Tag -> Tag -> Tag
Ord,Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tag -> ShowS
showsPrec :: Int -> Tag -> ShowS
$cshow :: Tag -> String
show :: Tag -> String
$cshowList :: [Tag] -> ShowS
showList :: [Tag] -> ShowS
Show)

type Tags = [Tag]

inTags :: Tag -> Tags -> Bool
inTags :: Tag -> [Tag] -> Bool
inTags = Tag -> [Tag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem

noTags :: Tags
noTags :: [Tag]
noTags = []

data Tagged a = Tagged { forall a. Tagged a -> [Tag]
tags :: Tags , forall a. Tagged a -> a
unTag :: a }
  deriving (Tagged a -> Tagged a -> Bool
(Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool) -> Eq (Tagged a)
forall a. Eq a => Tagged a -> Tagged a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Tagged a -> Tagged a -> Bool
== :: Tagged a -> Tagged a -> Bool
$c/= :: forall a. Eq a => Tagged a -> Tagged a -> Bool
/= :: Tagged a -> Tagged a -> Bool
Eq,Eq (Tagged a)
Eq (Tagged a) =>
(Tagged a -> Tagged a -> Ordering)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Tagged a)
-> (Tagged a -> Tagged a -> Tagged a)
-> Ord (Tagged a)
Tagged a -> Tagged a -> Bool
Tagged a -> Tagged a -> Ordering
Tagged a -> Tagged a -> Tagged a
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
forall a. Ord a => Eq (Tagged a)
forall a. Ord a => Tagged a -> Tagged a -> Bool
forall a. Ord a => Tagged a -> Tagged a -> Ordering
forall a. Ord a => Tagged a -> Tagged a -> Tagged a
$ccompare :: forall a. Ord a => Tagged a -> Tagged a -> Ordering
compare :: Tagged a -> Tagged a -> Ordering
$c< :: forall a. Ord a => Tagged a -> Tagged a -> Bool
< :: Tagged a -> Tagged a -> Bool
$c<= :: forall a. Ord a => Tagged a -> Tagged a -> Bool
<= :: Tagged a -> Tagged a -> Bool
$c> :: forall a. Ord a => Tagged a -> Tagged a -> Bool
> :: Tagged a -> Tagged a -> Bool
$c>= :: forall a. Ord a => Tagged a -> Tagged a -> Bool
>= :: Tagged a -> Tagged a -> Bool
$cmax :: forall a. Ord a => Tagged a -> Tagged a -> Tagged a
max :: Tagged a -> Tagged a -> Tagged a
$cmin :: forall a. Ord a => Tagged a -> Tagged a -> Tagged a
min :: Tagged a -> Tagged a -> Tagged a
Ord,(forall a b. (a -> b) -> Tagged a -> Tagged b)
-> (forall a b. a -> Tagged b -> Tagged a) -> Functor Tagged
forall a b. a -> Tagged b -> Tagged a
forall a b. (a -> b) -> Tagged a -> Tagged b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Tagged a -> Tagged b
fmap :: forall a b. (a -> b) -> Tagged a -> Tagged b
$c<$ :: forall a b. a -> Tagged b -> Tagged a
<$ :: forall a b. a -> Tagged b -> Tagged a
Functor,(forall m. Monoid m => Tagged m -> m)
-> (forall m a. Monoid m => (a -> m) -> Tagged a -> m)
-> (forall m a. Monoid m => (a -> m) -> Tagged a -> m)
-> (forall a b. (a -> b -> b) -> b -> Tagged a -> b)
-> (forall a b. (a -> b -> b) -> b -> Tagged a -> b)
-> (forall b a. (b -> a -> b) -> b -> Tagged a -> b)
-> (forall b a. (b -> a -> b) -> b -> Tagged a -> b)
-> (forall a. (a -> a -> a) -> Tagged a -> a)
-> (forall a. (a -> a -> a) -> Tagged a -> a)
-> (forall a. Tagged a -> [a])
-> (forall a. Tagged a -> Bool)
-> (forall a. Tagged a -> Int)
-> (forall a. Eq a => a -> Tagged a -> Bool)
-> (forall a. Ord a => Tagged a -> a)
-> (forall a. Ord a => Tagged a -> a)
-> (forall a. Num a => Tagged a -> a)
-> (forall a. Num a => Tagged a -> a)
-> Foldable Tagged
forall a. Eq a => a -> Tagged a -> Bool
forall a. Num a => Tagged a -> a
forall a. Ord a => Tagged a -> a
forall m. Monoid m => Tagged m -> m
forall a. Tagged a -> Bool
forall a. Tagged a -> Int
forall a. Tagged a -> [a]
forall a. (a -> a -> a) -> Tagged a -> a
forall m a. Monoid m => (a -> m) -> Tagged a -> m
forall b a. (b -> a -> b) -> b -> Tagged a -> b
forall a b. (a -> b -> b) -> b -> Tagged a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Tagged m -> m
fold :: forall m. Monoid m => Tagged m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Tagged a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Tagged a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Tagged a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Tagged a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Tagged a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Tagged a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Tagged a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Tagged a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Tagged a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Tagged a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Tagged a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Tagged a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Tagged a -> a
foldr1 :: forall a. (a -> a -> a) -> Tagged a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Tagged a -> a
foldl1 :: forall a. (a -> a -> a) -> Tagged a -> a
$ctoList :: forall a. Tagged a -> [a]
toList :: forall a. Tagged a -> [a]
$cnull :: forall a. Tagged a -> Bool
null :: forall a. Tagged a -> Bool
$clength :: forall a. Tagged a -> Int
length :: forall a. Tagged a -> Int
$celem :: forall a. Eq a => a -> Tagged a -> Bool
elem :: forall a. Eq a => a -> Tagged a -> Bool
$cmaximum :: forall a. Ord a => Tagged a -> a
maximum :: forall a. Ord a => Tagged a -> a
$cminimum :: forall a. Ord a => Tagged a -> a
minimum :: forall a. Ord a => Tagged a -> a
$csum :: forall a. Num a => Tagged a -> a
sum :: forall a. Num a => Tagged a -> a
$cproduct :: forall a. Num a => Tagged a -> a
product :: forall a. Num a => Tagged a -> a
Foldable,Functor Tagged
Foldable Tagged
(Functor Tagged, Foldable Tagged) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Tagged a -> f (Tagged b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Tagged (f a) -> f (Tagged a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Tagged a -> m (Tagged b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Tagged (m a) -> m (Tagged a))
-> Traversable Tagged
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Tagged (m a) -> m (Tagged a)
forall (f :: * -> *) a.
Applicative f =>
Tagged (f a) -> f (Tagged a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tagged a -> m (Tagged b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tagged a -> f (Tagged b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tagged a -> f (Tagged b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tagged a -> f (Tagged b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Tagged (f a) -> f (Tagged a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Tagged (f a) -> f (Tagged a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tagged a -> m (Tagged b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tagged a -> m (Tagged b)
$csequence :: forall (m :: * -> *) a. Monad m => Tagged (m a) -> m (Tagged a)
sequence :: forall (m :: * -> *) a. Monad m => Tagged (m a) -> m (Tagged a)
Traversable)

instance Show a => Show (Tagged a) where
  show :: Tagged a -> String
show (Tagged [Tag]
tags a
a) =
   Bool -> ShowS
bracketsIf (Tag
Erased Tag -> [Tag] -> Bool
`inTags` [Tag]
tags) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
     Bool -> ShowS
showCast (Tag
Cast Tag -> [Tag] -> Bool
`inTags` [Tag]
tags) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
       a -> String
forall a. Show a => a -> String
show  a
a

showCast :: Bool -> String -> String
showCast :: Bool -> ShowS
showCast Bool
True  String
s = String
"'cast" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
Util.parens String
s
showCast Bool
False String
s = String
s

instance Pretty a => Pretty (Tagged a) where
  prettyPrec :: Int -> Tagged a -> Doc
prettyPrec Int
k (Tagged []   a
a) = Int -> a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
k a
a
  prettyPrec Int
_ (Tagged [Tag]
tags a
a) =
    Bool -> Doc -> Doc
prettyErased (Tag
Erased Tag -> [Tag] -> Bool
`inTags` [Tag]
tags) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      Bool -> Doc -> Doc
prettyCast (Tag
Cast Tag -> [Tag] -> Bool
`inTags` [Tag]
tags) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        a -> Doc
forall a. Pretty a => a -> Doc
pretty a
a

prettyErased :: Bool -> Doc -> Doc
prettyErased :: Bool -> Doc -> Doc
prettyErased Bool
True  Doc
doc = Doc -> Doc
brackets Doc
doc
prettyErased Bool
False Doc
doc = Doc
doc

prettyCast :: Bool -> Doc -> Doc
prettyCast :: Bool -> Doc -> Doc
prettyCast Bool
True  Doc
doc = String -> Doc
text String
"'cast" Doc -> Doc -> Doc
<> Doc -> Doc
PP.parens Doc
doc
prettyCast Bool
False Doc
doc = Doc
doc

-- expressions -------------------------------------------------------

data Expr
  = Sort (Sort Expr)   -- ^ @Size@ @Set@ @CoSet@
  -- sizes
  | Zero
  | Succ Expr
  | Infty
  | Max [Expr]   -- ^ (list has at least 2 elements)
  | Plus [Expr]  -- ^ (list has at least 2 elements)
  -- identifiers
  | Meta MVar    -- ^ meta-variable
  | Var Name     -- ^ variables are named
  | Def DefId    -- ^ identifiers in the signature
{-
  | Con Co Name [Expr] -- constructors applied to arguments
  | Def Name     -- fun/cofun ?
  | Let Name     -- definition (non-recursive)
-}
  -- dependently typed lambda calculus
  | Record RecInfo [(Name,Expr)] -- ^ record { p1 = e1; ...; pn = en }
  | Proj PrePost Name            -- ^ proj _  or  _ .proj
  | Pair Expr Expr
  | Case Expr (Maybe Type) [Clause]
    -- ^ Type is @Nothing@ in input, @Just@ after t.c.
  | LLet LBind Telescope Expr Expr
    -- ^ @let [x : A] = t in u@, @let [x] tel = t in u@
    --   after t.c. @Telescope@ is empty (fused into @LBind@)
  | App Expr Expr
  | Lam Dec Name Expr
  | Quant PiSigma TBind Expr
  | Sing Expr Expr  -- <t : A> singleton type
  -- instead of bounded quantification, a type for subsets
  -- use as @Pi/Sigma (TBind ... (Below ltle a)) b@
  | Below LtLe Expr                     -- ^ <(a : Size) or <=(a : Size)
  -- for extraction
  | Ann (Tagged Expr) -- ^ annotated expr, e.g. with Erased tag
  | Irr -- ^ for instance the term correponding to the absurd pattern
    deriving (Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
/= :: Expr -> Expr -> Bool
Eq,Eq Expr
Eq Expr =>
(Expr -> Expr -> Ordering)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Expr)
-> (Expr -> Expr -> Expr)
-> Ord Expr
Expr -> Expr -> Bool
Expr -> Expr -> Ordering
Expr -> Expr -> Expr
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
$ccompare :: Expr -> Expr -> Ordering
compare :: Expr -> Expr -> Ordering
$c< :: Expr -> Expr -> Bool
< :: Expr -> Expr -> Bool
$c<= :: Expr -> Expr -> Bool
<= :: Expr -> Expr -> Bool
$c> :: Expr -> Expr -> Bool
> :: Expr -> Expr -> Bool
$c>= :: Expr -> Expr -> Bool
>= :: Expr -> Expr -> Bool
$cmax :: Expr -> Expr -> Expr
max :: Expr -> Expr -> Expr
$cmin :: Expr -> Expr -> Expr
min :: Expr -> Expr -> Expr
Ord)

data PrePost = Pre | Post deriving (PrePost -> PrePost -> Bool
(PrePost -> PrePost -> Bool)
-> (PrePost -> PrePost -> Bool) -> Eq PrePost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrePost -> PrePost -> Bool
== :: PrePost -> PrePost -> Bool
$c/= :: PrePost -> PrePost -> Bool
/= :: PrePost -> PrePost -> Bool
Eq, Eq PrePost
Eq PrePost =>
(PrePost -> PrePost -> Ordering)
-> (PrePost -> PrePost -> Bool)
-> (PrePost -> PrePost -> Bool)
-> (PrePost -> PrePost -> Bool)
-> (PrePost -> PrePost -> Bool)
-> (PrePost -> PrePost -> PrePost)
-> (PrePost -> PrePost -> PrePost)
-> Ord PrePost
PrePost -> PrePost -> Bool
PrePost -> PrePost -> Ordering
PrePost -> PrePost -> PrePost
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
$ccompare :: PrePost -> PrePost -> Ordering
compare :: PrePost -> PrePost -> Ordering
$c< :: PrePost -> PrePost -> Bool
< :: PrePost -> PrePost -> Bool
$c<= :: PrePost -> PrePost -> Bool
<= :: PrePost -> PrePost -> Bool
$c> :: PrePost -> PrePost -> Bool
> :: PrePost -> PrePost -> Bool
$c>= :: PrePost -> PrePost -> Bool
>= :: PrePost -> PrePost -> Bool
$cmax :: PrePost -> PrePost -> PrePost
max :: PrePost -> PrePost -> PrePost
$cmin :: PrePost -> PrePost -> PrePost
min :: PrePost -> PrePost -> PrePost
Ord, Int -> PrePost -> ShowS
[PrePost] -> ShowS
PrePost -> String
(Int -> PrePost -> ShowS)
-> (PrePost -> String) -> ([PrePost] -> ShowS) -> Show PrePost
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrePost -> ShowS
showsPrec :: Int -> PrePost -> ShowS
$cshow :: PrePost -> String
show :: PrePost -> String
$cshowList :: [PrePost] -> ShowS
showList :: [PrePost] -> ShowS
Show)
data PiSigma = Pi | Sigma deriving (PiSigma -> PiSigma -> Bool
(PiSigma -> PiSigma -> Bool)
-> (PiSigma -> PiSigma -> Bool) -> Eq PiSigma
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PiSigma -> PiSigma -> Bool
== :: PiSigma -> PiSigma -> Bool
$c/= :: PiSigma -> PiSigma -> Bool
/= :: PiSigma -> PiSigma -> Bool
Eq, Eq PiSigma
Eq PiSigma =>
(PiSigma -> PiSigma -> Ordering)
-> (PiSigma -> PiSigma -> Bool)
-> (PiSigma -> PiSigma -> Bool)
-> (PiSigma -> PiSigma -> Bool)
-> (PiSigma -> PiSigma -> Bool)
-> (PiSigma -> PiSigma -> PiSigma)
-> (PiSigma -> PiSigma -> PiSigma)
-> Ord PiSigma
PiSigma -> PiSigma -> Bool
PiSigma -> PiSigma -> Ordering
PiSigma -> PiSigma -> PiSigma
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
$ccompare :: PiSigma -> PiSigma -> Ordering
compare :: PiSigma -> PiSigma -> Ordering
$c< :: PiSigma -> PiSigma -> Bool
< :: PiSigma -> PiSigma -> Bool
$c<= :: PiSigma -> PiSigma -> Bool
<= :: PiSigma -> PiSigma -> Bool
$c> :: PiSigma -> PiSigma -> Bool
> :: PiSigma -> PiSigma -> Bool
$c>= :: PiSigma -> PiSigma -> Bool
>= :: PiSigma -> PiSigma -> Bool
$cmax :: PiSigma -> PiSigma -> PiSigma
max :: PiSigma -> PiSigma -> PiSigma
$cmin :: PiSigma -> PiSigma -> PiSigma
min :: PiSigma -> PiSigma -> PiSigma
Ord)

instance Show PiSigma where
  show :: PiSigma -> String
show PiSigma
Pi    = String
"->"
  show PiSigma
Sigma = String
"&"

-- | Optional constructor name of a record value.
data RecInfo
  = AnonRec                           -- ^ anonymous record
  | NamedRec { RecInfo -> ConK
recConK :: ConK
             , RecInfo -> QName
recConName :: QName    -- ^ record constructor
             , RecInfo -> Bool
recNamedFields :: Bool -- ^ print field names?
             , RecInfo -> Dotted
recDottedRef :: Dotted -- ^ coming from dotted constructor (unconfirmed)
             }
  deriving (RecInfo -> RecInfo -> Bool
(RecInfo -> RecInfo -> Bool)
-> (RecInfo -> RecInfo -> Bool) -> Eq RecInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecInfo -> RecInfo -> Bool
== :: RecInfo -> RecInfo -> Bool
$c/= :: RecInfo -> RecInfo -> Bool
/= :: RecInfo -> RecInfo -> Bool
Eq, Eq RecInfo
Eq RecInfo =>
(RecInfo -> RecInfo -> Ordering)
-> (RecInfo -> RecInfo -> Bool)
-> (RecInfo -> RecInfo -> Bool)
-> (RecInfo -> RecInfo -> Bool)
-> (RecInfo -> RecInfo -> Bool)
-> (RecInfo -> RecInfo -> RecInfo)
-> (RecInfo -> RecInfo -> RecInfo)
-> Ord RecInfo
RecInfo -> RecInfo -> Bool
RecInfo -> RecInfo -> Ordering
RecInfo -> RecInfo -> RecInfo
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
$ccompare :: RecInfo -> RecInfo -> Ordering
compare :: RecInfo -> RecInfo -> Ordering
$c< :: RecInfo -> RecInfo -> Bool
< :: RecInfo -> RecInfo -> Bool
$c<= :: RecInfo -> RecInfo -> Bool
<= :: RecInfo -> RecInfo -> Bool
$c> :: RecInfo -> RecInfo -> Bool
> :: RecInfo -> RecInfo -> Bool
$c>= :: RecInfo -> RecInfo -> Bool
>= :: RecInfo -> RecInfo -> Bool
$cmax :: RecInfo -> RecInfo -> RecInfo
max :: RecInfo -> RecInfo -> RecInfo
$cmin :: RecInfo -> RecInfo -> RecInfo
min :: RecInfo -> RecInfo -> RecInfo
Ord)

newtype Dotted = Dotted { Dotted -> IORef Bool
dottedRef :: IORef Bool }

instance Eq   Dotted where Dotted
_ == :: Dotted -> Dotted -> Bool
== Dotted
_ = Bool
True
instance Ord  Dotted where Dotted
_ <= :: Dotted -> Dotted -> Bool
<= Dotted
_ = Bool
True
instance Show Dotted where show :: Dotted -> String
show Dotted
d = Bool -> ShowS -> ShowS
forall a. Bool -> (a -> a) -> a -> a
fwhen (Dotted -> Bool
isDotted Dotted
d) (String
"un" String -> ShowS
forall a. [a] -> [a] -> [a]
++) String
"confirmed"

-- A bit of imperative programming

mkDotted :: MonadIO m => Bool -> m Dotted
mkDotted :: forall (m :: * -> *). MonadIO m => Bool -> m Dotted
mkDotted Bool
b = IO Dotted -> m Dotted
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Dotted -> m Dotted) -> IO Dotted -> m Dotted
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Dotted
Dotted (IORef Bool -> Dotted) -> IO (IORef Bool) -> IO Dotted
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
b

-- default value, shared over all instances
{-# NOINLINE notDotted #-}
notDotted :: Dotted
notDotted :: Dotted
notDotted = IO Dotted -> Dotted
forall a. IO a -> a
unsafePerformIO (IO Dotted -> Dotted) -> IO Dotted -> Dotted
forall a b. (a -> b) -> a -> b
$ Bool -> IO Dotted
forall (m :: * -> *). MonadIO m => Bool -> m Dotted
mkDotted Bool
False

isDotted :: Dotted -> Bool
isDotted :: Dotted -> Bool
isDotted = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> (Dotted -> IO Bool) -> Dotted -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool)
-> (Dotted -> IORef Bool) -> Dotted -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dotted -> IORef Bool
dottedRef

clearDotted :: MonadIO m => Dotted -> m ()
clearDotted :: forall (m :: * -> *). MonadIO m => Dotted -> m ()
clearDotted Dotted
d | Dotted -> Bool
isDotted Dotted
d = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      -- putStrLn ("clearing a dot")
      IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Dotted -> IORef Bool
dottedRef Dotted
d) Bool
False
  | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

alignDotted :: MonadIO m => Dotted -> Dotted -> m ()
alignDotted :: forall (m :: * -> *). MonadIO m => Dotted -> Dotted -> m ()
alignDotted Dotted
d1 Dotted
d2 = case (Dotted -> Bool
isDotted Dotted
d1, Dotted -> Bool
isDotted Dotted
d2) of
  (Bool
True, Bool
False) -> Dotted -> m ()
forall (m :: * -> *). MonadIO m => Dotted -> m ()
clearDotted Dotted
d1
  (Bool
False, Bool
True) -> Dotted -> m ()
forall (m :: * -> *). MonadIO m => Dotted -> m ()
clearDotted Dotted
d2
  (Bool, Bool)
_             -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

recDotted :: RecInfo -> Bool
recDotted :: RecInfo -> Bool
recDotted NamedRec{Dotted
recDottedRef :: RecInfo -> Dotted
recDottedRef :: Dotted
recDottedRef} = Dotted -> Bool
isDotted Dotted
recDottedRef
recDotted RecInfo
AnonRec = Bool
False

instance Show RecInfo where
  show :: RecInfo -> String
show RecInfo
AnonRec              = String
""
  show ri :: RecInfo
ri@NamedRec{QName
recConName :: RecInfo -> QName
recConName :: QName
recConName} = (if RecInfo -> Bool
recDotted RecInfo
ri then String
"." else String
"") String -> ShowS
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
recConName

-- * smart constructors

-- | Create a universal binding.  Fuse hidden bindings.
pi :: TBind -> Expr -> Expr
pi :: TBind -> Expr -> Expr
pi = PiSigma -> TBind -> Expr -> Expr
piSig PiSigma
Pi

piSig :: PiSigma -> TBind -> Expr -> Expr
piSig :: PiSigma -> TBind -> Expr -> Expr
piSig = PiSigma -> TBind -> Expr -> Expr
Quant
{-
piSig piSig ta e =
  case ta of
    ta@TBind{ boundDom = Domain{ decor = Hidden }} ->
      case e of
        Quant piSig' tel tb c | piSig == piSig'
          -> Quant piSig (Telescope $ ta : telescope tel) tb c
        _ -> error $ "lone hidden binding" ++ show ta
    _ -> Quant piSig emptyTel ta e
-}

proj :: Expr -> PrePost -> Name -> Expr
proj :: Expr -> PrePost -> Name -> Expr
proj Expr
e PrePost
Pre Name
n  = Expr -> Expr -> Expr
App (PrePost -> Name -> Expr
Proj PrePost
Pre Name
n) Expr
e
proj Expr
e PrePost
Post Name
n = Expr -> Expr -> Expr
App Expr
e (PrePost -> Name -> Expr
Proj PrePost
Post Name
n)

-- | Non-dependent function type.
funType :: Dom Type -> Expr -> Expr
funType :: Dom Expr -> Expr -> Expr
funType Dom Expr
a Expr
b = PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi (Dom Expr -> TBind
forall a. Dom a -> TBinding a
noBind Dom Expr
a) Expr
b

erasedExpr, castExpr :: Expr -> Expr
erasedExpr :: Expr -> Expr
erasedExpr Expr
e = Tagged Expr -> Expr
Ann ([Tag] -> Expr -> Tagged Expr
forall a. [Tag] -> a -> Tagged a
Tagged [Tag
Erased] Expr
e)
castExpr :: Expr -> Expr
castExpr   Expr
e = Tagged Expr -> Expr
Ann ([Tag] -> Expr -> Tagged Expr
forall a. [Tag] -> a -> Tagged a
Tagged [Tag
Cast]   Expr
e)

succView :: Expr -> (Int, Expr)
succView :: Expr -> (Int, Expr)
succView (Succ Expr
e) = (Int -> Int) -> (Int, Expr) -> (Int, Expr)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Expr -> (Int, Expr)
succView Expr
e)
succView Expr
e = (Int
0, Expr
e)

-- Clauses and patterns ----------------------------------------------

data Clause = Clause
  { Clause -> TeleVal
clTele     :: TeleVal      -- top-level telescope of type values for PVars
  , Clause -> [Pattern]
clPatterns :: [Pattern]
  , Clause -> Maybe Expr
clExpr     :: Maybe Expr   -- Nothing if absurd clause
  } deriving (Clause -> Clause -> Bool
(Clause -> Clause -> Bool)
-> (Clause -> Clause -> Bool) -> Eq Clause
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Clause -> Clause -> Bool
== :: Clause -> Clause -> Bool
$c/= :: Clause -> Clause -> Bool
/= :: Clause -> Clause -> Bool
Eq,Eq Clause
Eq Clause =>
(Clause -> Clause -> Ordering)
-> (Clause -> Clause -> Bool)
-> (Clause -> Clause -> Bool)
-> (Clause -> Clause -> Bool)
-> (Clause -> Clause -> Bool)
-> (Clause -> Clause -> Clause)
-> (Clause -> Clause -> Clause)
-> Ord Clause
Clause -> Clause -> Bool
Clause -> Clause -> Ordering
Clause -> Clause -> Clause
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
$ccompare :: Clause -> Clause -> Ordering
compare :: Clause -> Clause -> Ordering
$c< :: Clause -> Clause -> Bool
< :: Clause -> Clause -> Bool
$c<= :: Clause -> Clause -> Bool
<= :: Clause -> Clause -> Bool
$c> :: Clause -> Clause -> Bool
> :: Clause -> Clause -> Bool
$c>= :: Clause -> Clause -> Bool
>= :: Clause -> Clause -> Bool
$cmax :: Clause -> Clause -> Clause
max :: Clause -> Clause -> Clause
$cmin :: Clause -> Clause -> Clause
min :: Clause -> Clause -> Clause
Ord,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
$cshowsPrec :: Int -> Clause -> ShowS
showsPrec :: Int -> Clause -> ShowS
$cshow :: Clause -> String
show :: Clause -> String
$cshowList :: [Clause] -> ShowS
showList :: [Clause] -> ShowS
Show)

clause :: [Pattern] -> Maybe Expr -> Clause
-- clause = Clause (error "internal error: no telescope in clause before typechecking!")
clause :: [Pattern] -> Maybe Expr -> Clause
clause = TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause [] -- empty clTele

data PatternInfo = PatternInfo
  { PatternInfo -> ConK
coPat          :: ConK    -- (co)constructor
  , PatternInfo -> Bool
irrefutablePat :: Bool    -- constructor of a record (UNUSED)
  , PatternInfo -> Bool
dottedPat      :: Bool
  } deriving (PatternInfo -> PatternInfo -> Bool
(PatternInfo -> PatternInfo -> Bool)
-> (PatternInfo -> PatternInfo -> Bool) -> Eq PatternInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PatternInfo -> PatternInfo -> Bool
== :: PatternInfo -> PatternInfo -> Bool
$c/= :: PatternInfo -> PatternInfo -> Bool
/= :: PatternInfo -> PatternInfo -> Bool
Eq,Eq PatternInfo
Eq PatternInfo =>
(PatternInfo -> PatternInfo -> Ordering)
-> (PatternInfo -> PatternInfo -> Bool)
-> (PatternInfo -> PatternInfo -> Bool)
-> (PatternInfo -> PatternInfo -> Bool)
-> (PatternInfo -> PatternInfo -> Bool)
-> (PatternInfo -> PatternInfo -> PatternInfo)
-> (PatternInfo -> PatternInfo -> PatternInfo)
-> Ord PatternInfo
PatternInfo -> PatternInfo -> Bool
PatternInfo -> PatternInfo -> Ordering
PatternInfo -> PatternInfo -> PatternInfo
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
$ccompare :: PatternInfo -> PatternInfo -> Ordering
compare :: PatternInfo -> PatternInfo -> Ordering
$c< :: PatternInfo -> PatternInfo -> Bool
< :: PatternInfo -> PatternInfo -> Bool
$c<= :: PatternInfo -> PatternInfo -> Bool
<= :: PatternInfo -> PatternInfo -> Bool
$c> :: PatternInfo -> PatternInfo -> Bool
> :: PatternInfo -> PatternInfo -> Bool
$c>= :: PatternInfo -> PatternInfo -> Bool
>= :: PatternInfo -> PatternInfo -> Bool
$cmax :: PatternInfo -> PatternInfo -> PatternInfo
max :: PatternInfo -> PatternInfo -> PatternInfo
$cmin :: PatternInfo -> PatternInfo -> PatternInfo
min :: PatternInfo -> PatternInfo -> PatternInfo
Ord,Int -> PatternInfo -> ShowS
[PatternInfo] -> ShowS
PatternInfo -> String
(Int -> PatternInfo -> ShowS)
-> (PatternInfo -> String)
-> ([PatternInfo] -> ShowS)
-> Show PatternInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PatternInfo -> ShowS
showsPrec :: Int -> PatternInfo -> ShowS
$cshow :: PatternInfo -> String
show :: PatternInfo -> String
$cshowList :: [PatternInfo] -> ShowS
showList :: [PatternInfo] -> ShowS
Show)

type Pattern = Pat Expr

-- | Patterns parametrized by type of dot patterns.
data Pat e
  = VarP Name                      -- ^ x
  | ConP PatternInfo QName [Pat e] -- ^ (c ps) and (.c ps)
  | SuccP (Pat e)                  -- ^ ($ p)
  | SizeP e Name                   -- ^ (x > y) (# > y) ($x > y)
  | PairP (Pat e) (Pat e)          -- ^ (p, p')
  | ProjP Name                     -- ^ .proj
  | DotP e                         -- ^ .e
  | AbsurdP                        -- ^ ()
  | ErasedP (Pat e)                -- ^ pattern which got erased
  | UnusableP (Pat e)
{- ^ a pattern which results from matching a coinductive type and
the corresponding size index is not in the coinductive result type of
the function.  Such a pattern is not usable for termination
checking. -}
{-
             | IrrefutableP (Pat e) -- pattern made from record constructors
                                    -- can be matched by applying destructors
  NOT GOOD ENOUGH.  Irrefutable constructors might be mixed with others, e.g.

    pair x refl

  The whole pattern is not irrefutable, but still you want the pair destructed
  lazily by projections.
-}
-- --  | IrrP -- pattern which got erased
               deriving (Pat e -> Pat e -> Bool
(Pat e -> Pat e -> Bool) -> (Pat e -> Pat e -> Bool) -> Eq (Pat e)
forall e. Eq e => Pat e -> Pat e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => Pat e -> Pat e -> Bool
== :: Pat e -> Pat e -> Bool
$c/= :: forall e. Eq e => Pat e -> Pat e -> Bool
/= :: Pat e -> Pat e -> Bool
Eq,Eq (Pat e)
Eq (Pat e) =>
(Pat e -> Pat e -> Ordering)
-> (Pat e -> Pat e -> Bool)
-> (Pat e -> Pat e -> Bool)
-> (Pat e -> Pat e -> Bool)
-> (Pat e -> Pat e -> Bool)
-> (Pat e -> Pat e -> Pat e)
-> (Pat e -> Pat e -> Pat e)
-> Ord (Pat e)
Pat e -> Pat e -> Bool
Pat e -> Pat e -> Ordering
Pat e -> Pat e -> Pat e
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
forall e. Ord e => Eq (Pat e)
forall e. Ord e => Pat e -> Pat e -> Bool
forall e. Ord e => Pat e -> Pat e -> Ordering
forall e. Ord e => Pat e -> Pat e -> Pat e
$ccompare :: forall e. Ord e => Pat e -> Pat e -> Ordering
compare :: Pat e -> Pat e -> Ordering
$c< :: forall e. Ord e => Pat e -> Pat e -> Bool
< :: Pat e -> Pat e -> Bool
$c<= :: forall e. Ord e => Pat e -> Pat e -> Bool
<= :: Pat e -> Pat e -> Bool
$c> :: forall e. Ord e => Pat e -> Pat e -> Bool
> :: Pat e -> Pat e -> Bool
$c>= :: forall e. Ord e => Pat e -> Pat e -> Bool
>= :: Pat e -> Pat e -> Bool
$cmax :: forall e. Ord e => Pat e -> Pat e -> Pat e
max :: Pat e -> Pat e -> Pat e
$cmin :: forall e. Ord e => Pat e -> Pat e -> Pat e
min :: Pat e -> Pat e -> Pat e
Ord)

{-
-- which pattern shapes are irrefutable?
-- only ConP and SuccP might be refutable
irrefutable :: Pattern -> Bool
irrefutable ConP{} = False
irrefutable SuccP{} = False
irrefutable VarP{}         = True
irrefutable SizeP{}        = True
irrefutable IrrefutableP{} = True
irrefutable DotP{}         = True
irrefutable AbsurdP{}      = True
irrefutable ErasedP{}      = True
-}

type Case = (Pattern,Expr)

type Subst = Map MVar Expr

con :: ConK -> QName -> Expr
con :: ConK -> QName -> Expr
con ConK
co QName
n = DefId -> Expr
Def (DefId -> Expr) -> DefId -> Expr
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId (ConK -> IdKind
ConK ConK
co) QName
n
-- con co n = Con co n []

fun, dat :: QName -> Expr
fun :: QName -> Expr
fun QName
n    = DefId -> Expr
Def (DefId -> Expr) -> DefId -> Expr
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
FunK QName
n
dat :: QName -> Expr
dat QName
n    = DefId -> Expr
Def (DefId -> Expr) -> DefId -> Expr
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
DatK QName
n

letdef :: Name -> Expr
letdef :: Name -> Expr
letdef Name
n = DefId -> Expr
Def (DefId -> Expr) -> DefId -> Expr
forall a b. (a -> b) -> a -> b
$ IdKind -> QName -> DefId
DefId IdKind
LetK (QName -> DefId) -> QName -> DefId
forall a b. (a -> b) -> a -> b
$ Name -> QName
QName Name
n

type SpineView = (Expr, [Expr])

-- collect applications to expose head
spineView :: Expr -> SpineView
spineView :: Expr -> SpineView
spineView = [Expr] -> Expr -> SpineView
aux []
  where aux :: [Expr] -> Expr -> SpineView
aux [Expr]
sp (App Expr
f Expr
e) = [Expr] -> Expr -> SpineView
aux (Expr
eExpr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:[Expr]
sp) Expr
f
        aux [Expr]
sp Expr
e = (Expr
e, [Expr]
sp)

test_spineView :: SpineView
test_spineView :: SpineView
test_spineView = Expr -> SpineView
spineView ((Name -> Expr
Var Name
x Expr -> Expr -> Expr
`App` Name -> Expr
Var Name
y) Expr -> Expr -> Expr
`App` Name -> Expr
Var Name
z)
  where x :: Name
x = String -> Name
fresh String
"x"
        y :: Name
y = String -> Name
fresh String
"y"
        z :: Name
z = String -> Name
fresh String
"z"
{-
  where x = Name "x" $ unsafePerformIO newUnique
        y = Name "y" $ unsafePerformIO newUnique
        z = Name "z" $ unsafePerformIO newUnique
-}

{-
-- sort expressions
set  = Sort Set
size = Sort Size
-}

isErasedExpr :: Expr -> (Bool, Expr)
isErasedExpr :: Expr -> (Bool, Expr)
isErasedExpr (Ann (Tagged [Tag]
tags Expr
e)) =
  let (Bool
b, Expr
e') = Expr -> (Bool, Expr)
isErasedExpr Expr
e
  in  (Bool
b Bool -> Bool -> Bool
|| Tag
Erased Tag -> [Tag] -> Bool
`inTags` [Tag]
tags, Expr
e')
isErasedExpr Expr
e = (Bool
False, Expr
e)

type Extr = Expr -- extracted expressions
type EType = Type -- extracted types

-- declarations --------------------------------------------------

data Declaration
  = DataDecl Name Sized Co [Pol] Telescope Type [Constructor] [Name] -- data/codata
  | RecordDecl Name Telescope Type Constructor [Name] -- record
  | MutualFunDecl Bool Co [Fun]     -- mutual fun block / mutual cofun block, bool for measured
  | FunDecl Co Fun  -- fun, possibly inside MutualDecl
  | LetDecl Bool Name Telescope (Maybe Type) Expr
      -- ^ Bool for eval.  After t.c., tel. is empty and type is Just.
  | PatternDecl Name [Name] Pattern
  | MutualDecl Bool [Declaration]  -- mutual data/fun block, bool for measured
  | OverrideDecl Override [Declaration]    -- expect/ignore some type error
    deriving (Declaration -> Declaration -> Bool
(Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool) -> Eq Declaration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Declaration -> Declaration -> Bool
== :: Declaration -> Declaration -> Bool
$c/= :: Declaration -> Declaration -> Bool
/= :: Declaration -> Declaration -> Bool
Eq,Eq Declaration
Eq Declaration =>
(Declaration -> Declaration -> Ordering)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Bool)
-> (Declaration -> Declaration -> Declaration)
-> (Declaration -> Declaration -> Declaration)
-> Ord Declaration
Declaration -> Declaration -> Bool
Declaration -> Declaration -> Ordering
Declaration -> Declaration -> Declaration
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
$ccompare :: Declaration -> Declaration -> Ordering
compare :: Declaration -> Declaration -> Ordering
$c< :: Declaration -> Declaration -> Bool
< :: Declaration -> Declaration -> Bool
$c<= :: Declaration -> Declaration -> Bool
<= :: Declaration -> Declaration -> Bool
$c> :: Declaration -> Declaration -> Bool
> :: Declaration -> Declaration -> Bool
$c>= :: Declaration -> Declaration -> Bool
>= :: Declaration -> Declaration -> Bool
$cmax :: Declaration -> Declaration -> Declaration
max :: Declaration -> Declaration -> Declaration
$cmin :: Declaration -> Declaration -> Declaration
min :: Declaration -> Declaration -> Declaration
Ord,Int -> Declaration -> ShowS
[Declaration] -> ShowS
Declaration -> String
(Int -> Declaration -> ShowS)
-> (Declaration -> String)
-> ([Declaration] -> ShowS)
-> Show Declaration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Declaration -> ShowS
showsPrec :: Int -> Declaration -> ShowS
$cshow :: Declaration -> String
show :: Declaration -> String
$cshowList :: [Declaration] -> ShowS
showList :: [Declaration] -> ShowS
Show)

data Override
  = Fail            -- ^ expect an error, ignore block
  | Check           -- ^ expect no error, still ignore block
  | TrustMe         -- ^ ignore recoverable errors
  | Impredicative   -- ^ use impredicativity for these declarations
    deriving (Override -> Override -> Bool
(Override -> Override -> Bool)
-> (Override -> Override -> Bool) -> Eq Override
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Override -> Override -> Bool
== :: Override -> Override -> Bool
$c/= :: Override -> Override -> Bool
/= :: Override -> Override -> Bool
Eq,Eq Override
Eq Override =>
(Override -> Override -> Ordering)
-> (Override -> Override -> Bool)
-> (Override -> Override -> Bool)
-> (Override -> Override -> Bool)
-> (Override -> Override -> Bool)
-> (Override -> Override -> Override)
-> (Override -> Override -> Override)
-> Ord Override
Override -> Override -> Bool
Override -> Override -> Ordering
Override -> Override -> Override
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
$ccompare :: Override -> Override -> Ordering
compare :: Override -> Override -> Ordering
$c< :: Override -> Override -> Bool
< :: Override -> Override -> Bool
$c<= :: Override -> Override -> Bool
<= :: Override -> Override -> Bool
$c> :: Override -> Override -> Bool
> :: Override -> Override -> Bool
$c>= :: Override -> Override -> Bool
>= :: Override -> Override -> Bool
$cmax :: Override -> Override -> Override
max :: Override -> Override -> Override
$cmin :: Override -> Override -> Override
min :: Override -> Override -> Override
Ord,Int -> Override -> ShowS
[Override] -> ShowS
Override -> String
(Int -> Override -> ShowS)
-> (Override -> String) -> ([Override] -> ShowS) -> Show Override
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Override -> ShowS
showsPrec :: Int -> Override -> ShowS
$cshow :: Override -> String
show :: Override -> String
$cshowList :: [Override] -> ShowS
showList :: [Override] -> ShowS
Show)

data TySig a = TypeSig { forall a. TySig a -> Name
namePart :: Name, forall a. TySig a -> a
typePart :: a }
               deriving (TySig a -> TySig a -> Bool
(TySig a -> TySig a -> Bool)
-> (TySig a -> TySig a -> Bool) -> Eq (TySig a)
forall a. Eq a => TySig a -> TySig a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TySig a -> TySig a -> Bool
== :: TySig a -> TySig a -> Bool
$c/= :: forall a. Eq a => TySig a -> TySig a -> Bool
/= :: TySig a -> TySig a -> Bool
Eq,Eq (TySig a)
Eq (TySig a) =>
(TySig a -> TySig a -> Ordering)
-> (TySig a -> TySig a -> Bool)
-> (TySig a -> TySig a -> Bool)
-> (TySig a -> TySig a -> Bool)
-> (TySig a -> TySig a -> Bool)
-> (TySig a -> TySig a -> TySig a)
-> (TySig a -> TySig a -> TySig a)
-> Ord (TySig a)
TySig a -> TySig a -> Bool
TySig a -> TySig a -> Ordering
TySig a -> TySig a -> TySig a
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
forall a. Ord a => Eq (TySig a)
forall a. Ord a => TySig a -> TySig a -> Bool
forall a. Ord a => TySig a -> TySig a -> Ordering
forall a. Ord a => TySig a -> TySig a -> TySig a
$ccompare :: forall a. Ord a => TySig a -> TySig a -> Ordering
compare :: TySig a -> TySig a -> Ordering
$c< :: forall a. Ord a => TySig a -> TySig a -> Bool
< :: TySig a -> TySig a -> Bool
$c<= :: forall a. Ord a => TySig a -> TySig a -> Bool
<= :: TySig a -> TySig a -> Bool
$c> :: forall a. Ord a => TySig a -> TySig a -> Bool
> :: TySig a -> TySig a -> Bool
$c>= :: forall a. Ord a => TySig a -> TySig a -> Bool
>= :: TySig a -> TySig a -> Bool
$cmax :: forall a. Ord a => TySig a -> TySig a -> TySig a
max :: TySig a -> TySig a -> TySig a
$cmin :: forall a. Ord a => TySig a -> TySig a -> TySig a
min :: TySig a -> TySig a -> TySig a
Ord,Int -> TySig a -> ShowS
[TySig a] -> ShowS
TySig a -> String
(Int -> TySig a -> ShowS)
-> (TySig a -> String) -> ([TySig a] -> ShowS) -> Show (TySig a)
forall a. Show a => Int -> TySig a -> ShowS
forall a. Show a => [TySig a] -> ShowS
forall a. Show a => TySig a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TySig a -> ShowS
showsPrec :: Int -> TySig a -> ShowS
$cshow :: forall a. Show a => TySig a -> String
show :: TySig a -> String
$cshowList :: forall a. Show a => [TySig a] -> ShowS
showList :: [TySig a] -> ShowS
Show,(forall a b. (a -> b) -> TySig a -> TySig b)
-> (forall a b. a -> TySig b -> TySig a) -> Functor TySig
forall a b. a -> TySig b -> TySig a
forall a b. (a -> b) -> TySig a -> TySig b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TySig a -> TySig b
fmap :: forall a b. (a -> b) -> TySig a -> TySig b
$c<$ :: forall a b. a -> TySig b -> TySig a
<$ :: forall a b. a -> TySig b -> TySig a
Functor)
type TypeSig = TySig Type

type Type = Expr

-- | Constructor declaration.  Top-level scope (independent of data pars).
data Constructor = Constructor
 { Constructor -> QName
ctorName :: QName       -- ^ Name of the constructor.
 , Constructor -> ParamPats
ctorPars :: ParamPats   -- ^ Constructor patterns (if new style params).
 , Constructor -> Expr
ctorType :: Type        -- ^ Constructor type (@fields -> target@).
 } deriving (Constructor -> Constructor -> Bool
(Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Bool) -> Eq Constructor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Constructor -> Constructor -> Bool
== :: Constructor -> Constructor -> Bool
$c/= :: Constructor -> Constructor -> Bool
/= :: Constructor -> Constructor -> Bool
Eq, Eq Constructor
Eq Constructor =>
(Constructor -> Constructor -> Ordering)
-> (Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Constructor)
-> (Constructor -> Constructor -> Constructor)
-> Ord Constructor
Constructor -> Constructor -> Bool
Constructor -> Constructor -> Ordering
Constructor -> Constructor -> Constructor
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
$ccompare :: Constructor -> Constructor -> Ordering
compare :: Constructor -> Constructor -> Ordering
$c< :: Constructor -> Constructor -> Bool
< :: Constructor -> Constructor -> Bool
$c<= :: Constructor -> Constructor -> Bool
<= :: Constructor -> Constructor -> Bool
$c> :: Constructor -> Constructor -> Bool
> :: Constructor -> Constructor -> Bool
$c>= :: Constructor -> Constructor -> Bool
>= :: Constructor -> Constructor -> Bool
$cmax :: Constructor -> Constructor -> Constructor
max :: Constructor -> Constructor -> Constructor
$cmin :: Constructor -> Constructor -> Constructor
min :: Constructor -> Constructor -> Constructor
Ord, Int -> Constructor -> ShowS
[Constructor] -> ShowS
Constructor -> String
(Int -> Constructor -> ShowS)
-> (Constructor -> String)
-> ([Constructor] -> ShowS)
-> Show Constructor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Constructor -> ShowS
showsPrec :: Int -> Constructor -> ShowS
$cshow :: Constructor -> String
show :: Constructor -> String
$cshowList :: [Constructor] -> ShowS
showList :: [Constructor] -> ShowS
Show)

type ParamPats = Maybe (Telescope, [Pattern])

newtype Telescope = Telescope { Telescope -> [TBind]
telescope :: [TBind] }
  deriving (Telescope -> Telescope -> Bool
(Telescope -> Telescope -> Bool)
-> (Telescope -> Telescope -> Bool) -> Eq Telescope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Telescope -> Telescope -> Bool
== :: Telescope -> Telescope -> Bool
$c/= :: Telescope -> Telescope -> Bool
/= :: Telescope -> Telescope -> Bool
Eq, Eq Telescope
Eq Telescope =>
(Telescope -> Telescope -> Ordering)
-> (Telescope -> Telescope -> Bool)
-> (Telescope -> Telescope -> Bool)
-> (Telescope -> Telescope -> Bool)
-> (Telescope -> Telescope -> Bool)
-> (Telescope -> Telescope -> Telescope)
-> (Telescope -> Telescope -> Telescope)
-> Ord Telescope
Telescope -> Telescope -> Bool
Telescope -> Telescope -> Ordering
Telescope -> Telescope -> Telescope
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
$ccompare :: Telescope -> Telescope -> Ordering
compare :: Telescope -> Telescope -> Ordering
$c< :: Telescope -> Telescope -> Bool
< :: Telescope -> Telescope -> Bool
$c<= :: Telescope -> Telescope -> Bool
<= :: Telescope -> Telescope -> Bool
$c> :: Telescope -> Telescope -> Bool
> :: Telescope -> Telescope -> Bool
$c>= :: Telescope -> Telescope -> Bool
>= :: Telescope -> Telescope -> Bool
$cmax :: Telescope -> Telescope -> Telescope
max :: Telescope -> Telescope -> Telescope
$cmin :: Telescope -> Telescope -> Telescope
min :: Telescope -> Telescope -> Telescope
Ord, Int -> Telescope -> ShowS
[Telescope] -> ShowS
Telescope -> String
(Int -> Telescope -> ShowS)
-> (Telescope -> String)
-> ([Telescope] -> ShowS)
-> Show Telescope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Telescope -> ShowS
showsPrec :: Int -> Telescope -> ShowS
$cshow :: Telescope -> String
show :: Telescope -> String
$cshowList :: [Telescope] -> ShowS
showList :: [Telescope] -> ShowS
Show, Telescope -> Int
(Telescope -> Int) -> Size Telescope
forall a. (a -> Int) -> Size a
$csize :: Telescope -> Int
size :: Telescope -> Int
Size, Telescope -> Bool
(Telescope -> Bool) -> Null Telescope
forall a. (a -> Bool) -> Null a
$cnull :: Telescope -> Bool
null :: Telescope -> Bool
Null)

emptyTel :: Telescope
emptyTel :: Telescope
emptyTel = [TBind] -> Telescope
Telescope []

data Arity = Arity
  { Arity -> Int
fullArity    :: Int        -- ^ arity of the function
  , Arity -> Maybe Int
isProjection :: Maybe Int  -- ^ projection? then number of parameters
  } deriving (Arity -> Arity -> Bool
(Arity -> Arity -> Bool) -> (Arity -> Arity -> Bool) -> Eq Arity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Arity -> Arity -> Bool
== :: Arity -> Arity -> Bool
$c/= :: Arity -> Arity -> Bool
/= :: Arity -> Arity -> Bool
Eq, Eq Arity
Eq Arity =>
(Arity -> Arity -> Ordering)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Bool)
-> (Arity -> Arity -> Arity)
-> (Arity -> Arity -> Arity)
-> Ord Arity
Arity -> Arity -> Bool
Arity -> Arity -> Ordering
Arity -> Arity -> Arity
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
$ccompare :: Arity -> Arity -> Ordering
compare :: Arity -> Arity -> Ordering
$c< :: Arity -> Arity -> Bool
< :: Arity -> Arity -> Bool
$c<= :: Arity -> Arity -> Bool
<= :: Arity -> Arity -> Bool
$c> :: Arity -> Arity -> Bool
> :: Arity -> Arity -> Bool
$c>= :: Arity -> Arity -> Bool
>= :: Arity -> Arity -> Bool
$cmax :: Arity -> Arity -> Arity
max :: Arity -> Arity -> Arity
$cmin :: Arity -> Arity -> Arity
min :: Arity -> Arity -> Arity
Ord, Int -> Arity -> ShowS
[Arity] -> ShowS
Arity -> String
(Int -> Arity -> ShowS)
-> (Arity -> String) -> ([Arity] -> ShowS) -> Show Arity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Arity -> ShowS
showsPrec :: Int -> Arity -> ShowS
$cshow :: Arity -> String
show :: Arity -> String
$cshowList :: [Arity] -> ShowS
showList :: [Arity] -> ShowS
Show)

data Fun = Fun
  { Fun -> TypeSig
funTypeSig :: TypeSig      -- ^ internal name and type
  , Fun -> Name
funExtName :: Name         -- ^ external name (for associated eta-expanded fun)
  , Fun -> Arity
funArity   :: Arity
  , Fun -> [Clause]
funClauses :: [Clause]
  } deriving (Fun -> Fun -> Bool
(Fun -> Fun -> Bool) -> (Fun -> Fun -> Bool) -> Eq Fun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fun -> Fun -> Bool
== :: Fun -> Fun -> Bool
$c/= :: Fun -> Fun -> Bool
/= :: Fun -> Fun -> Bool
Eq, Eq Fun
Eq Fun =>
(Fun -> Fun -> Ordering)
-> (Fun -> Fun -> Bool)
-> (Fun -> Fun -> Bool)
-> (Fun -> Fun -> Bool)
-> (Fun -> Fun -> Bool)
-> (Fun -> Fun -> Fun)
-> (Fun -> Fun -> Fun)
-> Ord Fun
Fun -> Fun -> Bool
Fun -> Fun -> Ordering
Fun -> Fun -> Fun
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
$ccompare :: Fun -> Fun -> Ordering
compare :: Fun -> Fun -> Ordering
$c< :: Fun -> Fun -> Bool
< :: Fun -> Fun -> Bool
$c<= :: Fun -> Fun -> Bool
<= :: Fun -> Fun -> Bool
$c> :: Fun -> Fun -> Bool
> :: Fun -> Fun -> Bool
$c>= :: Fun -> Fun -> Bool
>= :: Fun -> Fun -> Bool
$cmax :: Fun -> Fun -> Fun
max :: Fun -> Fun -> Fun
$cmin :: Fun -> Fun -> Fun
min :: Fun -> Fun -> Fun
Ord, Int -> Fun -> ShowS
[Fun] -> ShowS
Fun -> String
(Int -> Fun -> ShowS)
-> (Fun -> String) -> ([Fun] -> ShowS) -> Show Fun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fun -> ShowS
showsPrec :: Int -> Fun -> ShowS
$cshow :: Fun -> String
show :: Fun -> String
$cshowList :: [Fun] -> ShowS
showList :: [Fun] -> ShowS
Show)

{-
letToFun :: TypeSig -> Expr -> Fun
letToFun ts e = (ts, (0, [Clause [] $ Just e]))
-}

-- extracted declarations --------------------------------------------

type EDeclaration = Declaration
type EClause      = Clause
type EPattern     = Pattern
type EConstructor = Constructor
type ETypeSig     = TypeSig
type EFun         = Fun
type ETelescope   = Telescope

-- boilerplate -------------------------------------------------------

{-
instance Functor TySig where
  fmap f ts = ts { typePart = f (typePart ts) }
-}

-- eraseMeasure (Delta -> mu -> T) = Delta -> T
eraseMeasure :: Expr -> Expr
eraseMeasure :: Expr -> Expr
eraseMeasure (Quant PiSigma
Pi (TMeasure{}) Expr
b) = Expr
b -- there can only be one measure!
eraseMeasure (Quant PiSigma
Pi a :: TBind
a@(TBind{}) Expr
b)  = PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi TBind
a (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
eraseMeasure Expr
b
eraseMeasure (Quant PiSigma
Pi a :: TBind
a@(TBound{}) Expr
b) = PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
Pi TBind
a (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
eraseMeasure Expr
b
eraseMeasure (LLet LBind
a Telescope
tel Expr
e Expr
b) = LBind -> Telescope -> Expr -> Expr -> Expr
LLet LBind
a Telescope
tel Expr
e (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
eraseMeasure Expr
b
eraseMeasure Expr
t = Expr
t

-- inferable term = True/False
-- not needed for types or sizes
inferable :: Expr -> Bool
inferable :: Expr -> Bool
inferable Var{}   = Bool
True
inferable Sort{}  = Bool
True
inferable Zero{}  = Bool
True
inferable Infty{} = Bool
True
--inferable Con{}   = True
-- 2012-01-22 constructors are no longer inferable, since parameters are missing
inferable (Def (DefId { idKind :: DefId -> IdKind
idKind = ConK{} }))  = Bool
False
inferable Def{} = Bool
True
inferable (App Expr
f Expr
_) = Expr -> Bool
inferable Expr
f
-- inferable (Pair f e) = inferable f && inferable e  -- pairs are not inferable due to irrelevant sigma!
-- inferable Sing{}  = True  -- not with universes
inferable Expr
_       = Bool
False

-- | Collect the variables from the binders
class BoundVars a where
  boundVars :: Collection c Name => a -> c

instance BoundVars a => BoundVars [a] where
  boundVars :: forall c. Collection c Name => [a] -> c
boundVars = (a -> c) -> [a] -> c
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> c
forall c. Collection c Name => a -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars

instance BoundVars a => BoundVars (Maybe a) where
  boundVars :: forall c. Collection c Name => Maybe a -> c
boundVars = (a -> c) -> Maybe a -> c
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> c
forall c. Collection c Name => a -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars

instance (BoundVars a, BoundVars b) => BoundVars (a, b) where
  boundVars :: forall c. Collection c Name => (a, b) -> c
boundVars (a
a, b
b) = [c] -> c
forall a. Monoid a => [a] -> a
mconcat [a -> c
forall c. Collection c Name => a -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars a
a, b -> c
forall c. Collection c Name => b -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars b
b]

instance (BoundVars a, BoundVars b, BoundVars c) => BoundVars (a, b, c) where
  boundVars :: forall c. Collection c Name => (a, b, c) -> c
boundVars (a
a, b
b, c
c) = [c] -> c
forall a. Monoid a => [a] -> a
mconcat [a -> c
forall c. Collection c Name => a -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars a
a, b -> c
forall c. Collection c Name => b -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars b
b, c -> c
forall c. Collection c Name => c -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars c
c]

instance BoundVars (TBinding a) where
  boundVars :: forall c. Collection c Name => TBinding a -> c
boundVars (TBind Name
x Dom a
_)  = Name -> c
forall c e. Collection c e => e -> c
Coll.singleton Name
x
  boundVars (TMeasure Measure Expr
_) = c
forall a. Monoid a => a
mempty
  boundVars (TBound Bound Expr
_)   = c
forall a. Monoid a => a
mempty

instance BoundVars Telescope where
  boundVars :: forall c. Collection c Name => Telescope -> c
boundVars = [TBind] -> c
forall c. Collection c Name => [TBind] -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars ([TBind] -> c) -> (Telescope -> [TBind]) -> Telescope -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> [TBind]
telescope

instance BoundVars (Pat e) where
  boundVars :: forall c. Collection c Name => Pat e -> c
boundVars (VarP Name
name)   = Name -> c
forall c e. Collection c e => e -> c
Coll.singleton Name
name
  boundVars (SizeP e
_ Name
y)   = Name -> c
forall c e. Collection c e => e -> c
Coll.singleton Name
y
  boundVars (SuccP Pat e
p)     = Pat e -> c
forall c. Collection c Name => Pat e -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars Pat e
p
  boundVars (ConP PatternInfo
_ QName
_ [Pat e]
ps) = [Pat e] -> c
forall c. Collection c Name => [Pat e] -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars [Pat e]
ps
  boundVars (PairP Pat e
p Pat e
p')  = (Pat e, Pat e) -> c
forall c. Collection c Name => (Pat e, Pat e) -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars (Pat e
p, Pat e
p')
  boundVars (ProjP Name
_)     = c
forall a. Monoid a => a
mempty
  boundVars (DotP e
_)      = c
forall a. Monoid a => a
mempty
  boundVars (ErasedP Pat e
p)   = Pat e -> c
forall c. Collection c Name => Pat e -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars Pat e
p
  boundVars (Pat e
AbsurdP)     = c
forall a. Monoid a => a
mempty
  boundVars (UnusableP Pat e
_) = c
forall a. Monoid a => a
mempty



-- | Boilerplate to extract free variables in the usual sense.
class FreeVars a where
  freeVars :: a -> Set Name

instance FreeVars a => FreeVars [a] where
  freeVars :: [a] -> Set Name
freeVars = (a -> Set Name) -> [a] -> Set Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance FreeVars a => FreeVars (Maybe a) where
  freeVars :: Maybe a -> Set Name
freeVars = (a -> Set Name) -> Maybe a -> Set Name
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance FreeVars a => FreeVars (Sort a) where
  freeVars :: Sort a -> Set Name
freeVars = (a -> Set Name) -> Sort a -> Set Name
forall m a. Monoid m => (a -> m) -> Sort a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance FreeVars a => FreeVars (Dom a) where
  freeVars :: Dom a -> Set Name
freeVars = (a -> Set Name) -> Dom a -> Set Name
forall m a. Monoid m => (a -> m) -> Dom a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance FreeVars a => FreeVars (Measure a) where
  freeVars :: Measure a -> Set Name
freeVars = (a -> Set Name) -> Measure a -> Set Name
forall m a. Monoid m => (a -> m) -> Measure a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance FreeVars a => FreeVars (Bound a) where
  freeVars :: Bound a -> Set Name
freeVars = (a -> Set Name) -> Bound a -> Set Name
forall m a. Monoid m => (a -> m) -> Bound a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance FreeVars a => FreeVars (Tagged a) where
  freeVars :: Tagged a -> Set Name
freeVars = (a -> Set Name) -> Tagged a -> Set Name
forall m a. Monoid m => (a -> m) -> Tagged a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars

instance (FreeVars a, FreeVars b) => FreeVars (a, b) where
  freeVars :: (a, b) -> Set Name
freeVars (a
a, b
b) = [Set Name] -> Set Name
forall a. Monoid a => [a] -> a
mconcat [a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars a
a, b -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars b
b]

instance (FreeVars a, FreeVars b, FreeVars c) => FreeVars (a, b, c) where
  freeVars :: (a, b, c) -> Set Name
freeVars (a
a, b
b, c
c) = [Set Name] -> Set Name
forall a. Monoid a => [a] -> a
mconcat [a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars a
a, b -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars b
b, c -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars c
c]

instance FreeVars a => FreeVars (TBinding a) where
  freeVars :: TBinding a -> Set Name
freeVars (TBind Name
_x Dom a
a) = Dom a -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Dom a
a  -- Note: x is bound in the stuff to come, not in a.
  freeVars (TMeasure Measure Expr
m) = Measure Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Measure Expr
m
  freeVars (TBound Bound Expr
b)   = Bound Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Bound Expr
b

instance FreeVars Telescope where
  freeVars :: Telescope -> Set Name
freeVars (Telescope [])         = Set Name
forall a. Monoid a => a
mempty
  freeVars (Telescope (TBind
tb : [TBind]
tel)) = TBind -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars TBind
tb Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                          (Telescope -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars ([TBind] -> Telescope
Telescope [TBind]
tel) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ TBind -> Set Name
forall c. Collection c Name => TBind -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars TBind
tb)

instance FreeVars Expr where
  freeVars :: Expr -> Set Name
freeVars Expr
e0 =
    case Expr
e0 of
      Sort Sort Expr
s    -> Sort Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Sort Expr
s
      Expr
Zero      -> Set Name
forall a. Monoid a => a
mempty
      Succ Expr
e    -> Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
e
      Expr
Infty     -> Set Name
forall a. Monoid a => a
mempty
      Var Name
name  -> Name -> Set Name
forall a. a -> Set a
Set.singleton Name
name
      Def{}     -> Set Name
forall a. Monoid a => a
mempty
      Case Expr
e Maybe Expr
mt [Clause]
cls
                -> (Expr, Maybe Expr, [Clause]) -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars (Expr
e, Maybe Expr
mt, [Clause]
cls)
      LLet (TBind Name
x Dom (Maybe Expr)
dom) Telescope
tel Expr
t Expr
u | Telescope -> Bool
forall a. Null a => a -> Bool
null Telescope
tel
                -> (Dom (Maybe Expr), Expr) -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars (Dom (Maybe Expr)
dom, Expr
t) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.delete Name
x (Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
u)
      Pair Expr
f Expr
e  -> (Expr, Expr) -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars (Expr
f, Expr
e)
      App  Expr
f Expr
e  -> (Expr, Expr) -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars (Expr
f, Expr
e)
      Max  [Expr]
es   -> [Expr] -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars [Expr]
es
      Plus [Expr]
es   -> [Expr] -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars [Expr]
es
      Lam Dec
_ Name
x Expr
e -> Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.delete Name
x (Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
e)
      Quant PiSigma
_pisig TBind
ta Expr
b -> TBind -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars TBind
ta Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
b Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ TBind -> Set Name
forall c. Collection c Name => TBind -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars TBind
ta)
{-
      Quant pisig tel ta b
                -> freeVars tel' `Set.union` (freeVars b Set.\\ boundVars tel')
                     where tel' = Telescope $ telescope tel ++ [ta]
-}
      Sing Expr
e Expr
t  -> (Expr, Expr) -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars (Expr
e, Expr
t)
      Below LtLe
_ Expr
e -> Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
e
      Ann Tagged Expr
te    -> Tagged Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Tagged Expr
te
      Expr
Irr       -> Set Name
forall a. Monoid a => a
mempty
      Expr
e         -> String -> Set Name
forall a. HasCallStack => String -> a
error (String -> Set Name) -> String -> Set Name
forall a b. (a -> b) -> a -> b
$ String
"freeVars " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not implemented"

instance FreeVars Clause where
  freeVars :: Clause -> Set Name
freeVars (Clause TeleVal
_ [Pattern]
_  Maybe Expr
Nothing)  = Set Name
forall a. Monoid a => a
mempty  -- absurd clause
  freeVars (Clause TeleVal
_ [Pattern]
ps (Just Expr
e)) = Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
e Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [Pattern] -> Set Name
forall c. Collection c Name => [Pattern] -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars [Pattern]
ps

patternVars :: Pattern -> [Name]
patternVars :: Pattern -> [Name]
patternVars = Pattern -> [Name]
forall c. Collection c Name => Pattern -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars
{-
patternVars (VarP name)   = [name]
patternVars (SizeP x y)   = [y]
patternVars (SuccP p)     = patternVars p
patternVars (ConP _ _ ps) = List.concat $ List.map patternVars ps
patternVars (PairP p p')  = patternVars p ++ patternVars p'
patternVars (DotP _)      = []
patternVars (ErasedP p)   = patternVars p
patternVars (AbsurdP)     = []
-}

-- | Get all the definitions that are refered to in expression.
--   This is used e.g. to check whether a (co)fun is recursive.
class UsedDefs a where
  usedDefs :: a -> [Name]

instance UsedDefs a => UsedDefs [a] where
  usedDefs :: [a] -> [Name]
usedDefs = (a -> [Name]) -> [a] -> [Name]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance UsedDefs a => UsedDefs (Maybe a) where
  usedDefs :: Maybe a -> [Name]
usedDefs = (a -> [Name]) -> Maybe a -> [Name]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance UsedDefs a => UsedDefs (Sort a) where
  usedDefs :: Sort a -> [Name]
usedDefs = (a -> [Name]) -> Sort a -> [Name]
forall m a. Monoid m => (a -> m) -> Sort a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance UsedDefs a => UsedDefs (Dom a) where
  usedDefs :: Dom a -> [Name]
usedDefs = (a -> [Name]) -> Dom a -> [Name]
forall m a. Monoid m => (a -> m) -> Dom a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance UsedDefs a => UsedDefs (Measure a) where
  usedDefs :: Measure a -> [Name]
usedDefs = (a -> [Name]) -> Measure a -> [Name]
forall m a. Monoid m => (a -> m) -> Measure a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance UsedDefs a => UsedDefs (Bound a) where
  usedDefs :: Bound a -> [Name]
usedDefs = (a -> [Name]) -> Bound a -> [Name]
forall m a. Monoid m => (a -> m) -> Bound a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance UsedDefs a => UsedDefs (Tagged a) where
  usedDefs :: Tagged a -> [Name]
usedDefs = (a -> [Name]) -> Tagged a -> [Name]
forall m a. Monoid m => (a -> m) -> Tagged a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs

instance (UsedDefs a, UsedDefs b) => UsedDefs (a, b) where
  usedDefs :: (a, b) -> [Name]
usedDefs (a
a, b
b) = [[Name]] -> [Name]
forall a. Monoid a => [a] -> a
mconcat [a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs a
a, b -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs b
b]

instance (UsedDefs a, UsedDefs b, UsedDefs c) => UsedDefs (a, b, c) where
  usedDefs :: (a, b, c) -> [Name]
usedDefs (a
a, b
b, c
c) = [[Name]] -> [Name]
forall a. Monoid a => [a] -> a
mconcat [a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs a
a, b -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs b
b, c -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs c
c]

instance (UsedDefs a, UsedDefs b, UsedDefs c, UsedDefs d) => UsedDefs (a, b, c, d) where
  usedDefs :: (a, b, c, d) -> [Name]
usedDefs (a
a, b
b, c
c, d
d) = [[Name]] -> [Name]
forall a. Monoid a => [a] -> a
mconcat [a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs a
a, b -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs b
b, c -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs c
c, d -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs d
d]

instance UsedDefs a => UsedDefs (TBinding a) where
  usedDefs :: TBinding a -> [Name]
usedDefs (TBind Name
_ Dom a
e)  = Dom a -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Dom a
e
  usedDefs (TMeasure Measure Expr
m) = Measure Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Measure Expr
m
  usedDefs (TBound Bound Expr
b)   = Bound Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Bound Expr
b

instance UsedDefs Telescope where
  usedDefs :: Telescope -> [Name]
usedDefs = [TBind] -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs ([TBind] -> [Name])
-> (Telescope -> [TBind]) -> Telescope -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> [TBind]
telescope

instance UsedDefs DefId where
  usedDefs :: DefId -> [Name]
usedDefs DefId
x
    | DefId -> IdKind
idKind DefId
x IdKind -> [IdKind] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdKind
FunK, IdKind
DatK] = [QName -> Name
unqual (QName -> Name) -> QName -> Name
forall a b. (a -> b) -> a -> b
$ DefId -> QName
idName DefId
x]
    | Bool
otherwise                     = []

instance UsedDefs Clause where
  usedDefs :: Clause -> [Name]
usedDefs = Maybe Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Maybe Expr -> [Name])
-> (Clause -> Maybe Expr) -> Clause -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> Maybe Expr
clExpr

instance UsedDefs Expr where
  usedDefs :: Expr -> [Name]
usedDefs (Def DefId
x)            = DefId -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs DefId
x
  usedDefs (Pair Expr
f Expr
e)         = (Expr, Expr) -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Expr
f, Expr
e)
  usedDefs (App Expr
f Expr
e)          = (Expr, Expr) -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Expr
f, Expr
e)
  usedDefs (Max [Expr]
es)           = [Expr] -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs [Expr]
es
  usedDefs (Plus [Expr]
es)          = [Expr] -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs [Expr]
es
  usedDefs (Lam Dec
_ Name
_ Expr
e)        = Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Expr
e
  usedDefs (Sing Expr
a Expr
b)         = (Expr, Expr) -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Expr
a, Expr
b)
  usedDefs (Below LtLe
_ Expr
b)        = Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Expr
b
--  usedDefs (Quant _ tel tb b) = usedDefs (tel, tb, b)
  usedDefs (Quant PiSigma
_ TBind
tb Expr
b)     = (TBind, Expr) -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (TBind
tb, Expr
b)
  usedDefs (LLet LBind
tb Telescope
tel Expr
e1 Expr
e2)= (LBind, Telescope, Expr, Expr) -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (LBind
tb, Telescope
tel, Expr
e1, Expr
e2)
  usedDefs (Succ Expr
e)           = Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Expr
e
  usedDefs (Case Expr
e Maybe Expr
mt [Clause]
cls)    = (Expr, Maybe Expr, [Clause]) -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Expr
e, Maybe Expr
mt, [Clause]
cls)
  usedDefs (Ann Tagged Expr
e)            = Tagged Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Tagged Expr
e
  usedDefs (Sort Sort Expr
s)           = Sort Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Sort Expr
s
  usedDefs Expr
Zero               = []
  usedDefs Expr
Infty              = []
  usedDefs Meta{}             = []
  usedDefs Var{}              = []
  usedDefs Proj{}             = []
  usedDefs (Record RecInfo
_ri [(Name, Expr)]
rs)    = ((Name, Expr) -> [Name]) -> [(Name, Expr)] -> [Name]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs (Expr -> [Name])
-> ((Name, Expr) -> Expr) -> (Name, Expr) -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Expr) -> Expr
forall a b. (a, b) -> b
snd) [(Name, Expr)]
rs
  usedDefs Expr
e                  = String -> [Name]
forall a. HasCallStack => String -> a
error (String -> [Name]) -> String -> [Name]
forall a b. (a -> b) -> a -> b
$ String
"usedDefs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not implemented"

rhsDefs :: [Clause] -> [Name]
rhsDefs :: [Clause] -> [Name]
rhsDefs [Clause]
cls = ([Name] -> Clause -> [Name]) -> [Name] -> [Clause] -> [Name]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl (\ [Name]
ns (Clause TeleVal
_ [Pattern]
_ Maybe Expr
e) -> [Name] -> (Expr -> [Name]) -> Maybe Expr -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Expr -> [Name]
forall a. UsedDefs a => a -> [Name]
usedDefs Maybe Expr
e [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
ns) [] [Clause]
cls

-- pretty printing expressions ---------------------------------------

precArrL, precAppL, precAppR :: Int
[Int
precArrL, Int
precAppL, Int
precAppR] = [Int
1..Int
3]

instance Pretty Name where
--  pretty x = text $ suggestion x
  pretty :: Name -> Doc
pretty Name
x = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
x

instance Pretty QName where
  pretty :: QName -> Doc
pretty (Qual Name
m Name
n) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
m Doc -> Doc -> Doc
<> String -> Doc
text String
"." Doc -> Doc -> Doc
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n
  pretty (QName Name
n)  = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n

instance Pretty DefId where
--    pretty d = pretty $ name d
    pretty :: DefId -> Doc
pretty DefId
d = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DefId -> String
forall a. Show a => a -> String
show DefId
d

instance Pretty Expr where
  prettyPrec :: Int -> Expr -> Doc
prettyPrec Int
_ Expr
Irr         = String -> Doc
text String
"."
  prettyPrec Int
k (Sort Sort Expr
s)    = Int -> Sort Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
k Sort Expr
s
  prettyPrec Int
_ Expr
Zero        = String -> Doc
text String
"0"
  prettyPrec Int
_ Expr
Infty       = String -> Doc
text String
"#"
  prettyPrec Int
_ (Meta Int
i)    = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"?" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
  prettyPrec Int
_ (Var Name
n)     = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n
--  prettyPrec _ (Con _ n)   = text n
  prettyPrec Int
_ (Def DefId
x)     = DefId -> Doc
forall a. Pretty a => a -> Doc
pretty DefId
x
--  prettyPrec _ (Let n)     = text n
  prettyPrec Int
_ (Sing Expr
e Expr
t)  = Doc -> Doc
angleBrackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t
  prettyPrec Int
_ e :: Expr
e@Succ{}    =
    case Expr -> (Int, Expr)
succView Expr
e of
      (Int
n, Expr
Zero) -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n
      (Int
n, Expr
e')   -> String -> Doc
text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'$') Doc -> Doc -> Doc
<> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Expr
e'
--  prettyPrec k (Succ e)    = text "$" <> prettyPrec precAppR e
{-  prettyPrec k (Succ e)    = parensIf (precAppR <= k) $
                              text "$" <+> prettyPrec precAppR e   -}
  prettyPrec Int
k (Max [Expr]
es)  = Bool -> Doc -> Doc
parensIf (Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (Doc -> Expr -> Doc) -> Doc -> [Expr] -> Doc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl (\ Doc
d Expr
e -> Doc
d Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Expr
e) (String -> Doc
text String
"max") [Expr]
es
  prettyPrec Int
k (Plus (Expr
e:[Expr]
es))  = Bool -> Doc -> Doc
parensIf (Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (Doc -> Expr -> Doc) -> Doc -> [Expr] -> Doc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl (\ Doc
d Expr
e' -> Doc
d Doc -> Doc -> Doc
<+> String -> Doc
text String
"+" Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Expr
e') (Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Expr
e) [Expr]
es
  prettyPrec Int
_ (Proj PrePost
Pre Name
n)   = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n
  prettyPrec Int
_ (Proj PrePost
Post Name
n)  = String -> Doc
text String
"." Doc -> Doc -> Doc
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n
  prettyPrec Int
_ (Record RecInfo
AnonRec []) = String -> Doc
text String
"record" Doc -> Doc -> Doc
<+> Doc -> Doc
braces Doc
empty
  prettyPrec Int
_ (Record RecInfo
AnonRec [(Name, Expr)]
rs) = String -> Doc
text String
"record" Doc -> Doc -> Doc
<+> [(Name, Expr)] -> Doc
forall a b. (Pretty a, Pretty b) => [(a, b)] -> Doc
prettyRecFields [(Name, Expr)]
rs
  prettyPrec Int
_ (Record (NamedRec ConK
_ QName
n Bool
_ Dotted
dotted) []) = Dotted -> Doc -> Doc
forall a. DotIf a => a -> Doc -> Doc
dotIf Dotted
dotted (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
n
  prettyPrec Int
_ (Record (NamedRec ConK
_ QName
n Bool
True Dotted
dotted) [(Name, Expr)]
rs) = Dotted -> Doc -> Doc
forall a. DotIf a => a -> Doc -> Doc
dotIf Dotted
dotted (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
n Doc -> Doc -> Doc
<+> [(Name, Expr)] -> Doc
forall a b. (Pretty a, Pretty b) => [(a, b)] -> Doc
prettyRecFields [(Name, Expr)]
rs
  prettyPrec Int
k (Record (NamedRec ConK
_ QName
n Bool
False Dotted
dotted) [(Name, Expr)]
rs) =
   Bool -> Doc -> Doc
parensIf (Bool -> Bool
not ([(Name, Expr)] -> Bool
forall a. Null a => a -> Bool
null [(Name, Expr)]
rs) Bool -> Bool -> Bool
&& Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Dotted -> Doc -> Doc
forall a. DotIf a => a -> Doc -> Doc
dotIf Dotted
dotted (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
     QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (((Name, Expr) -> Doc) -> [(Name, Expr)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR (Expr -> Doc) -> ((Name, Expr) -> Expr) -> (Name, Expr) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Expr) -> Expr
forall a b. (a, b) -> b
snd) [(Name, Expr)]
rs)
  prettyPrec Int
_ (Pair Expr
e1 Expr
e2) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e1 Doc -> Doc -> Doc
<+> Doc
comma Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e2
  prettyPrec Int
k (App Expr
f Expr
e)  = Bool -> Doc -> Doc
parensIf (Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppL Expr
f Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Expr
e
--   prettyPrec k (App e [])  = prettyPrec k e
--   prettyPrec k (App e es)  = parensIf (precAppR <= k) $
--     List.foldl (\ d e -> d <+> prettyPrec precAppR e) (prettyPrec precAppL e) es
  prettyPrec Int
k (Case Expr
e Maybe Expr
mt [Clause]
cs) = Bool -> Doc -> Doc
parensIf (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e) Doc -> Doc -> Doc
<+> (Doc -> (Expr -> Doc) -> Maybe Expr -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\ Expr
t -> Doc
colon Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t) Maybe Expr
mt) Doc -> Doc -> Doc
$$ ([Doc] -> Doc
vlist ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Clause -> Doc) -> [Clause] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map Clause -> Doc
prettyCase [Clause]
cs)
  prettyPrec Int
k (Lam Dec
dec Name
x Expr
e) = Bool -> Doc -> Doc
parensIf (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc -> Doc
brackets else Doc -> Doc
forall a. a -> a
id) (String -> Doc
text String
"\\" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"->")
      Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e
  prettyPrec Int
k (LLet (TBind Name
n (Domain Maybe Expr
mt Kind
_ki Dec
dec)) Telescope
tel Expr
e1 Expr
e2) | Telescope -> Bool
forall a. Null a => a -> Bool
null Telescope
tel = Bool -> Doc -> Doc
parensIf (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc
lbrack else Doc
PP.empty) Doc -> Doc -> Doc
<>
       Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat [ Doc -> (Expr -> Doc) -> Maybe Expr -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\ Expr
t -> Doc
colon Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t) Maybe Expr
mt
                           Doc -> Doc -> Doc
<> (if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc
rbrack else Doc
PP.empty)
                       , Doc
equals Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e1 ]))
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e2)
  prettyPrec Int
k (LLet (TBind Name
n (Domain Maybe Expr
mt Kind
_ki Dec
dec)) Telescope
tel Expr
e1 Expr
e2) = Bool -> Doc -> Doc
parensIf (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc -> Doc
brackets else Doc -> Doc
forall a. a -> a
id) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
n)
                Doc -> Doc -> Doc
<+> Telescope -> Doc
forall a. Pretty a => a -> Doc
pretty Telescope
tel
                Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat [ Doc -> (Expr -> Doc) -> Maybe Expr -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\ Expr
t -> Doc
colon Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t) Maybe Expr
mt
                         , Doc
equals Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e1 ])
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"in" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e2)
{-
  prettyPrec k (LLet (TBind n (Domain Nothing _ki dec)) e1 e2) = parensIf (0 < k) $
    (text "let" <+> ((if erased dec then lbrack else PP.empty) <>
       pretty n <+> vcat [ if erased dec then rbrack else PP.empty
                         , equals <+> pretty e1 ]))
    $$ (text "in" <+> pretty e2)
-}
  prettyPrec Int
k (Below LtLe
ltle Expr
e) = LtLe -> Doc
forall a. Pretty a => a -> Doc
pretty LtLe
ltle Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
k Expr
e
  prettyPrec Int
k (Quant PiSigma
Pi (TMeasure Measure Expr
mu) Expr
t2) = Bool -> Doc -> Doc
parensIf (Int
precArrL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (Measure Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Measure Expr
mu Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t2)
  prettyPrec Int
k (Quant PiSigma
Pi (TBound Bound Expr
beta) Expr
t2) = Bool -> Doc -> Doc
parensIf (Int
precArrL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    (Bound Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Bound Expr
beta Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t2)

  prettyPrec Int
k (Quant PiSigma
pisig (TBind Name
x (Domain Expr
t1 Kind
_ki Dec
dec)) Expr
t2) | String -> Bool
forall a. Null a => a -> Bool
null (Name -> String
suggestion Name
x) = Bool -> Doc -> Doc
parensIf (Int
precArrL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc
ppol Doc -> Doc -> Doc
<> Doc -> Doc
brackets (Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t1)
       else Doc
ppol Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precArrL Expr
t1)
      Doc -> Doc -> Doc
<+> PiSigma -> Doc
forall a. Pretty a => a -> Doc
pretty PiSigma
pisig Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t2)
    where pol :: Pol
pol = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
          ppol :: Doc
ppol = if Pol
polPol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
==Pol
defaultPol then Doc
PP.empty else String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Pol -> String
forall a. Show a => a -> String
show Pol
pol

  prettyPrec Int
k (Quant PiSigma
pisig (TBind Name
x (Domain (Below LtLe
ltle Expr
t1) Kind
_ki Dec
dec)) Expr
t2) = Bool -> Doc -> Doc
parensIf (Int
precArrL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Doc
ppol Doc -> Doc -> Doc
<>
    ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc -> Doc
brackets else Doc -> Doc
parens) (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
<+> LtLe -> Doc
forall a. Pretty a => a -> Doc
pretty LtLe
ltle Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t1) Doc -> Doc -> Doc
<+> PiSigma -> Doc
forall a. Pretty a => a -> Doc
pretty PiSigma
pisig Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t2
    where pol :: Pol
pol = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
          ppol :: Doc
ppol = if Pol
polPol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
==Pol
defaultPol then Doc
PP.empty else String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Pol -> String
forall a. Show a => a -> String
show Pol
pol

  prettyPrec Int
k (Quant PiSigma
pisig (TBind Name
x (Domain Expr
t1 Kind
_ki Dec
dec)) Expr
t2) = Bool -> Doc -> Doc
parensIf (Int
precArrL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Doc
ppol Doc -> Doc -> Doc
<>
    ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc -> Doc
brackets else Doc -> Doc
parens) (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
<+> Doc
colon Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t1) Doc -> Doc -> Doc
<+> PiSigma -> Doc
forall a. Pretty a => a -> Doc
pretty PiSigma
pisig Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t2
    where pol :: Pol
pol = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
          ppol :: Doc
ppol = if Pol
polPol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
==Pol
defaultPol then Doc
PP.empty else String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Pol -> String
forall a. Show a => a -> String
show Pol
pol

  prettyPrec Int
_ (Ann Tagged Expr
e) = Tagged Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Tagged Expr
e

class DotIf a where
  dotIf :: a -> Doc -> Doc

instance DotIf Bool where
  dotIf :: Bool -> Doc -> Doc
dotIf Bool
False Doc
d = Doc
d
  dotIf Bool
True  Doc
d = String -> Doc
text String
"." Doc -> Doc -> Doc
<> Doc
d

instance DotIf Dotted where
  dotIf :: Dotted -> Doc -> Doc
dotIf Dotted
c = Bool -> Doc -> Doc
forall a. DotIf a => a -> Doc -> Doc
dotIf (Dotted -> Bool
isDotted Dotted
c)

instance Pretty TBind where
  prettyPrec :: Int -> TBind -> Doc
prettyPrec Int
_ (TMeasure Measure Expr
mu) = Measure Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Measure Expr
mu
  prettyPrec Int
_ (TBound Bound Expr
beta) = Bound Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Bound Expr
beta

  prettyPrec Int
_ (TBind Name
x (Domain (Below LtLe
ltle Expr
t1) Kind
_ki Dec
dec)) =
    Doc
ppol Doc -> Doc -> Doc
<>
    ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc -> Doc
brackets else Doc -> Doc
parens) (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
<+> LtLe -> Doc
forall a. Pretty a => a -> Doc
pretty LtLe
ltle Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t1)
    where pol :: Pol
pol = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
          ppol :: Doc
ppol = if Pol
polPol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
==Pol
defaultPol then Doc
PP.empty else String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Pol -> String
forall a. Show a => a -> String
show Pol
pol

  prettyPrec Int
_ (TBind Name
x (Domain Expr
t1 Kind
_ki Dec
dec)) =
    Doc
ppol Doc -> Doc -> Doc
<>
    ((if Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec then Doc -> Doc
brackets else Doc -> Doc
parens) (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
<+> Doc
colon Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
t1)
    where pol :: Pol
pol = Dec -> Pol
forall pol. Polarity pol => Decoration pol -> pol
polarity Dec
dec
          ppol :: Doc
ppol = if Pol
polPol -> Pol -> Bool
forall a. Eq a => a -> a -> Bool
==Pol
defaultPol then Doc
PP.empty else String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Pol -> String
forall a. Show a => a -> String
show Pol
pol

instance Pretty Telescope where
  prettyPrec :: Int -> Telescope -> Doc
prettyPrec Int
_ Telescope
tel = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (TBind -> Doc) -> [TBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TBind -> Doc
forall a. Pretty a => a -> Doc
pretty ([TBind] -> [Doc]) -> [TBind] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
tel

prettyRecFields :: (Pretty a, Pretty b) => [(a,b)] -> Doc
prettyRecFields :: forall a b. (Pretty a, Pretty b) => [(a, b)] -> Doc
prettyRecFields [(a, b)]
rs =
    let Doc
l:[Doc]
ls = ((a, b) -> Doc) -> [(a, b)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (\ (a
n, b
e) -> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
n Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Int -> b -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0 b
e) [(a, b)]
rs
    in  [Doc] -> Doc
cat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc
lbrace Doc -> Doc -> Doc
<+> Doc
l) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (Doc
semi Doc -> Doc -> Doc
<+>) [Doc]
ls [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
empty Doc -> Doc -> Doc
<+> Doc
rbrace]

prettyCase :: Clause -> Doc
prettyCase :: Clause -> Doc
prettyCase (Clause TeleVal
_ [Pattern
p] Maybe Expr
Nothing)  = Pattern -> Doc
forall a. Pretty a => a -> Doc
pretty Pattern
p
prettyCase (Clause TeleVal
_ [Pattern
p] (Just Expr
e)) = Pattern -> Doc
forall a. Pretty a => a -> Doc
pretty Pattern
p Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e

instance Pretty PiSigma where
  pretty :: PiSigma -> Doc
pretty PiSigma
Pi    = String -> Doc
text String
"->"
  pretty PiSigma
Sigma = String -> Doc
text String
"&"

vlist :: [Doc] -> Doc
vlist :: [Doc] -> Doc
vlist [] = Doc
lbrace Doc -> Doc -> Doc
<> Doc
rbrace
vlist [Doc]
ds = ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(<+>) (Doc
lbrace Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat Doc
semi) [Doc]
ds) Doc -> Doc -> Doc
$$ Doc
rbrace

instance Pretty (Measure Expr) where
  pretty :: Measure Expr -> Doc
pretty (Measure [Expr]
es) = String -> Doc
text String
"|" Doc -> Doc -> Doc
<> Doc -> [Doc] -> Doc
hsepBy Doc
comma ((Expr -> Doc) -> [Expr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map Expr -> Doc
forall a. Pretty a => a -> Doc
pretty [Expr]
es) Doc -> Doc -> Doc
<> String -> Doc
text String
"|"

instance Pretty LtLe where
  pretty :: LtLe -> Doc
pretty LtLe
Lt = String -> Doc
text String
"<"
  pretty LtLe
Le = String -> Doc
text String
"<="

instance Pretty (Bound Expr) where
  pretty :: Bound Expr -> Doc
pretty (Bound LtLe
ltle Measure Expr
mu Measure Expr
mu') = Measure Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Measure Expr
mu Doc -> Doc -> Doc
<+> LtLe -> Doc
forall a. Pretty a => a -> Doc
pretty LtLe
ltle Doc -> Doc -> Doc
<+> Measure Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Measure Expr
mu'

{-
instance Pretty (Bound Expr) where
  pretty (Bound mu mu') = case predecessor mu' of
    Nothing -> pretty mu <+> text "<" <+> pretty mu'
    Just mu' -> pretty mu <+> text "<=" <+> pretty mu'
-}


instance Pretty (Sort Expr) where
  prettyPrec :: Int -> Sort Expr -> Doc
prettyPrec Int
_ (SortC Class
c)  = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Class -> String
forall a. Show a => a -> String
show Class
c
  prettyPrec Int
_ (Set Expr
Zero) = String -> Doc
text String
"Set" -- print as Set for backwards compat.
  prettyPrec Int
k (Set Expr
e) =  Bool -> Doc -> Doc
parensIf (Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> Doc
text String
"Set" Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Expr
e
  prettyPrec Int
k (CoSet Expr
e) = Bool -> Doc -> Doc
parensIf (Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    String -> Doc
text String
"CoSet" Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Expr
e

instance Pretty Pattern where
  prettyPrec :: Int -> Pattern -> Doc
prettyPrec Int
_ (VarP Name
x)       = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
  prettyPrec Int
k (ConP PatternInfo
co QName
c [Pattern]
ps) = Bool -> Doc -> Doc
parensIf (Bool -> Bool
not ([Pattern] -> Bool
forall a. Null a => a -> Bool
null [Pattern]
ps) Bool -> Bool -> Bool
&& Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    -- (if dottedPat co then text "." else empty) <>
    Bool -> Doc -> Doc
forall a. DotIf a => a -> Doc -> Doc
dotIf (PatternInfo -> Bool
dottedPat PatternInfo
co) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Pattern -> Doc) -> [Pattern] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR) [Pattern]
ps)
  prettyPrec Int
k (SuccP Pattern
p)      = String -> Doc
text String
"$" Doc -> Doc -> Doc
<> Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
k Pattern
p
  prettyPrec Int
k (SizeP Expr
x Name
y)    = Bool -> Doc -> Doc
parensIf (Int
precAppR Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
y Doc -> Doc -> Doc
<+> String -> Doc
text String
"<" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
x
  prettyPrec Int
_ (PairP Pattern
p Pattern
p')   = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Pattern -> Doc
forall a. Pretty a => a -> Doc
pretty Pattern
p Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<+> Pattern -> Doc
forall a. Pretty a => a -> Doc
pretty Pattern
p'
  prettyPrec Int
k (UnusableP Pattern
p)  = Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
k Pattern
p
  prettyPrec Int
_ (ProjP Name
x)      = String -> Doc
text String
"." Doc -> Doc -> Doc
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
  prettyPrec Int
_ (DotP Expr
p)       = String -> Doc
text String
"." Doc -> Doc -> Doc
<> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Expr
p
  prettyPrec Int
_ (Pattern
AbsurdP)      = String -> Doc
text String
"()"
  prettyPrec Int
_ (ErasedP Pattern
p)    = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0 Pattern
p


instance Show Expr where
  showsPrec :: Int -> Expr -> ShowS
showsPrec Int
k Expr
e String
s = Doc -> String
render (Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
k Expr
e) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
  -- show = render . pretty -- showExpr

instance Show Pattern where
  show :: Pattern -> String
show = Doc -> String
render (Doc -> String) -> (Pattern -> Doc) -> Pattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Doc
forall a. Pretty a => a -> Doc
pretty

showCase :: Clause -> String
showCase :: Clause -> String
showCase (Clause TeleVal
_ [Pattern
p] Maybe Expr
Nothing) = Doc -> String
render (Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Pattern
p)
showCase (Clause TeleVal
_ [Pattern
p] (Just Expr
e)) = Doc -> String
render (Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR Pattern
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e

showCases :: [Clause] -> String
showCases :: [Clause] -> String
showCases = String -> (Clause -> String) -> [Clause] -> String
forall a. String -> (a -> String) -> [a] -> String
showList String
"; " Clause -> String
showCase



-- substitution ------------------------------------------------------

{-
class PatSubst p where
  patSubst :: [(Name, Expr)] -> p -> p

instance PatSubst Name where
  patSubst phi n = maybe p id $ lookup n phi
-}

-- | substitute into pattern
patSubst :: [(Name, Pattern)] -> Pattern -> Pattern
patSubst :: [(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi Pattern
p =
  let phi' :: Name -> Expr
phi' Name
x = Expr -> (Pattern -> Expr) -> Maybe Pattern -> Expr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Expr
Var Name
x) Pattern -> Expr
patternToExpr (Maybe Pattern -> Expr) -> Maybe Pattern -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, Pattern)] -> Maybe Pattern
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x [(Name, Pattern)]
phi
  in
  case Pattern
p of
    VarP Name
n -> Pattern -> (Pattern -> Pattern) -> Maybe Pattern -> Pattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pattern
p Pattern -> Pattern
forall a. a -> a
id (Maybe Pattern -> Pattern) -> Maybe Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, Pattern)] -> Maybe Pattern
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Pattern)]
phi
    ConP PatternInfo
pi QName
n [Pattern]
ps -> PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
pi QName
n ([Pattern] -> Pattern) -> [Pattern] -> Pattern
forall a b. (a -> b) -> a -> b
$ (Pattern -> Pattern) -> [Pattern] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
List.map ([(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi) [Pattern]
ps
    SuccP Pattern
p      -> Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi Pattern
p
    SizeP Expr
e Name
y    -> Expr -> Name -> Pattern
forall e. e -> Name -> Pat e
SizeP ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi' Expr
e) Name
y
    PairP Pattern
p1 Pattern
p2  -> Pattern -> Pattern -> Pattern
forall e. Pat e -> Pat e -> Pat e
PairP ([(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi Pattern
p1) ([(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi Pattern
p2)
    ProjP Name
_      -> Pattern
p
    DotP Expr
e       -> Expr -> Pattern
forall e. e -> Pat e
DotP (Expr -> Pattern) -> Expr -> Pattern
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi' Expr
e
    Pattern
AbsurdP      -> Pattern
p
    ErasedP Pattern
p    -> Pattern -> Pattern
forall e. Pat e -> Pat e
ErasedP (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi Pattern
p
    UnusableP Pattern
p   -> Pattern -> Pattern
forall e. Pat e -> Pat e
UnusableP (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Name, Pattern)] -> Pattern -> Pattern
patSubst [(Name, Pattern)]
phi Pattern
p

-- parallel substitution (CAUTION! NOT CAPTURE AVOIDING!)
-- only needed to generate destructors
-- does not substitute into patterns of a Case

class ParSubst a where
  parSubst :: (Name -> Expr) -> a -> a

instance ParSubst a => ParSubst [a] where
  parSubst :: (Name -> Expr) -> [a] -> [a]
parSubst = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> [a] -> [a])
-> ((Name -> Expr) -> a -> a) -> (Name -> Expr) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst

instance ParSubst a => ParSubst (Maybe a) where
  parSubst :: (Name -> Expr) -> Maybe a -> Maybe a
parSubst = (a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Maybe a -> Maybe a)
-> ((Name -> Expr) -> a -> a)
-> (Name -> Expr)
-> Maybe a
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst

instance ParSubst a => ParSubst (Dom a) where
  parSubst :: (Name -> Expr) -> Dom a -> Dom a
parSubst = (a -> a) -> Dom a -> Dom a
forall a b. (a -> b) -> Dom a -> Dom b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Dom a -> Dom a)
-> ((Name -> Expr) -> a -> a) -> (Name -> Expr) -> Dom a -> Dom a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst

instance ParSubst a => ParSubst (Measure a) where
  parSubst :: (Name -> Expr) -> Measure a -> Measure a
parSubst = (a -> a) -> Measure a -> Measure a
forall a b. (a -> b) -> Measure a -> Measure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Measure a -> Measure a)
-> ((Name -> Expr) -> a -> a)
-> (Name -> Expr)
-> Measure a
-> Measure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst

instance ParSubst a => ParSubst (Bound a) where
  parSubst :: (Name -> Expr) -> Bound a -> Bound a
parSubst = (a -> a) -> Bound a -> Bound a
forall a b. (a -> b) -> Bound a -> Bound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Bound a -> Bound a)
-> ((Name -> Expr) -> a -> a)
-> (Name -> Expr)
-> Bound a
-> Bound a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst

instance ParSubst a => ParSubst (Tagged a) where
  parSubst :: (Name -> Expr) -> Tagged a -> Tagged a
parSubst = (a -> a) -> Tagged a -> Tagged a
forall a b. (a -> b) -> Tagged a -> Tagged b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Tagged a -> Tagged a)
-> ((Name -> Expr) -> a -> a)
-> (Name -> Expr)
-> Tagged a
-> Tagged a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst

instance ParSubst a => ParSubst (TBinding a) where
  parSubst :: (Name -> Expr) -> TBinding a -> TBinding a
parSubst Name -> Expr
phi (TBind Name
x Dom a
a)  = Name -> Dom a -> TBinding a
forall a. Name -> Dom a -> TBinding a
TBind Name
x  (Dom a -> TBinding a) -> Dom a -> TBinding a
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Dom a -> Dom a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Dom a
a
  parSubst Name -> Expr
phi (TMeasure Measure Expr
m) = Measure Expr -> TBinding a
forall a. Measure Expr -> TBinding a
TMeasure (Measure Expr -> TBinding a) -> Measure Expr -> TBinding a
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Measure Expr -> Measure Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Measure Expr
m
  parSubst Name -> Expr
phi (TBound Bound Expr
b)   = Bound Expr -> TBinding a
forall a. Bound Expr -> TBinding a
TBound   (Bound Expr -> TBinding a) -> Bound Expr -> TBinding a
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Bound Expr -> Bound Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Bound Expr
b

instance ParSubst a => ParSubst (Sort a) where
  parSubst :: (Name -> Expr) -> Sort a -> Sort a
parSubst Name -> Expr
phi (CoSet a
e) = a -> Sort a
forall a. a -> Sort a
CoSet (a -> Sort a) -> a -> Sort a
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi a
e
  parSubst Name -> Expr
phi (Set a
e)   = a -> Sort a
forall a. a -> Sort a
Set   (a -> Sort a) -> a -> Sort a
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> a -> a
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi a
e
  parSubst Name -> Expr
_   Sort a
s         = Sort a
s

instance ParSubst Telescope where
  parSubst :: (Name -> Expr) -> Telescope -> Telescope
parSubst Name -> Expr
phi = [TBind] -> Telescope
Telescope ([TBind] -> Telescope)
-> (Telescope -> [TBind]) -> Telescope -> Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Expr) -> [TBind] -> [TBind]
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi ([TBind] -> [TBind])
-> (Telescope -> [TBind]) -> Telescope -> [TBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> [TBind]
telescope

instance ParSubst Clause where
  parSubst :: (Name -> Expr) -> Clause -> Clause
parSubst Name -> Expr
phi (Clause TeleVal
tel [Pattern]
ps Maybe Expr
e) = TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern]
ps (Maybe Expr -> Clause) -> Maybe Expr -> Clause
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Maybe Expr -> Maybe Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Maybe Expr
e

-- TODO: Refactor!
instance ParSubst Expr where
  parSubst :: (Name -> Expr) -> Expr -> Expr
parSubst Name -> Expr
phi (Sort Sort Expr
s)              = Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Sort Expr -> Sort Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Sort Expr
s
  parSubst Name -> Expr
phi (Succ Expr
e)              = Expr -> Expr
Succ ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
e)
  parSubst Name -> Expr
_   e :: Expr
e@Expr
Zero                = Expr
e
  parSubst Name -> Expr
_   e :: Expr
e@Expr
Infty               = Expr
e
  parSubst Name -> Expr
_   e :: Expr
e@Meta{}              = Expr
e
  parSubst Name -> Expr
_   e :: Expr
e@Proj{}              = Expr
e
  parSubst Name -> Expr
phi (Var Name
x)               = Name -> Expr
phi Name
x
  parSubst Name -> Expr
_   e :: Expr
e@Def{}               = Expr
e
  parSubst Name -> Expr
phi (Case Expr
e Maybe Expr
mt [Clause]
cls)       = Expr -> Maybe Expr -> [Clause] -> Expr
Case ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
e) ((Name -> Expr) -> Maybe Expr -> Maybe Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Maybe Expr
mt) ((Name -> Expr) -> [Clause] -> [Clause]
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi [Clause]
cls)
  parSubst Name -> Expr
phi (LLet LBind
ta Telescope
tel Expr
b Expr
c)     = LBind -> Telescope -> Expr -> Expr -> Expr
LLet ((Name -> Expr) -> LBind -> LBind
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi LBind
ta) ((Name -> Expr) -> Telescope -> Telescope
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Telescope
tel) ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
b) ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
c)
  parSubst Name -> Expr
phi (Pair Expr
f Expr
e)            = Expr -> Expr -> Expr
Pair ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
f) ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
e)
  parSubst Name -> Expr
phi (App Expr
f Expr
e)             = Expr -> Expr -> Expr
App ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
f) ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
e)
  parSubst Name -> Expr
phi (Record RecInfo
ri [(Name, Expr)]
rs)        = RecInfo -> [(Name, Expr)] -> Expr
Record RecInfo
ri ((Expr -> Expr) -> [(Name, Expr)] -> [(Name, Expr)]
forall a b n. (a -> b) -> [(n, a)] -> [(n, b)]
mapAssoc ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi) [(Name, Expr)]
rs)
  parSubst Name -> Expr
phi (Max [Expr]
es)              = [Expr] -> Expr
Max ((Name -> Expr) -> [Expr] -> [Expr]
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi [Expr]
es)
  parSubst Name -> Expr
phi (Plus [Expr]
es)             = [Expr] -> Expr
Plus ((Name -> Expr) -> [Expr] -> [Expr]
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi [Expr]
es)
  parSubst Name -> Expr
phi (Lam Dec
dec Name
x Expr
e)         = Dec -> Name -> Expr -> Expr
Lam Dec
dec Name
x ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
e)
  parSubst Name -> Expr
phi (Below LtLe
ltle Expr
e)        = LtLe -> Expr -> Expr
Below LtLe
ltle ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
e)
  parSubst Name -> Expr
phi (Quant PiSigma
pisig TBind
a Expr
b)     = PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
pisig ((Name -> Expr) -> TBind -> TBind
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi TBind
a) ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
b)
--  parSubst phi (Quant pisig tel a b) = Quant pisig (parSubst phi tel) (parSubst phi a) (parSubst phi b)
  parSubst Name -> Expr
phi (Sing Expr
a Expr
b)            = Expr -> Expr -> Expr
Sing ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
a) ((Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
b)
  parSubst Name -> Expr
phi (Ann Tagged Expr
e)               = Tagged Expr -> Expr
Ann (Tagged Expr -> Expr) -> Tagged Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Tagged Expr -> Tagged Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Tagged Expr
e
  parSubst Name -> Expr
_   Expr
e                     = String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
"Abstract.parSubst phi (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") undefined"
  {- NOT NEEDED
  sgSubst :: Name -> Expr -> Expr -> Expr
  sgSubst x t u = parSubst (\ y -> if x == y then t else Var y) u
  -}


-- | Metavariable substitution. (BY INTENTION NOT CAPTURE AVOIDING!)
--   Does not substitute in patterns!
class Substitute a where
  subst :: Subst -> a -> a

instance Substitute a => Substitute [a] where
  subst :: Subst -> [a] -> [a]
subst = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> [a] -> [a])
-> (Subst -> a -> a) -> Subst -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst

instance Substitute a => Substitute (Maybe a) where
  subst :: Subst -> Maybe a -> Maybe a
subst = (a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Maybe a -> Maybe a)
-> (Subst -> a -> a) -> Subst -> Maybe a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst

instance Substitute a => Substitute (Dom a) where
  subst :: Subst -> Dom a -> Dom a
subst = (a -> a) -> Dom a -> Dom a
forall a b. (a -> b) -> Dom a -> Dom b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Dom a -> Dom a)
-> (Subst -> a -> a) -> Subst -> Dom a -> Dom a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst

instance Substitute a => Substitute (Measure a) where
  subst :: Subst -> Measure a -> Measure a
subst = (a -> a) -> Measure a -> Measure a
forall a b. (a -> b) -> Measure a -> Measure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Measure a -> Measure a)
-> (Subst -> a -> a) -> Subst -> Measure a -> Measure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst

instance Substitute a => Substitute (Bound a) where
  subst :: Subst -> Bound a -> Bound a
subst = (a -> a) -> Bound a -> Bound a
forall a b. (a -> b) -> Bound a -> Bound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Bound a -> Bound a)
-> (Subst -> a -> a) -> Subst -> Bound a -> Bound a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst

instance Substitute a => Substitute (Tagged a) where
  subst :: Subst -> Tagged a -> Tagged a
subst = (a -> a) -> Tagged a -> Tagged a
forall a b. (a -> b) -> Tagged a -> Tagged b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Tagged a -> Tagged a)
-> (Subst -> a -> a) -> Subst -> Tagged a -> Tagged a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst

instance Substitute a => Substitute (TBinding a) where
  subst :: Subst -> TBinding a -> TBinding a
subst Subst
phi (TBind Name
x Dom a
a)  = Name -> Dom a -> TBinding a
forall a. Name -> Dom a -> TBinding a
TBind Name
x  (Dom a -> TBinding a) -> Dom a -> TBinding a
forall a b. (a -> b) -> a -> b
$ Subst -> Dom a -> Dom a
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Dom a
a
  subst Subst
phi (TMeasure Measure Expr
m) = Measure Expr -> TBinding a
forall a. Measure Expr -> TBinding a
TMeasure (Measure Expr -> TBinding a) -> Measure Expr -> TBinding a
forall a b. (a -> b) -> a -> b
$ Subst -> Measure Expr -> Measure Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Measure Expr
m
  subst Subst
phi (TBound Bound Expr
b)   = Bound Expr -> TBinding a
forall a. Bound Expr -> TBinding a
TBound   (Bound Expr -> TBinding a) -> Bound Expr -> TBinding a
forall a b. (a -> b) -> a -> b
$ Subst -> Bound Expr -> Bound Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Bound Expr
b

instance Substitute a => Substitute (Sort a) where
  subst :: Subst -> Sort a -> Sort a
subst Subst
phi (CoSet a
e) = a -> Sort a
forall a. a -> Sort a
CoSet (a -> Sort a) -> a -> Sort a
forall a b. (a -> b) -> a -> b
$ Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst Subst
phi a
e
  subst Subst
phi (Set a
e)   = a -> Sort a
forall a. a -> Sort a
Set   (a -> Sort a) -> a -> Sort a
forall a b. (a -> b) -> a -> b
$ Subst -> a -> a
forall a. Substitute a => Subst -> a -> a
subst Subst
phi a
e
  subst Subst
_   Sort a
s         = Sort a
s

instance Substitute Telescope where
  subst :: Subst -> Telescope -> Telescope
subst Subst
phi = [TBind] -> Telescope
Telescope ([TBind] -> Telescope)
-> (Telescope -> [TBind]) -> Telescope -> Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> [TBind] -> [TBind]
forall a. Substitute a => Subst -> a -> a
subst Subst
phi ([TBind] -> [TBind])
-> (Telescope -> [TBind]) -> Telescope -> [TBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> [TBind]
telescope

instance Substitute Clause where
  subst :: Subst -> Clause -> Clause
subst Subst
phi (Clause TeleVal
tel [Pattern]
ps Maybe Expr
e) = TeleVal -> [Pattern] -> Maybe Expr -> Clause
Clause TeleVal
tel [Pattern]
ps (Maybe Expr -> Clause) -> Maybe Expr -> Clause
forall a b. (a -> b) -> a -> b
$ Subst -> Maybe Expr -> Maybe Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Maybe Expr
e

instance Substitute Expr where
  subst :: Subst -> Expr -> Expr
subst Subst
phi (Sort Sort Expr
s)              = Sort Expr -> Expr
Sort (Sort Expr -> Expr) -> Sort Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Subst -> Sort Expr -> Sort Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Sort Expr
s
  subst Subst
phi (Succ Expr
e)              = Expr -> Expr
Succ (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
e)
  subst Subst
_   e :: Expr
e@Expr
Zero                = Expr
e
  subst Subst
_   e :: Expr
e@Expr
Infty               = Expr
e
  subst Subst
phi e :: Expr
e@(Meta Int
i)            = Expr -> Int -> Subst -> Expr
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Expr
e Int
i Subst
phi
  subst Subst
_   e :: Expr
e@Var{}               = Expr
e
  subst Subst
_   e :: Expr
e@Def{}               = Expr
e
  subst Subst
_   e :: Expr
e@Proj{}              = Expr
e
  subst Subst
phi (Case Expr
e Maybe Expr
mt [Clause]
cls)       = Expr -> Maybe Expr -> [Clause] -> Expr
Case (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
e) (Subst -> Maybe Expr -> Maybe Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Maybe Expr
mt) (Subst -> [Clause] -> [Clause]
forall a. Substitute a => Subst -> a -> a
subst Subst
phi [Clause]
cls)
  subst Subst
phi (LLet LBind
ta Telescope
tel Expr
b Expr
c)     = LBind -> Telescope -> Expr -> Expr -> Expr
LLet (Subst -> LBind -> LBind
forall a. Substitute a => Subst -> a -> a
subst Subst
phi LBind
ta) (Subst -> Telescope -> Telescope
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Telescope
tel) (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
b) (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
c)
  subst Subst
phi (Pair Expr
f Expr
e)            = Expr -> Expr -> Expr
Pair (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
f) (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
e)
  subst Subst
phi (App Expr
f Expr
e)             = Expr -> Expr -> Expr
App (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
f) (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
e)
  subst Subst
phi (Record RecInfo
ri [(Name, Expr)]
rs)        = RecInfo -> [(Name, Expr)] -> Expr
Record RecInfo
ri ((Expr -> Expr) -> [(Name, Expr)] -> [(Name, Expr)]
forall a b n. (a -> b) -> [(n, a)] -> [(n, b)]
mapAssoc (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi) [(Name, Expr)]
rs)
  subst Subst
phi (Max [Expr]
es)              = [Expr] -> Expr
Max (Subst -> [Expr] -> [Expr]
forall a. Substitute a => Subst -> a -> a
subst Subst
phi [Expr]
es)
  subst Subst
phi (Plus [Expr]
es)             = [Expr] -> Expr
Plus (Subst -> [Expr] -> [Expr]
forall a. Substitute a => Subst -> a -> a
subst Subst
phi [Expr]
es)
  subst Subst
phi (Lam Dec
dec Name
x Expr
e)         = Dec -> Name -> Expr -> Expr
Lam Dec
dec Name
x (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
e)
  subst Subst
phi (Below LtLe
ltle Expr
e)        = LtLe -> Expr -> Expr
Below LtLe
ltle (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
e)
  subst Subst
phi (Quant PiSigma
pisig TBind
a Expr
b)     = PiSigma -> TBind -> Expr -> Expr
Quant PiSigma
pisig (Subst -> TBind -> TBind
forall a. Substitute a => Subst -> a -> a
subst Subst
phi TBind
a) (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
b)
--  subst phi (Quant pisig tel a b) = Quant pisig (subst phi tel) (subst phi a) (subst phi b)
  subst Subst
phi (Sing Expr
a Expr
b)            = Expr -> Expr -> Expr
Sing (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
a) (Subst -> Expr -> Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Expr
b)
  subst Subst
phi (Ann Tagged Expr
e)               = Tagged Expr -> Expr
Ann (Tagged Expr -> Expr) -> Tagged Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Subst -> Tagged Expr -> Tagged Expr
forall a. Substitute a => Subst -> a -> a
subst Subst
phi Tagged Expr
e
  subst Subst
_   Expr
e                     = String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
"Abstract.subst phi (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") undefined"

-- Printing declarations ---------------------------------------------

{-
instance Show Declaration where
  show = render . pretty

instance Pretty Declaration
  pretty (DataD
-}

-- pretty print a function body
prettyFun :: Name -> [Clause] -> Doc
prettyFun :: Name -> [Clause] -> Doc
prettyFun Name
f [Clause]
cls = [Doc] -> Doc
vlist ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Clause -> Doc) -> [Clause] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (Name -> Clause -> Doc
forall a. Pretty a => a -> Clause -> Doc
prettyClause Name
f) [Clause]
cls

prettyClause :: Pretty a => a -> Clause -> Doc
prettyClause :: forall a. Pretty a => a -> Clause -> Doc
prettyClause a
f (Clause TeleVal
_ [Pattern]
ps Maybe Expr
Nothing) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
f Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Pattern -> Doc) -> [Pattern] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR) [Pattern]
ps)
prettyClause a
f (Clause TeleVal
_ [Pattern]
ps (Just Expr
e)) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
f
  Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Pattern -> Doc) -> [Pattern] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
List.map (Int -> Pattern -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
precAppR) [Pattern]
ps)
  Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
e

-- Constructor analysis ----------------------------------------------

data FieldClass
  = Index                    -- ^ E.g., the length in Vector.
  | NotErasableIndex         -- ^ E.g., @c : (index : A) -> D (f index)@
  | Field (Maybe Destructor) -- ^ An actual field, not free in the target.
    deriving (FieldClass -> FieldClass -> Bool
(FieldClass -> FieldClass -> Bool)
-> (FieldClass -> FieldClass -> Bool) -> Eq FieldClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldClass -> FieldClass -> Bool
== :: FieldClass -> FieldClass -> Bool
$c/= :: FieldClass -> FieldClass -> Bool
/= :: FieldClass -> FieldClass -> Bool
Eq, Int -> FieldClass -> ShowS
[FieldClass] -> ShowS
FieldClass -> String
(Int -> FieldClass -> ShowS)
-> (FieldClass -> String)
-> ([FieldClass] -> ShowS)
-> Show FieldClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldClass -> ShowS
showsPrec :: Int -> FieldClass -> ShowS
$cshow :: FieldClass -> String
show :: FieldClass -> String
$cshowList :: [FieldClass] -> ShowS
showList :: [FieldClass] -> ShowS
Show)

type Destructor = (Type, Arity, Clause)

data FieldInfo = FieldInfo
  { FieldInfo -> Dec
fDec   :: Dec
  , FieldInfo -> Name
fName  :: Name        -- ^ Empty "" for anonymous fields.
  , FieldInfo -> Expr
fType  :: Type        -- ^ Naked type (no preceeding telescope).
--  , fLazy  :: Bool        -- lazy (coinductive occ) or strict (everything else) -- see TCM.hs ConSig
  , FieldInfo -> FieldClass
fClass :: FieldClass
  }

instance Show FieldInfo where
  show :: FieldInfo -> String
show (FieldInfo Dec
dec Name
name Expr
t FieldClass
fcl) =
    (if FieldClass
fcl FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
== FieldClass
Index then String
"index " else String
"field ") String -> ShowS
forall a. [a] -> [a] -> [a]
++
    Bool -> ShowS
bracketsIf (Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased Dec
dec) (Name -> String
forall a. Show a => a -> String
show Name
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " -- ++ (if lazy then "?" else "")
                                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
t)

data PatternsType
  = NotPatterns        -- at least "pattern" is none
  | LinearPatterns     -- the patterns do not share a common var
  | NonLinearPatterns  -- the patterns share a common var
    deriving (PatternsType -> PatternsType -> Bool
(PatternsType -> PatternsType -> Bool)
-> (PatternsType -> PatternsType -> Bool) -> Eq PatternsType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PatternsType -> PatternsType -> Bool
== :: PatternsType -> PatternsType -> Bool
$c/= :: PatternsType -> PatternsType -> Bool
/= :: PatternsType -> PatternsType -> Bool
Eq, Eq PatternsType
Eq PatternsType =>
(PatternsType -> PatternsType -> Ordering)
-> (PatternsType -> PatternsType -> Bool)
-> (PatternsType -> PatternsType -> Bool)
-> (PatternsType -> PatternsType -> Bool)
-> (PatternsType -> PatternsType -> Bool)
-> (PatternsType -> PatternsType -> PatternsType)
-> (PatternsType -> PatternsType -> PatternsType)
-> Ord PatternsType
PatternsType -> PatternsType -> Bool
PatternsType -> PatternsType -> Ordering
PatternsType -> PatternsType -> PatternsType
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
$ccompare :: PatternsType -> PatternsType -> Ordering
compare :: PatternsType -> PatternsType -> Ordering
$c< :: PatternsType -> PatternsType -> Bool
< :: PatternsType -> PatternsType -> Bool
$c<= :: PatternsType -> PatternsType -> Bool
<= :: PatternsType -> PatternsType -> Bool
$c> :: PatternsType -> PatternsType -> Bool
> :: PatternsType -> PatternsType -> Bool
$c>= :: PatternsType -> PatternsType -> Bool
>= :: PatternsType -> PatternsType -> Bool
$cmax :: PatternsType -> PatternsType -> PatternsType
max :: PatternsType -> PatternsType -> PatternsType
$cmin :: PatternsType -> PatternsType -> PatternsType
min :: PatternsType -> PatternsType -> PatternsType
Ord, Int -> PatternsType -> ShowS
[PatternsType] -> ShowS
PatternsType -> String
(Int -> PatternsType -> ShowS)
-> (PatternsType -> String)
-> ([PatternsType] -> ShowS)
-> Show PatternsType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PatternsType -> ShowS
showsPrec :: Int -> PatternsType -> ShowS
$cshow :: PatternsType -> String
show :: PatternsType -> String
$cshowList :: [PatternsType] -> ShowS
showList :: [PatternsType] -> ShowS
Show)

data ConstructorInfo = ConstructorInfo
  { ConstructorInfo -> QName
cName   :: QName
--  , cType   :: TVal
  , ConstructorInfo -> ParamPats
cPars   :: ParamPats  -- ^ Constructor parameters if unequal to data parameters.
  , ConstructorInfo -> [FieldInfo]
cFields :: [FieldInfo]
  , ConstructorInfo -> Expr
cTyCore :: Type
  , ConstructorInfo -> (PatternsType, [Pattern])
cPatFam :: (PatternsType, [Pattern])
  , ConstructorInfo -> Bool
cEtaExp :: Bool -- all destructors are defined, family pattern is non-overlapping with family patterns of other constructors
  , ConstructorInfo -> Bool
cRec    :: Bool -- constructor has recursive fields
  } deriving Int -> ConstructorInfo -> ShowS
[ConstructorInfo] -> ShowS
ConstructorInfo -> String
(Int -> ConstructorInfo -> ShowS)
-> (ConstructorInfo -> String)
-> ([ConstructorInfo] -> ShowS)
-> Show ConstructorInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstructorInfo -> ShowS
showsPrec :: Int -> ConstructorInfo -> ShowS
$cshow :: ConstructorInfo -> String
show :: ConstructorInfo -> String
$cshowList :: [ConstructorInfo] -> ShowS
showList :: [ConstructorInfo] -> ShowS
Show

corePat :: ConstructorInfo -> [Pattern]
corePat :: ConstructorInfo -> [Pattern]
corePat = (PatternsType, [Pattern]) -> [Pattern]
forall a b. (a, b) -> b
snd ((PatternsType, [Pattern]) -> [Pattern])
-> (ConstructorInfo -> (PatternsType, [Pattern]))
-> ConstructorInfo
-> [Pattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> (PatternsType, [Pattern])
cPatFam

{- Old comment:
a record type is a data type that fulfills 3 conditions
   1. non-recursive
   2. exactly 1 constructor
   3. constructor carries names for each of its arguments

Non-indexed case: generate destructors

  data Sigma (A : Set) (B : A -> Set) : Set
  { pair : (fst : A) -> (snd : B fst) -> Sigma A B
  }
  fst : [A : Set] -> [B : A -> Set] -> (p : Sigma A B) -> A
  { fst A B (pair _fst _snd) = _fst }
  snd : [A : Set] -> [B : A -> Set] -> (p : Sigma A B) -> B (fst p)
  { snd A B (pair _fst _snd) = _snd }

-}
{- Indexed case: For the constructor

  vcons : (n : Nat) -> (head : A) -> (tail : Vec A n) -> Vec A (suc n)

cName   = "vcons"
-- cType   = evaluation of (A : Set) -> (n : Nat) -> ...
cFields = [("n",Nat,Index),("head",A,Field),("tail",Vec A n,Field)]
cTyCore = Vec A (suc n)
cPatFam = (True, [A, suc n])
cEtaExp = True, but may be set to False later since the constructor is recursive

We generate the destructors

  head : (A : Set) -> (n : Nat) -> (x : Vec A (suc n)) -> A
  head A n (vcons .n _head _tail) = _head

  tail : (A : Set) -> (n : Nat) -> (x : Vec A (suc n)) -> Vec A n
  tail A n (vcons .n _head _tail) = _tail

in the implementation we use "constructed_by_head" for "x"

discriminate index arguments from fields
  - split constructor type into telescope and core
    [(n : Nat),(head : A),(tail : Vec A n)], Vec A (suc n)
  - find free variables of core: [A,n]
  - create a list of (name,type,classification) for each constructor arg,
    where classification in {index,field}

-}

-- TODO: analyze value, not expression!
-- get all the variables which are under injective functions

class InjectiveVars a where
  injectiveVars :: a -> Set Name

instance InjectiveVars a => InjectiveVars [a] where
  injectiveVars :: [a] -> Set Name
injectiveVars = (a -> Set Name) -> [a] -> Set Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance InjectiveVars a => InjectiveVars (Maybe a) where
  injectiveVars :: Maybe a -> Set Name
injectiveVars = (a -> Set Name) -> Maybe a -> Set Name
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance InjectiveVars a => InjectiveVars (Sort a) where
  injectiveVars :: Sort a -> Set Name
injectiveVars = (a -> Set Name) -> Sort a -> Set Name
forall m a. Monoid m => (a -> m) -> Sort a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance InjectiveVars a => InjectiveVars (Dom a) where
  injectiveVars :: Dom a -> Set Name
injectiveVars = (a -> Set Name) -> Dom a -> Set Name
forall m a. Monoid m => (a -> m) -> Dom a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance InjectiveVars a => InjectiveVars (Measure a) where
  injectiveVars :: Measure a -> Set Name
injectiveVars = (a -> Set Name) -> Measure a -> Set Name
forall m a. Monoid m => (a -> m) -> Measure a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance InjectiveVars a => InjectiveVars (Bound a) where
  injectiveVars :: Bound a -> Set Name
injectiveVars = (a -> Set Name) -> Bound a -> Set Name
forall m a. Monoid m => (a -> m) -> Bound a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance InjectiveVars a => InjectiveVars (Tagged a) where
  injectiveVars :: Tagged a -> Set Name
injectiveVars = (a -> Set Name) -> Tagged a -> Set Name
forall m a. Monoid m => (a -> m) -> Tagged a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars

instance (InjectiveVars a, InjectiveVars b) => InjectiveVars (a, b) where
  injectiveVars :: (a, b) -> Set Name
injectiveVars (a
a, b
b) = [Set Name] -> Set Name
forall a. Monoid a => [a] -> a
mconcat [a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars a
a, b -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars b
b]

instance (InjectiveVars a, InjectiveVars b, InjectiveVars c) => InjectiveVars (a, b, c) where
  injectiveVars :: (a, b, c) -> Set Name
injectiveVars (a
a, b
b, c
c) = [Set Name] -> Set Name
forall a. Monoid a => [a] -> a
mconcat [a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars a
a, b -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars b
b, c -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars c
c]

instance InjectiveVars a => InjectiveVars (TBinding a) where
  injectiveVars :: TBinding a -> Set Name
injectiveVars (TBind Name
_ Dom a
a)  = Dom a -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Dom a
a
  injectiveVars (TMeasure Measure Expr
m) = Measure Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Measure Expr
m
  injectiveVars (TBound Bound Expr
b)   = Bound Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Bound Expr
b

instance InjectiveVars Telescope where
  injectiveVars :: Telescope -> Set Name
injectiveVars (Telescope []) = Set Name
forall a. Monoid a => a
mempty
  injectiveVars (Telescope (TBind
tb : [TBind]
tel)) = TBind -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars TBind
tb Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                          (Telescope -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars ([TBind] -> Telescope
Telescope [TBind]
tel) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ TBind -> Set Name
forall c. Collection c Name => TBind -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars TBind
tb)

instance InjectiveVars Expr where
  injectiveVars :: Expr -> Set Name
injectiveVars Expr
e =
   case Expr -> SpineView
spineView Expr
e of
    (Var Name
name            , []) -> Name -> Set Name
forall a. a -> Set a
Set.singleton Name
name
    (Def (DefId DatK{} QName
_), [Expr]
es) -> [Expr] -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars [Expr]
es
    (Def (DefId ConK{} QName
_), [Expr]
es) -> [Expr] -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars [Expr]
es
    (Record RecInfo
_ri [(Name, Expr)]
rs       , []) -> [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ ((Name, Expr) -> Set Name) -> [(Name, Expr)] -> [Set Name]
forall a b. (a -> b) -> [a] -> [b]
List.map (Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars (Expr -> Set Name)
-> ((Name, Expr) -> Expr) -> (Name, Expr) -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Expr) -> Expr
forall a b. (a, b) -> b
snd) [(Name, Expr)]
rs
    (Succ Expr
e              , []) -> Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Expr
e
    (Lam Dec
_ Name
x Expr
e           , []) -> Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.delete Name
x (Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Expr
e)
    (Quant PiSigma
_ TBind
ta Expr
b , []) -> TBind -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars TBind
ta Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Expr
b Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ TBind -> Set Name
forall c. Collection c Name => TBind -> c
forall a c. (BoundVars a, Collection c Name) => a -> c
boundVars TBind
ta)
--     (Quant _ tel ta b , []) ->
--       injectiveVars tel' `Set.union` (injectiveVars b Set.\\ boundVars tel')
--         where tel' = Telescope $ telescope tel ++ [ta]
--     (Sort s             , []) -> injectiveVars s
    (Ann Tagged Expr
e              , []) -> Tagged Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Tagged Expr
e
    SpineView
_                         -> Set Name
forall a. Set a
Set.empty

classifyFields :: Co -> Name -> Type -> [FieldInfo]
classifyFields :: Co -> Name -> Expr -> [FieldInfo]
classifyFields Co
_co Name
_19dataName Expr
ty = (TBind -> FieldInfo) -> [TBind] -> [FieldInfo]
forall a b. (a -> b) -> [a] -> [b]
List.map (Set Name -> TBind -> FieldInfo
classifyField Set Name
fvs) ([TBind] -> [FieldInfo]) -> [TBind] -> [FieldInfo]
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
tele
  where (Telescope
tele, Expr
core) = Expr -> (Telescope, Expr)
typeToTele Expr
ty
        fvs :: Set Name
fvs = Expr -> Set Name
forall a. FreeVars a => a -> Set Name
freeVars Expr
core
        ivs :: Set Name
ivs = Expr -> Set Name
forall a. InjectiveVars a => a -> Set Name
injectiveVars Expr
core
        classifyField :: Set Name -> TBind -> FieldInfo
classifyField Set Name
fvs (TBind Name
name (Domain Expr
ty Kind
_ki Dec
dec)) = FieldInfo
          { fDec :: Dec
fDec = Dec
dec
          , fName :: Name
fName  = Name
name
          , fType :: Expr
fType  = Expr
ty
--          , fLazy  = co == CoInd && maybeRecursiveOccurrence dataName ty
          , fClass :: FieldClass
fClass = if Name
name Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
fvs then
                       if Name
name Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
ivs then FieldClass
Index else FieldClass
NotErasableIndex
                      else Maybe Destructor -> FieldClass
Field Maybe Destructor
forall a. Maybe a
Nothing
          }

isField :: FieldClass -> Bool
isField :: FieldClass -> Bool
isField Field{} = Bool
True
isField FieldClass
_       = Bool
False

isNamedField :: FieldInfo -> Bool
isNamedField :: FieldInfo -> Bool
isNamedField FieldInfo
f = FieldClass -> Bool
isField (FieldInfo -> FieldClass
fClass FieldInfo
f) Bool -> Bool -> Bool
&& Bool -> Bool
not (Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (Dec -> Bool) -> Dec -> Bool
forall a b. (a -> b) -> a -> b
$ FieldInfo -> Dec
fDec FieldInfo
f) Bool -> Bool -> Bool
&& Bool -> Bool
not (Name -> Bool
emptyName (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ FieldInfo -> Name
fName FieldInfo
f)

destructorNames :: [FieldInfo] -> [Name]
destructorNames :: [FieldInfo] -> [Name]
destructorNames [FieldInfo]
fields = (FieldInfo -> Name) -> [FieldInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
List.map FieldInfo -> Name
fName ([FieldInfo] -> [Name]) -> [FieldInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$ (FieldInfo -> Bool) -> [FieldInfo] -> [FieldInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter FieldInfo -> Bool
isNamedField [FieldInfo]
fields

analyzeConstructor :: Co -> Name -> Telescope -> Constructor -> ConstructorInfo
analyzeConstructor :: Co -> Name -> Telescope -> Constructor -> ConstructorInfo
analyzeConstructor Co
co Name
dataName Telescope
dataPars (Constructor QName
constrName ParamPats
conPars Expr
ty) =
  let (Telescope
_, Expr
core)  = Expr -> (Telescope, Expr)
typeToTele Expr
ty
      pars :: Telescope
pars       = Telescope
-> ((Telescope, [Pattern]) -> Telescope) -> ParamPats -> Telescope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Telescope
dataPars (Telescope, [Pattern]) -> Telescope
forall a b. (a, b) -> a
fst ParamPats
conPars
      fields :: [FieldInfo]
fields     = Co -> Name -> Expr -> [FieldInfo]
classifyFields Co
co Name
dataName Expr
ty
      -- freshenFieldName fi = fi { fName = freshen $ fName fi }
      -- freshfields = List.map freshenFieldName fields
      -- generate destructors
      -- choose a name for the record to destroy
      indices :: [FieldInfo]
indices    = (FieldInfo -> Bool) -> [FieldInfo] -> [FieldInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ FieldInfo
f -> FieldInfo -> FieldClass
fClass FieldInfo
f FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
== FieldClass
Index) [FieldInfo]
fields
      indexTele :: Telescope
indexTele  = [TBind] -> Telescope
Telescope ([TBind] -> Telescope) -> [TBind] -> Telescope
forall a b. (a -> b) -> a -> b
$ (FieldInfo -> TBind) -> [FieldInfo] -> [TBind]
forall a b. (a -> b) -> [a] -> [b]
List.map (\ FieldInfo
f -> Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind (FieldInfo -> Name
fName FieldInfo
f) (Dom Expr -> TBind) -> Dom Expr -> TBind
forall a b. (a -> b) -> a -> b
$ Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain (FieldInfo -> Expr
fType FieldInfo
f) Kind
defaultKind (FieldInfo -> Dec
fDec FieldInfo
f)) [FieldInfo]
indices
      indexNames :: [Name]
indexNames  = (FieldInfo -> Name) -> [FieldInfo] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
List.map FieldInfo -> Name
fName [FieldInfo]
indices
      -- do not generated destructors for erased arguments
      destrNames :: [Name]
destrNames = [FieldInfo] -> [Name]
destructorNames [FieldInfo]
fields
      recName :: Name
recName    = Name -> Name
internal (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ QName -> Name
name QName
constrName -- "constructed_by_" ++ constrName
      parNames :: [Name]
parNames   = (TBind -> Name) -> [TBind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
List.map TBind -> Name
forall a. TBinding a -> Name
boundName ([TBind] -> [Name]) -> [TBind] -> [Name]
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
pars
      parAndIndexNames :: [Name]
parAndIndexNames = [Name]
parNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
indexNames
      -- substitute variable "fst" by application "fst A B p"
      phi :: Name -> Expr
phi Name
x = if Name
x Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
destrNames
                then (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl Expr -> Expr -> Expr
App ({-fun x-} Name -> Expr
letdef Name
x) ((Name -> Expr) -> [Name] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
List.map Name -> Expr
Var ([Name]
parAndIndexNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
recName]))
                else Name -> Expr
Var Name
x
      -- prefix d =  "destructor_argument_" ++ d
      prefix :: Name -> Name
prefix Name
d = Name
d { suggestion = "#" ++ suggestion d }
      -- modifiedDestrNames = List.map prefix destrNames
      -- TODO: Index arguments are not always before fields
      pattern :: Pattern
pattern = PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP (ConK -> Bool -> Bool -> PatternInfo
PatternInfo (Co -> ConK
coToConK Co
co) Bool
False Bool
False) -- to bootstrap destructor, not irrefutable
          QName
constrName
          ( -- 2012-01-22 PARS GONE!   List.map (DotP . Var) parNames ++
            (FieldInfo -> Pattern) -> [FieldInfo] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
List.map (\ FieldInfo
fi -> (case FieldInfo -> FieldClass
fClass FieldInfo
fi of
                            FieldClass
Index   -> Expr -> Pattern
forall e. e -> Pat e
DotP (Expr -> Pattern) -> (Name -> Expr) -> Name -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Expr
Var
                            Field{} -> Name -> Pattern
forall e. Name -> Pat e
VarP (Name -> Pattern) -> (Name -> Name) -> Name -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
prefix)
                         (FieldInfo -> Name
fName FieldInfo
fi))
              [FieldInfo]
fields)
      destrType :: Expr -> Expr
destrType Expr
t = -- teleToTypeErase (pars ++ indexTele)
                    Telescope -> Expr -> Expr
teleToTypeErase Telescope
pars (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> Expr -> Expr
teleToType Telescope
indexTele (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$
                      TBind -> Expr -> Expr
pi (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind Name
recName (Dom Expr -> TBind) -> Dom Expr -> TBind
forall a b. (a -> b) -> a -> b
$ Expr -> Dom Expr
forall a. a -> Dom a
defaultDomain Expr
core) (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ (Name -> Expr) -> Expr -> Expr
forall a. ParSubst a => (Name -> Expr) -> a -> a
parSubst Name -> Expr
phi Expr
t
      destrBody :: Name -> Clause
destrBody (Name
dn) = [Pattern] -> Maybe Expr -> Clause
clause ((Name -> Pattern) -> [Name] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
List.map Name -> Pattern
forall e. Name -> Pat e
VarP [Name]
parAndIndexNames [Pattern] -> [Pattern] -> [Pattern]
forall a. [a] -> [a] -> [a]
++ [Pattern
pattern]) (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Name -> Expr
Var Name
dn))
      fields' :: [FieldInfo]
fields' = [FieldInfo] -> (FieldInfo -> FieldInfo) -> [FieldInfo]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
mapOver [FieldInfo]
fields ((FieldInfo -> FieldInfo) -> [FieldInfo])
-> (FieldInfo -> FieldInfo) -> [FieldInfo]
forall a b. (a -> b) -> a -> b
$
        \ FieldInfo
f -> if FieldInfo -> Bool
isNamedField FieldInfo
f then
                  FieldInfo
f { fClass = Field $ Just
                         ( destrType (fType f)
                         , let npars = Telescope -> Int
forall a. Size a => a -> Int
size Telescope
pars
                           in  Arity { fullArity = npars + size indexTele + 1
                                     , isProjection = Just npars
                                     }
                         , destrBody (prefix (fName f)) )}
                else FieldInfo
f
      computeLinearity :: (Bool, [Pattern]) -> (PatternsType, [Pattern])
      computeLinearity :: (Bool, [Pattern]) -> (PatternsType, [Pattern])
computeLinearity (Bool
False, [Pattern]
ps) = (PatternsType
NotPatterns, [Pattern]
ps)
      computeLinearity (Bool
True , [Pattern]
ps) = (if Bool
linear then PatternsType
LinearPatterns else PatternsType
NonLinearPatterns, [Pattern]
ps) where
        linear :: Bool
linear = [Pattern] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [Pattern]
ps Bool -> Bool -> Bool
|| ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null ([Name] -> Bool) -> [Name] -> Bool
forall a b. (a -> b) -> a -> b
$ ([Name] -> [Name] -> [Name]) -> [[Name]] -> [Name]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldl1 [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.intersect ([[Name]] -> [Name]) -> [[Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Pattern -> [Name]) -> [Pattern] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
List.map Pattern -> [Name]
patternVars [Pattern]
ps)

      result :: ConstructorInfo
result = ConstructorInfo
       { cName :: QName
cName   = QName
constrName
       , cPars :: ParamPats
cPars   = ParamPats
conPars
       , cFields :: [FieldInfo]
cFields = [FieldInfo]
fields'
       , cTyCore :: Expr
cTyCore = Expr
core
       -- check whether core is D ps and store pats; also compute whether ps are linear
       , cPatFam :: (PatternsType, [Pattern])
cPatFam = (Bool, [Pattern]) -> (PatternsType, [Pattern])
computeLinearity ((Bool, [Pattern]) -> (PatternsType, [Pattern]))
-> (Bool, [Pattern]) -> (PatternsType, [Pattern])
forall a b. (a -> b) -> a -> b
$ Writer All [Pattern] -> (Bool, [Pattern])
forall a. Writer All a -> (Bool, a)
fromAllWriter (Writer All [Pattern] -> (Bool, [Pattern]))
-> Writer All [Pattern] -> (Bool, [Pattern])
forall a b. (a -> b) -> a -> b
$ Expr -> Writer All [Pattern]
isPatIndFamC Expr
core
       , cEtaExp :: Bool
cEtaExp = [FieldInfo] -> Bool
destructorNamesPresent [FieldInfo]
fields
       , cRec :: Bool
cRec    = Bool
True  -- we don't know here, assume the worst
       }
   in -- trace ("analyzeConstructor returns " ++ show result) $
        ConstructorInfo
result

-- can only eta expand if I can generate all destructors
destructorNamesPresent :: [FieldInfo] -> Bool
destructorNamesPresent :: [FieldInfo] -> Bool
destructorNamesPresent [FieldInfo]
fields =
  (FieldInfo -> Bool) -> [FieldInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ FieldInfo
f -> FieldInfo -> FieldClass
fClass FieldInfo
f FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
/= FieldClass
NotErasableIndex Bool -> Bool -> Bool
&&  -- no bad index
              (FieldInfo -> FieldClass
fClass FieldInfo
f FieldClass -> FieldClass -> Bool
forall a. Eq a => a -> a -> Bool
== FieldClass
Index Bool -> Bool -> Bool
||
               Bool -> Bool
not (Dec -> Bool
forall pol. Polarity pol => pol -> Bool
erased (Dec -> Bool) -> Dec -> Bool
forall a b. (a -> b) -> a -> b
$ FieldInfo -> Dec
fDec FieldInfo
f) Bool -> Bool -> Bool
&& Bool -> Bool
not (Name -> Bool
emptyName (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ FieldInfo -> Name
fName FieldInfo
f))) -- no erased or unnamed field
    [FieldInfo]
fields

-- | Analyze all constructors of a data type at once
--   so that we can also check which constructors patterns are irrefutable.
analyzeConstructors :: Co -> Name -> Telescope -> [Constructor] -> [ConstructorInfo]
analyzeConstructors :: Co -> Name -> Telescope -> [Constructor] -> [ConstructorInfo]
analyzeConstructors Co
co Name
dataName Telescope
pars [Constructor]
cs =
  let cis :: [ConstructorInfo]
cis = (Constructor -> ConstructorInfo)
-> [Constructor] -> [ConstructorInfo]
forall a b. (a -> b) -> [a] -> [b]
List.map (Co -> Name -> Telescope -> Constructor -> ConstructorInfo
analyzeConstructor Co
co Name
dataName Telescope
pars) [Constructor]
cs
      -- check if patterns overlaps with any other
      overlapList :: [Bool]
overlapList = (ConstructorInfo -> Int -> Bool)
-> [ConstructorInfo] -> [Int] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ ConstructorInfo
ci Int
n -> ([Pattern] -> Bool) -> [[Pattern]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Pattern] -> [Pattern] -> Bool
overlaps (ConstructorInfo -> [Pattern]
corePat ConstructorInfo
ci)) ([[Pattern]] -> Bool) -> [[Pattern]] -> Bool
forall a b. (a -> b) -> a -> b
$ (ConstructorInfo -> [Pattern]) -> [ConstructorInfo] -> [[Pattern]]
forall a b. (a -> b) -> [a] -> [b]
List.map ConstructorInfo -> [Pattern]
corePat ([ConstructorInfo] -> [[Pattern]])
-> [ConstructorInfo] -> [[Pattern]]
forall a b. (a -> b) -> a -> b
$ Int -> [ConstructorInfo] -> [ConstructorInfo]
forall a. Int -> [a] -> [a]
take Int
n [ConstructorInfo]
cis [ConstructorInfo] -> [ConstructorInfo] -> [ConstructorInfo]
forall a. [a] -> [a] -> [a]
++ Int -> [ConstructorInfo] -> [ConstructorInfo]
forall a. Int -> [a] -> [a]
drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [ConstructorInfo]
cis) [ConstructorInfo]
cis [Int
0..] -- worst case quadratic, could be improved by exploiting symmetry
      result :: [ConstructorInfo]
result = (ConstructorInfo -> Bool -> ConstructorInfo)
-> [ConstructorInfo] -> [Bool] -> [ConstructorInfo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ ConstructorInfo
ci Bool
ov -> if Bool
ov then ConstructorInfo
ci { cEtaExp = False } else ConstructorInfo
ci) [ConstructorInfo]
cis [Bool]
overlapList
  in [ConstructorInfo]
result

-- | Build constructor type from constructor info, erasing all indices.
reassembleConstructor :: ConstructorInfo -> Constructor
reassembleConstructor :: ConstructorInfo -> Constructor
reassembleConstructor ConstructorInfo
ci = QName -> ParamPats -> Expr -> Constructor
Constructor (ConstructorInfo -> QName
cName ConstructorInfo
ci) (ConstructorInfo -> ParamPats
cPars ConstructorInfo
ci) (ConstructorInfo -> Expr
reassembleConstructorType ConstructorInfo
ci)

-- | Assumes that all the indices (even from data telescope) are contained
--   in fields.
reassembleConstructorType :: ConstructorInfo -> Type
reassembleConstructorType :: ConstructorInfo -> Expr
reassembleConstructorType ConstructorInfo
ci = [FieldInfo] -> Expr
buildPi (ConstructorInfo -> [FieldInfo]
cFields ConstructorInfo
ci) where
  buildPi :: [FieldInfo] -> Expr
buildPi [] = ConstructorInfo -> Expr
cTyCore ConstructorInfo
ci
  buildPi (FieldInfo
f:[FieldInfo]
fs) = TBind -> Expr -> Expr
pi (Name -> Dom Expr -> TBind
forall a. Name -> Dom a -> TBinding a
TBind (FieldInfo -> Name
fName FieldInfo
f) (Dom Expr -> TBind) -> Dom Expr -> TBind
forall a b. (a -> b) -> a -> b
$ Expr -> Kind -> Dec -> Dom Expr
forall a. a -> Kind -> Dec -> Dom a
Domain (FieldInfo -> Expr
fType FieldInfo
f) Kind
defaultKind (Dec -> FieldClass -> Dec
decor (FieldInfo -> Dec
fDec FieldInfo
f) (FieldInfo -> FieldClass
fClass FieldInfo
f))) (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ [FieldInfo] -> Expr
buildPi [FieldInfo]
fs
    where decor :: Dec -> FieldClass -> Dec
decor Dec
_   FieldClass
Index = Dec
irrelevantDec -- DONE: SWITCH ON!
          decor Dec
dec FieldClass
_     = Dec
dec

-- Pattern inductive families ----------------------------------------

-- isPatIndFam takes a list of type signatures (constructor decls.)
-- and checks whether we have a pattern inductive family
-- in this case, a list of constructors with the associated
-- type indices (translated into pattern list) is returned
-- type parameters are dropped
{-
isPatIndFam :: Int -> [Constructor] -> Maybe [(Name,[Pattern])]
isPatIndFam numPars= mapM (\ tysig ->
                             fmap (\ ps -> (namePart tysig, drop numPars ps))
                                  (isPatIndFamC (typePart tysig)))
-}

-- isPatIndFamC checks whether an expression (the type of s constructor)
-- is of the form
--   Gamma -> D ps
-- and returns the list ps of patterns if it is the case
isPatIndFamC :: Expr -> Writer All [Pattern]
isPatIndFamC :: Expr -> Writer All [Pattern]
isPatIndFamC (Def DefId
_) = [Pattern] -> Writer All [Pattern]
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
isPatIndFamC (App Expr
f Expr
e) = do
  ps <- Expr -> Writer All [Pattern]
isPatIndFamC Expr
f
  p  <- exprToDotPat' e
  return $ ps ++ [p]
-- isPatIndFamC (App e es) = do
--   ps  <- isPatIndFamC e
--   ps' <- mapM exprToDotPat' es
--   return $ ps ++ ps'
isPatIndFamC (Quant PiSigma
Pi TBind
_ Expr
e) = Expr -> Writer All [Pattern]
isPatIndFamC Expr
e
isPatIndFamC Expr
_ = All -> WriterT All Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All Bool
False) WriterT All Identity ()
-> Writer All [Pattern] -> Writer All [Pattern]
forall a b.
WriterT All Identity a
-> WriterT All Identity b -> WriterT All Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Pattern] -> Writer All [Pattern]
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Pattern auxiliary functions ---------------------------------------

-- extract all subpatterns of the form y > x and arrange them in a
-- TreeShapedOrder
tsoFromPatterns :: [Pattern] -> TSO Name
tsoFromPatterns :: [Pattern] -> TSO Name
tsoFromPatterns [Pattern]
ps = [(Name, (Int, Name))] -> TSO Name
forall a. (Ord a, Eq a) => [(a, (Int, a))] -> TSO a
TSO.fromList ([(Name, (Int, Name))] -> TSO Name)
-> [(Name, (Int, Name))] -> TSO Name
forall a b. (a -> b) -> a -> b
$ [[(Name, (Int, Name))]] -> [(Name, (Int, Name))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat ([[(Name, (Int, Name))]] -> [(Name, (Int, Name))])
-> [[(Name, (Int, Name))]] -> [(Name, (Int, Name))]
forall a b. (a -> b) -> a -> b
$ (Pattern -> [(Name, (Int, Name))])
-> [Pattern] -> [[(Name, (Int, Name))]]
forall a b. (a -> b) -> [a] -> [b]
List.map Pattern -> [(Name, (Int, Name))]
forall {a}. Num a => Pattern -> [(Name, (a, Name))]
loop [Pattern]
ps where
  loop :: Pattern -> [(Name, (a, Name))]
loop (SizeP (Var Name
father) Name
son)        = [(Name
son,(a
1,Name
father))]
  loop (SizeP (Succ (Var Name
father)) Name
son) = [(Name
son,(a
0,Name
father))]
  loop (SizeP{})                       = []
  loop (ConP PatternInfo
_ QName
_ [Pattern]
ps)                   = [[(Name, (a, Name))]] -> [(Name, (a, Name))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat ([[(Name, (a, Name))]] -> [(Name, (a, Name))])
-> [[(Name, (a, Name))]] -> [(Name, (a, Name))]
forall a b. (a -> b) -> a -> b
$ (Pattern -> [(Name, (a, Name))])
-> [Pattern] -> [[(Name, (a, Name))]]
forall a b. (a -> b) -> [a] -> [b]
List.map Pattern -> [(Name, (a, Name))]
loop [Pattern]
ps
  loop (PairP Pattern
p Pattern
p')                    = Pattern -> [(Name, (a, Name))]
loop Pattern
p [(Name, (a, Name))] -> [(Name, (a, Name))] -> [(Name, (a, Name))]
forall a. [a] -> [a] -> [a]
++ Pattern -> [(Name, (a, Name))]
loop Pattern
p'
  loop (SuccP   Pattern
p)                     = Pattern -> [(Name, (a, Name))]
loop Pattern
p
  loop (ErasedP Pattern
p)                     = Pattern -> [(Name, (a, Name))]
loop Pattern
p
  loop ProjP{}                         = []
  loop VarP{}                          = []
  loop DotP{}                          = []
  loop UnusableP{}                     = []

-- for non-dot patterns, patterns overlap if one matches against the other
-- infinity size is represented as (DotP Infty)
-- I reprogram it here, since it does not need a monad
overlap :: Pattern -> Pattern -> Bool
overlap :: Pattern -> Pattern -> Bool
overlap (VarP Name
_) Pattern
_ = Bool
True
overlap Pattern
_ (VarP Name
_) = Bool
True
overlap (ConP PatternInfo
_ QName
c [Pattern]
ps) (ConP PatternInfo
_ QName
c' [Pattern]
ps') = QName
c QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
c' Bool -> Bool -> Bool
&& [Pattern] -> [Pattern] -> Bool
overlaps [Pattern]
ps [Pattern]
ps' -- only source of non-overlap
overlap (PairP Pattern
p1 Pattern
p2) (PairP Pattern
p1' Pattern
p2') = [Pattern] -> [Pattern] -> Bool
overlaps [Pattern
p1,Pattern
p2] [Pattern
p1',Pattern
p2']
overlap (ProjP Name
n) (ProjP Name
n') = Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' -- another source of non-overlap
-- size patterns always overlap
overlap (SuccP Pattern
_) Pattern
_ = Bool
True
overlap Pattern
_ (SuccP Pattern
_) = Bool
True
overlap SizeP{} Pattern
_   = Bool
True
overlap Pattern
_ SizeP{}   = Bool
True
-- dot patterns always overlap (safe approximation)
overlap (DotP Expr
_) Pattern
_ = Bool
True
overlap Pattern
_ (DotP Expr
_) = Bool
True
{-
overlap (SuccP p) (SuccP p') = overlap p p'
overlap (SuccP p) (DotP Infty) = overlap p (DotP Infty)
overlap (DotP Infty) (SuccP p') = overlap (DotP Infty) p'
overlap (DotP Infty) (DotP Infty) = True
-}

overlaps :: [Pattern] -> [Pattern] -> Bool
overlaps :: [Pattern] -> [Pattern] -> Bool
overlaps [Pattern]
ps [Pattern]
ps' = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Pattern -> Pattern -> Bool) -> [Pattern] -> [Pattern] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern -> Pattern -> Bool
overlap [Pattern]
ps [Pattern]
ps'

-- | @exprToPattern@ is used in the termination checker to convert
--   dot patterns into proper patterns.
exprToPattern :: Expr -> Maybe Pattern
exprToPattern :: Expr -> Maybe Pattern
exprToPattern (Def (DefId (ConK ConK
co) QName
n)) = Pattern -> Maybe Pattern
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
pi QName
n []
  where pi :: PatternInfo
pi = ConK -> Bool -> Bool -> PatternInfo
PatternInfo ConK
co Bool
False Bool
False -- not irrefutable (TODO: good enough?)
exprToPattern (Var Name
n)       = Pattern -> Maybe Pattern
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Name -> Pattern
forall e. Name -> Pat e
VarP Name
n
exprToPattern (Pair Expr
e Expr
e')   = Pattern -> Pattern -> Pattern
forall e. Pat e -> Pat e -> Pat e
PairP (Pattern -> Pattern -> Pattern)
-> Maybe Pattern -> Maybe (Pattern -> Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Pattern
exprToPattern Expr
e Maybe (Pattern -> Pattern) -> Maybe Pattern -> Maybe Pattern
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Maybe Pattern
exprToPattern Expr
e'
exprToPattern (Succ Expr
e)      = Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP (Pattern -> Pattern) -> Maybe Pattern -> Maybe Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe Pattern
exprToPattern Expr
e
exprToPattern (Proj PrePost
Post Name
n) = Pattern -> Maybe Pattern
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Name -> Pattern
forall e. Name -> Pat e
ProjP Name
n
exprToPattern (App Expr
f Expr
e)     = Pattern -> Pattern -> Maybe Pattern
patApp (Pattern -> Pattern -> Maybe Pattern)
-> (Maybe Pattern, Maybe Pattern) -> Maybe Pattern
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> (m a, m b) -> m c
==<< (Expr -> Maybe Pattern
exprToPattern Expr
f, Expr -> Maybe Pattern
exprToPattern Expr
e)
-- exprToPattern (Infty)    = return $ DotP Infty -- leads to non-term in compareExpr
exprToPattern Expr
_ = String -> Maybe Pattern
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"exprToPattern"

-- | Only constructor patterns can be applied to a pattern.
patApp :: Pattern -> Pattern -> Maybe Pattern
patApp :: Pattern -> Pattern -> Maybe Pattern
patApp (ConP PatternInfo
co QName
n [Pattern]
ps) Pattern
p = Pattern -> Maybe Pattern
forall a. a -> Maybe a
Just (Pattern -> Maybe Pattern) -> Pattern -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
co QName
n ([Pattern]
ps [Pattern] -> [Pattern] -> [Pattern]
forall a. [a] -> [a] -> [a]
++ [Pattern
p])
patApp Pattern
_              Pattern
_ = Maybe Pattern
forall a. Maybe a
Nothing

-- | @exprToDotPat@ turns an expression into a pattern.
-- The @Bool@ is @True@ if the pattern is proper, i.e., does not contain
-- @DotP@ except @DotP Infty@.
exprToDotPat :: Expr -> (Bool, Pattern)
exprToDotPat :: Expr -> (Bool, Pattern)
exprToDotPat = Writer All Pattern -> (Bool, Pattern)
forall a. Writer All a -> (Bool, a)
fromAllWriter (Writer All Pattern -> (Bool, Pattern))
-> (Expr -> Writer All Pattern) -> Expr -> (Bool, Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Writer All Pattern
exprToDotPat'

exprToDotPat' :: Expr -> Writer All Pattern
exprToDotPat' :: Expr -> Writer All Pattern
exprToDotPat' Expr
e = do
  let fallback :: m Pattern
fallback = All -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All Bool
False) m () -> m Pattern -> m Pattern
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pattern -> m Pattern
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Pattern
forall e. e -> Pat e
DotP Expr
e)
  case Expr
e of
    Def (DefId (ConK ConK
co) QName
n) -> Pattern -> Writer All Pattern
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Writer All Pattern) -> Pattern -> Writer All Pattern
forall a b. (a -> b) -> a -> b
$ PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
pi QName
n [] where
      pi :: PatternInfo
pi = ConK -> Bool -> Bool -> PatternInfo
PatternInfo ConK
co Bool
False Bool
False -- not irrefutable (TODO: good enough?)
    Proj PrePost
Post Name
n -> Pattern -> Writer All Pattern
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Writer All Pattern) -> Pattern -> Writer All Pattern
forall a b. (a -> b) -> a -> b
$ Name -> Pattern
forall e. Name -> Pat e
ProjP Name
n
    Var Name
n       -> Pattern -> Writer All Pattern
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Writer All Pattern) -> Pattern -> Writer All Pattern
forall a b. (a -> b) -> a -> b
$ Name -> Pattern
forall e. Name -> Pat e
VarP Name
n
    Pair Expr
e Expr
e'   -> Pattern -> Pattern -> Pattern
forall e. Pat e -> Pat e -> Pat e
PairP (Pattern -> Pattern -> Pattern)
-> Writer All Pattern -> WriterT All Identity (Pattern -> Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Writer All Pattern
exprToDotPat' Expr
e WriterT All Identity (Pattern -> Pattern)
-> Writer All Pattern -> Writer All Pattern
forall a b.
WriterT All Identity (a -> b)
-> WriterT All Identity a -> WriterT All Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Writer All Pattern
exprToDotPat' Expr
e'
    Expr
Infty       -> Pattern -> Writer All Pattern
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Writer All Pattern) -> Pattern -> Writer All Pattern
forall a b. (a -> b) -> a -> b
$ Expr -> Pattern
forall e. e -> Pat e
DotP Expr
Infty
    Succ Expr
e      -> Pattern -> Pattern
forall e. Pat e -> Pat e
SuccP (Pattern -> Pattern) -> Writer All Pattern -> Writer All Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Writer All Pattern
exprToDotPat' Expr
e
    App Expr
f Expr
e     -> Writer All Pattern
-> (Pattern -> Writer All Pattern)
-> Maybe Pattern
-> Writer All Pattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Writer All Pattern
forall {m :: * -> *}. MonadWriter All m => m Pattern
fallback Pattern -> Writer All Pattern
forall a. a -> WriterT All Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pattern -> Writer All Pattern)
-> WriterT All Identity (Maybe Pattern) -> Writer All Pattern
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      Pattern -> Pattern -> Maybe Pattern
patApp (Pattern -> Pattern -> Maybe Pattern)
-> Writer All Pattern
-> WriterT All Identity (Pattern -> Maybe Pattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Writer All Pattern
exprToDotPat' Expr
f WriterT All Identity (Pattern -> Maybe Pattern)
-> Writer All Pattern -> WriterT All Identity (Maybe Pattern)
forall a b.
WriterT All Identity (a -> b)
-> WriterT All Identity a -> WriterT All Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Writer All Pattern
exprToDotPat' Expr
e
{-
    (App f e') -> do
      pf <- exprToDotPat' f
      case pf of
         (ConP co c ps) -> do pe <- exprToDotPat' e'
                              return $ ConP co c (ps ++ [pe])
         _ -> fallback
-}
    Expr
_ -> Writer All Pattern
forall {m :: * -> *}. MonadWriter All m => m Pattern
fallback

patternToExpr :: Pattern -> Expr
patternToExpr :: Pattern -> Expr
patternToExpr (VarP Name
n)       = Name -> Expr
Var Name
n
patternToExpr (SizeP Expr
_m Name
n)   = Name -> Expr
Var Name
n
patternToExpr (ConP PatternInfo
pi QName
n [Pattern]
ps) = (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl Expr -> Expr -> Expr
App (ConK -> QName -> Expr
con (PatternInfo -> ConK
coPat PatternInfo
pi) QName
n) ((Pattern -> Expr) -> [Pattern] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
List.map Pattern -> Expr
patternToExpr [Pattern]
ps)
-- patternToExpr (ConP co n ps) = Con co n `App` (List.map patternToExpr ps)
patternToExpr (PairP Pattern
p Pattern
p')   = Expr -> Expr -> Expr
Pair (Pattern -> Expr
patternToExpr Pattern
p) (Pattern -> Expr
patternToExpr Pattern
p')
patternToExpr (SuccP Pattern
p)      = Expr -> Expr
Succ (Pattern -> Expr
patternToExpr Pattern
p)
patternToExpr (UnusableP Pattern
p)  = Pattern -> Expr
patternToExpr Pattern
p
patternToExpr (ProjP Name
n)      = PrePost -> Name -> Expr
Proj PrePost
Post Name
n
patternToExpr (DotP Expr
e)       = Expr
e -- cannot put Irr here because introPatType wants to compute the value of a dot pattern (after all bindings have been introduced)
patternToExpr (ErasedP Pattern
p)    = Expr -> Expr
erasedExpr (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr
patternToExpr Pattern
p
patternToExpr (Pattern
AbsurdP)      = Expr
Irr

-- | Dot all constructor subpatterns.  Used when expanding a dotted patsyn.
dotConstructors :: Pattern -> Pattern
dotConstructors :: Pattern -> Pattern
dotConstructors Pattern
p =
  case Pattern
p of
    ConP PatternInfo
pi QName
c [Pattern]
ps -> PatternInfo -> QName -> [Pattern] -> Pattern
forall e. PatternInfo -> QName -> [Pat e] -> Pat e
ConP PatternInfo
pi{ dottedPat = True } QName
c ([Pattern] -> Pattern) -> [Pattern] -> Pattern
forall a b. (a -> b) -> a -> b
$ (Pattern -> Pattern) -> [Pattern] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
List.map Pattern -> Pattern
dotConstructors [Pattern]
ps
    PairP Pattern
p1 Pattern
p2  -> Pattern -> Pattern -> Pattern
forall e. Pat e -> Pat e -> Pat e
PairP (Pattern -> Pattern
dotConstructors Pattern
p1) (Pattern -> Pattern
dotConstructors Pattern
p2)
    Pattern
_            -> Pattern
p

-- admissible pattern ------------------------------------------------

-- completeP is used in admPattern, should not be True for UnusableP
completeP :: Pattern -> Bool
completeP :: Pattern -> Bool
completeP (DotP Expr
_) = Bool
True
completeP (VarP Name
_) = Bool
True
completeP SizeP{}  = Bool
False -- True
completeP (UnusableP Pattern
p) = Pattern -> Bool
completeP Pattern
p
completeP (ErasedP Pattern
p)   = Pattern -> Bool
completeP Pattern
p
completeP Pattern
_ = Bool
False

isDotPattern :: Pattern -> Bool
isDotPattern :: Pattern -> Bool
isDotPattern (DotP Expr
_ ) = Bool
True
isDotPattern Pattern
_ = Bool
False

-- isSuccessorPattern is used in admPattern, should not be True for UnusableP
isSuccessorPattern :: Pattern -> Bool
isSuccessorPattern :: Pattern -> Bool
isSuccessorPattern (SuccP Pattern
_)   = Bool
True
isSuccessorPattern (DotP Expr
e)    = Expr -> Bool
isSuccessor Expr
e
isSuccessorPattern (ErasedP Pattern
p) = Pattern -> Bool
isSuccessorPattern Pattern
p
isSuccessorPattern Pattern
_ = Bool
False

isSuccessor :: Expr -> Bool
isSuccessor :: Expr -> Bool
isSuccessor (Ann Tagged Expr
e)  = Expr -> Bool
isSuccessor (Tagged Expr -> Expr
forall a. Tagged a -> a
unTag Tagged Expr
e)
isSuccessor (Succ Expr
_) = Bool
True
isSuccessor Expr
_        = Bool
False

shallowSuccP :: Pattern -> Bool
shallowSuccP :: Pattern -> Bool
shallowSuccP = \case
     (SuccP Pattern
p)   -> Pattern -> Bool
isVarP Pattern
p
     (ErasedP Pattern
p) -> Pattern -> Bool
shallowSuccP Pattern
p
     (DotP Expr
e)    -> Expr -> Bool
shallowSuccE Expr
e
     Pattern
_           -> Bool
False

   where isVarP :: Pattern -> Bool
isVarP (VarP Name
_)         = Bool
True
         isVarP (DotP Expr
e)         = Expr -> Bool
isVarE Expr
e
         isVarP (ErasedP Pattern
p)      = Pattern -> Bool
isVarP Pattern
p
         isVarP Pattern
_                = Bool
False

         isVarE :: Expr -> Bool
isVarE (Ann Tagged Expr
e)          = Expr -> Bool
isVarE (Tagged Expr -> Expr
forall a. Tagged a -> a
unTag Tagged Expr
e)
         isVarE (Var Name
_)          = Bool
True
         isVarE Expr
_                = Bool
False

         shallowSuccE :: Expr -> Bool
shallowSuccE (Ann Tagged Expr
e)    = Expr -> Bool
shallowSuccE (Tagged Expr -> Expr
forall a. Tagged a -> a
unTag Tagged Expr
e)
         shallowSuccE (Succ Expr
e)   = Expr -> Bool
isVarE Expr
e
         shallowSuccE Expr
_          = Bool
False

-- telescopes --------------------------------------------------------

---- construction

-- | typeToTele ((x : A) -> (y : B) -> C) = ([(x,A),(y,B)], C)
typeToTele :: Type -> (Telescope, Type)
typeToTele :: Expr -> (Telescope, Expr)
typeToTele = Int -> Expr -> (Telescope, Expr)
typeToTele' (-Int
1) -- take all Pis into the telescope

-- | @typeToTele' k t@.
--   If @k > 0@ it takes at most @k@ leading @Pi@s into the telescope
--   STALE: (hidden bindings do not count).
typeToTele' :: Int -> Type -> (Telescope, Type)
typeToTele' :: Int -> Expr -> (Telescope, Expr)
typeToTele' Int
k Expr
t = ([TBind] -> Telescope) -> ([TBind], Expr) -> (Telescope, Expr)
forall b c d. (b -> c) -> (b, d) -> (c, d)
mapFst [TBind] -> Telescope
Telescope (([TBind], Expr) -> (Telescope, Expr))
-> ([TBind], Expr) -> (Telescope, Expr)
forall a b. (a -> b) -> a -> b
$ Int -> Expr -> [TBind] -> ([TBind], Expr)
ttt Int
k Expr
t []
    where
      ttt :: Int -> Type -> [TBind] -> ([TBind], Type)
--      ttt k (Quant Pi htel tb t2) tel | k /= 0 = ttt (k-1) t2 (telescope htel ++ tb : tel)
      ttt :: Int -> Expr -> [TBind] -> ([TBind], Expr)
ttt Int
k (Quant PiSigma
Pi TBind
tb Expr
t2) [TBind]
tel | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int -> Expr -> [TBind] -> ([TBind], Expr)
ttt (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Expr
t2 (TBind
tb TBind -> [TBind] -> [TBind]
forall a. a -> [a] -> [a]
: [TBind]
tel)
      ttt Int
_ Expr
t [TBind]
tel = ([TBind] -> [TBind]
forall a. [a] -> [a]
reverse [TBind]
tel, Expr
t)

---- modification

instance LensDec Telescope where
  getDec :: Telescope -> Dec
getDec   = String -> Telescope -> Dec
forall a. HasCallStack => String -> a
error String
"getDec not defined for Telescope"
  mapDec :: (Dec -> Dec) -> Telescope -> Telescope
mapDec Dec -> Dec
f = [TBind] -> Telescope
Telescope ([TBind] -> Telescope)
-> (Telescope -> [TBind]) -> Telescope -> Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TBind -> TBind) -> [TBind] -> [TBind]
forall a b. (a -> b) -> [a] -> [b]
List.map ((Dec -> Dec) -> TBind -> TBind
forall a. LensDec a => (Dec -> Dec) -> a -> a
mapDec Dec -> Dec
f) ([TBind] -> [TBind])
-> (Telescope -> [TBind]) -> Telescope -> [TBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> [TBind]
telescope

---- destruction

teleLam :: Telescope -> Expr -> Expr
teleLam :: Telescope -> Expr -> Expr
teleLam Telescope
tel Expr
e = ((Dec, Name) -> Expr -> Expr) -> Expr -> [(Dec, Name)] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Dec -> Name -> Expr -> Expr) -> (Dec, Name) -> Expr -> Expr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dec -> Name -> Expr -> Expr
Lam) Expr
e ([(Dec, Name)] -> Expr) -> [(Dec, Name)] -> Expr
forall a b. (a -> b) -> a -> b
$
  (TBind -> (Dec, Name)) -> [TBind] -> [(Dec, Name)]
forall a b. (a -> b) -> [a] -> [b]
List.map (\ TBind
tb -> (Dom Expr -> Dec
forall a. Dom a -> Dec
decor (Dom Expr -> Dec) -> Dom Expr -> Dec
forall a b. (a -> b) -> a -> b
$ TBind -> Dom Expr
forall a. TBinding a -> Dom a
boundDom TBind
tb, TBind -> Name
forall a. TBinding a -> Name
boundName TBind
tb)) ([TBind] -> [(Dec, Name)]) -> [TBind] -> [(Dec, Name)]
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
tel

teleToType' :: (Dec -> Dec) -> Telescope -> Type -> Type
teleToType' :: (Dec -> Dec) -> Telescope -> Expr -> Expr
teleToType' Dec -> Dec
mod Telescope
tel Expr
t = (TBind -> Expr -> Expr) -> Expr -> [TBind] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ TBind
tb -> TBind -> Expr -> Expr
pi ((Dec -> Dec) -> TBind -> TBind
forall a. LensDec a => (Dec -> Dec) -> a -> a
mapDec Dec -> Dec
mod TBind
tb)) Expr
t ([TBind] -> Expr) -> [TBind] -> Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
tel
{-
teleToType' mod []       t = t
teleToType' mod (tb:tel) t = Pi (mapDec mod tb) (teleToType' mod tel t)
-}

teleToType :: Telescope -> Type -> Type
teleToType :: Telescope -> Expr -> Expr
teleToType = (Dec -> Dec) -> Telescope -> Expr -> Expr
teleToType' Dec -> Dec
forall a. a -> a
id

teleToTypeErase :: Telescope -> Type -> Type
teleToTypeErase :: Telescope -> Expr -> Expr
teleToTypeErase = (Dec -> Dec) -> Telescope -> Expr -> Expr
teleToType' Dec -> Dec
forall pol. Polarity pol => pol -> pol
demote -- (\ dec -> dec { erased = True })

adjustTopDecs :: (Dec -> Dec) -> Type -> Type
adjustTopDecs :: (Dec -> Dec) -> Expr -> Expr
adjustTopDecs Dec -> Dec
f Expr
t = (Dec -> Dec) -> Telescope -> Expr -> Expr
teleToType' Dec -> Dec
f Telescope
tel Expr
core where
  (Telescope
tel, Expr
core) = Expr -> (Telescope, Expr)
typeToTele Expr
t

teleToTypeM :: (Applicative m) => (Dec -> m Dec) -> Telescope -> Type -> m Type
teleToTypeM :: forall (m :: * -> *).
Applicative m =>
(Dec -> m Dec) -> Telescope -> Expr -> m Expr
teleToTypeM Dec -> m Dec
mod Telescope
tel Expr
t =
  (TBind -> m Expr -> m Expr) -> m Expr -> [TBind] -> m Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ TBind
tb m Expr
mt -> TBind -> Expr -> Expr
pi (TBind -> Expr -> Expr) -> m TBind -> m (Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> m Dec) -> TBind -> m TBind
forall (m :: * -> *).
Applicative m =>
(Dec -> m Dec) -> TBind -> m TBind
mapDecM Dec -> m Dec
mod TBind
tb m (Expr -> Expr) -> m Expr -> m Expr
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Expr
mt) (Expr -> m Expr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
t) ([TBind] -> m Expr) -> [TBind] -> m Expr
forall a b. (a -> b) -> a -> b
$ Telescope -> [TBind]
telescope Telescope
tel

adjustTopDecsM :: (Applicative m) => (Dec -> m Dec) -> Type -> m Type
adjustTopDecsM :: forall (m :: * -> *).
Applicative m =>
(Dec -> m Dec) -> Expr -> m Expr
adjustTopDecsM Dec -> m Dec
f Expr
t = (Dec -> m Dec) -> Telescope -> Expr -> m Expr
forall (m :: * -> *).
Applicative m =>
(Dec -> m Dec) -> Telescope -> Expr -> m Expr
teleToTypeM Dec -> m Dec
f Telescope
tel Expr
core where
  (Telescope
tel, Expr
core) = Expr -> (Telescope, Expr)
typeToTele Expr
t


{- How to translate a clause with patterns into one that does irrefutable
   matching on records

f (zero, (x, (y, z))) true (x', false) = rhs

 translates to

f (zero, xyz) true (x', false) rhs'  where rhs = subst
  [ fst xyz       / x,
    fst (snd xyz) / y,
    snd (snd xyz) / z,
    x' / x'
  ] rhs'

We walk through the patterns from left to right, to get the de Bruijn indices
for the pattern variables (dot patterns also have a de Bruijn index).

  Gamma, pi, n |- x --> Gamma(pi(n)), n+1, [n/n]

  Gamma, pi, n |- .t --> infer

If we return from a record pattern whose components were all irrefutable, we
apply a substitution to Telescope


-}