packages feed

MiniAgda 0.2014.9.12 → 0.2016.12.19

raw patch · 64 files changed

+23956/−16429 lines, 64 filesdep ~basedep ~haskell-src-exts

Dependency ranges changed: base, haskell-src-exts

Files

− Abstract.hs 
@@ -1,2213 +0,0 @@--- 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 NoImplicitPrelude #-}--module Abstract where--import Prelude hiding (showList, map, concat, foldl, pi, null)--import Control.Applicative hiding (empty)-import Control.Monad.Writer (Writer, tell, All(..))-import Control.Monad.Trans--import Data.Monoid hiding ((<>))-import Data.Foldable (Foldable, foldMap)-import qualified Data.Foldable as Foldable-import Data.Traversable as Traversable-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 (Eq, Ord, Show)--data Name = Name-  { suggestion :: String    -- ^ suggestion for printing the name.-  , what       :: WhatName-  , uid        :: Unique -- !Unique-  }---- | Names are compared according to their UID.-instance Eq Name where-  x == x' = uid x == uid x'--instance Ord Name where-  compare x x' = compare (uid x) (uid x')--instance Show Name where-  show (Name n _ u) = 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 n = Name n UserName $ unsafePerformIO newUnique-{-# NOINLINE fresh #-}--freshen :: Name -> Name-freshen n = fresh (suggestion n)---- | A non-unique empty name.  Use only inconstant functions!-noName :: Name-noName = fresh ""---- | Check whether name is @""@.-emptyName :: Name -> Bool-emptyName n = null (suggestion n)--nonEmptyName :: Name -> String -> Name-nonEmptyName n s | emptyName n = n { suggestion = s }-                 | otherwise   = n---- | Get the first non-empty name from a non-empty list of names.-bestName :: [Name] -> Name-bestName [n]    = n-bestName (n:ns)-  | emptyName n = bestName ns-  | otherwise   = n---- temporary hack for reification--iAmNotUnique :: Unique-iAmNotUnique = unsafePerformIO newUnique-{-# NOINLINE iAmNotUnique #-}--unsafeName :: String -> Name-unsafeName s = Name s QuoteName iAmNotUnique---- | External reference to recursive function (outside of the body).-mkExtName :: Name -> Name-mkExtName n = Name (suggestion n) EtaAliasName $ unsafePerformIO newUnique--- mkExtName n = "_" ++ n-{-# NOINLINE mkExtName #-}--mkExtRef  n = letdef (mkExtName n)--isEtaAlias :: Name -> Bool-isEtaAlias n = what n == EtaAliasName---- | Internal name for compiler-generated stuff.-internal :: Name -> Name-internal n = freshen 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 = List.map (\ c -> if c==' ' then '_' else c)-{--exprToName e = spaceToUnderscore $ show e-patToName p  = spaceToUnderscore $ show p--}---- | Qualified name.-data QName-  = Qual  { qual :: Name, name :: Name }-  | QName { name :: Name }-  deriving (Eq, Ord)--instance Show QName where-  show (Qual m n) = show m ++ "." ++ show n-  show (QName n)  = show n---- | An unqualified name is an instance of a qualified name.-nameInstanceOf (QName n) (Qual _ n') = n == n'-nameInstanceOf n         n'          = n == n'---- | Fails if qualified name.-unqual (QName n) = n-unqual n         = error $ "Abstract.unqual: " ++ show n--data Sized = Sized | NotSized-             deriving (Eq,Ord,Show)--data Co = Ind-        | CoInd-          deriving (Eq,Ord,Show)--showFun :: Co -> String-showFun Ind   = "fun"-showFun CoInd = "cofun"--data LtLe = Lt | Le deriving (Eq,Ord)--instance Show LtLe where-  show Lt = "<"-  show Le = "<="---- decoration of Pi-types ------------------------------------------------ 1. whether argument is irrelevant / its polarity--- further possibilities:--- 2. hidden--data Decoration pos-    = Dec { thePolarity :: pos }-    | Hidden-  deriving (Eq, Ord, Functor, Foldable, Traversable, Show)--polarity :: Polarity pol => Decoration pol -> pol-polarity Hidden    = hidden-polarity (Dec pol) = pol--instance Polarity a => Polarity (Decoration a) where-  erased        = erased . polarity-  compose  p p' = Dec $ compose (polarity p) (polarity p')-  neutral       = Dec neutral-  promote       = Dec . promote . polarity-  demote        = Dec . demote . polarity-  hidden        = Hidden--type Dec = Decoration Pol-type UDec = Decoration PProd--class LensPol a where-  getPol :: a -> Pol-  setPol :: Pol -> a -> a-  setPol = mapPol . const-  mapPol :: (Pol -> Pol) -> a -> a-  mapPol f a = setPol (f (getPol a)) a--instance LensPol Dec where-  getPol = polarity-  setPol p Hidden = Hidden-  setPol p dec    = dec { thePolarity = p }--udec :: Dec -> UDec-udec = fmap pprod--irrelevantDec = Dec Pol.Const-paramDec = Dec Param-defaultDec = Dec defaultPol--- defaultDec = paramDec -- TODO: Dec { polarity = Rec }-defaultUpperDec = Dec $ pprod 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 SPos--coDomainDec :: Dec -> Dec-coDomainDec Hidden = Dec Param -- REDUNDANT-coDomainDec dec-    | polarity dec == Pol.Const = Dec Param-    | otherwise                 = Dec Rec---- compDec dec dec'--- composition of decoration, used when type checking arguments--- of functions decorated with dec-compDec :: Dec -> UDec -> UDec-compDec dec udec = compose (fmap pprod dec) udec--{--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 (Succ e) = Just e-  predecessor _ = Nothing--sizeSuccE :: Expr -> Expr-sizeSuccE Infty = Infty-sizeSuccE e     = Succ e--minSizeE :: Expr -> Expr -> Expr-minSizeE Infty e2 = e2-minSizeE e1 Infty = e1-minSizeE Zero  e2 = Zero-minSizeE e1 Zero  = Zero-minSizeE (Succ e1) (Succ e2) = Succ (minSizeE e1 e2)-minSizeE e1 e2 = error $ "minSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2)--maxSizeE :: Expr -> Expr -> Expr-maxSizeE Infty e2 = Infty-maxSizeE e1 Infty = Infty-maxSizeE Zero  e2 = e2-maxSizeE e1 Zero  = e1-maxSizeE (Succ e1) (Succ e2) = Succ (maxSizeE e1 e2)-maxSizeE e1 e2 = Max [e1, e2]--- maxSizeE e1 e2 = error $ "maxSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2)--flattenMax :: Expr -> [Expr] -> [Expr]-flattenMax Infty          acc = [Infty]-flattenMax Zero           acc = acc-flattenMax (Max [])       acc = acc-flattenMax (Max (e : es)) acc = flattenMax e $ flattenMax (Max es) acc-flattenMax e              acc = e : acc---- smart constructor for MAX-maxE :: [Expr] -> Expr-maxE es = Max $ foldr flattenMax [] es--sizeVarsToInfty :: Expr -> Expr-sizeVarsToInfty Zero = Zero-sizeVarsToInfty (Succ e) = sizeSuccE (sizeVarsToInfty e)-sizeVarsToInfty _ = Infty--leqSizeE :: Expr -> Expr -> Bool-leqSizeE Zero e  = True-leqSizeE e Zero  = False-leqSizeE e Infty = True-leqSizeE (Succ e) (Succ e') = leqSizeE e e'-leqSizeE Infty e = False---- plus :: Expr -> Expr -> Expr---- 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 (Eq, Ord, Show)--predClass :: Class -> Class--- predClass Ty    = Tm-predClass TSize = Size-predClass Tm    = Tm-predClass Size  = 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 (Eq, Ord, Functor, Foldable, 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 (SortC c) = show c-  show (Set Zero) = "Set"-  show (CoSet Infty) = "Set"-  show (Set e) = Util.parens $ ("Set " ++ show e)-  show (CoSet e) = Util.parens $ ("CoSet " ++ show e)--topSort :: Sort Expr-topSort = Set Infty---- | The expression representing the type Size.-tSize :: Expr-tSize = Sort (SortC Size)---- | Checking whether an expression represents type Size.-isSize :: Expr -> Bool-isSize (Sort (SortC Size)) = True-isSize (Below Le Infty)    = True-isSize _                   = False--predSort :: Sort Expr -> Sort Expr-predSort (SortC  c)     = SortC (predClass c)-predSort (CoSet  e)     = SortC Tm-predSort (Set Zero)     = SortC Tm-predSort (Set (Succ e)) = Set e-predSort (Set Infty)    = Set Infty-predSort s@(Set Var{})  = s-predSort s = error $ "internal error: predSort " ++ show s---- only for sorts appearing in kinds:--succSort :: Sort Expr -> Sort Expr-succSort (SortC Size) = SortC TSize-succSort (SortC Tm)   = Set Zero-succSort (Set e)      = Set (sizeSuccE e)--minSort :: Sort Expr -> Sort Expr -> Sort Expr-minSort (SortC Tm) (Set e) = SortC Tm-minSort (Set e) (SortC Tm) = SortC Tm-minSort (Set e) (Set e') = Set (minSizeE e e')--- minSort (SortC c) (SortC c') | c == c' = SortC c-minSort (SortC c) (SortC c') = SortC $ minClass c c'-minSort s s' = error $ "minSort (" ++ show s ++ ") (" ++ show s' ++ ") not implemented"---- 2012-01-21: that should not be necessary, but to move on...-minClass :: Class -> Class -> Class-minClass Tm c = Tm-minClass c Tm = Tm-minClass Size c = Size-minClass c Size = Size-minClass TSize TSize = TSize-maxClass :: Class -> Class -> Class--maxClass Tm c = c-maxClass c Tm = c-maxClass Size c = c-maxClass c Size = c-maxClass TSize TSize = TSize--maxSort :: Sort Expr -> Sort Expr -> Sort Expr-maxSort (SortC Tm) (Set e) = Set e-maxSort (Set e) (SortC Tm) = Set e-maxSort (Set e) (Set e') = Set (maxSizeE e e')--- maxSort (SortC c) (SortC c') | c == c' = SortC c-maxSort (SortC c) (SortC c') = SortC $ maxClass c c'-maxSort s s' = error $ "maxSort (" ++ show s ++ ") (" ++ show s' ++ ") 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 compuationally--- contribute to produce a value of kind s'-irrSortFor :: Sort Expr -> Sort Expr -> Bool-irrSortFor (SortC Tm) _          = False -- terms matter for terms and everything-irrSortFor _          (SortC Tm) = True  -- nothing else can be eliminated into a term-irrSortFor (SortC Size) _        = False -- sizes matter for everything but terms-irrSortFor _        (SortC Size) = True  -- nothing else can be eliminated into a size-irrSortFor (SortC TSize) _        = False -- sizes matter for everything but terms-irrSortFor _        (SortC TSize) = True  -- nothing else can be eliminated into a size-irrSortFor (Set e) (Set e')      = not $ leqSizeE e e'---- kinds ----------------------------------------------------------------- kinds classify expressions into terms, types, universes, ...--- since the analysis is not precise, we give an interval of classes--data Kind-  = Kind { lowerKind :: Sort Expr , upperKind :: Sort Expr }-  | NoKind   -- absurd clauses, neutral wrt. union-  | AnyKind  -- not yet classified, neutral wrt. intersection-    deriving (Eq, Ord)----defaultKind = Kind (SortC Tm) topSort -- no classification, could be anything-defaultKind = AnyKind--preciseKind s = Kind s s-kSize   = preciseKind (SortC Size)-kTSize  = preciseKind (SortC TSize)-kTerm   = preciseKind (SortC Tm)-kType   = preciseKind (Set Zero)-kUniv e = preciseKind (Set (Succ (sizeVarsToInfty e))) -- used in TypeChecker--instance Show Kind where-  show NoKind = "()"-  show AnyKind = "?"---  show k | k == defaultKind = "?"-  show (Kind kl ku) | kl == ku = show kl-  show (Kind kl ku) = show kl ++ ".." ++ show ku---- print kind in four letters-prettyKind :: Kind -> String-prettyKind NoKind                       = "none"-prettyKind AnyKind                      = "anyk"--- prettyKind k | k == defaultKind         = "anyk"-prettyKind (Kind _ (SortC Tm))          = "term"-prettyKind (Kind _ (SortC Size))        = "size"-prettyKind k | k == kType               = "type"-prettyKind (Kind (Set (Succ Zero)) _)   = "univ"-prettyKind (Kind (Set Zero) _)          = "ty-u"-prettyKind (Kind (SortC Tm) (Set Zero)) = "tmty"-prettyKind k                            = "mixk"---- if D : T and T has kind ki, then D has kind dataKind ki-dataKind :: Kind -> Kind-dataKind (Kind _ (Set (Succ e))) = Kind (Set Zero) (Set e)---- in (x : A) -> B, if x : A and A has kind ki, then x has kind argKind ki-argKind :: Kind -> Kind-argKind NoKind = NoKind-argKind AnyKind = AnyKind-argKind (Kind s s') = Kind (predSort s) (predSort s')---- if e : A and A has kind ki, then e has kind predKind ki-predKind :: Kind -> Kind-predKind NoKind = NoKind-predKind AnyKind = AnyKind--- predecessors in the kind hierarchy-predKind ki@(Kind _ (SortC Size))  = error $ "predKind " ++ show ki-predKind (Kind _ (SortC TSize)) = kSize--- proper types are only inhabited by terms-predKind (Kind _ (Set Zero)) = kTerm--- proper universes are inhabited by types and universes-predKind (Kind (Set (Succ e)) s) = Kind (Set Zero) (predSort s)--- something which is a type or a universe can be inhabited by a term-predKind (Kind _ s) = Kind (SortC Tm) (predSort s)--succKind :: Kind -> Kind-succKind AnyKind = AnyKind-succKind (Kind _ (SortC Tm)) = kType-succKind (Kind _ (SortC Size)) = kTSize-succKind (Kind s _) = Kind (succSort s) (Set Infty) -- no upper bound---- partial operation!-intersectKind :: Kind -> Kind -> Kind-intersectKind NoKind ki = ki -- NoKind means here "intersection is not happening"-intersectKind ki NoKind = ki-intersectKind AnyKind ki = ki-intersectKind ki AnyKind = ki-intersectKind (Kind x1 x2) (Kind y1 y2) =-  Kind (maxSort x1 y1) (minSort x2 y2)--unionKind :: Kind -> Kind -> Kind-unionKind ki1 ki2 = -- trace (show ki1 ++ " `unionKind` " ++ show ki2) $-  case (ki1,ki2) of-    (NoKind, ki) -> ki-    (ki, NoKind) -> ki-    (AnyKind, ki) -> AnyKind-    (ki, AnyKind) -> AnyKind-    (Kind x1 x2, Kind y1 y2) ->-      Kind (minSort x1 y1) (maxSort x2 y2)---- ki `irrelevantFor` ki' if an argument of kind ki cannot--- computationally contribute to a result of kind ki'-irrelevantFor :: Kind -> Kind -> Bool-irrelevantFor NoKind _ = False -- do not make a statement if there is no info-irrelevantFor _ NoKind = False-irrelevantFor AnyKind _ = False-irrelevantFor _ AnyKind = False-irrelevantFor (Kind s _) (Kind _ s') = irrSortFor s s'--- worst case szenario: the least kind of the argument is still--- irrelevant for the biggest kind of the result--data Kinded a = Kinded { kindOf :: Kind, valueOf :: a }-                deriving (Eq, Ord, Functor, Foldable, Traversable)--instance Show a => Show (Kinded a) where---  show (Kinded ki a) | ki == defaultKind = show a-  show (Kinded ki a) = show a ++ "::" ++ show ki---- function domains ----------------------------------------------------data Dom a = Domain { typ :: a, kind :: Kind, decor :: Dec }-             deriving (Eq, Ord, Functor, Foldable, Traversable)--instance Show a => Show (Dom a) where-    show (Domain ty ki dec) = show dec ++ show ty ++ "::" ++ show ki--defaultDomain a = Domain a defaultKind defaultDec-domFromKinded (Kinded ki t) = Domain t ki defaultDec-defaultIrrDom a = Domain a defaultKind irrelevantDec--sizeDomain :: Dec -> Dom Expr-sizeDomain dec = Domain tSize kTSize dec--belowDomain :: Dec -> LtLe -> Expr -> Dom Expr-belowDomain dec ltle e = Domain (Below ltle e) kTSize dec--class LensDec a where-  getDec :: a -> Dec-  setDec :: Dec -> a -> a-  setDec d = mapDec $ const d-  mapDec :: (Dec -> Dec) -> a -> a-  mapDec f a = setDec (f $ getDec a) a--instance LensDec (Dom a) where-  getDec = decor-  setDec d dom = dom { decor = d }--instance LensPol (Dom a) where-  getPol = getPol . getDec-  mapPol = mapDec . mapPol--{--instance Functor Dom where-  fmap f dom = dom { typ = f (typ dom) }---- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)-instance Traversable Dom where-  traverse f dom = (\ ty -> dom { typ = ty }) <$> f (typ dom)--}---- identifiers ----------------------------------------------------------- |-data ConK-  = Cons    -- ^ a constructor-  | CoCons  -- ^ a coconstructor-  | DefPat  -- ^ a defined pattern-    deriving (Eq, Ord, Show)--data IdKind-  = DatK       -- ^ data/codata-  | ConK ConK  -- ^ constructor (ind/coind/defined)-  | FunK       -- ^ fun/cofun-  | LetK       -- ^ let definition-    deriving (Eq, Ord)--instance Show IdKind where-    show DatK   = "data"-    show ConK{} = "con"-    show FunK   = "fun"-    show LetK   = "let"--conKind (ConK _) = True-conKind _        = False--coToConK Ind = Cons-coToConK CoInd = CoCons--data DefId = DefId { idKind :: IdKind, idName :: QName }-           deriving (Eq, Ord)--instance Show DefId where-    show d = show (idName d) -- ++ "@" ++ show (idKind d)--type MVar = Int -- metavariables are numbered---- typed bindings in Pi, LLet, Telescope -------------------------------data TBinding a = TBind-  { boundName :: Name        -- ^ @emptyName@ if non-dependent.-  , boundDom  :: Dom a       -- ^ @x : T@ or @i < j@.-  }-  | TMeasure (Measure Expr)  -- ^ Measure @|m|@.-  | TBound   (Bound Expr)    -- ^ Constraint @|m| <(=) |m'|@.-    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)--type LBind = TBinding (Maybe Type)-type TBind = TBinding Type--noBind :: Dom a -> TBinding a-noBind = TBind (fresh "")--boundType :: TBind -> Type-boundType = typ . boundDom--instance LensDec (TBinding a) where-  getDec = getDec . boundDom-  mapDec f (TBind x dom) = TBind x (dom { decor = f (decor dom) })-  mapDec f tb = tb--mapDecM :: (Applicative m) => (Dec -> m Dec) -> TBind -> m TBind-mapDecM f tb@TBind{} = flip setDec tb <$> f (getDec tb)-mapDecM f tb         = pure tb---- measures ------------------------------------------------------------newtype Measure a = Measure { measure :: [a] }    -- mu-    deriving (Eq,Ord,Functor,Foldable,Traversable)--instance Show a => Show (Measure a) where-    show (Measure l) = "|" ++ showList "," show l ++ "|"--succMeasure :: (a -> a) -> Measure a -> Measure a-succMeasure succ mu = maybe (error "cannot take successor of empty measure") id $ applyLastM (Just . succ) 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 f (Measure mu) = Measure <$> loop mu-  where loop []     = fail "empty measure"-        loop [e]    = (:[]) <$> f e-        loop (e:es) = (e:)  <$> loop es--instance HasPred a => HasPred (Measure a) where-  predecessor mu = applyLastM predecessor mu--data Bound a = Bound { ltle :: LtLe, leftBound :: Measure a, rightBound :: Measure a }  -- mu < mur  of mu <= mu'-    deriving (Eq,Ord,Functor,Foldable,Traversable)--instance Show a => Show (Bound a) where-  show (Bound Lt mu1 mu2) = show mu1 ++ " < " ++ show mu2-  show (Bound Le mu1 mu2) = show mu1 ++ " <= " ++ show 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 (Eq,Ord,Show)--type Tags = [Tag]--inTags :: Tag -> Tags -> Bool-inTags = elem--noTags = []--data Tagged a = Tagged { tags :: Tags , unTag :: a }-  deriving (Eq,Ord,Functor,Foldable,Traversable)--instance Show a => Show (Tagged a) where-  show (Tagged tags a) =-   bracketsIf (Erased `inTags` tags) $-     showCast (Cast `inTags` tags) $-       show  a--showCast :: Bool -> String -> String-showCast True  s = "'cast" ++ Util.parens s-showCast False s = s--instance Pretty a => Pretty (Tagged a) where-  prettyPrec k (Tagged []   a) = prettyPrec k a-  prettyPrec _ (Tagged tags a) =-    prettyErased (Erased `inTags` tags) $-      prettyCast (Cast `inTags` tags) $-        pretty a--prettyErased True  doc = brackets doc-prettyErased False doc = doc--prettyCast True  doc = text "'cast" <> PP.parens doc-prettyCast False 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 (Eq,Ord)--data PrePost = Pre | Post deriving (Eq, Ord, Show)-data PiSigma = Pi | Sigma deriving (Eq, Ord)--instance Show PiSigma where-  show Pi    = "->"-  show Sigma = "&"---- | Optional constructor name of a record value.-data RecInfo-  = AnonRec                           -- ^ anonymous record-  | NamedRec { recConK :: ConK-             , recConName :: QName    -- ^ record constructor-             , recNamedFields :: Bool -- ^ print field names?-             , recDottedRef :: Dotted -- ^ coming from dotted constructor (unconfirmed)-             }-  deriving (Eq, Ord)--newtype Dotted = Dotted { dottedRef :: IORef Bool }--instance Eq   Dotted where x == y = True-instance Ord  Dotted where x <= y = True-instance Show Dotted where show d = fwhen (isDotted d) ("un" ++) "confirmed"---- A bit of imperative programming--mkDotted :: MonadIO m => Bool -> m Dotted-mkDotted b = liftIO $ Dotted <$> newIORef b---- default value, shared over all instances-{-# NOINLINE notDotted #-}-notDotted :: Dotted-notDotted = unsafePerformIO $ mkDotted False--isDotted :: Dotted -> Bool-isDotted = unsafePerformIO . readIORef . dottedRef--clearDotted :: MonadIO m => Dotted -> m ()-clearDotted d | isDotted d = liftIO $ do-      -- putStrLn ("clearing a dot")-      writeIORef (dottedRef d) False-  | otherwise = return ()--alignDotted :: MonadIO m => Dotted -> Dotted -> m ()-alignDotted d1 d2 = case (isDotted d1, isDotted d2) of-  (True, False) -> clearDotted d1-  (False, True) -> clearDotted d2-  _             -> return ()--recDotted :: RecInfo -> Bool-recDotted NamedRec{recDottedRef} = isDotted recDottedRef-recDotted AnonRec = False--instance Show RecInfo where-  show AnonRec              = ""-  show ri@NamedRec{recConName} = (if recDotted ri then "." else "") ++ show recConName---- * smart constructors---- | Create a universal binding.  Fuse hidden bindings.-pi :: TBind -> Expr -> Expr-pi = piSig Pi--piSig :: PiSigma -> TBind -> Expr -> Expr-piSig = 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 e Pre n  = App (Proj Pre n) e-proj e Post n = App e (Proj Post n)---- | Non-dependent function type.-funType a b = Quant Pi (noBind a) b--erasedExpr e = Ann (Tagged [Erased] e)-castExpr   e = Ann (Tagged [Cast]   e)--succView :: Expr -> (Int, Expr)-succView (Succ e) = inc (succView e) where inc (n, e) = (n+1, e)-succView e = (0, e)---- Clauses and patterns ------------------------------------------------data Clause = Clause-  { clTele     :: TeleVal      -- top-level telescope of type values for PVars-  , clPatterns :: [Pattern]-  , clExpr     :: Maybe Expr   -- Nothing if absurd clause-  } deriving (Eq,Ord,Show)---- clause = Clause (error "internal error: no telescope in clause before typechecking!")-clause = Clause [] -- empty clTele--data PatternInfo = PatternInfo-  { coPat          :: ConK    -- (co)constructor-  , irrefutablePat :: Bool    -- constructor of a record (UNUSED)-  , dottedPat      :: Bool-  } deriving (Eq,Ord,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 (Eq,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 co n = Def $ DefId (ConK co) n--- con co n = Con co n []-fun n    = Def $ DefId FunK n-dat n    = Def $ DefId DatK n-letdef n = Def $ DefId LetK $ QName n--type SpineView = (Expr, [Expr])---- collect applications to expose head-spineView :: Expr -> SpineView-spineView = aux []-  where aux sp (App f e) = aux (e:sp) f-        aux sp e = (e, sp)--test_spineView = spineView ((Var x `App` Var y) `App` Var z)-  where x = fresh "x"-        y = fresh "y"-        z = fresh "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 (Ann (Tagged tags e)) =-  let (b, e') = isErasedExpr e-  in  (b || Erased `inTags` tags, e')-isErasedExpr e = (False, 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 (Eq,Ord,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 (Eq,Ord,Show)--data TySig a = TypeSig { namePart :: Name, typePart :: a }-               deriving (Eq,Ord,Show,Functor)-type TypeSig = TySig Type--type Type = Expr---- | Constructor declaration.  Top-level scope (independent of data pars).-data Constructor = Constructor- { ctorName :: QName       -- ^ Name of the constructor.- , ctorPars :: ParamPats   -- ^ Constructor patterns (if new style params).- , ctorType :: Type        -- ^ Constructor type (@fields -> target@).- } deriving (Eq, Ord, Show)--type ParamPats = Maybe (Telescope, [Pattern])--newtype Telescope = Telescope { telescope :: [TBind] }-  deriving (Eq, Ord, Show, Size, Null)--emptyTel = Telescope []--data Arity = Arity-  { fullArity    :: Int        -- ^ arity of the function-  , isProjection :: Maybe Int  -- ^ projection? then number of parameters-  } deriving (Eq, Ord, Show)--data Fun = Fun-  { funTypeSig :: TypeSig      -- ^ internal name and type-  , funExtName :: Name         -- ^ external name (for associated eta-expanded fun)-  , funArity   :: Arity-  , funClauses :: [Clause]-  } deriving (Eq, Ord, 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 (Quant Pi (TMeasure{}) b) = b -- there can only be one measure!-eraseMeasure (Quant Pi a@(TBind{}) b)  = Quant Pi a $ eraseMeasure b-eraseMeasure (Quant Pi a@(TBound{}) b) = Quant Pi a $ eraseMeasure b-eraseMeasure (LLet a tel e b) = LLet a tel e $ eraseMeasure b-eraseMeasure t = t---- inferable term = True/False--- not needed for types or sizes-inferable :: Expr -> Bool-inferable Var{}   = True-inferable Sort{}  = True-inferable Zero{}  = True-inferable Infty{} = True---inferable Con{}   = True--- 2012-01-22 constructors are no longer inferable, since parameters are missing-inferable (Def (DefId { idKind = ConK{} }))  = False-inferable Def{} = True-inferable (App f e) = inferable f--- inferable (Pair f e) = inferable f && inferable e  -- pairs are not inferable due to irrelevant sigma!--- inferable Sing{}  = True  -- not with universes-inferable _       = False---- | Collect the variables from the binders-class BoundVars a where-  boundVars :: Collection c Name => a -> c--instance BoundVars a => BoundVars [a] where-  boundVars = foldMap boundVars--instance BoundVars a => BoundVars (Maybe a) where-  boundVars = foldMap boundVars--instance (BoundVars a, BoundVars b) => BoundVars (a, b) where-  boundVars (a, b) = mconcat [boundVars a, boundVars b]--instance (BoundVars a, BoundVars b, BoundVars c) => BoundVars (a, b, c) where-  boundVars (a, b, c) = mconcat [boundVars a, boundVars b, boundVars c]--instance BoundVars (TBinding a) where-  boundVars (TBind x a)  = Coll.singleton x-  boundVars (TMeasure m) = mempty-  boundVars (TBound b)   = mempty--instance BoundVars Telescope where-  boundVars = boundVars . telescope--instance BoundVars (Pat e) where-  boundVars (VarP name)   = Coll.singleton name-  boundVars (SizeP x y)   = Coll.singleton y-  boundVars (SuccP p)     = boundVars p-  boundVars (ConP _ _ ps) = boundVars ps-  boundVars (PairP p p')  = boundVars (p, p')-  boundVars (ProjP _)     = mempty-  boundVars (DotP _)      = mempty-  boundVars (ErasedP p)   = boundVars p-  boundVars (AbsurdP)     = mempty-  boundVars (UnusableP p) = 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 = foldMap freeVars--instance FreeVars a => FreeVars (Maybe a) where-  freeVars = foldMap freeVars--instance FreeVars a => FreeVars (Sort a) where-  freeVars = foldMap freeVars--instance FreeVars a => FreeVars (Dom a) where-  freeVars = foldMap freeVars--instance FreeVars a => FreeVars (Measure a) where-  freeVars = foldMap freeVars--instance FreeVars a => FreeVars (Bound a) where-  freeVars = foldMap freeVars--instance FreeVars a => FreeVars (Tagged a) where-  freeVars = foldMap freeVars--instance (FreeVars a, FreeVars b) => FreeVars (a, b) where-  freeVars (a, b) = mconcat [freeVars a, freeVars b]--instance (FreeVars a, FreeVars b, FreeVars c) => FreeVars (a, b, c) where-  freeVars (a, b, c) = mconcat [freeVars a, freeVars b, freeVars c]--instance FreeVars a => FreeVars (TBinding a) where-  freeVars (TBind x a)  = freeVars a  -- Note: x is bound in the stuff to come, not in a.-  freeVars (TMeasure m) = freeVars m-  freeVars (TBound b)   = freeVars b--instance FreeVars Telescope where-  freeVars (Telescope [])         = mempty-  freeVars (Telescope (tb : tel)) = freeVars tb `Set.union`-                          (freeVars (Telescope tel) Set.\\ boundVars tb)--instance FreeVars Expr where-  freeVars e0 =-    case e0 of-      Sort s    -> freeVars s-      Zero      -> mempty-      Succ e    -> freeVars e-      Infty     -> mempty-      Var name  -> Set.singleton name-      Def{}     -> mempty-      Case e mt cls-                -> freeVars (e, mt, cls)-      LLet (TBind x dom) tel t u | null tel-                -> freeVars (dom, t) `Set.union` Set.delete x (freeVars u)-      Pair f e  -> freeVars (f, e)-      App  f e  -> freeVars (f, e)-      Max  es   -> freeVars es-      Plus es   -> freeVars es-      Lam _ x e -> Set.delete x (freeVars e)-      Quant pisig ta b -> freeVars ta `Set.union` (freeVars b Set.\\ boundVars ta)-{--      Quant pisig tel ta b-                -> freeVars tel' `Set.union` (freeVars b Set.\\ boundVars tel')-                     where tel' = Telescope $ telescope tel ++ [ta]--}-      Sing e t  -> freeVars (e, t)-      Below _ e -> freeVars e-      Ann te    -> freeVars te-      Irr       -> mempty-      e         -> error $ "freeVars " ++ show e ++ " not implemented"--instance FreeVars Clause where-  freeVars (Clause _ ps Nothing)  = mempty  -- absurd clause-  freeVars (Clause _ ps (Just e)) = freeVars e Set.\\ boundVars ps--patternVars :: Pattern -> [Name]-patternVars = 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 = foldMap usedDefs--instance UsedDefs a => UsedDefs (Maybe a) where-  usedDefs = foldMap usedDefs--instance UsedDefs a => UsedDefs (Sort a) where-  usedDefs = foldMap usedDefs--instance UsedDefs a => UsedDefs (Dom a) where-  usedDefs = foldMap usedDefs--instance UsedDefs a => UsedDefs (Measure a) where-  usedDefs = foldMap usedDefs--instance UsedDefs a => UsedDefs (Bound a) where-  usedDefs = foldMap usedDefs--instance UsedDefs a => UsedDefs (Tagged a) where-  usedDefs = foldMap usedDefs--instance (UsedDefs a, UsedDefs b) => UsedDefs (a, b) where-  usedDefs (a, b) = mconcat [usedDefs a, usedDefs b]--instance (UsedDefs a, UsedDefs b, UsedDefs c) => UsedDefs (a, b, c) where-  usedDefs (a, b, c) = mconcat [usedDefs a, usedDefs b, usedDefs c]--instance (UsedDefs a, UsedDefs b, UsedDefs c, UsedDefs d) => UsedDefs (a, b, c, d) where-  usedDefs (a, b, c, d) = mconcat [usedDefs a, usedDefs b, usedDefs c, usedDefs d]--instance UsedDefs a => UsedDefs (TBinding a) where-  usedDefs (TBind _ e)  = usedDefs e-  usedDefs (TMeasure m) = usedDefs m-  usedDefs (TBound b)   = usedDefs b--instance UsedDefs Telescope where-  usedDefs = usedDefs . telescope--instance UsedDefs DefId where-  usedDefs id-    | idKind id `elem` [FunK, DatK] = [unqual $ idName id]-    | otherwise                     = []--instance UsedDefs Clause where-  usedDefs = usedDefs . clExpr--instance UsedDefs Expr where-  usedDefs (Def id)           = usedDefs id-  usedDefs (Pair f e)         = usedDefs (f, e)-  usedDefs (App f e)          = usedDefs (f, e)-  usedDefs (Max es)           = usedDefs es-  usedDefs (Plus es)          = usedDefs es-  usedDefs (Lam _ x e)        = usedDefs e-  usedDefs (Sing a b)         = usedDefs (a, b)-  usedDefs (Below _ b)        = usedDefs b---  usedDefs (Quant _ tel tb b) = usedDefs (tel, tb, b)-  usedDefs (Quant _ tb b)     = usedDefs (tb, b)-  usedDefs (LLet tb tel e1 e2)= usedDefs (tb, tel, e1, e2)-  usedDefs (Succ e)           = usedDefs e-  usedDefs (Case e mt cls)    = usedDefs (e, mt, cls)-  usedDefs (Ann e)            = usedDefs e-  usedDefs (Sort s)           = usedDefs s-  usedDefs Zero               = []-  usedDefs Infty              = []-  usedDefs Meta{}             = []-  usedDefs Var{}              = []-  usedDefs Proj{}             = []-  usedDefs (Record ri rs)     = foldMap (usedDefs . snd) rs-  usedDefs e                  = error $ "usedDefs " ++ show e ++ " not implemented"--rhsDefs :: [Clause] -> [Name]-rhsDefs cls = List.foldl (\ ns (Clause _ ps e) -> maybe [] usedDefs e ++ ns) [] cls---- pretty printing expressions -----------------------------------------[precArrL, precAppL, precAppR] = [1..3]--instance Pretty Name where---  pretty x = text $ suggestion x-  pretty x = text $ show x--instance Pretty QName where-  pretty (Qual m n) = pretty m <> text "." <> pretty n-  pretty (QName n)  = pretty n--instance Pretty DefId where---    pretty d = pretty $ name d-    pretty d = text $ show d--instance Pretty Expr where-  prettyPrec _ Irr         = text "."-  prettyPrec k (Sort s)    = prettyPrec k s-  prettyPrec _ Zero        = text "0"-  prettyPrec _ Infty       = text "#"-  prettyPrec _ (Meta i)    = text $ "?" ++ show i-  prettyPrec _ (Var n)     = pretty n---  prettyPrec _ (Con _ n)   = text n-  prettyPrec _ (Def id)    = pretty id---  prettyPrec _ (Let n)     = text n-  prettyPrec _ (Sing e t)  = angleBrackets $ pretty e <+> colon <+> pretty t-  prettyPrec k e@Succ{}    =-    case succView e of-      (n, Zero) -> text $ show n-      (n, e)    -> text (replicate n '$') <> prettyPrec precAppR e---  prettyPrec k (Succ e)    = text "$" <> prettyPrec precAppR e-{-  prettyPrec k (Succ e)    = parensIf (precAppR <= k) $-                              text "$" <+> prettyPrec precAppR e   -}-  prettyPrec k (Max es)  = parensIf (precAppR <= k) $-    List.foldl (\ d e -> d <+> prettyPrec precAppR e) (text "max") es-  prettyPrec k (Plus (e:es))  = parensIf (1 < k) $-    List.foldl (\ d e -> d <+> text "+" <+> prettyPrec 1 e) (prettyPrec 1 e) es-  prettyPrec k (Proj Pre n)   = pretty n-  prettyPrec k (Proj Post n)  = text "." <> pretty n-  prettyPrec k (Record AnonRec []) = text "record" <+> braces empty-  prettyPrec k (Record AnonRec rs) = text "record" <+> prettyRecFields rs-  prettyPrec k (Record (NamedRec _ n _ dotted) []) = dotIf dotted $ pretty n-  prettyPrec k (Record (NamedRec _ n True dotted) rs) = dotIf dotted $ pretty n <+> prettyRecFields rs-  prettyPrec k (Record (NamedRec _ n False dotted) rs) =-   parensIf (not (null rs) && precAppR <= k) $ dotIf dotted $-     pretty n <+> hsep (List.map (prettyPrec precAppR . snd) rs)-  prettyPrec k (Pair e1 e2) = parens $ pretty e1 <+> comma <+> pretty e2-  prettyPrec k (App f e)  = parensIf (precAppR <= k) $-    prettyPrec precAppL f <+> prettyPrec precAppR 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 k (Case e mt cs) = parensIf (0 < k) $-    (text "case" <+> pretty e) <+> (maybe empty (\ t -> colon <+> pretty t) mt) $$ (vlist $ List.map prettyCase cs)-  prettyPrec k (Lam dec x e) = parensIf (0 < k) $-    (if erased dec then brackets else id) (text "\\" <+> pretty x <+> text "->")-      <+> pretty e-  prettyPrec k (LLet (TBind n (Domain mt ki dec)) tel e1 e2) | null tel = parensIf (0 < k) $-    (text "let" <+> ((if erased dec then lbrack else PP.empty) <>-       pretty n <+> vcat [ maybe empty (\ t -> colon <+> pretty t) mt-                           <> (if erased dec then rbrack else PP.empty)-                       , equals <+> pretty e1 ]))-    $$ (text "in" <+> pretty e2)-  prettyPrec k (LLet (TBind n (Domain mt ki dec)) tel e1 e2) = parensIf (0 < k) $-    (text "let" <+> ((if erased dec then brackets else id) $ pretty n)-                <+> pretty tel-                <+> vcat [ maybe empty (\ t -> colon <+> pretty t) mt-                         , equals <+> pretty e1 ])-    $$ (text "in" <+> pretty 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 k (Below ltle e) = pretty ltle <+> prettyPrec k e-  prettyPrec k (Quant Pi (TMeasure mu) t2) = parensIf (precArrL <= k) $-    (pretty mu <+> text "->" <+> pretty t2)-  prettyPrec k (Quant Pi (TBound beta) t2) = parensIf (precArrL <= k) $-    (pretty beta <+> text "->" <+> pretty t2)--  prettyPrec k (Quant pisig (TBind x (Domain t1 ki dec)) t2) | null (suggestion x) = parensIf (precArrL <= k) $-    ((if erased dec then ppol <> brackets (pretty t1)-       else ppol <+> prettyPrec precArrL t1)-      <+> pretty pisig <+> pretty t2)-    where pol = polarity dec-          ppol = if pol==defaultPol then PP.empty else text $ show pol--  prettyPrec k (Quant pisig (TBind x (Domain (Below ltle t1) ki dec)) t2) = parensIf (precArrL <= k) $-    ppol <>-    ((if erased dec then brackets else parens) $-      pretty x <+> pretty ltle <+> pretty t1) <+> pretty pisig <+> pretty t2-    where pol = polarity dec-          ppol = if pol==defaultPol then PP.empty else text $ show pol--  prettyPrec k (Quant pisig (TBind x (Domain t1 ki dec)) t2) = parensIf (precArrL <= k) $-    ppol <>-    ((if erased dec then brackets else parens) $-      pretty x <+> colon <+> pretty t1) <+> pretty pisig <+> pretty t2-    where pol = polarity dec-          ppol = if pol==defaultPol then PP.empty else text $ show pol--  prettyPrec k (Ann e) = pretty e--class DotIf a where-  dotIf :: a -> Doc -> Doc--instance DotIf Bool where-  dotIf False d = d-  dotIf True  d = text "." <> d--instance DotIf Dotted where-  dotIf c = dotIf (isDotted c)--instance Pretty TBind where-  prettyPrec k (TMeasure mu) = pretty mu-  prettyPrec k (TBound beta) = pretty beta--  prettyPrec k (TBind x (Domain (Below ltle t1) ki dec)) =-    ppol <>-    ((if erased dec then brackets else parens) $-      pretty x <+> pretty ltle <+> pretty t1)-    where pol = polarity dec-          ppol = if pol==defaultPol then PP.empty else text $ show pol--  prettyPrec k (TBind x (Domain t1 ki dec)) =-    ppol <>-    ((if erased dec then brackets else parens) $-      pretty x <+> colon <+> pretty t1)-    where pol = polarity dec-          ppol = if pol==defaultPol then PP.empty else text $ show pol--instance Pretty Telescope where-  prettyPrec k tel = sep $ map pretty $ telescope tel--prettyRecFields rs =-    let l:ls = List.map (\ (n, e) -> pretty n <+> equals <+> prettyPrec 0 e) rs-    in  cat $ (lbrace <+> l) : List.map (semi <+>) ls ++ [empty <+> rbrace]--prettyCase (Clause _ [p] Nothing)  = pretty p-prettyCase (Clause _ [p] (Just e)) = pretty p <+> text "->" <+> pretty e--instance Pretty PiSigma where-  pretty Pi    = text "->"-  pretty Sigma = text "&"--vlist :: [Doc] -> Doc-vlist [] = lbrace <> rbrace-vlist ds = (vcat $ zipWith (<+>) (lbrace : repeat semi) ds) $$ rbrace--instance Pretty (Measure Expr) where-  pretty (Measure es) = text "|" <> hsepBy comma (List.map pretty es) <> text "|"--instance Pretty LtLe where-  pretty Lt = text "<"-  pretty Le = text "<="--instance Pretty (Bound Expr) where-  pretty (Bound ltle mu mu') = pretty mu <+> pretty ltle <+> pretty 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 k (SortC c)  = text $ show c-  prettyPrec k (Set Zero) = text "Set" -- print as Set for backwards compat.-  prettyPrec k (Set e) =  parensIf (precAppR <= k) $-    text "Set" <+> prettyPrec precAppR e-  prettyPrec k (CoSet e) = parensIf (precAppR <= k) $-    text "CoSet" <+> prettyPrec precAppR e--instance Pretty Pattern where-  prettyPrec k (VarP x)       = pretty x-  prettyPrec k (ConP co c ps) = parensIf (not (null ps) && precAppR <= k) $-    -- (if dottedPat co then text "." else empty) <>-    dotIf (dottedPat co) $ pretty c <+> hsep (List.map (prettyPrec precAppR) ps)-  prettyPrec k (SuccP p)      = text "$" <> prettyPrec k p-  prettyPrec k (SizeP x y)    = parensIf (precAppR <= k) $ pretty y <+> text "<" <+> pretty x-  prettyPrec k (PairP p p')   = parens $ pretty p <> comma <+> pretty p'-  prettyPrec k (UnusableP p)  = prettyPrec k p-  prettyPrec k (ProjP x)      = text "." <> pretty x-  prettyPrec k (DotP p)       = text "." <> prettyPrec precAppR p-  prettyPrec k (AbsurdP)      = text "()"-  prettyPrec k (ErasedP p)    = brackets $ prettyPrec 0 p---instance Show Expr where-  showsPrec k e s = render (prettyPrec k e) ++ s-  -- show = render . pretty -- showExpr--instance Show Pattern where-  show = render . pretty--showCase (Clause _ [p] Nothing) = render (prettyPrec precAppR p)-showCase (Clause _ [p] (Just e)) = render (prettyPrec precAppR p) ++ " -> " ++ show e-showCases = showList "; " 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 phi p =-  let phi' x = maybe (Var x) patternToExpr $ lookup x phi-  in-  case p of-    VarP n -> maybe p id $ lookup n phi-    ConP pi n ps -> ConP pi n $ List.map (patSubst phi) ps-    SuccP p      -> SuccP $ patSubst phi p-    SizeP e y    -> SizeP (parSubst phi' e) y-    PairP p1 p2  -> PairP (patSubst phi p1) (patSubst phi p2)-    ProjP x      -> p-    DotP e       -> DotP $ parSubst phi' e-    AbsurdP      -> p-    ErasedP p    -> ErasedP $ patSubst phi p-    UnusableP p   -> UnusableP $ patSubst phi 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 = map . parSubst--instance ParSubst a => ParSubst (Maybe a) where-  parSubst = fmap . parSubst--instance ParSubst a => ParSubst (Dom a) where-  parSubst = fmap . parSubst--instance ParSubst a => ParSubst (Measure a) where-  parSubst = fmap . parSubst--instance ParSubst a => ParSubst (Bound a) where-  parSubst = fmap . parSubst--instance ParSubst a => ParSubst (Tagged a) where-  parSubst = fmap . parSubst--instance ParSubst a => ParSubst (TBinding a) where-  parSubst phi (TBind x a)  = TBind x  $ parSubst phi a-  parSubst phi (TMeasure m) = TMeasure $ parSubst phi m-  parSubst phi (TBound b)   = TBound   $ parSubst phi b--instance ParSubst a => ParSubst (Sort a) where-  parSubst phi (CoSet e) = CoSet $ parSubst phi e-  parSubst phi (Set e)   = Set   $ parSubst phi e-  parSubst phi s         = s--instance ParSubst Telescope where-  parSubst phi = Telescope . parSubst phi . telescope--instance ParSubst Clause where-  parSubst phi (Clause tel ps e) = Clause tel ps $ parSubst phi e---- TODO: Refactor!-instance ParSubst Expr where-  parSubst phi (Sort s)              =  Sort $ parSubst phi s-  parSubst phi (Succ e)              = Succ (parSubst phi e)-  parSubst phi e@Zero                = e-  parSubst phi e@Infty               = e-  parSubst phi e@Meta{}              = e-  parSubst phi e@Proj{}              = e-  parSubst phi (Var x)               = phi x-  parSubst phi e@Def{}               = e-  parSubst phi (Case e mt cls)       = Case (parSubst phi e) (parSubst phi mt) (parSubst phi cls)-  parSubst phi (LLet ta tel b c)     = LLet (parSubst phi ta) (parSubst phi tel) (parSubst phi b) (parSubst phi c)-  parSubst phi (Pair f e)            = Pair (parSubst phi f) (parSubst phi e)-  parSubst phi (App f e)             = App (parSubst phi f) (parSubst phi e)-  parSubst phi (Record ri rs)        = Record ri (mapAssoc (parSubst phi) rs)-  parSubst phi (Max es)              = Max (parSubst phi es)-  parSubst phi (Plus es)             = Plus (parSubst phi es)-  parSubst phi (Lam dec x e)         = Lam dec x (parSubst phi e)-  parSubst phi (Below ltle e)        = Below ltle (parSubst phi e)-  parSubst phi (Quant pisig a b)     = Quant pisig (parSubst phi a) (parSubst phi b)---  parSubst phi (Quant pisig tel a b) = Quant pisig (parSubst phi tel) (parSubst phi a) (parSubst phi b)-  parSubst phi (Sing a b)            = Sing (parSubst phi a) (parSubst phi b)-  parSubst phi (Ann e)               = Ann $ parSubst phi e-  parSubst phi e                     = error $ "Abstract.parSubst phi (" ++ show e ++ ") 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 = map . subst--instance Substitute a => Substitute (Maybe a) where-  subst = fmap . subst--instance Substitute a => Substitute (Dom a) where-  subst = fmap . subst--instance Substitute a => Substitute (Measure a) where-  subst = fmap . subst--instance Substitute a => Substitute (Bound a) where-  subst = fmap . subst--instance Substitute a => Substitute (Tagged a) where-  subst = fmap . subst--instance Substitute a => Substitute (TBinding a) where-  subst phi (TBind x a)  = TBind x  $ subst phi a-  subst phi (TMeasure m) = TMeasure $ subst phi m-  subst phi (TBound b)   = TBound   $ subst phi b--instance Substitute a => Substitute (Sort a) where-  subst phi (CoSet e) = CoSet $ subst phi e-  subst phi (Set e)   = Set   $ subst phi e-  subst phi s         = s--instance Substitute Telescope where-  subst phi = Telescope . subst phi . telescope--instance Substitute Clause where-  subst phi (Clause tel ps e) = Clause tel ps $ subst phi e--instance Substitute Expr where-  subst phi (Sort s)              = Sort $ subst phi s-  subst phi (Succ e)              = Succ (subst phi e)-  subst phi e@Zero                = e-  subst phi e@Infty               = e-  subst phi e@(Meta i)            = Map.findWithDefault e i phi-  subst phi e@Var{}               = e-  subst phi e@Def{}               = e-  subst phi e@Proj{}              = e-  subst phi (Case e mt cls)       = Case (subst phi e) (subst phi mt) (subst phi cls)-  subst phi (LLet ta tel b c)     = LLet (subst phi ta) (subst phi tel) (subst phi b) (subst phi c)-  subst phi (Pair f e)            = Pair (subst phi f) (subst phi e)-  subst phi (App f e)             = App (subst phi f) (subst phi e)-  subst phi (Record ri rs)        = Record ri (mapAssoc (subst phi) rs)-  subst phi (Max es)              = Max (subst phi es)-  subst phi (Plus es)             = Plus (subst phi es)-  subst phi (Lam dec x e)         = Lam dec x (subst phi e)-  subst phi (Below ltle e)        = Below ltle (subst phi e)-  subst phi (Quant pisig a b)     = Quant pisig (subst phi a) (subst phi b)---  subst phi (Quant pisig tel a b) = Quant pisig (subst phi tel) (subst phi a) (subst phi b)-  subst phi (Sing a b)            = Sing (subst phi a) (subst phi b)-  subst phi (Ann e)               = Ann $ subst phi e-  subst phi e                     = error $ "Abstract.subst phi (" ++ show e ++ ") 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 f cls = vlist $ List.map (prettyClause f) cls--prettyClause f (Clause _ ps Nothing) = pretty f <+> hsep (List.map (prettyPrec precAppR) ps)-prettyClause f (Clause _ ps (Just e)) = pretty f-  <+> hsep (List.map (prettyPrec precAppR) ps)-  <+> equals <+> pretty 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 (Eq, Show)--type Destructor = (Type, Arity, Clause)--data FieldInfo = FieldInfo-  { fDec   :: Dec-  , fName  :: Name        -- ^ Empty "" for anonymous fields.-  , fType  :: Type        -- ^ Naked type (no preceeding telescope).---  , fLazy  :: Bool        -- lazy (coinductive occ) or strict (everything else) -- see TCM.hs ConSig-  , fClass :: FieldClass-  }--instance Show FieldInfo where-  show (FieldInfo dec name t fcl) =-    (if fcl == Index then "index " else "field ") ++-    bracketsIf (erased dec) (show name ++ " : " -- ++ (if lazy then "?" else "")-                                      ++ show 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 (Eq, Ord, Show)--data ConstructorInfo = ConstructorInfo-  { cName   :: QName---  , cType   :: TVal-  , cPars   :: ParamPats  -- ^ Constructor parameters if unequal to data parameters.-  , cFields :: [FieldInfo]-  , cTyCore :: Type-  , cPatFam :: (PatternsType, [Pattern])-  , cEtaExp :: Bool -- all destructors are defined, family pattern is non-overlapping with family patterns of other constructors-  , cRec    :: Bool -- constructor has recursive fields-  } deriving Show--corePat :: ConstructorInfo -> [Pattern]-corePat = snd . 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 = foldMap injectiveVars--instance InjectiveVars a => InjectiveVars (Maybe a) where-  injectiveVars = foldMap injectiveVars--instance InjectiveVars a => InjectiveVars (Sort a) where-  injectiveVars = foldMap injectiveVars--instance InjectiveVars a => InjectiveVars (Dom a) where-  injectiveVars = foldMap injectiveVars--instance InjectiveVars a => InjectiveVars (Measure a) where-  injectiveVars = foldMap injectiveVars--instance InjectiveVars a => InjectiveVars (Bound a) where-  injectiveVars = foldMap injectiveVars--instance InjectiveVars a => InjectiveVars (Tagged a) where-  injectiveVars = foldMap injectiveVars--instance (InjectiveVars a, InjectiveVars b) => InjectiveVars (a, b) where-  injectiveVars (a, b) = mconcat [injectiveVars a, injectiveVars b]--instance (InjectiveVars a, InjectiveVars b, InjectiveVars c) => InjectiveVars (a, b, c) where-  injectiveVars (a, b, c) = mconcat [injectiveVars a, injectiveVars b, injectiveVars c]--instance InjectiveVars a => InjectiveVars (TBinding a) where-  injectiveVars (TBind x a)  = injectiveVars a-  injectiveVars (TMeasure m) = injectiveVars m-  injectiveVars (TBound b)   = injectiveVars b--instance InjectiveVars Telescope where-  injectiveVars (Telescope []) = mempty-  injectiveVars (Telescope (tb : tel)) = injectiveVars tb `Set.union`-                          (injectiveVars (Telescope tel) Set.\\ boundVars tb)--instance InjectiveVars Expr where-  injectiveVars e =-   case spineView e of-    (Var name            , []) -> Set.singleton name-    (Def (DefId DatK{} _), es) -> injectiveVars es-    (Def (DefId ConK{} _), es) -> injectiveVars es-    (Record ri rs        , []) -> Set.unions $ List.map (injectiveVars . snd) rs-    (Succ e              , []) -> injectiveVars e-    (Lam _ x e           , []) -> Set.delete x (injectiveVars e)-    (Quant _ ta b , []) -> injectiveVars ta `Set.union` (injectiveVars b Set.\\ boundVars 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 e              , []) -> injectiveVars e-    _                         -> Set.empty--classifyFields :: Co -> Name -> Type -> [FieldInfo]-classifyFields co dataName ty = List.map (classifyField fvs) $ telescope tele-  where (tele, core) = typeToTele ty-        fvs = freeVars core-        ivs = injectiveVars core-        classifyField fvs (TBind name (Domain ty ki dec)) = FieldInfo-          { fDec = dec-          , fName  = name-          , fType  = ty---          , fLazy  = co == CoInd && maybeRecursiveOccurrence dataName ty-          , fClass = if name `Set.member` fvs then-                       if name `Set.member` ivs then Index else NotErasableIndex-                      else Field Nothing-          }--isField :: FieldClass -> Bool-isField Field{} = True-isField _       = False--isNamedField :: FieldInfo -> Bool-isNamedField f = isField (fClass f) && not (erased $ fDec f) && not (emptyName $ fName f)--destructorNames :: [FieldInfo] -> [Name]-destructorNames fields = List.map fName $ filter isNamedField fields--analyzeConstructor :: Co -> Name -> Telescope -> Constructor -> ConstructorInfo-analyzeConstructor co dataName dataPars (Constructor constrName conPars ty) =-  let (_, core)  = typeToTele ty-      pars       = maybe dataPars fst conPars-      fields     = classifyFields co dataName ty-      -- freshenFieldName fi = fi { fName = freshen $ fName fi }-      -- freshfields = List.map freshenFieldName fields-      -- generate destructors-      -- choose a name for the record to destroy-      indices    = filter (\ f -> fClass f == Index) fields-      indexTele  = Telescope $ List.map (\ f -> TBind (fName f) $ Domain (fType f) defaultKind (fDec f)) indices-      indexNames  = List.map fName indices-      -- do not generated destructors for erased arguments-      destrNames = destructorNames fields-      recName    = internal $ name constrName -- "constructed_by_" ++ constrName-      parNames   = List.map boundName $ telescope pars-      parAndIndexNames = parNames ++ indexNames-      -- substitute variable "fst" by application "fst A B p"-      phi x = if x `elem` destrNames-                then List.foldl App ({-fun x-} letdef x) (List.map Var (parAndIndexNames ++ [recName]))-                else Var x-      -- prefix d =  "destructor_argument_" ++ d-      prefix d = d { suggestion = "#" ++ suggestion d }-      -- modifiedDestrNames = List.map prefix destrNames-      -- TODO: Index arguments are not always before fields-      pattern = ConP (PatternInfo (coToConK co) False False) -- to bootstrap destructor, not irrefutable-          constrName-          ( -- 2012-01-22 PARS GONE!   List.map (DotP . Var) parNames ++-            List.map (\ fi -> (case fClass fi of-                            Index   -> DotP . Var-                            Field{} -> VarP . prefix)-                         (fName fi))-              fields)-      destrType t = -- teleToTypeErase (pars ++ indexTele)-                    teleToTypeErase pars $ teleToType indexTele $-                      pi (TBind recName $ defaultDomain core) $ parSubst phi t-      destrBody (dn) = clause (List.map VarP parAndIndexNames ++ [pattern]) (Just (Var dn))-      fields' = mapOver fields $-        \ f -> if isNamedField f then-                  f { fClass = Field $ Just-                         ( destrType (fType f)-                         , let npars = size pars-                           in  Arity { fullArity = npars + size indexTele + 1-                                     , isProjection = Just npars-                                     }-                         , destrBody (prefix (fName f)) )}-                else f-      computeLinearity :: (Bool, [Pattern]) -> (PatternsType, [Pattern])-      computeLinearity (False, ps) = (NotPatterns, ps)-      computeLinearity (True , ps) = (if linear then LinearPatterns else NonLinearPatterns, ps) where-        linear = List.null ps || (List.null $ List.foldl1 List.intersect $ List.map patternVars ps)--      result = ConstructorInfo-       { cName   = constrName-       , cPars   = conPars-       , cFields = fields'-       , cTyCore = core-       -- check whether core is D ps and store pats; also compute whether ps are linear-       , cPatFam = computeLinearity $ fromAllWriter $ isPatIndFamC core-       , cEtaExp = destructorNamesPresent fields-       , cRec    = True  -- we don't know here, assume the worst-       }-   in -- trace ("analyzeConstructor returns " ++ show result) $-        result---- can only eta expand if I can generate all destructors-destructorNamesPresent :: [FieldInfo] -> Bool-destructorNamesPresent fields =-  all (\ f -> fClass f /= NotErasableIndex &&  -- no bad index-              (fClass f == Index ||-               not (erased $ fDec f) && not (emptyName $ fName f))) -- no erased or unnamed field-    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 dataName pars cs =-  let cis = List.map (analyzeConstructor co dataName pars) cs-      -- check if patterns overlaps with any other-      overlapList = zipWith (\ ci n -> any (overlaps (corePat ci)) $ List.map corePat $ take n cis ++ drop (n+1) cis) cis [0..] -- worst case quadratic, could be improved by exploiting symmetry-      result = zipWith (\ ci ov -> if ov then ci { cEtaExp = False } else ci) cis overlapList-  in result---- | Build constructor type from constructor info, erasing all indices.-reassembleConstructor :: ConstructorInfo -> Constructor-reassembleConstructor ci = Constructor (cName ci) (cPars ci) (reassembleConstructorType ci)---- | Assumes that all the indices (even from data telescope) are contained---   in fields.-reassembleConstructorType :: ConstructorInfo -> Type-reassembleConstructorType ci = buildPi (cFields ci) where-  buildPi [] = cTyCore ci-  buildPi (f:fs) = pi (TBind (fName f) $ Domain (fType f) defaultKind (decor (fDec f) (fClass f))) $ buildPi fs-    where decor dec Index = irrelevantDec -- DONE: SWITCH ON!-          decor 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 (Def id) = return []-isPatIndFamC (App f e) = do-  ps <- isPatIndFamC f-  p  <- exprToDotPat' e-  return $ ps ++ [p]--- isPatIndFamC (App e es) = do---   ps  <- isPatIndFamC e---   ps' <- mapM exprToDotPat' es---   return $ ps ++ ps'-isPatIndFamC (Quant Pi _ e) = isPatIndFamC e-isPatIndFamC _ = tell (All False) >> return []---- Pattern auxiliary functions ------------------------------------------- extract all subpatterns of the form y > x and arrange them in a--- TreeShapedOrder-tsoFromPatterns :: [Pattern] -> TSO Name-tsoFromPatterns ps = TSO.fromList $ List.concat $ List.map loop ps where-  loop (SizeP (Var father) son) = [(son,(1,father))]-  loop (SizeP (Succ (Var father)) son) = [(son,(0,father))]-  loop (SizeP e      son) = []-  loop (ConP _ _ ps)      = List.concat $ List.map loop ps-  loop (PairP p p')       = loop p ++ loop p'-  loop (SuccP   p)        = loop p-  loop (ErasedP p)        = loop 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 (VarP _) p' = True-overlap p (VarP _)  = True-overlap (ConP _ c ps) (ConP _ c' ps') = c == c' && overlaps ps ps' -- only source of non-overlap-overlap (PairP p1 p2) (PairP p1' p2') = overlaps [p1,p2] [p1',p2']-overlap (ProjP n) (ProjP n') = n == n' -- another source of non-overlap--- size patterns always overlap-overlap (SuccP p) _ = True-overlap _ (SuccP p) = True-overlap SizeP{} _   = True-overlap _ SizeP{}   = True--- dot patterns always overlap (safe approximation)-overlap (DotP _) _ = True-overlap _ (DotP _) = 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 ps ps' = and $ zipWith overlap ps ps'---- | @exprToPattern@ is used in the termination checker to convert---   dot patterns into proper patterns.-exprToPattern :: Expr -> Maybe Pattern-exprToPattern (Def (DefId (ConK co) n)) = return $ ConP pi n []-  where pi = PatternInfo co False False -- not irrefutable (TODO: good enough?)-exprToPattern (Var n)       = return $ VarP n-exprToPattern (Pair e e')   = PairP <$> exprToPattern e <*> exprToPattern e'-exprToPattern (Succ e)      = SuccP <$> exprToPattern e-exprToPattern (Proj Post n) = return $ ProjP n-exprToPattern (App f e)     = patApp ==<< (exprToPattern f, exprToPattern e)--- exprToPattern (Infty)    = return $ DotP Infty -- leads to non-term in compareExpr-exprToPattern _ = fail "exprToPattern"---- | Only constructor patterns can be applied to a pattern.-patApp :: Pattern -> Pattern -> Maybe Pattern-patApp (ConP co n ps) p = Just $ ConP co n (ps ++ [p])-patApp _              _ = 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 = fromAllWriter . exprToDotPat'--exprToDotPat' :: Expr -> Writer All Pattern-exprToDotPat' e = do-  let fallback = tell (All False) >> return (DotP e)-  case e of-    Def (DefId (ConK co) n) -> return $ ConP pi n [] where-      pi = PatternInfo co False False -- not irrefutable (TODO: good enough?)-    Proj Post n -> return $ ProjP n-    Var n       -> return $ VarP n-    Pair e e'   -> PairP <$> exprToDotPat' e <*> exprToDotPat' e'-    Infty       -> return $ DotP Infty-    Succ e      -> SuccP <$> exprToDotPat' e-    App f e     -> maybe fallback return =<< do-      patApp <$> exprToDotPat' f <*> exprToDotPat' 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--}-    _ -> fallback--patternToExpr :: Pattern -> Expr-patternToExpr (VarP n)       = Var n-patternToExpr (SizeP m n)    = Var n-patternToExpr (ConP pi n ps) = List.foldl App (con (coPat pi) n) (List.map patternToExpr ps)--- patternToExpr (ConP co n ps) = Con co n `App` (List.map patternToExpr ps)-patternToExpr (PairP p p')   = Pair (patternToExpr p) (patternToExpr p')-patternToExpr (SuccP p)      = Succ (patternToExpr p)-patternToExpr (UnusableP p)  = patternToExpr p-patternToExpr (ProjP n)      = Proj Post n-patternToExpr (DotP e)       = e -- cannot put Irr here because introPatType wants to compute the value of a dot pattern (after all bindings have been introduced)-patternToExpr (ErasedP p)    = erasedExpr $ patternToExpr p-patternToExpr (AbsurdP)      = Irr---- | Dot all constructor subpatterns.  Used when expanding a dotted patsyn.-dotConstructors :: Pattern -> Pattern-dotConstructors p =-  case p of-    ConP pi c ps -> ConP pi{ dottedPat = True } c $ List.map dotConstructors ps-    PairP p1 p2  -> PairP (dotConstructors p1) (dotConstructors p2)-    _            -> p---- admissible pattern ---------------------------------------------------- completeP is used in admPattern, should not be True for UnusableP-completeP :: Pattern -> Bool-completeP (DotP _) = True-completeP (VarP _) = True-completeP SizeP{}  = False -- True-completeP (UnusableP p) = completeP p-completeP (ErasedP p)   = completeP p-completeP _ = False--isDotPattern :: Pattern -> Bool-isDotPattern (DotP _ ) = True-isDotPattern _ = False---- isSuccessorPattern is used in admPattern, should not be True for UnusableP-isSuccessorPattern :: Pattern -> Bool-isSuccessorPattern (SuccP _)   = True-isSuccessorPattern (DotP e)    = isSuccessor e-isSuccessorPattern (ErasedP p) = isSuccessorPattern p-isSuccessorPattern _ = False--isSuccessor :: Expr -> Bool-isSuccessor (Ann e)  = isSuccessor (unTag e)-isSuccessor (Succ e) = True-isSuccessor _        = False--shallowSuccP :: Pattern -> Bool-shallowSuccP p = case p of-     (SuccP p)   -> isVarP p-     (ErasedP p) -> shallowSuccP p-     (DotP e)    -> shallowSuccE e-     _           -> False--   where isVarP (VarP _)         = True-         isVarP (DotP e)         = isVarE e-         isVarP (ErasedP p)      = isVarP p-         isVarP _                = False--         isVarE (Ann e)          = isVarE (unTag e)-         isVarE (Var _)          = True-         isVarE _                = False--         shallowSuccE (Ann e)    = shallowSuccE (unTag e)-         shallowSuccE (Succ e)   = isVarE e-         shallowSuccE _          = False---- telescopes -------------------------------------------------------------- construction---- | typeToTele ((x : A) -> (y : B) -> C) = ([(x,A),(y,B)], C)-typeToTele :: Type -> (Telescope, Type)-typeToTele = typeToTele' (-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' k t = mapFst Telescope $ ttt k 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 k (Quant Pi tb t2) tel | k /= 0 = ttt (k-1) t2 (tb : tel)-      ttt k t tel = (reverse tel, t)------ modification--instance LensDec Telescope where-  getDec   = error "getDec not defined for Telescope"-  mapDec f = Telescope . List.map (mapDec f) . telescope------ destruction--teleLam :: Telescope -> Expr -> Expr-teleLam tel e = foldr (uncurry Lam) e $-  List.map (\ tb -> (decor $ boundDom tb, boundName tb)) $ telescope tel--teleToType' :: (Dec -> Dec) -> Telescope -> Type -> Type-teleToType' mod tel t = foldr (\ tb -> pi (mapDec mod tb)) t $ telescope tel-{--teleToType' mod []       t = t-teleToType' mod (tb:tel) t = Pi (mapDec mod tb) (teleToType' mod tel t)--}--teleToType :: Telescope -> Type -> Type-teleToType = teleToType' id--teleToTypeErase :: Telescope -> Type -> Type-teleToTypeErase = teleToType' demote -- (\ dec -> dec { erased = True })--adjustTopDecs :: (Dec -> Dec) -> Type -> Type-adjustTopDecs f t = teleToType' f tel core where-  (tel, core) = typeToTele t--teleToTypeM :: (Applicative m) => (Dec -> m Dec) -> Telescope -> Type -> m Type-teleToTypeM mod tel t =-  foldr (\ tb mt -> pi <$> mapDecM mod tb <*> mt) (pure t) $ telescope tel--adjustTopDecsM :: (Applicative m) => (Dec -> m Dec) -> Type -> m Type-adjustTopDecsM f t = teleToTypeM f tel core where-  (tel, core) = typeToTele 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----}
− Abstract.hs-boot 
@@ -1,4 +0,0 @@-module Abstract where--data TBinding a-
− Collection.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}--module Collection where--import Data.List as List-import Data.Monoid--import Data.Set (Set)-import qualified Data.Set as Set--class Monoid c => Collection c e | c -> e where-{--  empty     :: c-  append    :: c -> c -> c-  concat    :: [c] -> c--}-  singleton :: e -> c-  delete    :: e -> c -> c-  (\\)      :: c -> c -> c--instance Eq a => Collection [a] a where-{--  empty     = []-  append    = (++)-  concat    = List.concat--}-  singleton = (:[])-  delete    = List.delete-  (\\)      = (List.\\)--instance Ord a => Collection (Set a) a where-{--  empty     = Set.empty-  append    = Set.union-  concat    = Set.unions--}-  singleton = Set.singleton-  delete    = Set.delete-  (\\)      = (Set.\\)
− Concrete.hs 
@@ -1,324 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--- concrete syntax-module Concrete where--import Prelude hiding (null)--import Util-import Abstract (Co,Sized,PiSigma(..),Decoration(..),Dec,Override(..),Measure(..),Bound(..),HasPred(..),LtLe(..),polarity)-import qualified Abstract as A-import Polarity---- | Concrete names.-data Name = Name { theName :: String }-  deriving (Eq,Ord)--instance Show Name where-  show (Name n) = n---- | Possibly qualified names.-data QName-  = Qual  { qual :: Name, name :: Name }  -- ^ @X.x@ e.g. qualified constructor.-  | QName { name :: Name }                -- ^ @x@.-  deriving (Eq,Ord)--unqual (QName n) = n--instance Show QName where-  show (Qual m n) = show m ++ "." ++ show n-  show (QName n)  = show n--set0 = Set Zero-ident n = Ident (QName n)---- | Concrete expressions syntax.-data Expr-  = Set Expr                        -- ^ Universe @Set e@; @Set@ for @Set 0@.-  | CoSet Expr-  | Size                            -- ^ @Size@ type of sizes.-  | Succ Expr                       -- ^ @$e@.-  | Zero                            -- ^ @0@.-  | Infty                           -- ^ @#@.-  | Max                             -- ^ @max@.-  | Plus Expr Expr                  -- ^ @e + e'@.-  | RApp Expr Expr                  -- ^ @e |> f@.-  | App Expr [Expr]                 -- ^ @f e1 ... en@ or @f <| e@.-  | Lam Name Expr                   -- ^ @\ x -> e@.-  | Case Expr (Maybe Type) [Clause] -- ^ @case e : A { cls }@.-  | LLet LetDef Expr                -- ^ @let x = e in e'@ local let.-  | Quant PiSigma Telescope Expr    -- ^ @(x : A) -> B@, @[x : A] -> B@, @(x : A) & B@.-  | Pair Expr Expr                  -- ^ @e , e'@.-  | Record [([Name],Expr)]          -- ^ @record { x = e, x' y = e' }@.-  | Proj Name                       -- ^ @.x@.-  | Ident QName                     -- ^ @x@ or @D.c@.-  | Unknown                         -- ^ @_@.-  | Sing Expr Expr                  -- ^ @<e : A>@ singleton type.---  | EBind TBind Expr                -- ^ @[x : A] B@-  deriving (Eq)--data LetDef = LetDef-  { letDefDec :: Dec-  , letDefName :: Name-  , letDefTel  ::  Telescope-  , letDefType :: (Maybe Type)-  , letDefExpr :: Expr-  } deriving (Eq, Show)--instance Show Expr where-    show = prettyExpr--instance HasPred Expr where-  predecessor (Succ e) = Just e-  predecessor _ = Nothing--data Declaration-  = DataDecl Name Sized Co Telescope Type [Constructor]-      [Name] -- list of field names-  | RecordDecl Name Telescope Type Constructor-      [Name] -- list of field names-  | FunDecl Co TypeSig [Clause]-  | LetDecl Bool LetDef -- True = if eval---  | LetDecl Bool Name Telescope (Maybe Type) Expr -- True = if eval-  | PatternDecl Name [Name] Pattern-  | MutualDecl [Declaration]-  | OverrideDecl Override [Declaration] -- fail etc.-    deriving (Eq,Show)--data TypeSig = TypeSig Name Type-             deriving (Eq)--instance Show TypeSig where-  show (TypeSig n t) = show n ++ " : " ++ show t--type Type = Expr--data Constructor = Constructor-  { conName :: Name-  , conTel  :: Telescope-  , conType :: Maybe Type -- can be omitted *but* for families-  } deriving (Eq)--instance Show Constructor where-  show (Constructor n tel (Just t)) = show n ++ " " ++ show tel ++ " : " ++ show t-  show (Constructor n tel  Nothing) = show n ++ " " ++ show tel--type TBind = TBinding Type-type LBind = TBinding (Maybe Type)  -- possibly domain-free--data TBinding a = TBind-  { boundDec   :: Dec-  , boundNames :: [Name] -- [] if no name is given, then its a single bind-  , boundType  :: a-  }-  | TBounded  -- bounded quantification-  { boundDec   :: Dec-  , boundName  :: Name -- [] if no name is given, then its a single bind-  , ltle       :: LtLe-  , upperBound :: Expr---  , boundMType :: Maybe Type -- type is inferred from upperBound-  }-  | TMeasure (Measure Expr)-  | TBound (Bound Expr)---  | TSized { boundName :: Name } -- the size parameter of a sized record-    deriving (Eq,Show)--type Telescope = [TBind]--data DefClause = DefClause-   Name         -- function identifier-   [Elim]-   (Maybe Expr) -- Nothing for absurd pattern clause- deriving (Eq,Show)--data Elim-  = EApp Pattern          -- application to a pattern-  | EProj Name [Pattern]  -- projection with arguments-    deriving (Eq,Show)--data Clause = Clause-                (Maybe Name) -- Just funId | Nothing for case clauses-                [Pattern]-                (Maybe Expr) -- Nothing for absurd pattern clause-            deriving (Eq,Show)--data Pattern-  = ConP Bool QName [Pattern] -- ^ @(c ps)@ if @False; @(.c ps)@ if @True@.-  | PairP Pattern Pattern     -- ^ @(p, p')@-  | SuccP Pattern             -- ^ @($ p)@-  | DotP Expr                 -- ^ @.e@-  | IdentP QName              -- ^ @x@ or @c@ or @D.c@.-  | SizeP Expr Name           -- ^ @(x > y)@ or @y < #@ or ...-  | AbsurdP                   -- ^ @()@-    deriving (Eq,Show)--type Case = (Pattern,Expr)---- | Used in Parser.-patApp :: Pattern -> [Pattern] -> Pattern-patApp (IdentP c)         ps' = ConP False  c ps'-patApp (ConP dotted c ps) ps' = ConP dotted c (ps ++ ps')---- * Pretty printing.--prettyLBind :: LBind -> String--- prettyLBind (TSized x)                   = prettyTBind False (TSized x)-prettyLBind (TMeasure mu)                = prettyTBind False (TMeasure mu)-prettyLBind (TBound (Bound ltle mu mu')) = prettyTBind False (TBound (Bound ltle mu mu'))-prettyLBind (TBounded dec x ltle e)      = prettyTBind False (TBounded dec x ltle e)-prettyLBind (TBind dec xs (Just t))      = prettyTBind False (TBind dec xs t)-prettyLBind (TBind dec xs Nothing) =-  if erased dec then addPol False $ brackets binding-   else addPol True binding-  where binding = Util.showList " " show xs-        pol = polarity dec-        addPol b x = if pol==defaultPol-                      then x-                      else show pol ++ (if b then " " else "") ++ x---prettyTBind :: Bool -> TBind -> String--- prettyTBind inPi (TSized x) = parens ("sized " ++ x)-prettyTBind inPi (TMeasure mu) = "|" ++-  (Util.showList ","  prettyExpr (measure mu)) ++ "|"-prettyTBind inPi (TBound (Bound ltle mu mu')) = "|" ++-  (Util.showList ","  prettyExpr (measure mu))  ++ "| " ++ show ltle ++ " |" ++-  (Util.showList ","  prettyExpr (measure mu')) ++ "|"-prettyTBind inPi (TBind dec xs t) =-  if erased dec then addPol False $ brackets binding-   else if (null xs) then addPol True s-   else addPol (not inPi) $ (if inPi then parens else id) binding-  where s = prettyExpr t-        binding = if null xs then s else-          foldr (\ x s -> show x ++ " " ++ s) (": " ++ s) xs-        pol = polarity dec-        addPol b x = if pol==defaultPol-                      then x-                      else show pol ++ (if b then " " else "") ++ x-prettyTBind inPi (TBounded dec x ltle e) =-  if erased dec then addPol False $ brackets binding-   else addPol (not inPi) $ (if inPi then parens else id) binding-  where binding = show x ++ " < " ++ prettyExpr e-        pol = polarity dec-        addPol b x = if pol==defaultPol-                      then x-                      else show pol ++ (if b then " " else "") ++ x-{--prettyTBind :: Bool -> TBind -> String-prettyTBind inPi (TBind dec x t) =-  if erased dec then addPol False $ brackets binding-   else if x=="" then addPol True s-   else addPol (not inPi) $ (if inPi then parens else id) binding-  where s = prettyExpr t-        binding = if x == "" then s else x ++ " : " ++ s-        pol = polarity dec-        addPol b x = if pol==Mixed then x-                      else show pol ++ (if b then " " else "") ++ x--}-prettyLetBody :: String -> Expr -> String-prettyLetBody s e = parens $ s ++ " in " ++ prettyExpr e--prettyLetAssign :: String -> Expr -> String-prettyLetAssign s e = "let " ++ s ++ " = " ++ prettyExpr e--prettyLetDef :: LetDef -> String-prettyLetDef (LetDef dec n [] mt e) = prettyLetAssign (prettyLBind tb) e-  where tb = TBind dec [n] mt-prettyLetDef (LetDef dec n tel mt e) = prettyLetAssign s e-  where s = prettyDecId dec n ++ " " ++ prettyTel False tel ++ prettyMaybeType mt--prettyDecId :: Dec -> Name -> String-prettyDecId dec x-  | erased dec = brackets $ show x-  | otherwise  =-     let pol = polarity dec-     in  if pol == defaultPol then show x else show pol ++ show x--prettyTel :: Bool -> Telescope -> String-prettyTel inPi = Util.showList " " (prettyTBind inPi)--prettyMaybeType = maybe "" $ \ t -> " : " ++ prettyExpr t--prettyExpr :: Expr -> String-prettyExpr e =-    case e of-      -- Type e          -> "Type " ++ prettyExpr e-      CoSet e         -> "CoSet " ++ prettyExpr e-      Set e         -> "CoSet " ++ prettyExpr e-      -- Set             -> "Set"-      Size            -> "Size"-      Max             -> "max"-      Succ e          -> "$ " ++ prettyExpr e -- ++ ")"-      Zero            -> "0"-      Infty           -> "#"-      Plus e1 e2      -> "(" ++ prettyExpr e1 ++ " + " ++  prettyExpr e2 ++ ")"-      Pair e1 e2      -> "(" ++ prettyExpr e1 ++ " , " ++  prettyExpr e2 ++ ")"-      App e1 el       -> "(" ++ prettyExprs (e1:el) ++ ")"-      Lam x e1        -> "(\\" ++ show x ++ " -> " ++ prettyExpr e1 ++ ")"-      Case e Nothing cs -> "case " ++ prettyExpr e ++ " { " ++ Util.showList "; " prettyCase cs ++ " } "-      Case e (Just t) cs -> "case " ++ prettyExpr e ++ " : " ++ prettyExpr t ++ " { " ++ Util.showList "; " prettyCase cs ++ " } "-      LLet letdef e -> prettyLetBody (prettyLetDef letdef) e-{--      LLet tb e1 e2 -> "(let " ++ prettyLBind tb ++ " = " ++ prettyExpr e1 ++ " in " ++ prettyExpr e2 ++ ")"--}-      Record rs       -> "record {" ++ Util.showList "; " prettyRecordLine rs ++ "}"-      Proj n          -> "." ++ show n-      Ident n         -> show n-      Unknown         -> "_"-      Sing e t        -> "<" ++ prettyExpr e ++ " : " ++ prettyExpr t ++ ">"---      Quant pisig tb t2 -> parens $ prettyTBind True tb-      Quant pisig tel t2 -> parens $ prettyTel True tel-                                  ++ " " ++ show pisig ++ " " ++ prettyExpr t2--prettyRecordLine (xs, e) = Util.showList " " show xs ++ " = " ++ prettyExpr e--prettyCase (Clause Nothing [p] Nothing)  = prettyPattern p-prettyCase (Clause Nothing [p] (Just e)) = prettyPattern p ++ " -> " ++ prettyExpr e--prettyPattern :: Pattern -> String-prettyPattern (ConP dotted c ps) = parens $ foldl (\ acc p -> acc ++ " " ++ prettyPattern p) (if dotted then "." ++ show c else show c) ps-prettyPattern (PairP p1 p2) = parens $ prettyPattern p1 ++ ", " ++-                                prettyPattern p2-prettyPattern (SuccP p)   = parens $ "$ " ++ prettyPattern p-prettyPattern (DotP e)    = "." ++ prettyExpr e-prettyPattern (IdentP x)  = show x-prettyPattern (SizeP e y) = parens $ prettyExpr e ++ " > " ++ show y-prettyPattern (AbsurdP)   = parens ""--prettyExprs :: [Expr] -> String-prettyExprs = Util.showList " " prettyExpr--prettyDecl (PatternDecl n ns p) = "pattern " ++ (Util.showList " " show (n:ns)) ++ " = " ++ prettyPattern p--teleToType :: Telescope -> Type -> Type-teleToType [] t = t-teleToType (tb:tel) t2 = Quant Pi [tb] (teleToType tel t2)---teleToType (PosTB dec n t:tel) t2 = Pi dec n t (teleToType tel t2)--typeToTele :: Type -> (Telescope, Type)-typeToTele (Quant Pi tel0 c) =-  let (tel, a) = typeToTele c in (tel0 ++ tel, a)-typeToTele a = ([],a)--{--teleToType :: Telescope -> Type -> Type-teleToType [] t = t-teleToType (tb:tel) t2 = Quant Pi tb (teleToType tel t2)---teleToType (PosTB dec n t:tel) t2 = Pi dec n t (teleToType tel t2)--typeToTele :: Type -> (Telescope, Type)-typeToTele = typeToTele' (-1)--typeToTele' :: Int -> Type -> (Telescope, Type)-typeToTele' k (Quant A.Pi tb c) | k /= 0 =-  let (tel, a) = typeToTele' (k-1) c in (tb:tel, a)-typeToTele' _ a = ([],a)--}--teleNames :: Telescope -> [Name]-teleNames tel = concat $ map tbindNames tel--tbindNames :: TBind -> [Name]-tbindNames TBind{ boundNames }   = boundNames-tbindNames TBounded{ boundName } = [boundName]--- tbindNames TSized{ boundName }   = [boundName]-tbindNames tb = error $ "tbindNames (" ++ show tb ++ ")"
− Eval.hs 
@@ -1,2359 +0,0 @@-{-# LANGUAGE TupleSections, FlexibleInstances, FlexibleContexts, NamedFieldPuns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-}---- Activate this flag if i < $i should only hold for i < #.--- #define STRICTINFTY--module Eval where--import Prelude hiding (mapM, null, pi)--import Control.Applicative-import Control.Monad.Identity hiding (mapM)-import Control.Monad.State hiding (mapM)-import Control.Monad.Except hiding (mapM)-import Control.Monad.Reader hiding (mapM)--import qualified Data.Array as Array-import Data.Maybe -- fromMaybe-import Data.Monoid hiding ((<>))-import Data.List as List hiding (null) -- find-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Foldable (foldMap)-import Data.Traversable (Traversable, mapM, traverse)-import qualified Data.Traversable as Traversable--import Debug.Trace (trace)--import Abstract-import Polarity as Pol-import Value-import TCM-import PrettyTCM-import Warshall  -- positivity checking--import TraceError-import Util---traceEta msg a = a -- trace msg a-traceEtaM msg = return () -- traceM msg-{--traceEta msg a = trace msg a-traceEtaM msg = traceM msg--}--traceRecord msg a = a-traceRecordM msg = return ()---traceMatch msg a = a -- trace msg a-traceMatchM msg = return () -- traceM msg-{--traceMatch msg a = trace msg a-traceMatchM msg = traceM msg--}--traceLoop msg a = a -- trace msg a-traceLoopM msg = return () -- traceM msg-{--traceLoop msg a = trace msg a-traceLoopM msg = traceM msg--}--traceSize msg a = a -- trace msg a-traceSizeM msg = return () -- traceM msg-{--traceSize msg a = trace msg a-traceSizeM msg = traceM msg--}--failValInv :: (MonadError TraceError m) => Val -> m a-failValInv v = throwErrorMsg $ "internal error: value " ++ show v ++ " violates representation invariant"---- evaluation with rewriting ---------------------------------------{---Rewriting rules have the form--  blocked --> pattern--this means that at the root, at most one rewriting step is possible.-Rewriting rules are considered computational, since they trigger new-(symbolic) computations.  At least they have to be applied in--- pattern matching-- equality checking-When a new rule b --> p is added, b should be in --> normal form.-Otherwise there could be inconsistencies, like adding both rules--  b --> true-  b --> false--If after adding b --> true b is rewritten to nf, then the second rule-would be true --> false, which can be captured by MiniAgda.--Also, after adding a new rule, it could be used to rewrite the old rules.--Implementation:--- add a set of local rewriting rules to the context (not to the state)-- keep values in --> weak head normal form-- untyped equality test between values-- -}--class Reval a where-  reval' :: Valuation -> a -> TypeCheck a-  reval  :: a -> TypeCheck a-  reval = reval' emptyVal--instance Reval a => Reval (Maybe a) where-  reval' valu ma = Traversable.traverse (reval' valu) ma--instance Reval b => Reval (a,b) where-  reval' valu (x,v) = (x,) <$> reval' valu v--instance Reval a => Reval [a] where-  reval' valu vs = mapM (reval' valu) vs--instance Reval Env where-  reval' valu (Environ rho mmeas) =-   flip Environ mmeas <$> reval' valu rho-   -- no need to reevaluate mmeas, since only sizes---- | When combining valuations, the old one takes priority.---   @[sigma][tau]v = [[sigma]tau]v@-instance Reval Valuation where-  reval' valu (Valuation valu') = Valuation . (++ valuation valu) <$>-    reval' valu valu'--instance Reval a => Reval (Measure a) where-  reval' valu beta = Traversable.traverse (reval' valu) beta--instance Reval a => Reval (Bound a) where-  reval' valu beta = Traversable.traverse (reval' valu) beta--instance Reval Val where-  reval' valu u = traceLoop ("reval " ++ show u) $ do-    let reval v   = reval' valu v-        reEnv rho = reval' valu rho-        reFun fv  = reval' valu fv-    case u of-      VSort (CoSet v) -> VSort . CoSet <$> reval v-      VSort{} -> return u-      VInfty  -> return u-      VZero   -> return u-      VSucc{} -> return u  -- no rewriting in size expressions-      VMax{}  -> return u-      VPlus{}  -> return u-      VProj{}  -> return u -- cannot rewrite projection-      VPair v1 v2 -> VPair <$> reval v1 <*> reval v2-      VRecord ri rho -> VRecord ri <$> mapAssocM reval rho--      VApp v vl          -> do-        v'  <- reval v-        vl' <- mapM reval vl-        w   <- foldM app v' vl'-        reduce w  -- since we only have rewrite rules at base types-                  -- we do not need to reduces prefixes of w--      VDef{} -> return $ VApp u [] -- restore invariant-                                   -- CAN'T rewrite defined fun/data-      VGen i -> reduce (valuateGen i valu)  -- CAN rewrite variable--      VCase v tv env cl -> do-        v' <- reval v-        tv' <- reval tv-        env' <- reEnv env-        evalCase v' tv' env' cl--      VBelow ltle v         -> VBelow ltle <$> reval v-      VGuard beta v         -> VGuard <$> reval beta <*> reval v-      VQuant pisig x dom fv ->-        VQuant pisig x-          <$> Traversable.mapM reval dom-          <*> reFun fv-    {--      VQuant pisig x dom env b -> do-        dom' <- Traversable.mapM reval dom-        env' <- reEnv env-        return $ VQuant pisig x dom' env' b-    -}-      VConst v           -> VConst <$> reval' valu v-      VLam x env e       -> flip (VLam x) e <$> reval' valu env-      VAbs x i v valu'   -> VAbs x i v <$> reval' valu valu'-      VUp v tv           -> up False ==<< (reval' valu v, reval' valu tv)  -- do not force at this point--      VClos env e        -> do env' <- reEnv env-                               return $ VClos env' e--      VMeta i env k      -> do env' <- reEnv env-                               return $ VMeta i env' k--      VSing v tv         -> vSing ==<< (reval v, reval tv)-      VIrr -> return u-      v -> throwErrorMsg $ "NYI : reval " ++ show v----- TODO: singleton Sigma types--- <t : Pi x:a.f> = Pi x:a <t x : f x>--- <t : A -> B  > = Pi x:A <t x : B>--- <t : <t' : a>> = <t' : a>-vSing :: Val -> TVal -> TypeCheck TVal-vSing v (VQuant Pi x' dom fv) = do-  let x = fresh $ if emptyName x' then "xSing#" else suggestion x'-  VQuant Pi x dom <$> do-  underAbs_ x dom fv $ \ i xv bv -> do-    v <- app v xv-    vAbs x i <$> vSing v bv-vSing _ tv@(VSing{}) = return $ tv-vSing v tv           = return $ VSing v tv-{---- This is a bit of a hack (finding a fresh name)--- <t : Pi x:a.b> = Pi x:a <t x : b>--- <t : Pi x:a.f> = Pi x:a <t x : f x>--- <t : <t' : a>> = <t' : a>-vSing :: Val -> TVal -> TVal-vSing v (VQuant Pi x dom env b)-  | not (emptyName x) = -- xv `seq` x' `seq`-     (VQuant Pi x dom (update env xv v) $ Sing (App (Var xv) (Var x)) b)-      where xv = fresh ("vSing#" ++ suggestion x)-vSing v (VQuant Pi x dom env b) =---  | otherwise =-     (VQuant Pi x' dom (update env xv v) $ Sing (App (Var xv) (Var x')) b')-      where xv = fresh ("vSing#" ++ suggestion x)-            x' = fresh $ if emptyName x then "xSing#" else suggestion x-            b' = parSubst (\ y -> Var $ if y == x then x' else y) b-vSing _ tv@(VSing{}) = tv-vSing v tv           = VSing v tv--}---- reduce the root of a value-reduce :: Val -> TypeCheck Val-reduce v = traceLoop ("reduce " ++ show v) $- do-  rewrules <- asks rewrites-  mr <- findM (\ rr -> equal v (lhs rr)) rewrules-  case mr of-     Nothing -> return v-     Just rr -> traceRew ("firing " ++ show rr) $ return (rhs rr)---- equal v v'  tests values for untyped equality--- precond: v v' are in --> whnf-equal :: Val -> Val -> TypeCheck Bool-equal u1 u2 = traceLoop ("equal " ++ show u1 ++ " =?= " ++ show u2) $-  case (u1,u2) of-    (v1,v2) | v1 == v2 -> return True -- includes all size expressions---    (VSucc v1, VSucc v2) -> equal v1 v2  -- NO REDUCING NECC. HERE (Size expr)-    (VApp v1 vl1, VApp v2 vl2) ->-       (equal v1 v2) `andLazy` (equals' vl1 vl2)-    (VQuant pisig1 x1 dom1 fv1, VQuant pisig2 x2 dom2 fv2) | pisig1 == pisig2 ->-       andLazy (equal (typ dom1) (typ dom2)) $  -- NO RED. NECC. (Type)-         new x1 dom1 $ \ vx -> equal ==<< (app fv1 vx, app fv2 vx)-    (VProj _ p, VProj _ q) -> return $ p == q-    (VPair v1 w1, VPair v2 w2) -> (equal v1 v2) `andLazy` (equal w1 w2)-    (VBelow ltle1 v1, VBelow ltle2 v2) | ltle1 == ltle2 -> equal v1 v2-    (VSing v1 tv1, VSing v2 tv2) -> (equal v1 v2) `andLazy` (equal tv1 tv2)--    (fv1, fv2) | isFun fv1, isFun fv2 -> -- PROBLEM: DOM. MISSING, CAN'T "up" fresh variable-      addName (bestName [absName fv1, absName fv2]) $ \ vx ->-        equal ==<< (app fv1 vx, app fv2 vx)-{--    (VLam x1 env1 b1, VLam x2 env2 b2) -> -- PROBLEM: DOMAIN MISSING-         addName x1 $ \ vx -> do          -- CAN'T "up" fresh variable-               do v1 <- whnf (update env1 x1 vx) b1-                  v2 <- whnf (update env2 x2 vx) b2-                  equal v1 v2--}-    (VRecord ri1 rho1, VRecord ri2 rho2) | notDifferentNames ri1 ri2 -> and <$>-      zipWithM (\ (n1,v1) (n2,v2) -> ((n1 == n2) &&) <$> equal' v1 v2) rho1 rho2-    _ -> return False--notDifferentNames :: RecInfo -> RecInfo -> Bool-notDifferentNames (NamedRec _ n _ _) (NamedRec _ n' _ _) = n == n'-notDifferentNames _ _ = True--equals' :: [Val] -> [Val] -> TypeCheck Bool-equals' [] []             = return True-equals' (w1:vs1) (w2:vs2) = (equal' w1 w2) `andLazy` (equals' vs1 vs2)-equals' vl1 vl2           = return False--equal' w1 w2 = whnfClos w1 >>= \ v1 -> equal v1 =<< whnfClos w2--{- LEADS TO NON-TERMINATION--- equal' v1 v2  tests values for untyped equality--- v1 v2 are not necessarily in --> whnf-equal' v1 v2 = do-  v1' <- reduce v1-  v2' <- reduce v2-  equal v1' v2'--}---- normalization -------------------------------------------------------reify :: Val -> TypeCheck Expr-reify v = reify' (5, True) v---- normalize to depth m-reify' :: (Int, Bool) -> Val -> TypeCheck Expr-reify' m v0 = do-  let reify = reify' m  -- default recursive call-  case v0 of-    (VClos rho e)        -> whnf rho e >>= reify-    (VZero)              -> return $ Zero-    (VInfty)             -> return $ Infty-    (VSucc v)            -> Succ <$> reify v-    (VMax vs)            -> maxE <$> mapM reify vs-    (VPlus vs)           -> Plus <$> mapM reify vs-    (VMeta x rho n)      -> -- error $ "cannot reify meta-variable " ++ show v0-                            return $ iterate Succ (Meta x) !! n-    (VSort (CoSet v))    -> Sort . CoSet <$> reify v-    (VSort s)            -> return $ Sort $ vSortToSort s-    (VBelow ltle v)      -> Below ltle <$> reify v-    (VQuant pisig x dom fv) -> do-          dom' <- Traversable.mapM reify dom-          underAbs_ x dom fv $ \ k xv vb -> do-            let x' = unsafeName (suggestion x ++ "~" ++ show k)-            piSig pisig (TBind x' dom') <$> reify vb-    (VSing v tv)         -> liftM2 Sing (reify v) (reify tv)-    fv | isFun fv        -> do-          let x = absName fv-          addName x $ \ xv@(VGen k) -> do-            vb <- app fv xv-            let x' = unsafeName (suggestion x ++ "~" ++ show k)-            Lam defaultDec x' <$> reify vb  -- TODO: dec!?-    (VUp v tv)           -> reify v -- TODO: type directed reification-    (VGen k)             -> return $ Var $ unsafeName $ "~" ++ show k-    (VDef d)             -> return $ Def d-    (VProj fx n)         -> return $ Proj fx n-    (VPair v1 v2)        -> Pair <$> reify v1 <*> reify v2-    (VRecord ri rho)     -> Record ri <$> mapAssocM reify rho-    (VApp v vl)          -> if fst m > 0 && snd m-                             then force v0 >>= reify' (fst m - 1, True) -- forgotten the meaning of the boolean, WAS: False)-                             else let m' = (fst m, True) in-                               liftM2 (foldl App) (reify' m' v) (mapM (reify' m') vl)-    (VCase v tv rho cls) -> do-          e <- reify v-          t <- reify tv-          return $ Case e (Just t) cls -- TODO: properly evaluate clauses!!-    (VIrr)               -> return $ Irr-    v -> failDoc (text "Eval.reify" <+> prettyTCM v <+> text "not implemented")---- printing (conversion to Expr) ----------------------------------------- similar to reify-toExpr :: Val -> TypeCheck Expr-toExpr v =-  case v of-    VClos rho e     -> closToExpr rho e-    VZero           -> return $ Zero-    VInfty          -> return $ Infty-    (VSucc v)       -> Succ <$> toExpr v-    VMax vs         -> maxE <$> mapM toExpr vs-    VPlus vs        -> Plus <$> mapM toExpr vs-    VMeta x rho n   -> metaToExpr x rho n-    VSort s         -> Sort <$> mapM toExpr s-{--    VSort (CoSet v) -> (Sort . CoSet) <$> toExpr v-    VSort (Set v)   -> (Sort . Set) <$> toExpr v-    VSort (SortC s) -> return $ Sort (SortC s)--}-    VMeasured mu bv -> pi <$> (TMeasure <$> mapM toExpr mu) <*> toExpr bv-    VGuard beta bv  -> pi <$> (TBound <$> mapM toExpr beta) <*> toExpr bv-    VBelow Le VInfty -> return $ Sort $ SortC Size-    VBelow ltle bv  -> Below ltle <$> toExpr bv-    VQuant pisig x dom fv -> underAbs' x fv $ \ xv bv ->-      piSig pisig <$> (TBind x <$> mapM toExpr dom) <*> toExpr bv-    VSing v tv      -> Sing <$> toExpr v <*> toExpr tv-    fv | isFun fv   -> addName (absName fv) $ \ xv -> toExpr =<< app fv xv-{--    VLam x rho e    -> addNameEnv x rho $ \ x rho ->-      Lam defaultDec x <$> closToExpr rho e--}-    VUp v tv        -> toExpr v-    VGen k          -> Var <$> nameOfGen k-    VDef d          -> return $ Def d-    VProj fx n      -> return $ Proj fx n-    VPair v1 v2     -> Pair <$> toExpr v1 <*> toExpr v2-    VRecord ri rho  -> Record ri <$> mapAssocM toExpr rho-    VApp v vl       -> liftM2 (foldl App) (toExpr v) (mapM toExpr vl)-    VCase v tv rho cls -> Case <$> toExpr v <*> (Just <$> toExpr tv) <*> mapM (clauseToExpr rho) cls-    VIrr            -> return $ Irr--{--addBindEnv :: TBind -> Env -> (Env -> TypeCheck a) -> TypeCheck a-addBindEnv (TBind x dom) rho cont = do-  let dom' = fmap (VClos rho) dom-  newWithGen x dom' $ \ k _ ->-    cont (update rho x (VGen k))--}--addNameEnv :: Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a---addNameEnv "" rho cont = cont "" rho-addNameEnv x rho cont = do-  let dom' = defaultDomain VIrr -- error $ "internal error: variable " ++ show x ++ " comes without domain"-  newWithGen x dom' $ \ k _ -> do-    x' <- nameOfGen k-    cont x' (update rho x (VGen k))--addPatternEnv :: Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a-addPatternEnv p rho cont =-  case p of-    VarP x       -> addNameEnv     x  rho $ cont . VarP -- \ x rho -> cont (VarP x) rho-    SizeP e x    -> addNameEnv     x  rho $ cont . VarP-    PairP p1 p2  -> addPatternEnv  p1 rho $ \ p1 rho ->-                     addPatternEnv p2 rho $ \ p2 rho -> cont (PairP p1 p2) rho-    ConP pi n ps -> addPatternsEnv ps rho $ cont . ConP pi n -- \ ps rho -> cont (ConP pi n ps) rho-    SuccP p      -> addPatternEnv  p  rho $ cont . SuccP-    UnusableP p  -> addPatternEnv  p  rho $ cont . UnusableP-    DotP e       -> do { e <- closToExpr rho e ; cont (DotP e) rho }-    AbsurdP      -> cont AbsurdP rho-    ErasedP p    -> addPatternEnv  p  rho $ cont . ErasedP--addPatternsEnv :: [Pattern] -> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a-addPatternsEnv []     rho cont = cont [] rho-addPatternsEnv (p:ps) rho cont =-  addPatternEnv p rho $ \ p rho ->-    addPatternsEnv ps rho $ \ ps rho ->-      cont (p:ps) rho--{--class BindClosToExpr a where-  bindClosToExpr :: Env -> a -> (Env -> a -> TCM b) -> TCM b--instance ClosToExpr a => BindClosToExpr (TBinding a) where-  bindClosToExpr--}--class ClosToExpr a where-  closToExpr     :: Env -> a -> TypeCheck a-  bindClosToExpr :: Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b--  -- default : no binding-  closToExpr rho a = bindClosToExpr rho a $ \ rho a -> return a-  bindClosToExpr rho a cont = cont rho =<< closToExpr rho a--instance ClosToExpr a => ClosToExpr [a] where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (Maybe a) where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (Dom a) where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (Sort a) where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (Measure a) where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (Bound a) where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (Tagged a) where-  closToExpr = traverse . closToExpr--instance ClosToExpr a => ClosToExpr (TBinding a) where-  bindClosToExpr rho (TBind x a) cont = do-    a <- closToExpr rho a-    addNameEnv x rho $ \ x rho -> cont rho $ TBind x a-  bindClosToExpr rho (TMeasure mu) cont = cont rho . TMeasure =<< closToExpr rho mu-  bindClosToExpr rho (TBound beta) cont = cont rho . TBound =<< closToExpr rho beta--instance ClosToExpr Telescope where-  bindClosToExpr rho (Telescope tel) cont = loop rho tel $ \ rho -> cont rho . Telescope-    where-      loop rho []         cont = cont rho []-      loop rho (tb : tel) cont = bindClosToExpr rho tb $ \ rho tb ->-        loop rho tel $ \ rho tel -> cont rho $ tb : tel--instance ClosToExpr Expr where-  closToExpr rho e =-    case e of-      Sort s         -> Sort <$> closToExpr rho s-      Zero           -> return e-      Succ e         -> Succ <$> closToExpr rho e-      Infty          -> return e-      Max es         -> Max  <$> closToExpr rho es-      Plus es        -> Plus <$> closToExpr rho es-      Meta x         -> return e-      Var x          -> toExpr =<< whnf rho e-      Def d          -> return e-      Case e mt cls  -> Case <$> closToExpr rho e <*> closToExpr rho mt <*> mapM (clauseToExpr rho) cls-      LLet tb tel e1 e2 | null tel -> do-        e1 <- closToExpr rho e1-        bindClosToExpr rho tb $ \ rho tb -> LLet tb tel e1 <$> closToExpr rho e2-      Proj fx n      -> return e-      Record ri rs   -> Record ri <$> mapAssocM (closToExpr rho) rs-      Pair e1 e2     -> Pair <$> closToExpr rho e1 <*> closToExpr rho e2-      App e1 e2      -> App <$> closToExpr rho e1 <*> closToExpr rho e2-      Lam dec x e    -> addNameEnv x rho $ \ x rho ->-        Lam dec x <$> closToExpr rho e-      Below ltle e   -> Below ltle <$> closToExpr rho e-{--      Quant Pi tel mu@TMeasure{} e | null tel -> pi <$> closToExpr rho mu   <*> closToExpr rho e-      Quant Pi tel beta@TBound{} e | null tel -> pi <$> closToExpr rho beta <*> closToExpr rho e--}-      Quant piSig tb e -> bindClosToExpr rho tb $ \ rho tb -> Quant piSig tb <$> closToExpr rho e---       Quant piSig tel tb e -> bindClosToExpr rho tel $ \ rho tel ->---         bindClosToExpr rho tb $ \ rho tb -> Quant piSig tel tb <$> closToExpr rho e-      Sing e1 e2     -> Sing <$> closToExpr rho e1 <*> closToExpr rho e2-      Ann taggedE    -> Ann <$> closToExpr rho taggedE-      Irr            -> return e--metaToExpr :: Int -> Env -> Int -> TypeCheck Expr-metaToExpr x rho k = return $ iterate Succ (Meta x) !! k--clauseToExpr :: Env -> Clause -> TypeCheck Clause-clauseToExpr rho (Clause vtel ps me) = addPatternsEnv ps rho $ \ ps rho ->-   Clause vtel ps <$> mapM (closToExpr rho) me---- evaluation ------------------------------------------------------------ | Weak head normal form.---   Monadic, since it reads the globally defined constants from the signature.---   @let@s are expanded away.--whnf :: Env -> Expr -> TypeCheck Val-whnf env e = enter ("whnf " ++ show e) $-  case e of-    Meta i -> do let v = VMeta i env 0-                 traceMetaM $ "whnf meta " ++ show v-                 return v-    LLet (TBind x dom) tel e1 e2 | null tel -> do-      let v1 = mkClos env e1-      whnf (update env x v1) e2-{---- ALT: remove erased lambdas entirely-    Lam dec x e1 | erased dec -> whnf env e1-                 | otherwise -> return $ VLam x env e1--}-    Lam dec x e1 -> return $ vLam x env e1-    Below ltle e -> VBelow ltle <$> whnf env e-    Quant pisig (TBind x dom) b -> do-      dom' <- Traversable.mapM (whnf env) dom  -- Pi is strict in its first argument-      return $ VQuant pisig x dom' $ vLam x env b--    -- a measured type evaluates to-    -- * a bounded type if measure present in environment (rhs of funs)-    -- * otherwise to a measured type (lhs of funs)-    Quant Pi (TMeasure mu) b -> do-      muv <- whnfMeasure env mu-      bv  <- whnf env b -- not adding measure constraint to context!-      case (envBound env) of-        Nothing   -> return $ VMeasured muv bv-           -- throwErrorMsg $ "panic: whnf " ++ show e ++ " : no measure in environment " ++ show env-        Just muv' -> return $ VGuard (Bound Lt muv muv') bv--    Quant Pi (TBound (Bound ltle mu mu')) b -> do-          muv  <- whnfMeasure env mu-          muv' <- whnfMeasure env mu'-          bv   <- whnf env b  -- not adding measure constraint to context!-          return $ VGuard (Bound ltle muv muv') bv--    Sing e t  -> do tv <- whnf env t-                    sing env e tv--    Pair e1 e2 -> VPair <$> whnf env e1 <*> whnf env e2-    Proj fx n  -> return $ VProj fx n--    Record ri@(NamedRec Cons _ _ _) rs -> VRecord ri <$> mapAssocM (whnf env) rs--    -- coinductive and anonymous records are treated lazily:-    Record ri rs -> return $ VRecord ri $ mapAssoc (mkClos env) rs--{---- ALT: filter out all erased arguments from application-    App e1 el -> do v1 <- whnf env e1-                    vl <- liftM (filter (/= VIrr)) $ mapM (whnf env) el-                    app v1 vl--}-    App f e   -> do vf <- whnf env f-                    let ve = mkClos env e-                    app vf ve-{--    App e1 el -> do v1 <- whnf env e1-                    vl <- mapM (whnf env) el-                    app v1 vl--}--    Case e (Just t) cs -> do-      v  <- whnf env e-      vt <- whnf env t-      evalCase v vt env cs-                  -- trace ("case head evaluates to " ++ showVal v) $ return ()--    Sort s -> whnfSort env s >>= return . vSort-    Infty -> return VInfty-    Zero -> return VZero-    Succ e1 -> do v <- whnf env e1           -- succ is strict-                  return $ succSize v--    Max es  -> do vs <- mapM (whnf env) es   -- max is strict-                  return $ maxSize vs-    Plus es -> do vs <- mapM (whnf env) es   -- plus is strict-                  return $ plusSizes vs--    Def (DefId LetK n) -> do-        item <- lookupSymbQ n-        whnfClos (definingVal item)--    Def (DefId (ConK DefPat) n) -> whnfClos . definingVal =<< lookupSymbQ n---    Def (DefId (ConK DefPat) n) -> throwErrorMsg $ "internal error: whnf of defined pattern " ++ show n-    Def id   -> return $ vDef id-{--    Con co n -> return $ VCon co n--    Def n -> return $ VDef n--    Let n -> do sig <- gets signature-                let (LetSig _ v) = lookupSig n sig-                return v---                let (LetSig _ e) = lookupSig n sig---                whnf [] e--}-    Var y -> lookupEnv env y >>= whnfClos-    Ann e -> whnf env (unTag e) -- return VIrr -- NEED TO KEEP because of eta-exp!-    Irr -> return VIrr-    e   -> throwErrorMsg $ "NYI whnf " ++ show e--whnfMeasure :: Env -> Measure Expr -> TypeCheck (Measure Val)-whnfMeasure rho (Measure mu) = mapM (whnf rho) mu >>= return . Measure--whnfSort :: Env -> Sort Expr -> TypeCheck (Sort Val)-whnfSort rho (SortC c) = return $ SortC c-whnfSort rho (CoSet e) = whnf rho e >>= return . CoSet-whnfSort rho (Set e)   = whnf rho e >>= return . Set--whnfClos :: Clos -> TypeCheck Val-whnfClos v = -- trace ("whnfClos " ++ show v) $-  case v of-    (VClos e rho) -> whnf e rho-    -- (VApp (VProj Pre n) [u]) -> app u (VProj Post n) -- NO EFFECT-    (VApp (VDef (DefId FunK n)) vl) -> appDef n vl -- THIS IS TO SOLVE A PROBLEM-    v -> return v-{- THE PROBLEM IS that-  (tail (x Up Stream)) Up Stream is a whnf, because Up Stream is lazy-  in equality checking this is a problem when the Up is removed.--}---- evaluate in standard environment-whnf' :: Expr -> TypeCheck Val-whnf' e = do-  env <- getEnv-  whnf env e---- <t : Pi x:a.b> = Pi x:a <t x : b>--- <t : <t' : a>> = <t' : a>-sing :: Env -> Expr -> TVal -> TypeCheck TVal-sing rho e tv = do-  let v = mkClos rho e -- v <- whnf rho e-  vSing v tv-{--sing env' e (VPi dec x av env b)  = do-  return $ VPi dec x' av env'' (Sing (App e (Var x')) b)-    where env'' = env' ++ env  -- super ugly HACK-          x'    = if x == "" then fresh env'' else x-    -- Should work with just x since shadowing is forbidden-sing _ _ tv@(VSing{}) = return $ tv-sing env e tv = do v <- whnf env e      -- singleton strict, is this OK?!-                   return $ VSing v tv--}--sing' :: Expr -> TVal -> TypeCheck TVal-sing' e tv = do-  env <- getEnv-  sing env e tv--evalCase :: Val -> TVal -> Env -> [Clause] -> TypeCheck Val-evalCase v tv env cs = do-  m  <- matchClauses env cs [v]-  case m of-    Nothing -> return $ VCase v tv env cs-    Just v' -> return $ v'--piApp :: TVal -> Clos -> TypeCheck TVal-piApp (VGuard beta bv) w = piApp bv w-piApp (VQuant Pi x dom fv) w = app fv w-piApp tv@(VApp (VDef (DefId DatK n)) vl) (VProj Post p) = projectType tv p VIrr -- no rec value here-piApp tv w = failDoc (text "piApp: IMPOSSIBLE to instantiate" <+> prettyTCM tv <+> text "to argument" <+> prettyTCM w)--piApps :: TVal -> [Clos] -> TypeCheck TVal-piApps tv [] = return tv-piApps tv (v:vs) = do tv' <- piApp tv v-                      piApps tv' vs--updateValu valu i v = reval' (sgVal i v) valu---- in app u v, u might be a VDef (e.g. when coming from reval)-app :: Val -> Clos -> TypeCheck Val-app = app' True---- | Application of arguments and projections.-app' :: Bool -> Val -> Clos -> TypeCheck Val-app' expandDefs u v = do-         let app = app' expandDefs-             appDef' True  f vs = appDef f vs-             appDef' False f vs = return $ VDef (DefId FunK f) `VApp` vs-             appDef_ = appDef' expandDefs-         case u of-            VProj Pre n -> flip (app' expandDefs) (VProj Post n) =<< whnfClos v-            VRecord ri rho -> do-              let VProj Post n = v-              maybe (throwErrorMsg $ "app: projection " ++ show n ++ " not found in " ++ show u)-                whnfClos (lookup n rho)-            VDef (DefId FunK n) -> appDef_ n [v]-            VApp (VDef (DefId FunK n)) vl -> appDef_ n (vl ++ [v])-            VApp h@(VDef (DefId (ConK Cons) n)) vl -> do-              v <- whnfClos v      -- inductive constructors are strict!-              return $ VApp h (vl ++ [v])---            VDef n -> appDef n [v]---            VApp (VDef id) vl -> VApp (VDef id) (vl ++ [v])-            VApp v1 vl -> return $ VApp v1 (vl ++ [v])---- VSing is a type!---           VSing u (VQuant Pi x dom fu) -> vSing <$> app u v <*> app fu v--            VLam x env e    -> whnf (update env x v) e-            VConst u        -> whnfClos u-            VAbs x i u valu -> flip reval' u =<< updateValu valu i v-            VUp u (VQuant Pi x dom fu) -> up False ==<< (app u v, app fu v)--{--            VUp u1 (VQuant Pi x dom rho b) -> do-{---- ALT: erased functions are not applied to their argument!-              v1 <- if erased dec then return v else app v [w]  -- eta-expand w ??--}-              v1 <- app u1 v  -- eta-expand v ??-              bv <- whnf (update rho x v) b-              up False v1 bv--}-            VUp u1 (VApp (VDef (DefId DatK n)) vl) -> do-              u' <- force u-              app u' v--            VIrr -> return VIrr-{- 2010-11-01 this breaks extraction for System U example-            VIrr -> throwErrorMsg $ "app internal error: " ++ show (VApp u [v])--}-            _ -> return $ VApp u [v]------ app :: Val -> [Val] -> TypeCheck Val--- app u [] = return $ u--- app u c = do---          case (u,c) of---             (VApp u2 c2,_) -> app u2 (c2 ++ c)---             (VLam x env e,(v:vl))  -> do v' <- whnf (update env x v) e---                                          app v' vl---             (VDef n,_) -> appDef n c---             (VUp v (VPi dec x av rho b), w:wl) -> do--- {---- -- ALT: erased functions are not applied to their argument!---               v1 <- if erased dec then return v else app v [w]  -- eta-expand w ??--- -}---               v1 <- app v [w]  -- eta-expand w ??---               bv <- whnf (update rho x w) b---               v2 <- up v1 bv---               app v2 wl--- {---- -- ALT: VIrr consumes applications---             (VIrr,_) -> return VIrr---  -}---             (VIrr,_) -> throwErrorMsg $ "app internal error: " ++ show (VApp u c)---             _ -> return $ VApp u c----- unroll a corecursive definition one time (until constructor appears)-force' :: Bool -> Val -> TypeCheck (Bool, Val)-force' b (VSing v tv) = do  -- for singleton types, force type!-  (b',tv') <- force' b tv-  return (b', VSing v tv')-force' b (VUp v tv) = up True v tv >>= \ v' -> return (True, v')  -- force eta expansion-force' b (VClos rho e) = do-  v <- whnf rho e-  force' b v-force' b v@(VDef (DefId FunK n)) = failValInv v-{-- --trace ("force " ++ show v) $-    do sig <- gets signature-       case lookupSig n sig of-         (FunSig CoInd t cl True) -> do m <- matchClauses [] cl []-                                        case m of-                                          Just v' -> force v'-                                          Nothing -> return v-         _ -> return v--}-force' b v@(VApp (VDef (DefId FunK n)) vl) = enterDoc (text "force" <+> prettyTCM v) $-    do sig <- gets signature-       case Map.lookup n sig of-         Just (FunSig isCo t ki ar cl True _) -> traceMatch ("forcing " ++ show v) $-            do m <- matchClauses emptyEnv cl vl-               case m of-                 Just v' -> traceMatch ("forcing " ++ show n ++ " succeeded") $-                   force' True v'-                 Nothing -> traceMatch ("forcing " ++ show n ++ " failed") $-                   return (b, v)-         _ -> return (b, v)-force' b v = return (b, v)--force :: Val -> TypeCheck Val-force v = -- trace ("forcing " ++ show v) $-  liftM snd $ force' False v---- apply a recursive function--- corecursive ones are not expanded even if the arity is exceeded--- this is because a coinductive type needs to be destructed by pattern matching-appDef :: QName -> [Val] -> TypeCheck Val-appDef n vl = --trace ("appDef " ++ n) $-    do-      -- identifier might not be in signature yet, e.g. ind.-rec.def.-      sig <- gets signature-      case (Map.lookup n sig) of-        Just (FunSig { isCo = Ind, arity = ar, clauses = cl, isTypeChecked = True })-         | length vl >= fullArity ar -> do-           m <- matchClauses emptyEnv cl vl-           case m of-              Nothing -> return $ VApp (VDef (DefId FunK n)) vl-              Just v2 -> return v2-        _ -> return $ VApp (VDef (DefId FunK n)) vl---- reflection and reification  ------------------------------------------- TODO: eta for builtin sigma-types !?---- up force v tv--- force==True also expands at coinductive type-up :: Bool -> Val -> TVal -> TypeCheck Val-up f (VUp v tv') tv                              = up f v tv-up f v           tv@VQuant{ vqPiSig = Pi }       = return $ VUp v tv-up f _           (VSing v vt)                    = up f v vt-up f v           (VDef d)                        = failValInv $ VDef d-up f v           (VApp (VDef (DefId DatK d)) vl) = upData f v d vl-up f v           _                               = return v--{- Most of the code to eta expand on data types is in-   TypeChecker.hs "typeCheckDeclaration"-- Currently, eta expansion only happens at data *types* with exactly-one constructor.  In a first step, this will be extended to-non-recursive pattern inductive families.--The strategy is: match type value with result type for all the constructors-0. if there are no matches, eta expand to * (VIrr)-1. if there is exactly one match, eta expand accordingly using destructors-2. if there are more matches, do not eta-expand--up{Vec A (suc n)} x = vcons A n (head A n x) (tail A n x)--up{Vec Bool (suc zero)} x-  = vcons Bool zero (head Bool zero x) (tail Bool zero x)--For vcons-- the patterns of  Vec : (A : Set) -> Nat -> Set  are  [A,suc n]-- matching  Bool,suc zero  against  A,suc n  yields A=Bool,n=zero-- this means we can eta expand to vcons-- go through the fields of vcons-  - if Index use value obtained by matching-  - if Field destr, use  destr <all pars> <all indices> x---}---- matchingConstructors is for use in checkPattern--- matchingConstructors (D vs)  returns all the constructors--- each as tuple (ci,rho)--- of family D whose target matches (D vs) under substitution rho-matchingConstructors :: Val -> TypeCheck (Maybe [(ConstructorInfo,Env)])-matchingConstructors v@(VDef d) = failValInv v -- matchingConstructors' d []-matchingConstructors (VApp (VDef (DefId DatK d)) vl) = matchingConstructors' d vl >>= return . Just-matchingConstructors v = return Nothing--- throwErrorMsg $ "matchingConstructors: not a data type: " ++ show v -- return []--matchingConstructors' :: QName -> [Val] -> TypeCheck [(ConstructorInfo,Env)]-matchingConstructors' n vl = do-  sige <- lookupSymbQ n-  case sige of-    (DataSig {symbTyp = dv, constructors = cs}) -> -- if (null cs) then ret [] else do -- no constructor-      matchingConstructors'' True vl dv cs---- matchingConstructors''--- Arguments:---   symm     symmetric match---   vl       arguments to D (instance of D)---   dv       complete type value of D---   cs       constructors--- Returns a list [(ci,rho)] of matching constructors together with the---   environments which are solutions for the free variables in the constr.type--- this is also for use in upData-matchingConstructors'' :: Bool -> [Val] -> Val -> [ConstructorInfo] -> TypeCheck [(ConstructorInfo,Env)]-matchingConstructors'' symm vl dv cs = do-  vl <- mapM whnfClos vl-  compressMaybes <$> do-    forM cs $ \ ci -> do-      let ps = snd (cPatFam ci)-          -- list of patterns ps where D ps is the constructor target-      fmap (ci,) <$> nonLinMatchList symm emptyEnv ps vl dv---data MatchingConstructors a-  = NoConstructor-  | OneConstructor a-  | ManyConstructors-  | UnknownConstructors-    deriving (Eq,Show)--getMatchingConstructor-  :: Bool           -- eta   : must the field etaExpand be set of the data type-  -> QName          -- d     : the name of the data types-  -> [Val]          -- vl    : the arguments of the data type-  -> TypeCheck (MatchingConstructors-     ( Co           -- co    : coinductive type?-     , [Val]        -- parvs : the parameter half of the arguments-     , Env          -- rho   : the substitution for the index variables to arrive at d vl-     , [Val]        -- indvs : the index values of the constructor-     , ConstructorInfo -- ci : the only matching constructor-     ))-getMatchingConstructor eta n vl = traceRecord ("getMatchingConstructor " ++ show (n, vl)) $- do-  -- when checking a mutual data decl, the sig entry of the second data-  -- is not yet in place when checking the first, thus, lookup may fail-  sig <- gets signature-  case Map.lookup n sig of-    Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand}) | eta `implies` etaExpand ->-     if (null cs) then return NoConstructor else do -- no constructor: empty type-       -- for each constructor, match its core against the type-      -- produces a list of maybe (c.info, environment)-      cenvs <- matchingConstructors'' False vl dv cs-      traceRecordM $ "Matching constructors: " ++ show cenvs-      case cenvs of-        -- exactly one matching constructor: can eta expand---        [(ci,env)] -> if not (eta `implies` cEtaExp ci) then return UnknownConstructors else do-        [(ci,env)] -> if eta && not (cEtaExp ci) then return UnknownConstructors else do-          -- get list of index values from environment-          let fis = cFields ci-          let indices = filter (\ fi -> fClass fi == Index) fis-          let indvs = map (\ fi -> lookupPure env (fName fi)) indices-          let (pars, _) = splitAt npars vl-          return $ OneConstructor (co, pars, env, indvs, ci)-        -- more or less than one matching constructors: cannot eta expand-        l -> -- trace ("getMatchingConstructor: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $-               return ManyConstructors-    _ -> traceRecord ("no eta expandable type") $ return UnknownConstructors--getFieldsAtType-  :: QName          -- d     : the name of the data types-  -> [Val]          -- vl    : the arguments of the data type-  -> TypeCheck-     (Maybe         -- Nothing if not a record type-       [(Name       -- list of projection names-        ,TVal)])    -- and their instantiated type R ... -> C-getFieldsAtType n vl = do-  mc <- getMatchingConstructor False n vl-  case mc of-    OneConstructor (_, pars, _, indvs, ci) -> do-      let pi = pars ++ indvs-      -- for each argument of constructor, get value-      let arg (FieldInfo { fName = x, fClass = Index }) = return []-          arg (FieldInfo { fName = d, fClass = Field _ }) = do-            -- lookup type sig  t  of destructor  d-            t <- lookupSymbTyp d-            -- pi-apply destructor type to parameters and indices-            t' <- piApps t pi-            return [(d,t')]-      Just . concat <$> mapM arg (cFields ci)-    _ -> return Nothing---- similar to piApp, but for record types and projections-projectType :: TVal -> Name -> Val -> TypeCheck TVal-projectType tv p rv = do-  let fail1 = failDoc (text "expected record type when taking the projection" <+> prettyTCM (Proj Post p) <> comma <+> text "but found type" <+> prettyTCM tv)-  let fail2 = failDoc (text "record type" <+> prettyTCM tv <+> text "does not have field" <+> prettyTCM p)-  case tv of-    VApp (VDef (DefId DatK d)) vl -> do-      mfs <- getFieldsAtType d vl-      case mfs of-        Nothing -> fail1-        Just ptvs ->-          case lookup p ptvs of-            Nothing -> fail2-            Just tv -> piApp tv rv -- apply to record arg-    _ -> fail1---- eta expand  v  at data type  n vl-upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val-upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $- do-  let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ show n ++ show vl) $ return v'-  mc <- getMatchingConstructor True n vl-  case mc of-    NoConstructor -> ret VIrr-    OneConstructor (co, pars, env, indvs, ci) ->-      -- lazy eta-expansion for coinductive records like streams!-      if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId DatK n) vl) else do-          -- get list of index values from environment-          let fis = cFields ci-          let piv = pars ++ indvs ++ [v]-          -- for each argument of constructor, get value-          let arg (FieldInfo { fName = x, fClass = Index }) =-                lookupEnv env x-              arg (FieldInfo { fName = d, fClass = Field _ }) = do-                -- lookup type sig  t  of destructor  d-                LetSig {symbTyp = t, definingVal = w} <- lookupSymb d-                -- pi-apply destructor type to parameters, indices and value v-                t' <- piApps t piv-                -- recursively eta expand  (d <pars> v)-                -- OLD, defined projections:-                -- w <- foldM (app' False) w piv -- LAZY: only unfolds let, not def-                -- NEW, builtin projections:-                w <- app' False v (VProj Post d)-                up False w t' -- now: LAZY--          vs <- mapM arg fis-          let fs = map fName fis-              v' = VRecord (NamedRec (coToConK co) (cName ci) False notDotted) $ zip fs vs---          v' <- foldM app (vCon (coToConK co) (cName ci)) vs -- 2012-01-22 PARS GONE: (pars ++ vs)-          ret v'-    -- more constructors or unknown situation: do not eta expand-    _ -> return v--{---- eta expand  v  at data type  n vl-upData :: Bool -> Val -> Name -> [Val] -> TypeCheck Val-upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $- do-  let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ n ++ show vl) $ return v'-  -- when checking a mutual data decl, the sig entry of the second data-  -- is not yet in place when checking the first, thus, lookup may fail-  sig <- gets signature-  case Map.lookup n sig of-    Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand = True}) -> if (null cs) then ret VIrr else do -- no constructor: empty type-      let (pars, inds) = splitAt npars vl-      -- for each constructor, match its core against the type-      -- produces a list of maybe (c.info, environment)-      cenvs <- matchingConstructors'' False vl dv cs-      -- traceM $ "Matching constructors: " ++ show cenvs-      case cenvs of-        -- exactly one matching constructor: can eta expand-        [(ci,env)] -> if not (cEtaExp ci) then return v else-         if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId Dat n) vl) else do-          -- get list of index values from environment-          let fis = cFields ci-          let indices = filter (\ fi -> fClass fi == Index) fis-          let indvs = map (\ fi -> lookupPure env (fName fi)) indices-          let piv = pars ++ indvs ++ [v]-          -- for each argument of constructor, get value-          let arg (FieldInfo { fName = x, fClass = Index }) =-                lookupEnv env x-              arg (FieldInfo { fName = d, fClass = Field _ }) = do-                -- lookup type sig  t  of destructor  d-                t <- lookupSymbTyp d-                -- pi-apply destructor type to parameters, indices and value v-                t' <- piApps t piv-                -- recursively eta expand  (d <pars> v)-                -- WAS: up (VDef (DefId Fun d) `VApp` piv) t'-                up False (VDef (DefId Fun d) `VApp` piv) t' -- now: LAZY-          vs <- mapM arg fis-          v' <- foldM app (vCon co (cName ci)) (pars ++ vs)-          ret v'-        -- more or less than one matching constructors: cannot eta expand-        l -> -- trace ("Eta: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $-               return v-    _ -> return v--}--{--      let matchC (c, ps, ds) =-            do menv <- nonLinMatchList [] ps inds dv-               case menv of-                 Nothing -> return False-                 Just env -> do-                   let grps = groupBy (\ (x,_) (y,_) -> x == y) env-                   -- TODO: now compare elements in the group-                   -- NEED types for equality check-                   -- trivial if groups are singletons-                   return $ all (\ l -> length l <= 1) grps-      cs' <- filterM matchC cs-      case cs' of-        [] -> return $ VIrr-        [(c,_,ds)] ->  do-          let parsv = pars ++ [v]-          let aux d = do-               -- lookup type sig  t  of destructor  d-               let FunSig { symbTyp = t } = lookupSig d sig-               -- pi-apply destructor type to parameters and value v-               t' <- piApps t parsv-               -- recursively eta expand  (d <pars> v)-               up (VDef d `VApp` parsv) t'-          vs <- mapM aux ds-          app (VCon co c) (pars ++ vs)-        _ -> return v-    _ -> return v--}--{--refl : [A : Set] -> [a : A] -> Id A a a-up{Id T t t'} x-  Id T t t' =?= Id A a a  --> A = T, a = t, a = t'--}--{- OLD CODE FOR NON-DEPENDENT RECORDS ONLY-    -- erase if n is a empty type-    (DataSig {constructors = []}) -> return $ VIrr-    -- eta expand v if n is a tuple type-    (DataSig {isCo = co, constructors = [c], destructors = Just ds}) -> do-       let vlv = vl ++ [v]-       let aux d = do -- lookup type sig  t  of destructor  d-                      let FunSig { symbTyp = t } = lookupSig d sig-                      -- pi-apply destructor type to parameters and value v-                      t' <- piApps t vlv-                      -- recursively eta expand  (d <pars> v)-                      up (VDef d `VApp` vlv) t'-       vs <- mapM aux ds-       app (VCon co c) (vl ++ vs) -- (map (\d -> VDef d `VApp` (vl ++ [v])) ds)-    _ -> return v-END OLD CODE -}---- pattern matching -----------------------------------------------------matchClauses :: Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)-matchClauses env cl vl0 = do-  vl <- mapM reduce vl0  -- REWRITE before matching (2010-07-12 dysfunctional because of lazy?)-  loop cl vl-    where loop [] vl = return Nothing-          loop (Clause _ pl Nothing : cl2) vl = loop cl2 vl -- no need to try absurd clauses-          loop (Clause _ pl (Just rhs) : cl2) vl =-              do x <- matchClause env pl rhs vl-                 case x of-                   Nothing -> loop cl2 vl-                   Just v -> return $ Just v--bindMaybe :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)-bindMaybe mma k = mma >>= maybe (return Nothing) k--matchClause :: Env -> [Pattern] -> Expr -> [Val] -> TypeCheck (Maybe Val)-matchClause env pl rhs vl =-  case (pl, vl) of-    (p:pl, v:vl) -> match env p v `bindMaybe` \ env' -> matchClause env' pl rhs vl--    -- done matching: eval clause body in env and apply it to remaining arsg-    ([], _)      -> Just <$> do flip (foldM app) vl =<< whnf env rhs--    -- too few arguments to fire clause: give up-    (_, [])      -> return Nothing---match :: Env -> Pattern -> Val -> TypeCheck (Maybe Env)-match env p v0 = --trace (show env ++ show v0) $-  do-    -- force against constructor pattern or pair pattern-    v <- case p of-           ConP{}  -> do v <- force v0; traceMatch ("matching pattern " ++ show (p,v)) $ return v-           PairP{} -> do v <- force v0; traceMatch ("matching pattern " ++ show (p,v)) $ return v-           _ -> whnfClos v0-    case (p,v) of---      (ErasedP _,_) -> return $ Just env  -- TOO BAD, DOES NOT WORK (eta!)-      (ErasedP p,_) -> match env p v-      (AbsurdP{},_) -> return $ Just env-      (DotP _,   _) -> return $ Just env-      (VarP x,   _) -> return $ Just (update env x v)-      (SizeP _ x,_) -> return $ Just (update env x v)-      (ProjP x, VProj Post y) | x == y -> return $ Just env-      (PairP p1 p2, VPair v1 v2) -> matchList env [p1,p2] [v1,v2]-      (ConP _ x [],VDef (DefId (ConK _) y)) -> failValInv v -- | x == y -> return $ Just env---  The following case is NOT IMPOSSIBLE:---      (ConP _ x pl,VApp (VDef (DefId (ConK _) y)) vl) -> failValInv v-      (ConP _ x pl,VApp (VDef (DefId (ConK _) y)) vl) | nameInstanceOf x  y -> matchList env pl vl-      -- If a value is a dotted record value, we do not succeed, since-      -- it is not sure this is the correct constructor.-      (ConP _ x pl,VRecord (NamedRec ri y _ dotted) rs) | nameInstanceOf x y && not (isDotted dotted) ->-         matchList env pl $ map snd rs-      (p@(ConP pi _ _), v) | coPat pi == DefPat -> do-        p <- expandDefPat p-        match env p v-      (SuccP p', v) -> (predSize <$> whnfClos v) `bindMaybe` match env p'-      (UnusableP p,_) -> throwErrorMsg ("internal error: match " ++ show (p,v))-      _ -> return Nothing--matchList :: Env -> [Pattern] -> [Val] -> TypeCheck (Maybe Env)-matchList env []     []     = return $ Just env-matchList env (p:pl) (v:vl) =-  match env p v `bindMaybe` \ env' ->-  matchList env' pl vl-matchList env pl     vl     = throwErrorMsg $ "matchList internal error: inequal length while trying to match patterns " ++ show pl ++ " against values " ++ show vl---- * Typed Non-linear Matching -------------------------------------------type GenToPattern = [(Int,Pattern)]-type MatchState = (Env, GenToPattern)---- @nonLinMatch True@ allows also instantiation in v0--- this is useful for finding all matching constructors--- for an erased argument in checkPattern-nonLinMatch :: Bool -> Bool -> MatchState -> Pattern -> Val -> TVal -> TypeCheck (Maybe MatchState)-nonLinMatch undot symm st p v0 tv = traceMatch ("matching pattern " ++ show (p,v0)) $ do-  -- force against constructor pattern-  v <- case p of-         ConP{}  -> force v0-         PairP{} -> force v0-         _ -> whnfClos v0-  case (p,v) of-    (ErasedP{}, _) -> return $ Just st-    (DotP{}   , _) -> return $ Just st-    (_,    VGen i) | symm -> return $ Just $ mapSnd ((i,p):) st -- no check in case of non-lin!-    (VarP    x, _) -> matchVarP x v-    (SizeP _ x, _) -> matchVarP x v-    (ProjP x,     VProj Post y) | x == y -> return $ Just st-    (ConP _ c pl, VApp (VDef (DefId (ConK _) c')) vl) | nameInstanceOf c c' -> do-      vc <- conLType c tv-      nonLinMatchList' undot symm st pl vl vc-    -- Here, we do accept dotted constructors, since we are abusing this for unification.-    (ConP _ c pl, VRecord (NamedRec _ c' _ dotted) rs) | nameInstanceOf c c' -> do-      when undot $ clearDotted dotted-      vc <- conLType c tv-      nonLinMatchList' undot symm st pl (map snd rs) vc-    -- if the match against an unconfirmed constructor-    -- we can succeed, but not compute a sensible environment-    (_, VRecord (NamedRec _ c' _ dotted) rs) | isDotted dotted && not undot -> return $ Just st-    (p@(ConP pi _ _), v) | coPat pi == DefPat -> do-      p <- expandDefPat p-      nonLinMatch undot symm st p v tv-    (PairP p1 p2, VPair v1 v2) -> do-      tv <- force tv-      case tv of-        VQuant Sigma x dom fv -> do-          nonLinMatch undot symm st p1 v1 (typ dom) `bindMaybe` \ st -> do-          nonLinMatch undot symm st p2 v2 =<< app fv v1-        _ -> failDoc $ text "nonLinMatch: expected" <+> prettyTCM tv <+> text "to be a Sigma-type (&)"-    (SuccP p', v) -> (predSize <$> whnfClos v) `bindMaybe` \ v' ->-      nonLinMatch undot symm st p' v' tv-    _ -> return Nothing-  where-    -- Check that the previous solution for @x@ is equal to @v@.-    -- Here, we need the type!-    matchVarP x v = do-      let env = fst st-      case find ((x ==) . fst) $ envMap $ fst st of-        Nothing     -> return $ Just $ mapFst (\ env -> update env x v) st-        Just (y,v') -> ifM (eqValBool tv v v') (return $ Just st) (return Nothing)---- nonLinMatchList symm env ps vs tv--- typed non-linear matching of patterns ps against values vs at type tv---   env   is the accumulator for the solution of the matching-nonLinMatchList :: Bool -> Env -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe Env)-nonLinMatchList symm env ps vs tv =-  fmap fst <$> nonLinMatchList' False symm (env, []) ps vs tv--nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState)-nonLinMatchList' undot symm st [] [] tv = return $ Just st-nonLinMatchList' undot symm st (p:pl) (v:vl) tv = do-  tv <- force tv-  case tv of-    VQuant Pi x dom fv ->-      nonLinMatch undot symm st p v (typ dom) `bindMaybe` \ st' ->-      nonLinMatchList' undot symm st' pl vl =<< app fv v-    _ -> throwErrorMsg $ "nonLinMatchList': cannot match in absence of pi-type"-nonLinMatchList' _ _ _ _ _ _ = return Nothing----- | Expand a top-level pattern synonym-expandDefPat :: Pattern -> TypeCheck Pattern-expandDefPat p@(ConP pi c ps) | coPat pi == DefPat = do-  PatSig ns pat v <- lookupSymbQ c-  unless (length ns == length ps) $-    throwErrorMsg ("underapplied defined pattern in " ++ show p)-  let pat' = if dottedPat pi then dotConstructors pat else pat-  return $ patSubst (zip ns ps) pat'-expandDefPat p = return p-------------------------------------------------------------------------------- * Unification------------------------------------------------------------------------------instance Monoid (TypeCheck Bool) where-  mempty  = return True-  mappend = andLazy-  mconcat = andM---- | Occurrence check @nocc ks v@ (used by 'SPos' and 'TypeCheck').---   Checks that generic values @ks@ does not occur in value @v@.---   In the process, @tv@ is normalized.-class Nocc a where-  nocc :: [Int] -> a -> TypeCheck Bool--instance Nocc a => Nocc [a] where-  nocc = foldMap . nocc--instance Nocc a => Nocc (Dom a) where-  nocc = foldMap . nocc--instance Nocc a => Nocc (Measure a) where-  nocc = foldMap . nocc--instance Nocc a => Nocc (Bound a) where-  nocc = foldMap . nocc--instance (Nocc a, Nocc b) => Nocc (a,b) where-  nocc ks (a, b) = nocc ks a `andLazy` nocc ks b--instance Nocc a => Nocc (Sort a) where-  nocc ks (Set   v) = nocc ks v-  nocc ks (CoSet v) = nocc ks v-  nocc ks (SortC _) = mempty--instance Nocc Val where-  nocc ks v = do-    -- traceM ("nocc " ++ show v)-    v <- whnfClos v-    case v of-      -- neutrals-      VGen k                -> return $ not $ k `elem` ks-      VApp v1 vl            -> nocc ks $ v1 : vl-      VDef{}                -> mempty-      VProj{}               -> mempty-      -- Binders:-      -- ALT: do not evaluate under binders (just check environment).-      -- This is less precise but more efficient. Can give false alarms.-      -- Still sound. (Should maybe done first, like in Agda).-      VQuant pisig x dom fv -> nocc ks dom `mappend` do-                               underAbs  x dom  fv $ \ _i _xv bv -> nocc ks bv-      fv@(VLam x env b)     -> underAbs' x      fv $ \ _xv bv -> nocc ks bv-      fv@(VAbs x i u valu)  -> underAbs' x      fv $ \ _xv bv -> nocc ks bv-      fv@(VConst v)         -> underAbs' noName fv $ \ _xv bv -> nocc ks bv-      -- pairs-      VRecord _ rs          -> nocc ks $ map snd rs-      VPair v w             -> nocc ks (v, w)-      -- sizes-      VZero                 -> mempty-      VSucc v               -> nocc ks v-      VInfty                -> mempty-      VMax vl               -> nocc ks vl-      VPlus vl              -> nocc ks vl-      VSort s               -> nocc ks s-      VMeasured mu tv       -> nocc ks (mu, tv)-      VGuard beta tv        -> nocc ks (beta, tv)-      VBelow ltle v         -> nocc ks v-      VSing v tv            -> nocc ks (v, tv)-      VUp v tv              -> nocc ks (v, tv)-      VIrr                  -> mempty-      VCase v tv env cls    -> nocc ks $ v : tv : map snd (envMap env)-      -- impossible: closure (reduced away)-      VClos{}               -> throwErrorMsg $ "internal error: nocc " ++ show (ks,v)----- heterogeneous typed equality and subtyping --------------------------eqValBool :: TVal -> Val -> Val -> TypeCheck Bool-eqValBool tv v v' = errorToBool $ eqVal tv v v'--- eqValBool tv v v' = (eqVal tv v v' >> return True) `catchError` (\ _ -> return False)--eqVal :: TVal -> Val -> Val -> TypeCheck ()-eqVal tv = leqVal' N mixed (Just (One tv))----- force history-data Force = N | L | R -- not yet, left , right-    deriving (Eq,Show)--class Switchable a where-  switch :: a -> a--instance Switchable Force where-  switch L = R-  switch R = L-  switch N = N--instance Switchable Pol where-  switch = polNeg--instance Switchable (a,a) where-  switch (a,b) = (b,a)--instance Switchable a => Switchable (Maybe a) where-  switch = fmap switch--{---- WONTFIX: FOR THE FOLLOWING TO BE SOUND, ONE NEEDS COERCIVE SUBTYPING!--- the problem is that after extraction, erased arguments are gone!--- a function which does not use its argument can be used as just a function--- [A] -> A <= A -> A--- A <= [A]-leqDec :: Pol -> Dec -> Dec -> Bool-leqDec SPos  dec1 dec2 = erased dec2 || not (erased dec1)-leqDec Neg   dec1 dec2 = erased dec1 || not (erased dec2)-leqDec mixed   dec1 dec2 = erased dec1 == erased dec2--}---- subtyping for erasure disabled--- but subtyping for polarities!-leqDec :: Pol -> Dec -> Dec -> Bool-leqDec p dec1 dec2 = erased dec1 == erased dec2-  && relPol p leqPol (polarity dec1) (polarity dec2)---- subtyping -----------------------------------------------------------subtype :: Val -> Val -> TypeCheck ()-subtype v1 v2 = -- enter ("subtype " ++ show v1 ++ "  <=  " ++ show v2) $-  leqVal' N Pos Nothing v1 v2---- Pol ::= Pos | Neg | mixed-leqVal :: Pol -> TVal -> Val -> Val -> TypeCheck ()-leqVal p tv = leqVal' N p (Just (One tv))--type MT12 = Maybe (OneOrTwo TVal)---- view the shape of a type or a pair of types-data TypeShape-  = ShQuant PiSigma-            (OneOrTwo Name)-            (OneOrTwo Domain)-            (OneOrTwo FVal)      -- both are function types-  | ShSort  SortShape            -- sort of same shape-  | ShData  QName (OneOrTwo TVal)-- same data, but with possibly different args-  | ShNe    (OneOrTwo TVal)      -- both neutral-  | ShSing  Val TVal             -- 1 and singleton-  | ShSingL Val TVal TVal        -- 2 and the left is a singleton-  | ShSingR TVal Val TVal        -- 2 and the right is a singleton-  | ShNone-    deriving (Eq, Ord)--data SortShape-  = ShSortC Class              -- same sort constant-  | ShSet   (OneOrTwo Val)     -- Set i and Set j-  | ShCoSet (OneOrTwo Val)     -- CoSet i and CoSet j-    deriving (Eq, Ord)--shSize = ShSort (ShSortC Size)---- typeView does not normalize!-typeView :: TVal -> TypeShape-typeView tv =-  case tv of-    VQuant pisig x dom fv        -> ShQuant pisig (One x) (One dom) (One fv)-    VBelow{}                     -> shSize-    VSort s                      -> ShSort (sortView s)-    VSing v tv                   -> ShSing v tv-    VApp (VDef (DefId DatK n)) vs -> ShData n (One tv)-    VApp (VDef (DefId FunK n)) vs -> ShNe (One tv)  -- stuck fun-    VApp (VGen i) vs             -> ShNe (One tv)  -- type variable-    VGen i                       -> ShNe (One tv)  -- type variable-    VCase{}                      -> ShNe (One tv)  -- stuck case-    _                            -> ShNone -- error $ "typeView " ++ show tv--sortView :: Sort Val -> SortShape-sortView s =-  case s of-    SortC c -> ShSortC c-    Set   v -> ShSet   (One v)-    CoSet v -> ShCoSet (One v)--typeView12 :: (Functor m, Monad m, MonadError TraceError m) => OneOrTwo TVal -> m TypeShape--- typeView12 :: OneOrTwo TVal -> TypeCheck TypeShape-typeView12 (One tv) = return $ typeView tv-typeView12 (Two tv1 tv2) =-  case (tv1, tv2) of-    (VQuant pisig1 x1 dom1 fv1, VQuant pisig2 x2 dom2 fv2)-      | pisig1 == pisig2 && erased (decor dom1) == erased (decor dom2) ->-        return $ ShQuant pisig1 (Two x1 x2) (Two dom1 dom2) (Two fv1 fv2)-    (VSort s1, VSort s2) -> ShSort <$> sortView12 (Two s1 s2)-    (VSing v tv, _)      -> return $ ShSingL v tv tv2-    (_, VSing v tv)      -> return $ ShSingR tv1 v tv-    _ -> case (typeView tv1, typeView tv2) of-           (ShSort s1, ShSort s2) | s1 == s2 -> return $ ShSort $ s1-           (ShData n1 _, ShData n2 _) | n1 == n2 -> return $ ShData n1 (Two tv1 tv2)-           (ShNe{}     , ShNe{}     )            -> return $ ShNe (Two tv1 tv2)-           _ -> throwErrorMsg $ "type " ++ show tv1 ++ " has different shape than " ++ show tv2--sortView12 :: (Monad m, MonadError TraceError m) => OneOrTwo (Sort Val) -> m SortShape-sortView12 (One s) = return $ sortView s-sortView12 (Two s1 s2) =-  case (s1, s2) of-    (SortC c1, SortC c2) | c1 == c2 -> return $ ShSortC c1-    (Set v1, Set v2)                -> return $ ShSet (Two v1 v2)-    (CoSet v1, CoSet v2)            -> return $ ShCoSet (Two v1 v2)-    _ -> throwErrorMsg $ "sort " ++ show s1 ++ " has different shape than " ++ show s2--whnf12 :: OneOrTwo Env -> OneOrTwo Expr -> TypeCheck (OneOrTwo Val)-whnf12 env12 e12 = Traversable.traverse id $ zipWith12 whnf env12 e12--app12 ::  OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)-app12 fv12 v12 = Traversable.traverse id $ zipWith12 app fv12 v12---- if m12 = Nothing, we are checking subtyping, otherwise we are--- comparing objects or higher-kinded types--- if two types are given (heterogeneous equality), they need to be--- of the same shape, otherwise they cannot contain common terms-leqVal' :: Force -> Pol -> MT12 -> Val -> Val -> TypeCheck ()-leqVal' f p mt12 u1' u2' = local (\ cxt -> cxt { consistencyCheck = False }) $ do- -- 2013-03-30 During subtyping, it is fine to add any size hypotheses.- l <- getLen- ren <- getRen- enterDoc (case mt12 of-  Nothing -> -- text ("leqVal' (subtyping) " ++ show  (Map.toList $ ren) ++ " |-")-             text "leqVal' (subtyping) "-             <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ")-             <+> prettyTCM u2'-  Just (One tv) -> -- text ("leqVal' " ++ show  (Map.toList $ ren) ++ " |-")-             text "leqVal' "-             <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ")-             <+> prettyTCM u2' <+> colon-             <+> prettyTCM tv-  Just (Two tv1 tv2) -> -- text ("leqVal' " ++ show  (Map.toList $ ren) ++ " |-")-             text "leqVal' "-             <+> prettyTCM u1' <+> colon-             <+> prettyTCM tv1 <+> text (" <=" ++ show p ++ " ")-             <+> prettyTCM u2' <+> colon-             <+> prettyTCM tv2) $ do-{--    ce <- ask-    trace  (("rewrites: " +?+ show (rewrites ce)) ++ "  leqVal': " ++ show ce ++ "\n |- " ++ show u1' ++ "\n  <=" ++ show p ++ "  " ++ show u2') $--}-    mt12f <- mapM (mapM force) mt12 -- leads to LOOP, see HungryEta.ma-    sh12 <- case mt12f of-              Nothing -> return Nothing-              Just tv12 -> case runExcept $ typeView12 tv12 of-                Right sh -> return $ Just sh-                Left err -> (recoverFail $ show err) >> return Nothing-    case sh12 of--      -- subtyping directed by common type shape--      Just (ShSing{}) -> return () -- two terms are equal at singleton type!-      Just (ShSingL v1 tv1' tv2) -> leqVal' f p (Just (Two tv1' tv2)) v1 u2'-      Just (ShSingR tv1 v2 tv2') -> leqVal' f p (Just (Two tv1 tv2')) u1' v2-      Just (ShSort (ShSortC Size)) -> leqSize p u1' u2'--{-  functions are compared pointwise--   Gamma, p(x:A) |- t x : B  <=  Gamma', p'(x:A') |- t' x : B'-   -----------------------------------------------------------   Gamma |- t : p(x:A) -> B  <=  Gamma' |- t' : p'(x:A') -> B'--}-      Just (ShQuant Pi x12 dom12 fv12) -> do-         x <- do-           let x = name12 x12-           if null (suggestion x) then do-             case (u1', u2') of-               (VLam x _ _, _) -> return x-               (_, VLam x _ _) -> return x-               _ -> return x-            else return x-         newVar x dom12 $ \ _ xv12 -> do-            u1' <- app u1' (first12  xv12)-            u2' <- app u2' (second12 xv12)-            tv12 <- app12 fv12 xv12-            leqVal' f p (Just tv12) u1' u2'-{--      Just (VPi x1 dom1 env1 b1, VPi x2 dom2 env2 b2)  ->-         new2 x1 (dom1, dom2) $ \ (xv1, xv2) -> do-            u1' <- app u1' xv1-            u2' <- app u2' xv2-            tv1' <- whnf (update env1 x1 xv1) b1-            tv2' <- whnf (update env2 x2 xv2) b2-            leqVal' f p (Just (tv1', tv2')) u1' u2'--}---      -- structural subtyping (not directed by types)--      _ -> do-       u1 <- reduce =<< whnfClos u1'-       u2 <- reduce =<< whnfClos u2'--       let tryForcing fallback = do-            (f1,u1f) <- force' False u1-            (f2,u2f) <- force' False u2-            case (f1,f2) of -- (u1f /= u1,u2f /= u2) of--              (True,False) | f /= R -> -- only unroll one side-                 enter ("forcing LHS") $-                           leqVal' L p mt12 u1f u2-              (False,True) | f /= L ->-                 enter ("forcing RHS") $-                           leqVal' R p mt12 u1 u2f-              _ -> -- enter ("not forcing " ++ show (f1,f2,f)) $-                     fallback--           leqCons n1 vl1 n2 vl2 = do-                 unless (n1 == n2) $-                  recoverFail $-                    "leqVal': head mismatch "  ++ show u1 ++ " != " ++ show u2-                 case mt12 of-                   Nothing -> recoverFail $ "leqVal': cannot compare constructor terms without type"-                   Just tv12 -> do-                     ct12 <- Traversable.mapM (conType n1) tv12-                     leqVals' f p ct12 vl1 vl2-                     return ()-{--       leqStructural u1 u2 where-          leqStructural u1 u2 =--}-       case (u1,u2) of--{--  C = C'  (proper: C' entails C, but I do not want to implement entailment)-  Gamma, C |- A  <=  Gamma', C' |- A'-  ------------------------------------------  Gamma |- C ==> A  <=  Gamma' |- C' ==> A'--}-              (VGuard beta1 bv1, VGuard beta2 bv2) -> do-                 entailsGuard (switch p) beta1 beta2-                 leqVal' f p Nothing bv1 bv2--              (VGuard beta u1, u2) | p `elem` [Neg,Pos] ->-                addOrCheckGuard (switch p) beta $-                  leqVal' f p Nothing u1 u2--              (u1, VGuard beta u2) | p `elem` [Neg,Pos] ->-                addOrCheckGuard p beta $-                  leqVal' f p Nothing u1 u2- {--  p' <= p-  Gamma' |- A' <= Gamma |- A-  Gamma, p(x:A) |- B <= Gamma', p'(x:A') |- B'-  ----------------------------------------------------------  Gamma |- p(x:A) -> B : s <= Gamma' |- p'(x:A') -> B' : s'--}-              (VQuant piSig1 x1 dom1@(Domain av1 _ dec1) fv1,-               VQuant piSig2 x2 dom2@(Domain av2 _ dec2) fv2) -> do-                 let p' = if piSig1 == Pi then switch p else p-                 if piSig1 /= piSig2 || not (leqDec p' dec1 dec2) then-                    recoverFailDoc $ text "subtyping" <+> prettyTCM u1 <+> text (" <=" ++ show p ++ " ") <+> prettyTCM u2 <+> text "failed"-                  else do-                    leqVal' (switch f) p' Nothing av1 av2-                    -- take smaller domain-                    let dom = if (p' == Neg) then dom2 else dom1-                    let x = bestName $ if p' == Neg then [x2,x1] else [x1,x2]-                    new x dom $ \ xv -> do-                      bv1 <- app fv1 xv-                      bv2 <- app fv2 xv-                      enterDoc (text "comparing codomain" <+> prettyTCM bv1 <+> text "with" <+> prettyTCM bv2) $-                        leqVal' f p Nothing bv1 bv2--              (VSing v1 av1, VSing v2 av2) -> do-                  leqVal' f p Nothing av1 av2-                  leqVal' N mixed (Just (Two av1 av2)) v1 v2  -- compare for eq.--              (VSing v1 av1, VBelow ltle v2) | av1 == vSize && p == Pos -> do-                 v1 <- whnfClos v1-                 leSize ltle p v1 v2--{- 2012-01-28 now vSize is VBelow Le Infty--              -- extra cases since vSize is not implemented as VBelow Le Infty-              (u1,u2) | isVSize u1 && isVSize u2 -> return ()-              (VSort (SortC Size), VBelow{}) -> leqStructural (VBelow Le VInfty) u2-              (VBelow{}, VSort (SortC Size)) -> leqStructural u1 (VBelow Le VInfty)--}-              -- care needed to not make <=# a subtype of <#-              (VBelow ltle1 v1, VBelow ltle2 v2) ->-                case (p, ltle1, ltle2) of-                  _ | ltle1 == ltle2 -> leSize Le p v1 v2-                  (Neg, Le, Lt) -> leSize Le p (vSucc v1) v2-                  (Neg, Lt, Le) -> leSize Lt p v1 v2  -- careful here-                  (p  , Lt, Le) -> leSize Le p v1 (vSucc v2)-                  (p  , Le, Lt) -> leSize Lt p v1 v2  -- careful here--              -- unresolved eta-expansions (e.g. at coinductive type)-              (VUp v1 av1, VUp v2 av2) -> do-                  -- leqVal' f p Nothing av1 av2      -- do not compare types-                  leqVal' f p (Just (Two av1 av2)) v1 v2  -- OR: Just(tv1,tv2) ?-              (VUp v1 av1, u2) -> leqVal' f p mt12 v1 u2-              (u1, VUp v2 av2) -> leqVal' f p mt12 u1 v2--              (VRecord (NamedRec _ n1 _ _) rs1, VRecord (NamedRec _ n2 _ _) rs2) ->-                 leqCons n1 (map snd rs1) n2 (map snd rs2)--{--              -- the following three cases should be impossible-              -- but aren't.  I gave up on this bug -- 2012-01-25-              -- FOUND IT--              (VRecord (NamedRec _ n1 _) rs1,-               VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 (map snd rs1) n2 vl2--              (VApp v1@(VDef (DefId (ConK _) n1)) vl1,-               VRecord (NamedRec _ n2 _) rs2) -> leqCons n1 vl1 n2 (map snd rs2)--              (VApp v1@(VDef (DefId (ConK _) n1)) vl1,-               VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 vl1 n2 vl2--}--              -- smart equality is not transitive-              (VCase v1 tv1 env1 cl1, VCase v2 tv2 env2 cl2) -> do-                 leqVal' f p (Just (Two tv1 tv2)) v1 v2 -- FIXED: do not have type here, but v1,v2 are neutral-                 leqClauses f p mt12 v1 tv1 env1 cl1 env2 cl2--{- REMOVED, NOT TRANSITIVE-              (VCase v env cl, v2) -> leqCases (switch f) (switch p) (switch mt12) v2 v env cl-              (v1, VCase v env cl) -> leqCases f p mt12 v1 v env cl--}-              (VSing v1 av1, av2)  -> leqVal' f p Nothing av1 av2  -- subtyping ax-              (VSort s1, VSort s2) -> leqSort p s1 s2-              (a1,a2) | a1 == a2 -> return ()-              (u1,u2) -> tryForcing $-                case (u1,u2) of-                  (VApp v1 vl1, VApp v2 vl2) -> leqApp f p v1 vl1 v2 vl2-                  (VApp v1 vl1, u2) -> leqApp f p v1 vl1 u2 []-                  (u1, VApp v2 vl2) -> leqApp f p u1 []  v2 vl2-                  _ -> leqApp f p u1 [] u2 []--leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck ()-leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where-  loop cls1 cls2 = case (cls1,cls2) of-    ([],[]) -> return ()-    (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do-      ns <- flip execStateT [] $ alphaPattern p1 p2-      case (mrhs1, mrhs2) of-        (Nothing, Nothing) -> return ()-        (Just e1, Just e2) -> do-            let tv = maybe vTopSort first12 mt12-            let tv012 = maybe [] toList12 mt12-            addPattern (tvp `arrow` tv) p2 env2 $ \ _ pv env2' ->-              addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do-                let env1' = env2' { envMap = compAssoc ns (envMap env2') }-                v1  <- whnf (appendEnv env1' env1) e1-                v2  <- whnf (appendEnv env2' env2) e2-                leqVal' f pol (toMaybe12 tv012) v1 v2-            loop cls1' cls2'-{---- naive implementation for now-leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck ()-leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where-  loop cls1 cls2 = case (cls1,cls2) of-    ([],[]) -> return ()-    (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do-      eqPattern p1 p2-      case (mrhs1, mrhs2) of-        (Nothing, Nothing) -> return ()-        (Just e1, Just e2) -> do-            let tv = maybe vTopSort first12 mt12-            let tv012 = maybe [] toList12 mt12-            addPattern (tvp `arrow` tv) p1 env1 $ \ _ pv env' ->-              addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do-                v1  <- whnf (appendEnv env' env1) e1-                v2  <- whnf (appendEnv env' env2) e2-                leqVal' f pol (toMaybe12 tv012) v1 v2-            loop cls1' cls2'--eqPattern :: Pattern -> Pattern -> TypeCheck ()-eqPattern p1 p2 = if p1 == p2 then return () else throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2--}--type NameMap = [(Name,Name)]--alphaPattern :: Pattern -> Pattern -> StateT NameMap TypeCheck ()-alphaPattern p1 p2 = do-  let failure = throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2-      alpha x1 x2 = do-        ns <- get-        case lookup x1 ns of-          Nothing -> put $ (x1,x2) : ns-          Just x2' | x2 == x2' -> return ()-                   | otherwise -> failure-  case (p1,p2) of-    (VarP x1, VarP x2) -> alpha x1 x2-    (ConP pi1 n1 ps1, ConP pi2 n2 ps2) | pi1 == pi2 && n1 == n2 ->-      zipWithM_ alphaPattern ps1 ps2-    (SuccP p1, SuccP p2) -> alphaPattern p1 p2-    (SizeP _ x1, SizeP _ x2) -> alpha x1 x2-    (PairP p11 p12, PairP p21 p22) -> do-      alphaPattern p11 p21-      alphaPattern p12 p22-    (ProjP n1, ProjP n2) -> unless (n1 == n2) failure-    (DotP _, DotP _) -> return ()-    (AbsurdP, AbsurdP) -> return ()-    (ErasedP p1, ErasedP p2) -> alphaPattern p1 p2-    (UnusableP p1, UnusableP p2) -> alphaPattern p1 p2-    _ -> failure---- leqCases f p tv1 v1 v tv env cl--- checks whether  v1 <=p (VCase v tv env cl) : tv1-leqCases :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> [Clause] -> TypeCheck ()-leqCases f pol mt12 v1 v tvp env cl = do-  vcase <- evalCase v tvp env cl-  case vcase of-    (VCase v tvp env cl) -> mapM_ (leqCase f pol mt12 v1 v tvp env) cl-    v2 -> leqVal' f pol mt12 v1 v2---- absurd cases need not be checked-leqCase :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> Clause -> TypeCheck ()-leqCase f pol mt12 v1 v tvp env (Clause _ [p] Nothing) = return ()-leqCase f pol mt12 v1 v tvp env (Clause _ [p] (Just e)) = enterDoc (text "leqCase" <+> prettyTCM v <+> text " --> " <+> text (show p ++ "  |- ") <+> prettyTCM v1 <+> text (" <=" ++ show pol ++ " ") <+> prettyTCM (VClos env e)) $ do    -- ++ "  :  " ++ show mt12) $--- the dot patterns inside p are only valid in environment env-  let tv = case mt12 of-             Nothing -> vTopSort-             Just tv12 -> second12 tv12-  addPattern (tvp `arrow` tv) p env $ \ _ pv env' ->-    addRewrite (Rewrite v pv) [tv,v1] $ \ [tv',v1'] -> do-      v2  <- whnf (appendEnv env' env) e-      v2' <- reval v2 -- 2010-09-10, WHY?-      let mt12' = fmap (mapSecond12 (const tv')) mt12-      leqVal' f pol mt12' v1' v2'---- compare spines (see rule Al-App-Ne, Abel, MSCS 08)--- q ::= mixed | Pos | Neg-leqVals' :: Force -> Pol -> OneOrTwo TVal -> [Val] -> [Val] -> TypeCheck (OneOrTwo TVal)-leqVals' f q tv12 vl1 vl2 = do-  sh12 <- typeView12 =<< mapM force tv12-  case (vl1, vl2, sh12) of--    ([], [], _) -> return tv12--    (VProj Post p1 : vs1, VProj Post p2 : vs2, ShData d _) -> do-      unless (p1 == p2) $-        recoverFailDoc $ text "projections"-          <+> prettyTCM p1 <+> text "and"-          <+> prettyTCM p2 <+> text "differ!"-        -- recoverFail $ "projections " ++ show p1 ++ " and " ++ show p2 ++ " differ!"-      tv12 <- mapM (\ tv -> projectType tv p1 VIrr) tv12-      leqVals' f q tv12 vs1 vs2--    (w1:vs1, w2:vs2, ShQuant Pi x12 dom12 fv12) -> do-      let p = oneOrTwo id polAnd (fmap (polarity . decor) dom12)-      let dec = Dec p -- WAS: , erased = erased $ decor $ first12 dom12 }-      v1 <- whnfClos w1-      v2 <- whnfClos w2-      tv12 <- do-        if erased p -- WAS: (erased dec || p == Pol.Const)-         -- we have skipped an argument, so proceed with two types!-         then app12 (toTwo fv12) (Two v1 v2)-         else do-           let q' = polComp p q-           applyDec dec $-             leqVal' f q' (Just $ fmap typ dom12) v1 v2-           -- we have not skipped comparison, so proceed (1/2) as we came in-           case fv12 of-             Two{}  -> app12 fv12 (Two v1 v2)-             One fv -> One <$> app fv v1-               -- type is invariant, so it does not matter which one we take-      leqVals' f q tv12 vs1 vs2--    _ -> failDoc $ text "leqVals': not (compatible) function types or mismatch number of arguments when comparing "-           <+> prettyTCM vl1 <+> text " to "-           <+> prettyTCM vl2 <+> text " at type "-           <+> prettyTCM tv12---    _ -> throwErrorMsg $ "leqVals': not (compatible) function types or mismatch number of arguments when comparing  " ++ show vl1 ++ "  to  " ++ show vl2 ++ "  at type  " ++ show tv12--{--leqVals' f q (VPi x1 dom1@(Domain av1 _ dec1) env1 b1,-              VPi x2 dom2@(Domain av2 _ dec2) env2 b2)-         (w1:vs1) (w2:vs2) | dec1 == dec2 = do-  let p = polarity dec1-  v1 <- whnfClos w1-  v2 <- whnfClos w2-  when (not (erased dec1)) $-    applyDec dec1 $ leqVal' f (polComp p q) (Just (av1,av2)) v1 v2-  tv1 <- whnf (update env1 x1 v1) b1-  tv2 <- whnf (update env2 x2 v2) b2-  leqVals' f q (tv1,tv2) vs1 vs2--}--{--leqNe :: Force -> Val -> Val -> TypeCheck TVal-leqNe f v1 v2 = --trace ("leqNe " ++ show v1 ++ "<=" ++ show v2) $-  do case (v1,v2) of-      (VGen k1, VGen k2) -> if k1 == k2 then do-                                 dom <- lookupGem k1-                                 return $ typ dom-                               else throwErrorMsg $ "gen mismatch "  ++ show k1 ++ " " ++ show k2--}---- leqApp f pol v1 vs1 v2 vs2    checks   v1 vs1 <=pol v2 vs2--- pol ::= Param | Pos | Neg-leqApp :: Force -> Pol -> Val -> [Val] -> Val -> [Val] -> TypeCheck ()-leqApp f pol v1 w1 v2 w2 = {- trace ("leqApp: " -- ++ show delta ++ " |- "-                                  ++ show v1 ++ show w1 ++ " <=" ++ show pol ++ " " ++ show v2 ++ show w2) $ -}-{--  do let headMismatch = recoverFail $-            "leqApp: head mismatch "  ++ show v1 ++ " != " ++ show v2--}-  do let headMismatch = recoverFailDoc $ text "leqApp: head mismatch"-           <+> prettyTCM v1 <+> text "!=" <+> prettyTCM v2-     let emptyOrUnit u1 u2 =-          unlessM (isEmptyType u1) $ unlessM (isUnitType u2) $ headMismatch-     case (v1,v2) of-{-  IMPOSSIBLE:-      (VApp v1 [], v2) -> leqApp f pol v1 w1 v2 w2-      (v1, VApp v2 []) -> leqApp f pol v1 w1 v2 w2--}-{--      (VApp{}, _)    -> throwErrorMsg $ "leqApp: internal error: hit application v1 = " ++ show v1-      (_, VApp{})    -> throwErrorMsg $ "leqApp: internal error: hit application v2 = " ++ show v2--}--      (VUp v1 _, v2) -> leqApp f pol v1 w1 v2 w2-      (v1, VUp v2 _) -> leqApp f pol v1 w1 v2 w2--      (VGen k1, VGen k2) | k1 == k2 -> do-        tv12 <- (fmap typ . domain) <$> lookupGen k1-        leqVals' f pol tv12 w1 w2-        return ()-{--      (VGen k1, VGen k2) ->-        if k1 /= k2-          then headMismatch-          else do tv12 <- (fmap typ . domain) <$> lookupGen k1-                  leqVals' f pol tv12 w1 w2-                  return ()--}-{--      (VCon _ n, VCon _ m) ->-        if n /= m-         then throwErrorMsg $-            "leqApp: head mismatch "  ++ show v1 ++ " != " ++ show v2-         else do-          sige <- lookupSymb n-          case sige of-            (ConSig tv) -> -- constructor-               leqVals' f tv (repeat mixed) w1 w2 >> return ()--}--      (VDef n, VDef m) | n == m ->  do-        tv <- lookupSymbTypQ (idName n)-        leqVals' f pol (One tv) w1 w2-        return ()--      -- check for least or greatest type--      (u1,u2) -> if pol == Pos then emptyOrUnit u1 u2 else-                 if pol == Neg then emptyOrUnit u2 u1 else headMismatch--{--      -- least type-      (VDef (DefId DatK n), v2) | pol == Pos ->-        ifM (isEmptyData n) (return ()) headMismatch-      (v1, VDef (DefId DatK n)) | pol == Neg ->-        ifM (isEmptyData n) (return ()) headMismatch--}-{--      (VDef n, VDef m) ->-        if (name n) /= (name m) then do-           bot <- if pol==Neg then isEmptyData $ name m else-                  if pol==Pos then isEmptyData $ name n else return False-           if bot then return () else headMismatch-         else do-           tv <- lookupSymbTyp (name n)-           leqVals' f pol (One tv) w1 w2-           return ()--}-{--          sig <- gets signature-          case lookupSig (name n) sig of-            (DataSig{ numPars = p, positivity = pos, isSized = s, isCo = co, symbTyp = tv }) -> -- data type-               let positivitySizeIndex = if s /= Sized then mixed else-                                           if co == Ind then Pos else Neg-                   pos' = -- trace ("leqApp:  posOrig = " ++ show (pos ++ [positivitySizeIndex])) $-                     map (polComp pol) (pos ++ positivitySizeIndex : repeat mixed) -- the polComp will replace all SPos by Pos-               in leqVals' f tv pos' w1 w2-                    >> return ()---- otherwise, we are dealing with a (co) recursive function or a constructor-            entry -> leqVals' f (symbTyp entry) (repeat mixed) w1 w2 >> return ()--}--{--      _ -> headMismatch--      _ -> recoverFail $ "leqApp: " ++ show v1 ++ show w1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ show w2--}--isEmptyType :: TVal -> TypeCheck Bool-isEmptyType (VDef (DefId DatK n)) = isEmptyData n-isEmptyType _ = return False--isUnitType :: TVal -> TypeCheck Bool-isUnitType (VDef (DefId DatK n)) = isUnitData n-isUnitType _ = return False---- comparing sorts and sizes -------------------------------------------leqSort :: Pol -> Sort Val -> Sort Val -> TypeCheck ()-leqSort p = relPolM p leqSort'-{--leqSort mixed s1 s2 = leqSort' s1 s2 >> leqSort' s2 s1-leqSort Neg s1 s2 = leqSort' s2 s1-leqSort Pos s1 s2 = leqSort' s1 s2--}--leqSort' :: Sort Val -> Sort Val -> TypeCheck ()-leqSort' s1 s2 = do---  let err = "universe test " ++ show s1 ++ " <= " ++ show s2 ++ " failed"-  let err = text "universe test"-            <+> prettyTCM s1 <+> text "<="-            <+> prettyTCM s2 <+> text "failed"-  case (s1,s2) of-     (_            , Set VInfty)         -> return ()-     (SortC c      , SortC c') | c == c' -> return ()-     (Set v1       , Set v2)             -> leqSize Pos v1 v2-     (CoSet VInfty , Set v)              -> return ()-     (Set VZero    , CoSet{})            -> return ()-     (CoSet v1     , CoSet v2)           -> leqSize Neg v1 v2-     _ -> recoverFailDoc err--minSize :: Val -> Val -> Maybe Val-minSize v1 v2 =-  case (v1,v2) of-    (VZero,_)  -> return VZero-    (_,VZero)  -> return VZero-    (VInfty,_) -> return v2-    (_,VInfty) -> return v1-    (VMax vs,_) -> maxMins $ map (\ v -> minSize v v2) vs-    (_,VMax vs) -> maxMins $ map (\ v -> minSize v1 v) vs-    (VSucc v1', VSucc v2') -> fmap succSize $ minSize v1' v2'-    (VGen i, VGen j) -> if i == j then return $ VGen i else Nothing-    (VSucc v1', VGen j) -> minSize v1' v2-    (VGen i, VSucc v2') -> minSize v1 v2'--maxMins :: [Maybe Val] -> Maybe Val-maxMins mvs = case compressMaybes mvs of-                     [] -> Nothing-                     vs' -> return $ maxSize vs'---- substaging on size values-leqSize :: Pol -> Val -> Val -> TypeCheck ()-leqSize = leSize Le--ltSize :: Val -> Val -> TypeCheck ()-ltSize = leSize Lt Pos--leSize :: LtLe -> Pol -> Val -> Val -> TypeCheck ()-leSize ltle pol v1 v2 = enterDoc (text "leSize"-      <+> prettyTCM v1 <+> text (show ltle ++ show pol)-      <+> prettyTCM v2) $--- enter ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $-    traceSize ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $-    do case (v1,v2) of-         _ | v1 == v2 && ltle == Le -> return () -- TODO: better handling of sums!-         (VSucc v1,VSucc v2) -> leSize ltle pol v1 v2-{--         (VGen i1,VGen i2) -> do-           d <- getSizeDiff i1 i2 -- check size relation from constraints-           case d of-             Nothing -> recoverFail $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2-             Just k -> case (pol,k) of-               (_, 0) | pol == mixed -> return ()-               (Pos, _) | k >= 0 -> return ()-               (Neg, _) | k <= 0 -> return ()-               _ ->  recoverFail $ "leqSize: " ++ show v1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ " failed"--}-{--           if v1 == v2 then return ()-           else throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2--}-         (VInfty,VInfty) | ltle == Le -> return ()-                         | otherwise -> recoverFail "leSize: # < # failed"-         (VApp h1 tl1,VApp h2 tl2) -> leqApp N pol h1 tl1 h2 tl2-         _ -> relPolM pol (leSize' ltle) v1 v2--leqSize' :: Val -> Val -> TypeCheck ()-leqSize' = leSize' Le--leSize' :: LtLe -> Val -> Val -> TypeCheck ()-leSize' ltle v1 v2 = -- enter ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $-  enterDoc (text "leSize'" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2) $-    traceSize ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $-    do let failure = recoverFailDoc $ text "leSize':"-             <+> prettyTCM v1 <+> text (show ltle)-             <+> prettyTCM v2 <+> text "failed"-           -- err = "leSize': " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 ++ " failed"-       case (v1,v2) of-         (VZero,_) | ltle == Le -> return ()-         (VSucc{}, VZero) -> failure-         (VInfty, VZero) -> failure-         (VGen{}, VZero) -> failure-         (VMax vs,_) -> mapM_ (\ v -> leSize' ltle v v2) vs -- all v in vs <= v2-         (_,VMax vs)  -> foldr1 orM $ map (leSize' ltle v1) vs -- this produces a disjunction---         (_,VMax _)  -> addLe ltle v1 v2 -- this produces a disjunction-         (_,VInfty) | ltle == Le -> return ()-         (VZero, VInfty) -> return ()-         (VMeta{},VZero) -> addLe ltle v1 v2-{--         (0,VMeta i n', VMeta j m') ->-           let (n,m) = if bal <= 0 then (n', m' - bal) else (n' + bal, m') in--}-         (VMeta i rho n, VMeta j rho' m) ->-               addLe ltle (VMeta i rho  (n - min n m))-                        (VMeta j rho' (m - min n m))-         (VMeta i rho n, VSucc v2) | n > 0 -> leSize' ltle (VMeta i rho (n-1)) v2-         (VMeta i rho n, v2)  -> addLe ltle v1 v2-         (VSucc v1, VMeta i rho n) | n > 0 -> leSize' ltle v1 (VMeta i rho (n-1))-         (v1,VMeta i rho n) -> addLe ltle v1 v2-         _ -> leSize'' ltle 0 v1 v2-{- HANDLED BY leSize'' ltle-         (VSucc{}, VGen{}) -> throwErrorMsg err-         (VSucc{}, VPlus{}) -> throwErrorMsg err--}--- leSize'' ltle bal v v'  checks whether  Succ^bal v `lt` v'--- invariant: bal is zero in cases for VMax and VMeta-leSize'' :: LtLe -> Int -> Val -> Val -> TypeCheck ()-leSize'' ltle bal v1 v2 = traceSize ("leSize'' " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2) $-    do let failure = recoverFailDoc (text "leSize'':" <+> prettyTCM v1 <+> text ("+ " ++ show bal) <+> text (show ltle) <+> prettyTCM v2 <+> text "failed")-           check mb = ifM mb (return ()) failure-           ltlez = case ltle of { Le -> 0 ; Lt -> -1 }-       case (v1,v2) of-#ifdef STRICTINFTY--- Only cancel variables < #-         _ | v1 == v2 && ltle == Le && bal <= 0 -> return ()-         (VGen i, VGen j) | i == j && bal <= -1 -> check $ isBelowInfty i-#else--- Allow cancelling of all variables-         _ | v1 == v2 && bal <= ltlez -> return () -- TODO: better handling of sums!-#endif-         (VGen i, VInfty) | ltle == Lt -> check $ isBelowInfty i-         (VZero,_) | bal <= ltlez -> return ()-         (VZero,VInfty) -> return ()-         (VZero,VGen _) | bal > ltlez -> recoverFailDoc $ text "0 not <" <+> prettyTCM v2-         (VSucc v1, v2) -> leSize'' ltle (bal + 1) v1 v2-         (v1, VSucc v2) -> leSize'' ltle (bal - 1) v1 v2-         (VPlus vs1, VPlus vs2) -> leSizePlus ltle bal vs1 vs2-         (VPlus vs1, VZero) -> leSizePlus ltle bal vs1 []-         (VZero, VPlus vs2) -> leSizePlus ltle bal [] vs2-         (VPlus vs1, _) -> leSizePlus ltle bal vs1 [v2]-         (_, VPlus vs2) -> leSizePlus ltle bal [v1] vs2-         (VZero,_) -> leSizePlus ltle bal [] [v2]-         (_,VZero) -> leSizePlus ltle bal [v1] []-         _ -> leSizePlus ltle bal [v1] [v2]--#if (defined STRICTINFTY)-{-  2012-02-06 this modification cancels only variables < #-    However, omega-instantiation is valid [i < #] -> F i subseteq F #-    because every chain has a limit at #.--}-leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()-leSizePlus Lt bal vs1 vs2 = do-  vs2' <- filterM varBelowInfty vs2-  vs1' <- filterM varBelowInfty vs1-  leSizePlus' Lt bal (vs1 List.\\ vs2') (vs2 List.\\ vs1')-leSizePlus Le bal vs1 vs2 =-  leSizePlus' Le bal (vs1 List.\\ vs2) (vs2 List.\\ vs1)-#else-leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()-leSizePlus ltle bal vs1 vs2 =-  leSizePlus' ltle bal (vs1 List.\\ vs2) (vs2 List.\\ vs1)-#endif---varBelowInfty :: Val -> TypeCheck Bool-varBelowInfty (VGen i) = isBelowInfty i-varBelowInfty _        = return False--leSizePlus' :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()-leSizePlus' ltle bal vs1 vs2 = do-  let v1 = plusSizes vs1-  let v2 = plusSizes vs2-  let exit True  = return ()-      exit False | bal >= 0  = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text ("+ " ++ show bal ++ " " ++ show ltle) <+> prettyTCM v2 <+> text "failed")-                 | otherwise = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2 <+> text ("+ " ++ show (-bal) ++ " failed"))-  traceSizeM ("leSizePlus' ltle " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2)-  let ltlez = case ltle of { Le -> 0 ; Lt -> -1 }-  case (vs1,vs2) of-    ([],_) | bal <= ltlez -> return ()-    ([],[VGen i]) -> do-      n <- getMinSize i-      -- traceM ("getMinSize = " ++ show n)-      case n of-        Nothing -> exit False -- height of VGen i == 0-        Just n  -> exit (bal <= n + ltlez)-    ([VGen i1],[VGen i2]) -> do-      d <- sizeVarBelow i1 i2-      traceSizeM ("sizeVarBelow " ++ show (i1,i2) ++ " returns " ++ show d)-      case d of-        Nothing -> tryIrregularBound i1 i2 (ltlez - bal)--- recoverFail $ "leSize: head mismatch: " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2-        Just k -> exit (bal <= k + ltlez)-    _ -> exit False---- BAD HACK!--- check (VGen i1) <= (VGen i2) + k-tryIrregularBound :: Int -> Int -> Int -> TypeCheck ()-tryIrregularBound i1 i2 k = do-  betas <- asks bounds-  let beta = Bound Le (Measure [VGen i1]) (Measure [iterate VSucc (VGen i2) !! k])-  foldl (\ result beta' -> result `orM` entailsGuard Pos beta' beta)-    (recoverFail "bound not entailed")-    betas--{--leqSize' :: Val -> Val -> TypeCheck ()-leqSize' v1 v2 = --trace ("leqSize' " ++ show v1 ++ show v2) $-    do case (v1,v2) of-         (VMax vs,_) -> mapM_ (\ v -> leqSize' v v2) vs -- all v in vs <= v2-         (_,VMax _)  -> addLeq v1 v2 -- this produces a disjunction-         (VSucc v1,VSucc v2) -> leqSize' v1 v2-         (VGen v1,VGen v2) -> do-           d <- getSizeDiff v1 v2-           case d of-             Nothing -> throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2-             Just k -> if k >= 0 then return () else throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 ++ " failed"-         (_,VInfty) -> return ()-         (VMeta i n, VSucc v2) | n > 0 -> leqSize' (VMeta i (n-1)) v2-         (VMeta i n, VMeta j m) -> addLeq (VMeta i (n - min n m))-                                          (VMeta j (m - min n m))-         (VMeta i n, v2) -> addLeq v1 v2-         (VSucc v1, VMeta i n) | n > 0 -> leqSize' v1 (VMeta i (n-1))-         (v1,VMeta i n) -> addLeq v1 v2-         (v1,VSucc v2) -> leqSize' v1 v2-         _ -> throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2--}---- measures and guards -------------------------------------------------{---- compare lexicographically--- precondition: same length-ltMeasure :: Measure Val -> Measure Val -> TypeCheck ()-ltMeasure  (Measure mu1) (Measure mu2) =-  -- enter ("checking " ++ show mu1 ++ " < " ++ show mu2) $-    lexSizes Lt mu1 mu2--}--{--leqMeasure :: Pol -> Measure Val -> Measure Val -> TypeCheck ()-leqMeasure mixed (Measure mu1) (Measure mu2) = do-  zipWithM (leqSize mixed) mu1 mu2-  return ()-leqMeasure Pos (Measure mu1) (Measure mu2) = lexSizes mu1 mu2-leqMeasure Neg (Measure mu1) (Measure mu2) = lexSizes mu2 mu1--}---- lexSizes True  mu mu' checkes mu <  mu'--- lexSizes False mu mu' checkes mu <= mu'-lexSizes :: LtLe -> [Val] -> [Val] -> TypeCheck ()-lexSizes ltle mu1 mu2 = traceSize ("lexSizes " ++ show (ltle,mu1,mu2)) $-  case (ltle, mu1, mu2) of-    (Lt, [], []) -> recoverFail $ "lexSizes: no descent detected"-    (Le, [], []) -> return ()-    (lt, a1:mu1, a2:mu2) -> do-      b <- newAssertionHandling Failure $ errorToBool $ leSize ltle Pos a1 a2-      case (lt,b) of-        (Le,False) -> recoverFailDoc $ text "lexSizes: expected" <+> prettyTCM a1 <+> text "<=" <+> prettyTCM a2-            -- recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2-        (Lt,True) -> return ()-        _ -> lexSizes ltle mu1 mu2--{--      r <- compareSize a1 a2-      case r of-        LT -> return ()-        EQ -> lexSizes ltle mu1 mu2-        GT -> recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2--}--{---- TODO: reprogram leqSize in terms of a proper compareSize-compareSize :: Val -> Val -> TypeCheck Ordering-compareSize a1 a2 = do-  let ret o = trace ("compareSize: " ++ show a1 ++ " compared to " ++ show a2 ++ " returns " ++ show o) $ return o-  le <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a1 a2-  ge <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a2 a1-  case (le,ge) of-    (True,False) -> ret LT -- THIS IS COMPLETE BOGUS!!!-    (True,True)  -> ret EQ-    (False,True) -> ret GT-    (False,False) -> throwErrorMsg $ "compareSize (" ++ show a1 ++ ", " ++ show a2 ++ "): sizes incomparable"--}--{- Bound entailment--1. (mu1 <  mu1') ==> (mu2 <  mu2') if mu2 <= mu1 and mu1' <= mu2'-2. (mu1 <= mu1') ==> (mu2 <  mu2') one of these <= strict (<)-3. (mu1 <  mu1') ==> (mu2 <= mu2') as 1.-4. (mu1 <= mu1') ==> (mu2 <= mu2') as 1.---}-entailsGuard :: Pol -> Bound Val -> Bound Val -> TypeCheck ()-entailsGuard pol beta1@(Bound ltle1 (Measure mu1) (Measure mu1')) beta2@(Bound ltle2 (Measure mu2) (Measure mu2')) = enterDoc (text ("entailsGuard:") <+> prettyTCM beta1 <+> text (show pol ++ "==>") <+> prettyTCM beta2) $ do-  case pol of-    _ | pol == mixed -> do-      assert (ltle1 == ltle2) $ "unequal bound types"-      zipWithM (leqSize mixed) mu1  mu2-      zipWithM (leqSize mixed) mu1' mu2'-      return ()-    Pos | ltle1 == Lt || ltle2 == Le  -> do-      lexSizes Le mu2  mu1  -- not strictly smaller-      lexSizes Le mu1' mu2'-      return ()-    Pos -> do-      (lexSizes Lt mu2  mu1 >> lexSizes Le mu1' mu2')-      `orM`-      (lexSizes Le mu2  mu1 >> lexSizes Lt mu1' mu2')-    Neg   -> entailsGuard (switch pol) beta2 beta1--{--eqGuard :: Bound Val -> Bound Val -> TypeCheck ()-eqGuard (Bound (Measure mu1) (Measure mu1')) (Bound (Measure mu2) (Measure mu2')) = do-  zipWithM (leqSize mixed) mu1 mu2-  zipWithM (leqSize mixed) mu1' mu2'-  return ()--}--checkGuard :: Bound Val -> TypeCheck ()-checkGuard beta@(Bound ltle mu mu') =-  enterDoc (text "checkGuard" <+> prettyTCM beta) $-    lexSizes ltle (measure mu) (measure mu')--addOrCheckGuard :: Pol -> Bound Val -> TypeCheck a -> TypeCheck a-addOrCheckGuard Neg beta cont = checkGuard beta >> cont-addOrCheckGuard Pos beta cont = addBoundHyp beta cont---- comparing polarities ---------------------------------------------------leqPolM :: Pol -> PProd -> TypeCheck ()-leqPolM p (PProd Pol.Const _) = return ()-leqPolM p (PProd q m) | Map.null m && not (isPVar p) =-  if leqPol p q then return ()-   else recoverFail $ "polarity check " ++ show p ++ " <= " ++ show q ++ " failed"-leqPolM p q = do-  traceM $ "adding polarity constraint " ++ show p ++ " <= " ++ show q--leqPolPoly :: Pol -> PPoly -> TypeCheck ()-leqPolPoly p (PPoly l) = mapM_ (leqPolM p) l---- adding an edge to the positivity graph-addPosEdge :: DefId -> DefId -> PProd -> TypeCheck ()-addPosEdge src tgt p = unless (src == tgt && isSPos p) $ do-  -- traceM ("adding interesting positivity graph edge  " ++ show src ++ " --[ " ++ show p ++ " ]--> " ++ show tgt)-  st <- get-  put $ st { positivityGraph = Arc (Rigid src) (ppoly p) (Rigid tgt) : positivityGraph st }--checkPositivityGraph :: TypeCheck ()-checkPositivityGraph = enter ("checking positivity") $ do-  st <- get-  let cs = positivityGraph st-  let gr = buildGraph cs-  let n  = nextNode gr-  let m0 = mkMatrix n (graph gr)-  let m  = warshall m0-  let isDataId i = case Map.lookup i (intMap gr) of-                     Just (Rigid (DefId DatK _)) -> True-                     _ -> False-  let dataDiag = [ m Array.! (i,i) | i <- [0..n-1], isDataId i ]-  mapM_ (\ x -> leqPolPoly oone x) dataDiag-{--  let solvable = all (\ x -> leqPol oone x)-  unless solvable $ recoverFail $ "positivity check failed"--}-  -- TODO: solve constraints-  put $ st { positivityGraph = [] }---- telescopes ----------------------------------------------------------telView :: TVal -> TypeCheck ([(Val, TBinding TVal)], TVal)-telView tv = do-  case tv of-    VQuant Pi x dom fv -> underAbs_ x dom fv $ \ _ xv bv -> do-      (vTel, core) <- telView bv-      return ((xv, TBind x dom) : vTel, core)-    _ -> return ([], tv)---- | Turn a fully applied constructor value into a named record value.-mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val-mkConVal dotted co n vs vc = do-  (vTel, _) <- telView vc-  let fieldNames = map (boundName . snd) vTel-  return $ VRecord (NamedRec co n False dotted) $ zip fieldNames vs
− Eval.hs-boot 
@@ -1,39 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--module Eval where--import Abstract-import Value-import {-# SOURCE #-} TCM (TypeCheck)--class Reval a where-  reval' :: Valuation -> a -> TypeCheck a-  reval  :: a -> TypeCheck a-  reval = reval' emptyVal--instance Reval Val-instance Reval Env--toExpr :: Val -> TypeCheck Expr--whnf  :: Env -> Expr -> TypeCheck Val-whnf' :: Expr -> TypeCheck Val-app   :: Val -> Val -> TypeCheck Val--whnfClos :: Val -> TypeCheck Val-force :: Val -> TypeCheck Val-piApps :: TVal -> [Clos] -> TypeCheck TVal--matchList :: Env -> [Pattern] -> [Val] -> TypeCheck (Maybe Env)--type GenToPattern = [(Int,Pattern)]-type MatchState = (Env, GenToPattern)-nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState)--projectType :: TVal -> Name -> Val -> TypeCheck TVal--up    :: Bool -> Val -> TVal -> TypeCheck Val--leqSize' :: Val -> Val -> TypeCheck ()--mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val
− Extract.hs 
@@ -1,690 +0,0 @@-{-# LANGUAGE TupleSections, NamedFieldPuns #-}--module Extract where--{- extract to Fomega--Examples:------------MiniAgda--  data Vec (A : Set) : Nat -> Set-  { vnil  : Vec A zero-  ; vcons : [n : Nat] -> (head : A) -> (tail : Vec A n) -> Vec A (suc n)-  } fields head, tail--  fun length : [A : Set] -> [n : Nat] -> Vec A n -> <n : Nat>-  { length .A .zero    (vnil A)         = zero-  ; length .A .(suc n) (vcons A n a as) = suc (length A n as)-  }--Fomega--  data Vec (A : Set) : Set-  { vnil  : Vec A-  ; vcons : (head : A) -> (tail : Vec A) -> Vec A-  }--  fun head : [A : Set] -> Vec A -> A-  { head (vcons 'head 'tail) = 'head-  }--  fun tail : [A : Set] -> Vec A -> A-  { head (vcons 'head 'tail) = 'tail-  }--  fun length : [A : Set] -> Vec A -> Nat-  { length [A]  vnil             = zero-  ; length [A] (vcons [.A] a as) = suc (length [A] as)-  }---Bidirectional extraction-========================--Types--  Base ::= D As         data type-         | ?            inexpressible type--  A,B ::= Base | A -> B | [x:K] -> B | [] -> B  with erasure markers-  A0, B0 ::= Base | A0 -> B0 | [x:K0] -> B0     without erasure markers--  |.| erase erasure markers--Inference mode:--  Term extraction:  Gamma |- t :> A  --> e    |Gamma| |- e : |A|-  Type extraction:  Gamma |- T :> K  --> A    |Gamma| |- A : |K|-  Kind extraction:  Gamma |- U :> [] --> K    |Gamma| |- K : []--Checking mode:--  Term extraction:  Gamma |- t <: A  --> e    |Gamma| |- e : |A|-  Type extraction:  Gamma |- T <: K  --> A    |Gamma| |- A : |K|-  Kind extraction:  Gamma |- U <: [] --> K    |Gamma| |- K : []--Type and kind extraction keep erasure markers!--Checking abstraction:--  Relevant abstraction:-  Gamma, x:A |- t <: B --> e-  ---------------------------------  Gamma |- \x.t <: A -> B --> \x.e--  Type abstraction:-  Gamma, x:K |- t <: B --> e : B0-  -----------------------------------------  Gamma |- \[x].t <: [x:K] -> B --> \[x].e-      also \xt--  Irrelevant abstraction:-  Gamma |- t : B --> e-  --------------------------------  Gamma |- \[x].t : [] -> B --> e-      also \xt--  Relevant abstraction at unknown type:-  Gamma, x:? |- t : ? --> e-  ---------------------------  Gamma |- \x.t : ? --> \x.e--  Irrelevant abstraction at unknown type:-  Gamma |- t : ? --> e-  --------------------------  Gamma |- \[x].t : ? --> e--Checking by inference:--  Gamma |- t :> A --> e    e : |A| <: |B| --> e'-  -----------------------------------------------  Gamma |- t <: B --> e' : B0--Casting:--  ------------------ A0 does not contain ?-  e : A0 <: A0 --> e--  ----------------------- A0 != B0 or one does contain ?-  e : A0 <: B0 --> cast e--Inferring variable:--  -----------------------------  Gamma |- x :> Gamma(x) --> x--Inferring application:--  Relevant application:-  Gamma |- t :> A -> B --> f     Gamma |- u <: A --> e-  -----------------------------------------------------  Gamma |- t u :> B --> f e--  Type application:-  Gamma |- t :> [x:K] -> B --> f   Gamma |- u <: K --> A-  -------------------------------------------------------  Gamma |- t [u] :> : B[A/x] --> f [A]-      also  t u--  Irrelevant application:-  Gamma |- t :> [] -> B --> f-  ----------------------------  Gamma |- t [u] :> B --> f-      also  t u--  Relevant application at unknown type:-  Gamma |- t :> ? --> f     Gamma |- u <: ? --> e-  ------------------------------------------------  Gamma |- t u :> ? --> f e--  Irrelevant application at unknown type:-  Gamma |- t :> ? --> f-  --------------------------  Gamma |- t [u] :> ? --> f-----}--import Prelude hiding (pi, null)--import Control.Applicative-import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State--import Data.Char-import Data.Traversable (Traversable)-import qualified Data.Traversable as Traversable-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Maybe as Maybe--import Text.PrettyPrint--import Polarity as Pol-import Abstract-import Value-import Eval-import TCM-import TraceError-import Util--traceExtrM s = return ()--runExtract sig k = runExceptT (runReaderT (runStateT k (initWithSig sig)) emptyContext)---- extraction--type FExpr        = Expr-type FDeclaration = Declaration-type FClause      = Clause-type FPattern     = Pattern-type FConstructor = Constructor-type FTypeSig     = TypeSig-type FFun         = Fun-type FTelescope   = Telescope--type FTVal        = TVal--extractDecls :: [EDeclaration] -> TypeCheck [FDeclaration]-extractDecls ds = concat <$> mapM extractDecl ds--extractDecl :: EDeclaration -> TypeCheck [FDeclaration]-extractDecl d =-  case d of-    MutualDecl _ ds -> extractDecls ds -- TODO!-    OverrideDecl{} -> throwErrorMsg $ "extractDecls internal error: overrides impossible"-    MutualFunDecl _ co funs -> extractFuns co funs-    FunDecl co fun -> extractFun co fun-    LetDecl evl x tel (Just t) e | null tel -> extractLet evl x t e-    PatternDecl{}    -> return []-    DataDecl n _ co _ tel ty cs fields -> extractDataDecl n co tel ty cs--extractFuns :: Co -> [Fun] -> TypeCheck [FDeclaration]-extractFuns co funs = do-  funs <- concat <$> mapM extractFunTypeSig funs-  concat <$> mapM (extractFun co) funs--extractFun :: Co -> Fun -> TypeCheck [FDeclaration]-extractFun co (Fun (TypeSig n t) n' ar cls) = do-  tv <- whnf' t-  cls <- concat <$> mapM (extractClause n tv) cls-  return [ FunDecl co $ Fun (TypeSig n t) n' ar cls-         -- , LetDecl False (TypeSig n' t) (Var n)  -- no longer needed, since n and n' print the same-         ]--{- OLD-extractFun :: Co -> Fun -> TypeCheck [FDeclaration]-extractFun co (TypeSig n t, (ar, cls)) = extractIfTerm n $ do-  tv0 <- whnf' t-  t <- extractType tv0-  setExtrTyp n t-  let n' = mkExtName n-  setExtrTyp n' t-  tv <- whnf' t-  cls <- concat <$> mapM (extractClause n tv) cls-  return [ FunDecl co (TypeSig n t, (ar, cls))-         , LetDecl False (TypeSig n' t) (Var n)-         ]--}-{--extractFunTypeSigs :: [Fun] -> TypeCheck [Fun]-extractFunTypeSigs = mapM extractFunTypeSig--}---- only extract type sigs-extractFunTypeSig :: Fun -> TypeCheck [Fun]-extractFunTypeSig (Fun ts@(TypeSig n t) n' ar cls) = extractIfTerm n $ do-  ts@(TypeSig n t) <- extractTypeSig ts-  setExtrTyp n' t-  return [Fun ts n' ar cls]--extractLet :: Bool -> Name -> Type -> Expr -> TypeCheck [FDeclaration]-extractLet evl n t e = extractIfTerm n $ do-  TypeSig n t <- extractTypeSig (TypeSig n t)-  e <- extractCheck e =<< whnf' t-  return [LetDecl evl n emptyTel (Just t) e]--extractTypeSig :: TypeSig -> TypeCheck FTypeSig-extractTypeSig (TypeSig n t) = do-  t <- extractType =<< whnf' t-  setExtrTyp n t-  return $ TypeSig n t--extractIfTerm :: Name -> TypeCheck [a] -> TypeCheck [a]-extractIfTerm n cont = do-  k <- symbolKind <$> lookupSymb n-  if k == NoKind || lowerKind k == SortC Tm then cont else return []--extractDataDecl :: Name -> Co -> Telescope -> Type -> [Constructor] -> TypeCheck [FDeclaration]-extractDataDecl n co tel ty cs = do-  -- k    <- extrTyp <$> lookupSymb n-  tel' <- extractKindTel tel-  Just core <- addBinds tel $ extractKind =<< whnf' ty-  -- (_, core) = typeToTele' (length tel') k-  cs   <- mapM (extractConstructor tel) cs-  return [DataDecl n NotSized co [] tel' core cs []]--extractConstructor :: Telescope -> Constructor -> TypeCheck FConstructor-extractConstructor tel0 (Constructor n pars t) = do-{- fails for HEq-  -- 2012-01-22: remove irrelevant parameters-  let tel = filter (\ (TBind _ dom) -> not $ erased $ decor dom)  tel0--}-  let tel = tel0-  -- compute full extracted constructor type and add to the signature-  t' <- extractType =<< whnf emptyEnv (teleToTypeErase tel t)-  setExtrTypQ n t'-  let (tel',core) = typeToTele' (size tel) t'-  return $ Constructor n pars core-  -- compute type minus telescope-  -- TypeSig n <$> (extractType =<< whnf' t)--extractClause :: Name -> FTVal -> Clause -> TypeCheck [FClause]-extractClause f tv (Clause _ pl Nothing) = return [] -- discard absurd clauses-extractClause f tv cl@(Clause vtel pl (Just rhs)) = do-  traceM ("extracting clause " ++ render (prettyClause f cl)-          ++ "\n at type " ++ show tv)-{--  tel <- introPatterns pl tv0 $ \ _ _ -> do-           vtel <- getContextTele-           extractTeleVal vtel-  addBinds tel $--}-  introPatVars pl $-    extractPatterns tv pl $ \ pl tv -> do-      rhs <- extractCheck rhs tv-      return [Clause vtel pl (Just rhs)] -- TODO: return FTelescope (type!)---- the pattern variables are already in context-extractPatterns :: FTVal -> [Pattern] ->-                   ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a-extractPatterns tv [] cont = cont [] tv-extractPatterns tv (p:ps) cont =-  extractPattern tv p $ \ pl tv ->-    extractPatterns tv ps $ \ ps tv ->-      cont (pl ++ ps) tv--extractPattern :: FTVal -> Pattern ->-                  ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a-extractPattern tv p cont = do-  traceM ("extracting pattern " ++ render (pretty p) ++ " at type " ++ show tv)-  fv <- funView tv-  case fv of-    EraseArg tv -> cont [] tv  -- skip erased patterns--    Forall x dom fv -> do-      xv <- whnf' (patternToExpr p) -- pattern variables are already in scope-      bv <- app fv xv -- TODO!-      case p of-        ErasedP (VarP y) -> setTypeOfName y dom $ cont [] bv-        _ -> cont [] bv-{--    Forall x ki env t -> new x ki $ \ xv ->-      cont [] =<< whnf (update env x xv) t -- TODO!--}-    Arrow av bv -> extractPattern' av p (flip cont bv)--extractPattern' :: FTVal -> Pattern ->-                  ([FPattern] -> TypeCheck a) -> TypeCheck a-extractPattern' av p cont =-      case p of-        VarP y -> setTypeOfName y (defaultDomain av) $-          cont [VarP y]-        PairP p1 p2 -> do-          view <- prodView av-          -- hack to avoid IMPOSSIBLE-          let (av1, av2) = case view of-                             Prod av1 av2 -> (av1, av2)-                             _ -> (av, av) -- HACK-          extractPattern' av1 p1 $ \ ps1 -> do-            extractPattern' av2 p2 $ \ ps2 ->-               let ps [] ps2    = ps2-                   ps ps1 []    = ps1-                   ps [p1] [p2] = [PairP p1 p2]-               in  cont $ ps ps1 ps2--{--          case view of-            Prod av1 av2 ->-              extractPattern' av1 p1 $ \ [p1] -> do-                extractPattern' av2 p2 $ \ [p2] -> cont [PairP p1 p2]-            _ -> throwErrorMsg $ "extractPattern': IMPOSSIBLE: pattern " ++-                          show p ++ " : " ++ show av--}-        ConP pi n ps -> do---          tv <- whnf' =<< extrTyp <$> lookupSymb n-          tv <- extrConType n av-          extractPatterns tv ps $ \ ps _ ->-            cont [ConP pi n ps]-        _ -> cont []--extrConType :: QName -> FTVal -> TypeCheck FTVal-extrConType c av = do-  ConSig { conPars, extrTyp, dataPars } <- lookupSymbQ c-  traceExtrM ("extrConType " ++ show c ++ " has extrTyp = " ++ show extrTyp)-  tv <- whnf' extrTyp-  numPars <- maybe (return dataPars) (const $ throwErrorMsg $ "NYI: extrConType for pattern parameters") conPars-  case numPars of-   0 -> return tv-   _ -> do-    case av of-      VApp (VDef (DefId DatK d)) vs -> do-        DataSig { positivity } <- lookupSymbQ d-        traceExtrM ("extrConType " ++ show c ++ "; data type has positivity = " ++ show positivity)-        let pars 0 pols vs = []-            pars n (pol:pols) vs | erased pol = VIrr : pars (n-1) pols vs-            pars n (pol:pols) (v:vs) = v : pars (n-1) pols vs-            pars n pols vs = error $ "pars " ++ show n ++ show pols ++ show vs-        piApps tv $ pars numPars positivity $ vs ++ repeat VIrr-{--        let (pars, inds) = splitAt numPars vs-        piApps tv pars--}-      _ -> piApps tv $ replicate numPars VIrr---      _ -> throwErrorMsg $ "extrConType " ++ show c ++ ": expected datatype, found " ++ show av---- extracting a term from a term ---------------------------------------extractInfer :: Expr -> TypeCheck (FExpr, FTVal)-extractInfer e = do-  case e of--    Var x -> (Var x,) . typ . domain <$> lookupName1 x--    App f e0 -> do-      let (er, e) = isErasedExpr e0-      (f, tv) <- extractInfer f-      fv <- funView tv-      case fv of-        EraseArg bv -> return (f,bv)-        Forall x dom fv -> do-          e <- extractTypeAt e (typ dom)-          bv <- app fv =<< whnf' e-          return $ (App f (erasedExpr e), bv)-        Arrow av bv -> return (if er then f else App f e, bv)-        NotFun -> return (if er then f else castExpr f `App` e, VIrr)--    Def f -> (Def f,) <$> do (whnf' . extrTyp) =<< lookupSymbQ (idName f)--    Pair{} -> throwErrorMsg $ "extractInfer: IMPOSSIBLE: pair " ++ show e-    -- other expressions are erased or types--    _ -> return (Irr, VIrr)--extractCheck :: Expr -> FTVal -> TypeCheck (FExpr)-extractCheck e tv = do-  case e of-    Lam dec y e -> do-      fv <- funView tv-      case fv of-        EraseArg bv        -> extractCheck e bv -- discard lambda-        Forall x dom fv    ->-          Lam (decor dom) y <$> do-            newWithGen y dom $ \ i xv ->-              extractCheck e =<< app fv (VGen i) -- no eta-expansion-        Arrow av bv        ->-          if erased dec then extractCheck e bv-           else Lam dec y <$> do-             new' y (defaultDomain av) $-               extractCheck e bv-        NotFun            -> castExpr <$>-          if erased dec then extractCheck e VIrr-           else Lam dec y <$> do-             new' y (defaultDomain VIrr) $-               extractCheck e VIrr--    LLet (TBind x dom0) tel e1 e2 | null tel -> do-      let dom = fmap Maybe.fromJust dom0-      if erased (decor dom) then extractCheck e2 tv else do -- discard let-       vdom <- Traversable.mapM whnf' dom         -- MiniAgda type val-       dom  <- Traversable.mapM extractType vdom  -- Fomega type-       vdom <- Traversable.mapM whnf' dom         -- Fomega type val-       e1  <- extractCheck e1 (typ vdom)-       LLet (TBind x (fmap Just dom)) emptyTel e1 <$> do-         new' x vdom $ extractCheck e2 tv--    Pair e1 e2 -> do-      view <- prodView tv-      let (av1,av2) = case view of-                        Prod av1 av2 -> (av1, av2)-                        _ -> (tv,tv) -- HACK!!-      Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2-{--      case view of-        Prod av1 av2 -> Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2-        _ -> throwErrorMsg $ "extractCheck: tuple type expected " ++ show e ++ " : " ++ show tv--}--    -- TODO: case--    _ -> fallback-  where-    fallback = do-      (e,tv') <- extractInfer e-      insertCast e tv tv'--insertCast :: FExpr -> FTVal -> FTVal -> TypeCheck FExpr-insertCast e tv1 tv2 = loop tv1 tv2 where-  loop tv1 tv2 =-    case (tv1,tv2) of-      (VIrr,_) -> return $ castExpr e-      (_,VIrr) -> return $ castExpr e-      _  -> return e -- TODO!--funView :: FTVal -> TypeCheck FunView-funView tv =-  case tv of-    -- erasure mark-    VQuant Pi x dom fv | erased (decor dom) && typ dom == VIrr ->-      EraseArg <$> app fv VIrr-    -- forall-    VQuant Pi x dom fv | erased (decor dom) ->-      return $ Forall x dom fv-    -- function type-    VQuant Pi x dom fv ->-      Arrow (typ dom) <$> app fv VIrr-    -- any other type can be a function type, but this needs casts!-    _ -> return NotFun -- $ Arrow VIrr VIrr--data FunView-  = Arrow    FTVal FTVal            -- A -> B-  | Forall   Name Domain FTVal      -- forall X:K. A-  | EraseArg FTVal                  -- [] -> B-  | NotFun                          -- ()--prodView :: FTVal -> TypeCheck ProdView-prodView tv =-  case tv of-    VQuant Sigma x dom fv -> Prod (typ dom) <$> app fv VIrr-    _                     -> return $ NotProd--data ProdView-  = Prod FTVal FTVal -- A * B-  | NotProd---- extracting a kind from a value --------------------------------------type FKind = Expr -- FKind ::= Set | FKind -> FKind | [Irr] -> FKind--star :: FKind-star = Sort $ Set Zero--extractSet :: Sort Val -> Maybe FKind-extractSet s =-  case s of-    SortC _ -> Nothing-    Set _   -> Just $ star-    CoSet _ -> Just $ star---- keep irrelevant entries-extractKindTel :: Telescope -> TypeCheck FTelescope-extractKindTel (Telescope tel) = Telescope <$> loop tel where-  loop [] = return []-  loop (TBind x dom : tel) = do-    dom  <- Traversable.mapM whnf' dom-    dom' <- extractKindDom dom-    if erased (decor dom') then-      newIrr x $-        (TBind x dom' :) <$> loop tel-     else newTyVar x (typ dom') $ \ i -> do-        x <- nameOfGen i-        (TBind x dom' :) <$> loop tel--{---- keep irrelevant entries-extractKindTel :: Telescope -> TypeCheck FTelescope-extractKindTel tel = do-  tv     <- whnf' (teleToType tel star)-  Just k <- extractKind tv-  let (tel, s) = typeToTele k-  return tel-  -- throw away erasure marks-  -- return $ filter (\ tb -> not $ erased $ decor $ boundDom tb) tel--}--extractKindDom :: Domain -> TypeCheck (Dom FKind)-extractKindDom dom =-  maybe (defaultIrrDom Irr) defaultDomain <$>-    if erased (decor dom) then return Nothing-     else extractKind (typ dom)--extractKind :: TVal -> TypeCheck (Maybe FKind)-extractKind tv =-  case tv of-    VSort s -> return $ extractSet s-    VMeasured mu vb -> extractKind vb-    VGuard beta vb -> extractKind vb-    VQuant Pi x dom fv -> new' x dom $ do-       bv  <- app fv VIrr-       mk' <- extractKind bv-       case mk' of-         Nothing -> return Nothing-         Just k' -> do-           dom' <- extractKindDom dom-           let x = fresh ""-           return $ Just $ pi (TBind x dom') k'-    _ -> return Nothing---- extracting a type constructor from a value --------------------------type FType = Expr-{- FType ::= Irr                 -- not expressible in Fomega-           | D FTypes            -- data type-           | X FTypes            -- type variable-           | FType -> FType      -- function type-           | [X:FKind] -> FType  -- polymorphic type-           | [Irr] -> FType      -- erasure marker- -}---- tyVarName i = fresh $ "a" ++ show i--newTyVar :: Name -> FKind -> (Int -> TypeCheck a) -> TypeCheck a-newTyVar x k cont = newWithGen x (defaultDomain (VClos emptyEnv k)) $-  \ i _ -> cont i                  -- store kinds unevaluated--addFKindTel :: FTelescope -> TypeCheck a -> TypeCheck a-addFKindTel (Telescope tel) = loop tel where-  loop []                  cont = cont-  loop (TBind x dom : tel) cont = newTyVar x (typ dom) $ \ _ ->-    loop tel cont--extractTeleVal :: TeleVal -> TypeCheck FTelescope-extractTeleVal = Telescope <.> loop where-  loop []          = return []-  loop (tb : vtel) = do-    tb <- Traversable.mapM extractType tb-    addBind tb $ do-      (tb :) <$> loop vtel--extractType :: TVal -> TypeCheck FType-extractType = extractTypeAt star--extractTypeAt :: FKind -> TVal -> TypeCheck FType-extractTypeAt k tv = do-  case (tv,k) of--    (VMeasured mu vb, _) -> extractTypeAt k vb-    (VGuard beta vb, _) -> extractTypeAt k vb--    -- relevant function space / sigma type --> non-dependent-    (VQuant pisig x dom fv, _) | not (erased (decor dom)) -> do-      a <- extractType (typ dom)-      -- new' x dom $ do-      bv <- app fv VIrr-      b  <- extractType bv-      let x = fresh ""-      return $ piSig pisig (TBind x (defaultDomain a)) b--    -- irrelevant function space --> forall or erasure marker-    (VQuant Pi x dom fv, _) | erased (decor dom) -> do-      mk <- extractKind (typ dom)-      case mk of-        Nothing -> do -- new' x dom $ do-          bv <- app fv VIrr-          b  <- extractType bv-          let x = fresh ""-          return $ pi (TBind x (defaultIrrDom Irr)) b-        Just k' -> do-          newTyVar x k' $ \ i -> do-            bv <- app fv $ VGen i-            b  <- extractType bv-            x  <- nameOfGen i-            return $ pi (TBind x (defaultIrrDom k')) b--    (VApp (VDef (DefId DatK n)) vs, _) -> do-      k  <- extrTyp <$> lookupSymbQ n  -- get kind of dname from signature-      as <- extractTypes k vs  -- turn vs into types as at kind k-      return $ foldl App (Def (DefId DatK n)) as--    (VGen i,_) -> do---      VClos _ k <- (typ . fromOne . domain) <$> lookupGen i  -- get kind of var from cxt-      Var <$> nameOfGen i-      -- return $ Var (tyVarName i)--    (VApp (VGen i) vs,_) -> do-      VClos _ k <- (typ . fromOne . domain) <$> lookupGen i  -- get kind of var from cxt-      as <- extractTypes k vs  -- turn vs into types as at kind k-      x <- nameOfGen i-      return $ foldl App (Var x) as--    (VLam x env e, Quant Pi (TBind _ dom) k) | erased (decor dom) -> do-      tv <- whnf (update env x VIrr) e-      extractTypeAt k tv--    (VLam x env e, Quant Pi (TBind _ dom) k) -> newTyVar x (typ dom) $ \ i -> do-      tv <- whnf (update env x (VGen i)) e-      x  <- nameOfGen i-      Lam defaultDec x <$> extractTypeAt k tv--    (VLam{},_) -> error $ "panic! extractTypeAt " ++ show (tv,k)--    (VSing _ tv,_) -> extractTypeAt k tv--    (VUp v _,_)    -> extractTypeAt k v--    _ -> return Irr--extractTypes :: FKind -> [TVal] -> TypeCheck [FType]-extractTypes k vs =-  case (k,vs) of-    (_, []) -> return []-    (Quant Pi (TBind _ dom) k, v:vs) | erased (decor dom) -> extractTypes k vs-    (Quant Pi (TBind _ dom) k, v:vs) -> do-      v  <- whnfClos v-      a  <- extractTypeAt (typ dom) v-      as <- extractTypes k vs-      return $ a : as-    _ -> error $ "panic! extractTypes  " ++ show k ++ "  " ++ show vs---- auxiliary functions -------------------------------------------------{- this is setExtrTyp-addFTypeSig :: Name -> FType -> TypeCheck ()-addFTypeSig n t = modifySig n (\ item -> item { extrTyp = t })--}
− HsSyntax.hs 
@@ -1,129 +0,0 @@-{- 2010-09-17 haskell syntax tools -}--module HsSyntax where--import Abstract (PiSigma(..))-import Language.Haskell.Exts.Syntax--noLoc :: SrcLoc-noLoc = SrcLoc "" 0 0--mkQual :: String -> String -> QName-mkQual m s = Qual (ModuleName m) (Ident s)--mkModule :: [Decl] -> Module-mkModule hs = Module noLoc main_mod pragmas warning exports imports decls where-  pragmas = [ LanguagePragma noLoc $ map Ident-    [ "NoImplicitPrelude"-    , "GADTs"-    , "KindSignatures"-    ]]-  warning = Nothing-  exports = Nothing-  imports =-    [ mkQualImport "GHC.Show" "Show"-    , mkQualImport "System.IO" "IO"-    , mkQualImport "Unsafe.Coerce" "Coerce"-    ]-  decls   = hs ++-    [ TypeSig noLoc [ main_name ] io-    , FunBind [ mkClause main_name [] rhs ]-    ] where rhs  = Var (mkQual "IO" "putStrLn") `App` Lit (String "Hello, world!")-            io   = TyCon (mkQual "IO" "IO") `TyApp` unit_tycon--mkQualImport :: String -> String -> ImportDecl-mkQualImport modName asName =-  ImportDecl-  { importLoc       = noLoc-  , importModule    = ModuleName modName-  , importQualified = True-  , importSrc       = False-  , importPkg       = Nothing-  , importAs        = Just $ ModuleName asName-  , importSpecs     = Nothing-  }--noContext = []-noDeriving = []-noTyVarBind = []-showDeriving = (mkQual "Show" "Show", [])--mkDataDecl :: Name -> [TyVarBind] -> Kind -> [GadtDecl] -> Decl-mkDataDecl n tel k cs = GDataDecl noLoc DataType noContext n tel (Just k) cs [showDeriving]--mkConDecl :: Name -> Type -> GadtDecl-mkConDecl n t = GadtDecl noLoc n t--mkKindFun :: Kind -> Kind -> Kind-mkKindFun = KindFn-{--mkKindFun k k' = parens k `KindFn` k'-      where parens H.KindStar = H.KindStar-            parens k          = H.KindParen k--}--mkTyPiSig :: PiSigma -> Type -> Type -> Type-mkTyPiSig Pi    = mkTyFun-mkTyPiSig Sigma = mkTyProd--mkTyProd :: Type -> Type -> Type-mkTyProd a b = TyTuple Boxed [a,b]--mkTyFun :: Type -> Type -> Type-mkTyFun = TyFun--- mkTyFun a b = mkTyParen a `TyFun` b--mkForall :: Name -> Kind -> Type -> Type-mkForall x k t = TyForall (Just $ [KindedVar x k]) noContext t--mkTyParen :: Type -> Type-mkTyParen a@(TyVar{}) = a-mkTyParen a@(TyCon{}) = a-mkTyParen a = TyParen a--mkTyApp :: Type -> Type -> Type-mkTyApp f a = TyApp f a--noBinds = BDecls []--mkTypeSig :: Name -> Type -> Decl-mkTypeSig x t = TypeSig noLoc [x] t---- create a simple function clause x = t-mkLet :: Name -> Exp -> Decl-mkLet x e = FunBind [mkClause x [] e]--mkClause :: Name -> [Pat] -> Exp -> Match-mkClause f ps e = Match noLoc f ps Nothing (UnGuardedRhs e) noBinds--mkCast :: Exp -> Exp-mkCast e = Var (mkQual "Coerce" "unsafeCoerce") `App` e--mkCon :: Name -> Exp-mkCon = Con . UnQual--mkVar :: Name -> Exp-mkVar = Var . UnQual--mkLam :: Name -> Exp -> Exp-mkLam x (Lambda _ ps e) = Lambda noLoc (PVar x : ps) e-mkLam x  e              = Lambda noLoc [PVar x] e--mkParen :: Exp -> Exp-mkParen e@(Var{}) = e-mkParen e@(Con{}) = e-mkParen e = Paren e--mkApp :: Exp -> Exp -> Exp-mkApp f e = App f e -- (mkParen e)--mkLLet :: Name -> Maybe Type -> Exp -> Exp -> Exp-mkLLet x t e e' = Let (BDecls [mkLet x e]) e'--mkPair :: Exp -> Exp -> Exp-mkPair e1 e2 = Tuple Boxed [e1,e2]--{- this is already predefined as unit_con-hsDummyExp :: HsExp-hsDummyExp = HsCon $ Special $ HsUnitCon  -- Haskell's '()'--}
− Lexer.x 
@@ -1,208 +0,0 @@--{--module Lexer where--}--%wrapper "posn"--$digit = 0-9			-- digits-$alpha = [a-zA-Z]		-- alphabetic characters-$u     = [ . \n ]               -- universal: any character-@ident = $alpha ($alpha | $digit | \_ | \')*  -- identifier--tokens :---$white+				;-"--".*				;-"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;---sized	    	     	   	{ tok (\p s -> Sized p) }-data				{ tok (\p s -> Data p) }-codata				{ tok (\p s -> CoData p) }-record				{ tok (\p s -> Record p) }-fields                          { tok (\p s -> Fields p) }-fun				{ tok (\p s -> Fun p) }-cofun				{ tok (\p s -> CoFun p) }-pattern                         { tok (\p s -> Pattern p) }-case                            { tok (\p s -> Case p) }-def				{ tok (\p s -> Def p) }-let				{ tok (\p s -> Let p) }-in				{ tok (\p s -> In p) }-eval				{ tok (\p s -> Eval p)}-fail				{ tok (\p s -> Fail p)}-check				{ tok (\p s -> Check p)}-trustme				{ tok (\p s -> TrustMe p)}-impredicative                 	{ tok (\p s -> Impredicative p)}-mutual				{ tok (\p s -> Mutual p) }-Type				{ tok (\p s -> Type p) }-Set				{ tok (\p s -> Set p) }-CoSet				{ tok (\p s -> CoSet p) }-"<|"                            { tok (\p s -> LTri p) }-"|>"                            { tok (\p s -> RTri p) }-Size				{ tok (\p s -> Size p) }-\#				{ tok (\p s -> Infty p) }-\$				{ tok (\p s -> Succ p) }-max                             { tok (\p s -> Max p) }--\{				{ tok (\p s -> BrOpen p) }-\}				{ tok (\p s -> BrClose p) }-\[				{ tok (\p s -> BracketOpen p) }-\]				{ tok (\p s -> BracketClose p) }-\(				{ tok (\p s -> PrOpen p) }-\)				{ tok (\p s -> PrClose p) }-\|				{ tok (\p s -> Bar p) }-\;				{ tok (\p s -> Sem p) }-\:				{ tok (\p s -> Col p) }-\,				{ tok (\p s -> Comma p) }-\.				{ tok (\p s -> Dot p) }-\+\+                            { tok (\p s -> PlusPlus p) }-\+				{ tok (\p s -> Plus p) }-\-				{ tok (\p s -> Minus p) }-\/				{ tok (\p s -> Slash p) }-\*				{ tok (\p s -> Times p) }-\^				{ tok (\p s -> Hat p) }-\&				{ tok (\p s -> Amp p) }-"->"				{ tok (\p s -> Arrow p)  }-"<="                            { tok (\p s -> Leq p)  }-=				{ tok (\p s -> Eq p) }-\\				{ tok (\p s -> Lam p) }-\_				{ tok (\p s -> Underscore p) }-\<                              { tok (\p s -> AngleOpen p) }-\>                              { tok (\p s -> AngleClose p) }--[$digit]+		        { tok (\p s -> (Number s p )) }-@ident                          { tok (\p s -> (Id s p )) }-@ident \. @ident                { tok (\p s -> (qualId s p)) }--{-data Token = Id String AlexPosn-           | QualId (String, String) AlexPosn-     	   | Number String AlexPosn-     	   | Sized AlexPosn-           | Data AlexPosn-	   | CoData AlexPosn-	   | Record AlexPosn-	   | Fields AlexPosn-	   | Mutual AlexPosn-           | Fun AlexPosn-           | CoFun AlexPosn-           | Pattern AlexPosn-	   | Case AlexPosn-	   | Def AlexPosn-	   | Let AlexPosn-	   | In AlexPosn-           | Type AlexPosn-           | Set AlexPosn-           | CoSet AlexPosn-	   | Eval AlexPosn-	   | Fail AlexPosn-	   | Check AlexPosn-	   | TrustMe AlexPosn-	   | Impredicative AlexPosn-           -- size type-           | Size AlexPosn-           | Infty AlexPosn-           | Succ AlexPosn-           | Max AlexPosn-           ---           | LTri AlexPosn-           | RTri AlexPosn-           | AngleOpen AlexPosn-           | AngleClose AlexPosn-           | BrOpen AlexPosn-           | BrClose AlexPosn-           | BracketOpen AlexPosn-           | BracketClose AlexPosn-           | PrOpen AlexPosn-           | PrClose AlexPosn-           | Bar AlexPosn-           | Sem AlexPosn-           | Col AlexPosn-	   | Comma AlexPosn-	   | Dot AlexPosn-           | Arrow AlexPosn-           | Leq AlexPosn-           | Eq AlexPosn-	   | PlusPlus AlexPosn-	   | Plus AlexPosn-	   | Minus AlexPosn-	   | Slash AlexPosn-	   | Times AlexPosn-	   | Hat AlexPosn-	   | Amp AlexPosn-           | Lam AlexPosn-           | Underscore AlexPosn-           | NotUsed AlexPosn -- so happy doesn't generate overlap case pattern warning-             deriving (Eq)--qualId s p = let (m, '.':n) = break (== '.') s in QualId (m,n) p--prettyTok :: Token -> String-prettyTok c = "\"" ++ tk ++ "\" at " ++ (prettyAlexPosn pos) where-  (tk,pos) = case c of-    (Id s p) -> (show s,p)-    (QualId (m, n) p) -> (show m ++ "." ++ show n, p)-    (Number i p) -> (i,p)-    Sized p -> ("sized",p)-    Data p -> ("data",p)-    CoData p -> ("codata",p)-    Record p -> ("record",p)-    Fields p -> ("fields",p)-    Mutual p -> ("mutual",p)-    Fun p -> ("fun",p)-    CoFun p -> ("cofun",p)-    Pattern p -> ("pattern",p)-    Case p -> ("case",p)-    Def p -> ("def",p)-    Let p -> ("let",p)-    In p -> ("in",p)-    Eval p -> ("eval",p)-    Fail p -> ("fail",p)-    Check p -> ("check",p)-    TrustMe p -> ("trustme",p)-    Impredicative p -> ("impredicative",p)-    Type p -> ("Type",p)-    Set p -> ("Set",p)-    CoSet p -> ("CoSet",p)-    Size p -> ("Size",p)-    Infty p -> ("#",p)-    Succ p -> ("$",p)-    Max p -> ("max",p)-    LTri p -> ("<|",p)-    RTri p -> ("|>",p)-    AngleOpen p -> ("<",p)-    AngleClose p -> (">",p)-    BrOpen p -> ("{",p)-    BrClose p -> ("}",p)-    BracketOpen p -> ("[",p)-    BracketClose p -> ("]",p)-    PrOpen p -> ("(",p)-    PrClose p -> (")",p)-    Bar p -> ("|",p)-    Sem p -> (";",p)-    Col p -> (":",p)-    Comma p -> (",",p)-    Dot p -> (".",p)-    Arrow p -> ("->",p)-    Leq p -> ("<=",p)-    Eq p -> ("=",p)-    PlusPlus p -> ("++",p)-    Plus p -> ("+",p)-    Minus p -> ("-",p)-    Slash p -> ("/",p)-    Times p -> ("*",p)-    Hat p -> ("^",p)-    Amp p -> ("&",p)-    Lam p -> ("\\",p)-    Underscore p -> ("_",p)-    _ -> error "not used"---prettyAlexPosn (AlexPn _ line row) = "line " ++ show line ++ ", row " ++ show row--tok f p s = f p s--}
− Main.hs 
@@ -1,136 +0,0 @@-module Main where--import Prelude hiding (null)--import System.Environment-import System.Exit-import System.IO (stdout, hSetBuffering, BufferMode(..))--import qualified Language.Haskell.Exts.Syntax as H-import qualified Language.Haskell.Exts.Pretty as H--import Lexer-import Parser--import qualified Concrete as C-import qualified Abstract as A-import Abstract (Name)-import ScopeChecker-import Value-import TCM-import TypeChecker-import Extract-import ToHaskell--import Util--main :: IO ()-main = do-  hSetBuffering stdout NoBuffering-  putStrLn "MiniAgda by Andreas Abel and Karl Mehltretter"-  args <- getArgs-  mapM_ mainFile args--mainFile :: String -> IO ()-mainFile fileName = do-  putStrLn $ "--- opening " ++ show fileName ++ " ---"-  file <- readFile fileName-  let t = alexScanTokens file-  let cdecls =  parse t-  -- putStrLn "--- parsing ---"-  -- mapM (putStrLn . show) cdecls-  putStrLn "--- scope checking ---"-  adecls <- doScopeCheck cdecls-  -- mapM (putStrLn . show) adecls-  putStrLn "--- type checking ---"-  (edecls, sig) <- doTypeCheck adecls-  putStrLn "--- evaluating ---"-  showAll sig adecls-{--  putStrLn "--- extracting ---"-  edecls <- doExtract sig edecls-  hsmodule <- doTranslate edecls-  putStrLn $ H.prettyPrint hsmodule-  -- printHsDecls hsdecls--}-  putStrLn $ "--- closing " ++ show fileName ++ " ---"---- print extracted program--ppHsMode :: H.PPHsMode-ppHsMode = H.PPHsMode  -- H.defaultMode-  { H.classIndent  = 2-  , H.doIndent     = 3-  , H.caseIndent   = 3-  , H.letIndent    = 4-  , H.whereIndent  = 2-  , H.onsideIndent = 1-  , H.spacing      = False-  , H.layout       = H.PPOffsideRule-  , H.linePragmas  = False-  }--printHsDecls :: [H.Decl] -> IO ()-printHsDecls hs = mapM_ (putStrLn . H.prettyPrintWithMode ppHsMode) hs---- all let declarations-allLet :: Signature -> [A.Declaration] -> [(Name,A.Expr)]-allLet sig [] = []-allLet sig (decl:xs) =-    case decl of-      (A.LetDecl True n tel _ e) | null tel ->-          (n,e):(allLet sig xs)-      _ -> allLet sig xs---showAll :: Signature -> [A.Declaration] -> IO ()-showAll sig decl = mapM_ (showLet sig) $ allLet sig decl--showLet :: Signature -> (Name,A.Expr) -> IO ()-showLet sig (n,e) = do-  r <- doWhnf sig e-  case r of-    Right (v,_) -> putStrLn $ show n ++ " has whnf " ++ show v-    Left err    -> do putStrLn $ "error during evaluation:\n" ++ show err-                      exitFailure-  r <- doNf sig e-  case r of-    Right (v,_) -> putStrLn $ show n ++ " evaluates to " ++ show v-    Left err    -> do putStrLn $ "error during evaluation:\n" ++ show err-                      exitFailure--doExtract :: Signature -> [A.EDeclaration] -> IO [A.EDeclaration]-doExtract sig decls = do-  k <- runExtract sig $ extractDecls decls-  case k of-    Left err -> do-      putStrLn $ "error during extraction:\n" ++ show err-      exitFailure-    Right (hs, _) ->-      return hs--doTranslate :: [A.EDeclaration] -> IO H.Module-doTranslate decls = do-  k <- runTranslate $ translateModule decls-  case k of-    Left err -> do-      putStrLn $ "error during extraction:\n" ++ show err-      exitFailure-    Right hs ->-      return hs--doTypeCheck :: [A.Declaration] -> IO ([A.EDeclaration], Signature)-doTypeCheck decls = do-  k <- typeCheck decls-  case k of-    Left err -> do-      putStrLn $ "error during typechecking:\n" ++ show err-      exitFailure-    Right (edecls, st) ->-      return (edecls, signature st)--doScopeCheck :: [C.Declaration] -> IO [A.Declaration]-doScopeCheck decl = case scopeCheck decl of-     Left err -> do putStrLn $ "scope check error: " ++ show err-                    exitFailure-     Right (decl',_) -> return $ decl'
Makefile view
@@ -1,111 +1,4 @@-# Makefile for miniagda--files=Abstract Collection Concrete Eval Extract HsSyntax Lexer Main Parser Polarity PrettyTCM ScopeChecker Semiring SparseMatrix TCM Termination ToHaskell Tokens TraceError TreeShapedOrder TypeChecker Util Value Warshall-hsfiles=$(foreach file,$(files),$(file).hs)-ghcflags=-ignore-package monads-fd -rtsopts-# -fglasgow-exts-optflags=-# -O  #slow compilation, not much speedup-profflags=-prof -auto-all-distfiles=*.hs *.hs-boot Lexer.x Parser.y Makefile-distdirs=test/succeed test/fail examples--cabalp=cabal install -p --enable-executable-profiling--.PHONY : test succeed fail examples lib current default all clean veryclean--default : Main test-all : Main test examples lib--prof-current : miniagda-prof-	miniagda-prof examples/FiCS12/fics12-06.ma +RTS -prof -s-#	miniagda-prof test/succeed/Zero.ma +RTS -prof -s-#	miniagda-prof privateExamples/NisseContNorm/negative-2010-11-23.ma +RTS -prof-current : Main-#	Main test/fail/BoundedFake.ma-	Main examples/Existential/StreamProcCase.ma-#	Main test/features/Existential/list.ma-#	Main test/features/Existential/nat.ma-#	Main examples/RBTree/RBTreeConor.ma-#	Main test/fail/InvalidField.ma-#	Main test/succeed/BuiltinSigma.ma-#	Main test/features/records.ma-#	Main test/succeed/MeasuredHerSubst2.ma-#	Main examples/Coinductive/SubjectReductionProblem.ma-#	Main examples/Sized/Maximum.ma-#	Main examples/Irrelevance/Vector.ma-#	Main examples/JeffTerellCoqClub20100120.ma-#	Main examples/HugoCantor/tryLoopInjData.ma-#	Main examples/HugoCantor/InjDataLoop.ma-#	Main test/features/countConstructors.ma-#	Main examples/HugoCantor/injectiveData.ma-#	Main examples/BoveCapretta/Eval.ma # vec.ma # examples/List.ma-#	Main test/fail/OverlappingPatternIndFam.ma # vec.ma # examples/List.ma--# ship : ../dist/miniagda-2009-07-03.tgz # 06-27.tgz-#-# ../dist/%.tgz : $(distfiles)-# 	tar czf $@ $^ $(distdirs)-#--miniagda-prof : Main.hs $(hsfiles)-	ghc $(ghcflags) $(profflags) $< --make -o $@--Main : Main.hs $(hsfiles)-	ghc $(ghcflags) $(optflags) $< --make -o $@--install-prof-libs :-	$(cabalp) transformers-	$(cabalp) mtl-	$(cabalp) syb-	$(cabalp) parsec-	$(cabalp) preprocessor-tools-	$(cabalp) cpphs-	$(cabalp) haskell-src-exts-	$(cabalp) IfElse-	$(cabalp) utility-ht--SCT : SCT.hs Lexer.hs SCTParser.hs SCTSyntax.hs-	ghc $(ghcflags) $< --make -o $@--Lexer.hs : Lexer.x-	alex $<--%arser.hs : %arser.y Lexer.hs-	happy --info=$<-grm.txt $<--test : Main succeed fail--succeed :-	@echo "======================================================================"-	@echo "===================== Suite of successfull tests ====================="-	@echo "======================================================================"-	make -C test/succeed--fail :-	@echo "======================================================================"-	@echo "======================= Suite of failing tests ======================="-	@echo "======================================================================"-	make -C test/fail--examples : Main-	@echo "======================================================================"-	@echo "========================== Suite of examples ========================="-	@echo "======================================================================"-	make -C examples--lib : Main-	@echo "======================================================================"-	@echo "=============================== Library =============================="-	@echo "======================================================================"-	make -C lib---clean :-	-rm *.o *.hi Main miniagda-prof-# 	make -C test/fail clean--veryclean : clean-	make -C test/fail clean+install :+	cabal install  # EOF
MiniAgda.cabal view
@@ -1,13 +1,13 @@ name:            MiniAgda-version:         0.2014.9.12+version:         0.2016.12.19 build-type:      Simple-cabal-version:   >= 1.8+cabal-version:   >= 1.22 license:         OtherLicense license-file:    LICENSE author:          Andreas Abel and Karl Mehltretter maintainer:      Andreas Abel <andreas.abel@ifi.lmu.de> homepage:        http://www.tcs.ifi.lmu.de/~abel/miniagda/-bug-reports:     http://hub.darcs.net/abel/miniagda/issues+bug-reports:     https://github.com/andreasabel/miniagda/issues category:        Dependent types synopsis:        A toy dependently typed programming language with type-based termination. description:@@ -22,7 +22,10 @@   Recent features include bounded size quantification and destructor   patterns for a more general handling of coinduction. -tested-with:        GHC == 7.8.3+tested-with:        GHC == 7.6.3+                    GHC == 7.8.4+                    GHC == 7.10.3+                    GHC == 8.0.1  extra-source-files: Makefile @@ -35,20 +38,21 @@                     test/fail/adm/*.err                     lib/*.ma source-repository head-  type:     darcs-  location: http://hub.darcs.net/abel/miniagda+  type:     git+  location: https://github.com/andreasabel/miniagda  executable miniagda-  hs-source-dirs:   .+  hs-source-dirs:   src   build-depends:    array >= 0.3 && < 0.6,-                    base >= 4.2 && < 4.8,+                    base >= 4.6 && < 5,                     containers >= 0.3 && < 0.6,-                    haskell-src-exts >= 1.14 && < 1.16,+                    haskell-src-exts >= 1.17 && < 1.18,                     mtl >= 2.2.0.1 && < 2.3,                     pretty >= 1.0 && < 1.2   build-tools:      happy >= 1.15 && < 2,                     alex >= 3.0 && < 4-  extensions:       CPP+  default-language: Haskell98+  default-extensions: CPP                     MultiParamTypeClasses                     TypeSynonymInstances                     FlexibleInstances
− Parser.y 
@@ -1,520 +0,0 @@-{-{-# LANGUAGE BangPatterns #-}-module Parser where--import qualified Lexer as T-import qualified Concrete as C--import Abstract (Decoration(..),Dec,defaultDec,Override(..))-import Polarity (Pol(..))-import qualified Abstract as A-import qualified Polarity as A-import Concrete (Name,patApp)-}--%name parse-%tokentype { T.Token }-%error { parseError }--%token--id      { T.Id $$ _ }-qualid  { T.QualId $$ _ }-number  { T.Number $$ _ }-data    { T.Data _ }-codata  { T.CoData _ }-record  { T.Record _ }-sized   { T.Sized _ }-fields  { T.Fields _ }-mutual  { T.Mutual _ }-fun     { T.Fun _ }-cofun   { T.CoFun _ }-pattern { T.Pattern _ }-case    { T.Case _ }-def     { T.Def _ }-let     { T.Let _ }-in      { T.In _ }-eval    { T.Eval _ }-fail    { T.Fail _ }-check   { T.Check _ }-trustme { T.TrustMe _ }-impredicative { T.Impredicative _ }-type    { T.Type _ }-set     { T.Set _ }-coset   { T.CoSet _ }-size    { T.Size _ }-infty   { T.Infty _ }-succ    { T.Succ _ }-max     { T.Max _ }-'<|'    { T.LTri _ }-'|>'    { T.RTri _ }-'<'     { T.AngleOpen _ }-'>'     { T.AngleClose _ }-'{'     { T.BrOpen _ }-'}'     { T.BrClose _ }-'['     { T.BracketOpen _ }-']'     { T.BracketClose _ }-'('     { T.PrOpen _ }-')'     { T.PrClose _ }-'|'     { T.Bar _ }-','     { T.Comma _ }-';'     { T.Sem _ }-':'     { T.Col _ }-'.'     { T.Dot _ }-'->'    { T.Arrow _ }-'<='    { T.Leq _ }-'='     { T.Eq _ }-'++'    { T.PlusPlus _ }-'+'     { T.Plus _ }-'-'     { T.Minus _ }-'/'     { T.Slash _ } -- UNUSED-'*'     { T.Times _ } -- UNUSED-'^'     { T.Hat _ }-'&'     { T.Amp _ }-'\\'    { T.Lam _ }-'_'     { T.Underscore _ }--%%--TopLevel :: { [C.Declaration] }-TopLevel : Declarations { reverse $1}---Declarations :: { [C.Declaration] }-Declarations : {- empty -} { [] }-             | Declarations Declaration { $2 : $1 }--Declaration :: { C.Declaration }-Declaration : Data                      { $1 }-           | CoData                     { $1 }-           | SizedData                  { $1 }-           | SizedCoData                { $1 }-           | RecordDecl                 { $1 }-           | Fun                        { $1 }-           | CoFun                      { $1 }-           | Mutual                     { $1 }-           | Let                        { $1 }-           | PatternDecl                { $1 }-           | impredicative Declaration          { C.OverrideDecl Impredicative [$2] }-           | impredicative '{' Declarations '}' { C.OverrideDecl Impredicative $3 }-           | fail Declaration             { C.OverrideDecl Fail [$2] }-           | fail '{' Declarations '}'    { C.OverrideDecl Fail $3 }-           | check Declaration            { C.OverrideDecl Check [$2] }-           | check '{' Declarations '}'   { C.OverrideDecl Check $3 }-           | trustme Declaration          { C.OverrideDecl TrustMe [$2] }-           | trustme '{' Declarations '}' { C.OverrideDecl TrustMe $3 }-{--Data :: { C.Declaration }-Data : data Id DataTelescope ':' Expr '{' Constructors '}' OptFields-   { C.DataDecl $2 A.NotSized A.Ind $3 $5 (reverse $7) $9 }--SizedData :: { C.Declaration }-SizedData : sized data Id DataTelescope ':' Expr '{' Constructors '}' OptFields-   { C.DataDecl $3 A.Sized A.Ind $4 $6 (reverse $8) $10 }--CoData :: { C.Declaration }-CoData : codata Id DataTelescope ':' Expr '{' Constructors '}' OptFields-       { C.DataDecl $2 A.NotSized A.CoInd $3 $5 (reverse $7) $9 }--SizedCoData :: { C.Declaration }-SizedCoData : sized codata Id DataTelescope ':' Expr '{' Constructors '}' OptFields-       { C.DataDecl $3 A.Sized A.CoInd $4 $6 (reverse $8) $10 }--RecordDecl :: { C.Declaration }-RecordDecl : record Id DataTelescope ':' Expr '{' Constructor '}'  OptFields-   { C.RecordDecl $2 $3 $5 $7 $9 }--}--Data :: { C.Declaration }-Data : data DataDef-  { let (n,tel,t,cs,fs) = $2 in C.DataDecl n A.NotSized A.Ind tel t cs fs }--SizedData :: { C.Declaration }-SizedData : sized data DataDef-  { let (n,tel,t,cs,fs) = $3 in C.DataDecl n A.Sized A.Ind tel t cs fs }--CoData :: { C.Declaration }-CoData : codata DataDef-  { let (n,tel,t,cs,fs) = $2 in C.DataDecl n A.NotSized A.CoInd tel t cs fs }--SizedCoData :: { C.Declaration }-SizedCoData : sized codata DataDef-  { let (n,tel,t,cs,fs) = $3 in C.DataDecl n A.Sized A.CoInd tel t cs fs }--RecordDecl :: { C.Declaration }-RecordDecl : record DataDef1-  { let (n,tel,t,c,fs) = $2 in C.RecordDecl n tel t c fs }--DataDef :: { (C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name]) }-DataDef : Id DataTelescope ':' Expr '{' Constructors '}' OptFields-            { ($1, $2, $4, reverse $6, $8)}-        | Id DataTelescope '{' Constructors '}' OptFields-            { ($1, $2, C.set0, reverse $4, $6)}--DataDef1 :: { (C.Name, C.Telescope, C.Type, C.Constructor, [C.Name]) }-DataDef1 : Id DataTelescope ':' Expr '{' Constructor '}' OptFields-            { ($1, $2, $4, $6, $8)}-         | Id DataTelescope '{' Constructor '}' OptFields-            { ($1, $2, C.set0, $4, $6)}--Fun :: { C.Declaration }-Fun : fun TypeSig '{' Clauses '}' { C.FunDecl A.Ind $2 $4 }--CoFun :: { C.Declaration }-CoFun : cofun TypeSig '{' Clauses '}' { C.FunDecl A.CoInd $2 $4  }--Mutual :: { C.Declaration }-Mutual : mutual '{' Declarations '}' { C.MutualDecl (reverse $3) }--Let :: { C.Declaration }-Let : Eval let LetDef { C.LetDecl $1 $3 }--{--Let : Eval let Id Telescope TypeOpt '=' ExprT { C.LetDecl $1 $3 $4 $5 $7 }--- Let : Eval let Id Telescope ':' Expr '=' ExprT { C.LetDecl $1 $3 $4 $6 $8 }--}--LetDef :: { C.LetDef }-LetDef : PolId Telescope TypeOpt '=' ExprT { let (dec,n) = $1 in C.LetDef dec n $2 $3 $5 }--Eval :: { Bool }-Eval : {- nothing -}  { False }-     | eval           { True  }--TypeOpt :: { Maybe C.Type }-TypeOpt : {- nothing -} { Nothing }-        | ':' Expr      { Just $2 }--{--Let :: { C.Declaration }-Let : let TypeSig '=' ExprT { C.LetDecl False $2 $4 }-      | eval let TypeSig '=' ExprT { C.LetDecl True $3 $5 }--}--PatternDecl :: { C.Declaration }-PatternDecl : pattern SpcIds '=' PairP { C.PatternDecl (head $2) (tail $2) $4 }---OptFields :: { [Name] }-OptFields : {- empty -}  { [] }-          | fields Ids   { $2 }--------Id :: { Name }-Id : id { C.Name $1 }--- no longer  number { $1 }--SpcIds :: { [Name] } -- non-empty list-SpcIds : Id     { [$1] }-       | Id SpcIds { $1 : $2 }--Ids :: { [Name] } -- non-empty list-Ids : Id              { [$1] }-    | Id ',' Ids { $1 : $3 }--Pol :: { Pol }-Pol : '++'         { SPos  }-    | '+'          { Pos   }-    | '-'          { Neg   }-    | '.'          { Const } -- use bracket [..]-    | '^'          { Param }-    | '*'          { Rec   } -- recursive---    | {- empty -}  { Mixed }--Measure :: { A.Measure C.Expr }-Measure : '|' Meas { A.Measure $2 }--Meas :: { [C.Expr] }-Meas : Expr '|'      { [$1] }-     | Expr ',' Meas { $1 : $3 }--Bound :: { A.Bound C.Expr }-Bound : Measure '<' Measure { A.Bound A.Lt $1 $3 }-      | Measure '<=' Measure { A.Bound A.Le $1 $3 } {- (A.succMeasure C.Succ $3) } -}--EIds :: { [Name] } -- non-empty list-EIds : ExprList       { let { f (C.Ident (C.QName x)) = x-                            ; f e = error ("not an identifier: " ++ C.prettyExpr e)-                            } in map f $1-                      }--Telescope :: { C.Telescope }-Telescope :  {- empty -}          { [] }-              | TBind Telescope { $1 : $2 }-              | Measure Telescope { C.TMeasure $1 : $2 }---- Binding.-TBind :: { C.TBind }-TBind-  :     '(' EIds ':' Expr ')' { C.TBind   (Dec Default) $2      $4 }-  |     '(' Id  '<'  Expr ')' { C.TBounded A.defaultDec $2 A.Lt $4 }-  |     '(' Id  '<=' Expr ')' { C.TBounded A.defaultDec $2 A.Le $4 }-  | Pol '(' EIds ':' Expr ')' { C.TBind    (Dec $1)     $3      $5 }-  | Pol '(' Id  '<'  Expr ')' { C.TBounded (Dec $1)     $3 A.Lt $5 }-  | Pol '(' Id '<='  Expr ')' { C.TBounded (Dec $1)     $3 A.Le $5 }-  | EBind                     { $1 }-  | HBind                     { $1 }---- Erased binding-EBind :: { C.TBind }-EBind-  : '[' Ids ':' Expr ']' { C.TBind    A.irrelevantDec $2      $4 }-  | '[' Id '<'  Expr ']' { C.TBounded A.irrelevantDec $2 A.Lt $4 }-  | '[' Id '<=' Expr ']' { C.TBounded A.irrelevantDec $2 A.Le $4 }---- Hidden binding-HBind :: { C.TBind }-HBind-  : '{' Ids ':' Expr '}' { C.TBind    A.Hidden $2      $4 }-  | '{' Id '<'  Expr '}' { C.TBounded A.Hidden $2 A.Lt $4 }-  | '{' Id '<=' Expr '}' { C.TBounded A.Hidden $2 A.Le $4 }---UntypedBind :: { C.LBind }-UntypedBind : Id              { C.TBind A.defaultDec [$1] Nothing }-            | '[' Id ']'      { C.TBind A.irrelevantDec [$2] Nothing }-            | Pol Id          { C.TBind (Dec $1) [$2] Nothing }-            | Pol '(' Id ')'  { C.TBind (Dec $1) [$3] Nothing }--PolId :: { (Dec, C.Name) }-PolId : Id              {  (A.defaultDec   , $1) }-      | '[' Id ']'      {  (A.irrelevantDec, $2) }-      | Pol Id          {  (Dec $1         , $2) }--LLetDef :: { C.LetDef }-LLetDef : LetDef        { $1 }--- legacy forms-        |  '[' Id ':' Expr ']' '=' Expr     { C.LetDef A.irrelevantDec $2 [] (Just $4) $7 }  -- erased binding-        |  Pol '(' Id ':' Expr ')' '=' Expr { C.LetDef (Dec $1) $3 [] (Just $5) $8 } -- ordinary binding---- let binding-LBind :: { C.LBind }-LBind :  UntypedBind         { $1 }-      |  Id ':' Expr         { C.TBind A.defaultDec [$1] (Just $3) } -- ordinary binding-      |  '(' Id ':' Expr ')' { C.TBind A.defaultDec [$2] (Just $4) } -- ordinary binding-      |  '[' Id ':' Expr ']' { C.TBind A.irrelevantDec [$2] (Just $4) }  -- erased binding-      |  Pol '(' Id ':' Expr ')' { C.TBind (Dec $1) [$3] (Just $5) } -- ordinary binding---      |  Pol '[' Id ':' Expr ']' { C.TBind (Dec True $1) [$3] $5 }  -- erased binding--Domain :: { C.Telescope }-Domain : Expr0             { [C.TBind (Dec Default) {- A.defaultDec -} [] $1] }-       | '[' Expr ']'      { [C.TBind A.irrelevantDec [] $2] }-       | Pol Expr0         { [C.TBind (Dec $1) [] $2] }---       | Pol '[' Expr ']'  { [C.TBind (Dec True  $1) [] $3] }-       | TBind             { [$1] }-       | Measure           { [C.TMeasure $1] }-       | Bound             { [C.TBound $1] }-       | Telescope         { $1 }----- expressions which can be tuples e , e'-ExprT :: { C.Expr}-ExprT : ExprList           { foldr1 C.Pair $1 }--ExprList :: { [C.Expr] }-ExprList : Expr               { [$1] }-         | Expr ',' ExprList     { $1 : $3 }----- general form of expression-Expr :: { C.Expr }-Expr : Domain '->' Expr                 { C.Quant A.Pi $1 $3 }-     | '\\' SpcIds '->' ExprT           { foldr C.Lam $4 $2 }-     | let LLetDef in ExprT             { C.LLet $2 $4 }-     | case ExprT TypeOpt '{' Cases '}' { C.Case $2 $3 $5 }-     | Expr0                            { $1 }                -- Sigma type-     | Expr1 '+' Expr                   { C.Plus $1 $3 }-     | Expr1 '<|' Expr                  { C.App $1 [$3] }-     | Expr1 '|>' Expr                  { C.App $3 [$1] }---- Sigma types (A & B, (x : A) & B)-Expr0 :: { C.Expr }-Expr0 : Expr1                            { $1 }-      | SigDom '&' Expr0                 { C.Quant A.Sigma [$1] $3 }---- SigDom ~ Domain, but no Telescope and no Expr0-SigDom :: { C.TBind }-SigDom : Expr1             { C.TBind (Dec Default) {- A.defaultDec -} [] $1 }-       | '[' Expr ']'      { C.TBind A.irrelevantDec [] $2 }-       | Pol Expr1         { C.TBind (Dec $1) [] $2 }---       | Pol '[' Expr ']'  { C.TBind (Dec True  $1) [] $3 }-       | TBind             { $1 }-       | Measure           { C.TMeasure $1 }-       | Bound             { C.TBound $1   }  -- constraint---- perform applications-Expr1 :: { C.Expr }-Expr1 : Expr2 { let (f : args) = reverse $1 in-                if null args then f else C.App f args-	      }-       | coset Expr3      { C.CoSet $2 }-       | set              { C.Set C.Zero }-       | set Expr3        { C.Set $2 }-       | number '*' Expr1 { let n = read $1 in-                            if n==0 then C.Zero else-                            iterate (C.Plus $3) $3 !! (n-1) }---       | EBind Expr1      { C.EBind $1 $2 }---- gather applications-Expr2 :: { [C.Expr] }-Expr2 : Expr3 { [$1] }-       | Expr2 Expr3 { $2 : $1 }-       | Expr2 '.' Id { C.Proj $3 : $1 }-       | Expr2 set   { C.Set C.Zero : $1 }---       | succ SE { [C.Succ $2] }---- atoms-Expr3 :: { C.Expr }-Expr3 : size                      { C.Size }-      | max                       { C.Max }-      | infty                     { C.Infty }-      | QName                     { C.Ident $1}-      | '<' ExprT ':' Expr '>'    { C.Sing $2 $4 }-      | '(' ExprT ')'             { $2 }-      | '_'                       { C.Unknown }-      | succ Expr3                { C.Succ $2 }  -- succ is a prefix op-      | number                    { iterate C.Succ C.Zero !! (read $1) }-      | record '{' RecordDefs '}' { C.Record $3 }--QName :: { C.QName }-QName : qualid { let (m,n) = $1 in C.Qual (C.Name m) (C.Name n) }-      | Id     { C.QName $1}--{---- general form of type expression-Type :: { C.Expr }-Type : Domain '->' Type                 { C.Quant A.Pi $1 $3 }-     | let LBind '=' ExprT in Type      { C.LLet $2 $4 $6 }-     | case ExprT '{' Cases '}'         { C.Case $2 $4 }-     | Type1                            { $1 }---- perform applications-Type1 :: { C.Expr }-Type1 : Type2 { let (f : args) = reverse $1 in-                if null args then f else C.App f args-	      }-       | coset Expr3                      { C.CoSet $2 }-       | set                              { C.Set C.Zero }-       | set Expr3                        { C.Set $2 }-       | Domain '&' Type1                 { C.Quant A.Sigma $1 $3 }---- gather applications-Type2 :: { [C.Expr] }-Type2 : Type3 { [$1] }-      | Type2 Expr3 { $2 : $1 }-      | Type2 '.' Id { C.Proj $3 : $1 }-      | Type2 set   { C.Set C.Zero : $1 }---- type atoms-Type3 :: { C.Expr }-Type3 : size                      { C.Size }-      | Id                        { C.Ident $1}-      | '(' Type ')'              { $2 }-      | '_'                       { C.Unknown }--}--RecordDefs :: { [([Name],C.Expr)] }-RecordDefs-  : RecordDef ';' RecordDefs   { $1 : $3 }-  | RecordDef                  { [$1] }-  | {- empty -}                { [] }--RecordDef :: { ([Name],C.Expr) }-RecordDef : SpcIds '=' ExprT    { ($1,$3) }--TypeSig :: { C.TypeSig }-TypeSig : Id ':' Expr { C.TypeSig $1 $3 }--Constructor :: { C.Constructor }-Constructor : Id Telescope ':' Expr { C.Constructor $1 $2 (Just $4) }-            | Id Telescope          { C.Constructor $1 $2 Nothing }--Constructors :: { [C.Constructor ] }-Constructors :-      Constructors ';' Constructor { $3 : $1 }-    | Constructors ';' { $1 }-    | Constructor { [$1] }-    | {- empty -} { [] }--Cases :: { [C.Clause] }-Cases : Pattern '->' ExprT ';' Cases  { (C.Clause Nothing [$1] (Just $3)) : $5 }-      | Pattern '->' ExprT            { (C.Clause Nothing [$1] (Just $3)) : [] }-      | Pattern ';' Cases             { (C.Clause Nothing [$1] Nothing) : $3 }-      | Pattern                       { (C.Clause Nothing [$1] Nothing) : [] }-      | {- empty -}                   { [] }--Clause :: { C.Clause }-Clause : Id LHS '=' ExprT { C.Clause (Just $1) $2 (Just $4) }-       | Id LHS           { C.Clause (Just $1) $2 Nothing }--LHS :: { [C.Pattern] }-LHS : Patterns { reverse $1 }--Patterns :: { [C.Pattern] }-Patterns : {- empty -} { [] }---    | Pattern Patterns { $1 : $2 }-    | Patterns Pattern { $2 : $1 }-    | Patterns '<|' ElemP { $3 : $1 }---- atomic patterns-Pattern :: { C.Pattern }-Pattern : '(' ')'            { C.AbsurdP     }-        | '(' PairP ')'      { $2            }-        | DotId              { $1            }-        | succ Pattern       { C.SuccP $2    }-        | '.' set            { C.DotP (C.Set C.Zero) }-        | '.' Expr3          { C.DotP $2     }---- pattern tuples-PairP :: { C.Pattern }-PairP : ElemP ',' PairP     { C.PairP $1 $3 }-      | ElemP               { $1 }--ElemP :: { C.Pattern }-ElemP : ConP                { $1 }-      | Expr3 '>' Id        { C.SizeP $1 $3 }-      | Id '<' Expr3        { C.SizeP $3 $1 }-      | Pattern             { $1 }-      | ConP '<|' ElemP     { patApp $1 [$3] } -- '<|' is Haskell's '$' (appl.)---- constructor with at least one argument pattern-ConP :: { C.Pattern }-ConP : DotId Pattern       { patApp $1 [$2] }-     | ConP Pattern        { patApp $1 [$2] }--DotId :: { C.Pattern }-DotId : Id                 { C.IdentP (C.QName $1) }-      | '.' Id             { C.ConP True (C.QName $2) [] }---Clauses :: { [C.Clause] }-Clauses : RClauses { reverse $1 }--RClauses :: { [C.Clause ] }-RClauses- : RClauses ';' Clause { $3 : $1 }- | RClauses ';'        { $1      }- | Clause              { [$1]    }- | {- empty -}         { []      }---- Binding in data telescope, supports (+ X : Set) for backwards compatibility-TBindSP :: { C.TBind }-TBindSP-  :     '(' Ids ':' Expr ')' { C.TBind (Dec Default) $2 $4 } -- ordinary binding-  |     '[' Ids ':' Expr ']' { C.TBind A.irrelevantDec $2 $4 }  -- erased bind.-  | Pol '(' Ids ':' Expr ')' { C.TBind (Dec $1) $3 $5 }-  | '(' '+' Ids ':' Expr ')' { C.TBind (Dec SPos) $3 $5 }----  | '(' sized Id ')'     { C.TSized $3 }--DataTelescope :: { C.Telescope }-DataTelescope :  {- empty -}          { [] }-              | TBindSP DataTelescope { $1 : $2 }--{--parseError :: [T.Token] -> a-parseError [] = error "Parse error at EOF"-parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x)--}
− Polarity.hs 
@@ -1,421 +0,0 @@-{- In the context of polarities, we use "recursive" in the sense of-"computable" rather than syntactic recursion. -}--module Polarity where--import Util-import Warshall--import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.List as List--{- 2010-10-09 Fusing polarity and irrelevance--     .      constant (= irrelevant) function-    / \-  ++   |    strictly positive function (types only)-   |   |-   +   -    positive/negative function (types only)-    \ /-     ^      parametric function (lambda cube), default for types-     |-     *      recursive function (pattern matching), default for terms--- Composition (AC)--  . p = .-  * p = *  (p not .)-  ^ p = ^  (p not .,*)- ++ p = p-  + p = p  (p not ++)-  - - = +--Equality/subtyping <=p--  x <=. y  iff  true-  x <=- y  iff  x >= y-  x <=^ y  iff  x == y-  x <=* y  iff  x == y- -}---- polarities and strict positivity ------------------------------------class Polarity pol where-  erased    :: pol -> Bool-  compose   :: pol -> pol -> pol-  neutral   :: pol                 -- ^ neutral for compose.-  promote   :: pol -> pol-  demote    :: pol -> pol-  hidden    :: pol                 -- ^ corresponding to hidden quantification--type PVarId = Int--data Pol-  = Const -- non-occurring, irrelevant-  | SPos  -- strictly positive-  | Pos   -- positive-  | Neg   -- negative, used internally for contravariance of sized codata-  | Param -- parametric (lambda) function-  | Rec   -- recursive (takes decision)-  | Default     -- no polarity given (for parsing)-  | PVar PVarId -- flexible polarity variable-         deriving (Eq,Ord)--mixed = Rec-defaultPol = Rec-{--mixed = Param -- TODO: Rec-defaultPol = Param -- TODO: Rec--}-instance Polarity Pol where-  erased  = (==) Const-  compose = polComp-  neutral = SPos-  promote = invComp Const-  demote  = invComp Rec-  hidden  = Const--instance Show Pol where-  show Const = "."-  show SPos  = "++"-  show Pos   = "+"-  show Neg   = "-"-  show Param = "^"-  show Rec   = "*"-  show Default = "{default polarity}"-  show (PVar i) = showPVar i--showPVar i = "?p" ++ show i--isPVar (PVar{}) = True-isPVar _ = False---- information ordering-leqPol :: Pol -> Pol -> Bool-leqPol x Const  = True   -- Const is top-leqPol Const x  = False-leqPol Rec y    = True   -- Rec is bottom-leqPol x Rec    = False-leqPol Param y  = True   -- Param is second bottom-leqPol x Param  = False-leqPol Pos SPos = True-leqPol x   y    = x == y--{- RETIRED-isSPos :: Pol -> Bool-isSPos SPos = True-isSPos Const = True-isSPos _ = False--}--{- NOT USED-isPos :: Pol -> Bool-isPos Pos = True-isPos x = isSPos x--}---- polarity negation--- used in Eval.hs leqVals' for switching sides--- this means it is only applied to Pos, Neg, Param,--- never to SPos, Const, or polarity expressions-polNeg :: Pol -> Pol-polNeg Const  = Const-polNeg SPos  = Neg-polNeg Pos   = Neg-polNeg Neg   = Pos-polNeg Param = Param-polNeg Rec   = Rec---- polarity composition--- used in Eval.hs leqVals'-polComp :: Pol -> Pol -> Pol-polComp Const  x  = Const   -- most dominant-polComp x Const   = Const-polComp Rec x     = Rec  -- dominant except for Const-polComp x Rec     = Rec-polComp Param x   = Param  -- dominant except for Const, Rec-polComp x Param   = Param-polComp SPos  x   = x      -- neutral-polComp x SPos    = x-polComp Pos  x    = x      -- neutral except for SPos-polComp x Pos     = x-polComp Neg Neg   = Pos    -- order 2-{- pol.comp. is ass., comm., with neutral ++, and infinity Const-   cancellation does not hold, since composition with anything by ++ is-   information loss:-     q p <= q p' ==> p <= p'-   only if q = ++ (then it is trivial anyway) -}---- polarity inverse composition (see Abel, MSCS 2008)--- invComp p q1 <= q2  <==> q1 <= polComp p q2--- used in TCM.hs cxtApplyDec-invComp :: Pol -> Pol -> Pol-invComp Rec   Rec   = Rec       -- in rec. arg. keep only rec. vars-invComp Rec   x     = Const     -- all others are declared unusable-invComp Param Param = Param     -- in parametric mixed arg, keep only mixed vars-invComp Param x     = Const-invComp Const x     = Param     -- a constant function can take any argument-invComp SPos  x     = x         -- SPos is the identity-invComp p     SPos  = Const     -- SPos preserved only under SPos-invComp Pos   x     = x         -- x not SPos-invComp Neg   x     = polNeg x  -- x not SPos--{- UNUSED-invCompExpr :: Pol -> PExpr -> PExpr-invCompExpr q (PValue p)   = PValue $ invComp q p-invCompExpr q (PExpr q' i) = PExpr (polComp q q') i--}---- polarity conjuction (infimum)--- used in comparing spines-polAnd :: Pol -> Pol -> Pol-polAnd Const x = x      -- most information-polAnd x Const = x-polAnd Rec   x = Rec   -- least information-polAnd x   Rec = Rec-{--polAnd Param x  = Param   -- 2nd least information-polAnd x Param  = Param--}-polAnd x y | x == y = x       -- same information-polAnd SPos Pos = Pos     -- SPos is more informative than Pos-polAnd Pos SPos = Pos-{--polAnd SPos Neg = Param-polAnd Neg SPos = Param--}-polAnd _ _      = Param     -- remaining cases: conflicting info or Param--instance SemiRing Pol where-  oplus  = polAnd-  otimes = polComp-  ozero  = Const    -- dominant for composition, neutral for infimum-  oone   = SPos     -- neutral  for composition---- computing a relation from <=-relPol :: Pol -> (a -> a -> Bool) -> (a -> a -> Bool)-relPol Const r a b = True-relPol Rec   r a b = r a b && r b a-relPol Param r a b = r a b && r b a-relPol Neg   r a b = r b a-relPol Pos   r a b = r a b-relPol SPos  r a b = r a b--relPolM :: (Monad m) => Pol -> (a -> a -> m ()) -> (a -> a -> m ())-relPolM Const r a b = return ()-relPolM Rec   r a b = r a b >> r b a-relPolM Param r a b = r a b >> r b a-relPolM Neg   r a b = r b a-relPolM Pos   r a b = r a b-relPolM SPos  r a b = r a b---- polarity product (composition of polarities) ------------------------data Multiplicity = POne | PTwo deriving (Eq, Ord)--instance Show Multiplicity where-  show POne = "1"-  show PTwo = "2"---- addition modulo 2-addMultiplicity :: Multiplicity -> Multiplicity -> Multiplicity-addMultiplicity PTwo y = y-addMultiplicity x PTwo = x-addMultiplicity POne POne = PTwo--type VarMults = Map PVarId Multiplicity -- multiplicity of variables (1 or 2)--showMults :: VarMults -> String-showMults mults =-  let ml = Map.toList mults  -- get list of (key,value) pairs-      l  = concat $ map f ml where-             f (k, POne) = [k]-             f (k, PTwo) = [k,k]-  in Util.showList "." showPVar l--multsEmpty = Map.empty--multsSingle :: Int -> VarMults-multsSingle i = Map.insert i POne multsEmpty---data PProd = PProd-  { coeff    :: Pol      -- a coefficient, excluding PVar-  , varMults :: VarMults -- multiplicity of variables (1 or 2)-  } deriving (Eq,Ord)--instance Polarity PProd where-  erased  = erased . coeff-  compose = polProd-  neutral = PProd SPos multsEmpty-  demote  = undefined-  promote = undefined-  hidden  = PProd hidden multsEmpty--instance Show PProd where-  show (PProd Const _) = show Const-  show (PProd SPos m) = if Map.null m then show SPos else showMults m-  show (PProd q m) = separate "." (show q) (showMults m)--pprod :: Pol -> PProd-pprod (PVar i) = PProd SPos (multsSingle i)-pprod q = PProd q multsEmpty---- | fails if not a simple polarity-fromPProd :: PProd -> Maybe Pol-fromPProd (PProd Const _)          = Just Const-fromPProd (PProd p m) | Map.null m = Just p-fromPProd _                        = Nothing--isSPos :: PProd -> Bool-isSPos (PProd Const _) = True-isSPos (PProd SPos m) = Map.null m-isSPos _ = False---- multiply two products--polProd :: PProd -> PProd -> PProd-polProd (PProd q1 m1) (PProd q2 m2) = PProd (polComp q1 q2) $-  Map.unionWith addMultiplicity m1 m2---- polarity expressions are polynomials --------------------------------data PPoly = PPoly { monomials :: [PProd] } deriving (Eq,Ord)--instance Show PPoly where-  show (PPoly []) = show Const-  show (PPoly [m]) = show m-  show (PPoly l)   = Util.showList "/\\" show l--ppoly :: PProd -> PPoly-ppoly (PProd Const _) = PPoly []-ppoly pp = PPoly [pp]--polSum :: PPoly -> PPoly -> PPoly-polSum (PPoly x) (PPoly y) = PPoly $ List.nub $ x ++ y--polProduct :: PPoly -> PPoly -> PPoly-polProduct (PPoly l1) (PPoly l2) =-  let ps = [ polProd x y | x <- l1, y <- l2]-  in PPoly $ List.nub $ ps--instance SemiRing PPoly where-  oplus  = polSum-  otimes = polProduct-  ozero  = PPoly []-  oone   = PPoly [PProd SPos Map.empty]--{--data PExpr-  = PValue Pol     -- constant polarity-  | PExpr Pol Int  -- PExpr q pi means q^_1 pi  (pi is the number of the var)---- a polarity variable-pvar :: Int -> PExpr-pvar = PExpr SPos  -- ++ is the neutral element of inverse polarity composition--instance Show PExpr where-  show (PValue p) = show p-  show (PExpr SPos i) = "?p" ++ show i-  show (PExpr q i) = show q ++ "^-1(?p" ++ show i ++ ")"--}---{- ML-style Polarity inference--Preliminaries:-1. constructor types are mixed-variant function types only-2. matching is only allowed on mixed-variant arguments-  1+2 are both consequences that only type-valued functions have variance-  and 1. data constructors are not types, 2. types are not matched on--Concrete syntax--  f : (xs : As) -> C   (C not a Pi-type)-  f = t--is parsed as abstract syntax--  f : pis(xs : As) -> C-  f = t--where pi_1..n are fresh polarity variables--Then t is type-checked to infer the polarity variables, e.g.--  f xs = t--  pis(xs : As) |- t : C--Now what can happen?--Variable:  t = x_i.  Then we add a constraint  pi_i <= ++--Application t = u v  where u : q(x:B) -> D--  q^-1(pis(xs: As)) |- v : B--  A term q^-1 pi arises where q is a polarity constant (!, ML-inference)-  or a polarity variable (recursion!, e.g. u = f)-  and pi is a polarity expression--In the context, keep SOLL and HABEN--  SOLL  is the original polarity (variable or constant)-  HABEN is a (ordered) list of pol.vars. and a pol.const. (default: ++)--Variable   : add constraint SOLL <= HABEN-Application: add q to HABEN by polarity multiplication (q is a var or const)-Abstraction: \xt : q(x:A) -> B:  continue with x (SOLL = q, HABEN = ++)--What kind of constraints do arise-1) q  <= pi    [ from variables , pi is a Pol-product ]-2) ++ <= pis  [ from positivity graph, pis is a sum of Pol-products ]-   this means ++ <= pi for all pi in pis--Solving constraints--- discard  o <= pi  and q <= /  (do not even need to add them)-- all pvars which are not bounded below (appearing in one q in 1)-  can be instantiated to /  which will remove some constraints----}--{- Mutual recursion--In mutual declarations, use the following Ansatz:  data/codata ++, functions o--  A = B -> A-  B = A -> B--A (B) is positive in its own body and negative in the body of B (A)--  F A B = B -> A   F(-,++)-  G A B = A -> B   G(-,++)--  F A B = G A B -> F A B-  G A B = F A B -> G A B--  Polarities:-  F : fa * -> fb * -> *-  G : ga * -> gb * -> *--  A : -fa, B : -fb |- G A B : *  ==> -fa <= ga, -fb <= gb-  A : -ga, B : -gb |- F A B : *  ==> -ga <= fa, -gb <= fb---}--{- Pure polarity inference--Judgement:  pis(xs:As) |- t : B ---> C--Variable:   pis(xs:As) |- xi : Ai ---> pi_i <= ++--Application: Delta |- u : q(x:A) -> B ---> C1-             Delta |- v : A           ---> C2-             ---------------------------------------------------             Delta |- u v : B[u/x] ---> C1,C2,q(Delta) <= Delta--}
− PrettyTCM.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module PrettyTCM where--import Prelude hiding (sequence, mapM)--import Abstract-import {-# SOURCE #-} Eval-import {-# SOURCE #-} TCM-import qualified Util-import Value--import Control.Applicative hiding (empty)-import Control.Monad ((<=<))-import Data.Traversable--import qualified Text.PrettyPrint as P----- from Agda.TypeChecking.Pretty--type Doc = P.Doc--empty, comma, colon :: Monad m => m Doc--empty	   = return P.empty-comma	   = return P.comma-colon      = text ":"-pretty x   = return $ Util.pretty x--- prettyA x  = P.prettyA x-text s	   = return $ P.text s-pwords s   = map return $ Util.pwords s-fwords s   = return $ Util.fwords s-sep ds	   = P.sep <$> sequence ds-fsep ds    = P.fsep <$> sequence ds-hsep ds    = P.hsep <$> sequence ds-vcat ds    = P.vcat <$> sequence ds-d1 $$ d2   = (P.$$) <$> d1 <*> d2-d1 <> d2   = (P.<>) <$> d1 <*> d2-d1 <+> d2  = (P.<+>) <$> d1 <*> d2-nest n d   = P.nest n <$> d-braces d   = P.braces <$> d-brackets d = P.brackets <$> d-parens d   = P.parens <$> d--prettyList ds = brackets $ fsep $ punctuate comma ds--punctuate _ [] = []-punctuate d ds = zipWith (<>) ds (replicate n d ++ [empty])-    where-	n = length ds - 1---- monadic pretty printing--class ToExpr a where-  toExpression :: a -> TypeCheck Expr--instance ToExpr Expr where-  toExpression = return--instance ToExpr Val where-  toExpression = toExpr---class PrettyTCM a where-  prettyTCM :: a -> TypeCheck Doc--instance PrettyTCM Name where-  prettyTCM = pretty--instance PrettyTCM Pattern where-  prettyTCM = pretty--instance PrettyTCM [Pattern] where-  prettyTCM = sep . map pretty--instance PrettyTCM Expr where-  prettyTCM = pretty--instance PrettyTCM (Sort Expr) where-  prettyTCM = pretty--instance PrettyTCM Val where-  prettyTCM = pretty <=< toExpr--instance PrettyTCM [Val] where-  prettyTCM = sep . map (pretty <=< toExpr)--instance PrettyTCM (Sort Val) where-  prettyTCM = pretty <=< mapM toExpr--instance PrettyTCM a => PrettyTCM (OneOrTwo a) where-  prettyTCM (One a)     = prettyTCM a-  prettyTCM (Two a1 a2) = prettyTCM a1 <+> text "||" <+> prettyTCM a2--instance (ToExpr a) => PrettyTCM (Measure a) where-  prettyTCM mu = pretty =<< mapM toExpression mu--instance (ToExpr a) => PrettyTCM (Bound a) where-  prettyTCM beta = pretty =<< mapM toExpression beta--instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where-  prettyTCM (a,b) = parens $ prettyTCM a <> comma <+> prettyTCM b
− ScopeChecker.hs 
@@ -1,1124 +0,0 @@--- NOTE: insertion of polarity variables disabled here, must be done--- in TypeChecker--{-# LANGUAGE TupleSections, DeriveFunctor, GeneralizedNewtypeDeriving,-      FlexibleContexts, FlexibleInstances, UndecidableInstances,-      MultiParamTypeClasses #-}--module ScopeChecker (scopeCheck) where--import Prelude hiding (mapM, null)--import Control.Applicative-import Control.Monad.Identity hiding (mapM)-import Control.Monad.Reader hiding (mapM)-import Control.Monad.State hiding (mapM)-import Control.Monad.Except hiding (mapM)--import Data.List as List hiding (null)-import Data.Maybe-import Data.Traversable (mapM)--import Debug.Trace--import Polarity(Pol(..))-import qualified Polarity as A-import Abstract (Sized,mkExtRef,Co,ConK(..),PrePost(..),MVar,Decoration(..),Override(..),Measure(..),adjustTopDecsM,Arity,polarity,LensPol(..))-import qualified Abstract as A-import qualified Concrete as C--import TraceError--import Util---- * scope checker--- check that all identifiers are in scope and global identifiers are only used once--- replaces Ident with Con, Def, Let or Var--- replaces IdentP with ConP or VarP in patterns--- replaces Unknown by a new Meta-Variable--- check pattern length is equal in each clause--- group mutual declarations---- | Entry point for scope checker.-scopeCheck :: [C.Declaration] -> Either TraceError ([A.Declaration],SCState)-scopeCheck dl = runScopeCheck initCtx initSt (scopeCheckDecls dl)---- * Local identifiers.---- ** local environment of scope checker--data SCCxt = SCCxt-  { stack             :: Stack     -- ^ Local names in scope.-    -- We keep a stack of these to disallow shadowing on the same level.-  , defaultPolarity   :: Pol       -- ^ Replacement for @Default@ polarity.-  , constraintAllowed :: Bool      -- ^ Is a constraint @|m| < |m'|@ legal now, since we just parsed a quantifier?-  }--type Stack = [Context]--initCtx :: SCCxt-initCtx = SCCxt-  { stack             = [[]]  -- one empty context to begin with-  , defaultPolarity   = A.Rec -- POL VARS DISABLED!!-  , constraintAllowed = False-  }---- ** A lens for @constraintAllowed@--class LensConstraintAllowed a where-  mapConstraintAllowed :: (Bool -> Bool) -> a -> a-  setConstraintAllowed :: Bool -> a -> a-  setConstraintAllowed b = mapConstraintAllowed (const b)--instance LensConstraintAllowed SCCxt where-  mapConstraintAllowed f sc = sc { constraintAllowed = f (constraintAllowed sc) }--instance (LensConstraintAllowed r, MonadReader r m) => LensConstraintAllowed (m a) where-  mapConstraintAllowed f = local (mapConstraintAllowed f)---- ** Managing the stack of local contexts.--newLevel :: ScopeCheck a -> ScopeCheck a-newLevel = local $ \ cxt -> cxt { stack = [] : stack cxt }--thisLevel :: SCCxt -> Context-thisLevel cxt = head (stack cxt)--instance Push Local SCCxt where-  push nx sc = sc { stack = push nx (stack sc) }---- ** translating concrete names to abstract names--type Local   = (C.Name,A.Name)-type Context = [Local]--emptyCtx :: Context-emptyCtx = []--newLocal :: Push Local b => C.Name -> b -> (A.Name, b)-newLocal n cxt = (x, push (n, x) cxt)-  where x = A.fresh $ C.theName n--lookupLocal :: C.Name -> ScopeCheck (Maybe A.Name)-lookupLocal n = retrieve n <$> asks stack--lookupGlobal :: C.QName -> ScopeCheck (Maybe DefI)-lookupGlobal n = lookupSig n <$> getSig--addContext :: Context -> SCCxt -> SCCxt-addContext delta sc = sc { stack = delta : stack sc }---- * Global identifiers.---- | Kind of identifier.-data IKind-  = DataK-  | ConK ConK-  | FunK Bool  -- ^ @False@ = inside body, @True@ = outside body-  | ProjK      -- ^ a record projection-  | LetK---- | Global identifier.-data DefI = DefI { ikind :: IKind, aname :: A.QName }---- | Scope check signature.-type Sig = [(C.QName,DefI)]--emptySig :: Sig-emptySig = []--lookupSigU :: C.Name -> Sig -> Maybe DefI-lookupSigU n = lookupSig (C.QName n)--lookupSig :: C.QName -> Sig -> Maybe DefI-lookupSig n [] = Nothing-lookupSig n ((x,k):xs) = if (x == n) then Just k else lookupSig n xs---- ** State of scope checker.--data SCState = SCState-  { signature  :: Sig-  , nextMeta   :: MVar-  , nextPolVar :: MVar-  }--initSt = SCState emptySig 0 0---- * The scope checking monad.---- | Scope checking monad.------ Reader monad for local environment of variables (used in expresssions and patterns).--- State monad (hidden) for global signature.--- Error monad for reporting scope violations.-newtype ScopeCheck a = ScopeCheck { unScopeCheck ::-  ReaderT SCCxt (StateT SCState (ExceptT TraceError Identity)) a }-  deriving (Functor, Applicative, Monad,-    MonadReader SCCxt, MonadError TraceError)--runScopeCheck-  :: SCCxt          -- ^ Local variable mapping.-  -> SCState        -- ^ Global identifier mapping.-  -> ScopeCheck a   -- ^ The computation.-  -> Either TraceError (a, SCState)-runScopeCheck ctx st (ScopeCheck sc) = runIdentity $ runExceptT $-  runStateT (runReaderT sc ctx) st---- ** Local state.---- | Add a local identifier.---   (Not tail recursive, since it also returns the generate id.)-addBind' :: Show e => e -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck (A.Name, a)-addBind' e n k = do-  ctx <- ask-  case retrieve n (thisLevel ctx) of-    Just _  -> errorAlreadyInContext e n-    Nothing -> do-      let (x, ctx') = newLocal n ctx -- addCtx' n ctx-      a <- local (const ctx') $ k x-      return (x, a)--addBind :: Show e => e -> C.Name -> ScopeCheck a -> ScopeCheck (A.Name, a)-addBind e n k = addBind' e n $ const k--addBinds :: Show e => e -> [C.Name] -> ScopeCheck a -> ScopeCheck ([A.Name], a)-addBinds e ns k = foldr step start ns where-  start    = do-    a <- k-    return ([], a)-  step n k = do-    (x, (xs, a)) <- addBind e n k-    return (x:xs, a)---- | Add local variable without checking shadowing.-addLocal :: C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a-addLocal n k = do-  ctx <- ask-  let (x, ctx') = newLocal n ctx-  local (const ctx') $ k x--addTel :: C.Telescope -> A.Telescope -> ScopeCheck a -> ScopeCheck a-addTel ctel atel = local (addContext nxs)-  where nxs = reverse $ zipTels ctel atel--zipTels :: C.Telescope -> A.Telescope -> [(C.Name,A.Name)]-zipTels ctel atel = zip ns xs-  where ns = collectTelescopeNames ctel-        xs = map A.boundName $ A.telescope atel---- ** Global state.--getSig :: ScopeCheck Sig-getSig = ScopeCheck $ gets signature---- | Add a global identifier.-addName :: IKind -> C.Name -> ScopeCheck A.Name-addName k n = do-  sig <- getSig-  when (isJust (lookupSig (C.QName n) sig)) $-    errorAlreadyInSignature "shadowing of global definitions forbidden" n-  let x = A.fresh $ C.theName n-  addANameU k n x-  return x---- addNameU :: IKind -> C.Name -> ScopeCheck A.Name--- addNameU k n = A.unqual <$> addName k (C.QName n)---- | Add an already translated global identifier.-addAName :: IKind -> C.QName -> A.QName -> ScopeCheck ()-addAName k n x = ScopeCheck $ modify $ \ st ->-  st { signature = (n, DefI k x) : signature st }--addANameU :: IKind -> C.Name -> A.Name -> ScopeCheck ()-addANameU ki n x = addAName ki (C.QName n) (A.QName x)---- | Add or reuse an unqualified name.-overloadName :: IKind -> C.Name -> ScopeCheck A.Name-overloadName k n = do-  sig <- getSig-  case lookupSigU n sig of-    Nothing -> do-      let x = A.fresh $ C.theName n-      addANameU k n x-      return x-    Just (DefI k' (A.QName x)) -> return x--{- UNUSED-addDecl :: C.Declaration -> ScopeCheck A.Name-addDecl (C.DataDecl n _ _ _ _ _ _) = addName DataK n-addDecl (C.RecordDecl n _ _ _ _)   = addName DataK n--}-{- UNUSED-addFunDecl :: Bool -> C.Declaration -> ScopeCheck A.Name-addFunDecl b (C.FunDecl _ ts _) = addTypeSig (FunK b) ts--}--addTypeSig :: IKind -> C.TypeSig -> A.TypeSig -> ScopeCheck ()-addTypeSig kind (C.TypeSig n _) (A.TypeSig x _) = addANameU kind n x--{- UNUSED--- | Add a global identifier.  Fail if already in signature.-addGlobal :: Show d => d -> IKind -> C.Name -> ScopeCheck A.Name-addGlobal d k n = enterShow n $ do-  sig <- getSig-  case lookupSig n sig of-    Just _  -> errorAlreadyInSignature d n-    Nothing -> addName k n--}---- | Create a meta variable.-nextMVar :: (MVar -> ScopeCheck a) -> ScopeCheck a-nextMVar f = ScopeCheck $ do-  st <- get-  put $ st { nextMeta = nextMeta st + 1 }-  unScopeCheck $ f (nextMeta st)---- | Create a polarity meta variable.-nextPVar :: (MVar -> ScopeCheck a) -> ScopeCheck a-nextPVar f = ScopeCheck $ do-  st <- get-  put $ st { nextPolVar = nextPolVar st + 1 }-  unScopeCheck $ f (nextPolVar st)---- ** Additional services of scope monad.---- | Default polarity is context-sensitive.-setDefaultPolarity :: Pol -> ScopeCheck a -> ScopeCheck a-setDefaultPolarity p = local (\ sccxt -> sccxt { defaultPolarity = p })-{--insertingPolVars :: Bool -> ScopeCheck a -> ScopeCheck a-insertingPolVars b = local (\ sccxt -> sccxt { insertPolVars = b })--}---- | Insert polarity variables for omitted polarities.-generalizeDec :: A.Dec -> ScopeCheck A.Dec-generalizeDec dec@A.Hidden = return dec-generalizeDec dec@A.Dec{}  =-  if (polarity dec == Default) then do-    p0 <- asks defaultPolarity-    case p0 of-      PVar{} -> nextPVar $ \ i ->-                  return $ setPol (PVar i) dec-      _      -> return $ setPol p0 dec-   else return dec--generalizeTBind :: C.TBind -> ScopeCheck C.TBind-generalizeTBind tb@C.TMeasure{} = return tb-generalizeTBind tb = do-  dec' <- generalizeDec (C.boundDec tb)-  return $ tb { C.boundDec = dec' }---- | Insert polarity variables in telescope.-generalizeTel :: C.Telescope -> ScopeCheck C.Telescope-generalizeTel = mapM generalizeTBind---- * Scope checking concrete syntax.-------------------------------------------------------------------------scopeCheckDecls :: [C.Declaration] -> ScopeCheck [A.Declaration]-scopeCheckDecls = mapM scopeCheckDeclaration--scopeCheckDeclaration :: C.Declaration -> ScopeCheck A.Declaration--scopeCheckDeclaration (C.OverrideDecl Check ds) = ScopeCheck $ do-  st <- get-  as <- unScopeCheck $ scopeCheckDecls ds -- declarations need to scope check-  put st                   -- but then forget their effect: restore old state-  return $ A.OverrideDecl Check as--scopeCheckDeclaration (C.OverrideDecl Fail ds) = ScopeCheck $ do-  st <- get-  as <- unScopeCheck $ scopeCheckDecls ds-               `catchError` (const $ return [])  --on error discard block-  put st-  return $ A.OverrideDecl Fail as-{--scopeCheckDeclaration (C.OverrideDecl Fail ds) = do-  st <- get-  (as,st') <- (do as  <- scopeCheckDecls ds-                  st' <- get-                  return (as,st'))-               `catchError` (const $ return ([],st))  --on error discard block-  put st'-  return $ A.OverrideDecl Fail as--}-scopeCheckDeclaration (C.OverrideDecl override ds) = do -- TrustMe,Impredicative-  as <- scopeCheckDecls ds-  return $ A.OverrideDecl override as--scopeCheckDeclaration (C.RecordDecl n tel t c fields) =-  scopeCheckRecordDecl n tel t c fields--scopeCheckDeclaration d@(C.DataDecl{}) =-  scopeCheckDataDecl d -- >>= return . (:[])--scopeCheckDeclaration d@(C.FunDecl co _ _) =-  scopeCheckFunDecls co [d] -- >>= return . (:[])--scopeCheckDeclaration (C.LetDecl eval letdef@C.LetDef{ C.letDefDec = dec, C.letDefName = n }) = do-  unless (dec == A.defaultDec) $-    throwErrorMsg $ "polarity annotation not supported in global let definition of " ++ show n-  (tel, mt, e) <- scopeCheckLetDef letdef-  x <- addName LetK n-  return $ A.LetDecl eval x tel mt e--scopeCheckDeclaration d@(C.PatternDecl n ns p) = do-  let errorHead = "invalid pattern declaration\n" ++ C.prettyDecl d ++ "\n"-  -- check pattern-  (p, delta) <- runStateT (scopeCheckPattern p) emptyCtx-  p <- local (addContext delta) $ scopeCheckDotPattern p-  -- ensure that pattern variables are the declared variables-  unless (sort ns == sort (map fst delta)) $ do-    let usedNames = map fst delta-        unusedNames = ns \\ usedNames-        undeclaredNames = usedNames \\ ns-    when (not (null unusedNames)) $ throwErrorMsg $-      errorHead ++ "unsed variables in pattern: "-        ++ Util.showList " " show unusedNames-    when (not (null undeclaredNames)) $ throwErrorMsg $-      errorHead ++ "undeclared variables in pattern: "-        ++ Util.showList " " show undeclaredNames-  --  when (n `elem` ns) $ throwErrorMsg $ errorHead ++ "pattern"-  x <- addName (ConK DefPat) n-  let xs = map (fromJust . flip lookup delta) ns-  return (A.PatternDecl x xs p)---- we support--- - mutual (co)funs--- - mutual (co)data--scopeCheckDeclaration (C.MutualDecl []) = throwErrorMsg "empty mutual block"-scopeCheckDeclaration (C.MutualDecl l@(C.DataDecl{}:xl)) =-  scopeCheckMutual l-scopeCheckDeclaration (C.MutualDecl l@(C.FunDecl  co _ _:xl)) =-  scopeCheckFunDecls co l  -- >>= return . (:[])-scopeCheckDeclaration (C.MutualDecl _) = throwErrorMsg "mutual combination not supported"--scopeCheckLetDef :: C.LetDef -> ScopeCheck (A.Telescope, Maybe (A.Type), A.Expr)-scopeCheckLetDef (C.LetDef dec n tel mt e) =  setDefaultPolarity A.Rec $ do-  tel <- generalizeTel tel-  (tel, (mt, e)) <- scopeCheckTele tel $ do-     (,) <$> mapM scopeCheckExprN mt  -- allow shadowing after : in type-         <*> scopeCheckExprN e        -- allow shadowing after =-  return (tel, mt, e)--{- scopeCheck Mutual block-first check signatures-then bodies--}-scopeCheckMutual :: [C.Declaration] -> ScopeCheck A.Declaration-scopeCheckMutual ds0 = do-  -- flatten nested mutual blocks and override decls-  ds <- mutualFlattenDecls ds0-  -- extract, check, and add type signatures-  let ktsigs = map mutualGetTypeSig ds-  (mmm, tsigs') <- unzip <$> mapM checkAndAddTypeSig ktsigs-  -- funs have been added with internal names-  -- check that all functions are unmeasured or have a same length measure-  let (ns, mll) = unzip $ compressMaybes mmm-  let measured = null mll || isJust (head mll)-  let ok = null mll || all ((head mll)==) (tail mll)-  when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length"-{--  -- switch to internal fun ids-  let funNames = [ n | (FunK _ , A.TypeSig n _) <- ktsigs ] -- internal fun names-{- SAME W/O COMPR-  let funNames = map (\ (_, C.TypeSig n _) -> n) $ filter aux ktsigs where-                   aux (FunK _, _) = True-                   aux _ = False--}-  mapM_ (addName (FunK False)) funNames -- TODO--}-  -- check bodies of declarations-  ds' <- mapM (setDefaultPolarity A.Rec . checkBody) (zip tsigs' ds)-  -- switch back to external fun ids-  let funNames = [ x | A.FunDecl _ (A.Fun _ x _ _) <- ds' ] -- external fun names-  zipWithM_ (addANameU (LetK)) ns funNames---  zipWithM_ (addAName (FunK True)) ns funNames-  return $ A.MutualDecl measured ds'--scopeCheckTele :: C.Telescope -> ScopeCheck a -> ScopeCheck (A.Telescope, a)-scopeCheckTele []         cont = (A.emptyTel,) <$> cont-scopeCheckTele (tb : tel) cont = do-  (tbs, (A.Telescope tel, a)) <- scopeCheckTBind tb $ scopeCheckTele tel cont-  return (A.Telescope $ tbs ++ tel, a)--scopeCheckTBind :: C.TBind -> ScopeCheck a -> ScopeCheck ([A.TBind], a)-scopeCheckTBind tb cont = do-  let contYes = setConstraintAllowed True  cont-      contNo  = setConstraintAllowed False cont-  case tb of-    C.TBind dec [] t -> do -- non-dependent function type-      t       <- scopeCheckExprN t-      ([A.noBind $ A.Domain t A.defaultKind dec],) <$> contNo-    C.TBind dec ns t -> do-      t       <- scopeCheckExprN t-      (xs, a) <- addBinds tb ns $ contYes-      return (map (\ x -> A.TBind x (A.Domain t A.defaultKind dec)) xs, a)-    C.TBounded dec n ltle e -> do-      e <- scopeCheckExprN e-      (x, a) <- addBind tb n $ contYes-      return ([A.TBind x (A.Domain (A.Below ltle e) A.defaultKind dec)], a)-    C.TMeasure mu -> do-      mu <- scopeCheckMeasure mu-      ([A.TMeasure mu],) <$> cont---    C.TMeasure mu -> throwErrorMsg $ "measure not allowed in telescope"-    C.TBound beta -> do-      unlessM (asks constraintAllowed) $-        errorConstraintNotAllowed beta-      beta <- scopeCheckBound beta-      ([A.TBound beta],) <$> cont--checkBody :: (A.TypeSig, C.Declaration) -> ScopeCheck A.Declaration-checkBody (A.TypeSig x tt, C.DataDecl n sz co tel _ cs fields) =-  checkDataBody tt n x sz co tel cs fields-checkBody (ts@(A.TypeSig n t), d@(C.FunDecl co tsig cls)) = do-  (ar,cls') <- scopeCheckFunClauses d-  let n' = A.mkExtName n-  return $ A.FunDecl co $ A.Fun ts n' ar cls'--mutualFlattenDecls :: [C.Declaration] -> ScopeCheck [C.Declaration]-mutualFlattenDecls ds = mapM mutualFlattenDecl ds >>= return . concat--mutualFlattenDecl :: C.Declaration -> ScopeCheck [C.Declaration]-mutualFlattenDecl (C.MutualDecl ds) = mutualFlattenDecls ds-mutualFlattenDecl (C.OverrideDecl Fail _) = throwErrorMsg $ "fail declaration not supported in mutual block"-mutualFlattenDecl (C.OverrideDecl o ds) = do-  ds' <- mutualFlattenDecls ds-  return $ map (\ d -> C.OverrideDecl o [d]) ds'-mutualFlattenDecl (C.LetDecl{}) = throwErrorMsg $ "let in mutual block not supported"-mutualFlattenDecl d = return $ [d]---- extract type sigs of a mutual block in order, error on nested mutual-mutualGetTypeSig :: C.Declaration -> (IKind, C.TypeSig)-mutualGetTypeSig (C.DataDecl n sz co tel t cs fields) =-  (DataK, C.TypeSig n (C.teleToType tel t))-mutualGetTypeSig (C.FunDecl co tsig cls) =-  (FunK False, tsig) -- fun id for use inside defining body-mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel Nothing e)) =-  error $ "let declaration of " ++ show n ++ ": type required in mutual block"-mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel (Just t) e)) =-  (LetK, C.TypeSig n (C.teleToType tel t))-{- mutualGetTypeSig (C.LetDecl ev tsig e) =-  (LetK, tsig) -}-mutualGetTypeSig (C.OverrideDecl _ [d]) =-  mutualGetTypeSig d---scopeCheckRecordDecl :: C.Name -> C.Telescope -> C.Type -> C.Constructor -> [C.Name] ->-  ScopeCheck A.Declaration-scopeCheckRecordDecl n tel t c cfields = enterShow n $ do-  setDefaultPolarity A.Param $ do-    tel <- generalizeTel tel-    -- STALE COMMENT: we do not infer at all: -- do not infer polarities in index arguments-    (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t)-    addANameU DataK n x-    let names = collectTelescopeNames tel-        target = C.App (C.ident n) (map C.ident names)  -- R pars-        (tel',t') = A.typeToTele' (length names) tt'-    c' <- scopeCheckConstructor n x (zipTels tel tel') A.CoInd target c-    let delta = contextFromConstructors c c'-    afields <- addFields ProjK delta cfields-    return $ A.RecordDecl x tel' t' c' afields--contextFromConstructors :: C.Constructor -> A.Constructor -> Context-contextFromConstructors (C.Constructor _ ctel0 mct) (A.Constructor _ _ at) = delta-  where ctel = maybe [] (fst . C.typeToTele) mct-        (atel, _) = A.typeToTele at-        delta = zipTels (ctel0 ++ ctel) atel--scopeCheckField :: Context -> C.Name -> ScopeCheck A.Name-scopeCheckField delta n =-  case lookup n delta of-    Nothing -> errorNotAField n-    Just x  -> return $ x--addFields :: IKind -> Context -> [C.Name] -> ScopeCheck [A.Name]-addFields kind delta cfields = do-    afields <- mapM (scopeCheckField delta) cfields-    mapM (uncurry $ addANameU kind) $ zip cfields afields-    return afields--scopeCheckDataDecl :: C.Declaration -> ScopeCheck A.Declaration-scopeCheckDataDecl decl@(C.DataDecl n sz co tel0 t cs fields) = enterShow n $ do-  setDefaultPolarity A.Param $ do-    tel <- generalizeTel tel0-    -- STALE: -- do not infer polarities in index arguments-    (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t)-    addANameU DataK n x-    checkDataBody tt' n x sz co tel cs fields---- precondition: name already added to signature-checkDataBody :: A.Type -> C.Name -> A.Name -> Sized -> Co -> C.Telescope -> [C.Constructor] -> [C.Name] -> ScopeCheck A.Declaration-checkDataBody tt' n x sz co tel cs fields = do-      let cnames = collectTelescopeNames tel         -- parameters-          target = C.App (C.ident n) $ map C.ident cnames  -- D pars-          (tel',t') = A.typeToTele' (length cnames) tt'-      cs' <- mapM (scopeCheckConstructor n x (zipTels tel tel') co target) cs-{- NO LONGER INFER DESTRUCTORS-      -- traceM ("constructors: " ++ show cs')---      when (t' == A.Sort A.Set && length cs' == 1) $ do---      when (length cs' == 1) $ do  -- TOO STRICT, DOES NOT TREAT Vec right-      let cis = A.analyzeConstructors co n tel' cs'-      flip mapM_ cis $ \ ci -> when (A.cEtaExp ci) $ do--- Add destructor names-        let fields = A.cFields ci -- A.classifyFields co n (A.typePart c)-        -- TODO Check for recursive occurrence!-        -- when (A.etaExpandable fields) $-        let destrNames =  A.destructorNames fields-        --when (not (null (destrNames))) $-        -- traceM ("fields: " ++ show fields)-        -- traceM ("destructors: " ++ show destrNames)-        mapM_ (addName (FunK True)) $ destrNames -- destructors are also upped- {--        let (ctel,_) = A.typeToTele (A.typePart (head cs'))-        let destrNames = map (\(_,x,_) -> x) ctel-        when (all (/= "") destrNames) $-          mapM_ (addName (FunK True)) destrNames -- destructors are also upped--}--}-      -- add declared destructor names-      let delta = concat $ map (uncurry contextFromConstructors) $ zip cs cs'-      -- fields <- addFields (LetK) delta fields-      -- 2012-01-26 register as projections-      fields <- addFields ProjK delta fields-      let pos = map (A.polarity . A.decor . A.boundDom) $ A.telescope tel'-      return $ A.DataDecl x sz co pos tel' t' cs' fields---- check whether all declarations in mutual block are (co)funs-checkFunMutual :: Co -> [C.Declaration] -> ScopeCheck ()-checkFunMutual co [] = return ()-checkFunMutual co (C.FunDecl co' _ _:xl) | co == co' = checkFunMutual co xl-checkFunMutual _ _ = throwErrorMsg "mutual combination not supported"--scopeCheckFunDecls :: Co -> [C.Declaration] -> ScopeCheck A.Declaration-scopeCheckFunDecls co l = do-  -- check for uniformity of mutual block (all funs/all cofuns)-  checkFunMutual co l-  -- check signatures and look for measures-  r <- mapM (\ (C.FunDecl _ tysig _) -> scopeCheckFunSig tysig) l-  let (ml:mll, tsl') = unzip r-  let ok = all (ml==) mll-  when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length"-  -- add names as internal ids and check bodies-  let nxs = zipWith (\ (C.FunDecl _ (C.TypeSig n _) _) (A.TypeSig x _) -> (n,x)) l tsl'-  --let addFuns b = mapM (uncurry $ addAName $ FunK b) nxs---  let addFuns b = mapM (\ (n,x) -> addAName (FunK b) n x) nxs-  -- addFuns False-  mapM (uncurry $ addANameU $ FunK False) nxs-  arcll' <- mapM (setDefaultPolarity A.Rec . scopeCheckFunClauses) l-  -- add names as external ids-  --addFuns True-  let nxs' = map (mapPair id A.mkExtName) nxs-  mapM (uncurry $ addANameU (LetK)) nxs'---  mapM (uncurry $ addAName (FunK True)) nxs'-  return $ A.MutualFunDecl (isJust ml) co $-    zipWith3 (\ ts (_, x') (ar, cls) -> A.Fun ts x' ar cls) tsl' nxs' arcll'---- | Does not add name to signature.-scopeCheckFunSig :: C.TypeSig -> ScopeCheck (Maybe Int, A.TypeSig)-scopeCheckFunSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do-    (ml, t') <- scopeCheckFunType t-    return (ml, A.TypeSig x t')---- scope check type of mutual function, return length of measure (if present)--- a fun type is a telescope followed by (maybe) a measure and a type expression-scopeCheckFunType :: C.Expr -> ScopeCheck (Maybe Int, A.Expr)-scopeCheckFunType t =-  case t of--      -- found a measure: continue normal scope checking-      C.Quant A.Pi [C.TMeasure mu] e1 -> do-        mu' <- scopeCheckMeasure mu-        e1' <- scopeCheckExprN e1-        return (Just $ length (measure mu'), A.pi (A.TMeasure mu') e1')--      -- bounds are allowed here, since we check a function type-      C.Quant A.Pi [C.TBound beta] e1 -> do-        beta'     <- scopeCheckBound beta-        (ml, e1') <- scopeCheckFunType e1-        return (ml, A.pi (A.TBound beta') e1')--      C.Quant A.Pi tel e -> do-        tel <- generalizeTel tel-        (tel, (ml, e)) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $-          scopeCheckTele tel $ setConstraintAllowed True $ scopeCheckFunType e-        ml' <- findMeasure tel-        ml <- case (ml,ml') of-                 (Nothing,ml') -> return ml'-                 (ml, Nothing) -> return ml-                 (Just{}, Just{}) -> errorOnlyOneMeasure-        return (ml, A.teleToType tel e)--      t -> (Nothing,) <$> scopeCheckExpr t -- no measure found--findMeasure :: A.Telescope -> ScopeCheck (Maybe Int)-findMeasure (A.Telescope tel) =-  case [ mu | A.TMeasure mu <- tel ] of-    []           -> return Nothing-    [Measure mu] -> return $ Just $ length mu-    _            -> errorOnlyOneMeasure---- | Check whether concrete name is already in signature.---   If yes, fail. If no, create abstract name and continue.-checkInSig :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a-checkInSig d n k = enterShow n $ do-  sig <- getSig-  case lookupSig (C.QName n) sig of-    Just _  -> errorAlreadyInSignature d n-    Nothing -> k (A.fresh $ C.theName n)---- checkInSigU :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a--- checkInSigU d n k = checkInSig d (C.QName n) (k . A.unqual)--scopeCheckFunClauses :: C.Declaration -> ScopeCheck (Arity, [A.Clause])-scopeCheckFunClauses (C.FunDecl _ (C.TypeSig n _) cl) = enterShow n $ do-  cl <- mapM (scopeCheckClause (Just n)) cl-  let m = if null cl then 0 else-       List.foldl1 min $ map (length . A.clPatterns) cl-  return (A.Arity m Nothing, cl)-{--       let b = checkPatternLength cl-       case b of-          Just m  -> return $ (A.Arity m Nothing, cl)-          Nothing -> throwErrorMsg $ " pattern length differs"--}---- | Check the type of a signature and generate abstract name.---   Does not add abstract name to signature.-scopeCheckTypeSig :: C.TypeSig -> ScopeCheck A.TypeSig-scopeCheckTypeSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do-    t' <- scopeCheckExpr t-    return $ A.TypeSig x t'---- | Results:------     @Nothing@            Not a function declaration.------     @Just (n, Nothing)@  Unmeasured function.------     @Just (n, Just m)@   Function with measure of length m-checkAndAddTypeSig :: (IKind, C.TypeSig) -> ScopeCheck (Maybe (C.Name, Maybe Int), A.TypeSig)-checkAndAddTypeSig (kind, ts@(C.TypeSig n _)) = do-  (mm, ts'@(A.TypeSig x _)) <--    case kind of-      FunK _ -> mapPair (Just . (n,)) id <$> scopeCheckFunSig ts-{--        do-        (mi, ts) <- scopeCheckFunSig ts-        return (Just mi, ts)--}-      _ -> (Nothing,) <$> scopeCheckTypeSig ts-  addANameU kind n x  -- or: addTypeSig kind ts ts'-  return (mm, ts')--collectTelescopeNames :: C.Telescope -> [C.Name]-collectTelescopeNames = concat . map C.boundNames---- | Check whether concrete name is already in signature.---   If yes, fail. If no, create abstract name and continue.-checkConsInSig :: Show decl => decl -> C.Name -> A.Name -> IKind -> C.Name -> (A.QName -> ScopeCheck a) -> ScopeCheck a-checkConsInSig decl d dx ki n cont = enterShow n $ do-  -- first check whether the datatype has this constructor already-  ifJustM (lookupSig (C.Qual d n) <$> getSig) (const $ errorAlreadyInSignature decl n) $ do-  -- then check the overloaded name and possibly add it-  x <- overloadName ki n-  -- the qualified name is added in the continuation-  cont $ A.Qual dx x---- | @cxt@ is the data telescope.-scopeCheckConstructor :: C.Name -> A.Name -> Context -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor-scopeCheckConstructor d dx cxt co t0 a@(C.Constructor n tel mt) = do-  let ki = ConK $ A.coToConK co-  checkConsInSig a d dx ki n $ \ x -> do--  let finish t mcxt = local (addContext $ maybe cxt id mcxt) $ do-       t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t-       t <- adjustTopDecsM defaultToParam t-       addAName ki (C.Qual d n) x-       let dummyDom = A.Domain A.Irr A.NoKind $ A.Dec Param-           mtel     = fmap (map (\ (n,x) -> A.TBind x dummyDom)) mcxt-           ps       = [] -- patterns computed during type checking-       return $ A.Constructor x (fmap ((,ps) . A.Telescope) mtel) t--  case mt of--    -- no target given, then add the data tel to the scope-    Nothing -> finish t0 Nothing--    -- target given, then the target binds the parameter names-    Just t -> do-      -- get the final target-      let (_, target) = C.typeToTele t--          fallback = finish t Nothing-          continue d' es = do-            -- unless (d == d') $ errorWrongTarget n d d'-            if (d /= d') then fallback else do-            -- get the parameters of target-            let (pars, inds) = splitAt (length cxt) es-            unless (length pars == length cxt) $ errorNotEnoughParameters n target-            -- if parameters are just data parameters, do it old style-            if and (zipWith isTelPar cxt pars) then fallback else do-            -- scopeCheck the parameters as patterns-            finish t . Just =<< parameterVariables pars--      case target of-        C.Ident (C.QName d')            -> continue d' []-        C.App (C.Ident (C.QName d')) es -> continue d' es-        _ -> fallback -- errorTargetMustBeAppliedName n target--{- OLD CODE-scopeCheckConstructor :: C.Telescope -> A.Telescope -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor-scopeCheckConstructor ctel atel co t0 a@(C.Constructor n tel mt) = addTel ctel atel $ checkInSig a n $ \ x -> do-    let t = maybe t0 id mt-    t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t-    t <- adjustTopDecsM defaultToParam t-    addAName (ConK $ A.coToConK co) n x-    return $ A.TypeSig x t--}-  where isTelPar (c,_) (C.Ident (C.QName x)) = c == x-        isTelPar _     _                     = False-        defaultToParam dec = case (A.polarity dec) of-          A.Default -> return $ setPol A.Param dec-          A.Param   -> return dec-          A.Const   -> return dec-          A.PVar{}  -> return dec-          _         -> throwErrorMsg $ "illegal polarity " ++ show (polarity dec) ++ " in type of constructor " ++ show a---- | Allow shadowing of previous locals.---   Always if we enter a subexpression which is not the body---   of a binder.-scopeCheckExprN :: C.Expr -> ScopeCheck A.Expr-scopeCheckExprN = newLevel . scopeCheckExpr--scopeCheckExpr :: C.Expr -> ScopeCheck A.Expr-scopeCheckExpr e = setConstraintAllowed False $ scopeCheckExpr' e--scopeCheckExpr' :: C.Expr -> ScopeCheck A.Expr-scopeCheckExpr' e =-    case e of-      -- replace underscore by next meta-variable-      C.Unknown -> nextMVar (return . A.Meta)-      C.Set   e -> A.Sort . A.Set   <$> scopeCheckExprN e-      C.CoSet e -> A.Sort . A.CoSet <$> scopeCheckExprN e-      C.Size    -> return $ A.Sort (A.SortC A.Size)-      C.Succ e1 -> A.Succ <$> scopeCheckExprN e1-      C.Zero    -> return A.Zero-      C.Infty   -> return A.Infty-      C.Plus e1 e2 -> do-        e1 <- scopeCheckExprN e1-        e2 <- scopeCheckExprN e2-        return $ A.Plus [e1, e2]-      C.Pair e1 e2   -> A.Pair <$> scopeCheckExprN e1 <*> scopeCheckExprN e2-      C.Sing e1 et   -> A.Sing <$> scopeCheckExprN e1 <*> scopeCheckExprN et-      C.App C.Max el -> do-        el' <- mapM scopeCheckExprN el-        when (length el' < 2) $ throwErrorMsg "max expects at least 2 arguments"-        return $ A.Max el'-      C.App e1 el -> foldl A.App <$> scopeCheckExprN e1 <*> mapM scopeCheckExprN el-      C.Case e mt cl -> do-        e'  <- scopeCheckExprN e-        mt' <- mapM scopeCheckExprN mt-        cl' <- mapM (scopeCheckClause Nothing) cl-        return $ A.Case e' mt' cl'--      -- measure & bound-      -- measures can only appear in fun sigs!-      C.Quant pisig [C.TMeasure mu] e1 -> do-        throwErrorMsg $ "measure not allowed in expression " ++ show e--      -- measure bound mu < mu'-      C.Quant A.Pi [C.TBound beta] e1 -> do-        unlessM (asks constraintAllowed) $ errorConstraintNotAllowed beta-        beta' <- scopeCheckBound beta-        e1'   <- scopeCheckExpr' e1-        return $ A.pi (A.TBound beta') e1'--      C.Quant A.Sigma [C.TBound beta] e1 -> throwErrorMsg $-        "measure bound not allowed in expression " ++ show e--      C.Quant pisig tel e -> do-        tel <- generalizeTel tel-        pol <- asks defaultPolarity-        (A.Telescope tel, e) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $ scopeCheckTele tel $-           setDefaultPolarity pol $ scopeCheckExpr' e-        return $ quant pisig tel e where---          quant A.Sigma [tb] = A.Quant A.Sigma tb-          quant A.Sigma tel e = foldr (A.Quant A.Sigma) e tel-          quant A.Pi    tel e = A.teleToType (A.Telescope tel) e--      C.Lam n e1 -> do-        (n, e1') <- addBind e n $ scopeCheckExpr e1-        return $ A.Lam A.defaultDec n e1' -- dec. in Lam is ignored in t.c.--      C.LLet letdef e2 -> do-        let dec = C.letDefDec letdef-        (tel, mt, e1) <- scopeCheckLetDef letdef-        (x, e2) <- addBind e (C.letDefName letdef) $ scopeCheckExpr e2-        return $ A.LLet (A.TBind x $ A.Domain mt A.defaultKind dec) tel e1 e2--      C.Record rs -> do-        let fields = map fst rs-        if (hasDuplicate fields) then (errorDuplicateField e) else do-          rs <- mapM scopeCheckRecordLine rs-          return $ A.Record A.AnonRec rs--      C.Proj n -> A.Proj Post <$> scopeCheckProj n--      C.Ident n@C.Qual{} -> scopeCheckGlobalVar n--      C.Ident n@C.QName{} -> do-        res <- lookupLocal (C.name n)-        case res of-          Just x -> return $ A.Var x-          Nothing -> scopeCheckGlobalVar n--      _ -> throwErrorMsg $ "NYI: scopeCheckExpr " ++ show e--scopeCheckGlobalVar :: C.QName -> ScopeCheck A.Expr-scopeCheckGlobalVar n = do-  res <- lookupGlobal n-  case res of-    Just (DefI k x) -> case k of-      (ConK co)  -> return $ A.con co x-      LetK       -> return $ A.letdef (A.unqual x)-      -- references to recursive functions are coded differently-      -- outside the mutual block-      FunK True  -> return $ A.fun x -- A.letdef x -- A.mkExtRef x-      FunK False -> return $ A.fun x-      DataK      -> return $ A.dat x-      ProjK      -> return $ A.Proj A.Pre (A.unqual x) -- errorProjectionUsedAsExpression n-    Nothing -> errorIdentifierUndefined n--scopeCheckLocalVar :: C.Name -> ScopeCheck A.Name-scopeCheckLocalVar n = maybe (errorIdentifierUndefined n) return =<< do-  lookupLocal n--scopeCheckRecordLine :: ([C.Name], C.Expr) -> ScopeCheck (A.Name, A.Expr)-scopeCheckRecordLine (n : ns, e) = do-  x <- scopeCheckProj n-  (x,) <$> scopeCheckExprN (foldr C.Lam e ns)--scopeCheckProj :: C.Name -> ScopeCheck A.Name-scopeCheckProj n = do-  sig <- getSig-  case lookupSigU n sig of-    Just (DefI ProjK x) -> return $ A.unqual x-    _                   -> errorNotAField n----- | @isProjIdent n = n@ if defined and the name of a projection.-isProjIdent :: C.QName -> ScopeCheck (Maybe A.Name)-isProjIdent n = do-  sig <- getSig-  return $-    case lookupSig n sig of-      Just (DefI ProjK x) -> Just $ A.unqual x-      _ -> Nothing--isProjection :: C.Expr -> ScopeCheck (Maybe A.Name)-isProjection (C.Ident n) = isProjIdent n-isProjection _           = return Nothing--scopeCheckMeasure :: A.Measure C.Expr -> ScopeCheck (A.Measure A.Expr)-scopeCheckMeasure (A.Measure es) = do-  es' <- mapM scopeCheckExprN es-  return $ A.Measure es'--scopeCheckBound :: A.Bound C.Expr -> ScopeCheck (A.Bound A.Expr)-scopeCheckBound (A.Bound ltle e1 e2) = do-  [e1',e2'] <- mapM scopeCheckMeasure [e1,e2]-  return $ A.Bound ltle e1' e2'--checkPatternLength :: [C.Clause] -> Maybe Int-checkPatternLength [] = Just 0 -- arity 0-checkPatternLength (C.Clause _ pl _:cl) = cpl (length pl) cl- where-   cpl k [] = Just k-   cpl k (C.Clause _ pl _ : cl) = if (length pl == k) then (cpl k cl) else Nothing--scopeCheckClause :: Maybe C.Name -> C.Clause -> ScopeCheck A.Clause-scopeCheckClause mname' (C.Clause mname pl mrhs) = do-  when (mname /= mname') $ errorClauseIdentifier mname mname'-  (pl, delta) <- runStateT (mapM scopeCheckPattern pl) emptyCtx-  local (addContext delta) $ do-    pl <- mapM scopeCheckDotPattern pl-    case mrhs of-      Nothing  -> return $ A.clause pl Nothing-      Just rhs -> A.clause pl . Just <$> scopeCheckExprN rhs---type PatCtx = Context-type SPS = StateT PatCtx ScopeCheck--scopeCheckPatVar :: C.QName -> SPS (A.Pat C.Expr)-scopeCheckPatVar n = do-      sig <- lift $ getSig-      case lookupSig n sig of-        Just (DefI (ConK co) n) -> return $ A.ConP (A.PatternInfo co False False) n []-                             -- a nullary constructor-        Just _  -> errorPatternNotConstructor n-        Nothing -> A.VarP <$> addUnique (C.unqual n)--scopeCheckPattern :: C.Pattern -> SPS (A.Pat C.Expr)-scopeCheckPattern p =-  case p of--    -- case n-    C.IdentP n        -> scopeCheckPatVar n-    C.ConP False n [] -> scopeCheckPatVar n--    -- case (i > j):-    C.SizeP m n -> do-      -- m   <- lift $ scopeCheckLocalVar m-      A.SizeP m <$> addUnique n--    -- case $p-    C.SuccP p2    -> A.SuccP <$> scopeCheckPattern p2--    -- case (p1,p2)-    C.PairP p1 p2 -> A.PairP <$> scopeCheckPattern p1 <*> scopeCheckPattern p2--    -- case .n-    C.ConP True n [] -> do-      -- try projection-      ifJustM (lift $ isProjIdent n) (return . A.ProjP) $ do-      -- try constructor-      sig <- lift $ getSig-      case lookupSig n sig of-        Just (DefI (ConK co) n) ->-              return $ A.ConP (A.PatternInfo co False True) n []-      -- fallback: dot pattern-        _  -> return $ A.DotP (C.Ident n)--    -- case [.]c ps-    C.ConP dotted n pl -> do-      sig <- lift $ getSig-      case lookupSig n sig of-        Just (DefI (ConK co) x) ->-          A.ConP (A.PatternInfo co False dotted) x <$> mapM scopeCheckPattern pl-        _  -> errorPatternNotConstructor n--    -- case .e-    C.DotP e  -> do-      isProj <- lift $ isProjection e-      case isProj of-       Just n  -> return $ A.ProjP n-       Nothing -> return $ A.DotP e -- dot patterns checked later--    -- case ()-    C.AbsurdP -> return $ A.AbsurdP---- | Add pattern variable to pattern context, must not be present yet.-addUnique :: C.Name -> SPS A.Name-addUnique = addPatVar True--addNonUnique :: C.Name -> SPS A.Name-addNonUnique = addPatVar False--addPatVar :: Bool -> C.Name -> SPS A.Name-addPatVar linear n = do-  delta <- get-  case retrieve n delta of-    Just x -> if linear then errorPatternNotLinear n else return x-    Nothing -> do-      let (x, delta') = newLocal n delta-      put delta'-      return x--scopeCheckDotPattern :: A.Pat C.Expr -> ScopeCheck A.Pattern-scopeCheckDotPattern p =-    case p of-      A.DotP e -> A.DotP <$> scopeCheckExprN e-      A.PairP p1 p2 -> A.PairP <$> scopeCheckDotPattern p1 <*>  scopeCheckDotPattern p2-      A.SuccP p -> A.SuccP <$> scopeCheckDotPattern p-      A.ConP co n pl -> A.ConP co n <$> mapM scopeCheckDotPattern pl---      A.SizeP m n -> flip A.SizeP n <$> scopeCheckLocalVar m -- return $ A.SizeP m n-      A.SizeP e n    -> flip A.SizeP n <$> scopeCheckExprN e-      A.VarP n       -> return $ A.VarP n  -- even though p = A.VarP n, it has wrong type!!-      A.ProjP n      -> return $ A.ProjP n-      A.AbsurdP      -> return $ A.AbsurdP-      -- impossible cases: ErasedP, UnusableP----- * Scope checking parameters--parameterVariables :: [C.Expr] -> ScopeCheck Context-parameterVariables es = do-  execStateT (mapM_ scopeCheckParameter es) emptyCtx---- | Extract variables bound by data parameters.---   We consider a more liberal set of patterns, everything---   that is injective and does not bind variables.-scopeCheckParameter :: C.Expr -> SPS ()-scopeCheckParameter e =-  case e of-    C.Set e'             -> scopeCheckParameter e'-    C.CoSet e'           -> scopeCheckParameter e'-    C.Size               -> return ()-    C.Succ e'            -> scopeCheckParameter e'-    C.Zero               -> return ()-    C.Infty              -> return ()-    C.Pair e1 e2         -> scopeCheckParameter e1 >> scopeCheckParameter e2-    C.Record fs          -> mapM_ (scpField e) fs-    C.Ident n            -> scpApp e n []-    C.App (C.Ident n) es -> scpApp e n es-    C.App C.App{} es     -> throwErrorMsg $ "scopeCheckParameter " ++ show e ++ ": internal invariant violated"-    _ -> errorInvalidParameter e-  where-    -- we can only treat a record expression as pattern-    -- if it does not bind any variables-    scpField :: C.Expr -> ([C.Name], C.Expr) -> SPS ()-    scpField e ([f], e') = scopeCheckParameter e'-    scpField e _         = errorInvalidParameter e--    scpApp :: C.Expr -> C.QName -> [C.Expr] -> SPS ()-    scpApp e n es = do-      sig <- lift $ getSig-      case lookupSig n sig of-        Just (DefI ConK{} n) -> mapM_ scopeCheckParameter es-        Just (DefI DataK  n) -> mapM_ scopeCheckParameter es-        Just _  -> errorInvalidParameter e-        Nothing -> void $ addNonUnique (C.unqual n) -- allow non-linearity---- * Scope checking errors--errorAlreadyInSignature s n = throwErrorMsg $ show s  ++ ": Identifier " ++ show n ++ " already in signature"--errorAlreadyInContext s n = throwErrorMsg $ show s ++ ": Identifier " ++ show n ++ " already in context"---- errorPatternNotVariable n = throwErrorMsg $ "pattern " ++ n ++ ": Identifier expected"--errorPatternNotConstructor n = throwErrorMsg $ "pattern " ++ show n ++ " is not a constructor"--errorNotAField n = throwErrorMsg $ "record field " ++ show n ++ " unknown"--- errorUnknownProjection n = throwErrorMsg $ "projection " ++ n ++ " unknown"--errorDuplicateField r = throwErrorMsg $ show r ++ " assigns a field twice"---errorProjectionUsedAsExpression n = throwErrorMsg $ "projection " ++ show n ++ " used as expression"--errorIdentifierUndefined n = throwErrorMsg $ "Identifier " ++ show n ++ " undefined"--errorPatternNotLinear n = throwErrorMsg $ "pattern not linear: " ++ show n--errorClauseIdentifier (Just n) (Just n') = throwErrorMsg $ "Expected identifier " ++ show n' ++ " as clause head, found " ++ show n--errorOnlyOneMeasure = throwErrorMsg "only one measure allowed in a function type"--errorConstraintNotAllowed beta = throwErrorMsg $-  show beta ++ ": constraints must follow a quantifier"--errorTargetMustBeAppliedName n t = throwErrorMsg $-  "constructor " ++ show n ++ ": target must be data/record type applied to parameters and indices; however, I found " ++ show t--errorWrongTarget c d d' = throwErrorMsg $-  "constructor " ++ show c ++ " should target data/record type " ++ show d ++ "; however, I found " ++ show d'--errorNotEnoughParameters c t = throwErrorMsg $-  "constructor " ++ show c ++ ": target " ++ show t ++ " is missing parameters"--errorInvalidParameter e = throwErrorMsg $-  "expression " ++ show e ++ " is not valid in a parameter"
− Semiring.hs 
@@ -1,101 +0,0 @@--- {-# LANGUAGE UndecidableInstances #-}---- | Semirings.  Original: Agda.Terminatio.Semiring--module Semiring-  ( HasZero(..), SemiRing(..)-  , Semiring(..)---  , semiringInvariant-  , integerSemiring-  , boolSemiring-  ) where--import Data.Monoid---{- | SemiRing type class.  Additive monoid with multiplication operation.-Inherit addition and zero from Monoid. -}--class (Eq a, Monoid a) => SemiRing a where---  isZero   :: a -> Bool-  multiply :: a -> a -> a----- | @HasZero@ is needed for sparse matrices, to tell which is the element---   that does not have to be stored.---   It is a cut-down version of @SemiRing@ which is definable---   without the implicit @?cutoff@.-class Eq a => HasZero a where-  zeroElement :: a---- | Semirings.--data Semiring a-  = Semiring { add  :: a -> a -> a  -- ^ Addition.-             , mul  :: a -> a -> a  -- ^ Multiplication.-             , zero :: a            -- ^ Zero.--- The one is never used in matrix multiplication---             , one  :: a            -- ^ One.-             }---- | Semiring invariant.---- I think it's OK to use the same x, y, z triple for all the--- properties below.--{--semiringInvariant :: (Arbitrary a, Eq a, Show a)-                  => Semiring a-                  -> a -> a -> a -> Bool-semiringInvariant (Semiring { add = (+), mul = (*)-                            , zero = zero --, one = one-                            }) = \x y z ->-  associative (+)           x y z &&-  identity zero (+)         x     &&-  commutative (+)           x y   &&-  associative (*)           x y z &&---  identity one (*)          x     &&-  leftDistributive (*) (+)  x y z &&-  rightDistributive (*) (+) x y z &&-  isZero zero (*)           x--}----------------------------------------------------------------------------- Specific semirings---- | The standard semiring on 'Integer's.--instance HasZero Integer where-  zeroElement = 0--instance Monoid Integer where-  mempty = 0-  mappend = (+)--instance SemiRing Integer where-  multiply = (*)---integerSemiring :: Semiring Integer-integerSemiring = Semiring { add = (+), mul = (*), zero = 0 } -- , one = 1 }---- prop_integerSemiring = semiringInvariant integerSemiring---- | The standard semiring on 'Bool's.--boolSemiring :: Semiring Bool-boolSemiring =-  Semiring { add = (||), mul = (&&), zero = False } --, one = True }---- prop_boolSemiring = semiringInvariant boolSemiring----------------------------------------------------------------------------- All tests--{--tests :: IO Bool-tests = runTests "Agda.Termination.Semiring"-  [ quickCheck' prop_integerSemiring-  , quickCheck' prop_boolSemiring-  ]--}
− SparseMatrix.hs 
@@ -1,459 +0,0 @@-{- | Sparse matrices.  Original: Agda.Termination.SparseMatrix--We assume the matrices to be very sparse, so we just implement them as-sorted association lists.-- -}--module SparseMatrix-  ( -- * Basic data types-    Matrix(M)-  , matrixInvariant-  , Size(..)-  , sizeInvariant-  , MIx (..)-  , mIxInvariant-    -- * Generating and creating matrices-  , fromLists-  , fromIndexList-  , toLists---  , matrix---  , matrixUsingRowGen-    -- * Combining and querying matrices-  , size-  , square-  , isEmpty-  , isSingleton-  , SparseMatrix.all, SparseMatrix.any-  , add, intersectWith, SparseMatrix.zip-  , mul-  , transpose-  , diagonal-    -- * Modifying matrices-  , addRow-  , addColumn-    -- * Tests-  ) where--import Data.Array-import qualified Data.List as List-import Data.Monoid---- import Test.QuickCheck--import Semiring (HasZero(..), SemiRing, Semiring)-import qualified Semiring as Semiring------------------------------------------------------------------------------- Basic data types---- | This matrix type is used for tests.--type TM = Matrix Integer Integer---- | Size of a matrix.--data Size i = Size { rows :: i, cols :: i }-  deriving (Eq, Ord, Show)--sizeInvariant :: (Ord i, Num i) => Size i -> Bool-sizeInvariant sz = rows sz >= 0 && cols sz >= 0--{--instance (Arbitrary i, Integral i) => Arbitrary (Size i) where-  arbitrary = do-    r <- natural-    c <- natural-    return $ Size { rows = fromInteger r, cols = fromInteger c }--instance CoArbitrary i => CoArbitrary (Size i) where-  coarbitrary (Size rs cs) = coarbitrary rs . coarbitrary cs--prop_Arbitrary_Size :: Size Integer -> Bool-prop_Arbitrary_Size = sizeInvariant--}---- | Converts a size to a set of bounds suitable for use with--- the matrices in this module.--toBounds :: Num i => Size i -> (MIx i, MIx i)-toBounds sz = (MIx { row = 1, col = 1 }, MIx { row = rows sz, col = cols sz })---- | Type of matrix indices (row, column).--data MIx i = MIx { row, col :: i }-  deriving (Eq, Show, Ix, Ord)--{--instance (Arbitrary i, Integral i) => Arbitrary (MIx i) where-  arbitrary = do-    r <- positive-    c <- positive-    return $ MIx { row = r, col = c }--instance CoArbitrary i => CoArbitrary (MIx i) where-  coarbitrary (MIx r c) = coarbitrary r . coarbitrary c--}---- | No nonpositive indices are allowed.--mIxInvariant :: (Ord i, Num i) => MIx i -> Bool-mIxInvariant i = row i >= 1 && col i >= 1--prop_Arbitrary_MIx :: MIx Integer -> Bool-prop_Arbitrary_MIx = mIxInvariant---- | Type of matrices, parameterised on the type of values.--data Matrix i b = M { size :: Size i, unM :: [(MIx i, b)] }-  deriving (Ord)--instance (Ord i, Eq a, HasZero a) => Eq (Matrix i a) where-  m1 == m2 = size m1 == size m2 && -    SparseMatrix.all (uncurry (==)) (SparseMatrix.zip m1 m2)--instance Functor (Matrix i) where-  fmap f (M sz m) = M sz (map (\ (i,a) -> (i, f a)) m)--matrixInvariant :: (Num i, Ix i) => Matrix i b -> Bool-matrixInvariant m = List.all (\ (MIx i j, b) -> 1 <= i && i <= rows sz-                                             && 1 <= j && j <= cols sz) (unM m)-  && strictlySorted (MIx 0 0) (unM m)-  && sizeInvariant sz-  where sz = size m---- matrix indices are lexicographically sorted with no duplicates--- Ord MIx should be the lexicographic one already (Haskell report)--strictlySorted :: (Ord i) => i -> [(i, b)] -> Bool-strictlySorted i [] = True-strictlySorted i ((i', b) : l) = i < i' && strictlySorted i' l-{--strictlySorted (MIx i j) [] = True-strictlySorted (MIx i j) ((MIx i' j', b) : l) =-  (i < i' || i == i' &&  j < j' ) && strictlySorted (MIx i' j') b--}--instance (Ord i, Integral i, Enum i, Show i, Show b, HasZero b) => Show (Matrix i b) where-  showsPrec _ m =-    showString "SparseMatrix.fromLists " . shows (size m) .-    showString " " . shows (toLists m)--{--instance (Integral i, HasZero b, Pretty b) =>-         Pretty (Matrix i b) where-  pretty = vcat . map (hsep . map pretty) . toLists--instance (Arbitrary i, Num i, Integral i, Arbitrary b, HasZero b)-         => Arbitrary (Matrix i b) where-  arbitrary     = matrix =<< arbitrary--instance (Ord i, Integral i, Enum i, CoArbitrary b, HasZero b) => CoArbitrary (Matrix i b) where-  coarbitrary m = coarbitrary (toLists m)---prop_Arbitrary_Matrix :: TM -> Bool-prop_Arbitrary_Matrix = matrixInvariant--}----------------------------------------------------------------------------- Generating and creating matrices---- | Generates a matrix of the given size, using the given generator--- to generate the rows.--{--matrixUsingRowGen :: (Arbitrary i, Integral i, Arbitrary b, HasZero b)-  => Size i-  -> (i -> Gen [b])-     -- ^ The generator is parameterised on the size of the row.-  -> Gen (Matrix i b)-matrixUsingRowGen sz rowGen = do-  rows <- vectorOf (fromIntegral $ rows sz) (rowGen $ cols sz)-  return $ fromLists sz rows--}---- | Generates a matrix of the given size.--{--matrix :: (Arbitrary i, Integral i, Arbitrary b, HasZero b)-  => Size i -> Gen (Matrix i b)-matrix sz = matrixUsingRowGen sz (\n -> vectorOf (fromIntegral n) arbitrary)--prop_matrix sz = forAll (matrix sz :: Gen TM) $ \m ->---  matrixInvariant m &&-  size m == sz--}---- | Constructs a matrix from a list of (index, value)-pairs.---- compareElt = (\ (i,_) (j,_) -> compare i j)--- normalize = filter (\ (i,b) -> b /= zeroElement)--fromIndexList :: (Ord i, HasZero b) => Size i -> [(MIx i, b)] -> Matrix i b-fromIndexList sz = M sz . List.sortBy (\ (i,_) (j,_) -> compare i j) . filter (\ (i,b) -> b /= zeroElement)--prop_fromIndexList :: TM -> Bool-prop_fromIndexList m = matrixInvariant m' && m' == m-  where vs = unM m-        m' = fromIndexList (size m) vs---- | @'fromLists' sz rs@ constructs a matrix from a list of lists of--- values (a list of rows).------ Precondition: @'length' rs '==' 'rows' sz '&&' 'all' (('==' 'cols' sz) . 'length') rs@.--fromLists :: (Ord i, Num i, Enum i, HasZero b) => Size i -> [[b]] -> Matrix i b-fromLists sz bs = fromIndexList sz $ -  List.zip ([ MIx i j | i <- [1..rows sz] , j <- [1..cols sz]]) (concat bs)---- | Converts a sparse matrix to a sparse list of rows--toSparseRows :: (Num i, Enum i, Eq i) => Matrix i b -> [(i,[(i,b)])]-toSparseRows m = aux 1 [] (unM m)-  where aux i' [] []  = []-        aux i' row [] = [(i', reverse row)]-        aux i' row ((MIx i j, b) : m)-            | i' == i   = aux i' ((j,b):row) m-            | otherwise = (i', reverse row) : aux i [(j,b)] m---- sparse vectors cannot have two entries in one column-blowUpSparseVec :: (Eq i, Ord i, Num i, Enum i, Show i) => b -> i -> [(i,b)] -> [b]-blowUpSparseVec zero n l = aux 1 l-  where aux i [] | i > n = []-                 | otherwise = zero : aux (i+1) []-        aux i ((j,b):l) | i <= n && j == i = b : aux (succ i) l-        aux i ((j,b):l) | i <= n && j >= i = zero : aux (succ i) ((j,b):l)-        aux i l = error $ "blowUpSparseVec (n = " ++ show n ++ ") aux i=" ++ show i ++ " j=" ++ show (fst (head l)) ++ " length l = " ++ show (length l)--- __IMPOSSIBLE__---- | Converts a matrix to a list of row lists.--toLists :: (Ord i, Integral i, Enum i, HasZero b, Show i) => Matrix i b -> [[b]]-toLists m = blowUpSparseVec emptyRow (rows sz) $-    map (\ (i,r) -> (i, blowUpSparseVec zeroElement (cols sz) r)) $ toSparseRows m---            [ [ maybe zeroElement id $ lookup (MIx { row = r, col = c }) (unM m)---            | c <- [1 .. cols sz] ] | r <- [1 .. rows sz] ]-  where sz = size m-        emptyRow = take (fromIntegral (cols sz)) $ repeat zeroElement--prop_fromLists_toLists :: TM -> Bool-prop_fromLists_toLists m = fromLists (size m) (toLists m) == m----------------------------------------------------------------------------- Combining and querying matrices---- | The size of a matrix.--{--size :: Ix i => Matrix i b -> Size i-size m = Size { rows = row b, cols = col b }-  where (_, b) = bounds $ unM m--}--prop_size :: TM -> Bool-prop_size m = sizeInvariant (size m)---prop_size_fromIndexList :: Size Int -> Bool-prop_size_fromIndexList sz =-  size (fromIndexList sz ([] :: [(MIx Int, Integer)])) == sz---- | 'True' iff the matrix is square.--square :: Ix i => Matrix i b -> Bool-square m = rows (size m) == cols (size m)---- | Returns 'True' iff the matrix is empty.--isEmpty :: (Num i, Ix i) => Matrix i b -> Bool-isEmpty m = rows sz <= 0 || cols sz <= 0-  where sz = size m---- | Returns 'Just b' iff it is a 1x1 matrix with just one entry 'b'.--isSingleton :: (Num i, Ix i, HasZero b) => Matrix i b -> Maybe b-isSingleton m = if (rows sz == 1 || cols sz == 1) then-    case unM m of-      [(_,b)] -> Just b-      []      -> Just zeroElement-  else Nothing-  where sz = size m---- | Transposition-transposeSize (Size { rows = n, cols = m }) = Size { rows = m, cols = n }-transpose m = M { size = transposeSize (size m)-                , unM  = List.sortBy (\ (i,a) (j,b) -> compare i j) $-                           map (\(MIx i j, b) -> (MIx j i, b)) $ unM m }--all :: (a -> Bool) -> Matrix i a -> Bool-all p m = List.all (\ (i,a) -> p a) (unM m)--any :: (a -> Bool) -> Matrix i a -> Bool-any p m = List.any (\ (i,a) -> p a) (unM m)---- | @'zip' m1 m2@ zips @m1@ and @m2@. ------ Precondition: @'size' m1 == 'size' m2@.--zip :: (Ord i, HasZero a) => Matrix i a -> Matrix i a -> Matrix i (a,a)-zip m1 m2 = M (size m1) $ zips (unM m1) (unM m2) where-  zips [] m = map (\ (i,b) -> (i,(zeroElement,b))) m-  zips l [] = map (\ (i,a) -> (i,(a,zeroElement))) l-  zips l@((i,a):l') m@((j,b):m')-    | i < j = (i,(a,zeroElement)) : zips l' m-    | i > j = (j,(zeroElement,b)) : zips l m'-    | otherwise = (i,(a,b)) : zips l' m'---- | @'add' (+) m1 m2@ adds @m1@ and @m2@. Uses @(+)@ to add values.------ Precondition: @'size' m1 == 'size' m2@.--add :: (Ord i) => (a -> a -> a) -> Matrix i a -> Matrix i a -> Matrix i a-add plus m1 m2 = M (size m1) $ mergeAssocWith plus (unM m1) (unM m2)---- | assoc list union-mergeAssocWith :: (Ord i) => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)]-mergeAssocWith f [] m = m-mergeAssocWith f l [] = l-mergeAssocWith f l@((i,a):l') m@((j,b):m')-    | i < j = (i,a) : mergeAssocWith f l' m-    | i > j = (j,b) : mergeAssocWith f l m'-    | otherwise = (i, f a b) : mergeAssocWith f l' m'---- | @'intersectWith' f m1 m2@ build the pointwise conjunction @m1@ and @m2@.---   Uses @f@ to combine non-zero values.------ Precondition: @'size' m1 == 'size' m2@.--intersectWith :: (Ord i) => (a -> a -> a) -> Matrix i a -> Matrix i a -> Matrix i a-intersectWith f m1 m2 = M (size m1) $ interAssocWith f (unM m1) (unM m2)---- | assoc list intersection-interAssocWith :: (Ord i) => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)]-interAssocWith f [] m = []-interAssocWith f l [] = []-interAssocWith f l@((i,a):l') m@((j,b):m')-    | i < j = interAssocWith f l' m-    | i > j = interAssocWith f l m'-    | otherwise = (i, f a b) : interAssocWith f l' m'--{--prop_add sz =-  forAll (three (matrix sz :: Gen TM)) $ \(m1, m2, m3) ->-    let m' = add (+) m1 m2 in-      associative (add (+)) m1 m2 m3 &&-      commutative (add (+)) m1 m2 &&-      matrixInvariant m' &&-      size m' == size m1--}---- | @'mul' semiring m1 m2@ multiplies @m1@ and @m2@. Uses the--- operations of the semiring @semiring@ to perform the--- multiplication.------ Precondition: @'cols' ('size' m1) == rows ('size' m2)@.--{- mul A B works as follows:-* turn A into a list of sparse rows and the transposed B as well-* form the crossproduct using the inner vector product to compute els-* the inner vector product is summing up-  after intersecting with the muliplication op of the semiring--}--mul :: (Enum i, Num i, Ix i, Eq a)-    => Semiring a -> Matrix i a -> Matrix i a -> Matrix i a-mul semiring m1 m2 = M (Size { rows = rows (size m1), cols = cols (size m2) }) $-  filter (\ (i,b) -> b /= Semiring.zero semiring) $-  [ (MIx i j, foldl (Semiring.add semiring) (Semiring.zero semiring) $-                map snd $ interAssocWith (Semiring.mul semiring) v w)-    | (i,v) <- toSparseRows m1-    , (j,w) <- toSparseRows $ transpose m2 ]--{--prop_mul sz =-  sized $ \n -> resize (n `div` 2) $-  forAll (two natural) $ \(c2, c3) ->-  forAll (matrix sz :: Gen TM) $ \m1 ->-  forAll (matrix (Size { rows = cols sz, cols = c2 })) $ \m2 ->-  forAll (matrix (Size { rows = c2, cols = c3 })) $ \m3 ->-    let m' = mult m1 m2 in-      associative mult m1 m2 m3 &&-      matrixInvariant m' &&-      size m' == Size { rows = rows sz, cols = c2 }-  where mult = mul Semiring.integerSemiring--}---- | @'diagonal' m@ extracts the diagonal of @m@.------ Precondition: @'square' m@.--diagonal :: (Enum i, Num i, Ix i, Show i, HasZero b) => Matrix i b -> [b]-diagonal m = blowUpSparseVec zeroElement (rows sz) $-  map (\ ((MIx i j),b) -> (i,b)) $ filter (\ ((MIx i j),b) -> i==j) (unM m)-  where sz = size m--{--diagonal :: (Enum i, Num i, Ix i, HasZero b) => Matrix i b -> Array i b-diagonal m = listArray (1, rows sz) $ blowUpSparseVec zeroElement (rows sz) $-  map (\ ((MIx i j),b) -> (i,b)) $ filter (\ ((MIx i j),b) -> i==j) (unM m)-  where sz = size m--}--{--prop_diagonal =-  forAll natural $ \n ->-  forAll (matrix (Size n n) :: Gen TM) $ \m ->-    bounds (diagonal m) == (1, n)--}----------------------------------------------------------------------------- Modifying matrices---- | @'addColumn' x m@ adds a new column to @m@, after the columns--- already existing in the matrix. All elements in the new column get--- set to @x@.--addColumn :: (Num i, HasZero b) => b -> Matrix i b -> Matrix i b-addColumn x m | x == zeroElement = m { size = (size m) { cols = cols (size m) + 1 }}---              | otherwise = __IMPOSSIBLE__--{--prop_addColumn :: TM -> Bool-prop_addColumn m =-  matrixInvariant m'-  &&-  map init (toLists m') == toLists m-  where-  m' = addColumn zeroElement m--}---- | @'addRow' x m@ adds a new row to @m@, after the rows already--- existing in the matrix. All elements in the new row get set to @x@.--addRow :: (Num i, HasZero b) => b -> Matrix i b -> Matrix i b-addRow x m | x == zeroElement = m { size = (size m) { rows = rows (size m) + 1 }}---           | otherwise = __IMPOSSIBLE__--prop_addRow :: TM -> Bool-prop_addRow m =-  matrixInvariant m'-  &&-  init (toLists m') == toLists m-  where-  m' = addRow zeroElement m----------------------------------------------------------------------------- Zipping (assumes non-empty matrices)--{- use mergeAssocList or interAssocList instead-zipWith :: (a -> b -> c) ->-           Matrix Integer a -> Matrix Integer b -> Matrix Integer c-zipWith f m1 m2-  = fromLists (Size { rows = toInteger $ length ll,-                      cols = toInteger $ length (head ll) }) ll-    where ll = List.zipWith (List.zipWith f) (toLists m1) (toLists m2)--}-
− TCM.hs 
@@ -1,1494 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, PatternGuards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, DeriveFoldable, DeriveTraversable, TupleSections #-}--module TCM where--import Prelude hiding (null)--import Control.Monad-import Control.Monad.Identity-import Control.Monad.State-import Control.Monad.Except-import Control.Monad.Reader--import Control.Applicative-import Data.Foldable (Foldable)-import qualified Data.Foldable as Foldable-import Data.Traversable (Traversable)-import qualified Data.Traversable as Traversable-import Data.Monoid--import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Maybe as Maybe--import Debug.Trace--import Abstract-import Polarity-import Value-import {-# SOURCE #-} Eval -- (up,whnf')-import PrettyTCM---- import CallStack-import TraceError--import TreeShapedOrder (TSO)-import qualified TreeShapedOrder as TSO--import Util--import Warshall---- traceSig msg a = trace msg a-traceSig msg a = a--traceRew msg a = a -- trace msg a-traceRewM msg = return () -- traceM msg-{--traceRew msg a = trace msg a-traceRewM msg = traceM msg--}---- metavariables and constraints--traceMeta msg a = a -- trace msg a-traceMetaM msg = return () -- traceM msg-{--traceMeta msg a = trace msg a-traceMetaM msg = traceM msg--}----- type checking monad -------------------------------------------------class (MonadCxt m, MonadSig m, MonadMeta m, MonadError TraceError m) =>-  MonadTCM m where----- lists of exactly one or two elements ---------------------------------- this would have been better implemented by just lists and a view---   type OneOrTwo a = [a]---   data View12 a = One a | Two a a---   fromList12--- then one could still get completeness of pattern matching!--- now we have lots of boilerplate code--data OneOrTwo a = One a | Two a a deriving (Eq, Ord, Functor, Foldable, Traversable)--instance Show a => Show (OneOrTwo a) where-  show (One a)   = show a-  show (Two a b) = show a ++ "||" ++ show b--name12 :: OneOrTwo Name -> Name-name12 (One n) = n-name12 (Two n1 n2)-  | null (suggestion n2) = n1-  | null (suggestion n1) = n2-  | suggestion n1 == suggestion n2 = n1-  | otherwise = fresh (suggestion n1 ++ "||" ++ suggestion n2)--{--instance Functor OneOrTwo where-  fmap f (One a)   = One (f a)-  fmap f (Two a b) = Two (f a) (f b)--instance Foldable OneOrTwo where-  foldMap f (One a) = f a-  foldMap f (Two a b) = f a `mappend` f b---- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)-instance Traversable OneOrTwo where-  traverse f (One a) = One <$> f a-  traverse f (Two a b) = Two <$> f a <*> f b--}---- eliminator-oneOrTwo :: (a -> b) -> (a -> a -> b) -> OneOrTwo a -> b-oneOrTwo f g (One a) = f a-oneOrTwo f g (Two a1 a2) = g a1 a2--fromOne :: OneOrTwo a -> a-fromOne (One a) = a--toTwo :: OneOrTwo a -> OneOrTwo a-toTwo = oneOrTwo (\ a -> Two a a) Two--first12 :: OneOrTwo a -> a-first12 (One a) = a-first12 (Two a1 a2) = a1--second12 :: OneOrTwo a -> a-second12 (One a) = a-second12 (Two a1 a2) = a2--mapSecond12 :: (a -> a) -> OneOrTwo a -> OneOrTwo a-mapSecond12 f (One a) = One (f a)-mapSecond12 f (Two a1 a2) = Two a1 (f a2)--zipWith12 :: (a -> b -> c) -> OneOrTwo a -> OneOrTwo b -> OneOrTwo c-zipWith12 f (One a) (One b) = One (f a b)-zipWith12 f (Two a a') (Two b b') = Two (f a b) (f a' b')--zipWith123 :: (a -> b -> c -> d) ->-              OneOrTwo a -> OneOrTwo b -> OneOrTwo c -> OneOrTwo d-zipWith123 f (One a) (One b) (One c) = One (f a b c)-zipWith123 f (Two a a') (Two b b') (Two c c') = Two (f a b c) (f a' b' c')--toList12 :: OneOrTwo a -> [a]-toList12 (One a) = [a]-toList12 (Two a1 a2) = [a1,a2]--fromList12 :: Show a => [a] -> OneOrTwo a-fromList12 [a]     = One a-fromList12 [a1,a2] = Two a1 a2-fromList12 l = error $ "fromList12 " ++ show l--toMaybe12 :: Show a => [a] -> Maybe (OneOrTwo a)-toMaybe12 []      = Nothing-toMaybe12 [a]     = Just $ One a-toMaybe12 [a1,a2] = Just $ Two a1 a2-toMaybe12 l = error $ "toMaybe12 " ++ show l----- reader monad for local environment--data TCContext = TCContext-  { context   :: SemCxt-  , renaming  :: Ren       -- assigning de Bruijn Levels to names-  , naming    :: Map Int Name  -- assigning names to de Bruijn levels---  , nameVariants :: Map Name Int -- how many variants of the name-  , environ   :: Env2-  , rewrites  :: Rewrites-  , sizeRels  :: TSO Int   -- relations of universal (rigid) size variables-                           -- collected from size patterns (x > y)-  , belowInfty:: [Int]     -- list of size variables < #-  , bounds    :: [Bound Val]  -- bound hyps that do not fit in sizeRels-  , consistencyCheck :: Bool -- ^ Do we need to check that new size relations are consistent with every valuation of the current @sizeRels@? [See ICFP 2013 paper]-  , checkingConType :: Bool  -- different PTS rules for constructor types (parametric function space!)-  , assertionHandling :: AssertionHandling -- recover from errors?-  , impredicative :: Bool       -- use impredicative PTS rules-  -- checking measured functions-  , funsTemplate :: Map Name (Kinded Fun) -- types of mutual funs with measures checking body-  , mutualFuns :: Map Name SigDef -- types of mutual funs while checking body-  , mutualCo :: Co                -- mutual block (co)recursive ?-  , mutualNames :: [Name] -- ^ The defined names of the current mutual block (and parents).-  , checkingMutualName :: Maybe DefId -- which body of a mutual block am I checking?-  , callStack :: [QName] -- ^ Used to avoid looping when going into recursive data definitions.-  }--instance Show TCContext where-    show ce = show (environ ce) ++ "; " ++ show (context ce)--emptyContext = TCContext-  { context  = cxtEmpty-  , renaming = Map.empty-  , naming   = Map.empty-  , environ  = emptyEnv-  , rewrites = emptyRewrites-  , sizeRels = TSO.empty-  , belowInfty = []-  , bounds   = []-  , consistencyCheck = False -- initially, no consistency check, turned on when entering rhs-  , checkingConType = False-  , assertionHandling = Failure  -- default is not to ignore any errors-  , impredicative = False-  , funsTemplate = Map.empty-  , mutualFuns = Map.empty-  , mutualCo = Ind-  , mutualNames = []-  , checkingMutualName = Nothing-  , callStack = []-  }---- state monad for global signature--data TCState = TCState-  { signature   :: Signature-  , metaVars    :: MetaVars-  , constraints :: Constraints-  , positivityGraph :: PositivityGraph-  -- , dots        :: Dots -- UNUSED-  }--type MetaVars = Map MVar MetaVar-emptyMetaVars = Map.empty--type MScope = [Name] -- ^ names of size variables which are in scope of mvar-data MetaVar = MetaVar-  { mscope   :: MScope-  , solution :: Maybe Val-  }--type PosConstrnt = Constrnt PPoly DefId ()-type PositivityGraph = [PosConstrnt]-emptyPosGraph = []---- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO))-type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO))--instance MonadAssert TypeCheck where-  assert b s = do-    h <- asks assertionHandling-    assert' h b s-  newAssertionHandling h = local ( \ ce -> ce { assertionHandling = h })--{- mtl-2 provides these instances--- TypeCheck is applicative since every monad is.--- I do not know why this ain't in the libraries...-instance Applicative TypeCheck where-  pure      = return-  mf <*> ma = mf >>= \ f -> ma >>= \ a -> pure (f a)--}--{- NOT NEEDED---- | Dotted constructors (the top one in the pattern).-type Dots = [(Dotted,Pattern)]--emptyDots = []--class LensDots a where-  getDots :: a -> Dots-  setDots :: Dots -> a -> a-  setDots = mapDots . const-  mapDots :: (Dots -> Dots) -> a -> a-  mapDots f a = setDots (f (getDots a)) a--instance LensDots TCState where-  getDots = dots-  setDots d st = st { dots = d }--newDotted :: Pattern -> TypeCheck Dotted-newDotted p = do-  d <- mkDotted True-  modify $ mapDots $ ((d,p):)-  return d--clearDots :: TypeCheck ()-clearDots = modify $ setDots emptyDots--openDots :: TypeCheck [Pattern]-openDots = map snd . filter (isDotted . fst) <$> gets dots--}---- rewriting rules -------------------------------------------------data Rewrite  = Rewrite { lhs :: Val,  rhs :: Val }-type Rewrites = [Rewrite]--emptyRewrites = []--instance Show Rewrite where-  show rr = show (lhs rr) ++ " --> " ++ show (rhs rr)--{- renaming --------------------------------------------------------  A renaming maps names to de Bruijn levels (= generic values).--}--type Ren = Map Name Int--type Env2 = Environ (OneOrTwo Val)--type Context a = Map Int a-type Context2 a = Context (OneOrTwo a)--{- context ---------------------------------------------------------A context maps generic values to their type value.--During type checking, named variables are mapped to-generic values via a renaming.  Thus, looking up the type of a-name involves first looking up the generic value, and then its type.---}--{---- data Domain = Domain { typ :: TVal, decor :: Dec }-data Domain = Domain { typ :: TVal, kind :: Class, decor :: Dec }--mapTyp :: (TVal -> TVal) -> Domain -> Domain-mapTyp f dom = dom { typ = f (typ dom) }--mapTypM :: Monad m => (TVal -> m TVal) -> Domain -> m Domain-mapTypM f dom = do-  t' <- f (typ dom)-  return $ dom { typ = t' }--instance Show Domain where-  show item = (if erased (decor item) then brackets else id) (show (typ item))--}---- During heterogeneous equality, a variable might have--- two different types, one on the left and one on the right.--- We implement this as Two tl tr.--data CxtE a = CxtEntry { domain :: a, upperDec :: UDec }-type CxtEntry  = CxtE (OneOrTwo Domain)-type CxtEntry1 = CxtE Domain--data SemCxt = SemCxt-  { len   :: Int-  , cxt   :: Context2 Domain  -- fixed part of context-  , upperDecs :: Context UDec -- the "should be below" decoration for each var.; this is updated by resurrection-  }-{- invariant: length (cxt delta) = length (upperDecs delta) = len-     cxt(i) = Two ... iff  upperDecs(i) = Two ...- -}--instance Show SemCxt where-  show delta =-    show $ zip (Map.elems (cxt delta))-               (Map.elems (upperDecs delta))-{--  show delta = show $ zip (-    zipWith3 (zipWith12 Domain)---    zipWith (\ entry dec -> fmap ((flip Domain) dec) entry)-      (Map.elems (cxt delta))-      (Map.elems (kinds delta))-      (Map.elems (decs delta))-    ) (Map.elems (upperDecs delta))--}-cxtEmpty = SemCxt-  { len = 0-  , cxt = Map.empty---  , kinds = Map.empty---  , decs = Map.empty-  , upperDecs = Map.empty-  }---- push a new type declaration on context-cxtPush' :: OneOrTwo Domain -> SemCxt -> SemCxt-cxtPush' entry delta =-  delta { len = k + 1-        , cxt  = Map.insert k entry (cxt delta)---        , cxt  = Map.insert k (fmap typ   entry) (cxt delta)---        , decs = Map.insert k (fmap decor entry) (decs delta)-        , upperDecs = Map.insert k defaultUpperDec (upperDecs delta)-        }-  where k = len delta-{--cxtPush' (tv12, dec) delta =-  delta { len = k + 1-        , cxt  = Map.insert k tv12 (cxt delta)-        , decs = Map.insert k dec (decs delta) }-  where k = len delta--}-{--cxtPush :: Dec -> TVal -> SemCxt -> (Int, SemCxt)-cxtPush dec v delta = (len delta, cxtPush' (One (Domain v dec)) delta)--- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta)--}--cxtPushEntry :: OneOrTwo Domain -> SemCxt -> (Int, SemCxt)-cxtPushEntry ce delta = (len delta, cxtPush' ce delta)--cxtPush :: Domain -> SemCxt -> (Int, SemCxt)-cxtPush dom delta = cxtPushEntry (One dom) delta--- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta)---- push a variable with a left and a right type-cxtPush2 :: Domain -> Domain -> SemCxt -> (Int, SemCxt)-cxtPush2 doml domr delta = cxtPushEntry (Two doml domr) delta---  (len delta, cxtPush' (Two doml domr) delta)--{---- push a variable with a left and a right type-cxtPush2 :: Dec -> TVal -> TVal -> SemCxt -> (Int, SemCxt)-cxtPush2 dec tvl tvr delta =-  (len delta, cxtPush' (Two tvl tvr, dec) delta)--}--cxtPushGen ::  Name -> SemCxt -> (Int, SemCxt)-cxtPushGen x delta = cxtPush bot delta-  where bot = error $ "IMPOSSIBLE: name " ++ show x ++ " is not bound to any type"---- only defined for single bindings-cxtSetType :: Int -> Domain -> SemCxt -> SemCxt-cxtSetType k dom delta =-  delta { cxt  = Map.insert k (One dom) (cxt delta)-        -- upperDecs need not be updated-        }---- | Version of 'Map.lookup' that throws 'TraceError'.-lookupM :: (MonadError TraceError m, Show k, Ord k) => k -> Map k v -> m v-lookupM k m = maybe (throwErrorMsg $ "lookupM: unbound key " ++ show k) return $ Map.lookup k m--cxtLookupGen :: MonadError TraceError m => SemCxt -> Int -> m CxtEntry-cxtLookupGen delta k = do-  dom12 <- lookupM k (cxt delta)-  udec  <- lookupM k (upperDecs delta)-  return $ CxtEntry dom12 udec--cxtLookupName :: MonadError TraceError m => SemCxt -> Ren -> Name -> m CxtEntry-cxtLookupName delta ren x = do-  i <- lookupM x ren-  cxtLookupGen delta i---- apply decoration, possibly resurrecting (see Pfenning, LICS 2001)--- and changing polarities (see Abel, MSCS 2008)-cxtApplyDec :: Dec -> SemCxt -> SemCxt-cxtApplyDec dec delta = delta { upperDecs = Map.map (compDec dec) (upperDecs delta) }--- cxtApplyDec dec delta =  delta { decs = Map.map (fmap $ invCompDec dec) (decs delta) }--{- RETIRED, use cxtApplyDec instead--- clear all "erased" flags (see Pfenning, LICS 2001)--- UPDATE: resurrection sets "target" status to erased---         (as opposed to setting "source" status to non-erased)-cxtResurrect :: SemCxt -> SemCxt-cxtResurrect delta = delta { upperDecs = Map.map (\ dec -> dec { erased = True}) (upperDecs delta) }--- cxtResurrect delta = delta { decs = Map.map (fmap resurrectDec) (decs delta) }--}---- manipulating the context --------------------------------------------{---- | Size decrements in bounded quantification do not count for termination-data LamPi-  = LamBind -- ^ add a lambda binding to the context-  | PiBind  -- ^ add a pi binding to the context--}--class Monad m => MonadCxt m where---  bind     :: Name -> Domain -> Val -> m a -> m a---  new performs eta-expansion "up" of new gen-  -- adding types (Two t1 t2) returns values (Two (Up t1 vi) (Up t2 vi))-  newVar     :: Name -> OneOrTwo Domain -> (Int -> OneOrTwo Val -> m a) -> m a-  newWithGen :: Name -> Domain -> (Int -> Val -> m a) -> m a-  newWithGen x d k = newVar x (One d)-    (\ i (One v) -> k i v)-  new2WithGen:: Name -> (Domain, Domain) -> (Int -> (Val, Val) -> m a) -> m a-  new2WithGen x (doml, domr) k = newVar x (Two doml domr)-    (\ i (Two vl vr) -> k i (vl, vr))-  new        :: Name -> Domain -> (Val -> m a) -> m a-  new x d cont = newWithGen x d (\ _ -> cont)-  new2       :: Name -> (Domain, Domain) -> ((Val, Val) -> m a) -> m a-  new2 x d cont = new2WithGen x d (\ _ -> cont)-{--  new2       :: Name -> (TVal, TVal, Dec) -> ((Val, Val) -> m a) -> m a-  new2 x d cont = new2WithGen x d (\ _ -> cont)--}-  new'       :: Name -> Domain -> m a -> m a-  new' x d cont = new x d (\ _ -> cont)-  newIrr     :: Name -> m a -> m a  -- only add binding x = VIrr to env-  addName    :: Name -> (Val -> m a) -> m a-{- RETIRED-  addTypeSigs :: [TySig TVal] -> m a -> m a-  addTypeSigs [] k = k-  addTypeSigs (TypeSig n tv : tss) k =-    new' n (defaultDomain tv) $ addTypeSigs tss k--}-  addKindedTypeSigs :: [Kinded (TySig TVal)] -> m a -> m a-  addKindedTypeSigs [] k = k-  addKindedTypeSigs (Kinded ki (TypeSig n tv) : ktss) k =-    new' n (Domain tv ki defaultDec) $ addKindedTypeSigs ktss k---  addName x = new x dontCare-  setType    :: Int -> Domain -> m a -> m a-  setTypeOfName :: Name -> Domain -> m a -> m a-  genOfName  :: Name -> m Int-  nameOfGen  :: Int -> m Name---  nameTaken  :: Name -> m Bool-  uniqueName :: Name -> Int -> m Name-  uniqueName x _ = return x -- $ freshen x -- TODO!  now freshen causes problems in extraction-{--  uniqueName x k = ifM (nameTaken x) (return $ show x ++ "~" ++ show k) (return x)--}-  lookupGen  :: Int -> m CxtEntry-  lookupGenType2 :: Int -> m (TVal, TVal)-  lookupGenType2 i = do-    entry <- lookupGen i-    case domain entry of-      One d1    -> return (typ d1, typ d1)-      Two d1 d2 -> return (typ d1, typ d2)-  lookupName :: Name -> m CxtEntry-  lookupName1 :: Name -> m CxtEntry1-  lookupName1 x = do-    e <- lookupName x-    return $ CxtEntry (fromOne (domain e)) (upperDec e)--  getContextTele :: m TeleVal  -- return context as telescope of type values-  getLen     :: m Int       -- return length of the context-  getEnv     :: m Env       -- return current environment-  getRen     :: m Ren       -- return current renaming-  applyDec   :: Dec -> m a -> m a  -- resurrect/adjust polarities-  resurrect  :: m a -> m a -- resurrect all erased variables in context-  resurrect = applyDec irrelevantDec-  addRewrite :: Rewrite -> [Val] -> ([Val] -> m a) -> m a-  addPattern :: TVal -> Pattern -> Env -> (TVal -> Val -> Env -> m a) -> m a -- step under pat-  addPatterns:: TVal -> [Pattern] -> Env -> (TVal -> [Val] -> Env -> m a) -> m a-  addSizeRel  :: Int -> Int -> Int -> m a -> m a-  addBelowInfty :: Int -> m a -> m a-  addBoundHyp :: Bound Val -> m a -> m a-  isBelowInfty :: Int -> m Bool-  sizeVarBelow :: Int -> Int -> m (Maybe Int)---  getSizeDiff :: Int -> Int -> m (Maybe Int)-  getMinSize  :: Int -> m (Maybe Int)-  getSizeVarsInScope :: m [Name]-  checkingCon :: Bool -> m a -> m a-  checkingDom :: m a -> m a  -- check domain A of Pi x:A.B (takes care of polarities)-  setCo :: Co -> m a -> m a -- entering a recursive or corecursive function?-  installFuns :: Co -> [Kinded Fun] -> m a -> m a-  setMeasure  :: Measure Val -> m a -> m a-  activateFuns :: m a -> m a -- create instance of mutually recursive functions bounded by measure-  goImpredicative :: m a -> m a-  checkingMutual :: Maybe DefId -> m a -> m a--dontCare = error "Internal error: tried to retrieve unassigned type of variable"--instance MonadCxt TypeCheck where--  newIrr x = local (\ ce -> ce { environ = update (environ ce) x (One VIrr) })--  -- UPDATE to 2?-  addName x f = enter ("new " ++ show x ++ " : _") $ do-    cxtenv <- ask-    let (k, delta) = cxtPushGen x (context cxtenv)-    let v = VGen k-    let rho = update (environ cxtenv) x (One v)-    x' <- uniqueName x k-    local (\ cxt -> cxt { context = delta-                        , renaming = Map.insert x k (renaming cxtenv)-                        , naming = Map.insert k x' (naming cxt)-                        , environ = rho }) (f v)---  newVar x dom12@(One (Domain (VBelow ltle v) ki dec)) f = do-    enter ("new " ++ show x ++ " " ++ show ltle ++ " " ++ show v) $ do-      cxtenv <- ask-      let (k, delta) = cxtPushEntry (One (Domain vSize kSize dec)) (context cxtenv)-      let xv  = VGen k-      let v12 = One xv-      let rho = update (environ cxtenv) x v12-      let beta = Bound ltle (Measure [xv]) (Measure [v])-      x' <- uniqueName x k-      local (\ cxt -> cxt { context = delta-                          , renaming = Map.insert x k (renaming cxtenv)-                          , naming = Map.insert k x' (naming cxtenv)-                          , environ = rho }) $-        addBoundHyp beta $ (f k v12)---  newVar x dom12 f = do-    let tv12 = fmap typ dom12-    enter ("new " ++ show x ++ " : " ++ show tv12) $ do-      cxtenv <- ask-      let (k, delta) = cxtPushEntry dom12 (context cxtenv)-      v12 <- Traversable.mapM (up False (VGen k)) tv12-      let rho = update (environ cxtenv) x v12-      x' <- uniqueName x k-      local (\ cxt -> cxt { context = delta-                          , renaming = Map.insert x k (renaming cxtenv)-                          , naming = Map.insert k x' (naming cxtenv)-                          , environ = rho }) (f k v12)-{--  newVar x (tv12, dec) f = enter ("new " ++ x ++ " : " ++ show tv12) $ do-    cxtenv <- ask-    let (k, delta) = cxtPushEntry (tv12, dec) (context cxtenv)-    v12 <- Traversable.mapM (up (VGen k)) tv12-    let rho = update (environ cxtenv) x v12-    local (\ cxt -> cxt { context = delta-                        , renaming = Map.insert x k (renaming cxtenv)-                        , environ = rho }) (f k v12)--}-  setType k dom =-    local (\ ce -> ce { context = cxtSetType k dom (context ce) })--  setTypeOfName x dom cont = do-    ce <- ask-    let Just k = Map.lookup x (renaming ce)-    setType k dom cont--  genOfName x = do-    ce <- ask-    case Map.lookup x (renaming ce) of-      Nothing -> throwErrorMsg $ "internal error: variable not bound: " ++ show x-      Just k -> return k--  nameOfGen k = do-    ce <- ask-    case Map.lookup k (naming ce) of-      Nothing -> return $ fresh $ "error_unnamed_gen" ++ show k-       -- throwErrorMsg $ "internal error: no name for variable " ++ show k-      Just x -> return x--{--  nameTaken "" = return True-  nameTaken x = do-    ce <- ask-    st <- get-    return (Map.member x (renaming ce) || Map.member x (signature st))--}--  lookupGen k = do-    ce <- ask-    cxtLookupGen (context ce) k--  lookupName x = do-    ce <- ask-    cxtLookupName (context ce) (renaming ce) x--  -- does not work with shadowing!-  getContextTele = do-    ce <- ask-    let cxt = context ce-    let ren = renaming ce-    let env = envMap $ environ ce-    let mkTBind (x,_) = (TBind x .fromOne . domain) <$> cxtLookupName cxt ren x-    mapM mkTBind env--  getLen = do-    ce <- ask-    return $ len (context ce)--  getRen = do-    ce <- ask-    return $ renaming ce--  -- since we only use getEnv during type checking, no case for Two-  -- (during equality/subtype checking, we have values)-  getEnv = do-    ce <- ask-    let (Environ rho mmeas) = environ ce-    return $ Environ (map (\ (x, One v) -> (x, v)) rho) mmeas--  applyDec dec = local (\ ce -> ce { context = cxtApplyDec dec (context ce) })---  applyDec dec = local (\ ce -> ce { upperDecs = Map.map (compDec dec) (upperDecs ce) })--  -- resurrection sets "target" status to erased-  -- (as opposed to setting "source" status to non-erased)-{--  resurrect = local (\ ce -> ce { upperDecs =-    Map.map (\ dec -> dec { erased = True }) (upperDecs ce) })--}-{--  resurrect = local (\ ce -> ce { context = cxtResurrect (context ce) })--}---  -- PROBABLY TOO INEFFICIENT-  addRewrite rew vs cont = traceRew ("adding rewrite " ++ show rew) $-    -- add rewriting rule-    local (\ cxt -> cxt { rewrites = rew : (rewrites cxt) }) $ do-      ce <- ask-      -- normalize all types in context-      traceRewM "normalizing types in context"-      cx' <- mapMapM (Traversable.mapM (Traversable.mapM reval)) (cxt (context ce))  -- LOOP!-      -- normalize environment-      traceRewM "normalizing environment"-      let Environ rho mmeas = environ ce-      rho' <- mapM (\ (x,v12) -> Traversable.mapM reval v12 >>= \ v12' -> return (x, v12')) rho-      let en' = Environ rho' mmeas -- no need to rewrite in measure since only size expressions-      -- normalize given values-      vs' <- mapM reval vs-      -- continue in updated context-      local (\ ce -> ce { context = (context ce) { cxt = cx' }-                        , environ = en' }) $ cont vs'--  -- addPattern :: TVal -> Pattern -> (TVal -> Val -> Env -> m a) -> m a-  addPattern tv@(VQuant Pi x dom fv) p rho cont =-       case p of-          VarP y -> underAbs y dom fv $ \ _ xv bv -> do-              cont bv xv (update rho y xv)--          SizeP e y -> underAbs y dom fv $ \ j xv bv -> do-              ve <- whnf' e-              addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $-                cont bv xv (update rho y xv)-{--          SizeP z y -> newWithGen y dom $ \ j xv -> do-              bv <- whnf (update env x xv) b-              VGen k <- whnf' (Var z)-              addSizeRel j 1 k $-                cont bv xv (update rho y xv)--}-          ConP pi n pl -> do-              sige <- lookupSymbQ n-              vc <- conLType n (typ dom)-              addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl?-                pv0 <- mkConVal notDotted (coPat pi) n vpl vc-                pv  <- up False pv0 (typ dom)-                vb  <- app fv pv-                cont vb pv rho-{--          ConP pi n pl -> do-              sige <- lookupSymb n-              let vc = symbTyp sige-              addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl?-                pv0 <- foldM app (vCon (coPat pi) n) vpl-                pv  <- up False pv0 (typ dom)-                vb  <- whnf (update env x pv) b-                cont vb pv rho--}-          SuccP p2 -> do-              addPattern (vSize `arrow` vSize) p2 rho $ \ _ vp2 rho -> do-                let pv = succSize vp2-                vb  <- app fv pv-                cont vb pv rho--          ErasedP p -> addPattern tv p rho cont---- for dot patterns, we have to do something smart, because they might--- contain identifiers which are not yet in scope, only after adding--- other patterns--- the following trivial solution only works for trivial dot patterns, i.e.,--- such that do not use yet undeclared identifiers--          DotP e -> do-              v  <- whnf rho e-              vb <- app fv v-              cont vb v rho -- [(x,v)]---  addPatterns tv [] rho cont = cont tv [] rho-  addPatterns tv (p:ps) rho cont =-    addPattern tv p rho $ \ tv' v env ->-      addPatterns tv' ps env $ \ tv'' vs env' ->-        cont tv'' (v:vs) env' -- (env' ++ env)--  addSizeRel son dist father k = do-    let s = "v" ++ show son ++ " + " ++ show dist ++ " <= v" ++ show father-    enter -- enterTrace-      ("adding size rel. " ++ s) $ do-    let modBI belowInfty = if father `elem` belowInfty || dist > 0 then son : belowInfty else belowInfty-    whenM (asks consistencyCheck `andLazy` do-           TSO.increasesHeight son (dist, father) <$> asks sizeRels) $ do-      recoverFail $ "cannot add hypothesis " ++ s ++ " because it is not satisfyable under all possible valuations of the current hypotheses"-    -- if the new son is an ancestor of the father, we are cyclic-    whenJustM (TSO.isAncestor father son <$> asks sizeRels) $ \ n -> -- n steps from father up to son-      when (dist > - n) $ -- still ok if dist == n == 0, otherwise fail-        recoverFail$ "cannot add hypothesis " ++ s ++ " because it makes the set of hyptheses unsatisfiable"-    local (\ cxt -> cxt-      { sizeRels = TSO.insert son (dist, father) (sizeRels cxt)-      , belowInfty = modBI (belowInfty cxt)-      }) k--  addBelowInfty i = local $ \ cxt -> cxt { belowInfty = i : belowInfty cxt }--  addBoundHyp beta@(Bound ltle (Measure mu) (Measure mu')) cont =-    case (ltle, mu, mu') of-      (Le, _, [VInfty]) -> cont---      (Lt, _, [VInfty]) -> failure  -- handle j < #-      (ltle, [v], [v']) -> loop (if ltle==Lt then 1 else 0) v v'-      _ -> failure-    where failure = do---            recoverFail $ "adding hypothetical constraint " ++ show beta ++ " not supported"-            assertDoc' Warning False (text "hypothetical constraint" <+> prettyTCM beta <+> text "ignored")-            cont--          loop n (VGen i) VInfty = addBelowInfty i cont-          loop n (VGen i) (VGen j) | n >= 0 = addSizeRel i n j cont-                                   | otherwise = addIrregularBound i j (-n) cont-          loop n (VSucc v) v' = loop (n + 1) v v'-          loop n v (VSucc v') = loop (n - 1) v v'-          loop _ _ _ = failure--          addIrregularBound i j n = local (\ ce -> ce { bounds = beta : bounds ce }) where-              v' = iterate VSucc (VGen j) !! n-              beta = Bound Le (Measure [VGen i]) (Measure [v'])--  isBelowInfty i = (i `elem`) <$> asks belowInfty--{--  isBelowInfty i = do-    belowInfty <- asks belowInfty-    if (i `elem` belowInfty) then return True else do-      tso <- asks sizeRels-      loop $ parents i tso where-        loop [] = return False-        loop [(_,j)] = return $ j `elem` belowInfty-        loop (x:xs)  = loop xs--}--  sizeVarBelow son ancestor = do-    cxt <- ask-    return $ TSO.isAncestor son ancestor (sizeRels cxt)-{--  getSizeDiff son ancestor = do-    cxt <- ask-    return $ TSO.diff son ancestor (sizeRels cxt)--}-  getMinSize parent = do-    cxt <- ask-    return $ TSO.height parent (sizeRels cxt)--  getSizeVarsInScope = do-    TCContext { context = delta, naming = nam } <- ask-    -- get all the size variables with positive or mixed polarity-    let fSize (i, tv12) =-          case tv12 of-            One dom -> isVSize $ typ dom-            _ -> -- trace ("not a size variable " ++ show i ++ " : " ++ show tv12) $-                   False-    -- create a list of key (gen) and Domain pairs for the size variables-    let idl = filter fSize $ Map.toAscList (cxt delta)-    let udecs = upperDecs delta-    let fPos (i, One dom) =-         case fromPProd (polarity (Maybe.fromJust (Map.lookup i udecs))) of-           Just p -> leqPol (polarity (decor dom)) p-           Nothing -> False-    let fName (i, _) = Maybe.fromJust $ Map.lookup i nam-    return $ map fName $ filter fPos idl---  checkingCon b = local (\ cxt -> cxt { checkingConType = b})--{--  checkingDom = local $ \ cxt ->-    if checkingConType cxt then cxt-     else cxt { context = cxtApplyDec (Dec False Neg) (context cxt) }--}-  -- check domain A of (x : A) -> B-  checkingDom k = do-    b <- asks checkingConType-    if b then k else applyDec (Dec Neg) k--  setCo co = local (\ cxt -> cxt { mutualCo = co })--  -- install functions for checking function clauses-  -- ==> use internal names-  installFuns co kfuns k = do-    let funt = foldl (\ m fun@(Kinded _ (Fun (TypeSig n _) n' _ _)) -> Map.insert n fun m)-                     Map.empty-                     kfuns-    local (\ cxt -> cxt { mutualCo = co, funsTemplate = funt }) k--  setMeasure mu k =  do-      rho0 <- getEnv-      let rho = rho0 { envBound = Just mu }-      local (\ cxt -> cxt-        { environ    = (environ cxt) { envBound = Just mu }-        }) k--  activateFuns k = do-      rho <- getEnv-      case (envBound rho) of-         Nothing -> k-         Just mu ->-           local (\ cxt -> cxt-             { mutualFuns =-                 Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt)-             }) k-    where boundFun :: Env -> Co -> Kinded Fun -> SigDef-          boundFun rho co (Kinded ki (Fun (TypeSig n t) n' ar cls)) =-            FunSig co (VClos rho t) ki ar cls False undefined--{--  activateFuns mu k = do-      rho0 <- getEnv-      let rho = rho0 { envBound = Just mu }-      local (\ cxt -> cxt-        { environ    = (environ cxt) { envBound = Just mu }-        , mutualFuns =-            Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt)-        }) k-    where boundFun :: Env -> Co -> Fun -> SigDef-          boundFun rho co (TypeSig n t, (ar, cls)) =-            FunSig co (VClos rho t) ar cls False- -}--  goImpredicative = local (\ cxt -> cxt { impredicative = True })--  checkingMutual mn = local (\ cxt -> cxt { checkingMutualName = mn })---- | Go into the codomain of a Pi-type or open an abstraction.-underAbs  :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a-underAbs x dom fv cont = newWithGen x dom $ \ i xv -> cont i xv =<< app fv xv---- | Do not check consistency preservation of context.-underAbs_  :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a-underAbs_ x dom fv cont = noConsistencyChecking $ underAbs x dom fv cont--noConsistencyChecking = local $ \ cxt -> cxt { consistencyCheck = False }---- | No eta, no hypotheses.  First returned val is a @VGen i@.-underAbs' :: Name -> FVal -> (Val -> Val -> TypeCheck a) -> TypeCheck a-underAbs' x fv cont = addName x $ \ xv -> cont xv =<< app fv xv---- addBind :: MonadTCM m => TBind -> m a -> m a-addBind :: TBind -> TypeCheck a -> TypeCheck a-addBind (TBind x dom) cont = do-  dom' <- (Traversable.mapM whnf' dom)-  new' x dom' cont--addBinds :: Telescope -> TypeCheck a -> TypeCheck a-addBinds tel k0 = foldr addBind k0 $ telescope tel---- introduce patterns into context and environment ---------------------- DOES NOT ETA-EXPAND VARIABLES!! -------------------------------------introPatterns :: [Pattern] -> TVal -> ([(Pattern,Val)] -> TVal -> TypeCheck a) -> TypeCheck a-introPatterns ps tv cont =                -- Problem: NO ETA EXPANSION!-  introPatVars ps $ do                    -- first bind pattern variables-    vs <- mapM (whnf' . patternToExpr) ps -- now we can evaluate patterns-    let pvs = zip ps vs-    introPatTypes pvs tv (cont pvs)       -- now we can assign types to pvars---- introduce variables bound in pattern into the environment--- extend delta by generic values but do not introduce their types--- this is to deal with dot patterns-introPatVar :: Pattern -> TypeCheck a -> TypeCheck a-introPatVar p cont =-    case p of-      VarP n -> addName n $ \ _ -> cont-      SizeP m n -> addName n $ \ _ -> cont-      ConP co n pl -> introPatVars pl cont-      PairP p1 p2 -> introPatVars [p1,p2] cont-      SuccP p -> introPatVar p cont-      ProjP{} -> cont-      DotP e -> cont-      AbsurdP -> cont-      ErasedP p -> introPatVar p cont--introPatVars :: [Pattern] -> TypeCheck a -> TypeCheck a-introPatVars [] cont = cont-introPatVars (p:ps) cont = introPatVar p $ introPatVars ps $ cont---- if the bindings name->gen are already in the environment--- we can now bind the gen to their types-introPatType :: (Pattern,Val) -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a-introPatType (p,v) tv cont = do-  case tv of-    VGuard beta bv -> addBoundHyp beta $ introPatType (p,v) bv cont-    VApp (VDef (DefId DatK d)) vl ->-      case p of-        ProjP n -> cont =<< projectType tv n VIrr -- no record value here-        _       -> throwErrorMsg $ "introPatType: internal error, expected projection pattern, found " ++ show p ++ " at type " ++ show tv-    VQuant Pi x dom fv -> do-       v  <- whnfClos v-       matchPatType (p,v) dom . cont =<< app fv v-    _ -> throwErrorMsg $ "introPatType: internal error, expected Pi-type, found " ++ show tv--introPatTypes :: [(Pattern,Val)] -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a-introPatTypes pvs tv f = do-  case pvs of-    [] -> f tv-    (pv:pvs') -> introPatType pv tv $ \ tv' -> introPatTypes pvs' tv' f--matchPatType :: (Pattern, Val) -> Domain -> TypeCheck a -> TypeCheck a-matchPatType (p,v) dom cont =-       case (p,v) of-                                                   -- erasure does not matter!-          (VarP y, VGen k) -> setType k dom $ cont--          (SizeP z y, VGen k) -> setType k dom $ cont--          (ConP co n [], _) -> cont--          (ConP co n pl, VApp (VDef (DefId ConK{} _)) vl) -> do-{--             sige <- lookupSymb n-             let vc = symbTyp sige--}-             vc <- conType n =<< force (typ dom)-             introPatTypes (zip pl vl) vc $ \ _ -> cont--          (SuccP p2, VSucc v2) -> matchPatType (p2, v2) (defaultDomain vSize) $ cont--          (PairP p1 p2, VPair v1 v2) -> do-             av <- force (typ dom)-             case av of-               VQuant Sigma x dom1@(Domain av1 ki dec) fv -> do-                 matchPatType (p1,v1) dom1 $ do-                   bv <- app fv v1-                   matchPatType (p2,v2) (Domain bv ki dec) cont-               _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show p ++ "  :  " ++ show dom--          (DotP e, _) -> cont-          (AbsurdP, _) -> cont-          (ErasedP p,_) -> matchPatType (p,v) dom cont-          _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show (p,v)----- Signature --------------------------------------------------------- input to and output of the type-checker--type Signature = Map QName SigDef---- a signature entry is either--- * a fun/cofun,--- * a defined constant,--- * a constructor, or--- * a data type id with its kind--- they share "symbTyp", the type signature of the definition-data SigDef-  = FunSig  { isCo          :: Co-            , symbTyp       :: TVal-            , symbolKind    :: Kind-            , arity         :: Arity-            , clauses       :: [Clause]-            , isTypeChecked :: Bool-            , extrTyp       :: Expr   -- ^ Fomega type.-            }-  | LetSig  { symbTyp       :: TVal-            , symbolKind    :: Kind-            , definingVal   :: Val---            , definingExpr  :: Expr-            , extrTyp       :: Expr   -- ^ Fomega type.-            }-  | PatSig  { patVars       :: [Name]-            , definingPat   :: Pattern-            , definingVal   :: Val-            }-  | ConSig  { conPars       :: ConPars-              -- ^ Parameter patterns and no. of variable they bind.-              --   @Nothing@ if old-style parameters.-            , lhsTyp        :: LHSType-              -- ^ LHS type of constructor for pattern matching, e.g.-   -- rhs @cons : [A : Set] [i : Size]         -> A -> List A i -> List A $i@-   -- lhs @cons : [A : Set] [i : Size] [j < i] -> A -> List A j -> List A i@-   -- @Name@ is the name of the size parameter.-            , recOccs       :: [Bool]-              -- ^ @True@ if argument contains rec.occs.of the (co)data type?-            , symbTyp       :: TVal   -- ^ (RHS) type, includs parameter tel.-            , dataName      :: Name   -- ^ Its datatype.-            , dataPars      :: Int    -- ^ No. of parameters of its datatype.-            , extrTyp       :: Expr   -- ^ Fomega type.-            }-  | DataSig { numPars       :: Int-            , positivity    :: [Pol]-            , isSized       :: Sized-            , isCo          :: Co-            , symbTyp       :: TVal-            , symbolKind    :: Kind-            -- the following information is only needed for eta-expansion-            -- hence it is only provided for suitable ind.fams.-            , constructors  :: [ConstructorInfo]-            , etaExpand     :: Bool -- non-overlapping pattern inductive family-                                    -- with at least one eta-expandable constructor-            , isTuple       :: Bool -- each constructor is irrefutable-                                    -- must be (NEW: non-overlapping) pattern inductive family-                                    -- qualifies for target of corecursive fun-                                    -- NO LONGER: exactly one constructor-                                    -- NOW: at least one constructor-                                    -- can be recursive-            , extrTyp       :: Expr -- Fomega kind-{--            , destructors   :: Maybe [Name] -- Nothing if not a record-            , isFamily      :: Bool--}-            } -- # parameters, positivity of parameters  , sized , co , type-              deriving (Show)---- | Parameter patterns and no. of variables they bind.-type ConPars = Maybe ([Name], [Pattern])---- | LHS type plus name of size index.-type LHSType = Maybe (Name, TVal)--isEmptyData :: QName -> TypeCheck Bool-isEmptyData n = do-  sig <- lookupSymbQ n-  case sig of-    DataSig { constructors } -> return $ null constructors-    _ -> throwErrorMsg $ "internal error: isEmptyData " ++ show n ++ ": name of data type expected"--isUnitData :: QName -> TypeCheck Bool-isUnitData n = do-  sig <- lookupSymbQ n-  case sig of-    DataSig { constructors = [c], isTuple } -> return $-      isTuple && null (cFields c) && cPatFam c == (LinearPatterns, [])-    DataSig { constructors } -> return False-    _ -> throwErrorMsg $ "internal error: isUnitData " ++ show n ++ ": name of data type expected"---undefinedFType :: QName -> Expr-undefinedFType n = Irr--- undefinedFType n = error $ "no extracted type for " ++ show n--symbKind :: SigDef -> Kind-symbKind ConSig{}  = kTerm          -- constructors are always terms-symbKind d         = symbolKind d   -- else: lookup-{- Data types can be big!!-symbKind DataSig{} = kType          -- data types are never universes--}--emptySig = Map.empty---- Handling constructor types  --------------------------------------------data DataView-  = Data Name [Clos]-  | NoData---- | Check if type @tv@ is a datatype @D vs@.-dataView :: TVal -> TypeCheck DataView-dataView tv = do-  tv <- force tv-  case tv of-{- 2012-01-31 EVIL, LEADS TO UNBOUND VARS:-    VQuant Pi x dom env b         -> do-      new x dom $ \ xv -> dataView =<< whnf (update env x xv) b--}-    VApp (VDef (DefId DatK n)) vs -> return $ Data (unqual n) vs-    VSing v dv                    -> dataView =<< whnfClos dv-    _                             -> return $ NoData---- | Disambiguate possibly overloaded constructor @c@ at given type @tv@.-disambigCon ::  QName -> TVal -> TypeCheck QName-disambigCon c tv =-  case c of-    Qual{}  -> return c-    QName n -> do-      dv <- dataView tv-      case dv of-        Data d _ -> return $ Qual d n-        _ -> throwErrorMsg $ "cannot resolve constructor " ++ show n---- | @conType c tv@ returns the type of constructor @c@ at datatype @tv@---   with parameters instantiated.-conType :: QName -> TVal -> TypeCheck TVal-conType c tv = do-  c <- disambigCon c tv-  ConSig { conPars, symbTyp, dataName, dataPars } <- lookupSymbQ c-  instConType c conPars symbTyp dataName dataPars tv---- | Get LHS type of constructor.------   Constructors or sized data types internally have a lhs type---   that differs from its rhs type.  E.g.,---   rhs @suc : [i : Size] -> Nat i -> Nat $i@---   lhs @suc : [i : Size] [j < i] -> Nat j -> Nat i@.---   In the lhs type, @i@ turns into an additional parameter.-conLType :: QName -> TVal -> TypeCheck TVal-conLType c tv = do-  c <- disambigCon c tv-  ConSig { conPars, lhsTyp, symbTyp, dataName, dataPars } <- lookupSymbQ c-  case lhsTyp of-    Nothing        -> instConType c conPars symbTyp dataName dataPars tv-    Just (x, lTyp) -> instConType c (fmap (inc x) conPars) lTyp dataName (dataPars+1) tv-  where inc x (xs, ps) = (xs ++ [x], ps ++ [VarP x])---- | Instantiate type of constructor to parameters obtained from---   the data type.------   @instConType c n symbTyp dataName tv@---   instantiates type @symbTyp@ of constructor @c@ with first @n@ arguments---   that @dataName@ is applied to in @tv@.---   @@---      instConType c n ((x1:A1..xn:An) -> B) d (d v1..vn ws) = B[vs/xs]---   @@-instConType :: QName -> ConPars -> TVal -> Name -> Int -> TVal -> TypeCheck TVal-instConType c conPars symbTyp dataName dataPars tv =-  instConLType' c conPars symbTyp Nothing (Just dataName) dataPars tv-{--instConType c numPars symbTyp dataName tv = do-  dv <- dataView tv-  case dv of-    NoData    -> failDoc (text ("conType " ++ show c ++ ": expected")-                   <+> prettyTCM tv <+> text "to be a data type")-    Data d vs -> do-      unless (d == dataName) $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show dataName-      let (pars, inds) = splitAt numPars vs-      unless (length pars == numPars) $-        failDoc (text ("conType " ++ show c ++ ": expected")-                   <+> prettyTCM tv-                   <+> text ("to be a data type applied to all of its " ++-                     show numPars ++ " parameters"))-      piApps symbTyp pars--}---- | Get correct lhs type for constructor pattern.------   @instConLType c numPars symbTyp Nothing isFlex tv@ behaves like---   @instConLType c numPars symbType _ tv@.------   But if the data types is sized and the constructor has a lhs type,---   @instConLType c numPars symbTyp (Just ltv) isFlex tv@---   uses the lhs type @ltv@ unless the variable instantiated for---   the size argument is flexible (because then it wants to be---   unified with the successor pattern of the rhs type.-instConLType :: QName -> ConPars -> TVal -> LHSType -> (Val -> Bool) -> Int -> TVal -> TypeCheck TVal-instConLType c conPars rhsTyp lhsTyp isFlex dataPars dataTyp =-  instConLType' c conPars rhsTyp (fmap (,isFlex) lhsTyp) Nothing dataPars dataTyp---- | The common pattern behind @instConType@ and @instConLType@.-instConLType' :: QName -> ConPars -> TVal -> Maybe ((Name, TVal), Val -> Bool) -> Maybe Name -> Int -> TVal -> TypeCheck TVal-instConLType' c conPars symbTyp isSized md dataPars tv =-  enter ("instConLType'") $ do-  let failure = failDoc (text ("conType " ++ show c ++ ": expected")-                   <+> prettyTCM tv-                   <+> text ("to be a data type applied to all of its " ++-                     show dataPars ++ " parameters"))-  dv <- dataView tv-  case dv of-    NoData    -> failDoc (text ("conType " ++ show c ++ ": expected")-                   <+> prettyTCM tv <+> text "to be a data type")-    Data d vs -> do-      whenJust md $ \ d' ->-        unless (d == d') $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show d'-      -- whenJust conPars $ throwErrorMsg $ "NYI: constructor with pattern parameters"-      let (pars, inds) = splitAt dataPars vs-      unless (length pars == dataPars) failure-      case (isSized, inds) of-        (Just _, []) -> failure-        -- if size index not flexible, use lhs type-        (Just ((x,ltv), isFlex), sizeInd:_) | not (isFlex sizeInd) ->-          continue d [x] ltv (pars ++ [sizeInd])-        -- otherwise, use rhs type-        _ -> continue d [] symbTyp pars-  where-    continue d ys tv pars = case conPars of-      Nothing      -> piApps tv pars-      Just (xs, ps) -> do-        let failure = failDoc $ sep-              [ text "instConType:"-              , text "cannot match parameters" <+> prettyList (map prettyTCM pars)-              , text "against patterns" <+> prettyList (map prettyTCM ps)-              , text "when instantiating type" <+> prettyTCM tv-              , text ("of constructor " ++ show c)-              ]-        -- clear dots here:-        mst <- nonLinMatchList' True True (emptyEnv, []) ps pars =<< lookupSymbTyp d-        case mst of-          Nothing  -> failure-          Just (Environ{ envMap = env0 }, psub) -> do-            let env = env0 ++ [ (x, VGen i) | (i, VarP x) <- psub ]-            -- if length env /= length xs then failure else do-            vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env-            piApps tv vs-{--        menv <- matchList emptyEnv ps pars-        case menv of-          Nothing  -> failure-          Just Environ{ envMap = env } -> if length env /= length xs then failure else do-            vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env-            piApps tv vs--}--{--      case isSized of-        Nothing  -> piApps symbTyp pars-        Just ltv -> do-          when (null inds) failure-          let sizeInd = head inds-          if isFlex sizeInd then piApps symbTyp pars else piApps ltv (pars ++ [sizeInd])--}---- Signature specification ---------------------------------------------class MonadCxt m => MonadSig m where-  lookupSymbTypQ :: QName -> m TVal-  lookupSymbQ    :: QName -> m SigDef-  addSigQ        :: QName -> SigDef -> m ()-  modifySigQ     :: QName -> (SigDef -> SigDef) -> m ()-  setExtrTypQ    :: QName -> Expr -> m ()--  lookupSymbTyp  :: Name -> m TVal-  lookupSymbTyp  = lookupSymbTypQ . QName--  lookupSymb     :: Name -> m SigDef-  lookupSymb     = lookupSymbQ . QName--  addSig         :: Name -> SigDef -> m ()-  addSig         = addSigQ . QName--  modifySig      :: Name -> (SigDef -> SigDef) -> m ()-  modifySig      = modifySigQ . QName--  setExtrTyp     :: Name -> Expr -> m ()-  setExtrTyp     = setExtrTypQ . QName---- Signature implementation --------------------------------------------instance MonadSig TypeCheck where--  -- first in context, then in signature-  -- lookupSymbTyp :: Name -> TypeCheck TVal-  lookupSymbTyp n = do-    mdom <- errorToMaybe $ lookupName1 n-    case mdom of-      Just (CxtEntry dom udec) -> return (typ dom)-      Nothing -> symbTyp <$> lookupSymb n--  lookupSymbTypQ (QName n) = lookupSymbTyp n-  lookupSymbTypQ n@Qual{}  = symbTyp <$> lookupSymbQ n--  -- lookupSymb :: Name -> TypeCheck SigDef-  lookupSymb n = do-    cxt <- ask-    case Map.lookup n (mutualFuns cxt) of-      Just k  -> return $ k-      Nothing -> lookupSymbInSig (QName n)--  lookupSymbQ (QName n) = lookupSymb n-  lookupSymbQ n@Qual{}  = lookupSymbInSig n--  -- addSig :: Name -> SigDef -> TypeCheck ()-  addSigQ n def = traceSig ("addSig: " ++ show n ++ " is bound to " ++ show def) $do-    st <- get-    put $ st { signature = Map.insert n def $ signature st }--  -- modifySig :: Name -> (SigDef -> SigDef) -> TypeCheck ()-  modifySigQ n f = do-    st <- get-    put $ st { signature = Map.adjust f n $ signature st }--  -- setExtrTyp :: Name -> Expr -> TypeCheck ()-  setExtrTypQ n t = modifySigQ n (\ d -> d { extrTyp = t })--lookupSymbInSig :: QName -> TypeCheck SigDef-lookupSymbInSig n = lookupSig n =<< gets signature-    where-      -- lookupSig :: Name -> Signature -> TypeCheck SigDef-      lookupSig n sig =-        case (Map.lookup n sig) of-          Nothing -> throwErrorMsg $ "identifier " ++ show n ++ " not in signature "  ++ show (Map.keys sig)-          Just k -> return k----- more on the type checking monad ---------------------------------initSt :: TCState-initSt = TCState emptySig emptyMetaVars emptyConstraints emptyPosGraph -- emptyDots--initWithSig :: Signature -> TCState-initWithSig sig = initSt { signature = sig }---- Meta-variable and constraint handling specification -----------------class Monad m => MonadMeta m where-  resetConstraints :: m ()-  mkConstraint     :: Val -> Val -> m (Maybe Constraint)-  addMeta          :: Ren -> MVar -> m ()-  addLeq           :: Val -> Val -> m ()--  addLe            :: LtLe -> Val -> Val -> m ()-  addLe Le v1 v2 = addLeq v1 v2-  addLe Lt v1 v2 = addLeq (succSize v1) v2 -- broken for #--  solveConstraints :: m Solution--  -- solve constraints and substitute solution into the analyzed expressions-  solveAndModify   :: [Expr] -> Env -> m [Expr]-  solveAndModify es rho = do-        sol <- solveConstraints-        let es' = map (subst (solToSubst sol rho)) es-        resetConstraints-        return es'---- Constraints implementation ------------------------------------------instance MonadMeta TypeCheck where--  --resetConstraints :: TypeCheck ()-  resetConstraints = do-    st <- get-    put $ st { constraints = emptyConstraints }--  -- mkConstraint :: Val -> Val -> TypeCheck (Maybe Constraint)-  mkConstraint v (VMax vs) = do-    bs <- mapM (errorToBool . leqSize' v) vs-    if any id bs then return Nothing else-     throwErrorMsg $ "cannot handle constraint " ++ show v ++ " <= " ++ show (VMax vs)-  mkConstraint w@(VMax vs) v = throwErrorMsg $ "cannot handle constraint " ++ show w ++ " <= " ++ show v-  mkConstraint (VMeta i rho n) (VMeta j rho' m) = retret $ arc (Flex i) (m-n) (Flex j)-  mkConstraint (VMeta i rho n) VInfty      = retret $ arc (Flex i) 0 (Rigid (RConst Infinite))-  mkConstraint (VMeta i rho n) v           = retret $ arc (Flex i) (m-n) (Rigid (RVar j))-    where (j,m) = vGenSuccs v 0-  mkConstraint VInfty (VMeta i rho n)      = retret $ arc (Rigid (RConst Infinite)) 0 (Flex i)-  mkConstraint v (VMeta j rho m)           = retret $ arc (Rigid (RVar i)) (m-n) (Flex j)-    where (i,n) = vGenSuccs v 0-  mkConstraint v1 v2 = throwErrorMsg $ "mkConstraint undefined for " ++ show (v1,v2)--  -- addMeta k x  adds a metavariable which can refer to VGens < k-  -- addMeta :: Ren -> MVar -> TypeCheck ()-  addMeta ren i = do-    scope <- getSizeVarsInScope-    traceMetaM ("addMeta " ++ show i ++ " scope " ++ show scope)-    st <- get-    put $ st { metaVars = Map.insert i (MetaVar scope Nothing) (metaVars st)-             , constraints = NewFlex i (\ k' -> True) -- k' < k)-            -- DO NOT ADD constraints of form <= infty !!-            --               : arc (Flex i) 0 (Rigid (RConst Infinite))-                           : constraints st }--  -- addLeq :: Val -> Val -> TypeCheck ()-  addLeq v1 v2 = traceMeta ("Constraint: " ++ show v1 ++ " <= " ++ show v2) $-    do mc <- mkConstraint v1 v2-       case mc of-         Nothing -> return ()-         Just c -> do-           st <- get-           put $ st { constraints = c : constraints st }--  -- solveConstraints :: TypeCheck Solution-  solveConstraints = do-    cs <- gets constraints-    if null cs then return emptySolution-     else case solve cs of-        Just subst -> traceMeta ("solution" ++ show subst) $-                      return subst-        Nothing    -> throwErrorMsg $ "size constraints " ++ show cs ++ " unsolvable"---nameOf :: EnvMap -> Int -> Maybe Name-nameOf [] j = Nothing-nameOf ((x,VGen i):rho) j | i == j = Just x-nameOf (_:rho) j = nameOf rho j--vGenSuccs (VGen k)  m = (k,m)-vGenSuccs (VSucc v) m = vGenSuccs v (m+1)-vGenSuccs v m = error $ "vGenSuccs fails on " ++ Util.parens (show v) ++ " " ++ show m--retret = return . return--sizeExprToExpr :: Env -> SizeExpr -> Expr-sizeExprToExpr rho (SizeConst Infinite) = Infty-sizeExprToExpr rho (SizeVar i n) | Just x <- nameOf (envMap rho) i = add (Var x) n-  where add e n | n <= 0 = e-                | otherwise = add (Succ e) (n-1)-sizeExprToExpr rho e@(SizeVar i n) | Nothing <- nameOf (envMap rho) i = error $ "panic: sizeExprToExpr " ++ Util.parens (show e) ++ ": variable v" ++ show i ++ " not in scope " ++ show (envMap rho)---maxExpr :: [Expr] -> Expr-maxExpr [] = Infty-maxExpr [e] = e-maxExpr l = if Infty `elem` l then Infty else Max l--solToSubst :: Solution -> Env -> Subst-solToSubst sol rho = Map.map (maxExpr . map (sizeExprToExpr rho)) sol---{--solToSubst :: Solution -> Env -> Subst-solToSubst sol rho = Map.foldWithKey step Map.empty sol-  where step k (SizeVar i n) sub | Just x <- nameOf rho i =-           Map.insert k (add (Var x) n) sub-        step k (SizeConst Infinite) sub = Map.insert k Infty sub-        step _ _ sub = sub--        add e n | n <= 0 = e-                | otherwise = add (Succ e) (n-1)--}---- pattern to Value ------------------------------------------------{- RETIRED-patternToVal :: Pattern -> TypeCheck Val-patternToVal p = do-  k <- getLen-  return $ fst (p2v k p)---- turn a pattern into a value--- dot patterns get variables corresponding to their flexible generic value-p2v :: Int -> Pattern -> (Val,Int)-p2v k p =-    case p of-      VarP n -> (VGen k,k+1)-      ConP co n [] -> (VCon co n,k)-      ConP co n pl -> let (vl,k') = ps2vs k pl-                      in (VApp (VCon co n) vl,k')-      SuccP p -> let (v,k') = p2v k p-                 in (VSucc v,k')-      DotP e -> (VGen k,k+1)--ps2vs :: Int -> [Pattern] -> ([Val],Int)-ps2vs k []  = ([],k)-ps2vs k (p:pl) = let (v,k') = p2v k p-                     (vl,k'') = ps2vs k' pl-                 in-                   (v:vl,k'')--}
− TCM.hs-boot 
@@ -1,17 +0,0 @@-module TCM where---- import CallStack-import TraceError--import Control.Monad.Identity-import Control.Monad.State-import Control.Monad.Except-import Control.Monad.Reader--data OneOrTwo a = One a | Two a a--data TCContext-data TCState---- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO))-type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO))
− Termination.hs 
@@ -1,896 +0,0 @@-{-# LANGUAGE ImplicitParams, PatternGuards #-}--module Termination where--import Prelude hiding (null)--import Data.Monoid-import Control.Monad.Writer -- (Writer, runWriter, tell, listen, Any(..), ...)--import Data.List as List hiding (null)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Foldable (Foldable, foldMap)-import qualified Data.Foldable as Foldable--import Debug.Trace----import System--import Abstract-import TraceError-import Util--import Semiring-import qualified SparseMatrix as M--import TreeShapedOrder (TSO)-import qualified TreeShapedOrder as TSO--traceTerm msg a = a -- trace msg a-traceTermM msg = return () -- traceM msg-{--traceTerm msg a = trace msg a-traceTermM msg = traceM msg--}---traceProg msg a =  a-traceProgM msg = return ()-{--traceProg msg a = trace msg a-traceProgM msg = traceM msg--}---- cutoff:  How far can we count?--- cutoff = 0 : decrease of -infty,0,1 (original SCT)--- cutoff = 1 : "           -infty,-1,0,1,2--- etc.--- this is a parameter to the termination checker--cutoff :: Int-cutoff = 2  -- we can trace descend of 3, ascend of 2---type Matrix a = M.Matrix Int a--empty :: Matrix a-empty = M.M (M.Size 0 0) []---- greater numbers shall mean more information for the term.checker.-data Order = Decr Int -- positive numbers: decrease, neg. numbers: increase-           | Un       -- infinite increase (- infty)-           | Mat (Matrix Order) -- square matrices only (rows = call arguments, cols = parameters of caller)-           deriving (Show,Eq,Ord)--instance HasZero Order where-  zeroElement = Un---- smart constructor-orderMat :: Matrix Order -> Order-orderMat m | M.isEmpty m                = Decr 0-           | Just o <- M.isSingleton m  = o-           | otherwise                  = Mat m-{--orderMat []    = Decr 0   -- 0x0 Matrix = neutral element-orderMat [[o]] = o        -- 1x1 Matrix-orderMat oss   = Mat oss  -- nxn Matrix--}---- smart constructor-decr :: (?cutoff :: Int) => Int -> Order-decr i | i < - ?cutoff = Un-       | i > ?cutoff  = Decr (?cutoff + 1)-       | otherwise   = Decr i---- present order in terms of <,<=,?-abstract :: Order -> Order-abstract (Decr k) | k > 0 = Decr 1-                  | k == 0 = Decr 0-                  | k < 0  = Un-abstract Un = Un-abstract (Mat m) = Mat $ absCM m--absCM :: Matrix Order -> Matrix Order-absCM = fmap abstract--- absCM = map (map abstract)---- the one is never needed for matrix multiplication-ordRing :: (?cutoff :: Int) => Semiring Order-ordRing = Semiring { add = maxO , mul = comp , zero = Un } -- , one = Decr 0 }---- composition = sequence of calls-comp :: (?cutoff :: Int) => Order -> Order -> Order-comp _ Un = Un-comp Un _ = Un-comp (Decr k) (Decr l) = decr (k + l)-comp (Mat m1) (Mat m2) = if (composable m1 m2) then-                             Mat $ M.mul ordRing m1 m2-                         else-                             comp (collapse m1) (collapse m2)-comp (Decr 0) (Mat m) = Mat m-comp (Mat m) (Decr 0) = Mat m-comp o (Mat m) = comp o (collapse m)-comp (Mat m) o = comp (collapse m) o--maxO :: (?cutoff :: Int) => Order -> Order -> Order-maxO o1 o2 = case (o1,o2) of-               (Un,_) -> o2-               (_,Un) -> o1-               (Decr k, Decr l) -> Decr (max k l) -- cutoff not needed-               (Mat m1, Mat m2) -> if (sameSize m1 m2) then-                                       Mat $ M.add maxO m1 m2-                                   else-                                       maxO (collapse m1) (collapse m2)-               (Mat m1,_) -> maxO (collapse m1) o2-               (_,Mat m2) -> maxO o1 (collapse m2)--minO :: (?cutoff :: Int) => Order -> Order -> Order-minO o1 o2 = case (o1,o2) of-               (Un,_) -> Un-               (_,Un) -> Un-               (Decr k, Decr l) -> decr (min k l)-               (Mat m1, Mat m2) -> if (sameSize m1 m2) then-                                       Mat $ minM m1 m2-                                   else-                                       minO (collapse m1) (collapse m2)-               (Mat m1,_) -> minO (collapse m1) o2-               (_,Mat m2) -> minO o1 (collapse m2)--{---- for non empty lists:-minimumO :: (?cutoff :: Int) => [Order] -> Order-minimumO = foldl1 minO--}---- | pointwise minimum-minM :: (?cutoff :: Int) => Matrix Order -> Matrix Order -> Matrix Order-minM = M.intersectWith minO-{--minM m1 m2 = [ minV x y | (x,y) <- zip m1 m2]- where-   minV :: Vector Order -> Vector Order -> Vector Order-   minV v1 v2 = [ minO x y | (x,y) <- zip v1 v2]--}--maxL :: (?cutoff :: Int) => [Order] -> Order-maxL = foldl1 maxO--minL :: (?cutoff :: Int) => [Order] -> Order-minL = foldl1 minO--{- collapse m--We assume that m codes a permutation:  each row has at most one column-that is not Un.--To collapse a matrix into a single value, we take the best value of-each column and multiply them.  That means if one column is all Un,-i.e., no argument relates to that parameter, than the collapsed value-is also Un.--This makes order multiplication associative.---collapse :: (?cutoff :: Int) => Matrix Order -> Order-collapse m = foldl1 comp (map maxL (M.transpose m))---}---{- collapse m--We assume that m codes a permutation:  each row has at most one column-that is not Un.--To collapse a matrix into a single value, we take the best value of-each column and multiply them.  That means if one column is all Un,-i.e., no argument relates to that parameter, than the collapsed value-is also Un.--This makes order multiplication associative.---}-collapse :: (?cutoff :: Int) => Matrix Order -> Order-collapse m = case M.toLists (M.transpose m) of---   [] -> __IMPOSSIBLE__   -- This can never happen if order matrices are generated by the smart constructor-   m' -> foldl1 comp $ map (foldl1 maxO) m'----type Vector a = [a]-type NaiveMatrix a = [Vector a]-------- matrix stuff--{--data Semiring a = Semiring { add :: (a -> a -> a) , mul :: (a -> a -> a) , one :: a , zero :: a }--}--ssum :: Semiring a -> Vector a -> a-ssum sem v = foldl (add sem) (zero sem) v--vadd :: Semiring a -> Vector a -> Vector a -> Vector a-vadd sem v1 v2 = [ (add sem) x y | (x,y) <- zip v1 v2]--scalarProdukt :: Semiring a -> Vector a -> Vector a -> a-scalarProdukt sem xs ys = ssum sem [(mul sem) x y  | (x,y) <- zip xs ys]--madd :: Semiring a -> NaiveMatrix a -> NaiveMatrix a -> NaiveMatrix a-madd sem m1 m2 = [ vadd sem x y | (x,y) <- zip m1 m2]--transp :: NaiveMatrix a -> NaiveMatrix a-transp [] = []-transp y = [[ z!!j | z<-y] | j<-[0..s]]-    where-    s = length (head y)-1--mmul :: Show a => Semiring a -> NaiveMatrix a -> NaiveMatrix a -> NaiveMatrix a-mmul sem m1 m2 = let m =-                         [[scalarProdukt sem r c | c <- transp m2] | r<-m1 ]-                 in m-diag :: NaiveMatrix a -> Vector a-diag [] = []-diag m = [ (m !! j) !! j | j <- [ 0..s] ]-   where-     s = length (head m) - 1--elems :: NaiveMatrix a -> Vector a-elems m = concat m--{--ok :: Matrix a -> Matrix a -> Bool-ok m1 m2 = (length m1) == length m2--}--sameSize :: Matrix a -> Matrix a -> Bool-sameSize m1 m2 = M.size m1 == M.size m2--composable :: Matrix a -> Matrix a -> Bool-composable m1 m2 = M.rows (M.size m1) == M.cols (M.size m2)--------- create a call matrix--- each row is for one argument  of the callee--- each column for one parameter of the caller-compareArgs :: (?cutoff :: Int) => TSO Name -> [Pattern] -> [Expr] -> Arity -> Matrix Order-compareArgs tso _ [] _ = empty-compareArgs tso [] _ _ = empty-compareArgs tso pl el ar_g =-  M.fromLists (M.Size { M.rows = fullArity ar_g , M.cols = length pl }) $-    map (\ e -> map (\ p -> --traceTerm ("comparing " ++ show e ++ " to " ++ show p) $-                                    compareExpr tso e p) pl) el-{--compareArgs tso pl el ar_g =-        let-            diff = ar_g - length el-            fill = if diff > 0 then-                       replicate diff (replicate (length pl) Un)-                   else []-            cmp = map (\ e -> (map (\ p -> --traceTerm ("comparing " ++ show e ++ " to " ++ show p) $-                                    compareExpr tso e p) pl)) el-        in-          cmp ++ fill--}--{--compareExpr :: (?cutoff :: Int) => Expr -> Pattern -> Order-compareExpr e p =-   case (e,p) of-      (_,UnusableP _) -> Un-      (_,DotP e') -> case exprToPattern e' of-                       Nothing -> if e == e' then Decr 0 else Un-                       Just p' -> compareExpr e p'-      (Var i,p) -> traceTerm ("compareVar " ++ show i ++ " " ++ show p) $ compareVar i p-      (App (Var i) _,p) -> compareVar i p-      (Con _ n1,ConP _ n2 [])  | n1 == n2 -> Decr 0-      (App (Con _ n1) [e1],ConP _ n2 [p1]) | n1 == n2 -> compareExpr e1 p1-      (App (Con _ n1) args,ConP _ n2 pl) | n1 == n2 && length args == length pl ->-              Mat (map (\ e -> (map (compareExpr e) pl)) args)-              -- without extended order :  minL $ zipWith compareExpr args pl-      (Succ e2,SuccP p2) -> compareExpr e2 p2-      -- new cases for counting constructors-      (Succ e2,p) -> Decr (-1) `comp` compareExpr e2 p-      (App (Con _ n1) args@(_:_), p) -> Decr (-1) `comp` minL (map (\e -> compareExpr e p) args)-      _ -> Un--}----compareExpr :: (?cutoff :: Int) => TSO Name -> Expr -> Pattern -> Order-compareExpr tso e p =-  let ret o = traceTerm ("comparing expression " ++ show e ++ " to pattern " ++ show p ++ " returns " ++ show o) o in-    ret $ compareExpr' tso e p--compareExpr' :: (?cutoff :: Int) => TSO Name -> Expr -> Pattern -> Order-compareExpr' tso (Ann e) p = compareExpr' tso (unTag e) p-compareExpr' tso e p =-   case (conView $ spineView e, p) of-      (_,UnusableP _) -> Un---      (Erased e,_)    -> compareExpr' tso e p-      (_,ErasedP p)   -> compareExpr' tso e p-      (_,DotP e') -> case exprToPattern e' of-                       Nothing ->  if e == e' then Decr 0 else Un-                       Just p' -> compareExpr' tso e p'-      ((Var i,_), p) -> -- traceTerm ("compareVar " ++ show i ++ " " ++ show p) $-                         compareVar tso i p---      (Con _ n1,ConP _ n2 [])  | n1 == n2 -> Decr 0---      (App (Con _ n1) [e1],ConP _ n2 [p1]) | n1 == n2 -> compareExpr' tso e1 p1-      ((Def (DefId (ConK _) n1),args),ConP _ n2 pl) | n1 == n2 && length args == length pl ->-          let os = zipWith (compareExpr' tso) args pl-          in  trace ("compareExpr (con/con case): os = " ++ show os) $-              if null os then Decr 0 else minL os-{- 2011-12-16 deactivate structured (matrix) orders-          orderMat $-            M.fromLists (M.Size { M.rows = length args, M.cols = length pl }) $-               map (\ e -> map (compareExpr' tso e) pl) args-              -- without extended order :  minL $ zipWith compareExpr' tso args pl--}-      ((Succ e2,_),SuccP p2) ->  compareExpr' tso e2 p2-      -- new cases for counting constructors-      ((Succ e2,_),p) ->  Decr (-1) `comp` compareExpr' tso e2 p-      ((Def (DefId (ConK Cons) n1),args@(_:_)), p) ->  Decr (-1) `comp` minL (map (\e -> compareExpr' tso e p) args)-      ((Proj Post n1,[]), ProjP n2) | n1 == n2 -> Decr 0-      _ -> Un--conView (Record (NamedRec co n _ _) rs, es) = (Def (DefId (ConK co) n), map snd rs ++ es)-conView p = p--compareVar :: (?cutoff :: Int) => TSO Name -> Name -> Pattern -> Order-compareVar tso n p =-  let ret o = o in -- traceTerm ("comparing variable " ++ n ++ " to " ++ show p ++ " returns " ++ show o) o in-    case p of-      UnusableP _ -> ret Un-      ErasedP p   -> compareVar tso n p-      VarP n2 -> if n == n2 then Decr 0 else-        case TSO.diff n n2 tso of -- if n2 is the k-th father of n, then it is a decrease by k-          Nothing -> ret Un-          Just k -> ret $ decr k-      SizeP n1 n2 -> if n == n2 then Decr 0 else-        case TSO.diff n n2 tso of -- if n2 is the k-th father of n, then it is a decrease by k-          Nothing -> ret Un-          Just k -> ret $ decr k-      PairP p1 p2 -> maxL (map (compareVar tso n) [p1,p2])-         -- no decrease in pair:  ALT: comp (Decr 1) (...)-      ConP pi c (p:pl) | coPat pi == Cons ->-        comp (Decr 1) (maxL (map (compareVar tso n) (p:pl)))-      ConP{}   -> ret Un-      ProjP{}  -> ret Un-      SuccP p2 -> comp (Decr 1) (compareVar tso n p2)-      DotP e -> case (exprToPattern e) of-                    Nothing -> ret $ Un-                    Just p' -> compareVar tso n p'-      _ -> error $ "NYI: compareVar " ++ show n ++ " to " ++ show p -- ret $ Un-------type Index = Name--data Call = Call { source :: Index , target :: Index , matrix :: CallMatrix }-            deriving (Eq,Show,Ord)---- call matrix:--- each row is for one argument  of the callee (target)--- each column for one parameter of the caller (source)--type CallMatrix = Matrix Order---- for two matrices m m' of the same dimensions,--- m `subsumes` m'  if  pointwise the entries of m are smaller than of m'-subsumes :: Matrix Order -> Matrix Order -> Bool-subsumes m m' = M.all (uncurry leq) mm'-  where mm' = M.zip m m' -- create one matrix of pairs-{--subsumes m m' = all (all (uncurry leq)) mm'-  where mm' = zipWith zip m m' -- create one matrix of pairs--}---- Order forms itself a partial order-leq :: Order -> Order -> Bool-leq Un _ = True-leq (Decr k) (Decr l) = k <= l-leq (Mat m) (Mat m') = subsumes m m'-leq _ _ = False---- for two matrices m m' such that m `subsumes` m'--- m `progress` m'  any positive entry in m' is smaller in m-progress :: Matrix Order -> Matrix Order -> Bool-progress m m' = M.any (uncurry decrToward0) mm'-  where mm' = M.zip m m' -- create one matrix of pairs-{--progress m m' = any (any (uncurry decrToward0)) mm'-  where mm' = zipWith zip m m' -- create one matrix of pairs--}--decrToward0 :: Order -> Order -> Bool-decrToward0 Un (Decr l) = True && l >= 0-decrToward0 (Decr k) (Decr l) = k < l  && l >= 0-decrToward0 (Mat m) (Mat m') = progress m m'-decrToward0 _ _ = False---{- call pathes--  are lists of names of length >=2--  [f,g,h] = f --> g --> h--}--newtype CallPath = CallPath { getCallPath :: [Name] } deriving Eq--instance Show CallPath where-  show (CallPath [g]) = show g-  show (CallPath (f:l)) = show f ++ "-->" ++ show (CallPath l)--emptyCP :: CallPath-emptyCP = CallPath []--mkCP :: Name -> Name -> CallPath-mkCP src tgt = CallPath [src, tgt]--mulCP :: CallPath -> CallPath -> CallPath-mulCP cp1@(CallPath one) cp2@(CallPath (g:two)) =-  if last one == g then CallPath (one ++ two)-  else error ("internal error: Termination.mulCP: trying to compose callpath " ++ show cp1 ++ " with " ++ show cp2)--compatibleCP :: CallPath -> CallPath -> Bool-compatibleCP (CallPath one) (CallPath two) = head one == head two && last one == last two--{--addCP :: CallPath -> CallPath -> CallPath-addCP (CallPath []) cp = cp-addCP cp (CallPath []) = cp-addCP cp1 cp2 = if cp1 == cp2 then cp1 else error ("internal error: Termination.addCP: trying to blend non-equal callpathes " ++ show cp1 ++ " and " ++ show cp2)--cpRing :: Semiring CallPath-cpRing = Semiring { add = addCP , mul = mulCP , one = undefined , zero = emptyCP }--}---- composed calls--type CompCall = (CallPath, CallMatrix)--mulCC :: (?cutoff :: Int) => CompCall -> CompCall -> CompCall-mulCC cc1@(cp1, m1) cc2@(cp2, m2) = zipPair mulCP (flip (M.mul ordRing)) cc1 cc2--subsumesCC :: CompCall -> CompCall -> Bool-subsumesCC cc1@(cp1, m1) cc2@(cp2, m2) =-  if compatibleCP cp1 cp2 then m1 `subsumes` m2-   else error ("internal error: Termination.subsumesCC: trying to compare composed call " ++ show cc2 ++ " with " ++ show cc1)--progressCC :: CompCall -> CompCall -> Bool-progressCC cc1@(cp1, m1) cc2@(cp2, m2) = progress m1 m2---{- call graph completion--organize call graph as a square matrix--  Name * Name -> Set CallMatrix--the completion process finds new calls by composing old calls.-There are two qualities of new calls.--  1) a completely new call or a call matrix in which one cell-     progressed from (Decr k | k > 0) towards -infty, i.e. a positive-     entry got smaller--  2) a negative entry got smaller--As long as 1-calls are found, continue completion.-[ I think 2-calls can be ignored when deciding whether to cont. ]-- -}---- sets of call matrices--type CMSet    = [CompCall]  -- normal form: no CM subsumes another--cmRing :: (?cutoff :: Int) => Semiring CMSet-cmRing = Semiring { add = unionCMSet , mul = mulCMSet , zero = [] } -- one = undefined ,--type Progress = Writer Any-type ProgressH = Writer (Any, Any)--firstHalf = (Any True, Any False)-secondHalf = (Any False, Any True)---- fullProgress = Sum 2--- halfProgress = Sum 1---- we keep CMSets always in normal form--- progress reported if m is "better" than one of ms--- progress can only be reported if m is being added, i.e., not subsumed-addCMh :: CompCall -> CMSet -> ProgressH CMSet-addCMh m [] = traceProg ("adding new call " ++ show m) $ do-  tell firstHalf-  return $ [m]-addCMh m (m':ms) =-  if m' `subsumesCC` m then traceTerm ("discarding new call " ++ show m) $-     return $ m':ms -- terminate early-   else do (ms', (Any h1, Any h2)) <- listen $ addCMh m ms-           when (h1 && not h2 && m `progressCC` m') $ do-             traceProgM ("progress made by " ++ show m ++ " over " ++ show m')-             tell secondHalf -- $ Any True-           if m `subsumesCC` m' then traceTerm ("discarding old call " ++ show m') $-                 return ms'-            else return $ m' : ms'--addCM' :: CompCall -> CMSet -> Progress CMSet-addCM' m ms = mapWriter (\(ms, (Any h1, Any h2)) -> (ms, Any $ h1 && h2)) (addCMh m ms)---- progress is reported if one of ms is "better" than ms'--- or if the oldset was empty and is no longer--- unionCMSet' addition oldset-unionCMSet' :: CMSet -> CMSet -> Progress CMSet-unionCMSet' [] []  = return []-unionCMSet' ms []  = tell (Any True) >> return ms-unionCMSet' ms ms' = foldM (flip addCM') ms' ms---- non-monadic versions-addCM :: CompCall -> CMSet -> CMSet-addCM m ms = fst $ runWriter (addCM' m ms)--unionCMSet :: CMSet -> CMSet -> CMSet-unionCMSet ms ms' = fst $ runWriter (unionCMSet' ms ms')--mulCMSet :: (?cutoff :: Int) => CMSet -> CMSet -> CMSet-mulCMSet ms ms' = foldl (flip addCM) [] $ [ mulCC m m' | m <- ms, m' <- ms' ]--{- call graph entries--type CGEntry = (CallPath, CMSet)--cgeRing :: Semiring CGEntry-cgeRing = Semiring { add = zipPair addCP unionCMSet,-                     mul = zipPair mulCP mulCMSet,-                     one = undefined,-                     zero = (emptyCP, []) }--addCGEntry' :: CGEntry -> CGEntry -> Progress CGEntry-addCGEntry' (cp1, ms1) (cp2, ms2) = do-  let cp = addCP cp1 cp2-  traceTermM ("call")-  ms <- unionCMSet' ms1 ms2-  return $ (cp, ms)--}---- call graphs--type CallGraph = NaiveMatrix CMSet -- CGEntry--stepCG :: (?cutoff :: Int) => CallGraph -> Progress CallGraph-stepCG cg = do-  traceProgM ("next iteration")-  traceProgM ("old cg " ++ show cg)-  traceProgM ("composed calls " ++ show cg')-  traceProgM ("adding new calls to callgraph...")-  zipWithM (zipWithM unionCMSet') cg' cg-  where cg' = mmul cmRing cg cg--{- "each idempotent call f->f has a decreasing arg" is an invariant-   of good call graphs.  Thus, we can stop call graph completion-   as soon as we see it violated.--   "idempotent" is defined on abstracted call matrices, i.e.,-   those that only have <, <=, ? and are not counting.- -}-complCGraph :: (?cutoff :: Int) => CallGraph -> CallGraph-complCGraph cg =-  let (cg', Any prog) = runWriter $ stepCG cg-  in  if prog && checkAll cg' then complCGraph cg' else cg'--checkAll :: (?cutoff :: Int) => CallGraph -> Bool-checkAll cg = all (all (checkIdem . snd)) $ diag cg---- each idempotent call needs a decreasing diagonal entry-checkIdem :: (?cutoff :: Int) => CallMatrix -> Bool-checkIdem cm =-  let cm'   = M.mul ordRing cm cm-      eqAbs = (absCM cm) == (absCM cm')-      d     = M.diagonal cm-  in  traceTerm ("checkIdem: cm = " ++ show cm ++ " cm' = " ++ show cm ++ " eqAbs = " ++ show eqAbs ++ " d = " ++ show d) $-      -- if cm `subsumes` cm'-      if eqAbs-       then any isDecr d else True--{- generate a call graph from a list of names and list of calls-1. group calls by source, obtaining a list of row--}--{- THIS IS WRONG:-makeCG :: [Name] -> [Call] -> CallGraph-makeCG names calls = map (\ tgt -> mkRow tgt [ c | c <- calls, target c == tgt ]) names-  where mkRow tgt calls = map (\ src ->  unionCMSet [ (mkCP src tgt, matrix c) | c <- calls, source c == src ] []) names--}--makeCG :: [Name] -> [Call] -> CallGraph-makeCG names calls = map (\ src -> mkRow src [ c | c <- calls, source c == src ]) names-  where mkRow src calls = map (\ tgt ->  unionCMSet [ (mkCP src tgt, matrix c) | c <- calls, target c == tgt ] []) names--{--callComb :: Call -> Call -> Call-callComb (Call s1 t1 m1) (Call s2 t2 m2) = Call s2 t1 (mmul ordRing m1 m2)--cgComb :: [Call] -> [Call] -> [Call]-cgComb cg1 cg2 = [ callComb c1 c2 | c1 <- cg1 , c2 <- cg2 , (source c1 == target c2)]--complete :: [Call] -> [Call]-complete cg = traceTerm ("call graph: " ++ show cg) $-  let cg' = complete' cg -- $ Set.fromList cg-  in -- traceTerm ("complete " ++ show cg')-       cg' -- Set.toList cg'--complete' :: [Call] -> [Call]  -- Set Call -> Set Call-complete' cg =-              let cgs = Set.fromList cg-                  cgs' = Set.union cgs (Set.fromList $ cgComb cg cg )-                  cg' = Set.toList cgs'-              in-                if (cgs == cgs') then cg else complete' cg'--checkAll :: [Call] -> Bool-checkAll x = all checkIdem x---- each idempotent call needs a decreasing diagonal entry-checkIdem :: Call -> Bool-checkIdem c = let cc = callComb c c-                  d = diag (matrix cc)-                  containsDecr = any isDecr d-              in (not (c == cc)) || containsDecr--}-isDecr :: Order -> Bool-isDecr o = case o of-             (Decr k) -> k > 0-             (Mat m) -> any isDecr (M.diagonal m)-             _ -> False-------------------------- top level function-terminationCheck :: MonadAssert m => [Fun] -> m ()-terminationCheck funs = do-       let ?cutoff = cutoff-       traceTermM $ "terminationCheck " ++ show funs-       let tl = terminationCheckFuns funs-       let nl = map fst tl-       let bl = map snd tl-       let nl2 = [ n | (n,b) <- tl , b == False ]-       case (and bl) of-            True -> return ()-            False -> case nl of-                    [f] -> recoverFail ("Termination check for function " ++ show f ++ " fails ")-                    _   -> recoverFail ("Termination check for mutual block " ++ show nl ++ " fails for " ++ show nl2)---terminationCheckFuns :: (?cutoff :: Int) => [Fun] -> [(Name,Bool)]-terminationCheckFuns funs =-   let namar = map (\ (Fun (TypeSig n _) _ ar _) -> (n, ar)) funs-               -- collectNames funs-       names = map fst namar-       cg0 = collectCGFunDecl namar funs-   in sizeChangeTermination names cg0--sizeChangeTermination :: (?cutoff :: Int) => [Name] -> [Call] -> [(Name,Bool)]-sizeChangeTermination names cg0 =-   let cg1 = makeCG names cg0-       cg = complCGraph $ cg1-       beh = zip names $ map (all (checkIdem . snd)) $ diag cg-   in traceTerm ("collected names: " ++ show names) $-      traceTerm ("call graph: " ++ show cg0) $-      traceTerm ("normalized call graph: " ++ show cg1) $-      traceTerm ("completed call graph: " ++ show cg) $-      traceTerm ("recursion behaviours" ++ show beh) $-      beh---{--terminationCheckFuns :: [ (TypeSig,[Clause]) ] -> [(Name,Bool)]-terminationCheckFuns funs =-    let beh = recBehaviours funs-    in-      traceTerm ("recursion behaviours" ++ show beh) $-        zip (map fst beh) (map (checkAll . snd ) beh )---- This is the main driver.-recBehaviours :: [ (TypeSig,[Clause]) ] -> [(Name,[Call])]-recBehaviours funs = let names = map fst $ collectNames funs-                         cg0 = collectCGFunDecl funs-                         cg = complete cg0-                     in traceTerm ("collected names: " ++ show names) $-                        traceTerm ("call graph: " ++ show cg0) $-                        groupCalls names [ c | c <- cg , (target c == source c) ]---groupCalls :: [Name] -> [Call] -> [(Name,[Call])]-groupCalls [] _ = []-groupCalls (n:nl) cl = (n, [ c | c <- cl , (source c == n) ]) : groupCalls nl cl--}--{--ccFunDecl :: [ ( TypeSig,[Clause]) ] -> [Call]-ccFunDecl funs = complete $ collectCGFunDecl funs--}--collectCGFunDecl :: (?cutoff :: Int) => [(Name,Arity)] -> [Fun] -> [Call]-collectCGFunDecl names funs =-      concatMap (collectClauses names) funs-          where-            collectClauses :: [(Name,Arity)] -> Fun -> [Call]-            collectClauses names (Fun (TypeSig n _) _ ar cll) = collectClause names n cll-            collectClause :: [(Name,Arity)] -> Name -> [Clause] -> [Call]-            collectClause names n ((Clause _ pl Nothing):rest) = collectClause names n rest-            collectClause names n ((Clause _ pl (Just rhs)):rest) =-              traceTerm ("collecting calls in " ++ show rhs) $-                (collectCallsExpr names n pl rhs) ++ (collectClause names n rest)-            collectClause names n [] = []--{- RETIRED-arity :: [Clause] -> Int-arity [] = 0-arity (Clause pl e:l) = length pl--}--{- RETIRED (map)-collectNames :: [Fun] -> [(Name,Arity)]-collectNames [] = []-collectNames (Fun (TypeSig n _) ar cls : rest) = (n,ar) : (collectNames rest)--}---- | harvest i > j  from  case i { $ j -> ...}-tsoCase :: TSO Name -> Expr -> [Clause] -> TSO Name-tsoCase tso (Var x) [Clause _ [SuccP (VarP y)] _] = TSO.insert y (1,x) tso-tsoCase tso _ _ = tso---- | harvest i < j  from (i < j) -> ... or (i < j) & ...-tsoBind :: TSO Name -> TBind -> TSO Name-tsoBind tso (TBind x (Domain (Below ltle (Var y)) _ _)) = TSO.insert x (n ltle,y) tso-  where n Lt = 1-        n Le = 0-tsoBind tso _ = tso--collectCallsExpr :: (?cutoff :: Int) => [(Name,Arity)] -> Name -> [Pattern] -> Expr -> [Call]-collectCallsExpr nl f pl e = traceTerm ("collectCallsExpr " ++ show e) $-  loop tso e where-    tso = tsoFromPatterns pl-    loop tso (Ann e) = loop tso (unTag e)-    loop tso e = headcalls ++ argcalls where-      (hd, args) = spineView e -- $ ignoreTopErasure e-      argcalls = concatMap (loop tso) args-      headcalls = case hd of-          (Def (DefId FunK (QName g))) ->-              case lookup g nl of-                Nothing -> []-                Just ar_g ->-                  traceTerm ("found call from " ++ show f ++ " to " ++ show g) $-                             let (Just ar_f) = lookup f nl-                                 (Just f') = List.elemIndex (f,ar_f) nl-                                 (Just g') = List.elemIndex (g,ar_g) nl-                                 m = compareArgs tso pl args ar_g-                                 cg = Call { source = f-                                           , target = g-                                           , matrix = m }-                             in-                               traceTerm ("found call " ++ show cg) $-                                 [cg]-          (Case e _ cls) -> loop tso e ++ concatMap (loop (tsoCase tso e cls)) (map (maybe Irr id . clExpr) cls)-          (Lam _ _ e1) -> loop tso e1-          (LLet tb tel e1 e2) | null tel->-             (loop tso e1) ++ -- type won't get evaluated-             (loop tso e2)-          (Quant _ tb@(TBind x dom) e2) -> (loop tso (typ dom)) ++ (loop (tsoBind tso tb) e2)-          (Quant _ (TMeasure mu) e2) -> Foldable.foldMap (loop tso) mu ++ (loop tso e2)-          (Quant _ (TBound beta) e2) -> Foldable.foldMap (loop tso) beta ++ (loop tso e2)-          (Below ltle e) -> loop tso e-          (Sing e1 e2) -> (loop tso e1) ++ (loop tso e2)-          (Pair e1 e2) -> (loop tso e1) ++ (loop tso e2)-          (Succ e) -> loop tso e-          (Max es) -> concatMap (loop tso) es-          (Plus es) -> concatMap (loop tso) es-          Sort (SortC{})  -> []-          Sort (Set e)    -> loop tso e-          Sort (CoSet e)  -> loop tso e-          Var{}   -> []-          Zero{} -> []-          Infty{} -> []-          Def{}   -> []-          Irr{}   -> []-          Proj{}   -> []-          Record ri rs -> Foldable.foldMap (loop tso . snd) rs-          Ann e1 -> loop tso (unTag e1)---          Con{}   -> []---          Let{}   -> []-          Meta{}  -> error $ "collect calls in unresolved meta variable " ++ show e-          _ -> error $ "NYI: collect calls in " ++ show e--{--collectCallsExpr :: (?cutoff :: Int) => [(Name,Int)] -> Name -> [Pattern] -> Expr -> [Call]-collectCallsExpr nl f pl e =-  traceTerm ("collectCallsExpr " ++ show e) $-    case e of-      (App (Def g) args) ->-        let calls = concatMap (collectCallsExpr nl f pl) args-            gIn = lookup g nl-        in-         traceTerm ("found call from " ++ f ++ " to " ++ g) $-          case gIn of-            Nothing -> calls-            Just ar_g -> let (Just ar_f) = lookup f nl-                             (Just f') = List.elemIndex (f,ar_f) nl-                             (Just g') = List.elemIndex (g,ar_g) nl-                             m = compareArgs pl args ar_g-                             cg = Call { source = f-                                       , target = g-                                       , matrix = m }-                         in-                           traceTerm ("found call " ++ show cg) $-                             cg:calls-      (Def g) ->  collectCallsExpr nl f pl (App (Def g) [])-      (App e args) -> concatMap (collectCallsExpr nl f pl) (e:args)-      (Case e cls) -> concatMap (collectCallsExpr nl f pl) (e:map clExpr cls)-      (Lam _ _ e1) -> collectCallsExpr nl f pl e1-      (LLet _ e1 t1 e2) ->  (collectCallsExpr nl f pl e1) ++ -- type won't get evaluated-                            (collectCallsExpr nl f pl e2)-      (Pi _ _ e1 e2) -> (collectCallsExpr nl f pl e1) ++-                              (collectCallsExpr nl f pl e2)-      (Sing e1 e2) -> (collectCallsExpr nl f pl e1) ++-                              (collectCallsExpr nl f pl e2)-      (Succ e1) -> collectCallsExpr nl f pl e1-      Sort{}  -> []-      Var{}   -> []-      Infty{} -> []-      Con{}   -> []-      Let{}   -> []-      Meta{}  -> error $ "collect calls in unresolved meta variable " ++ show e-      _ -> error $ "NYI: collect calls in " ++ show e--}-------------------------------------------------------------------------{- Foetus II - Counting Lexicographic Termination (delta-Foetus)--delta-SCT [Ben-Amram 2006] is too inefficient, at least with the bound-given in the paper.--  B(G) = (k + 1)2^k · m^2 · 2^(2k+1) (m∆)^(3k+1) (k + 1)^(3k^2+3k+1)--is an upper bound on the length of the longest path to be looked at to-exclude non-termination.--I guess that both argument permutation and counting is not very-common.  So an approach would be--- try to show termination with SCT-- try to show termination with delta-Foetus--Call graph completion in delta-Foetus--1. Iterate as long new simple cycles show up (i.e. cycles with no subcycles)--2. Find the possible lexicographic termination orders to for each function--3. Continue iterating while any of the arguments involved in any of the termination orders gets worse.  Some termination order hypotheses might collapse.--4. Stop when all hypotheses have collapsed (FAIL) or when no standing hypotheses gets any worse (SUCCESS).--Implementation:--After 1. save for each function and each of its arguments the worst-recursive behavior in any of the calls.  This map will be used to-monitor progress.---Careful:--  f x = f (x-1) | g (x - 100)-  g x = g (x+1) | f (x - 100)--Bad call f->f only found after 201 iterations of g!--Idea:  regular expressions over call matrices!--  (m1 + m2^*)^*---}
− ToHaskell.hs 
@@ -1,292 +0,0 @@-module ToHaskell where--{- type-directed extraction of Haskell programs with a lot of unsafeCoerce--Examples:------------MiniAgda--  data Vec (A : Set) : Nat -> Set-  { vnil  : Vec A zero-  ; vcons : [n : Nat] -> (head : A) -> (tail : Vec A n) -> Vec A (suc n)-  }--  fun length : [A : Set] -> [n : Nat] -> Vec A n -> <n : Nat>-  { length .A .zero    (vnil A)         = zero-  ; length .A .(suc n) (vcons A n a as) = suc (length A n as)-  }--Haskell--  {-# LANGUAGE NoImplicitPrelude #-}-  module Main where-  import qualified Text.Show as Show--  data Vec (a :: *)-    = Vec_vnil-    | Vec_vcons { vec_head :: a , vec_tail :: Vec a }-      deriving Show.Show--  length :: forall a. Vec a -> Nat-  length  Vec_vnil        = Nat_zero-  length (Vec_vcons a as) = Nat_suc (length as)--Components:--------------Translation from MiniAgda identifiers to Haskell identifiers---}--import Prelude hiding (null)--import Data.Char--import Control.Applicative-import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State--import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Traversable as Trav--import qualified Language.Haskell.Exts.Syntax as H-import Text.PrettyPrint--import Polarity-import Abstract-import Extract-import qualified HsSyntax as H-import TraceError-import Util---- translation monad--type Translate = StateT TState (ReaderT TContext (ExceptT TraceError IO))--{- no longer needed with mtl-2-instance Applicative Translate where-  pure      = return-  mf <*> ma = do { f <- mf; a <- ma; return (f a) }--}--data TState = TState--initSt :: TState-initSt = TState--data TContext = TContext--initCxt :: TContext-initCxt = TContext--runTranslate :: Translate a -> IO (Either TraceError a)-runTranslate t = runExceptT (runReaderT (evalStateT t initSt) initCxt)---- translation--translateModule :: [EDeclaration] -> Translate (H.Module)-translateModule ds = do-  hs <- translateDecls ds-  return $ H.mkModule hs--translateDecls :: [EDeclaration] -> Translate [H.Decl]-translateDecls ds = concat <$> mapM translateDecl ds--translateDecl :: EDeclaration -> Translate [H.Decl]-translateDecl d =-  case d of-    MutualDecl _ ds -> translateDecls ds-    OverrideDecl{} -> throwErrorMsg $ "translateDecls internal error: overrides impossible"-    MutualFunDecl _ _ funs -> translateFuns funs-    FunDecl _ fun -> translateFun fun-    LetDecl _ x tel (Just t) e | null tel -> translateLet x t e-    DataDecl n _ _ _ tel fkind cs _ -> translateDataDecl n tel fkind cs--translateFuns :: [Fun] -> Translate [H.Decl]-translateFuns funs = concat <$> mapM translateFun funs--translateFun :: Fun -> Translate [H.Decl]-translateFun (Fun ts@(TypeSig n t) n' ar cls) = do-  ts@(H.TypeSig _ [n] t) <- translateTypeSig ts-  cls <- concat <$> mapM (translateClause n) cls-  return [ts, H.FunBind cls]--translateLet :: Name -> Type -> FExpr -> Translate [H.Decl]-translateLet n t e-  | isEtaAlias n = return []  -- skip internal decls-  | otherwise = do-      ts <- translateTypeSig $ TypeSig n t-      e  <- translateExpr e-      n  <- hsName (DefId LetK $ QName n)-      return [ ts, H.mkLet n e ]--translateTypeSig :: TypeSig -> Translate H.Decl-translateTypeSig (TypeSig n t) = do-  n <- hsName (DefId LetK $ QName n)-  t <- translateType t-  return $ H.mkTypeSig n t--translateDataDecl :: Name -> FTelescope -> FKind -> [FConstructor] -> Translate [H.Decl]-translateDataDecl n tel k cs = do-  n   <- hsName (DefId DatK $ QName n)-  tel <- translateTelescope tel-  let k' = translateKind k-  cs  <- mapM translateConstructor cs-  return [H.mkDataDecl n tel k' cs]--translateConstructor :: FConstructor -> Translate H.GadtDecl-translateConstructor (Constructor n pars t) = do-  n  <- hsName (DefId (ConK Cons) n)-  t' <- translateType t-  return $ H.mkConDecl n t'--translateClause :: H.Name -> Clause -> Translate [H.Match]-translateClause n (Clause _ ps (Just rhs)) = do-  ps <- mapM translatePattern ps-  rhs <- translateExpr rhs-  return [H.mkClause n ps rhs]--translateTelescope :: FTelescope -> Translate [H.TyVarBind]-translateTelescope (Telescope tel) = mapM translateTBind tel'-  -- throw away erasure marks-  where tel' = filter (\ tb -> not $ erased $ decor $ boundDom tb) tel--translateTBind :: TBind -> Translate H.TyVarBind-translateTBind (TBind x dom) = do-  x <- hsVarName x-  return $ H.KindedVar x $ translateKind (typ dom)--translateKind :: FKind -> H.Kind-translateKind k =-  case k of-    k | k == star -> H.KindStar-    Quant Pi (TBind _ dom) k' | erased (decor dom) -> translateKind k'-    Quant Pi (TBind _ dom) k' ->-      translateKind (typ dom) `H.mkKindFun` translateKind k'--translateType :: FType -> Translate H.Type-translateType t =-  case t of--    Irr -> return $ H.unit_tycon--    Quant piSig (TBind _ dom) b | not (erased (decor dom)) ->-      H.mkTyPiSig piSig <$> translateType (typ dom) <*> translateType b--    Quant Pi (TBind _ dom) b | typ dom == Irr -> translateType b--    Quant Pi (TBind x dom) b -> do-      x <- hsVarName x-      let k = translateKind (typ dom)-      -- todo: add x to context-      t <- translateType b-      return $ H.mkForall x k t--    App f a -> H.mkTyApp <$> translateType f <*> translateType a--    Def d@(DefId DatK n) -> (H.TyCon . H.UnQual) <$> hsName d--    Var x -> H.TyVar <$> hsVarName x--    _ -> return H.unit_tycon--{- TODO:-    _ -> throwErrorMsg $ "no Haskell representation for type " ++ show t- -}--translateExpr :: FExpr -> Translate H.Exp-translateExpr e =-  case e of--    Var x -> H.mkVar <$> hsVarName x--    -- constructors-    Def f@(DefId (ConK{}) n) -> H.mkCon <$> hsName f--    -- function identifiers-    Def f@(DefId _ n) -> H.mkVar <$> hsName f--    -- discard type arguments-    App f e0 -> do-      f <- translateExpr f-      let (er, e) = isErasedExpr e0-      if er then return f else H.mkApp f <$> translateExpr e--    -- discard type lambdas-    Lam dec y e -> do-      y <- hsVarName y-      e <- translateExpr e-      return $ if erased dec then e else H.mkLam y e--    LLet (TBind x dom) tel e1 e2 | null tel-> do-      x  <- hsVarName x-      e2 <- translateExpr e2-      if erased (decor dom) then return e2 else do-        t  <- Trav.mapM translateType (typ dom)-        e1 <- translateExpr e1-        return $ H.mkLLet x t e1 e2--    Pair e1 e2 -> H.mkPair <$> translateExpr e1 <*> translateExpr e2--    -- TODO--    Ann (Tagged [Cast] e) -> H.mkCast <$> translateExpr e--    _ -> return $ H.unit_con--translatePattern :: Pattern -> Translate H.Pat-translatePattern p =-  case p of-    VarP y       -> H.PVar <$> hsVarName y-    PairP p1 p2  -> H.PTuple H.Boxed <$> mapM translatePattern [p1,p2]-    ConP pi n ps ->-       H.PApp <$> (H.UnQual <$> hsName (DefId (ConK $ coPat pi) n))-              <*> mapM translatePattern ps--{--Name translation--  data names        : check capitalization, identity translation-  constructor names : prefix with Dataname_-  destructor names  : ditto-  type-valued lets  : check capitalization, identity-  type-valued funs  : reject!-  lets              : check lowercase-  funs/cofuns       : check lowercase--}--hsVarName :: Name -> Translate H.Name-hsVarName x = return $ H.Ident $ show x--hsName :: DefId -> Translate H.Name-hsName id = enter ("error translating identifier " ++ show id) $-  case id of-  (DefId DatK (QName x)) -> do-    let n = suggestion x-    unless (isUpper $ head n) $-      throwErrorMsg $ "data names need to be capitalized"-    return $ H.Ident n-  (DefId (ConK co) (Qual d x)) -> do-    let n = suggestion x-        m = suggestion d-    return $ H.Ident $ m ++ "_" ++ n-    -- dataName <- getDataName x-    -- return $ H.Ident $ dataName ++ "_" ++ n-  -- lets, funs, cofuns. TODO: type-valued funs!---   (DefId Let ('_':n)) | -> return $ H.Ident n-  (DefId _ x) -> do-    let n = suggestion $ unqual x-{- ignore for now-     unless (isLower $ head n) $-       throwErrorMsg $ "function names need to start with a lowercase letter"- -}-    return $ H.Ident n---- getDataName constructorName = return dataNamec-getDataName :: Name -> Translate String-getDataName n = return "DATA"
− Tokens.hs 
@@ -1,29 +0,0 @@-module Tokens where--data Token -  = Id String-  | Data-  | Fun-  | Def-  | Mutual-  | Pattern-  | Set-  | Case-  -- size type-  | Size-  | Infty-  | Succ-  ---  | BrOpen-  | BrClose-  | PrOpen-  | PrClose-  | Sem-  | Col-  | Arrow-  | Eq-  | Lam-  | UScore-  | NotUsed -- so happy doesn't generate overlap case pattern warning-    deriving (Eq,Ord,Show)-
− TraceError.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}--module TraceError where--import Control.Monad.Except-import Debug.Trace--import Util-import Text.PrettyPrint--data TraceError = Err String | TrErr String TraceError---- instance Error TraceError where---     noMsg = Err "no message"---     strMsg s = Err s--instance Show TraceError where-    show (Err str) = str-    show (TrErr str err) = str ++ "\n/// " ++ show err--throwErrorMsg m = throwError (Err m)---- newErrorMsg :: (MonadError TraceError m) => m a -> String -> m a-newErrorMsg c s = c `catchError` (\ _ -> throwErrorMsg s)--- addErrorMsg c s = c `catchError` (\ s' -> throwErrorMsg (s' ++ "\n" ++ s))---- extend the current error message by n-throwTrace x n = x `catchError` ( \e -> throwError $ TrErr n e)-enter n x = throwTrace x n-enterTrace n x = trace n $ throwTrace x n-enterShow n = enter (show n)--enterDoc :: (MonadError TraceError m, Pretty d) => m d -> m a -> m a-enterDoc md cont = do-  d <- md-  enter (render (pretty d)) cont--failDoc :: (MonadError TraceError m) => m Doc -> m a-failDoc d = throwErrorMsg . render =<< d--newErrorDoc :: (MonadError TraceError m) => m a -> m Doc -> m a-newErrorDoc c d = c `catchError` (\ _ -> failDoc d)--errorToMaybe :: (MonadError e m) => m a -> m (Maybe a)-errorToMaybe m = (m >>= return . Just) `catchError` (const $ return Nothing)--errorToBool :: (MonadError e m) => m () -> m Bool-errorToBool m = (m >> return True) `catchError` (\ _ -> return False)--boolToErrorDoc :: (MonadError TraceError m) => m Doc -> Bool -> m ()-boolToErrorDoc d True  = return ()-boolToErrorDoc d False = failDoc d--boolToError :: (MonadError TraceError m) => String -> Bool -> m ()-boolToError msg True  = return ()-boolToError msg False = throwErrorMsg msg--instance MonadError () Maybe where-  catchError Nothing k = k ()-  catchError (Just a) k = Just a-  throwError () = Nothing--orM :: (MonadError e m) => m a -> m a -> m a-orM m1 m2 = m1 `catchError` (const m2)---- recoverable errors--data AssertionHandling = Failure | Warning | Ignore-                       deriving (Eq,Ord,Show)--assert' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> String -> m ()-assert' Ignore b s      = return ()-assert' h True s        = return ()-assert' Warning False s = liftIO $ putStrLn $ "warning: ignoring error: " ++ s-assert' Failure False s = throwErrorMsg s--assertDoc' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> m Doc -> m ()-assertDoc' h b md = assert' h b . render =<< md--class Monad m => MonadAssert m where-  assert :: Bool -> String -> m ()-  assertDoc :: Bool -> m Doc -> m ()-  assertDoc b md = assert b . render =<< md-  newAssertionHandling :: AssertionHandling -> m a -> m a-  recoverFail :: String -> m ()-  recoverFail = assert False-  recoverFailDoc :: m Doc -> m ()-  recoverFailDoc = assertDoc False--{--assert' :: (MonadIO m) => AssertionHandling -> Bool -> String -> m a -> m a-assert' Ignore b s k = k-assert' h True s k = k-assert' Warning False s k = do-  liftIO $ putStrLn s-  k-assert' Failure False s k = fail s--class Monad m => MonadAssert m where-  assert :: Bool -> String -> m a -> m a-  newAssertionHandling :: AssertionHandling -> m a -> m a--}
− TreeShapedOrder.hs 
@@ -1,164 +0,0 @@-{- A data structure to represent a forest of upside down trees,-similar to union-find.  The idea is to manage a tree-shaped form of-strict inequations--  i1 > i2 > i3-     > j2 > j3 > j4 > j5-          > k3-          > l3 > l4--  m1 > m2--  n1--Checking inequalty x < y is then performed by just enumerating the-parents of x and checking wether y is a member of it.--2010-11-12 UPDATE: We generalize this to ">=" and more by attaching to-each link a non-negative number.--  0  means  >=-  1  means  >-  n  means  at least n units greater--}--module TreeShapedOrder where--import Prelude hiding (null)-import Data.List hiding (insert, null) -- groupBy--import Data.Map (Map)-import qualified Data.Map as Map--import Data.Tree (Tree(..), Forest) -- rose trees-import qualified Data.Tree as Tree--import Util -- headM---- | Tree-structured partial orders.---   Represented as maps from children to parents plus a non-negative distance.-newtype TSO a = TSO { unTSO :: Map a (Int,a) } deriving (Eq, Ord)---- | Empty TSO.-empty :: TSO a-empty = TSO $ Map.empty---- | @insert a b o@  inserts a with parent b into order o.--- It does not check whether the tree structure is preserved.-insert :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> TSO a-insert a b (TSO o) = TSO $ Map.insert a b o---- | Construction from a list of child-distance-parent tuples.-fromList :: (Ord a, Eq a) => [(a,(Int,a))] -> TSO a-fromList l = foldl (\ o (a,b) -> insert a b o) empty l---- | @parents a0 o = [(d1,a1),..,(dn,an)]@ lists the parents of @a0@ in order,--- i.e., a(i+1) is parent of a(i) with distance d(i+1).-parents :: (Ord a, Eq a) => a -> TSO a -> [(Int,a)]-parents a (TSO o) = loop (Map.lookup a o) where-  loop Nothing  = []-  loop (Just (n,b)) = (n,b) : loop (Map.lookup b o)---- | @parent a o@ returns the immediate parent, if it exists.-parent :: (Ord a, Eq a) => a -> TSO a -> Maybe (Int,a)-parent a t = headMaybe $ parents a t---- | @isAncestor a b o = Just n@ if there are n steps up from a to b.-isAncestor :: (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int-isAncestor a b o = loop 0 ((0,a) : parents a o)-   where loop acc [] = Nothing-         loop acc ((n,a) : ps) | a == b    = Just (acc + n)-                               | otherwise = loop (acc + n) ps---- | @diff a b o = Just k@ if there are k steps up from a to b--- or (-k) steps down from b to a.-diff ::  (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int-diff a b o = maybe (fmap (\ k -> -k) $ isAncestor b a o) Just $ isAncestor a b o---- | create a map from parents to list of sons, leaves have an empty list-invert :: (Ord a, Eq a) => TSO a -> Map a [(Int,a)]-invert (TSO o) = Map.foldrWithKey step Map.empty o where-  step son (dist, parent) m = Map.insertWith (++) son [] $-    Map.insertWith (++) parent [(dist, son)] m---- | @height a t = Just k@ if $k$ is the length of the---   longest path from @a@ to a leaf. @Nothing@ if @a@ not in @t@.-height :: (Ord a, Eq a) => a -> TSO a -> Maybe Int-height a t = do-  let m = invert t-  let loop parent = do-        sons <- Map.lookup parent m-        return $ if null sons then 0 else-                  maximum $ map (\ (n,son) -> maybe 0 (n +) $ loop son) sons-  loop a---- | @increasesHeight a (n,b) t = True@ if @n > height b t@, i.e., if---   the insertion of a with parent b will destroy an existing---   minimal valuation of @t@-increasesHeight :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> Bool-increasesHeight a (n,b) t = n > maybe 0 id (height b t)---- | get the leaves of the TSO forest-leaves :: (Ord a, Eq a) => TSO a -> [a]-leaves o = map fst $ filter (\ (parent,sons) -> null sons) $ Map.toList (invert o)--{- FLAWED BOTTOM-UP-ATTEMPT, DOES NOT WORK-{- How to invert a TSO?--1. Create a Map from parents to their list of children.--2. Keep a working set of nodes.-   Find the leafs in this working set (nodes that do not have children).-   Cluster them by their parents.-   Turn their parents into trees,-   Continue with the parents.--}--- | invert a tree shaped order into a forest.  This can be used for printing-toForest :: (Ord a, Eq a) => TSO a -> Forest a-toForest o = loop (step initialTrees) where-  initialTrees = map (flip Node []) $ leaves o-  -- step :: (Ord a, Eq a) => Forest a -> [(Maybe a, Forest a)]-  step ts = map (\ l -> (fst (head l), map snd l)) $-    groupBy (\ (p,t) (p',t') -> p == p') $-    sortBy (\ (p,t) (p',t') -> compare p p') $-    map (\ t -> (parent (rootLabel t) o, t)) ts-  -- loop :: (Ord a, Eq a) => [(Maybe a, Forest a)] -> Forest a-  loop [] = []-  -- the trees whose roots have no parents are parts of the final forest-  loop ((Nothing, roots) : nonroots) = roots ++ loop nonroots-  -- the trees whose roots have a parent are iterated-  loop nonroots = loop $ step $ map (\ (Just p, ts) -> Node p ts) nonroots--}---- take a lexicographically sorted list of pathes--- and turn it into a forest by--- gathering the lists by common prefixes-pathesToForest :: (Ord a, Eq a) => [[(Int,a)]] -> Forest (Int, a)-pathesToForest [] = []-pathesToForest ll =-  map (\ l -> Node (head (head l))-                   (pathesToForest $ filter (not . null) $ map tail l)) $-    groupBy (\ l l' -> head l == head l') ll---- | invert a tree shaped order into a forest.  This can be used for printing.-toForest :: (Ord a, Eq a) => TSO a -> Forest (Int,a)-toForest o = pathesToForest $ sort $ map (\ a -> reverse ((0,a) : parents a o)) $ leaves o -- lex. sort--instance (Ord a, Eq a, Show a) => Show (TSO a) where-  show o = Tree.drawForest $ map (fmap show) $ toForest o--{--draw :: (Ord a, Eq a, Show a) => TSO a -> String-draw o = Tree.drawForest $ map (fmap show) $ toForest o--}---- test--l1 = map (\ (k,l) -> ("i" ++ show k, (1, "i" ++ show l))) [(0,1),(1,2),(2,3),(3,4)]-     ++ [("j2",(1,"i3"))]-o1 = fromList l1-t1 = diff "i2" "i1" o1-t2 = diff "i2" "j2" o1-t3 = height "i2" o1-t4 = height "i4" o1-t5 = height "k" o1
− TypeChecker.hs 
@@ -1,3301 +0,0 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,-      PatternGuards, TupleSections, NamedFieldPuns #-}--module TypeChecker where--import Prelude hiding (null)--import Control.Applicative hiding (Const) -- ((<$>))-import Control.Monad-import Control.Monad.Identity-import Control.Monad.State-import Control.Monad.Except-import Control.Monad.Reader--import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import qualified Data.Foldable as Foldable-import qualified Data.Traversable as Traversable--import Debug.Trace--import qualified Text.PrettyPrint as PP--import Util-import qualified Util as Util--import Abstract hiding (Substitute)-import Polarity as Pol-import Value-import TCM-import Eval-import Extract--- import SPos (nocc) -- RETIRED--- import CallStack-import PrettyTCM-import TraceError--import Warshall hiding (Flex) -- size constraint checking--import Termination---- import Completness---traceCheck msg a = a -- trace msg a-traceCheckM msg = return () -- traceM msg-{--traceCheck msg a = trace msg a-traceCheckM msg = traceM msg--}--traceSing msg a = a -- trace msg a-traceSingM msg = return () -- traceM msg-{--traceSing msg a = trace msg a-traceSingM msg = traceM msg--}--traceAdm msg a = a -- trace msg a-traceAdmM msg = return () -- traceM msg-{--traceAdm msg a = trace msg a-traceAdmM msg = traceM msg--}--{- DEAD CODE-runWhnf :: Signature -> TypeCheck a -> IO (Either TraceError (a,Signature))-runWhnf sig tc = (runExceptT (runStateT tc  sig))--}--doNf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= reify) (initWithSig sig)) emptyContext)-doWhnf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= whnfClos) (initWithSig sig)) emptyContext)----- top-level functions ---------------------------------------------runTypeCheck :: TCState -> TypeCheck a -> IO (Either TraceError (a,TCState))-runTypeCheck st tc = runExceptT (runReaderT (runStateT tc st) emptyContext)--- runTypeCheck st tc = runCallStackT (runReaderT (runStateT tc st) emptyContext) []--typeCheck dl = runTypeCheck initSt (typeCheckDecls dl)---- checking top-level declarations ---------------------------------echo :: MonadIO m => String -> m ()-echo = liftIO . putStrLn--echoR = echo--- echoR s = echo $ "R> " ++ s--echoTySig :: (Show n, MonadIO m) => n -> Expr -> m ()-echoTySig n t = return () -- echo $ "I> " ++ n ++ " : " ++ show t--echoKindedTySig :: (Show n, MonadIO m) => Kind -> n -> Expr -> m ()-echoKindedTySig ki n t = echo $ prettyKind ki ++ "  " ++ show n ++ " : " ++ show t--echoKindedDef :: (Show n, MonadIO m) => Kind -> n -> Expr -> m ()-echoKindedDef ki n t = echo $ prettyKind ki ++ "  " ++ show n ++ " = " ++ show t--echoEPrefix = "E> "--echoTySigE :: (Show n, MonadIO m) => n -> Expr -> m ()-echoTySigE n t = echo $ echoEPrefix ++ show n ++ " : " ++ show t--echoDefE :: (Show n, MonadIO m) => n -> Expr -> m ()-echoDefE n t = echo $ echoEPrefix ++ show n ++ " = " ++ show t---- the type checker returns pruned (extracted) terms--- with irrelevant subterms replaced by Irr-typeCheckDecls :: [Declaration] -> TypeCheck [EDeclaration]-typeCheckDecls []     = return []-typeCheckDecls (d:ds) = do-  de  <- typeCheckDeclaration d-  dse <- typeCheckDecls ds-  return (de ++ dse)---- since a data declaration generates destructor declarations--- we need to return a list here-typeCheckDeclaration :: Declaration -> TypeCheck [EDeclaration]-typeCheckDeclaration (OverrideDecl Check ds) = do-  st <- get-  typeCheckDecls ds-  put st             -- forget the effect of these decls-  return []-typeCheckDeclaration (OverrideDecl Fail ds) = do-  st <- get-  r <- (typeCheckDecls ds >> return True) `catchError`-        (\ s -> do liftIO $ putStrLn ("block fails as expected, error message:\n" ++ show s)-                   return False)-  if r then throwErrorMsg "unexpected success" else do-    put st-    return []--typeCheckDeclaration (OverrideDecl TrustMe ds) =-  newAssertionHandling Warning $ typeCheckDecls ds--typeCheckDeclaration (OverrideDecl Impredicative ds) =-  goImpredicative $ typeCheckDecls ds--typeCheckDeclaration (RecordDecl n tel t0 c fields) =-  -- just one "mutual" declaration-  checkingMutual (Just $ DefId DatK $ QName n) $ do-    result <- typeCheckDataDecl n NotSized CoInd [] tel t0 [c] fields-    checkPositivityGraph-    return result--typeCheckDeclaration (DataDecl n sz co pos0 tel t0 cs fields) =-  -- just one "mutual" declaration-  checkingMutual (Just $ DefId DatK $ QName n) $ do-    result <- typeCheckDataDecl n sz co pos0 tel t0 cs fields-    checkPositivityGraph-    return result--typeCheckDeclaration (LetDecl eval n tel mt e) = enter (show n) $ do-{- MOVED to checkLetDef-  (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer neutralDec e mt-  te <- return $ teleToType tel te-  ee <- return $ teleLam tel ee-  vt <- whnf' te--}-  (vt, te, Kinded ki ee) <- checkLetDef neutralDec tel mt e-  rho <- getEnv -- is emptyEnv-  -- TODO: solve size constraints-  -- does not work with emptyEnv-  -- [te, ee] <- solveAndModify [te, ee] rho  -- solve size constraints-  let v = mkClos rho ee -- delay whnf computation-  -- v  <- whnf' ee -- WAS: whnf' e'-  addSig n (LetSig vt ki v $ undefinedFType $ QName n)    -- late (var -> expr) binding, but ok since no shadowing---  addSig n (LetSig vt e')    -- late (var -> expr) binding, but ok since no shadowing-  echoKindedTySig ki n te---  echoTySigE n te---  echoDefE   n ee-  echoKindedDef ki n ee-  return [LetDecl eval n emptyTel (Just te) ee]--typeCheckDeclaration d@(PatternDecl x xs p) = do-{- WHY DOES THIS NOT TYPECHECK?-  let doc = (PP.text "pattern") <+> (PP.hsep (List.map Util.pretty (x:xs))) <+> PP.equals <+> Util.pretty p-  echo $ PP.render $ doc--}-  echo $ "pattern " ++ Util.showList " " show (x:xs) ++ " = " ++ show p-  v <- whnf' $ foldr (Lam defaultDec) (patternToExpr p) xs-  addSig x (PatSig xs p v)-  return [d]--typeCheckDeclaration (MutualFunDecl False co funs) =-  -- traceCheck ("type checking a function block") $-  do-    funse <- typeCheckFuns co funs-    return $ [MutualFunDecl False co funse]--typeCheckDeclaration (MutualFunDecl True co funs) =-  -- traceCheck ("type checking a block of measured function") $-  do-    funse <- typeCheckMeasuredFuns co funs-    return $ [MutualFunDecl False co funse]--typeCheckDeclaration (MutualDecl measured ds) = do-  -- first check type signatures-  -- we add the typings into the context, not the signature-  ktss <- typeCheckMutualSigs ds-  -- register the mutually defined names-  let ns = for ktss $ \ (Kinded _ (TypeSig n _)) -> n-      addMutualNames = local $ \ e -> e { mutualNames = ns ++ mutualNames e }-  -- then check bodies-  -- we need to construct a positivity graph-  edss <- addKindedTypeSigs ktss $ addMutualNames $-    zipWithM (typeCheckMutualBody measured) (map (predKind . kindOf) ktss) ds-  -- check and reset positivity graph-  checkPositivityGraph-  return $ concat edss----- check signatures of a flattened mutual block-typeCheckMutualSigs :: [Declaration] -> TypeCheck [Kinded (TySig TVal)]-typeCheckMutualSigs [] = return []-typeCheckMutualSigs (d:ds) = do-  kts@(Kinded ki (TypeSig n tv)) <- typeCheckMutualSig d-  new' n (Domain tv ki defaultDec) $ do-    ktss <- typeCheckMutualSigs ds-    return $ kts : ktss--typeCheckSignature :: TySig Type -> TypeCheck (Kinded (TySig TVal))-typeCheckSignature (TypeSig n t) = do-  echoTySig n t-  Kinded ki te <- checkType t-  tv <- whnf' te-  return $ Kinded (predKind ki) $ TypeSig n tv--typeCheckMutualSig :: Declaration -> TypeCheck (Kinded (TySig TVal))-typeCheckMutualSig (LetDecl ev n tel (Just t) e) =-  typeCheckSignature $ TypeSig n $ teleToType tel t-typeCheckMutualSig (DataDecl n sz co pos tel t cs fields) = do-  Kinded ki ts <- typeCheckSignature (TypeSig n (teleToType tel t))-  return $ Kinded ki ts-typeCheckMutualSig (FunDecl co (Fun ts n' ar cls)) =-  typeCheckSignature ts-typeCheckMutualSig (OverrideDecl TrustMe [d]) =-  newAssertionHandling Warning $ typeCheckMutualSig d-typeCheckMutualSig (OverrideDecl Impredicative [d]) =-  goImpredicative $ typeCheckMutualSig d-typeCheckMutualSig d = throwErrorMsg $ "typeCheckMutualSig: panic: unexpected declaration " ++ show d---- typeCheckMutualBody measured kindCandidate-typeCheckMutualBody :: Bool -> Kind -> Declaration -> TypeCheck [EDeclaration]-typeCheckMutualBody measured _ (DataDecl n sz co pos tel t cs fields) = do-  -- set name of mutual thing whose body we are checking-  checkingMutual (Just $ DefId DatK $ QName n) $-    ---    typeCheckDataDecl n sz co pos tel t cs fields-typeCheckMutualBody measured@False ki (FunDecl co fun@(Fun ts@(TypeSig n t) n' ar cls)) = do-  checkingMutual (Just $ DefId FunK $ QName n) $ do-    fun' <- typeCheckFunBody co ki fun-    return $ [FunDecl co fun']--typeCheckDataDecl :: Name -> Sized -> Co -> [Pol] -> Telescope -> Type -> [Constructor] -> [Name] -> TypeCheck [EDeclaration]-typeCheckDataDecl n sz co pos0 tel0 t0 cs0 fields = enter (show n) $- (do -- sig <- gets signature-     let params = size tel0-     -- in case we are dealing with a sized type, check that-     -- the polarity annotation (if present) at the size arg. is correct.-     (p', pos, t) <- do-       case sz of-         Sized    -> do-           let polsz = if co==Ind then Pos else Neg-           t <- case t0 of-             Quant Pi (TBind x (Domain domt ki dec)) b | isSize domt ->-               case (polarity dec) of-                 -- insert correct polarity annotation if none was there-                 pol | pol `elem` [Param,Rec] -> return $ Quant Pi (TBind x $ Domain tSize kSize $ setPol polsz dec) b-                 pol | pol == polsz -> return t0-                 pol -> throwErrorMsg $ "sized type " ++ show n ++ " has wrong polarity annotation " ++ show pol ++ " at Size argument, it should be " ++ show polsz-             t0 -> return t0-           return (params + 1, pos0 ++ [polsz], t)-         NotSized -> return (params, pos0, t0)-     -- compute full type signature (including parameter telescope)-     let dt = (teleToType tel0 t)-     echoTySig n dt-     {- mmh, this does not work,  e.g.  data Id (A : Set)(a : A) : A -> Set-        then A -> Set is not distinguishable from Set -> Set (GADT)-        unclear what to do...-     dte <- checkTele tel $ \ tele -> do-       te <- checkSmallType t-       return (teleToType tele te)-      -}-     -- get the target sort ds of the datatype-     Kinded ki0 (ds, dte) <- checkDataType p' dt -- TODO?: use above code?-     let ki = dataKind ki0-     echoKindedTySig ki n dte---     echoTySigE n dte-     v <- whnf emptyEnv dte-     Just fkind <- extractKind v-     -- get the updated telescope which contains the kinds-     let (tel, dtcore) = typeToTele' params dte-     -- compute the constructor telescopes-     cs0 <- mapM (insertConstructorTele tel dtcore) cs0-     let cis = analyzeConstructors co n tel cs0-     let cs  = map reassembleConstructor cis-     addSig n (DataSig { numPars = params-                       , positivity = pos-                       , isSized = sz-                       , isCo = co-                       , symbTyp = v-                       , symbolKind = ki-                       , constructors = cis-                       , etaExpand = False-                       , isTuple = False--- if cs==[] then Just [] else Nothing-{- OLD CODE-                       , constructors = map namePart cs-                       -- at first, do not add destructors, get them out later-                       , destructors  = Nothing-                       , isFamily = t /= Set  -- currently UNUSED- -}-                       , extrTyp = fkind-                       })-     when (sz == Sized) $-           szType co params v--     (isRecList, kcse) <- liftM unzip $-       mapM (typeCheckConstructor n dte sz co pos tel) cs--     -- compute the kind of the data type from the kinds of the-     -- constructor arguments  (mmh, DOES NOT WORK FOR MUTUAL DATA!)-     let newki = case (foldl unionKind NoKind (map kindOf kcse)) of-          NoKind  -> kType -- no non-rec constructor arguments-          AnyKind -> AnyKind-          Kind s s' -> Kind (Set Zero) s' -- a data type is always also a type-     -- echoKindedTySig newki n dte -- 2012-01-26 disabled (repetitive)--     -- solve for size variables-     sol <- solveConstraints-     -- TODO: substitute-     resetConstraints--     -- add destructors only for the constructors that are non-overlapping-     let decls = concat $ map mkDestrs cis-         -- cEtaExp = True means that all field names are present-         -- and constructor is not overlapping with others-         mkDestrs ci | cEtaExp ci = concat $ map mkDestr (cFields ci)-                     | otherwise  = []-         mkDestr fi =-          case (fClass fi) of-             Field (Just (ty, arity, cl)) | not (erased $ fDec fi) && not (emptyName $ fName fi) ->-               let n' = fName fi-                   n  = internal n'-               in-               [MutualFunDecl False Ind [Fun (TypeSig n ty) n' arity [cl]]]-             _ -> []--     when (not (null decls)) $-        traceCheckM $ "generated destructors: " ++ show decls-     declse <- mapM (\ d@(MutualFunDecl False co [Fun (TypeSig n t) n' ar cls]) -> do-                       -- echo $ "G> " ++ showFun co ++ " " ++ show n ++ " : " ++ show t-                       -- echo $ "G> " ++ PP.render (prettyFun n cls)-                       checkingMutual Nothing $ typeCheckDeclaration d)-                 decls--     -- decide whether to eta-expand at this type-     -- all patterns need to be proper and non-overlapping-     -- at least one constructor needs to be eta-expandable-     let isPatIndFam = all (\ ci -> fst (cPatFam ci) /= NotPatterns && cEtaExp ci) cis---                    && not (or overlapList)-     -- do not eta-expand recursive constructors (might not terminate)-     let disableRec ci {-ov-} rec' = ci-          { cRec    = rec'-          , cEtaExp =  cEtaExp ci               -- all destructors present-           && fst (cPatFam ci) /= NotPatterns -- proper pattern to compute indices---           && not ov                          -- non-overlapping-           && not (co==Ind && rec') }         -- non-recursive-     let cis' = zipWith disableRec cis {-overlapList-} isRecList-     let typeEtaExpandable = isPatIndFam && (null cis || any cEtaExp cis')-     traceEtaM $ "data " ++ show n ++ " eta-expandable " ++ show typeEtaExpandable ++ " constructors " ++ show cis'-     modifySig n (\ dataSig ->-                      dataSig { symbolKind = newki-                              , etaExpand = typeEtaExpandable-                              , constructors = cis'-                              , isTuple = length cis' >= 1 && isPatIndFam-                              })-     -- compute extracted data decl-     let (tele, te) = typeToTele' (size tel) dte-     return $ (DataDecl n sz co pos tele te (map valueOf kcse) fields) : concat declse--   ) -- `throwTrace` n  -- in case of an error, add name n to the trace---insertConstructorTele :: Telescope -> Type -> Constructor -> TypeCheck Constructor-insertConstructorTele dtel dt c@(Constructor n Nothing t) = return c-insertConstructorTele dtel dt c@(Constructor n Just{}  t) = do-  res <- computeConstructorTele dtel dt t-  return $ Constructor n (Just res) t---- | @computeConstructorTele dtel t = return ctel@---   Computes the constructor telescope from the target.-computeConstructorTele :: Telescope -> Type -> Type -> TypeCheck (Telescope, [Pattern])-computeConstructorTele dtel dt t = do-  -- target is data name applied to parameters and indices-  let (_, target) = typeToTele t-      (_, es)     = spineView target-      pars = take (size dtel) es-  (cxt, ps) <- checkConstructorParams pars  =<< whnf' (teleToType dtel dt)-  (,ps) . setDec (Dec Param) <$> do local (const cxt) $ contextToTele cxt---- | @checkConstructorParams pars tv = return cxt@---   Checks that parameters @pars@ are patterns elimating the datatype @tv@.---   Returns a context @cxt@ that binds the pattern variables in---   left-to-right order.-checkConstructorParams :: [Expr] -> TVal -> TypeCheck (TCContext, [Pattern])-checkConstructorParams es tv = do-  -- for now, we only allow patterns in parameters-  -- could be extended to unifyable expressions in general-  ps <- mapM (\ e -> maybe (errorParamNotPattern e) return $ exprToPattern e) es-  -- no goals from dot patterns, no absurd pattern-  ([],_,cxt,_,_,_,False) <- checkPatterns defaultDec [] emptySub tv ps-  return (cxt, ps)--  where-    errorParamNotPattern e = throwErrorMsg $-      "expected parameter to be a pattern, but I found " ++ show es---- |---   Precondition: @ce@ is included in the current context.-contextToTele :: TCContext -> TypeCheck Telescope-contextToTele ce = do-  let n     :: Int-      n     = len (context ce)           -- context length-      delta :: Map Int (OneOrTwo Domain)-      delta = cxt (context ce)           -- types for dB levels-      names :: Map Int Name-      names = naming ce                  -- names for dB levels-  -- traverse the context from left to right-  Telescope <$> do-    forM [0..n-1] $ \ k -> do-      x       <- lookupM k names-      One dom <- lookupM k delta-      TBind x <$> Traversable.traverse toExpr dom---- | @typeCheckConstructor d dt sz co pols tel (TypeSig c t)@------   returns True if constructor has recursive argument-typeCheckConstructor :: Name -> Type -> Sized -> Co -> [Pol] -> Telescope -> Constructor -> TypeCheck (Bool, Kinded EConstructor)-typeCheckConstructor d dt sz co pos dtel (Constructor n mctel t) = enter ("constructor " ++ show n) $ do-  let tel = maybe dtel fst mctel-{--  tel <- case cpars of-    -- old style data parameters-    Nothing -> return dtel-    -- new style pattern parameters-    Just{}  -> computeConstructorTele dtel dt t--}-  sig <- gets signature-  let telE = setDec irrelevantDec tel -- need kinded tel!!-    -- parameters are erased in types of constructors-  let tt = teleToType telE t-  echoTySig n tt-  let params = size tel-  -- when checking constructor types,  do NOT resurrect telescope-  --   data T [A : Set] : Set { inn : A -> T A }-  -- should be rejected, since A ~= T A, and T A = T B means A ~=B for arb. A, B!-  -- add data name as spos var, to check positivity-  -- and as NoKind, to compute the true kind from the constructors-  let telWithD = Telescope $ (TBind d $ Domain dt NoKind $ Dec SPos) : telescope tel-  Kinded ki te <- addBinds telWithD $-    checkConType sz t -- do NOT resurrect telescope!!--  -- Check target of constructor.-  dv <- whnf' dt-  let (Telescope argts,target) = typeToTele te-  whenNothing mctel $ -- only for old-style parameters-    addBinds telWithD $ addBinds (Telescope argts) $ checkTarget d dv tel target--  -- Make type of a constructor a singleton type.-  let mkName i n | emptyName n = fresh $ "y" ++ show i-                 | otherwise   = n-      fields = map boundName argts-      argns  = zipWith mkName [0..] $ fields-      argtbs = zipWith (\ n tb -> tb { boundName = n }) argns argts---      core   = (foldl App (con (coToConK co) n) $ map Var argns)-      core   = Record (NamedRec (coToConK co) n False notDotted) $ zip fields $ map Var argns-      tsing  = teleToType (Telescope argtbs) $ Sing core target--  let tte = teleToType telE tsing -- te -- DO resurrect here!-  vt <- whnf' tte--  -- Now, compute the remaining information concerning the constructor.--  {- old code was more accurate, since it evaluated before checking-     for recursive occurrence.-  recOccs <- sposConstructor d 0 pos vt -- get recursive occurrences-  -}-  mutualNames <- asks mutualNames-  let mutOcc tb = not $ null $ List.intersect (d:mutualNames) $ usedDefs $ boundType tb-      recOccs   = map mutOcc argts-      isRec     = or recOccs-  -- fType <- extractType vt -- moved to Extract-  let fType = undefinedFType n-  isSz <- if sz /= Sized then return Nothing else do-    szConstructor d co params vt -- check correct use of sizes-    if co == CoInd then return $ Just $ error "impossible lhs type of coconstructor" else do-    let (x, lte) = mapSnd (teleToType telE) $ mkConLType params te-    echoKindedTySig kTerm n lte-    ltv <- whnf' lte-    return $ Just (x, ltv)--  -- Add the type constructor to the signature.-  let cpars = fmap (mapFst (map boundName . telescope)) mctel -- deletes types, keeps names-  addSigQ n (ConSig cpars isSz recOccs vt d (size dtel) fType)---  let (tele, te) = typeToTele (length tel) tte -- NOT NECESSARY-  echoKindedTySig kTerm n tte-  -- traceM ("kind of " ++ n ++ "'s args: " ++ show ki)---  echoTySigE n tte-  return (isRec, Kinded ki $ Constructor n (fmap (mapFst (const telE)) mctel) te)--typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [EFun]-typeCheckMeasuredFuns co funs0 = do-    -- echo $ show funs-    kfse <- mapM typeCheckFunSig funs0 -- NO LONGER erases measure-    -- use erased type signatures with retaines measure-    let funs = zipWith (\ (Kinded ki ts) f -> f { funTypeSig = ts }) kfse funs0--    -- type check and solve size constraints-    -- return clauses with meta vars resolved-    kcle <- installFuns co (zipWith Kinded (map kindOf kfse) funs) $-      mapM typeCheckFunClauses funs-    let kis  = map kindOf kcle-    let clse = map valueOf kcle-{--    -- replace old clauses by new ones in funs-    let funs' = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clss--}-    -- get the list of mutually defined function names-    let funse = List.zipWith4 Fun-                  (map (fmap eraseMeasure . valueOf) kfse)-                  (map funExtName funs)-                  (map funArity funs)-                  clse-    -- print reconstructed clauses-    mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do-        -- echoR $ n ++ " : " ++ show t-        echoR $ (PP.render $ prettyFun n cls))-      funse-    -- replace in signature by erased clauses-    zipWithM (enableSig co) (zipWith intersectKind kis $ map kindOf kfse) funse-    return $ funse--  where-    enableSig :: Co -> Kind -> Fun -> TypeCheck ()-    enableSig co ki (Fun (TypeSig n t) n' ar' cl') = do-      vt <- whnf' t-      addSig n (FunSig co vt ki ar' cl' True $ undefinedFType $ QName n)-      -- add a let binding for external use-      v <- up False (vFun n) vt-      addSig n' (LetSig vt ki v $ undefinedFType $ QName n')------ type check the body of one function in a mutual block--- type signature is already checked and added to local context-typeCheckFunBody :: Co -> Kind -> Fun -> TypeCheck EFun-typeCheckFunBody co ki0 fun@(Fun ts@(TypeSig n t) n' ar cls0) = do-    -- echo $ show fun-    addFunSig co $ Kinded ki0 fun-    -- type check and solve size constraints-    -- return clauses with meta vars resolved-    Kinded ki clse <- setCo co $ typeCheckFunClauses fun--    -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary-    -- TODO: proper cleanup, proper removal of admissibility check!-    -- clse <- admCheckFunSig co names ts clse--    -- print reconstructed clauses-    -- echoR $ n ++ " : " ++ show t-    echoR $ (PP.render $ prettyFun n clse)-    -- replace in signature by erased clauses-    let fune = Fun ts n' ar clse-    enableSig ki fune-    return fune---typeCheckFuns :: Co -> [Fun] -> TypeCheck [EFun]-typeCheckFuns co funs0 = do-    -- echo $ show funs-    kfse <- mapM typeCheckFunSig funs0-    let kfuns = zipWith (\ (Kinded ki ts) (Fun ts0 n' ar cls) -> Kinded ki (Fun ts n' ar cls)) kfse funs0-    -- zipWithM (addFunSig co) (map kindOf kfse) funs-    mapM (addFunSig co) kfuns-    let funs = map valueOf kfuns-    -- type check and solve size constraints-    -- return clauses with meta vars resolved-    kce <- setCo co $ mapM typeCheckFunClauses funs-    let kis = map kindOf kce-    let clse = map valueOf kce-    -- get the list of mutually defined function names-    let names   = map (\ (Fun (TypeSig n t) n' ar cls) -> n) funs-    -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary-    -- TODO: proper cleanup, proper removal of admissibility check!-    clse <- zipWithM (\ (Fun tysig _ _ _) cls' -> admCheckFunSig co names tysig cls') funs clse-    -- replace old clauses by new ones in funs-    let funse = List.zipWith4 Fun-                  (map valueOf kfse)-                  (map funExtName funs)-                  (map funArity funs)-                  clse---    let funse = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clse-    -- print reconstructed clauses-    mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do-        -- echoR $ n ++ " : " ++ show t-        echoR $ (PP.render $ prettyFun n cls))-      funse-    terminationCheck funse-    -- replace in signature by erased clauses-    zipWithM enableSig kis funse-    return $ funse--addFunSig :: Co -> Kinded Fun -> TypeCheck ()-addFunSig co (Kinded ki (Fun (TypeSig n t) n' ar cl)) = do-    sig <- gets signature-    vt <- whnf' t -- TODO: PROBLEM for internal extraction (would need te here)-    addSig n (FunSig co vt ki ar cl False $ undefinedFType $ QName n) --not yet type checked / termination checked---- ADMCHECK FOR COFUN is not taking place in checking the lhs--- TODO: proper analysis for size patterns!--- admCheckFunSig mutualNames (TypeSig thisName thisType, clauses)-admCheckFunSig :: Co -> [Name] -> TypeSig -> [Clause] -> TypeCheck [Clause]-admCheckFunSig CoInd  mutualNames (TypeSig n t) cls = return cls-admCheckFunSig co@Ind mutualNames (TypeSig n t) cls = traceAdm ("admCheckFunSig: checking admissibility of " ++ show n ++ " : " ++ show t) $-   (-    do -- a function is not recursive if did does not mention any of the-       -- mutually defined function names-       let usedNames = rhsDefs cls-       let notRecursive = all (\ n -> not (n `elem` usedNames)) mutualNames-       -- for non-recursive functions, we can skip the admissibility check-       if notRecursive then-          -- trace ("function " ++ n ++ " is not recursive") $-            return cls-        else -- trace ("function " ++ n ++ " is recursive ") $-          do vt <- whnf' t-             admFunDef co cls vt-    ) `throwTrace` ("checking type of " ++ show n ++ " for admissibility")---enableSig :: Kind -> Fun -> TypeCheck ()-enableSig ki (Fun (TypeSig n _) n' ar' cl') = do-  (FunSig co vt ki0 ar cl _ ftyp) <- lookupSymb n-  addSig n (FunSig co vt (intersectKind ki ki0) ar cl' True ftyp)-  -- add a let binding for external use-  v <- up False (vFun n) vt-  addSig n' (LetSig vt ki v ftyp)----- typeCheckFunSig (TypeSig thisName thisType, clauses)-typeCheckFunSig :: Fun -> TypeCheck (Kinded ETypeSig)-typeCheckFunSig (Fun (TypeSig n t) n' ar cls) = enter ("type of " ++ show n) $ do-  echoTySig n t-  Kinded ki0 te <- checkType t-  -- let te = eraseMeasure te0-  let ki = predKind ki0-  echoKindedTySig ki n (eraseMeasure te)---  echoTySigE n te-  return $ Kinded ki $ TypeSig n te--typeCheckFunClauses :: Fun -> TypeCheck (Kinded [EClause])-typeCheckFunClauses (Fun (TypeSig n t) n' ar cl) = enter (show n) $-   do result@(Kinded _ cle) <- checkFun t cl-      -- traceCheck (show (TypeSig n t)) $-       -- traceCheck (show cl') $-      -- echo $ PP.render $ prettyFun n cle-      return result---- checkConType sz t = Kinded ki te--- the returned kind is the kind of the constructor arguments--- check that result is a universe---  ( params were already checked by checkDataType and are not included in t )--- called initially in the context consisting of the parameter telescope-checkConType :: Sized -> Expr -> TypeCheck (Kinded Extr)-checkConType NotSized t = checkConType' t-checkConType Sized t =-    case t of-      Quant Pi tb@(TBind _ (Domain t1 _ _)) t2 | isSize t1 -> do-             addBind (mapDec (const paramDec) tb) $ do  -- size is parametric in constructor type-               Kinded ki t2e <- checkConType' t2-               return $ Kinded ki $ Quant Pi (mapDec (const irrelevantDec) tb) t2e -- size is irrelevant in constructor-      _ -> throwErrorMsg $ "checkConType: expecting size quantification, found " ++ show t--checkConType' :: Expr -> TypeCheck (Kinded Extr)-checkConType' t = do-  (s, kte) <- checkingCon True $ inferType t-  case s of-    Set{} -> return kte-    CoSet{} -> return kte-    _ -> throwErrorMsg $ "checkConType: type " ++ show t ++ " of constructor not a universe"---- check that the data type and the parameter arguments (written down like declared in telescope)--- precondition: target tg type checks in current context-checkTarget :: Name -> TVal -> Telescope -> Type -> TypeCheck ()-checkTarget d dv tel tg = do-  tv <- whnf' tg-  case tv of-    VApp (VDef (DefId DatK (QName n))) vs | n == d -> do-      telvs <- mapM (\ tb -> whnf' (Var (boundName tb))) $ telescope tel-      enter ("checking datatype parameters in constructor target") $-        leqVals' N mixed (One dv) (take (size tel) vs) telvs-      return ()-    _ -> throwErrorMsg $ "constructor should produce something in data type " ++ show d--{- RETIRED (syntactic check)-checkTarget :: Name -> Telescope -> Type -> TypeCheck ()-checkTarget d tel tg =-    case spineView tg of-      (Def (DefId Dat n), args) | n == d -> checkParams tel (take (length tel) args)-      _ -> throwErrorMsg $ "target mismatch"  ++ show tg--    where checkParams :: Telescope -> [Expr] -> TypeCheck ()-          checkParams [] [] = return ()-          checkParams (tb : tl) ((Var n') : el) | boundName tb == n'-            = checkParams tl el-          checkParams tl al = throwErrorMsg $ "target param mismatch " ++-            d ++ " " ++ show tel ++ " != " ++ show tg ++ "\ncheckParams " ++ show tl ++ " " ++ show al ++ " failed"--}---- check that params are types--- check that arguments are stypes--- check that target is set-checkDataType :: Int -> Expr -> TypeCheck (Kinded (Sort Expr, Extr))-checkDataType p e = do-  traceCheckM ("checkDataType " ++ show e ++ " p=" ++ show p)-  case e of-     Quant Pi tb@(TBind x (Domain t1 _ dec)) t2 -> do-       k <- getLen-       traceCheckM ("length of context = " ++ show k)-       -- t1e <- checkingDom $ if k <= p then checkType t1 else checkSmallType t1-       (s1, Kinded ki0 t1e) <- checkingDom $ inferType t1-       let ki1 = predKind ki0-       addBind (TBind x (Domain t1 ki1 defaultDec)) $ do-         Kinded ki2 (s, t2e) <- checkDataType p t2-         -- when k <= p $ ltSort s1 s -- check size of indices (disabled)-         return $ Kinded ki2 (s, Quant Pi (TBind x (Domain t1e ki1 dec)) t2e)-     Sort s@(Set e1)   -> do-       (_, e1e) <- checkLevel e1-       return $ Kinded (kUniv e1e) (s, Sort $ Set e1e)-     Sort s@(CoSet e1) -> do-       e1e <- checkSize e1-       return $ Kinded (kUniv Zero) (s, Sort $ CoSet e1e)-     _ -> throwErrorMsg "doesn't target Set or CoSet"--{--checkSize :: Expr -> TypeCheck Extr-checkSize Infty = return Infty-checkSize e = valueOf <$> checkExpr e vSize--}--checkSize :: Expr -> TypeCheck Extr-checkSize e =-  case e of-    Meta i  -> do-      ren <- asks renaming-      addMeta ren i-      return e-    e       -> inferSize e--inferSize :: Expr -> TypeCheck Extr-inferSize e =-  case e of-    Zero  -> return e-    Infty -> return e-    Succ e  -> Succ <$> checkSize e-    Plus es -> Plus <$> mapM checkSize es-    Max  es -> maxE <$> mapM checkSize es-    e -> do-      (v, Kinded ki e) <- inferExpr e-      subtype v vSize-      return e--checkBelow :: Expr -> LtLe -> Val -> TypeCheck Extr-checkBelow e Le VInfty = checkSize e-checkBelow e ltle v = do-  e' <- checkSize e-  v' <- whnf' e-  leSize ltle Pos v' v-  return e'----- checkLevel e = (value of e, ee)--- if e : Size and value of e != Infty-checkLevel :: Expr -> TypeCheck (Val, Extr)-checkLevel e = do-  Kinded _ ee <- checkExpr e vSize-  v  <- whnf' e-  when (v == VInfty) $ recoverFail $ "# is not a valid universe level"-  return (v, ee)--{- Kind inference--          i    : Size              : Type-      t : Nat  : Set  : Set1 : ... : Type = Set\omega-  p : P : Prop : Set  : ...--Functional, cumulative PTS (s,s',s') written (s,s')--  (Size,s)   s != Size    size-dependency-  (s,Prop)                impredicative Prop-  (Set_i,Set_j)  i <= j   predicativity--Kind    can be used to construct Kinds-term t  terms, types, universes, proofs, propositions-type T  types, universes, propositions-size i  types, universes, propositions-prf  p  proofs-pred P  types, universes, propositions--We like to infer kinds of expressions--  Tm < Set < Set1 < Set2 < ...--For  t : A  if kind(A) = Tm then t is a term,-                       = Set then t is a type,-                       = Set1 then t is a type1 (e.g, a universe) ...--Then,  if  t : (x : A) -> B-      and  kind(A) `irrelevantFor` kind(B)   [ with irrelevantFor := > ]--we can change the type signature to--           t : [x : A] -> B--This is because you cannot eliminate a type to produce a term.--  kind(Set)  = Set-  kind(Size) = Size -- this means that we treat sizes as types, they cannot-  kind(s)    = s    -- if s is a sort-  kind((x : A) -> B) = kind(B)-  kind(A : Set0) = Tm-  kind(A : Prop) = Prf-  kind(A : Size) = <<impossible>>-  kind(A : Setk) = k-1--irrFor Tm  _    = False-irrFor Ty Tm    = True-irrFor Ty Prf   = True-irrFor Ty _     = False-irrFor Size Tm  = True-irrFor Size Prf = True--One problem is that we cannot infer exact kinds, e.g.--  fun T : Bool -> Set 1 -- T is a type-  { T true  = Bool      -- T true is a type-  ; T false = Set 0     -- T false is a universe-  }--T is either a type or a universe.  So we can only assign intervals.-This is like in Augustsson's Cayenne [not in his paper, though].--A datatype is always a type.  A size is a type.-A constructor is always a term.---}----- type checking---- checkExpr e tv = (e', ki)--- e' is the version of e with erasure marker at irrelevant positions--- ki is the kind of e (Tm, Ty, Set ...)--- ki is at most the predecessor of the sort of tv------ this is *internal* extraction in the style of Barras and Bernardo--- e.g., does not prune t : Id A a b--- thus, we can use the pruned version for evaluation!-checkExpr :: Expr -> TVal -> TypeCheck (Kinded Extr)-checkExpr e v = do-  l <- getLen-  enterDoc (text ("checkExpr " ++ show l ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do--   ce <- ask-   traceCheck ("checkExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " : " ++ show v ++ " in env" ++ show (environ ce)) $ do--    (case (e, v) of--{- In the presence of full bracket types,-   we could implement the following "resurrecting version of let"--   Gamma |- s : [A]-   Gamma, x:A |- t : C   Gamma, x:A, y:A |- t = t[y/x] : C-   --------------------------------------------------------   Gamma |- let x:[A] = s in t : C-- -}--      (App (Lam dec x f) e, v) | inferable e -> checkLet dec x emptyTel Nothing e f v--{--      (LLet (TBind x (Domain Nothing _ dec)) e1 e2, v) -> checkUntypedLet x dec e1 e2 v-      (LLet (TBind x (Domain (Just t1) _ dec)) e1 e2, v) -> checkTypedLet x t1 dec e1 e2 v--}-      (LLet (TBind x (Domain mt _ dec)) tel e1 e2, v) -> checkLet dec x tel mt e1 e2 v--      (Case (Var x) Nothing [Clause _ [SuccP (VarP y)] (Just rhs)], v) -> do-          (tv, _) <- resurrect $ inferExpr (Var x)-          subtype tv vSize-          vx@(VGen i) <- whnf' (Var x)-          endsInSizedCo i v-          let dom = Domain vSize kSize defaultDec-          newWithGen y dom $ \ j vy -> do-            let vp = VSucc vy-            addSizeRel j 1 i $-              addRewrite (Rewrite vx vp) [v] $ \ [v'] -> do-                Kinded ki2 rhse <- checkRHS emptySub rhs v'-                return $ Kinded ki2 $ Case (Var x) (Just tSize) [Clause [TBind y dom] [SuccP (VarP y)] (Just rhse)]---      (Case e mt cs, v) -> do-          (tv, t, Kinded ki1 ee) <- checkOrInfer neutralDec e mt-          ve <- whnf' ee-          -- tv' <- sing' ee tv -- DOES NOT WORK-          Kinded ki2 cle <- checkCases ve (arrow tv v) cs-          return $ Kinded ki2 $ Case ee (Just t) cle-{--      (Case e Nothing cs, _) -> do-          (tv, Kinded ki1 ee) <- inferExpr e-          ve <- whnf' ee-          -- tv' <- sing' ee tv -- DOES NOT WORK-          Kinded ki2 cle <- checkCases ve (arrow tv v) cs-          t <- toExpr tv-          return $ Kinded ki2 $ Case ee (Just t) cle--}-      (_, VGuard beta bv) ->-        addBoundHyp beta $ checkExpr e bv--      (e,v) | inferable e -> do-          (v2, Kinded ki1 ee) <- inferExpr e-          checkSubtype ee v2 v-          return $ Kinded ki1 ee--      _ -> checkForced e v--      ) -- >> (trace ("checkExpr successful: " ++ show e ++ ":" ++ show v) $ return ())---- | checkLet @let .x tel : t = e1 in e2@-checkLet :: Dec -> Name -> Telescope -> Maybe Type -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)-checkLet dec x tel mt1 e1 e2 v = do-  (v_t1, t1e, Kinded ki1 e1e) <- checkLetDef dec tel mt1 e1---  (v_t1, t1e, Kinded ki1 e1e) <- checkOrInfer dec e1 mt1-  checkLetBody x t1e v_t1 ki1 dec e1e e2 v---- | checkLetDef @.x tel : t = e@ becomes @.x : tel -> t = \ tel -> e@-checkLetDef :: Dec -> Telescope -> Maybe Type -> Expr -> TypeCheck (TVal, EType, Kinded Extr)-checkLetDef dec tel mt e = local (\ cxt -> cxt {consistencyCheck = True}) $ do-  -- 2013-04-01-  -- since a let telescope is treated like a lambda abstraction-  -- and the let-defined symbol reduces by itself, we need to-  -- do the context consistency check at each introduction.-  (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer dec e mt-  te <- return $ teleToType tel te-  ee <- return $ teleLam tel ee-  vt <- whnf' te-  return (vt, te, Kinded ki ee)--{--checkTypedLet :: Name -> Type -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)-checkTypedLet x t1 dec e1 e2 v = do-  Kinded kit t1e <- checkType t1-  v_t1 <- whnf' t1-  Kinded ki0 e1e <- applyDec dec $ checkExpr e1 v_t1-  let ki1 = intersectKind ki0 (predKind kit)-  checkLetBody x t1e v_t1 ki1 dec e1e e2 v-{--  v_e1 <- whnf' e1-  new x (Domain v_t1 ki1 dec) $ \ vx -> do-    addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do-      Kinded ki2 e2e <- checkExpr e2 v'-      return $ Kinded ki2 $ LLet (TBind x (Domain t1e ki1 dec)) e1e e2e  -- if e2e==Irr then Irr else LLet n t1e e1e e2e--}--checkUntypedLet :: Name -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)-checkUntypedLet x dec e1 e2 v = do-  (v_t1, Kinded ki1 e1e) <- applyDec dec $ inferExpr e1-  v_e1 <- whnf' e1-  t1e <- toExpr v_t1-  checkLetBody x t1e v_t1 ki1 dec e1e e2 v--}--checkLetBody :: Name -> EType -> TVal -> Kind -> Dec -> Extr -> Expr -> TVal -> TypeCheck (Kinded Extr)-checkLetBody x t1e v_t1 ki1 dec e1e e2 v = do-  v_e1 <- whnf' e1e-  new x (Domain v_t1 ki1 dec) $ \ vx -> do-    addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do-      Kinded ki2 e2e <- checkExpr e2 v'-      return $ Kinded ki2 $ LLet (TBind x (Domain (Just t1e) ki1 dec)) emptyTel e1e e2e-{---- Dependent let: not checkable in rho;Delta style---            v_e1 <- whnf rho e1---            checkExpr (update rho n v_e1) (v_t1 : delta) e2 v--}---- | @checkPair e1 e2 y dom env b@ checks @Pair e1 e2@ against---   @VQuant Sigma y dom env b@.-checkPair :: Expr -> Expr -> Name -> Domain -> FVal -> TypeCheck (Kinded Expr)-checkPair e1 e2 y dom@(Domain av ki dec) fv = do-  case av of-    VBelow Lt VInfty -> do-      lowerSemi <- underAbs y dom fv $ \ i _ bv -> lowerSemiCont i bv-      continue $ if lowerSemi then VBelow Le VInfty else av-    _ -> continue av-  where-    continue av = do-      Kinded k1 e1 <- applyDec dec $ checkExpr e1 av-      v1 <- whnf' e1-      bv <- app fv v1-      Kinded k2 e2 <- checkExpr e2 bv-      return $ Kinded (unionKind k1 k2) $ Pair (maybeErase dec e1) e2---- check expression after forcing the type-checkForced :: Expr -> TVal -> TypeCheck (Kinded Expr)-checkForced e v = do-  ren <- asks renaming-  v   <- force v---  enter ("checkForced " ++ show ren ++ " |- " ++ show e ++ " : " ++ show v) $ do-  enterDoc (text ("checkForced " ++ show ren ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do-    case (e,v) of-{--      (_, VGuard (Bound (Measure [VGen i]) (Measure [VGen j])) bv) ->-        addSizeRel i j $ checkForced e bv--}-      (_, VGuard beta bv) ->-        addBoundHyp beta $ checkForced e bv--      (Pair e1 e2, VQuant Sigma y dom@(Domain av ki dec) fv) ->-        checkPair e1 e2 y dom fv--      (Record ri rs, t@(VApp (VDef (DefId DatK d)) vl)) -> do-         let fail1 = failDoc (text "expected" <+> prettyTCM t <+> text "to be a record type")---         DataSig { numPars, isTuple } <- lookupSymb d---         unless isTuple $ fail1-         mfs <- getFieldsAtType d vl-         case mfs of-           Nothing -> fail1-           Just ptv -> do-             let checkField :: (Name, Expr) -> TypeCheck (Kinded [(Name,Expr)]) -> TypeCheck (Kinded [(Name,Expr)])-                 checkField (p,e) cont =-                  case lookup p ptv of-                    Nothing -> failDoc (prettyTCM p <+> text "is not a field of record" <+> prettyTCM t)-                    Just tv -> do-                      tv <- piApp tv VIrr -- remove record argument (cannot be dependent!)-                      Kinded k e <- checkExpr e tv-                      Kinded k' es <- cont-                      return $ Kinded (unionKind k k') ((p,e) : es)-             Kinded k rs <- foldr checkField (return $ Kinded NoKind []) rs-             return $ Kinded k $ Record ri rs---{- OLD:-Following Awodey/Bauer 2001, the following rule is valid--   Gamma, x:A |- t : B    Gamma, x:A, y:A |- t = t[y/x] : B-   ---------------------------------------------------------   Gamma |- \xt : Pi x:[A]. B--      (Lam _ y e1, VPi dec x va env t1) -> do-          rho <- getEnv  -- get the environment corresponding to Gamma-          new y (Domain va (resurrectDec dec)) $ \ vy -> do-            v_t1 <- whnf (update env x vy) t1-            -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1-            e1e <- checkExpr e1 v_t1-            when (erased dec) $ do  -- now check invariance of the e1-              new y (Domain va (resurrectDec dec)) $ \ vy' -> do-                ve  <- whnf (update rho y vy)  e1e-                ve' <- whnf (update rho y vy') e1e-                eqVal v_t1 ve ve'  -- BUT: ve' does not have type v_t1 !?-            -- prune the lambda if body has been pruned-            return $ if e1e==Irr then Irr else Lam y e1e- -}---- NOW just my rule (LICS 2010 draft) a la Barras/Bernardo--      (Lam _ y e1, VQuant Pi x dom fv) -> do-          -- rho <- getEnv  -- get the environment corresponding to Gamma-          underAbs y dom fv $ \ _ vy bv -> do-            -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1-            Kinded ki1 e1e <- checkExpr e1 bv-            -- the kind of a lambda is the kind of its body-            return $ Kinded ki1 $ Lam (decor dom) y e1e--      -- lone projection: eta-expand!-      (Proj Pre p, VQuant Pi x dom fv) -> do-         let y = nonEmptyName x "y"-         checkForced (Lam (decor dom) y $ App e (Var y)) v-{--      -- should be subsumed by checkBelow:-      (e, v) | isVSize v -> Kinded kSize <$> checkSize e--}-{-  MOVED to checkSize--      -- metavariables must have type size-      (Meta i, _) | isVSize v -> do-        addMeta ren i-        return $ Kinded kSize $ Meta i--     (Infty, v) | isVSize v -> return $ Kinded kSize $ Infty-      (Zero, v) | isVSize v -> return $ Kinded kSize $ Zero--      (Plus es, v) | isVSize v -> do-              ese <- mapM checkSize es-              return $ Kinded kSize $ Plus ese--      (Max es, v) | isVSize v -> do-              ese <- mapM checkSize es-              return $ Kinded kSize $ Max ese--      (Succ e2, v) | isVSize v -> do-              e2e <- checkSize e2-              return $ Kinded kSize $ Succ e2e--}--      (e, VBelow ltle v) -> Kinded kSize <$> checkBelow e ltle v-{--              -- prune sizes-              return $ if e2e==Irr then Irr else Succ e2e--}-      (e,v) -> do-        case spineView e of--          -- unfold defined patterns-          (h@(Def (DefId (ConK DefPat) c)), es) -> do-             PatSig xs pat _ <- lookupSymbQ c-             let (xs1, xs2) = splitAt (length es) xs-                 phi x      = maybe (Var x) id $ lookup x (zip xs1 es)-                 body       = parSubst phi (patternToExpr pat)-                 e          = foldr (Lam defaultDec) body xs2-             checkForced e v--          -- check constructor term-          (h@(Def (DefId (ConK co) c)), es) -> checkConTerm co c es v-{--          (h@(Def (DefId (ConK co) c)), es) -> do-             tv <- conType c v-             (knes, dv) <- checkSpine es tv-             let e = foldl App h $ map (snd . valueOf) knes-             checkSubtype e dv v-             e <- etaExpandPis e dv -- a bit similiar to checkSubtype, which computes a singleton-             return $ Kinded kTerm $ e--}-          -- else infer-          _ -> do-            (v2,kee) <- inferExpr e-            checkSubtype (valueOf kee) v2 v-            return kee---- | Check (partially applied) constructor term, eta-expand it and turn it---   into a named record.-checkConTerm :: ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Extr)-checkConTerm co c es v = do-  case v of-    VQuant Pi x dom fv -> do-      let y = freshen $ nonEmptyName x "y"-      underAbs y dom fv $ \ _ _ bv -> do-        Kinded ki ee <- checkConTerm co c (es ++ [Var y]) bv-        return $ Kinded ki $ Lam (decor dom) y ee-    _ -> do-      c <- disambigCon c v-      tv <- conType c v-      (knes, dv) <- checkSpine es tv-      let ee = Record (NamedRec co c False notDotted) $ map valueOf knes-      checkSubtype ee dv v-      return $ Kinded kTerm ee--{---- | Check (partially applied) constructor term, eta-expand it and turn it---   into a named record.-checkConTerm :: ConK -> Name -> [Expr] -> TVal -> TypeCheck (Kinded Extr)-checkConTerm co c es v = do-  tv <- conType c v-  (knes, dv) <- checkSpine es tv-  let e0 = foldl App (Def (DefId (ConK co) c)) $ map (snd . valueOf) knes-  checkSubtype e0 dv v-  (vTel, _) <- telView dv-  let xs   = map (boundName . snd) vTel-      decs = map (decor . boundDom . snd) vTel-      ys   = map freshen xs-      rs   = map valueOf knes ++ (zip xs $ map Var ys)-      e1   = Record (NamedRec co c False) rs-      e    = foldr (uncurry Lam) e1 (zip decs ys)-  return $ Kinded kTerm e--}--{---- | Only eta-expand at function types, do not force.-etaExpandPis :: Expr -> TVal -> TypeCheck Expr-etaExpandPis e tv = do-  case tv of-    VQuant Pi x dom env b -> new x dom $ \ xv -> do-      let y = freshen x-      Lam (decor dom) y <$> do-        etaExpandPis (App e (Var y)) =<< whnf (update env x xv) b-    _ -> return e--}--checkSpine :: [Expr] -> TVal -> TypeCheck ([Kinded (Name, Extr)], TVal)-checkSpine [] tv = return ([], tv)-checkSpine (e : es) tv = do-  (kne, tv) <- checkApp e tv-  (knes, tv) <- checkSpine es tv-  return (kne : knes, tv)--maybeErase dec = if erased dec then erasedExpr else id---- | checking e against (x : A) -> B returns (x,e) and B[e/x]-checkApp :: Expr -> TVal -> TypeCheck (Kinded (Name, Extr), TVal)-checkApp e2 v = do-  v <- force v -- if v is a corecursively defined type in Set, unfold!-  enter ("checkApp " ++ show v ++ " eliminated by " ++ show e2) $ do-  case v of-    VQuant Pi x dom@(Domain av@(VBelow Lt VInfty) _ dec) fv -> do-      upperSemi <- underAbs x dom fv $ \ i _ bv -> upperSemiCont i bv-      continue $ if upperSemi then VQuant Pi x dom{ typ = VBelow Le VInfty} fv-                 else v-    _ -> continue v- where-  continue v = case v of-    VQuant Pi x (Domain av _ dec) fv -> do-       (ki, v2, e2e) <- do-         if inferable e2 then do-       -- if e2 has a singleton type, we should not take v2 = whnf e2-       -- but use the single value of e2-       -- this is against the spirit of bidir. checking-              -- if checking a type we need to resurrect-              (av', Kinded ki e2e) <- applyDec dec $ inferExpr e2-              case av' of-                 VSing v2 av'' -> do subtype av' av-                                     return (ki, v2, e2e)-                 _ -> do checkSubtype e2e av' av-                         v2 <- whnf' e2e-                         return (ki, v2, e2e)-            else do-              Kinded ki e2e <- applyDec dec $ checkExpr e2 av-              v2 <- whnf' e2e-              return (ki, v2, e2e)-       bv <- app fv v2-       -- the kind of the application is the kind of its head-       return (Kinded ki $ (x,) $ maybeErase dec e2e, bv)-       -- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e])-    _ -> throwErrorMsg $ "checking application to " ++ show e2 ++ ": expected function type, found " ++ show v----- checkSubtype  expr : infered_type <= ascribed_type-checkSubtype :: Expr -> TVal -> TVal -> TypeCheck ()-checkSubtype e v2 v = do-    rho <- getEnv-    traceSingM $ "computing singleton <" ++ show e ++ " : " ++ show v2 ++ ">" -- ++ " in environment " ++ show rho-    v2principal <- sing rho e v2-    traceSingM $ "subtype checking " ++ show v2principal ++ " ?<= " ++ show v ++ " in environment " ++ show rho-    subtype v2principal v----- ptsRule s1 s2 = s  if (s1,s2,s) is a valid rule--- precondition: s1,s2 are proper sorts, i.e., not Size or Tm-ptsRule :: Bool -> Sort Val -> Sort Val -> TypeCheck (Sort Val)-ptsRule er s1 s2 = do-  cxt <- ask-  let parametric = checkingConType cxt  -- are we dealing with a parametric pi?-  let err = "ptsRule " ++ show (s1,s2) ++ " " ++ (if parametric then "(in type of constructor)" else "") ++ ": "-  case (s1,s2) of-    (Set VInfty,_) -> throwErrorMsg $ err ++ "domain too big"-    (Set v1, Set v2) ->-      if parametric then do-         unless er $ leqSize Pos v1 v2 -- when we are checking a constructor, to reject-         {- data Bad : Set { bad : Set -> Bad } -}-         return s2-       else return $ Set $ maxSize [v1,v2]-    (CoSet v1, Set VZero)-       | parametric   -> return $ CoSet v1-       | v1 == VInfty -> return $ Set VZero-       | otherwise    -> throwErrorMsg $ err ++ "domain cannot be sized"-    (CoSet v1, CoSet v2)-       | parametric   -> do-           let v2' = maybe v2 id $ predSize v2-           case minSize v1 v2 of-             Just v  -> return $ CoSet v-             Nothing -> throwErrorMsg $ err ++ "min" ++ show (v1,v2) ++ " does not exist"-       | v1 == VInfty -> return $ CoSet $ succSize v2-       | otherwise    -> throwErrorMsg $ err ++ "domain cannot be sized"-    _ -> return s2--checkOrInfer :: Dec -> Expr -> Maybe Type -> TypeCheck (TVal, EType, Kinded Extr)-checkOrInfer dec e Nothing = do-  (tv, ke) <- applyDec dec $ inferExpr e-  te <- toExpr tv-  return (tv, te, ke)-checkOrInfer dec e (Just t) = do-  Kinded kt te <- checkType t-  tv <- whnf' te-  Kinded ke ee <- applyDec dec $ checkExpr e tv-  let ki = intersectKind ke $ predKind kt-  return $ (tv, te, Kinded ki ee)---- inferType t = (s, te)-inferType :: Expr -> TypeCheck (Sort Val, Kinded Extr)-inferType t = do-  (sv, te) <- inferExpr t-  case sv of-    VSort s | not (s `elem` map SortC [Tm,Size]) -> return (s,te)-    _ -> throwErrorMsg $ "inferExpr: expected " ++ show t ++ " to be a type!"---- inferExpr e = (tv, s, ee)--- input : expr e | inferable e--- output: type tv, kind s, and erased form ee of e--- the kind tells whether e is a term, a size, a set, ...-inferExpr :: Expr -> TypeCheck (TVal, Kinded Extr)-inferExpr e = do-  (tv, ee) <- inferExpr' e-  case tv of-    VGuard beta vb -> do-      checkGuard beta-      return (vb, ee)-    _ -> return (tv, ee)--inferProj :: Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Extr)-inferProj e1 fx p = checkingCon False $ do-            (v, Kinded ki1 e1e) <- inferExpr e1-{--            let fail1 = failDoc (text "expected" <+> prettyTCM e1 <+> text "to be of record type when taking the projection" <+> text p <> comma <+> text "but found type" <+> prettyTCM v)-            let fail2 = failDoc (text "record" <+> prettyTCM e1 <+> text "of type" <+> prettyTCM v <+> text "does not have field" <+> text p)--}-            v <- force v -- if v is a corecursively defined type in Set, unfold!-            tv <- projectType v p =<< whnf' e1e-            return (tv, Kinded ki1 (proj e1e fx p))-{--            case v of-              VApp (VDef (DefId Dat d)) vl -> do-                mfs <- getFieldsAtType d vl-                case mfs of-                  Nothing -> fail1-                  Just ptvs ->-                    case lookup p ptvs of-                      Nothing -> fail2-                      Just tv -> do-                        tv <- piApp tv VIrr -- cut of record arg-                        return (tv, Kinded ki1 (App e1e (Proj p)))-              _ -> fail1--}----- inferExpr' might return a VGuard, this is removed in inferExpr--- the returned kind for constructor type is computed as the union--- of the kinds of the non-erased arguments--- otherwise it is the kind of the target-inferExpr' :: Expr -> TypeCheck (TVal, Kinded Extr)-inferExpr' e = enter ("inferExpr' " ++ show e) $-  let returnSing (Kinded ki ee) tv = do-        tv' <- sing' ee tv-        return (tv', Kinded ki ee)-  in-    (case e of--      Var x -> do-        traceCheckM ("infer variable " ++ show x)-        item <- lookupName1 x-        traceCheckM ("infer variable: retrieved item ")-        let dom = domain item-            av  = typ dom-        traceCheckM ("infer variable: " ++ show av)-        enterDoc (text "inferExpr: variable" <+> prettyTCM x <+> colon <+> prettyTCM av <+> text "may not occur") $ do-          let dec  = decor dom-              udec = upperDec item-              pol  = polarity dec-              upol = polarity udec-          when (erased dec && not (erased udec)) $-            recoverFail ", because it is marked as erased"-          enter ", because of polarity" $-            leqPolM pol upol-        traceCheckM ("infer variable returns")-        traceCheckM ("infer variable " ++ show x ++ " : " ++ show av)-        return $ (av, Kinded (kind dom) $ Var x)-{--        let err = "inferExpr: variable " ++ x ++ " : " ++ show (typ item) ++-                  " may not occur"-        let dec = decor item-        let pol = polarity dec-        if erased dec then-          throwErrorMsg $ err ++ ", because it is marked as erased"-         else if not (leqPol pol SPos) then-          throwErrorMsg $ err ++ ", because it has polarity " ++ show pol-         else do-           -- traceCheckM ("infer variable " ++ x ++ " : " ++ show  (typ item))-           return $ (typ item, Var x) -- TODO: (typ item, kind item, Var x)--}--      -- for constants, the kind coincides with the type!-      Sort (CoSet e) -> do-        ee <- checkSize e-        return (VSort (Set (VSucc VZero)), Kinded (kUniv Zero) $ Sort $ CoSet ee)-      Sort (Set e) ->  do-        (v, ee) <- checkLevel e-        return (VSort (Set (succSize v)), Kinded (kUniv ee) $ Sort $ Set ee)-      Sort (SortC Size) -> return (vTSize, Kinded kTSize $ e)-      Zero -> return (vSize, Kinded kSize Zero)-      Infty -> return (vSize, Kinded kSize Infty)-      Below ltle e -> do-        ee <- checkSize e-        return (vTSize, Kinded kTSize $ Below ltle ee)--      Quant pisig (TBind n (Domain t1 _ dec)) t2 -> do-        -- make sure that in a constructor declaration the constructor args are-        -- mixed-variant (there is no subtyping between constrs anyway)-        checkCon <- asks checkingConType-{- TODO-        when (checkCon && polarity dec /= Mixed) $-          throwErrorMsg $ "constructor arguments must be declared mixed-variant"--}-        (s1, Kinded ki0 t1e) <- (if pisig==Pi then checkingDom else id) $-          checkingCon False $ inferType t1 -- switch off parametric Pi-        -- the kind of the bound variable is the precedessor of the kind of its type-        let ki1 = predKind ki0-        addBind (TBind n (Domain t1e ki1 $ defaultDec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric)-        -- TODO:-        -- addBind (TBind n (Domain t1e ki1 $ coDomainDec dec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric)-          (s2, Kinded ki2 t2e) <- inferType t2-          ce <- ask-          let er = erased dec-          s <- if impredicative ce && er && s2 == Set VZero then return s2 else ptsRule er s1 s2 -- Impredicativity!-          -- improve erasure annotation: irrelevant arguments can be erased!-          let (ki',dec') = if checkCon then-                 -- in case of constructor types the kind is the union-                 -- of the kinds of the constructor arguments-                 if ki0 == kTSize then (ki2, irrelevantDec)-                  else if erased dec then (ki2, dec) -- do not count erased args in-                 else (unionKind ki0 ki2, dec)-                else (ki2, if argKind ki0 `irrelevantFor` (predKind ki2)-                            then irrelevantDec-                            else dec)-          -- the kind of the Pi-type is the kind of its target (codomain)-          return (VSort s, Kinded ki' $ Quant pisig (TBind n (Domain t1e ki1 dec')) t2e)--      Quant Pi (TMeasure (Measure mu)) t2 -> do-        mue <- mapM checkSize mu-        (s, Kinded ki2 t2e) <- inferType t2-        return (VSort s, Kinded ki2 $ Quant Pi (TMeasure (Measure mue)) t2e)--      Quant Pi (TBound (Bound ltle (Measure mu) (Measure mu'))) t2 -> do-        (mue,mue') <- checkingDom $ do-          mue  <- checkingDom $ mapM checkSize mu-          mue' <- mapM checkSize mu'-          return (mue,mue')-        (s, Kinded ki2 t2e) <- inferType t2-        return (VSort s, Kinded ki2 $ Quant Pi (TBound (Bound ltle (Measure mue) (Measure mue'))) t2e)--      Sing e1 t -> do-        (s, Kinded ki te) <- inferType t-        tv <- whnf' te-        Kinded ki1 e1e <- checkExpr e1 tv-        return (VSort $ s, Kinded (intersectKind ki $ succKind ki1) -- not sure how useful the intersection is, maybe just ki is good enough-                             $ Sing e1e te)--{- Not safe to infer pairs because of irrelevance!-      Pair e1 e2 -> do-        (tv1, Kinded k1 e1) <- inferExpr e1-        (tv2, Kinded k2 e2) <- inferExpr e2-        let ki = unionKind k1 k2-            tv = prod tv1 tv2-        return (tv, Kinded ki $ Pair e1 e2)--}--      App (Proj Pre p) e  -> inferProj e Pre p-      App e (Proj Post p) -> inferProj e Post p--      App e1 e2 -> checkingCon False $ do-        (v, Kinded ki1 e1e) <- inferExpr e1-        (Kinded ki2 (_, e2e), bv) <- checkApp e2 v-        -- the kind of the application is the kind of its head-        return (bv, Kinded ki1 $ App e1e e2e)-{--            v <- force v -- if v is a corecursively defined type in Set, unfold!-            case v of-               VQuant Pi x (Domain av _ dec) env b -> do-                  (v2,e2e) <--                    if inferable e2 then do-                  -- if e2 has a singleton type, we should not take v2 = whnf e2-                  -- but use the single value of e2-                  -- this is against the spirit of bidir. checking-                           -- if checking a type we need to resurrect-                           (av', Kinded _ e2e) <- applyDec dec $ inferExpr e2-                           case av' of-                              VSing v2 av'' -> do subtype av' av-                                                  return (v2,e2e)-                              _ -> do checkSubtype e2e av' av-                                      v2 <- whnf' e2e-                                      return (v2, e2e)-                         else do-                           Kinded _ e2e <- applyDec dec $ checkExpr e2 av-                           v2 <- whnf' e2-                           return (v2, e2e)-                  bv <- whnf (update env x v2) b-                  -- the kind of the application is the kind of its head-                  return (bv, Kinded ki1 $ App e1e (if erased dec then erasedExpr e2e else e2e))--- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e])-               _ -> throwErrorMsg $ "inferExpr : expected Pi with expression : " ++ show e1 ++ "," ++ show v--}----      App e1 (e2:el) -> inferExpr $ (e1 `App` [e2]) `App` el-      -- 2012-01-22 no longer infer constructors-      (Def id@(DefId {idKind, idName = name})) | not (conKind idKind) -> do -- traceCheckM ("infer defined head " ++ show n)-         mitem <- errorToMaybe $ lookupName1 $ unqual name-         case mitem of -- first check if it is also a var name-           Just item -> do -- we are inside a mutual declaration (not erased!)-             let pol  = (polarity $ decor $ domain item)-             let upol = (polarity $ upperDec item)-             mId <- asks checkingMutualName-             case mId of-               Just srcId ->-                 -- we are checking constructors or function bodies-                 addPosEdge srcId id upol-               Nothing ->-                 -- we are checking signatures-                 enter ("recursive occurrence of " ++ show name ++ " not strictly positive") $-                   leqPolM pol upol-             return (typ $ domain item, Kinded (kind $ domain item) $ e)-           Nothing -> -- otherwise, it is not the data type name just being defined-                 do sige <- lookupSymbQ name-                    case sige of-                      -- data types have always kind Set 0!-                      (DataSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e)-                      (FunSig  { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e)-                      -- constructors are always terms-                      (ConSig  { symbTyp = tv }) -> returnSing (Kinded kTerm e) tv  -- constructors have sing.type!-                      (LetSig  { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) -- return $ vSing v tv-{--      (Con _ n) -> do sig <- gets signature-                      case (lookupSig n sig) of-      (Let n) -> do sig <- gets signature-                    case (lookupSig n sig) of--}-      _ -> throwErrorMsg $ "cannot infer type of " ++ show e-     ) >>= \ tv -> ask >>= \ ce ->-         traceCheck ("inferExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " :=> " ++ show tv ++ " in env" ++ show (environ ce)) $---         traceCheck ("inferExpr: " ++ show e ++ " :=> " ++ show tv) $-           return tv---{- BAD IDEA!-improveDec :: Dec -> TVal -> Dec-improveDec dec v = if v == VSet || v == VSize then erased else dec--}--{---- entry point 3: resurrects-checkType :: Expr -> TypeCheck Extr-checkType e = (resurrect $ checkType' e) `throwTrace` ("not a type: " ++ show e )--checkType' :: Expr -> TypeCheck Extr-checkType' e = case e of-    Sort s -> return e-    Pi dec x t1 t2 -> do-        t1e <- checkType' t1-        -- ignore erasure flag in types!---        t1v <- whnf' t1e---        new' x (Domain (Dec False) t1v) $ do-        addBind x (Dec False) t1e $ do-          t2e <- checkType' t2-          return $ Pi dec x t1e t2e  -- Pi (improveDec dec t1v) x t1e t2e-    _ -> checkExpr' e $ VSort Set--}--checkType :: Expr -> TypeCheck (Kinded Extr)-checkType t =-  enter ("not a type: " ++ show t) $-    resurrect $ do-      (s, te) <- inferType t-      leqSort Pos s (Set VInfty)-      return te--checkSmallType :: Expr -> TypeCheck (Kinded Extr)-checkSmallType t =-  enter ("not a set: " ++ show t) $-    resurrect $ do-      (s, te) <- inferType t-      case s of-        Set VZero -> return te-        CoSet{} -> return te-        _ -> throwErrorMsg $ "expected " ++ show s ++ " to be Set or CoSet _"--{---- small type-checkSmallType :: Expr -> TypeCheck Extr-checkSmallType e  = (resurrect $ checkExpr' e $ VSort Set) `throwTrace` ("not a set: " ++ show e )--}---- check telescope and add bindings to contexts-checkTele :: Telescope -> TypeCheck a -> TypeCheck (ETelescope, a)-checkTele (Telescope tel) k = loop tel where-  loop tel = case tel of-    []                                  -> (emptyTel,) <$> k-    tb@(TBind x (Domain t _ dec)) : tel -> do-      Kinded ki te <- checkType t-      let tb = TBind x (Domain te (predKind ki) dec)-      (tel, a) <- addBind tb $ loop tel-      return (Telescope $ tb : telescope tel, a)---- the integer argument is the number of the clause, used just for user feedback-checkCases :: Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])-checkCases = checkCases' 1--checkCases' :: Int -> Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])-checkCases' i v tv [] = return $ Kinded NoKind []-checkCases' i v tv (c : cl) = do-    Kinded k1 ce  <- checkCase i v tv c-    Kinded k2 cle <- checkCases' (i + 1) v tv cl-    return $ Kinded (unionKind k1 k2) $ ce : cle--checkCase :: Int -> Val -> TVal -> Clause -> TypeCheck (Kinded EClause)-checkCase i v tv cl@(Clause _ [p] mrhs) = enter ("case " ++ show i) $-  -- traceCheck ("checking case " ++ show i) $-    do-      -- clearDots -- NOT NEEDED-      (flex,ins,cxt,vt,pe,pv,absp) <- checkPattern neutral [] emptySub tv p-      local (\ _ -> cxt) $ do-        mapM (checkGoal ins) flex-        tel <- getContextTele -- TODO!-        case (absp,mrhs) of-           (True,Nothing) -> return $ Kinded NoKind (Clause tel [pe] Nothing)-           (False,Nothing) -> throwErrorMsg ("missing right hand side in case " ++ showCase cl)-           (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in case " ++ showCase cl)-           (False,Just rhs) -> do-              -- pv <- whnf' (patternToExpr p) -- DIFFICULT FOR DOT PATTERNS!-      --        vp <- patternToVal p -- BUG: INTRODUCES FRESH GENS, BUT THEY HAVE ALREADY BEEN INTRODUCED IN checkPattern-              addRewrite (Rewrite v pv) [vt] $ \ [vt'] -> do-                Kinded ki rhse <- checkRHS ins rhs vt'-                return $ Kinded ki (Clause tel [pe] (Just rhse))-                -- [rhs'] <- solveAndModify [rhs] (environ cxt)-                -- return (Clause [p] rhs')---- type check a function--checkFun :: Type -> [Clause] -> TypeCheck (Kinded [EClause])-checkFun t cl = do-  tv <- whnf' t-  checkClauses tv cl---- the integer argument is the number of the clause, used just for user feedback-checkClauses :: TVal -> [Clause] -> TypeCheck (Kinded [EClause])-checkClauses = checkClauses' 1--checkClauses' :: Int -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])-checkClauses' i tv [] = return $ Kinded NoKind ([])-checkClauses' i tv (c:cl) = do-    Kinded ki1 ce  <- checkClause i tv c-    Kinded ki2 cle <- checkClauses' (i + 1) tv cl-    return $ Kinded (unionKind ki1 ki2) $ (ce : cle)---- checkClause i tv cl = (cl', cle)--- checking one equation cl of a function at type tv--- solve size constraints--- substitute solution into clause, resulting in cl'--- return also extracted clause cle-checkClause :: Int -> TVal -> Clause -> TypeCheck (Kinded EClause)-checkClause i tv cl@(Clause _ pl mrhs) = enter ("clause " ++ show i) $ do-  -- traceCheck ("checking function clause " ++ show i) $-    -- clearDots -- NOT NEEDED-    (flex,ins,cxt,tv0,ple,plv,absp) <- checkPatterns neutral [] emptySub tv pl-    -- 2013-03-30 When checking the rhs, we only allow new size hypotheses-    -- if they do not break any valuation of the existing hypotheses.-    -- See ICFP 2013 paper.-    -- We exclude cofuns here, for experimentation.-    -- Note that cofuns need not be SN, so the strict consistency may be-    -- not necessary.-    local (\ _ -> cxt { consistencyCheck = (mutualCo cxt == Ind) }) $ do-      mapM (checkGoal ins) flex-{--      dots <- openDots-      unless (null dots) $-        recoverFailDoc $ text "the following dotted constructors could not be confirmed: " <+> prettyTCM dots--}-      -- TODO: insert meta var solution in dot patterns-      tel <- getContextTele -- WRONG TELE, has VGens for DotPs-      case (absp,mrhs) of-         (True,Nothing) -> return $ Kinded NoKind (Clause tel ple Nothing)-         (False,Nothing) -> throwErrorMsg ("missing right hand side in clause " ++ show cl)-         (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in clause " ++ show cl)-         (False,Just rhs) -> do-            Kinded ki rhse <- checkRHS ins rhs tv0-            env  <- getEnv-            [rhse] <- solveAndModify [rhse] env-            return $ Kinded ki (Clause tel ple (Just rhse))----- * Pattern checking --------------------------------------------------type Substitution = Valuation -- [(Int,Val)]--emptySub    = emptyVal-sgSub       = sgVal-lookupSub i = lookup i . valuation--type DotFlex = (Int,(Expr,Domain))---- left over goals-data Goal-    = DotFlex Int (Maybe Expr) Domain-      -- ^ @Just@ : Flexible variable from inaccessible pattern.-      -- ^ @Nothing@ : Flexible variable from hidden function type.-    | MaxMatches Int TVal-    | DottedCons Dotted Pattern TVal-  deriving Show---- checkPatterns is initially called with an empty local context--- in the type checking monad-checkPatterns :: Dec -> [Goal] -> Substitution -> TVal -> [Pattern] -> TypeCheck ([Goal],Substitution,TCContext,TVal,[EPattern],[Val],Bool)-checkPatterns dec0 flex ins v pl =-  case v of-    VMeasured mu vb -> setMeasure mu $ checkPatterns dec0 flex ins vb pl-    VGuard beta vb -> addBoundHyp beta $ checkPatterns dec0 flex ins vb pl-{--    VGuard beta vb -> throwErrorMsg $ "checkPattern at type " ++ show v ++ " --- introduction of constraints not supported"--}-    _ -> case pl of-      [] -> do cxt <- ask-               return (flex,ins,cxt,v,[],[],False)-      (p:pl') -> do (flex',ins',cxt',v',pe,pv,absp) <- checkPattern dec0 flex ins v p-                    local (\ _ -> cxt') $ do-                      (flex'',ins'',cxt'',v'',ple,plv,absps) <- checkPatterns dec0 flex' ins' v' pl'-                      return (flex'',ins'',cxt'',v'', pe:ple, pv:plv, absp || absps) -- if pe==IrrP then ple else pe:ple)--{--checkPattern dec0 flex subst tv p = (flex', subst', cxt', tv', pe, pv, absp)--Input :-  dec0  : context in which pattern occurs (irrelevant, parametric, recursive)-          are we checking an erased argument? (constr. pat. needs to be forced!)-  flex  : list of pairs (flexible variable, its dot pattern + supposed type)-  subst : list of pairs (flexible variable, its valuation)-  cxt   : in monad, containing-    rho   : binding of variables to values-    delta : binding of generic values to their types-  tv    : type of the expression \ p -> t-  p     : the pattern to check--Output-  tv'   : type of t-  pe    : erased pattern-  pv    : value of pattern (this is in essence whnf' pe,-            but we cannot evaluate because of dot patterns)-  absp  : did we encounter an absurd pattern--}--checkPattern :: Dec -> [Goal] -> Substitution -> TVal -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,TVal,EPattern,Val,Bool)-checkPattern dec0 flex ins tv p = -- ask >>= \ TCContext { context = delta, environ = rho } -> trace ("checkPattern" ++ ("\n  dot pats: " +?+ show flex) ++ ("\n  substion: " +?+ show ins) ++ ("\n  environ : " +?+ show rho) ++ ("\n  context : " +?+ show delta) ++ "\n  pattern : " ++ show p ++ "\n  at type : " ++ show tv ++ "\t<>") $- enter ("pattern " ++ show p) $ do-  tv <- force tv-  case tv of-    -- record type can be eliminated-    VApp (VDef (DefId DatK d)) vl ->-      case p of-        ProjP proj -> do-          tv <- projectType tv proj VIrr -- do not have record value here-          cxt <- ask-          return (flex, ins, cxt, tv, p, VProj Post proj, False)-{--          mfs <- getFieldsAtType d vl-          case mfs of-            Nothing -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with projection pattern" <+> prettyTCM p)-            Just ptvs ->-              case lookup proj ptvs of-                Nothing -> failDoc (text "record type" <+> prettyTCM tv <+> text "does not know projection" <+> text proj)-                Just tv -> do-                  tv <- piApp tv VIrr -- cut of record arg-                  cxt <- ask-                  return (flex, ins, cxt, tv, p, VProj proj, False)--}-        _ -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with a non-projection pattern")--    -- intersection type-    VQuant Pi x dom@(Domain av ki Hidden) fv -> do-      -- introduce new flexible variable-      newWithGen x dom $ \ i xv -> do-        tv <- fv `app` xv-        checkPattern dec0 (DotFlex i Nothing dom : flex) ins tv p--    -- function type can be eliminated-    VQuant Pi x (Domain av ki dec) fv -> do-{--       let erased' = er || erased dec-       let decEr   = if erased' then irrelevantDec else dec -- dec {erased = erased'}--}-       let decEr = dec `compose` dec0-       let domEr   =  (Domain av ki decEr)-       case p of--         -- treat successor pattern here, because of admissibility check-         SuccP p2 -> do-                 when (av /= vSize) $ throwErrorMsg "checkPattern: expected type Size"-                 when (isSuccessorPattern p2) $ cannotMatchDeep p tv--                 co <- asks mutualCo-                 when (co /= CoInd) $-                   throwErrorMsg ("successor pattern only allowed in cofun")--                 enterDoc (text ("checkPattern " ++ show p ++" : matching on size, checking that target") <+> prettyTCM tv <+> text "ends in correct coinductive sized type") $-                   underAbs x domEr fv $ \ i _ bv -> endsInSizedCo i bv--                 cxt <- ask-                 -- 2012-02-05 assume size variable in SuccP to be < #-                 let sucTy = (vFinSize `arrow` vFinSize)-                 (flex',ins',cxt',tv',p2e,p2v,absp) <- checkPattern decEr flex ins sucTy p2-                 -- leqVal Mixed delta' VSet VSize av -- av = VSize-                 let pe = SuccP p2e-                 let pv = VSucc p2v---                 pv0 <- local (\ _ -> cxt') $ whnf' $ patternToExpr pe-                 -- pv0 <- patternToVal p -- RETIRE patternToVal-                 -- pv  <- up False pv0 av -- STUPID what can be eta-exanded at type Size??-                 vb  <- app fv pv-{--                 endsInCoind <- endsInSizedCo pv vb-                 when (not endsInCoind) $ throwErrorMsg $ "checkPattern " ++ show p ++" : cannot match on size since target " ++ show tv ++ " does not end in correct coinductive sized type"--}-                 return (flex',ins',cxt',vb,pe,pv,absp)--         -- other patterns: no need to know about result type-         _ -> do-           (flex',ins',cxt',pe,pv,absp) <- checkPattern' flex ins domEr p-           -- traceM ("checkPattern' returns " ++ show (flex',ins',cxt',pe,pv,absp))-           vb  <- app fv pv-           vb  <- substitute ins' vb  -- from ConP case -- ?? why not first subst and then whnf?-           -- traceCheckM ("Returning type " ++ show vb)-           return (flex',ins',cxt',vb,pe,pv,absp)--    _ -> throwErrorMsg $ "checkPattern: expected function type, found " ++ show tv---- TODO: refactor with monad transformers--- put absp into writer monad--turnIntoVarPatAtUnitType :: TVal -> Pattern -> TypeCheck Pattern-turnIntoVarPatAtUnitType (VApp (VDef (DefId DatK n)) _) p@(ConP pi c []) =-  flip (ifM $ isUnitData n) (return p) $ do-    let x = fresh "un!t"-    return $ VarP x-turnIntoVarPatAtUnitType _ p = return p--checkPattern' :: [Goal] -> Substitution -> Domain -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,EPattern,Val,Bool)-checkPattern' flex ins domEr@(Domain av ki decEr) p = do-       p <- turnIntoVarPatAtUnitType av p-       case p of-          SuccP{} -> failDoc (text "successor pattern" <+> prettyTCM p <+> text "not allowed here")--          PairP p1 p2 -> do-            av <- force av-            case av of-             VQuant Sigma y dom1@(Domain av1 ki1 dec1) fv -> do-              (flex, ins, cxt, pe1, pv1, absp1) <--                 checkPattern' flex ins (Domain av1 ki1 $ dec1 `compose` decEr) p1-              av2 <- app fv pv1-              (flex, ins, cxt, pe2, pv2, absp2) <--                 local (const cxt) $-                   checkPattern' flex ins (Domain av2 ki decEr) p2-              return (flex, ins, cxt, PairP pe1 pe2, VPair pv1 pv2, absp1 || absp2)-             _ -> failDoc (text "pair pattern" <+> prettyTCM p <+> text "could not be checked against type" <+> prettyTCM av)-{--   (x : Sigma y:A. B) -> C-     =iso= (y : A) -> (x' : B) -> C[(y,x')/x]--   (x : Sigma y:V. <B;rho1>) -> <C;rho2>-     =iso= (y : V) -> <(x': B) -> C; ?? x=(y,x')>- -}-{--            case av of-              VQuant Sigma y dom1@(Domain av1 ki1 dec1) env1 a2 -> do-                let x' = x ++ "#2"-                    ep = Pair (Var y) (Var x')-                    tv = VQuant Pi y dom1 env1 $-                           Quant x' (Domain a2--}--          ProjP proj -> failDoc (text "cannot eliminate type" <+> prettyTCM av <+> text "with projection pattern" <+> prettyTCM p)--          VarP y -> do-            new y domEr $ \ xv -> do-              cxt' <- ask-              p' <- case av of-                       VBelow Lt v -> flip SizeP y <$> toExpr v-                       _ -> return p-              return (flex, ins, cxt', maybeErase $ p', xv, False)--{- checking bounded size patterns--    ex : [i : Size] -> [j : Below< i] -> ...-    ex i (j < i) = ...--  type of pattern : Below< i needs to cover type of parameter Below< i--    zero : [j : Size] -> Nat $j   -- need to hold a "sized con type"-    zero : [j < i]    -> Nat i--    ex : [i : Size] -> (n : Nat i) -> ...-    ex i (zero (j < i) = ...--  type of size-pat : Below< i---}-          SizeP e y -> do -- pattern (z > y), y is the bound variable, z the bound of z-            e <- resurrect $ checkSize e -- (Var z)-            newWithGen y domEr $ \ j xv -> do-{--               VGen k <- whnf' (Var z)-               addSizeRel j 1 k $ do  -- j < k--}-               ve <- whnf' e-               addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ do-                 subtype av (VBelow Lt ve)-                 cxt' <- ask-                 return (flex, ins, cxt', maybeErase $ SizeP e y, xv, False)--          AbsurdP -> do-                 when (isFunType av) $ throwErrorMsg ("absurd pattern " ++ show p ++ " does not match function types, like " ++ show av)-                 cxt' <- ask-                 return (MaxMatches 0 av : flex, ins, cxt', maybeErase $ AbsurdP, VIrr, True)-{--                 cenvs <- matchingConstructors av  -- TODO: av might be MVar-                                                   -- need to be postponed-                 case cenvs of-                    [] -> do bv   <- whnf (update env x VIrr) b-                             cxt' <- ask-                             return (flex, ins, cxt', bv, maybeErase $ AbsurdP, True)-                    _ -> throwErrorMsg $ "type " ++ show av ++ " of absurd pattern not empty"--}--          -- always expand defined patterns!-          p@(ConP pi n ps) | coPat pi == DefPat -> do-            checkPattern' flex ins domEr =<< expandDefPat p----          ConP pi n pl | not $ dottedPat pi -> do-          ConP pi n pl -> do--                 -- disambiguate constructor first-                 n <- disambigCon n av--                 let co     = coPat pi-                     dotted = dottedPat pi--                 -- First check that we do not match against an irrelevant argument.-                 unless dotted $ nonDottedConstructorChecks n co pl-{- TODO-                 enter ("can only match non parametric arguments") $-                   leqPolM (polarity dec) (pprod defaultPol)--}-                 (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- checkConstructorPattern co n pl--                 when (isFunType vc') $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " of type " ++ show vc' ++ " not allowed")-                 let flexgen = concat $ map (\ g -> case g of-                        DotFlex i _ _ -> [i]-                        _ -> []) flex'-                     -- fst $ unzip flex'---                  av1 <- sing (environ cxt') (patternToExpr p) vc'---                  av2 <- sing (environ cxt') (patternToExpr p) av---                  subst <- local (\ _ -> cxt') $ inst flexgen VSet av1 av2---                 -- need to evaluate the erased pattern!-                 let pe = ConP pi n ple -- erased pattern-                 -- dot <- if dottedPat pi then newDotted p else return notDotted-                 dot <- if dottedPat pi then mkDotted True else return notDotted-                 pv0 <- mkConVal dot co n pvs vc-                 -- OLD: let pv0 = VDef (DefId (ConK co) n) `VApp` pvs-{--                 let epe = patternToExpr pe-                 pv0 <- local (\ _ -> cxt') $ whnf' epe---                 pv0 <- patternToVal p -- THIS USE should be ok, since the new GENs are not in the global context yet, only in cxt' -- NO LONGER ok with erasure!-                 -- traceM $ "sucessfully computed value " ++ show pv0 ++ " of pattern " ++ show epe--}--                 subst <- local (\ _ -> cxt') $ do-                   case av of  -- TODO: need subtyping-unify instead of unify??-                     VSing vav av0 -> do-                       vav <- whnfClos vav-                       inst Pos flexgen av0 pv0 vav-                     _ -> unifyIndices flexgen vc' av  -- vc' <= av ?!-                   -- THIS IMPLEMENTATION RELIES HEAVILY ON INJECTIVITY OF DATAS--{- moved to checkRHS-                 -- apply substitution to measures in environment-                 let mmu = (envBound . environ) cxt'-                 mmu' <- Traversable.mapM (substitute subst) mmu--}-{--                 ins'' <- compSubst ins' subst-                 vb <- substitute ins'' vb-                 delta' <- substitute ins'' delta'--}-                 ins''   <- compSubst ins' subst -- 2010-07-27 not ok to switch!-                 delta'' <- substitute ins'' (context cxt')-                 traceCheckM $ "delta'' = " ++ show delta''-                 av  <- substitute ins'' av  -- 2010-09-22: update av-                 pv  <- up False pv0 av--                 -- if the constructor was dotted, make sure it is the only match-                 let flex'' = fwhen dotted (DottedCons dot p av :) flex'-                 return (flex'', ins'', cxt' { context = delta'' },-                         maybeErase pe, pv, absp)-{- DO NOT UPDATE measure here, its done in checkRHS-                 return (flex', ins'', cxt' { context = delta'', environ = (environ cxt') { envBound = mmu' } }, vb',-                         maybeErase pe, absp)--}---{- UNUSED-          -- If we encounter a dotted constructor, we simply-          -- compute the pattern variable context-          -- and then treat the pattern as dot pattern.-          p@(ConP pi n ps) | dottedPat pi -> do-            (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <--              checkConstructorPattern (coPat pi) n ps-            local (const cxt') $-              checkPattern' flex ins domEr $ DotP $ patternToExpr p--}--          DotP e -> do-            -- create an informative, but irrelevant identifier for dot pattern-            let xp = fresh $ "." ++ case e of Var z -> suggestion z; _ -> Util.parens $ show e-            newWithGen xp domEr $ \ k xv -> do-                       cxt' <- ask-                       -- traceCheck ("Returning type " ++ show vb) $-                       return (DotFlex k (Just e) domEr : flex-                              ,ins-                              ,cxt'-                              ,maybeErase $ DotP e -- $ Var xp -- DotP $ Meta k -- e -- Meta k-                              -- ,maybeErase $ -- AbsurdP -- VarP $ show e-                              ,xv-                              ,False) -- TODO: Erase in e/ Meta subst!-{- original code-                    do let (k, delta') = cxtPush dec av delta-                       vb <- whnf (update env x (VGen k)) b-                       return ((k,(e,Domain av dec)):flex-                              ,ins-                              ,rho-                              ,delta'-                              ,vb)--}--    where-      maybeErase p = if erased decEr then ErasedP p else p--      checkConstructorPattern co n pl = do-                 when (isFunType av) $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " at type " ++ show av ++ " not allowed")--- TODO: ensure that matchings against erased arguments are forced---                 when (erased dec) $ throwErrorMsg $ "checkPattern: cannot match on erased argument " ++ show p ++ " : " ++ show av--                 ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n--                 -- the following is a hack to still support old-style-                 --   add .($ i) (zero i) ...-                 -- fun defs:  if (zero i) is matched against (Nat flexvar$i)-                 -- we use the old constructor type [i : Size] -> Nat $i-                 -- else, the new one [j < i] -> Nat i-                 let flexK k (DotFlex k' _ _) = k == k'-                     flexK k _ = False-                     -- use lhs con type only if sizeindex is not a rigid var-                     isFlex (VGen k) = List.any (flexK k) flex-                     isFlex _ = True-                     isSz = if co == Cons then sz else Nothing-                 vc <- instConLType n conPars vc isSz isFlex dataPars =<< force av-{--                 vc <- case sz of-                         Nothing -> instConType n nPars vc =<< force av-                         Just vc -> instConType n (nPars+1) vc =<< force av--}--                 -- (flex',ins',cxt',vc',ple,pvs,absp) <--                 (vc,) <$> checkPatterns decEr flex ins vc pl---      -- These checks are only relevant if a constructor is an actual match.-      nonDottedConstructorChecks n co pl = do-        ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n--        -- check that size argument of coconstr is dotted-        when (co == CoCons && isJust sz) $ do-          let sizep = head pl  -- 2012-01-22: WAS (pl !! nPars)-          unless (isDotPattern sizep) $-            throwErrorMsg $ "in pattern " ++ show p  ++ ", coinductive size sub pattern " ++ show sizep ++ " must be dotted"--        when (not $ decEr `elem` map Dec [Const,Rec]) $-          recoverFail $ "cannot match pattern " ++ show p ++ " against non-computational argument"-        -- check not to match non-trivially against erased stuff-        when (decEr == Dec Const) $ do-          let failNotForced = recoverFail $ "checkPattern: constructor " ++ show n ++ " of non-computational argument " ++ show p ++ " : " ++ show av ++ " not forced"-          mcenvs <- matchingConstructors av-          case mcenvs of-             Nothing -> do -- now check whether dataName is a record type-               DataSig { constructors } <- lookupSymb dataName-               unless (length constructors == 1) $ failNotForced-               return ()-             Just [] -> recoverFail $ "checkPattern: no constructor matches type " ++ show av-             Just [(ci, _)] | cName ci == n -> return ()-             _ -> failNotForced-----{- New treatment of size matching  (see examples/Sized/Cody.ma)--sized data O : Size -> Set-{ Z : [i : Size] -> O ($ i)-; S : [i : Size] -> O i -> O ($ i)-; L : [i : Size] -> (Nat -> O i) -> O ($ i)-; M : [i : Size] -> O i -> O i -> O ($ i)-}--fun deep : [i : Size] -> O i -> Nat -> Nat-{ deep i4 (M i3 (L j2 f) (S i2 (S i1 (S i x)))) n-  = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n)))-; deep i x n = n-}--Explicit form:  Size variables and their constraints are noted explicitely,-to be able to do untyped call extraction in the termination module.-- deep i4-  (M (i4 > i3)-       (L (i3 > j2) f)-       (S (i3 > i2)-            (S (i2 > i1)-                 (S (i1 > i) x)))) n-  = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n)))--i4, i3, ... are all rigid variables with constraints between them.-There is a tree hierarchy, but I do not know whether I can exploit-this.--  i4 > i3 > i2 > i1 > i-          > j3--This could be stored in a union-find-like data structure, or just in-the constraint matrix.--How to pattern match?--  id : [i : Size] -> List i -> List i-  id i (cons (i > j) x xs) = cons j x (id j xs)--Only a size variable matches a size arguments--  match  (cons (i > j) x xs)   against   List i-  get    cons : [j : Size] -> Nat -> List j -> List ($ j)-  yield  x : Nat, xs : List j, cons j x xs : List ($ j)-  check  List ($ j) <= List i- -}--{- RETIRED--- checkDot does not need to extract-checkDot :: Substitution -> DotFlex -> TypeCheck ()-checkDot subst (i,(e,it)) = enter ("dot pattern " ++ show e) $-  case (lookup i subst) of-    Nothing -> throwErrorMsg $ "not instantiated"-    Just v -> do-      tv <- substitute subst (typ it)-      ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv)-      applyDec (decor it) $ do-        checkExpr e tv-        v' <-  whnf' e -- TODO: has subst erased terms?-        enter ("inferred value " ++ show v ++ " does not match given dot pattern value " ++ show v') $-          eqVal Pos tv v v'--}---- checkDot does not need to extract--- 2012-01-25 now we do since "extraction" turns also con.terms into records-checkGoal :: Substitution -> Goal -> TypeCheck ()-checkGoal subst (DotFlex i me it) = enter ("dot pattern " ++ show me) $-  case lookupSub i subst of-    Nothing -> recoverFail $ "not instantiated"-    Just v -> whenJust me $ \ e -> do-      tv <- substitute subst (typ it)-      ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv)---      applyDec (decor it) $ do-      resurrect $ do -- consider a DotP e always as irrelevant!-        e <- valueOf <$> checkExpr e tv-        v' <-  whnf' e -- TODO: has subst erased terms?-        enterDoc (text "inferred value" <+> prettyTCM v <+> text "does not match given dot pattern value" <+> prettyTCM v') $-          leqVal Pos tv v v' -- WAS: eqVal-checkGoal subst (MaxMatches n av) = do-  traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av)-  av' <- substitute subst av-  traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av')-  -- av' <- reval av'-  -- traceCheckM ("checkGoal: reevalutated " ++ show av')-  mcenvs <- matchingConstructors av'-  traceCheckM ("checkGoal matching constructors = " ++ show mcenvs)-  maybe (recoverFail $ "not a data type: " ++ show av')-   (\ cenvs ->-      if length cenvs > n then recoverFail $-        if n==0 then "absurd pattern does not match since type " ++ show av' ++ " is not empty"-         else-           "more than one constructor matches type " ++ show av'-       else return ())-   mcenvs-checkGoal subst (DottedCons dot p av)-  | isDotted dot =-      enterDoc (text "confirming dotted constructor" <+> prettyTCM p) $ do-        checkGoal subst (MaxMatches 1 av)-  | otherwise    = return ()--checkRHS :: Substitution -> Expr -> TVal -> TypeCheck (Kinded Extr)-checkRHS ins rhs v = do-   traceCheckM ("checking rhs " ++ show rhs ++ " : " ++ show v)-   enter "right hand side" $ do-     -- first update measure according to substitution for dot variables-     cxt <- ask-     let rho = environ cxt-     mmu' <- Traversable.mapM (substitute ins) (envBound rho)-     local (\ _ -> cxt { environ = rho { envBound = mmu' }}) $-       activateFuns $-         checkExpr rhs v------ TODO type directed unification---- unifyIndices flex tv1 tv2--- tv1 = D pars  inds  is the type of the pattern--- tv2 = D pars' inds' is the type matched against--- Note that in this case we can unify without using the principle of--- injective data type constructors,--- we are only calling unifyIndices from the constructor pattern case--- in Checkpattern-unifyIndices :: [Int] -> Val -> Val -> TypeCheck Substitution-unifyIndices flex v1 v2 = ask >>= \ cxt -> enterDoc (text ("unifyIndices " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show Pos) <+> prettyTCM v2) $ do--- {--  case (v1,v2) of-    (VSing _ v1, VApp (VDef (DefId DatK d2)) vl2) ->-      flip (unifyIndices flex) v2 =<< whnfClos v1-    (VApp (VDef (DefId DatK d1)) vl1, VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 -> do-      (DataSig { numPars = np, symbTyp = tv, positivity = posl}) <- lookupSymbQ d1-      instList posl flex tv vl1 vl2 -- unify also parameters to solve dot patterns-    _ ->--- -}-         inst Pos flex vTopSort v1 v2--- throwErrorMsg ("unifyIndices " ++ show v1 ++ " =?= " ++ show v2 ++ " failed, not applied to data types")---- unify, but first produce whnf-instWh :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution-instWh pos flex tv w1 w2 = do-  v1 <- whnfClos w1-  v2 <- whnfClos w2-  inst pos flex tv v1 v2---- | Check occurrence and return singleton substitution.-assignFlex :: Int -> Val -> TypeCheck Substitution-assignFlex k v = do-  unlessM (nocc [k] v) $-    failDoc $-      text "variable " <+> prettyTCM (VGen k) <+>-      text " may not occur in " <+> prettyTCM v-  return $ sgSub k v---- match v1 against v2 by unification , yielding a substition-inst :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution-inst pos flex tv v1 v2 = ask >>= \ cxt -> enterDoc (text ("inst " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show pos) <+> prettyTCM v2 <+> colon <+> prettyTCM tv) $ do---  case tv of---    (VPi dec x av env b) ->-  case (v1,v2) of-    (VGen k, VGen j) | k == j -> return emptySub-    (VGen k, _) | elem k flex -> assignFlex k v2-    (_, VGen k) | elem k flex -> assignFlex k v1--    -- injectivity of data type constructors is unsound in general-    (VApp (VDef (DefId DatK d1)) vl1,-     VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 ->  do-         (DataSig { numPars, symbTyp = tv, positivity = posl }) <- lookupSymbQ d1-         instList' numPars posl flex tv vl1 vl2-           -- ignore parameters (first numPars args)-           -- this is sound because we have irrelevance for parameters-           -- we assume injectivity for indices--    -- Constructor applications are represented as VRecord-    (VRecord (NamedRec _ c1 _ dot1) rs1,-     VRecord (NamedRec _ c2 _ dot2) rs2) | c1 == c2 -> do-         alignDotted dot1 dot2-         sige <- lookupSymbQ c1-         instList [] flex (symbTyp sige) (map snd rs1) (map snd rs2)--    (VSucc v1',     VSucc v2')     -> instWh pos flex tv v1' v2'-    (VSucc v,       VInfty)        -> instWh pos flex tv v   VInfty-    (VSing v1' tv1, VSing v2' tv2) -> do-      subst <- inst pos flex tv tv1 tv2-      u1 <- substitute subst v1'-      u2 <- substitute subst v2'-      tv1' <- substitute subst tv1-      inst pos flex tv1' u1 u2 >>= compSubst subst---- HACK AHEAD-    (VUp v1 _, _) -> inst pos flex tv v1 v2-    (_, VUp v2 _) -> inst pos flex tv v1 v2---    (VUp v1' a1, VUp v2' a2) -> instList flex [a1,v1'] [a2,v2']---     (VPi dec x1 av1 env1 b1, VPi dec x2 av2 env2 b2) ->--{- TODO: REPAIR THIS-    _ -> traceCheck ("inst: WARNING! assuming " ++ show (context cxt) ++ " |- " ++ show v1 ++ " == " ++ show v2) $-           return [] -- throwErrorMsg $ "inst: NYI"- -}-    _ -> do leqVal pos tv v1 v2 `throwTrace` ("inst: leqVal " ++ show v1 ++ " ?<=" ++ show pos ++ " " ++ show v2 ++ " : " ++ show tv ++ " failed")-            return emptySub--instList :: [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution-instList = instList' 0---- unify lists, ignoring the first np items-instList' :: Int -> [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution-instList' np posl flex tv [] [] = return emptySub-instList' np posl flex tv (v1:vl1) (v2:vl2) = do-  v1 <- whnfClos v1-  v2 <- whnfClos v2-  if (np <= 0 || isMeta flex v1 || isMeta flex v2) then-    case tv of-      (VQuant Pi x dom fv) -> do-        let pol = getPol dom  -- WAS: (headPosl posl)-        subst <- inst pol flex (typ dom) v1 v2-        vl1' <- mapM (substitute subst) vl1-        vl2' <- mapM (substitute subst) vl2-        v    <- substitute subst v1-        fv   <- substitute subst fv-        vb   <- app fv v-        subst' <- instList' (np - 1) (tailPosl posl) flex vb vl1' vl2'-        compSubst subst subst'-   else-    case tv of-      (VQuant Pi x dom fv) -> do-        vb   <- app fv v2-        instList' (np - 1) (tailPosl posl) flex vb vl1 vl2-instList' np pos flex tv vl1 vl2 = throwErrorMsg $ "internal error: instList' " ++ show (np,pos,flex,tv,vl1,vl2) ++ " not handled"--headPosl :: [Pol] -> Pol-headPosl [] = mixed-headPosl (pos:_) = pos--tailPosl :: [Pol] -> [Pol]-tailPosl [] = []-tailPosl (_:posl) = posl---isMeta :: [Int] -> Val -> Bool-isMeta flex (VGen k) = k `elem` flex-isMeta _ _ = False--------------------------------------------------------------------------- * Substitution into values--------------------------------------------------------------------------- | Overloaded substitution of values for generic values (free variables).-class Substitute a where-  substitute :: Substitution -> a -> TypeCheck a--instance Substitute v => Substitute (x,v) where-  substitute subst (x,v) = (x,) <$> substitute subst v--instance Substitute v => Substitute [v] where-  substitute = mapM . substitute--instance Substitute v => Substitute (Maybe v) where-  substitute = Traversable.mapM . substitute--instance Substitute v => Substitute (Map k v) where-  substitute = Traversable.mapM . substitute--instance Substitute v => Substitute (OneOrTwo v) where-  substitute = Traversable.mapM . substitute--instance Substitute v => Substitute (Dom v) where-  substitute = Traversable.mapM . substitute--instance Substitute v => Substitute (Measure v) where-  substitute = Traversable.mapM . substitute--instance Substitute v => Substitute (Bound v) where-  substitute = Traversable.mapM . substitute--instance Substitute v => Substitute (Sort v) where-  substitute = Traversable.mapM . substitute---- substitute generic variable in value-instance Substitute Val where-  substitute subst v = do -- enterDoc (text "substitute" <$> prettyTCM v) $ do-    let sub v = substitute subst v-    case v of-      VGen k                -> return $ valuateGen k subst-      VApp v1 vl            -> foldM app ==<< (sub v1, sub vl)-      VSing v1 vt           -> vSing ==<< (sub v1, sub vt) -- TODO: Check reevaluation necessary?--      VSucc v1              -> succSize  <$> substitute subst v1-      VMax  vs              -> maxSize   <$> mapM (substitute subst) vs-      VPlus vs              -> plusSizes <$> mapM (substitute subst) vs--      VCase v1 tv1 env cl   -> VCase <$> sub v1 <*> sub tv1 <*> sub env <*> return cl-      VMeasured mu bv       -> VMeasured <$> sub mu <*> sub bv-      VGuard beta bv        -> VGuard <$> sub beta <*> sub bv--      VBelow ltle v         -> VBelow ltle <$> substitute subst v--      VQuant pisig x dom fv -> VQuant pisig x <$> sub dom <*> sub fv-      VRecord ri rs         -> VRecord ri <$> sub rs-      VPair v1 v2           -> VPair <$> sub v1 <*> sub v2-      VProj{}               -> return v--      VLam x env b          -> flip (VLam x) b <$> sub env-      VConst v              -> VConst <$> sub v-      VAbs x i v valu       -> VAbs x i v <$> sub valu-      VClos env e           -> flip VClos e <$> sub env-      VUp v1 vt             -> up False ==<< (sub v1, sub vt)-      VSort s               -> VSort <$> sub s-      VZero                 -> return $ v-      VInfty                -> return $ v-      VIrr                  -> return $ v-      VDef id               -> return $ vDef id  -- because empty list of apps will be rem.-      VMeta x env n         -> flip (VMeta x) n <$> sub env-{- REDUNDANT-      _ -> error $ "substitute: internal error: not defined for " ++ show v--}--instance Substitute SemCxt where-  substitute subst delta = do-    cxt' <- substitute subst (cxt delta)-    return $ delta { cxt = cxt' }---- | Substitute in environment.-instance Substitute Env where-  substitute subst (Environ rho mmeas) =-    Environ <$> substitute subst rho <*> substitute subst mmeas--instance Substitute Substitution where-  substitute subst2 subst1 = compSubst subst1 subst2---- | "merge" substitutions by first applying the second to the first, then---   appending them @t[sigma][tau] = t[sigma . tau]@-compSubst :: Substitution -> Substitution -> TypeCheck Substitution-compSubst (Valuation subst1) subst2@(Valuation subst2') =-    Valuation . (++ subst2') <$> substitute subst2 subst1--------------------------------------------------------------------------- * Size checking-------------------------------------------------------------------------{- TODO: From a sized data declaration--  sized data D pars : Size -> t-  { c : [j : Size] -> args -> D pars $j ts-  }--  with constructor type--   c : .pars -> [j : Size] -> args -> D pars $j ts--  extract new-style constructor type--   c :  .pars -> [i : Size] -> [j < i : Size] -> args -> D pars i ts--  Then replace in ConSig filed isSized :: Sized  by :: Maybe Expr-  which stores the new-style constructor type---}--mkConLType :: Int -> Expr -> (Name, Expr)-mkConLType npars t =-  let (Telescope (sizetb : tel), t0) = typeToTele t-  in case spineView t0 of-    (d@(Def (DefId DatK _)), args) ->-      let (pars, sizeindex : inds) = splitAt npars args-          i     = fresh "s!ze"-          args' = pars ++ Var i : inds-          core  = foldl App d args'-          tbi   = TBind i $ sizeDomain irrelevantDec-          tbj   = sizetb { boundDom = belowDomain irrelevantDec Lt (Var i) }-          tel'  = Telescope $ tbi : tbj : tel-      in (i, teleToType tel' core)-    _ -> error $ "conLType " ++ show npars ++ " (" ++ show t ++ "): illformed constructor type"------ * check wether the data type is sized type----- check data declaration type--- called from typeCheckDeclaration (DataDecl{})--- parameters : number of params, type-szType :: Co -> Int -> TVal -> TypeCheck ()-szType co p tv = doVParams p tv $ \ tv' -> do-    let polsz = if co==Ind then Pos else Neg-    case tv' of-      VQuant Pi x (Domain av ki dec) fv | isVSize av && not (erased dec) && polarity dec == polsz -> return ()-      _ -> throwErrorMsg $ "not a sized type, target " ++ show tv' ++ " must have non-erased domain " ++ show Size ++ " with polarity " ++ show polsz---- * constructors of sized type---- check data constructors--- called from typeCheckConstructor-szConstructor :: Name -> Co -> Int -> TVal -> TypeCheck ()-szConstructor n co p tv = enterDoc (text ("szConstructor " ++ show n ++ " :") <+> prettyTCM tv) $ do-  doVParams p tv $ \ tv' ->-    case tv' of-       VQuant Pi x dom fv | isVSize (typ dom) ->-          underAbs x dom fv $ \ k xv bv -> do-            szSizeVarUsage n co p k bv-       _ -> throwErrorMsg $ "not a valid sized constructor: expected size quantification"--szSizeVarUsage :: Name -> Co -> Int -> Int -> TVal -> TypeCheck ()-szSizeVarUsage n co p i tv = enterDoc (text "szSizeVarUsage of" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $-    case tv of-       VQuant Pi x dom fv -> do-          let av = typ dom-          szSizeVarDataArgs n p i av  -- recursive calls of for D..i..-          enterDoc (text "checking" <+> prettyTCM av <+> text (" to be " ++-              (if co == CoInd then "antitone" else "isotone") ++ " in variable")-              <+> prettyTCM (VGen i)) $-            szMono co i av                -- monotone in i-          underAbs x dom fv $ \ _ xv bv -> do-            szSizeVarUsage n co p i bv--       _ -> szSizeVarTarget p i tv---- check that Target is of form D ... (Succ i) ...-szSizeVarTarget :: Int -> Int -> TVal -> TypeCheck ()-szSizeVarTarget p i tv = enterDoc (text "szSizeVarTarget, variable" <+> prettyTCM (VGen i) <+> text ("argument no. " ++ show p ++ " in") <+> prettyTCM tv) $ do-    let err = text "expected target" <+> prettyTCM tv <+> text "of size" <+> prettyTCM (VSucc (VGen i))-    case tv of-       VSing _ tv -> szSizeVarTarget p i =<< whnfClos tv-       VApp d vl -> do-               v0 <- whnfClos (vl !! p)-               case v0 of-                 (VSucc (VGen i')) | i == i' -> return ()-                 _ -> failDoc err-       _ -> failDoc err----- check that rec. arguments are of form D ... i ....--- and size used nowhere else ?? -- Andreas, 2009-11-27 TOO STRICT!-{- accepts, for instance--   Nat -> Ord i      as argument of a constructor of  Ord ($ i)-   List (Rose A i)   as argument of a constructor of  Rose A ($i)- -}-szSizeVarDataArgs :: Name -> Int -> Int -> TVal -> TypeCheck ()-szSizeVarDataArgs n p i tv = enterDoc (text "sizeVarDataArgs" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $ do-   case tv of--     {- case D pars sizeArg args -}-     VApp (VDef (DefId DatK (QName m))) vl | n == m -> do-        let (pars, v0 : idxs) = splitAt p vl-        v0 <- whnfClos v0-        case v0 of-          VGen i' | i' == i -> do-            forM_ (pars ++ idxs) $ \ v -> nocc [i] v >>= do-              boolToErrorDoc $-                text "variable" <+> prettyTCM (VGen i) <+>-                text "may not occur in" <+> prettyTCM v-          _ -> failDoc $-                text "wrong size index" <+> prettyTCM v0 <+>-                text "at recursive occurrence" <+> prettyTCM tv---- not necessary: check for monotonicity above---     {- case D' pars sizeArg args -}---     VApp (VDef m) vl | n /= m -> do--     VApp v1 vl -> mapM_ (\ v -> whnfClos v >>= szSizeVarDataArgs n p i) (v1:vl)--     VQuant Pi x dom fv -> do-       szSizeVarDataArgs n p i (typ dom)-       underAbs x dom fv $ \ _ xv bv -> do-          szSizeVarDataArgs n p i bv--     fv | isFun fv ->-       addName (absName fv) $ \ xv -> szSizeVarDataArgs n p i =<< app fv xv-{--     VLam x env b ->-       addName x $ \ xv -> do-         bv <- whnf (update env x xv) b-         szSizeVarDataArgs n p i bv--}-     _ -> return ()--{- REMOVED, 2009-11-28, replaced by monotonicity check-     VGen i' -> return $ i' /= i-     VSucc tv' -> szSizeVarDataArgs n p i tv'- -}---- doVParams number_of_params constructor_or_datatype_signature--- skip over parameters of type signature of a constructor/data type-doVParams :: Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a-doVParams 0 tv k = k tv-doVParams p (VQuant Pi x dom fv) k =-  underAbs x dom fv $ \ _ xv bv -> do-    doVParams (p - 1) bv k------------------------------------------- check for admissible  type--{--- - admissibility needs to be check clausewise, because of Karl's example--   fun nonAdmissibleType : Unit -> Set--   fun diverge : (u : Unit) -> nonAdmissibleType u-   {-     diverge unit patterns = badRhs-   }-- - the type must be admissible in the current position-   only if the size pattern is a successor.-   If the pattern is a variable, then there is no induction on that size-   argument, so no limit case, so no upper semi-continuity necessary-   for the type.-- - when checking--     ... (s i) ps  admissible  (j : Size) -> A--   we will check--     A  admissible in j--   and continue with--     ... ps  admissible  A[s i / j]--   just to maintain type wellformedness.  The (s i) in A does not-   really matter, since there is no case distinction on ordinals.-- - a size pattern which is not inductive (meaning there is an-    inductive type indexed by that size) nor coinductive (meaning that-    the result type is coinductive and is indexed by that size) must-    be flagged unusable for termination checking.-- - the fun/cofun distinction could be inferred by the termination checker-   or be clausewise as in Agda 2---}---admFunDef :: Co -> [Clause] -> TVal -> TypeCheck [Clause]-admFunDef co cls tv = do-  (cls, inco) <- admClauses cls tv-  when (co==CoInd && not (co `elem` inco)) $-    throwErrorMsg $ show tv ++ " is not a type of a cofun" -- ++ if co==Ind then "fun" else "cofun"-  return cls--admClauses :: [Clause] -> TVal -> TypeCheck ([Clause], [Co])-admClauses [] tv = return ([], [])-admClauses (cl:cls) tv = do-  (cl',inco) <- admClause cl tv-  (cls',inco') <- admClauses cls tv-  return (cl' : cls', inco ++ inco')--admClause :: Clause -> TVal -> TypeCheck (Clause, [Co])-admClause (Clause tel ps e) tv = traceAdm ("admClause: admissibility of patterns " ++ show ps) $-   introPatterns ps tv $ \ pvs _ -> do-       (ps', inco) <- admPatterns pvs tv-       return (Clause tel ps' e, inco)--admPatterns :: [(Pattern,Val)] -> TVal -> TypeCheck ([Pattern], [Co])-admPatterns [] tv = do-  isCo <- endsInCo tv-  return ([], if isCo then [CoInd] else [])-admPatterns ((p,v):pvs) tv = do-   (p, inco1)  <- admPattern p tv-   bv <- piApp tv v-   (ps, inco2) <- admPatterns pvs bv-   return (p:ps, inco1 ++ inco2)--{---- turn a pattern into a value--- extend delta by generic values but do not introduce their types-evalPat :: Pattern -> (Val -> TypeCheck a) -> TypeCheck a-evalPat p f =-    case p of-      VarP n -> addName n f-      ConP co n [] -> f (VCon co n)-      ConP co n pl -> evalPats pl $ \ vl -> f (VApp (VCon co n) vl)-      SuccP p -> evalPat p $ \ v -> f (VSucc v)--- DOES NOT WORK SINCE e has unbound variables-      DotP e -> do-        v <- whnf' e-        f v--evalPats :: [Pattern] -> ([Val] -> TypeCheck a) -> TypeCheck a-evalPats [] f = f []-evalPats (p:ps) f = evalPat p $ \ v -> evalPats ps $ \ vs -> f (v:vs)--}--{--evalPat :: Pattern -> TypeCheck (State TCContext Val)-evalPat p =-    case p of-      VarP n -> return $ State $ \ ce ->-        let (k, delta) = cxtPushGen (context ce)-            rho = update n (VGen k) (environ ce)-        in  (VGen k, TCContext { context = delta, environ = rho })-      ConP co n [] -> return (VCon co n)-      ConP co n pl -> do-        vl <- mapM evalPat pl-        return (VApp (VCon co n) vl)-      SuccP p -> do-       v <- evalPat p-       return (VSucc v)--- TODO: does not work!---      DotP e -> return $ State $ \ ce ->--}-----{- 2013-03-31 On instantiation of quantifiers [i < #] - F i--If F is upper semi-continuous then--  [i < #] -> F i   is a sub"set" of   F #--so we can instantiate i to #.  (Hughes et al., POPL 96; Abel, LMCS 08)--1) Consider the special case--  F i = [j < i] -> G i--Because # is a limit, thus, j < i < #  iff j < #, we reason:--  F # = [j < #] -> G j--  [i < #] -> F i-      = [i < #] -> [j < i] -> G j  (since # is a limit)-      = [j < #] -> G j--2) Consider the special case--  F i = [j <= i] -> G j--We have--  F # = [j <= #] -> G j-      = G # /\ ([j < #] -> G j)--  [i < #] -> F i-      = [i < #] -> [j <= i] -> G j-      = [j < #] -> G j--So if G is upper semi-continuous, so is F.---}----- | Check whether a type is upper semi-continuous.-lowerSemiCont :: Int -> TVal -> TypeCheck Bool-lowerSemiCont i tv = errorToBool $ lowerSemiContinuous i tv--docNotLowerSemi i av = text "type " <+> prettyTCM av <+>-  text " not lower semi continuous in " <+> prettyTCM (VGen i)--lowerSemiContinuous :: Int -> TVal -> TypeCheck ()-lowerSemiContinuous i av = do-  av <- force av-  let fallback = szAntitone i av `newErrorDoc` docNotLowerSemi i av--  case av of--    -- [j < i] & F j  is lower semi-cont in i-    -- because [i < #] & [j < i] & F j is the same as [j < #] & F j-    -- [but what if i in FV(F j)? should not matter!] 2013-04-01-    VQuant Sigma x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return ()--    -- [j <= i] & F j  is lower semi-cont in i if F is-    VQuant Sigma x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' -> do-      underAbs x dom fv $ \ j xv bv -> lowerSemiContinuous j bv--    -- Sigma-type general case-    VQuant Sigma x dom@Domain{ typ = av } fv -> do-      lowerSemiContinuous i av-      underAbs x dom fv $ \ _ xv bv -> lowerSemiContinuous i bv--    VApp (VDef (DefId DatK n)) vl -> do-      sige <- lookupSymbQ n-      case sige of--        -- finite tuple type-        DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do-          -- match target of constructor against tv to instantiate-          --  c : ... -> D ps  -- ps = snd (cPatFam ci)-          mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis-          case mrhoci of-            Nothing -> fallback-            Just (rho,ci) -> if (cRec ci) then fallback else do-              -- infinite tuples (recursive constructor) are not lower semi cont-              enter ("lowerSemiContinuous: detected tuple type, checking components") $-                allComponentTypes (cFields ci) rho (lowerSemiContinuous i)--       -- i-sized inductive types are lower semi-cont in i-        DataSig { numPars, isSized = Sized, isCo = Ind } | length vl > numPars -> do-          s <- whnfClos $ vl !! numPars -- the size argument is the first fgter the parameters-          case s of-            VGen i' | i == i' -> return ()-            _ -> fallback--        -- finite inductive type-        DataSig { symbTyp = dv, constructors = cis, isCo = Ind } ->-          -- if any cRec cis then fallback else do -- we loop on recursive data, so exclude-          -- check that we do not loop on the same data names...-          ifM ((n `elem`) <$> asks callStack) fallback $ do-          local (\ ce -> ce { callStack = n : callStack ce }) $ do-          -- match target of constructor against tv to instantiate-          --  c : ... -> D ps  -- ps = snd (cPatFam ci)-          forM_ cis $ \ ci -> do-            match <- nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv-            Foldable.forM_ match $ \ rho -> do-                enter ("lowerSemiContinuous: detected tuple type, checking components") $-                  allComponentTypes (cFields ci) rho (lowerSemiContinuous i)--        _ -> fallback-    _ -> fallback---- | Check whether a type is upper semi-continuous.-upperSemiCont :: Int -> TVal -> TypeCheck Bool-upperSemiCont i tv = errorToBool $ endsInSizedCo' False i tv-  -- 2013-03-30-  -- endsInSizedCo needs tv[0/i] = Top-  -- upperSemiCont does not need this, the target can also be constant in i---- | @endsInSizedCo i tv@ checks that @tv@ is lower semi-continuous in @i@---   and that @tv[0/i] = Top@.-endsInSizedCo :: Int -> TVal -> TypeCheck ()-endsInSizedCo = endsInSizedCo' True---- | @endsInSizedCo' False i tv@ checks that @tv@ is lower semi-continuous in @i@.---   @endsInSizedCo' True i tv@ additionally checks that @tv[0/i] = Top@.-endsInSizedCo' :: Bool -> Int -> TVal -> TypeCheck ()-endsInSizedCo' endInCo i tv  = enterDoc (text "endsInSizedCo:" <+> prettyTCM tv) $ do-   tv <- force tv-   let fallback-         | endInCo = failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a CoSet or codata of size" <+> prettyTCM (VGen i) <+> text "nor a tuple type"-         | otherwise = szMonotone i tv-   case tv of-      VSort (CoSet (VGen i)) -> return ()-      VMeasured mu bv -> endsInSizedCo' endInCo i bv--      -- case forall j <= i. C j coinductive in i-      VQuant Pi x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' ->-        underAbs x dom fv $ \ j xv bv ->-          endsInSizedCo' endInCo j bv-      VGuard (Bound Le (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' ->-        endsInSizedCo' endInCo j bv--      -- same case again, written as j < i+1. C j-      VQuant Pi x dom@Domain{ typ = VBelow Lt (VSucc (VGen i')) } fv | i == i' ->-        underAbs x dom fv $ \ j xv bv ->-          endsInSizedCo' endInCo j bv-      VGuard (Bound Lt (Measure [VGen j]) (Measure [VSucc (VGen i')])) bv | i == i' ->-        endsInSizedCo' endInCo j bv--      -- case forall j < i. C j:  already coinductive in i !!-      -- Trivially, forall j < 0. C j is the top type.-      -- And, forall i < # forall j < i  is equivalent to forall j < #-      -- so we can instantiate i to #.-      VGuard (Bound Lt (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' ->-        return ()-      VQuant Pi x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return ()--      VQuant Pi x dom fv -> do-         lowerSemiContinuous i $ typ dom-         underAbs x dom fv $ \ _ xv bv -> endsInSizedCo' endInCo i bv--      VSing _ tv -> endsInSizedCo' endInCo i =<< whnfClos tv-      VApp (VDef (DefId DatK n)) vl -> do-         sige <- lookupSymbQ n-         case sige of-            DataSig { numPars = np, isSized = Sized, isCo = CoInd }-              | length vl > np -> do-                 v <- whnfClos $ vl !! np-                 if isVGeni v then return () else fallback-                   where isVGeni (VGen i) = True-                         isVGeni (VPlus vs) = and $ map isVGeni vs-                         isVGeni (VMax vs)  = and $ map isVGeni vs-                         isVGeni VZero = True-                         isVGeni _ = False-{- WE DO NOT HAVE SUBST ON VALUES!-                 case vl !! np of-                   VGen j -> if i == j then return () else fail1-                   VZero -> return ()-                   VClos rho e -> do-                     v <- whnf (update rho i VZero) e -- BUGGER-                     if v == VZero then return () else fail1--}--- we also allow the target to be a tuple if all of its components--- fulfill "endsInSizedCo"-            DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do-              allTypesOfTuple tv vl dv cis (endsInSizedCo' endInCo i)-{--              -- match target of constructor against tv to instantiate-              --  c : ... -> D ps  -- ps = snd (cPatFam ci)-              mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis-              case mrhoci of-                Nothing -> failDoc $ text "endsInSizedCo: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor"-                Just (rho,ci) -> enter ("endsInSizedCo: detected tuple target, checking components") $-                  fieldsEndInSizedCo endInCo i (cFields ci) rho--}-            _ -> fallback-      _ -> fallback-{- failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a function type nor a codata nor a tuple type"--}---- | @allTypesOfTyples args dv cis check@ performs @check@ on all component---   types of tuple type @tv = d args@ where @dv@ is the type of @d@.-allTypesOfTuple :: TVal -> [Val] -> TVal -> [ConstructorInfo] -> (TVal -> TypeCheck ()) -> TypeCheck ()-allTypesOfTuple tv vl dv cis check = do-  -- match target of constructor against tv to instantiate-  --  c : ... -> D ps  -- ps = snd (cPatFam ci)-  mrhoci <- Util.firstJustM $-    map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis-  -- we know that only one constructor can match, otherwise it would not be a tuple type-  case mrhoci of-    Nothing -> failDoc $ text "allTypesOfTuple: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor"-    Just (rho,ci) -> enter ("allTypesOfTuple: detected tuple target, checking components") $-      allComponentTypes (cFields ci) rho check--{--fieldsEndInSizedCo :: Bool -> Int -> [FieldInfo] -> Env -> TypeCheck ()-fieldsEndInSizedCo endInCo i fis rho0 = allComponentTypes fis rho0 (endsInSizedCo' endInCo i)-fieldsEndInSizedCo endInCo i fis rho0 = enter ("fieldsEndInSizedCo: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $-  loop fis rho0 where-    loop [] rho = return ()-    -- nothing to check for erased index fields-    loop (f : fs) rho | fClass f == Index && erased (fDec f) =-      loop fs rho-    loop (f : fs) rho | fClass f == Index = do-      tv <- whnf rho (fType f)-      endsInSizedCo' endInCo i tv-      loop fs rho-    loop (f : fs) rho = do-      tv <- whnf rho (fType f)-      when (not $ erased (fDec f)) $ endsInSizedCo' endInCo i tv-      -- for non-index fields, value is not given by matching, so introduce-      -- generic value-      new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do-        let rho' = update rho (fName f) xv-        -- do not need to check erased fields?-        loop fs rho'--}---- | @allComponentTypes fis env check@ applies @check@ to all field types---   in @fis@ (evaluated wrt to environment @env@).---   Erased fields are skipped.  (Is this correct?)-allComponentTypes :: [FieldInfo] -> Env -> (TVal -> TypeCheck ()) -> TypeCheck ()-allComponentTypes fis rho0 check = enter ("allComponentTypes: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $-  loop fis rho0 where-    loop [] rho = return ()--    -- nothing to check for erased index fields-    loop (f : fs) rho | fClass f == Index && erased (fDec f) =-      loop fs rho--    -- ordinary index field types are checked-    loop (f : fs) rho | fClass f == Index = do-      check =<< whnf rho (fType f)-      loop fs rho--    -- proper fields-    loop (f : fs) rho = do-      tv <- whnf rho (fType f)-      -- do not need to check erased fields?-      when (not $ erased (fDec f)) $ check tv-      -- for non-index fields, value is not given by matching, so introduce-      -- generic value-      new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do-        loop fs $ update rho (fName f) xv----endsInCo :: TVal -> TypeCheck Bool-endsInCo tv  = -- traceCheck ("endsInCo: " ++ show tv) $-   case tv of-      VQuant Pi x dom fv -> underAbs x dom fv $ \ _ _ bv -> endsInCo bv--      VApp (VDef (DefId DatK n)) vl -> do-         sige <- lookupSymbQ n-         case sige of-            DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $-               return True-            _ -> return False-      _ -> return False---- precondition: Pattern does not contain "Unusable"-admPattern :: Pattern -> TVal -> TypeCheck (Pattern, [Co])-admPattern p tv = traceAdm ("admPattern " ++ show p ++ " type: " ++ show tv) $-  case tv of-      VGuard beta bv -> addBoundHyp beta $ admPattern p bv-      VApp (VDef (DefId DatK d)) vl -> do-         case p of-           ProjP n -> return (p, [])-           _ -> throwErrorMsg "admPattern: IMPOSSIBLE: non-projection pattern for record type"-      VQuant Pi x dom fv -> underAbs x dom fv $ \ k xv bv -> do-  {--         if p is successor pattern-         check that bv is admissible in k, returning subset of [Ind, CoInd]-         p is usable if either CoInd or it is a var or dot pattern and Ind--}-         if isSuccessorPattern p then do-           inco <- admType k bv-           when (CoInd `elem` inco && not (shallowSuccP p)) $ cannotMatchDeep p tv-           if (CoInd `elem` inco)-              || (inco /= [] && completeP p)-            then return (p, inco)-            else return (UnusableP p, inco)-          else return (p, [])--      _ -> throwErrorMsg "admPattern: IMPOSSIBLE: pattern for a non-function type"--cannotMatchDeep p tv = recoverFailDoc $-  text "cannot match against deep successor pattern"-    <+> text (show p) <+> text "at type" <+> prettyTCM tv--admType :: Int -> TVal -> TypeCheck [Co]-admType i tv = enter ("admType: checking " ++ show tv ++ " admissible in v" ++ show i) $-    case tv of-       VQuant Pi x dom@(Domain av _ _) fv -> do-          isInd <- szUsed Ind i av-          when (not isInd) $-            szAntitone i av `newErrorDoc` docNotLowerSemi i av-          underAbs x dom fv $ \ gen _ bv -> do-            inco <- admType i bv-            if isInd then return (Ind : inco) else return inco-       _ -> do-          isCoind <- szUsed CoInd  i tv-          if isCoind then return [CoInd]-           else do-            szMonotone i tv-            return []--szUsed :: Co -> Int -> TVal -> TypeCheck Bool-szUsed co i tv = traceAdm ("szUsed: " ++ show tv ++ " " ++ show co ++ " in v" ++ show i) $-    case tv of-         (VApp (VDef (DefId DatK n)) vl) ->-             do sige <- lookupSymbQ n-                case sige of-                  DataSig { numPars = p-                          , isSized = Sized-                          , isCo = co' } | co == co' && length vl > p ->-                      -- p is the number of parameters-                      -- it is also the index of the size argument-                      do s <- whnfClos $ vl !! p-                         case s of-                           VGen i' | i == i' -> return True-                           _ -> return False-                  _ -> return False-         _ -> return False------ for inductive fun, and for every size argument i--- - every argument needs to be either inductive or antitone in i--- - the result needs to be monotone in i--{- szCheckIndFun admpos delta tv-- entry point for admissibility check for recursive functions- - scans for the first size quantification- - passes on to szCheckIndFunSize- - currently: also continues to look for the next size quantification...- -}--szCheckIndFun :: [Int] -> TVal -> TypeCheck ()-szCheckIndFun admpos tv = -- traceCheck ("szCheckIndFun: " ++ show delta ++ " |- " ++ show tv ++ " adm?") $-      case tv of-       VQuant Pi x dom fv -> underAbs x dom fv $ \ k _ bv -> do-         -- bv <- whnf' b-         if isVSize (typ dom) then do-             when (k `elem` admpos) $-               szCheckIndFunSize k bv-             szCheckIndFun admpos bv -- this is for lexicographic induction on sizes, I suppose?  Probably should me more fine grained!  Andreas, 2008-12-01-          else szCheckIndFun admpos bv-       _ -> return ()---{- szCheckIndFunSize delta i tv-- checks whether type tv is admissible for recursion in index i- - every argument needs to be either inductive or antitone in i- - the result needs to be monotone in i- -}--szCheckIndFunSize :: Int -> TVal -> TypeCheck ()-szCheckIndFunSize i tv = -- traceCheck ("szCheckIndFunSize: " ++ show delta ++ " |- " ++ show tv ++ " adm(v" ++ show i ++ ")?") $-    case tv of-       VQuant Pi x dom fv -> do-            szLowerSemiCont i (typ dom)---            new x dom $ \ k _  -> szCheckIndFunSize i =<< app fv (VGen k)-            underAbs x dom fv $ \ _ _ bv -> szCheckIndFunSize i bv-{--            new' x dom $ do-              bv <- whnf' b-              szCheckIndFunSize i bv--}-       _ -> szMonotone i tv--{- szLowerSemiCont-- - check for lower semi-continuity [Abel, CSL 2006]- - current approximation: inductive type or antitone- -}-szLowerSemiCont :: Int -> TVal -> TypeCheck ()-szLowerSemiCont i av = -- traceCheck ("szlowerSemiCont: checking " ++ show av ++ " lower semi continuous in v" ++ show i) $-   (szAntitone i av `catchError`-      (\ msg -> -- traceCheck (show msg) $-                   szInductive i av))-        `newErrorDoc` docNotLowerSemi i av---{- checking cofun-types for admissibility--conditions:--1. type must end in coinductive type or in sized coinductive type-   indexed by just a variable i which has been quantified in the type--2. in the second case, each argument must be inductive or antitone in i-   optimization:-     arguments types before the quantification over i can be ignored--}--data CoFunType-  = CoFun             -- yes, but not sized cotermination-  | SizedCoFun Int    -- yes an admissible sized type (the Int specifies the number of the recursive size argument)--{--design:--admCoFun delta tv : IsCoFunType--   endsInCo delta tv (len delta) id--admEndsInCo delta tv firstVar jobs : IsCoFunType--   traverse tv, gather continutations in jobs, check for CoInd in the end--   if tv = (x:A) -> B-      push A on delta-      add the following task to jobs:-        check A for lower semicontinuity in delta-      continue on B--   if tv = Codata^i-      run (jobs i)-      if they return (), return YesSized Int, otherwise No--   if tv = Codata-      return Yes--   otherwise-      return No- -}---- {- TODO: FINISH THIS!!--admCoFun :: TVal -> TypeCheck CoFunType-admCoFun tv = do-  l <- getLen-  admEndsInCo tv l (\ i -> return ())--admEndsInCo :: TVal -> Int -> (Int -> TypeCheck ()) -> TypeCheck CoFunType-admEndsInCo tv firstVar jobs = -- traceCheck ("admEndsInCo: " ++ show tv) $-   case tv of-      VQuant Pi x dom fv -> do-         l <- getLen-         let jobs' = (addJob l (typ dom) jobs)-         underAbs x dom fv $ \ _ _ bv -> admEndsInCo bv firstVar jobs'-{--         new' x dom $ do-           bv <- whnf' b-           admEndsInCo bv firstVar jobs'--}--{--      -- if not applied, it cannot be a sized type-      VDef n -> do-         sig <- gets signature-         case (lookupSig n sig) of-            DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $-               return CoFun-            _ -> throwErrorMsg $ "type of cofun does not end in coinductive type"--}--      VApp (VDef (DefId DatK n)) vl -> do-         sige <- lookupSymbQ n-         case sige of-            DataSig { isSized = NotSized, isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $-               return CoFun-            DataSig { numPars = p, isSized = Sized, isCo = CoInd } | length vl > p -> -- traceCheck ("found sized coinductive target") $-              do-               -- p is the number of parameters-               -- it is also the index of the size argument-               s <- whnfClos $ vl !! p-               case s of-                  VGen i -> do-                     jobs i-                     return $ SizedCoFun $ i - firstVar-                  _ -> throwErrorMsg $ "size argument in result type must be a variable"-            _ -> throwErrorMsg $ "type of cofun does not end in coinductive type"--addJob :: Int -> TVal -> (Int -> TypeCheck ())-       -> (Int -> TypeCheck ())-addJob l tv jobs recVar = do-  -- is the "recursive" size variable actually in scope?-  jobs recVar-  when (recVar < l) $ szLowerSemiCont recVar tv---- -}---{- szCheckCoFun  OBSOLETE!!-- entry point for admissibility check for corecursive functions- - scans for the first size quantification- - passes on to szCheckIndFunSize- - currently: also continues to look for the next size quantification- - and checks in the end whether the target is a coinductive type----- STALE COMMENT: for a cofun : arguments nocc i and result coinductive in i-szCheckCoFun :: SemCxt -> TVal -> TypeCheck ()-szCheckCoFun delta tv =-      case tv of-       VPi dec x av env b -> do-                let (k, delta') = cxtPush dec av delta-                bv <- whnf (update env x (VGen k)) b-                case av of-                  VSize -> do szCheckCoFunSize delta' k bv-                              szCheckCoFun delta' bv-                  _ -> szCheckCoFun delta' bv-       -- result-       (VApp (VDef n) vl) ->-          do sig <- gets signature-             case (lookupSig n sig) of-               (DataSig _ _ _ CoInd _) ->-                   return ()-               _ -> throwErrorMsg $ "cofun doesn't target coinductive type"-       (VDef n)  ->-          do sig <- gets signature-             case (lookupSig n sig) of-               (DataSig _ _ _ CoInd _) ->-                   return ()-               _ -> throwErrorMsg $ "cofun doesn't target coinductive type"-       _ -> throwErrorMsg $ "cofun doesn't target coinductive type"--szCheckCoFunSize :: SemCxt -> Int -> TVal -> TypeCheck ()-szCheckCoFunSize delta i tv = -- traceCheck ("szco " ++ show tv) $-      case tv of-       VPi dec x av env b ->  do-             let (k, delta') = cxtPush dec av delta-             bv <- whnf (update env x (VGen k)) b-             szLowerSemiCont delta i av-             szCheckCoFunSize delta' i bv-       -- result must be coinductive-       _ -> szCoInductive delta i tv---}--szMono :: Co -> Int -> TVal -> TypeCheck ()-szMono co i tv =-    case co of-         Ind   -> szMonotone i tv-         CoInd -> szAntitone i tv--szMonotone :: Int -> TVal -> TypeCheck ()-szMonotone i tv = traceCheck ("szMonotone: " -- ++ show delta ++ " |- "-                              ++ show tv ++ " mon(v" ++ show i ++ ")?") $- do-   let si = VSucc (VGen i)-   tv' <- substitute (sgSub i si) tv-   leqVal Pos vTopSort tv tv'--szAntitone :: Int -> TVal -> TypeCheck ()-szAntitone i tv = traceCheck ("szAntitone: " -- ++ show delta ++ " |- "-                              ++ show tv ++ " anti(v" ++ show i ++ ")?") $- do-   let si = VSucc (VGen i)-   tv' <- substitute (sgSub i si) tv-   leqVal Neg vTopSort tv tv'---- checks if tv is a sized inductive type of size i-szInductive :: Int -> TVal -> TypeCheck ()-szInductive i tv = szUsed' Ind i tv---- checks if tv is a sized coinductive type of size i-szCoInductive :: Int -> TVal -> TypeCheck ()-szCoInductive i tv = szUsed' CoInd i tv--szUsed' :: Co -> Int -> TVal -> TypeCheck ()-szUsed' co i tv =-    case tv of-         (VApp (VDef (DefId DatK n)) vl) ->-             do sige <- lookupSymbQ n-                case sige of-                  DataSig { numPars = p, isSized = Sized, isCo =  co' } | co == co' && length vl > p ->-                      -- p is the number of parameters-                      -- it is also the index of the size argument-                      do s <- whnfClos $ vl !! p-                         case s of-                           VGen i' | i == i' -> return ()-                           _ -> throwErrorMsg $ "expected size variable"-                  _ -> throwErrorMsg $ "expected (co)inductive sized type"-         _ -> throwErrorMsg $ "expected (co)inductive sized type"
− Util.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TupleSections, NoMonomorphismRestriction,-      FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}--module Util where--import Prelude hiding (showList, null)--import Control.Applicative hiding (empty)-import Control.Monad-import Control.Monad.Writer (Writer, runWriter, All, getAll)--import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Debug.Trace--import Text.PrettyPrint as PP--(+?+) :: String -> String -> String-(+?+) xs "[]" = []-(+?+) xs ys = xs ++ ys--implies :: Bool -> Bool -> Bool-implies a b = if a then b else True--class Pretty a where-    pretty	:: a -> Doc-    prettyPrec	:: Int -> a -> Doc--    pretty	= prettyPrec 0-    prettyPrec	= const pretty--instance Pretty Doc where-    pretty = id--angleBrackets :: Doc -> Doc-angleBrackets d = text "<" <+> d <+> text ">"---- | Apply when condition is @True@.-fwhen :: Bool -> (a -> a) -> a -> a-fwhen True  f a = f a-fwhen False f a = a--parensIf :: Bool -> Doc -> Doc-parensIf b = fwhen b PP.parens--hsepBy :: Doc -> [Doc] -> Doc-hsepBy sep [] = empty-hsepBy sep [d] = d-hsepBy sep (d:ds) = d <> sep <> hsepBy sep ds--pwords :: String -> [Doc]-pwords = map text . words--fwords :: String -> Doc-fwords = fsep . pwords--fromAllWriter :: Writer All a -> (Bool, a)-fromAllWriter m = let (a, w) = runWriter m-                  in  (getAll w, a)--traceM :: (Monad m) => String -> m ()-traceM msg = trace msg $ return ()--infixr 9 <.>---- | Composition: pure function after monadic function.-(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c-(f <.> g) a = f <$> g a--whenM :: Monad m => m Bool -> m () -> m ()-whenM mb k = mb >>= (`when` k)--unlessM :: Monad m => m Bool -> m () -> m ()-unlessM mb k = mb >>= (`unless` k)--whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m ()-whenJustM mm k = mm >>= (`whenJust` k)--whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) k = k a-whenJust Nothing  k = return ()--whenNothing :: (Monad m) => Maybe a -> m () -> m ()-whenNothing Nothing m = m-whenNothing Just{}  m = return ()--ifNothingM :: (Monad m) => m (Maybe a) -> m b -> (a -> m b) -> m b-ifNothingM mma mb f = maybe mb f =<< mma--ifJustM :: (Monad m) => m (Maybe a) -> (a -> m b) -> m b -> m b-ifJustM mma f mb = maybe mb f =<< mma--mapMapM :: (Monad m, Ord k) => (a -> m b) -> Map k a -> m (Map k b)-mapMapM f = Map.foldrWithKey step (return $ Map.empty)-  where step k a m = do a' <- f a-                        m' <- m-                        return $ Map.insert k a' m'--ifM :: Monad m => m Bool -> m a -> m a -> m a-ifM c d e = do { b <- c ; if b then d else e }--{- Control.Monad.IfElse-whenM :: Monad m => m Bool -> m () -> m ()-whenM c d = do { b <- c; if b then d else return () }--unlessM :: Monad m => m Bool -> m () -> m ()-unlessM c e = do { b <- c; if b then return () else e }--}--andLazy :: Monad m => m Bool -> m Bool -> m Bool-andLazy ma mb = ifM ma mb $ return False--andM  :: Monad m => [m Bool] -> m Bool-andM []     = return True-andM (m:ms) = m `andLazy` andM ms--findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM p []       = return Nothing-findM p (x : xs) = do b <- p x-                      if b then return (Just x) else findM p xs---- | Binary version of @=<<@.-(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c-f ==<< (ma, mb) = do { a <- ma; f a =<< mb }--parens :: String -> String-parens s = "(" ++ s ++ ")"--brackets :: String -> String-brackets s = "[" ++ s ++ "]"--bracketsIf :: Bool -> String -> String-bracketsIf False s = s-bracketsIf True  s = "[" ++ s ++ "]"--separate :: String -> String -> String -> String-separate sep "" y = y-separate sep x "" = x-separate sep x y  = x ++ sep ++ y--showList :: String -> (a -> String) -> [a] -> String-showList sep f [] = ""-showList sep f [e] = f e-showList sep f (e:es) = f e ++ sep ++ showList sep f es--- OR: showList sep f es = foldl separate "" $ map f es--hasDuplicate :: (Eq a) => [a] -> Bool-hasDuplicate [] = False-hasDuplicate (x : xs) = x `elem` xs || hasDuplicate xs--compressMaybes :: [Maybe a] -> [a]-compressMaybes = concat . map (maybe [] (\ a -> [a]))--mapFst :: (a -> c) -> (a,d) -> (c,d)-mapFst f (a,b) = (f a, b)--mapSnd :: (b -> d) -> (a,b) -> (a,d)-mapSnd f (a,b) = (a, f b)--mapPair :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)-mapPair f g (a,b) = (f a, g b)--zipPair :: (a -> b -> c) -> (d -> e -> f) -> (a,d) -> (b,e) -> (c,f)-zipPair f g (a,d) (b,e) = (f a b, g d e)--headMaybe :: [a] -> Maybe a-headMaybe [] = Nothing-headMaybe (a:as) = Just a--firstJust :: [Maybe a] -> Maybe a-firstJust = headMaybe . compressMaybes--firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)-firstJustM [] = return Nothing-firstJustM (mm : mms) = do-  m <- mm-  case m of-    Nothing -> firstJustM mms-    Just{}  -> return m--mapOver :: (Functor f) => f a -> (a -> b) -> f b-mapOver = flip fmap--for = mapOver--mapAssoc :: (a -> b) -> [(n,a)] -> [(n,b)]-mapAssoc f = map (\ (n, a) -> (n, f a))--mapAssocM :: (Applicative m, Monad m) => (a -> m b) -> [(n,a)] -> m [(n,b)]-mapAssocM f = mapM (\ (n, a) -> (n,) <$> f a)--compAssoc :: Eq b => [(a,b)] -> [(b,c)] -> [(a,c)]-compAssoc xs ys = [ (a,c) | (a,b) <- xs, (b',c) <- ys, b == b' ]---- * Lists and stacks of lists--class Push a b where-  push    :: a -> b -> b--instance Push a [a] where-  push = (:)--instance Push a [[a]] where-  push a (b:bs) = (a : b) : bs---- TOO HARD for ghc:--- instance Push a b => Push a [b] where---   push a (b:bs) = push a b : bs--class Retrieve a b c | b -> c where-  retrieve :: Eq a => a -> b -> Maybe c--instance Retrieve a [(a,b)] b where-  retrieve = lookup--instance Retrieve a [[(a,b)]] b where-  retrieve a = retrieve a . concat---- instance Retrieve a b c => Retrieve a [b] c where---   retrieve a = firstJust . map (retrieve a)--{--class ListLike a where-  length :: a -> Int-  null   :: a -> Bool-  nil    :: a--}--class Size a where-  size :: a -> Int--instance Size [a] where-  size = length--class Null a where-  null :: a -> Bool--instance Null [a] where-  null = List.null
− Value.hs 
@@ -1,407 +0,0 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}--module Value where--import Prelude hiding (null)--import Control.Applicative--import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set-import Debug.Trace--import Abstract-import Polarity-import Util-import TraceError -- orM---- call-by-value--- cofuns are not forced--data Val-  -- sizes-  = VInfty-  | VZero-  | VSucc Val-  | VMax [Val]-  | VPlus [Val]-  | VMeta MVar Env Int           -- X rho + n  (n-fold successor of X rho)-  -- types-  | VSort (Sort Val)-  | VMeasured (Measure Val) Val  -- mu -> A  (only in checkPattern)-  | VGuard (Bound Val) Val       -- mu<mu' -> A-  | VBelow LtLe Val              -- domain in bounded size quant.-  | VQuant-    { vqPiSig :: PiSigma-    , vqName  :: Name-    , vqDom   :: Domain-    , vqFun   :: FVal-    }-  | VSing Val TVal               -- Singleton type (TVal not Pi)-  -- functions-  | VLam Name Env Expr-  | VAbs Name Int Val Valuation  -- abstract free variable-  | VConst Val                   -- constant function-  | VUp Val TVal                 -- delayed eta expansion; TVal is a Pi-  -- values-  | VRecord RecInfo EnvMap       -- a record value / fully applied constructor-  | VPair Val Val                -- eager pair-  -- neutrals-  | VGen Int                     -- free variable (de Bruijn level)-  | VDef DefId                   -- co(data/constructor/fun)-                                 -- VDef occurs only inside a VApp!-  | VCase Val TVal Env [Clause]-  | VApp Val [Clos]-  -- closures-  | VProj PrePost Name           -- a projection as an argument to a neutral-  | VClos Env Expr               -- closure for cbn evaluation-  -- don't care-  | VIrr                         -- erased hypothetical inhabitant of empty type-    deriving (Eq,Ord)---- | Makes constant function if name is empty.-vLam :: Name -> Env -> Expr -> FVal-vLam x env e-  | emptyName x = VConst $ VClos env e-  | otherwise   = VLam x env e---- | Is a value a function?  May become more @True@ after forcing the @VUp@.-isFun :: Val -> Bool-isFun VLam{}                         = True-isFun VAbs{}                         = True-isFun VConst{}                       = True-isFun (VUp _ VQuant{ vqPiSig = Pi }) = True-isFun v                              = False--absName :: FVal -> Name-absName fv =-  case fv of-    VLam x _ _              -> x-    VAbs x _ _ _            -> x-    VUp _ (VQuant Pi x _ _) -> x-    _                       -> noName--type FVal = Val-type TVal = Val -- type value-type Clos = Val-type Domain = Dom TVal---- | Valuation of free variables.-newtype Valuation = Valuation { valuation :: [(Int,Val)] }-  deriving (Eq,Ord)--emptyVal  = Valuation []-sgVal i v = Valuation [(i,v)]--valuateGen :: Int -> Valuation -> Val-valuateGen i valu = maybe (VGen i) id $ lookup i $ valuation valu--type TeleVal = [TBinding Val]--data Environ a = Environ-  { envMap   :: [(Name,a)]          -- the actual map from names to values-  , envBound :: Maybe (Measure Val) -- optionally the current termination measure-  }-               deriving (Eq,Ord,Show)--type EnvMap = [(Name,Val)]-type Env = Environ Val--{--data MeasVal = MeasVal [Val]  -- lexicographic termination measure-               deriving (Eq,Ord,Show)--}---- smart constructors ---------------------------------------------------- | The value representing type Size.-vSize :: Val-vSize = VBelow Le VInfty -- 2012-01-28 non-termination bug I have not found--- vSize = VSort $ SortC Size--vFinSize = VBelow Lt VInfty---- | Ensure we construct the correct value representing Size.-vSort :: Sort Val -> Val-vSort (SortC Size) = vSize-vSort s            = VSort s--isVSize :: Val -> Bool-isVSize (VSort (SortC Size)) = True-isVSize (VBelow Le VInfty)   = True-isVSize _                    = False--vTSize = VSort $ SortC TSize--vTopSort :: Val-vTopSort = VSort $ Set VInfty--mkClos :: Env -> Expr -> Val-mkClos rho Infty       = VInfty-mkClos rho Zero        = VZero--- mkClos rho (Succ e)    = VSucc (mkClos rho e)  -- violates an invariant!! succeed/crazys-mkClos rho (Below ltle e) = VBelow ltle (mkClos rho e)-mkClos rho (Proj fx n) = VProj fx n-mkClos rho (Var x) = lookupPure rho x-mkClos rho (Ann e) = mkClos rho $ unTag e-mkClos rho e = VClos rho e-  -- Problem with MetaVars: freeVars of a meta var is unknown in this repr.!-  -- VClos (rho { envMap = filterEnv (freeVars e) (envMap rho)}) e--filterEnv :: Set Name -> EnvMap -> EnvMap-filterEnv ns [] = []-filterEnv ns ((x,v) : rho) =-  if Set.member x ns then (x,v) : filterEnv (Set.delete x ns) rho-   else filterEnv ns rho--vDef id   = VDef id `VApp` []-vCon co n = vDef $ DefId (ConK co) n--- vCon co n = vDef $ DefId (ConK (coToConK co)) n-vFun n    = vDef $ DefId FunK $ QName n-vDat n    = vDef $ DefId DatK n--{- POSSIBLY BREAKS INVARIANT!-vApp :: Val -> [Val] -> Val-vApp f [] = f-vApp f vs = VApp f vs--}--vAbs :: Name -> Int -> Val -> FVal-vAbs x i v = VAbs x i v emptyVal--arrow , prod :: TVal -> TVal -> TVal-arrow = quant Pi-prod  = quant Sigma--quant piSig a b = VQuant piSig x (defaultDomain a) (VConst b)-  where x   = fresh ""--- quant piSig a b = VQuant piSig x (defaultDomain a) (Environ [(bla,b)] Nothing) (Var bla)---   where x   = fresh ""---         bla = fresh "#codom"----- * Sizes ---------------------------------------------------------------- Sizes form a commutative semiring with multiplication (Plus) and--- idempotent addition (Max)------ Wellformed size values are polynomials, i.e., sums (Max) of products (Plus).--- A monomial m takes one of the forms (k stands for a variable: VGen or VMeta)--- 0. VSucc^* VZero--- 1. VSucc^* k--- 2. VSucc^* (VPlus [k1,...,kn])   where n>=2--- A polynomial takes one of the forms--- 0. VInfty--- 1. m--- 2. VMax ms  where length ms >= 2 and each mi different-{- OLD--- * VSucc^* VGen--- * VMax vs where each v_i = VSucc^* (VGen k_i) and all k_i different---           and vs has length >= 2--}------ the smart constructors construct wellformed size values using the laws--- $ #             = #                Infty--- max # k         = #--- $ (max i j)     = max ($ i) ($ j)  $ distributes over max--- max (max i j) k = max i j k        Assoc-Commut of max--- max i i         = i                Idempotency of max-succSize :: Val -> Val-succSize v = case v of-            VInfty -> VInfty-            VMax vs -> maxSize $ map succSize vs-            VMeta i rho n -> VMeta i rho (n + 1)  -- TODO: integrate + and mvar-            _ -> VSucc v-vSucc = succSize---- "multiplication" of sizes-plusSize :: Val -> Val -> Val-plusSize VZero v = v-plusSize v VZero = v-plusSize VInfty v = VInfty-plusSize v VInfty = VInfty-plusSize (VMax vs) v = maxSize $ map (plusSize v) vs-plusSize v (VMax vs) = maxSize $ map (plusSize v) vs-plusSize (VSucc v) v' = succSize $ plusSize v v'-plusSize v' (VSucc v) = succSize $ plusSize v v'-plusSize (VPlus vs) (VPlus vs') = VPlus $ List.sort (vs ++ vs') -- every summand is a var!  -- TODO: more efficient sorting!-plusSize (VPlus vs) v = VPlus $ List.insert v vs-plusSize v (VPlus vs) = VPlus $ List.insert v vs-plusSize v v' = VPlus $ List.sort [v,v']--plusSizes :: [Val] -> Val-plusSizes [] = VZero-plusSizes [v] = v-plusSizes (v:vs) = v `plusSize` (plusSizes vs)---- maxSize vs = VInfty                 if any v_i=Infty---            = VMax (sort (nub (flatten vs)) else--- precondition vs--maxSize :: [Val] -> Val-maxSize vs = case Set.toList . Set.fromList <$> flatten vs of-   Nothing -> VInfty-   Just [] -> VZero-   Just [v] -> v-   Just vs' -> VMax vs'-  where flatten (VZero:vs) = flatten vs-        flatten (VInfty:_) = Nothing-        flatten (VMax vs:vs') = flatten vs' >>= return . (vs++)-        flatten (v:vs) = flatten vs >>= return . (v:)-        flatten [] = return []--{--maxSize :: [Val] -> Val-maxSize vs = case flatten [] vs of-   [] -> VInfty-   [v] -> v-   vs' -> VMax vs'-  where flatten acc (VInfty:_) = []-        flatten acc (VMax vs:vs') = flatten (vs ++ acc) vs'-        flatten acc (v:vs) = flatten (v:acc) vs-        flatten acc [] = Set.toList $ Set.fromList acc -- sort, nub--}---- * destructors ---------------------------------------------------------vSortToSort :: Sort Val -> Sort Expr-vSortToSort (SortC c)    = SortC c-vSortToSort (Set VInfty) = Set Infty--predSize :: Val -> Maybe Val-predSize VInfty = Just VInfty-predSize (VSucc v) = Just v-predSize (VMax vs) = do vs' <- mapM predSize vs-                        return $ maxSize vs'-predSize (VMeta v rho n) | n > 0 = return $ VMeta v rho (n-1)-predSize _ = Nothing -- variable or zero or sum--instance HasPred Val where-  predecessor VInfty = Nothing -- for printing bounds-  predecessor v = predSize v--isFunType :: TVal -> Bool-isFunType VQuant{ vqPiSig = Pi } = True-isFunType _                      = False--isDataType :: TVal -> Bool-isDataType (VApp (VDef (DefId DatK _)) _) = True-isDataType (VSing v tv) = isDataType tv-isDataType _ = False---- * ugly printing -------------------------------------------------------instance Show (Sort Val) where-  show (SortC c) = show c-  show (Set VZero) = "Set"-  show (CoSet VInfty) = "Set"-  show (Set v) = parens $ ("Set " ++ show v)-  show (CoSet v) = parens $ ("CoSet " ++ show v)--instance Show Val where-  show v | isVSize v = "Size"-  show (VSort s) = show s-  show VInfty = "#"-  show VZero = "0"-  show (VSucc v) = "($ " ++ show v ++ ")"-  show (VMax vl) = "(max " ++ showVals vl ++ ")"-  show (VPlus (v:vl)) = parens $ foldr (\ v s -> show v ++ " + " ++ s) (show v) vl-  show (VApp v []) = show v-  show (VApp v vl) = "(" ++ show v ++ " " ++ showVals vl ++ ")"-  show (VDef id) = show id-  show (VProj Pre id) = show id-  show (VProj Post id) = "." ++ show id-  show (VPair v1 v2) = "(" ++ show v1 ++ ", " ++ show v2 ++ ")"-  show (VGen k) = "v" ++ show k-  show (VMeta k rho 0) = "?" ++ show k ++ showEnv rho-  show (VMeta k rho 1) = "$?" ++ show k ++ showEnv rho-  show (VMeta k rho n) = "(?" ++ show k ++ showEnv rho ++ " + " ++ show n ++")"-  show (VRecord ri env) = show ri ++ "{" ++ Util.showList "; " (\ (n, v) -> show n ++ " = " ++ show v) env ++ "}"-  show (VCase v vt env cs) = "case " ++ show v ++ " : " ++ show vt ++ " { " ++ showCases cs ++ " } " ++ showEnv env-  show (VClos (Environ [] Nothing) e) = showsPrec precAppR e ""-  show (VClos env e) = "{" ++ show e ++ " " ++ showEnv env ++ "}"-  show (VSing v vt) = "<" ++ show v ++ " : " ++ show vt ++ ">"-  show VIrr  = "."-  show (VMeasured mu tv) = parens $ show mu ++ " -> " ++ show tv-  show (VGuard beta tv) = parens $ show beta ++ " -> " ++ show tv-  show (VBelow ltle v) = show ltle ++ " " ++ show v--  show (VQuant pisig x (Domain (VBelow ltle v) ki dec) bv)-       | (ltle,v) /= (Le,VInfty) =-       parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) ++-                (if erased dec then brackets binding else parens binding)-                 ++ " " ++ show pisig ++ " " ++ showSkipLambda bv-            where binding = show x ++ " " ++ show ltle ++ " " ++ show v--  show (VQuant pisig x (Domain av ki dec) bv) =-        parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) ++-                (if erased dec then brackets binding-                  else if emptyName x then s1 else parens binding)-                    ++ " " ++ show pisig ++ " " ++ showSkipLambda bv-             where s1 = s2 ++ s0-                   s2 = show av-                   s3 = show ki-                   s0 = if ki == defaultKind || s2 == s3 then "" else "::" ++ s3-                   binding = if emptyName x then  s1 else show x ++ " : " ++ s1--  show (VLam x env e) = "(\\" ++ show x ++ " -> " ++ show e ++ showEnv env ++ ")"-  show (VConst v) = "(\\ _ -> " ++ show v ++ ")"-  show (VAbs x i v valu) = "(\\" ++ show x ++ "@" ++ show i ++ show v ++ showValuation valu ++ ")"-  show (VUp v vt) = "(" ++ show v ++ " Up " ++ show vt ++ ")"--showSkipLambda v =-  case v of-    (VLam x env e)    -> show e ++ showEnv env-    (VConst v)        -> show v-    (VAbs x i v valu) -> show v ++ showValuation valu-    v                 -> show v--showVals :: [Val] -> String-showVals [] = ""-showVals (v:vl) = show v ++ (if null vl then "" else " " ++ showVals vl)---- environment -----------------------------------------------------emptyEnv :: Environ a-emptyEnv = Environ [] Nothing--appendEnv :: Environ a -> Environ a -> Environ a-appendEnv (Environ rho mmeas) (Environ rho' mmeas') =-  Environ (rho ++ rho') (orM mmeas mmeas')---- | enviroment extension / update-update :: Environ a -> Name -> a -> Environ a-update env n v | emptyName n = env-               | otherwise   = env { envMap = (n,v) : envMap env }--lookupPure :: Show a => Environ a -> Name -> a-lookupPure rho x =-    case lookup x (envMap rho) of-      Just v -> v-      Nothing -> error $ "lookupPure: unbound identifier " ++ show x ++ " in environment " ++ show rho--lookupEnv :: Monad m => Environ a -> Name -> m a-lookupEnv rho x =-    case lookup x (envMap rho) of-      Just v -> return $ v-      Nothing -> fail $ "lookupEnv: unbound identifier " ++ show x --  ++ " in environment " ++ show rho-{--lookupEnv :: Monad m => Environ a -> Name -> m a-lookupEnv [] n = fail $ "lookupEnv: identifier " ++ show n ++ " not bound"-lookupEnv ((x,v):xs) n = if x == n then return v-                          else lookupEnv xs n--}--showValuation :: Valuation -> String-showValuation (Valuation [])  = ""-showValuation (Valuation tau) = "{" ++ Util.showList ", " (\(i,v) -> show i ++ " = " ++ show v) tau ++ "}"--showEnv :: Environ Val -> String-showEnv (Environ [] Nothing)   = ""-showEnv (Environ rho Nothing)  = "{" ++ showEnv' rho ++ "}"-showEnv (Environ [] (Just mu)) = "{ measure=" ++ show mu ++ " }"-showEnv (Environ rho (Just mu)) = "{" ++ showEnv' rho ++ " | measure=" ++ show mu ++ " }"--showEnv' :: EnvMap -> String-showEnv' = Util.showList ", " (\ (n,v) -> show n ++ " = " ++ show v)
− Value.hs-boot 
@@ -1,10 +0,0 @@-module Value where--import {-# SOURCE #-} Abstract--data Val-instance Eq Val-instance Ord Val-instance Show Val--type TeleVal = [TBinding Val]
− Warshall.hs 
@@ -1,433 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--module Warshall where--{- construct a graph from constraints--   x + n <= y   becomes   x ---(-n)---> y-   x <= n + y   becomes   x ---(+n)---> y--the default edge (= no edge is) labelled with infinity--building the graph involves keeping track of the node names.-We do this in a finite map, assigning consecutive numbers to nodes.--}---import Control.Monad.State-import Data.Maybe -- fromJust-import Data.Array-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.List as List--import Debug.Trace-import Util---traceSolve msg a = a -- trace msg a -traceSolveM msg = return () -- traceM msg-{--traceSolve msg a = trace msg a -traceSolveM msg = traceM msg--}----- semi rings ------------------------------------------------------class SemiRing a where-  oplus  :: a -> a -> a-  otimes :: a -> a -> a-  ozero  :: a -- neutral for oplus, dominant for otimes-  oone   :: a -- neutral for otimes--type Matrix a = Array (Int,Int) a---- assuming a square matrix-warshall :: SemiRing a => Matrix a -> Matrix a-warshall a0 = loop r a0 where -  b@((r,c),(r',c')) = bounds a0 -- assuming r == c and r' == c'-  loop k a | k <= r' = -    loop (k+1) (array b [ ((i,j), -                           (a!(i,j)) `oplus` ((a!(i,k)) `otimes` (a!(k,j))))-                        | i <- [r..r'], j <- [c..c'] ])-           | otherwise = a---- edge weight in the graph, forming a semi ring --data Weight = Finite Int | Infinite -              deriving (Eq)--inc :: Weight -> Int -> Weight-inc Infinite   n = Infinite-inc (Finite k) n = Finite (k + n)--instance Show Weight where-  show (Finite i) = show i-  show Infinite   = "."--instance Ord Weight where-  a <= Infinite = True-  Infinite <= b = False-  Finite a <= Finite b = a <= b--instance SemiRing Weight where-  oplus = min--  otimes Infinite _ = Infinite-  otimes _ Infinite = Infinite-  otimes (Finite a) (Finite b) = Finite (a + b)--  ozero = Infinite-  oone  = Finite 0- --- constraints ------------------------------------------------------- nodes of the graph are either --- * flexible variables (with identifiers drawn from Int), --- * rigid variables (also identified by Ints), or --- * constants (like 0, infinity, or anything between)--data Node rigid-  = Rigid rigid-  | Flex  FlexId-    deriving (Eq, Ord)--instance Show rigid => Show (Node rigid) where-  show (Flex  i) = "?" ++ show i-  show (Rigid r) = show r--data Rigid = RConst Weight-           | RVar RigidId-             deriving (Eq, Ord)--instance Show Rigid where-  show (RVar i) = "v" ++ show i-  show (RConst Infinite)   = "#"-  show (RConst (Finite n)) = show n--type NodeId  = Int-type RigidId = Int-type FlexId  = Int-type Scope   = RigidId -> Bool  --- which rigid variables a flex may be instatiated to--infinite (RConst Infinite) = True-infinite _ = False---- isBelow r w r'  --- checks, if r and r' are connected by w (meaning w not infinite)--- wether r + w <= r'--- precondition: not the same rigid variable-isBelow :: Rigid -> Weight -> Rigid -> Bool-isBelow _ Infinite _ = True-isBelow _ n (RConst Infinite) = True--- isBelow (RConst Infinite)   n (RConst (Finite _)) = False-isBelow (RConst (Finite i)) (Finite n) (RConst (Finite j)) = i + n <= j-isBelow _ _ _ = False -- rigid variables are not related---- a constraint is an edge in the graph-data Constrnt edgeLabel rigid flexScope-  = NewFlex FlexId flexScope-  | Arc (Node rigid) edgeLabel (Node rigid)--- Arc v1 k v2  at least one of v1,v2 is a VMeta (Flex), ---              the other a VMeta or a VGen (Rigid)--- if k <= 0 this means  $^(-k) v1 <= v2--- otherwise                    v1 <= $^k v3--type Constraint = Constrnt Weight Rigid Scope--arc :: Node Rigid -> Int -> Node Rigid -> Constraint-arc a k b = Arc a (Finite k) b--instance Show Constraint where-  show (NewFlex i s) = "SizeMeta(?" ++ show i ++ ")"-  show (Arc v1 (Finite k) v2) -    | k == 0 = show v1 ++ "<=" ++ show v2-    | k < 0  = show v1 ++ "+" ++ show (-k) ++ "<=" ++ show v2-    | otherwise  = show v1 ++ "<=" ++ show v2 ++ "+" ++ show k--type Constraints = [Constraint]--emptyConstraints = []---- graph (matrix) --------------------------------------------------data Graph edgeLabel rigid flexScope = Graph -  { flexScope :: Map FlexId flexScope       -- scope for each flexible var-  , nodeMap :: Map (Node rigid) NodeId      -- node labels to node numbers-  , intMap  :: Map NodeId (Node rigid)      -- node numbers to node labels-  , nextNode :: NodeId                      -- number of nodes (n)-  , graph :: NodeId -> NodeId -> edgeLabel  -- the edges (restrict to [0..n[)-  }---- the empty graph: no nodes, edges are all undefined (infinity weight)-initGraph :: SemiRing edgeLabel => Graph edgeLabel rigid flexScope-initGraph = Graph Map.empty Map.empty Map.empty 0 (\ x y -> ozero)---- the Graph Monad, for constructing a graph iteratively-type GM edgeLabel rigid flexScope = State (Graph edgeLabel rigid flexScope)--addFlex :: FlexId -> flexScope -> GM edgeLabel rigid flexScope ()-addFlex x scope = do-  st <- get-  put $ st { flexScope = Map.insert x scope (flexScope st) }----- i <- addNode n  returns number of node n. if not present, it is added first-addNode :: (Eq rigid, Ord rigid) => (Node rigid) -> GM edgeLabel rigid flexScope Int-addNode n = do-  st <- get-  case Map.lookup n (nodeMap st) of-    Just i -> return i-    Nothing -> do let i = nextNode st-                  put $ st { nodeMap = Map.insert n i (nodeMap st)-                           , intMap = Map.insert i n (intMap st)-                           , nextNode = i + 1-                           }-                  return i---- addEdge n1 k n2  --- improves the weight of egde n1->n2 to be at most k--- also adds nodes if not yet present-addEdge :: (Eq rigid, Ord rigid, SemiRing edgeLabel) => (Node rigid) -> edgeLabel -> (Node rigid) -> GM edgeLabel rigid flexScope ()-addEdge n1 k n2 = do-  i1 <- addNode n1-  i2 <- addNode n2-  st <- get-  let graph' x y = if (x,y) == (i1,i2) then k `oplus` (graph st) x y-                   else graph st x y-  put $ st { graph = graph' }--addConstraint :: (Eq rigid, Ord rigid, SemiRing edgeLabel) =>  -  Constrnt edgeLabel rigid flexScope -> GM edgeLabel rigid flexScope ()-addConstraint (NewFlex x scope) = do-  addFlex x scope-  addEdge (Flex x) oone (Flex x) -- add dummy edge to make sure each meta variable-                              -- is in the matrix and gets solved-addConstraint (Arc n1 k n2)     = addEdge n1 k n2--buildGraph :: (Eq rigid, Ord rigid, SemiRing edgeLabel) =>  -  [Constrnt edgeLabel rigid flexScope] -> Graph edgeLabel rigid flexScope-buildGraph cs = execState (mapM_ addConstraint cs) initGraph--mkMatrix :: Int -> (Int -> Int -> a) -> Matrix a-mkMatrix n g = array ((0,0),(n-1,n-1)) -                 [ ((i,j), g i j) | i <- [0..n-1], j <- [0..n-1]]---- displaying matrices with row and column labels ------------------------ a matrix with row descriptions in b and column descriptions in c-data LegendMatrix a b c = LegendMatrix -  { matrix   :: Matrix a-  , rowdescr :: Int -> b-  , coldescr :: Int -> c-  }--instance (Show a, Show b, Show c) => Show (LegendMatrix a b c) where-  show (LegendMatrix m rd cd) =-    -- first show column description-    let ((r,c),(r',c')) = bounds m-    in foldr (\ j s -> "\t" ++ show (cd j) ++ s) "" [c .. c'] ++ -    -- then output rows-       foldr (\ i s -> "\n" ++ show (rd i) ++-                foldr (\ j t -> "\t" ++ show (m!(i,j)) ++ t) -                      (s) -                      [c .. c'])-             "" [r .. r'] ---- solving the constraints ----------------------------------------------- a solution assigns to each flexible variable a size expression--- which is either a constant or a v + n for a rigid variable v-type Solution = Map Int MaxExpr--emptySolution :: Solution-emptySolution = Map.empty--extendSolution :: Solution -> Int -> SizeExpr -> Solution-extendSolution subst k v = Map.insertWith (++) k [v] subst--type MaxExpr = [SizeExpr]--- newtype MaxExpr = MaxExpr { sizeExprs :: [SizeExpr] } deriving (Show)--data SizeExpr = SizeVar Int Int   -- e.g. x + 5-              | SizeConst Weight  -- a number or infinity--instance Show SizeExpr where-  show (SizeVar n 0) = show (Rigid (RVar n))-  show (SizeVar n k) = show (Rigid (RVar n)) ++ "+" ++ show k-  show (SizeConst (Finite i)) = show i-  show (SizeConst Infinite)   = "#"---- sizeRigid r n  returns the size expression corresponding to r + n-sizeRigid :: Rigid -> Int -> SizeExpr-sizeRigid (RConst k) n = SizeConst (inc k n)-sizeRigid (RVar i)   n = SizeVar i n --{--apply :: SizeExpr -> Solution -> SizeExpr-apply e@(SizeExpr (Rigid _) _) phi = e-apply e@(SizeExpr (Flex  x) i) phi = case Map.lookup x phi of-  Nothing -> e-  Just (SizeExpr v j) -> SizeExpr v (i + j) - -after :: Solution -> Solution -> Solution-after psi phi = Map.map (\ e -> e `apply` phi) psi--}--{--solve :: Constraints -> Maybe Solution-solve cs = if any (\ x -> x < Finite 0) d then Nothing-     else Map.-   where gr = buildGraph cs-         n  = nextNode gr-         m  = mkMatrix n (graph gr)-         m' = warshall m-         d  = [ m!(i,i) | i <- [0 .. (n-1)] ]-         ns = keys (nodeMap gr)--}--{- compute solution--a solution CANNOT exist if--  v < v  for a rigid variable v--  v <= v' for rigid variables v,v'--  x < v   for a flexible variable x and a rigid variable v--thus, for each flexible x, only one of the following cases is possible--  r+n <= x+m <= infty  for a unique rigid r  (meaning r --(m-n)--> x)-  x <= r+n             for a unique rigid r  (meaning x --(n)--> r)--we are looking for the least values for flexible variables that solve-the constraints.  Algorithm--while flexible variables and rigid rows left-  find a rigid variable row i-    for all flexible columns j-      if i --n--> j with n<=0 (meaning i+n <= j) then j = i + n--while flexible variables j left-  search the row j for entry i-    if j --n--> i with n >= 0 (meaning j <= i + n) then j = i ----}--solve :: Constraints -> Maybe Solution-solve cs = traceSolve (show lm0) $ traceSolve (show lm) $ traceSolve (show cs) $-     let solution = if solvable then loop1 rigids emptySolution-                    else Nothing-     in traceSolve ("solution = " ++ show solution) $ -          solution-   where -- compute the graph and its transitive closure m-         gr  = buildGraph cs-         n   = nextNode gr            -- number of nodes-         m0  = mkMatrix n (graph gr)-         m   = warshall m0--         -- tracing only: build output version of transitive graph-         legend i = fromJust $ Map.lookup i (intMap gr) -- trace only-         lm0 = LegendMatrix m0 legend legend            -- trace only-         lm  = LegendMatrix m legend legend             -- trace only--         -- compute the sets of flexible and rigid node numbers-         ns  = Map.keys (nodeMap gr)                    -         -- a set of flexible variables-         flexs  = foldl (\ l k -> case k of (Flex i) -> i : l-                                            (Rigid _) -> l) [] ns-         -- a set of rigid variables-         rigids = foldl (\ l k -> case k of (Flex _) -> l-                                            (Rigid i) -> i : l) [] ns--         -- rigid matrix indices-         rInds = foldl (\ l r -> let Just i = Map.lookup (Rigid r) (nodeMap gr)-                                 in i : l) [] rigids--         -- check whether there is a solution-         -- d   = [ m!(i,i) | i <- [0 .. (n-1)] ]  -- diagonal--- a rigid variable might not be less than it self, so no -.. on the --- rigid part of the diagonal-         solvable = all (\ x -> x >= oone) [ m!(i,i) | i <- rInds ] &&--- a rigid variable might not be bounded below by infinity or--- bounded above by a constant--- it might not be related to another rigid variable-           all (\ (r,  r') -> r == r' || -                let Just row = (Map.lookup (Rigid r)  (nodeMap gr))-                    Just col = (Map.lookup (Rigid r') (nodeMap gr))-                    edge = m!(row,col)-                in  isBelow r edge r' ) -             [ (r,r') | r <- rigids, r' <- rigids ]-           &&--- a flexible variable might not be strictly below a rigid variable-           all (\ (x, v) -> -                let Just row = (Map.lookup (Flex x)  (nodeMap gr))-                    Just col = (Map.lookup (Rigid (RVar v)) (nodeMap gr))-                    edge = m!(row,col)-                in  edge >= Finite 0)-             [ (x,v) | x <- flexs, (RVar v) <- rigids ]---         inScope :: FlexId -> Rigid -> Bool-         inScope x (RConst _) = True-         inScope x (RVar v)   = case Map.lookup x (flexScope gr) of-                     Just scope -> scope v-                     Nothing    -> error $ "Warshall.inScope panic: flexible " ++ show x ++ " does not carry scope info when assigning it rigid variable " ++ show v  --{- loop1--while flexible variables and rigid rows left-  find a rigid variable row i-    for all flexible columns j-      if i --n--> j with n<=0 (meaning i + n <= j) then -        add i + n to the solution of j---}--         loop1 :: [Rigid] -> Solution -> Maybe Solution-         loop1 (r:rgds) subst = loop1 rgds subst' where -            row = fromJust $ Map.lookup (Rigid r) (nodeMap gr)-            subst' =-                  foldl (\ sub f -> -                          let col = fromJust $ Map.lookup (Flex f) (nodeMap gr)-                          in  case (True -- inScope f r  -- SEEMS WRONG TO IGNORE THINGS NOT IN SCOPE-                                   , m!(row,col)) of---                                Finite z | z <= 0 -> -                                (True, Finite z) -> -                                   let trunc z | z >= 0 = 0-                                            | otherwise = -z-                                   in extendSolution sub f (sizeRigid r (trunc z))-                                _ -> sub-                     ) subst flexs       -         loop1 [] subst = case flexs List.\\ (Map.keys subst) of-            [] -> Just subst-            flexs' -> loop2 flexs' subst--{- loop2--while flexible variables j left-  search the row j for entry i-    if j --n--> i with n >= 0 (meaning j <= i + n) then j = i ---}-         loop2 :: [FlexId] -> Solution -> Maybe Solution-         loop2 [] subst = Just subst -         loop2 (f:flxs) subst = loop3 0 subst-           where row = fromJust $ Map.lookup (Flex f) (nodeMap gr)-                 loop3 col subst | col >= n = -                   -- default to infinity-                    loop2 flxs (extendSolution subst f (SizeConst Infinite)) -                 loop3 col subst =-                   case Map.lookup col (intMap gr) of-                     Just (Rigid r) | not (infinite r) -> -                       case (True -- inScope f r-                            ,m!(row,col)) of-                        (True, Finite z) | z >= 0 -> -                            loop2 flxs (extendSolution subst f (sizeRigid r z))-                        (_, Infinite) -> loop3 (col+1) subst -                        _ -> Nothing -                     _ -> loop3 (col+1) subst
dist/build/miniagda/miniagda-tmp/Lexer.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP,MagicHash #-}-{-# LINE 2 "Lexer.x" #-}+{-# LINE 2 "src/Lexer.x" #-}   module Lexer where@@ -12,11 +13,9 @@ #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array-import Data.Char (ord) import Data.Array.Base (unsafeAt) #else import Array-import Char (ord) #endif #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts@@ -27,6 +26,53 @@ {-# LINE 1 "templates/wrappers.hs" #-} {-# LINE 1 "<built-in>" #-} {-# LINE 1 "<command-line>" #-}+{-# LINE 8 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 8 "<command-line>" #-} {-# LINE 1 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Alex wrapper code.@@ -34,9 +80,15 @@ -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. +++++ import Data.Word (Word8)-{-# LINE 22 "templates/wrappers.hs" #-}+{-# LINE 28 "templates/wrappers.hs" #-} +import Data.Char (ord) import qualified Data.Bits  -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.@@ -87,11 +139,11 @@                               in p' `seq`  Just (b, (p', c, bs, s))  -{-# LINE 92 "templates/wrappers.hs" #-}+{-# LINE 101 "templates/wrappers.hs" #-} -{-# LINE 106 "templates/wrappers.hs" #-}+{-# LINE 119 "templates/wrappers.hs" #-} -{-# LINE 121 "templates/wrappers.hs" #-}+{-# LINE 137 "templates/wrappers.hs" #-}  -- ----------------------------------------------------------------------------- -- Token positions@@ -111,7 +163,7 @@ alexStartPos = AlexPn 0 1 1  alexMove :: AlexPosn -> Char -> AlexPosn-alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+7) `div` 8)*8+1)+alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1 alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1) @@ -119,27 +171,27 @@ -- ----------------------------------------------------------------------------- -- Default monad -{-# LINE 242 "templates/wrappers.hs" #-}+{-# LINE 271 "templates/wrappers.hs" #-}   -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 333 "templates/wrappers.hs" #-}+{-# LINE 374 "templates/wrappers.hs" #-}   -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 360 "templates/wrappers.hs" #-}+{-# LINE 401 "templates/wrappers.hs" #-}   -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 378 "templates/wrappers.hs" #-}+{-# LINE 421 "templates/wrappers.hs" #-} -{-# LINE 392 "templates/wrappers.hs" #-}+{-# LINE 437 "templates/wrappers.hs" #-}   -- -----------------------------------------------------------------------------@@ -162,7 +214,7 @@ -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 424 "templates/wrappers.hs" #-}+{-# LINE 470 "templates/wrappers.hs" #-}   -- -----------------------------------------------------------------------------@@ -170,6 +222,8 @@  -- For compatibility with previous versions of Alex, and because we can. +alex_tab_size :: Int+alex_tab_size = 8 alex_base :: AlexAddr alex_base = AlexA# "\xf8\xff\xff\xff\x0a\x00\x00\x00\xdd\x00\x00\x00\xca\x00\x00\x00\x5d\x01\x00\x00\x30\x02\x00\x00\xb0\x02\x00\x00\x9f\x01\x00\x00\x00\x00\x00\x00\x21\x03\x00\x00\x00\x00\x00\x00\xa1\x03\x00\x00\x21\x04\x00\x00\x21\x05\x00\x00\xe1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x05\x00\x00\x00\x00\x00\x00\x93\x05\x00\x00\x93\x06\x00\x00\x53\x06\x00\x00\x00\x00\x00\x00\xfd\xff\xff\xff\x49\x07\x00\x00\x1c\x08\x00\x00\x00\x00\x00\x00\x2d\x07\x00\x00\xf5\x08\x00\x00\x49\x09\x00\x00\x9d\x09\x00\x00\xf1\x09\x00\x00\x45\x0a\x00\x00\x99\x0a\x00\x00\xed\x0a\x00\x00\x41\x0b\x00\x00\x95\x0b\x00\x00\xe9\x0b\x00\x00\x3d\x0c\x00\x00\x91\x0c\x00\x00\xe5\x0c\x00\x00\x39\x0d\x00\x00\x8d\x0d\x00\x00\xe1\x0d\x00\x00\x35\x0e\x00\x00\x89\x0e\x00\x00\xdd\x0e\x00\x00\x31\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x0f\x00\x00\xde\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\xff\xff\xff\xe1\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xff\xff\xff\x00\x00\x00\x00\x46\x00\x00\x00\x2d\x10\x00\x00\x81\x10\x00\x00\xd5\x10\x00\x00\x29\x11\x00\x00\x7d\x11\x00\x00\xd1\x11\x00\x00\x25\x12\x00\x00\x79\x12\x00\x00\xcd\x12\x00\x00\x21\x13\x00\x00\x75\x13\x00\x00\xc9\x13\x00\x00\x1d\x14\x00\x00\x71\x14\x00\x00\xc5\x14\x00\x00\x19\x15\x00\x00\x6d\x15\x00\x00\xc1\x15\x00\x00\x15\x16\x00\x00\x69\x16\x00\x00\xbd\x16\x00\x00\x11\x17\x00\x00\x65\x17\x00\x00\xb9\x17\x00\x00\x0d\x18\x00\x00\x61\x18\x00\x00\xb5\x18\x00\x00\x09\x19\x00\x00\x5d\x19\x00\x00\xb1\x19\x00\x00\x05\x1a\x00\x00\x59\x1a\x00\x00\xad\x1a\x00\x00\x01\x1b\x00\x00\x55\x1b\x00\x00\xa9\x1b\x00\x00\xfd\x1b\x00\x00\x51\x1c\x00\x00\xa5\x1c\x00\x00\xf9\x1c\x00\x00\x4d\x1d\x00\x00\xa1\x1d\x00\x00\xf5\x1d\x00\x00\x49\x1e\x00\x00\x9d\x1e\x00\x00\xf1\x1e\x00\x00\x45\x1f\x00\x00\x99\x1f\x00\x00\xed\x1f\x00\x00\x41\x20\x00\x00\x95\x20\x00\x00\xe9\x20\x00\x00\x3d\x21\x00\x00\x91\x21\x00\x00\xe5\x21\x00\x00\x39\x22\x00\x00\x8d\x22\x00\x00\xe1\x22\x00\x00\x35\x23\x00\x00\x89\x23\x00\x00\xdd\x23\x00\x00\x31\x24\x00\x00\x85\x24\x00\x00\xd9\x24\x00\x00\x2d\x25\x00\x00\x81\x25\x00\x00\xd5\x25\x00\x00\x29\x26\x00\x00\x7d\x26\x00\x00\xd1\x26\x00\x00\x25\x27\x00\x00\x79\x27\x00\x00\xcd\x27\x00\x00\x21\x28\x00\x00\x75\x28\x00\x00\xc9\x28\x00\x00\x1d\x29\x00\x00\x71\x29\x00\x00\xc5\x29\x00\x00\x19\x2a\x00\x00\x6d\x2a\x00\x00"# @@ -183,7 +237,7 @@ alex_deflt = AlexA# "\xff\xff\x05\x00\x05\x00\xff\xff\xff\xff\x05\x00\xff\xff\x0f\x00\x0f\x00\x08\x00\x08\x00\xff\xff\xff\xff\x05\x00\x05\x00\x05\x00\x12\x00\x12\x00\x16\x00\x16\x00\x18\x00\x18\x00\x18\x00\xff\xff\x18\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#  alex_accept = listArray (0::Int,160) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAcc (alex_action_6),AlexAcc (alex_action_7),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAcc (alex_action_30),AlexAcc (alex_action_31),AlexAcc (alex_action_32),AlexAcc (alex_action_33),AlexAcc (alex_action_34),AlexAcc (alex_action_35),AlexAcc (alex_action_36),AlexAcc (alex_action_37),AlexAcc (alex_action_38),AlexAcc (alex_action_39),AlexAcc (alex_action_40),AlexAcc (alex_action_41),AlexAcc (alex_action_42),AlexAcc (alex_action_43),AlexAcc (alex_action_44),AlexAcc (alex_action_45),AlexAcc (alex_action_46),AlexAcc (alex_action_47),AlexAcc (alex_action_48),AlexAcc (alex_action_49),AlexAcc (alex_action_50),AlexAcc (alex_action_51),AlexAcc (alex_action_52),AlexAcc (alex_action_53),AlexAcc (alex_action_54),AlexAcc (alex_action_55),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_57)]-{-# LINE 80 "Lexer.x" #-}+{-# LINE 80 "src/Lexer.x" #-}  data Token = Id String AlexPosn            | QualId (String, String) AlexPosn@@ -372,6 +426,53 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-} {-# LINE 1 "<command-line>" #-}+{-# LINE 9 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 9 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE@@ -428,8 +529,8 @@   narrow32Int# i   where    i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`-		     (b2 `uncheckedShiftL#` 16#) `or#`-		     (b1 `uncheckedShiftL#` 8#) `or#` b0)+                     (b2 `uncheckedShiftL#` 16#) `or#`+                     (b1 `uncheckedShiftL#` 8#) `or#` b0)    b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))    b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))    b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))@@ -469,30 +570,30 @@  alexScanUser user input (I# (sc))   = case alex_scan_tkn user input 0# input sc AlexNone of-	(AlexNone, input') ->-		case alexGetByte input of-			Nothing -> +        (AlexNone, input') ->+                case alexGetByte input of+                        Nothing ->    -				   AlexEOF-			Just _ ->+                                   AlexEOF+                        Just _ ->   -				   AlexError input'+                                   AlexError input' -	(AlexLastSkip input'' len, _) ->+        (AlexLastSkip input'' len, _) ->   -		AlexSkip input'' len+                AlexSkip input'' len -	(AlexLastAcc k input''' len, _) ->+        (AlexLastAcc k input''' len, _) ->   -		AlexToken input''' len k+                AlexToken input''' len k   -- Push the input through the DFA, remembering the most recent accepting@@ -501,7 +602,7 @@ alex_scan_tkn user orig_input len input s last_acc =   input `seq` -- strict in the input   let -	new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))+        new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))   in   new_acc `seq`   case alexGetByte input of@@ -515,23 +616,23 @@                 base   = alexIndexInt32OffAddr alex_base s                 offset = (base +# ord_c)                 check  = alexIndexInt16OffAddr alex_check offset-		+                                 new_s = if GTE(offset,0#) && EQ(check,ord_c)-			  then alexIndexInt16OffAddr alex_table offset-			  else alexIndexInt16OffAddr alex_deflt s-	in+                          then alexIndexInt16OffAddr alex_table offset+                          else alexIndexInt16OffAddr alex_deflt s+        in         case new_s of-	    -1# -> (new_acc, input)-		-- on an error, we want to keep the input *before* the-		-- character that failed, not after.-    	    _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)+            -1# -> (new_acc, input)+                -- on an error, we want to keep the input *before* the+                -- character that failed, not after.+            _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)                                                 -- note that the length is increased ONLY if this is the 1st byte in a char encoding)-			new_input new_s new_acc+                        new_input new_s new_acc       }   where-	check_accs (AlexAccNone) = last_acc-	check_accs (AlexAcc a  ) = AlexLastAcc a input (I# (len))-	check_accs (AlexAccSkip) = AlexLastSkip  input (I# (len))+        check_accs (AlexAccNone) = last_acc+        check_accs (AlexAcc a  ) = AlexLastAcc a input (I# (len))+        check_accs (AlexAccSkip) = AlexLastSkip  input (I# (len)) {-# LINE 198 "templates/GenericTemplate.hs" #-}  data AlexLastAcc a@@ -540,15 +641,11 @@   | AlexLastSkip  !AlexInput !Int  instance Functor AlexLastAcc where-    fmap f AlexNone = AlexNone+    fmap _ AlexNone = AlexNone     fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z-    fmap f (AlexLastSkip x y) = AlexLastSkip x y+    fmap _ (AlexLastSkip x y) = AlexLastSkip x y  data AlexAcc a user   = AlexAccNone   | AlexAcc a   | AlexAccSkip-{-# LINE 242 "templates/GenericTemplate.hs" #-}---- used by wrappers-iUnbox (I# (i)) = i
dist/build/miniagda/miniagda-tmp/Parser.hs view
@@ -13,8 +13,10 @@ import Concrete (Name,patApp) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts+import Control.Applicative(Applicative(..))+import Control.Monad (ap) --- parser produced by Happy Version 1.19.3+-- parser produced by Happy Version 1.19.5  newtype HappyAbsSyn  = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -2403,6 +2405,12 @@ happyIdentity = HappyIdentity happyRunIdentity (HappyIdentity a) = a +instance Functor HappyIdentity where+    fmap f (HappyIdentity a) = HappyIdentity (f a)++instance Applicative HappyIdentity where+    pure  = return+    (<*>) = ap instance Monad HappyIdentity where     return = HappyIdentity     (HappyIdentity p) >>= q = q p@@ -2428,8 +2436,54 @@ parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x) {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-} {-# LINE 1 "<command-line>" #-}+{-# LINE 10 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 10 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
+ src/Abstract.hs view
@@ -0,0 +1,2213 @@+-- 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 NoImplicitPrelude #-}++module Abstract where++import Prelude hiding (showList, map, concat, foldl, pi, null)++import Control.Applicative hiding (empty)+import Control.Monad.Writer (Writer, tell, All(..))+import Control.Monad.Trans++import Data.Monoid hiding ((<>))+import Data.Foldable (Foldable, foldMap)+import qualified Data.Foldable as Foldable+import Data.Traversable as Traversable+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 (Eq, Ord, Show)++data Name = Name+  { suggestion :: String    -- ^ suggestion for printing the name.+  , what       :: WhatName+  , uid        :: Unique -- !Unique+  }++-- | Names are compared according to their UID.+instance Eq Name where+  x == x' = uid x == uid x'++instance Ord Name where+  compare x x' = compare (uid x) (uid x')++instance Show Name where+  show (Name n _ u) = 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 n = Name n UserName $ unsafePerformIO newUnique+{-# NOINLINE fresh #-}++freshen :: Name -> Name+freshen n = fresh (suggestion n)++-- | A non-unique empty name.  Use only inconstant functions!+noName :: Name+noName = fresh ""++-- | Check whether name is @""@.+emptyName :: Name -> Bool+emptyName n = null (suggestion n)++nonEmptyName :: Name -> String -> Name+nonEmptyName n s | emptyName n = n { suggestion = s }+                 | otherwise   = n++-- | Get the first non-empty name from a non-empty list of names.+bestName :: [Name] -> Name+bestName [n]    = n+bestName (n:ns)+  | emptyName n = bestName ns+  | otherwise   = n++-- temporary hack for reification++iAmNotUnique :: Unique+iAmNotUnique = unsafePerformIO newUnique+{-# NOINLINE iAmNotUnique #-}++unsafeName :: String -> Name+unsafeName s = Name s QuoteName iAmNotUnique++-- | External reference to recursive function (outside of the body).+mkExtName :: Name -> Name+mkExtName n = Name (suggestion n) EtaAliasName $ unsafePerformIO newUnique+-- mkExtName n = "_" ++ n+{-# NOINLINE mkExtName #-}++mkExtRef  n = letdef (mkExtName n)++isEtaAlias :: Name -> Bool+isEtaAlias n = what n == EtaAliasName++-- | Internal name for compiler-generated stuff.+internal :: Name -> Name+internal n = freshen 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 = List.map (\ c -> if c==' ' then '_' else c)+{-+exprToName e = spaceToUnderscore $ show e+patToName p  = spaceToUnderscore $ show p+-}++-- | Qualified name.+data QName+  = Qual  { qual :: Name, name :: Name }+  | QName { name :: Name }+  deriving (Eq, Ord)++instance Show QName where+  show (Qual m n) = show m ++ "." ++ show n+  show (QName n)  = show n++-- | An unqualified name is an instance of a qualified name.+nameInstanceOf (QName n) (Qual _ n') = n == n'+nameInstanceOf n         n'          = n == n'++-- | Fails if qualified name.+unqual (QName n) = n+unqual n         = error $ "Abstract.unqual: " ++ show n++data Sized = Sized | NotSized+             deriving (Eq,Ord,Show)++data Co = Ind+        | CoInd+          deriving (Eq,Ord,Show)++showFun :: Co -> String+showFun Ind   = "fun"+showFun CoInd = "cofun"++data LtLe = Lt | Le deriving (Eq,Ord)++instance Show LtLe where+  show Lt = "<"+  show Le = "<="++-- decoration of Pi-types --------------------------------------------++-- 1. whether argument is irrelevant / its polarity+-- further possibilities:+-- 2. hidden++data Decoration pos+    = Dec { thePolarity :: pos }+    | Hidden+  deriving (Eq, Ord, Functor, Foldable, Traversable, Show)++polarity :: Polarity pol => Decoration pol -> pol+polarity Hidden    = hidden+polarity (Dec pol) = pol++instance Polarity a => Polarity (Decoration a) where+  erased        = erased . polarity+  compose  p p' = Dec $ compose (polarity p) (polarity p')+  neutral       = Dec neutral+  promote       = Dec . promote . polarity+  demote        = Dec . demote . polarity+  hidden        = Hidden++type Dec = Decoration Pol+type UDec = Decoration PProd++class LensPol a where+  getPol :: a -> Pol+  setPol :: Pol -> a -> a+  setPol = mapPol . const+  mapPol :: (Pol -> Pol) -> a -> a+  mapPol f a = setPol (f (getPol a)) a++instance LensPol Dec where+  getPol = polarity+  setPol p Hidden = Hidden+  setPol p dec    = dec { thePolarity = p }++udec :: Dec -> UDec+udec = fmap pprod++irrelevantDec = Dec Pol.Const+paramDec = Dec Param+defaultDec = Dec defaultPol+-- defaultDec = paramDec -- TODO: Dec { polarity = Rec }+defaultUpperDec = Dec $ pprod 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 SPos++coDomainDec :: Dec -> Dec+coDomainDec Hidden = Dec Param -- REDUNDANT+coDomainDec dec+    | polarity dec == Pol.Const = Dec Param+    | otherwise                 = Dec Rec++-- compDec dec dec'+-- composition of decoration, used when type checking arguments+-- of functions decorated with dec+compDec :: Dec -> UDec -> UDec+compDec dec udec = compose (fmap pprod dec) udec++{-+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 (Succ e) = Just e+  predecessor _ = Nothing++sizeSuccE :: Expr -> Expr+sizeSuccE Infty = Infty+sizeSuccE e     = Succ e++minSizeE :: Expr -> Expr -> Expr+minSizeE Infty e2 = e2+minSizeE e1 Infty = e1+minSizeE Zero  e2 = Zero+minSizeE e1 Zero  = Zero+minSizeE (Succ e1) (Succ e2) = Succ (minSizeE e1 e2)+minSizeE e1 e2 = error $ "minSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2)++maxSizeE :: Expr -> Expr -> Expr+maxSizeE Infty e2 = Infty+maxSizeE e1 Infty = Infty+maxSizeE Zero  e2 = e2+maxSizeE e1 Zero  = e1+maxSizeE (Succ e1) (Succ e2) = Succ (maxSizeE e1 e2)+maxSizeE e1 e2 = Max [e1, e2]+-- maxSizeE e1 e2 = error $ "maxSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2)++flattenMax :: Expr -> [Expr] -> [Expr]+flattenMax Infty          acc = [Infty]+flattenMax Zero           acc = acc+flattenMax (Max [])       acc = acc+flattenMax (Max (e : es)) acc = flattenMax e $ flattenMax (Max es) acc+flattenMax e              acc = e : acc++-- smart constructor for MAX+maxE :: [Expr] -> Expr+maxE es = Max $ foldr flattenMax [] es++sizeVarsToInfty :: Expr -> Expr+sizeVarsToInfty Zero = Zero+sizeVarsToInfty (Succ e) = sizeSuccE (sizeVarsToInfty e)+sizeVarsToInfty _ = Infty++leqSizeE :: Expr -> Expr -> Bool+leqSizeE Zero e  = True+leqSizeE e Zero  = False+leqSizeE e Infty = True+leqSizeE (Succ e) (Succ e') = leqSizeE e e'+leqSizeE Infty e = False++-- plus :: Expr -> Expr -> Expr++-- 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 (Eq, Ord, Show)++predClass :: Class -> Class+-- predClass Ty    = Tm+predClass TSize = Size+predClass Tm    = Tm+predClass Size  = 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 (Eq, Ord, Functor, Foldable, 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 (SortC c) = show c+  show (Set Zero) = "Set"+  show (CoSet Infty) = "Set"+  show (Set e) = Util.parens $ ("Set " ++ show e)+  show (CoSet e) = Util.parens $ ("CoSet " ++ show e)++topSort :: Sort Expr+topSort = Set Infty++-- | The expression representing the type Size.+tSize :: Expr+tSize = Sort (SortC Size)++-- | Checking whether an expression represents type Size.+isSize :: Expr -> Bool+isSize (Sort (SortC Size)) = True+isSize (Below Le Infty)    = True+isSize _                   = False++predSort :: Sort Expr -> Sort Expr+predSort (SortC  c)     = SortC (predClass c)+predSort (CoSet  e)     = SortC Tm+predSort (Set Zero)     = SortC Tm+predSort (Set (Succ e)) = Set e+predSort (Set Infty)    = Set Infty+predSort s@(Set Var{})  = s+predSort s = error $ "internal error: predSort " ++ show s++-- only for sorts appearing in kinds:++succSort :: Sort Expr -> Sort Expr+succSort (SortC Size) = SortC TSize+succSort (SortC Tm)   = Set Zero+succSort (Set e)      = Set (sizeSuccE e)++minSort :: Sort Expr -> Sort Expr -> Sort Expr+minSort (SortC Tm) (Set e) = SortC Tm+minSort (Set e) (SortC Tm) = SortC Tm+minSort (Set e) (Set e') = Set (minSizeE e e')+-- minSort (SortC c) (SortC c') | c == c' = SortC c+minSort (SortC c) (SortC c') = SortC $ minClass c c'+minSort s s' = error $ "minSort (" ++ show s ++ ") (" ++ show s' ++ ") not implemented"++-- 2012-01-21: that should not be necessary, but to move on...+minClass :: Class -> Class -> Class+minClass Tm c = Tm+minClass c Tm = Tm+minClass Size c = Size+minClass c Size = Size+minClass TSize TSize = TSize+maxClass :: Class -> Class -> Class++maxClass Tm c = c+maxClass c Tm = c+maxClass Size c = c+maxClass c Size = c+maxClass TSize TSize = TSize++maxSort :: Sort Expr -> Sort Expr -> Sort Expr+maxSort (SortC Tm) (Set e) = Set e+maxSort (Set e) (SortC Tm) = Set e+maxSort (Set e) (Set e') = Set (maxSizeE e e')+-- maxSort (SortC c) (SortC c') | c == c' = SortC c+maxSort (SortC c) (SortC c') = SortC $ maxClass c c'+maxSort s s' = error $ "maxSort (" ++ show s ++ ") (" ++ show s' ++ ") 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 compuationally+-- contribute to produce a value of kind s'+irrSortFor :: Sort Expr -> Sort Expr -> Bool+irrSortFor (SortC Tm) _          = False -- terms matter for terms and everything+irrSortFor _          (SortC Tm) = True  -- nothing else can be eliminated into a term+irrSortFor (SortC Size) _        = False -- sizes matter for everything but terms+irrSortFor _        (SortC Size) = True  -- nothing else can be eliminated into a size+irrSortFor (SortC TSize) _        = False -- sizes matter for everything but terms+irrSortFor _        (SortC TSize) = True  -- nothing else can be eliminated into a size+irrSortFor (Set e) (Set e')      = not $ leqSizeE e e'++-- kinds -------------------------------------------------------------++-- kinds classify expressions into terms, types, universes, ...+-- since the analysis is not precise, we give an interval of classes++data Kind+  = Kind { lowerKind :: Sort Expr , upperKind :: Sort Expr }+  | NoKind   -- absurd clauses, neutral wrt. union+  | AnyKind  -- not yet classified, neutral wrt. intersection+    deriving (Eq, Ord)++--defaultKind = Kind (SortC Tm) topSort -- no classification, could be anything+defaultKind = AnyKind++preciseKind s = Kind s s+kSize   = preciseKind (SortC Size)+kTSize  = preciseKind (SortC TSize)+kTerm   = preciseKind (SortC Tm)+kType   = preciseKind (Set Zero)+kUniv e = preciseKind (Set (Succ (sizeVarsToInfty e))) -- used in TypeChecker++instance Show Kind where+  show NoKind = "()"+  show AnyKind = "?"+--  show k | k == defaultKind = "?"+  show (Kind kl ku) | kl == ku = show kl+  show (Kind kl ku) = show kl ++ ".." ++ show ku++-- print kind in four letters+prettyKind :: Kind -> String+prettyKind NoKind                       = "none"+prettyKind AnyKind                      = "anyk"+-- prettyKind k | k == defaultKind         = "anyk"+prettyKind (Kind _ (SortC Tm))          = "term"+prettyKind (Kind _ (SortC Size))        = "size"+prettyKind k | k == kType               = "type"+prettyKind (Kind (Set (Succ Zero)) _)   = "univ"+prettyKind (Kind (Set Zero) _)          = "ty-u"+prettyKind (Kind (SortC Tm) (Set Zero)) = "tmty"+prettyKind k                            = "mixk"++-- if D : T and T has kind ki, then D has kind dataKind ki+dataKind :: Kind -> Kind+dataKind (Kind _ (Set (Succ e))) = Kind (Set Zero) (Set e)++-- in (x : A) -> B, if x : A and A has kind ki, then x has kind argKind ki+argKind :: Kind -> Kind+argKind NoKind = NoKind+argKind AnyKind = AnyKind+argKind (Kind s s') = Kind (predSort s) (predSort s')++-- if e : A and A has kind ki, then e has kind predKind ki+predKind :: Kind -> Kind+predKind NoKind = NoKind+predKind AnyKind = AnyKind+-- predecessors in the kind hierarchy+predKind ki@(Kind _ (SortC Size))  = error $ "predKind " ++ show ki+predKind (Kind _ (SortC TSize)) = kSize+-- proper types are only inhabited by terms+predKind (Kind _ (Set Zero)) = kTerm+-- proper universes are inhabited by types and universes+predKind (Kind (Set (Succ e)) s) = Kind (Set Zero) (predSort s)+-- something which is a type or a universe can be inhabited by a term+predKind (Kind _ s) = Kind (SortC Tm) (predSort s)++succKind :: Kind -> Kind+succKind AnyKind = AnyKind+succKind (Kind _ (SortC Tm)) = kType+succKind (Kind _ (SortC Size)) = kTSize+succKind (Kind s _) = Kind (succSort s) (Set Infty) -- no upper bound++-- partial operation!+intersectKind :: Kind -> Kind -> Kind+intersectKind NoKind ki = ki -- NoKind means here "intersection is not happening"+intersectKind ki NoKind = ki+intersectKind AnyKind ki = ki+intersectKind ki AnyKind = ki+intersectKind (Kind x1 x2) (Kind y1 y2) =+  Kind (maxSort x1 y1) (minSort x2 y2)++unionKind :: Kind -> Kind -> Kind+unionKind ki1 ki2 = -- trace (show ki1 ++ " `unionKind` " ++ show ki2) $+  case (ki1,ki2) of+    (NoKind, ki) -> ki+    (ki, NoKind) -> ki+    (AnyKind, ki) -> AnyKind+    (ki, AnyKind) -> AnyKind+    (Kind x1 x2, Kind y1 y2) ->+      Kind (minSort x1 y1) (maxSort x2 y2)++-- ki `irrelevantFor` ki' if an argument of kind ki cannot+-- computationally contribute to a result of kind ki'+irrelevantFor :: Kind -> Kind -> Bool+irrelevantFor NoKind _ = False -- do not make a statement if there is no info+irrelevantFor _ NoKind = False+irrelevantFor AnyKind _ = False+irrelevantFor _ AnyKind = False+irrelevantFor (Kind s _) (Kind _ s') = irrSortFor s s'+-- worst case szenario: the least kind of the argument is still+-- irrelevant for the biggest kind of the result++data Kinded a = Kinded { kindOf :: Kind, valueOf :: a }+                deriving (Eq, Ord, Functor, Foldable, Traversable)++instance Show a => Show (Kinded a) where+--  show (Kinded ki a) | ki == defaultKind = show a+  show (Kinded ki a) = show a ++ "::" ++ show ki++-- function domains --------------------------------------------------++data Dom a = Domain { typ :: a, kind :: Kind, decor :: Dec }+             deriving (Eq, Ord, Functor, Foldable, Traversable)++instance Show a => Show (Dom a) where+    show (Domain ty ki dec) = show dec ++ show ty ++ "::" ++ show ki++defaultDomain a = Domain a defaultKind defaultDec+domFromKinded (Kinded ki t) = Domain t ki defaultDec+defaultIrrDom a = Domain a defaultKind irrelevantDec++sizeDomain :: Dec -> Dom Expr+sizeDomain dec = Domain tSize kTSize dec++belowDomain :: Dec -> LtLe -> Expr -> Dom Expr+belowDomain dec ltle e = Domain (Below ltle e) kTSize dec++class LensDec a where+  getDec :: a -> Dec+  setDec :: Dec -> a -> a+  setDec d = mapDec $ const d+  mapDec :: (Dec -> Dec) -> a -> a+  mapDec f a = setDec (f $ getDec a) a++instance LensDec (Dom a) where+  getDec = decor+  setDec d dom = dom { decor = d }++instance LensPol (Dom a) where+  getPol = getPol . getDec+  mapPol = mapDec . mapPol++{-+instance Functor Dom where+  fmap f dom = dom { typ = f (typ dom) }++-- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)+instance Traversable Dom where+  traverse f dom = (\ ty -> dom { typ = ty }) <$> f (typ dom)+-}++-- identifiers -------------------------------------------------------++-- |+data ConK+  = Cons    -- ^ a constructor+  | CoCons  -- ^ a coconstructor+  | DefPat  -- ^ a defined pattern+    deriving (Eq, Ord, Show)++data IdKind+  = DatK       -- ^ data/codata+  | ConK ConK  -- ^ constructor (ind/coind/defined)+  | FunK       -- ^ fun/cofun+  | LetK       -- ^ let definition+    deriving (Eq, Ord)++instance Show IdKind where+    show DatK   = "data"+    show ConK{} = "con"+    show FunK   = "fun"+    show LetK   = "let"++conKind (ConK _) = True+conKind _        = False++coToConK Ind = Cons+coToConK CoInd = CoCons++data DefId = DefId { idKind :: IdKind, idName :: QName }+           deriving (Eq, Ord)++instance Show DefId where+    show d = show (idName d) -- ++ "@" ++ show (idKind d)++type MVar = Int -- metavariables are numbered++-- typed bindings in Pi, LLet, Telescope -----------------------------++data TBinding a = TBind+  { boundName :: Name        -- ^ @emptyName@ if non-dependent.+  , boundDom  :: Dom a       -- ^ @x : T@ or @i < j@.+  }+  | TMeasure (Measure Expr)  -- ^ Measure @|m|@.+  | TBound   (Bound Expr)    -- ^ Constraint @|m| <(=) |m'|@.+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++type LBind = TBinding (Maybe Type)+type TBind = TBinding Type++noBind :: Dom a -> TBinding a+noBind = TBind (fresh "")++boundType :: TBind -> Type+boundType = typ . boundDom++instance LensDec (TBinding a) where+  getDec = getDec . boundDom+  mapDec f (TBind x dom) = TBind x (dom { decor = f (decor dom) })+  mapDec f tb = tb++mapDecM :: (Applicative m) => (Dec -> m Dec) -> TBind -> m TBind+mapDecM f tb@TBind{} = flip setDec tb <$> f (getDec tb)+mapDecM f tb         = pure tb++-- measures ----------------------------------------------------------++newtype Measure a = Measure { measure :: [a] }    -- mu+    deriving (Eq,Ord,Functor,Foldable,Traversable)++instance Show a => Show (Measure a) where+    show (Measure l) = "|" ++ showList "," show l ++ "|"++succMeasure :: (a -> a) -> Measure a -> Measure a+succMeasure succ mu = maybe (error "cannot take successor of empty measure") id $ applyLastM (Just . succ) 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 f (Measure mu) = Measure <$> loop mu+  where loop []     = fail "empty measure"+        loop [e]    = (:[]) <$> f e+        loop (e:es) = (e:)  <$> loop es++instance HasPred a => HasPred (Measure a) where+  predecessor mu = applyLastM predecessor mu++data Bound a = Bound { ltle :: LtLe, leftBound :: Measure a, rightBound :: Measure a }  -- mu < mur  of mu <= mu'+    deriving (Eq,Ord,Functor,Foldable,Traversable)++instance Show a => Show (Bound a) where+  show (Bound Lt mu1 mu2) = show mu1 ++ " < " ++ show mu2+  show (Bound Le mu1 mu2) = show mu1 ++ " <= " ++ show 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 (Eq,Ord,Show)++type Tags = [Tag]++inTags :: Tag -> Tags -> Bool+inTags = elem++noTags = []++data Tagged a = Tagged { tags :: Tags , unTag :: a }+  deriving (Eq,Ord,Functor,Foldable,Traversable)++instance Show a => Show (Tagged a) where+  show (Tagged tags a) =+   bracketsIf (Erased `inTags` tags) $+     showCast (Cast `inTags` tags) $+       show  a++showCast :: Bool -> String -> String+showCast True  s = "'cast" ++ Util.parens s+showCast False s = s++instance Pretty a => Pretty (Tagged a) where+  prettyPrec k (Tagged []   a) = prettyPrec k a+  prettyPrec _ (Tagged tags a) =+    prettyErased (Erased `inTags` tags) $+      prettyCast (Cast `inTags` tags) $+        pretty a++prettyErased True  doc = brackets doc+prettyErased False doc = doc++prettyCast True  doc = text "'cast" <> PP.parens doc+prettyCast False 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 (Eq,Ord)++data PrePost = Pre | Post deriving (Eq, Ord, Show)+data PiSigma = Pi | Sigma deriving (Eq, Ord)++instance Show PiSigma where+  show Pi    = "->"+  show Sigma = "&"++-- | Optional constructor name of a record value.+data RecInfo+  = AnonRec                           -- ^ anonymous record+  | NamedRec { recConK :: ConK+             , recConName :: QName    -- ^ record constructor+             , recNamedFields :: Bool -- ^ print field names?+             , recDottedRef :: Dotted -- ^ coming from dotted constructor (unconfirmed)+             }+  deriving (Eq, Ord)++newtype Dotted = Dotted { dottedRef :: IORef Bool }++instance Eq   Dotted where x == y = True+instance Ord  Dotted where x <= y = True+instance Show Dotted where show d = fwhen (isDotted d) ("un" ++) "confirmed"++-- A bit of imperative programming++mkDotted :: MonadIO m => Bool -> m Dotted+mkDotted b = liftIO $ Dotted <$> newIORef b++-- default value, shared over all instances+{-# NOINLINE notDotted #-}+notDotted :: Dotted+notDotted = unsafePerformIO $ mkDotted False++isDotted :: Dotted -> Bool+isDotted = unsafePerformIO . readIORef . dottedRef++clearDotted :: MonadIO m => Dotted -> m ()+clearDotted d | isDotted d = liftIO $ do+      -- putStrLn ("clearing a dot")+      writeIORef (dottedRef d) False+  | otherwise = return ()++alignDotted :: MonadIO m => Dotted -> Dotted -> m ()+alignDotted d1 d2 = case (isDotted d1, isDotted d2) of+  (True, False) -> clearDotted d1+  (False, True) -> clearDotted d2+  _             -> return ()++recDotted :: RecInfo -> Bool+recDotted NamedRec{recDottedRef} = isDotted recDottedRef+recDotted AnonRec = False++instance Show RecInfo where+  show AnonRec              = ""+  show ri@NamedRec{recConName} = (if recDotted ri then "." else "") ++ show recConName++-- * smart constructors++-- | Create a universal binding.  Fuse hidden bindings.+pi :: TBind -> Expr -> Expr+pi = piSig Pi++piSig :: PiSigma -> TBind -> Expr -> Expr+piSig = 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 e Pre n  = App (Proj Pre n) e+proj e Post n = App e (Proj Post n)++-- | Non-dependent function type.+funType a b = Quant Pi (noBind a) b++erasedExpr e = Ann (Tagged [Erased] e)+castExpr   e = Ann (Tagged [Cast]   e)++succView :: Expr -> (Int, Expr)+succView (Succ e) = inc (succView e) where inc (n, e) = (n+1, e)+succView e = (0, e)++-- Clauses and patterns ----------------------------------------------++data Clause = Clause+  { clTele     :: TeleVal      -- top-level telescope of type values for PVars+  , clPatterns :: [Pattern]+  , clExpr     :: Maybe Expr   -- Nothing if absurd clause+  } deriving (Eq,Ord,Show)++-- clause = Clause (error "internal error: no telescope in clause before typechecking!")+clause = Clause [] -- empty clTele++data PatternInfo = PatternInfo+  { coPat          :: ConK    -- (co)constructor+  , irrefutablePat :: Bool    -- constructor of a record (UNUSED)+  , dottedPat      :: Bool+  } deriving (Eq,Ord,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 (Eq,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 co n = Def $ DefId (ConK co) n+-- con co n = Con co n []+fun n    = Def $ DefId FunK n+dat n    = Def $ DefId DatK n+letdef n = Def $ DefId LetK $ QName n++type SpineView = (Expr, [Expr])++-- collect applications to expose head+spineView :: Expr -> SpineView+spineView = aux []+  where aux sp (App f e) = aux (e:sp) f+        aux sp e = (e, sp)++test_spineView = spineView ((Var x `App` Var y) `App` Var z)+  where x = fresh "x"+        y = fresh "y"+        z = fresh "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 (Ann (Tagged tags e)) =+  let (b, e') = isErasedExpr e+  in  (b || Erased `inTags` tags, e')+isErasedExpr e = (False, 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 (Eq,Ord,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 (Eq,Ord,Show)++data TySig a = TypeSig { namePart :: Name, typePart :: a }+               deriving (Eq,Ord,Show,Functor)+type TypeSig = TySig Type++type Type = Expr++-- | Constructor declaration.  Top-level scope (independent of data pars).+data Constructor = Constructor+ { ctorName :: QName       -- ^ Name of the constructor.+ , ctorPars :: ParamPats   -- ^ Constructor patterns (if new style params).+ , ctorType :: Type        -- ^ Constructor type (@fields -> target@).+ } deriving (Eq, Ord, Show)++type ParamPats = Maybe (Telescope, [Pattern])++newtype Telescope = Telescope { telescope :: [TBind] }+  deriving (Eq, Ord, Show, Size, Null)++emptyTel = Telescope []++data Arity = Arity+  { fullArity    :: Int        -- ^ arity of the function+  , isProjection :: Maybe Int  -- ^ projection? then number of parameters+  } deriving (Eq, Ord, Show)++data Fun = Fun+  { funTypeSig :: TypeSig      -- ^ internal name and type+  , funExtName :: Name         -- ^ external name (for associated eta-expanded fun)+  , funArity   :: Arity+  , funClauses :: [Clause]+  } deriving (Eq, Ord, 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 (Quant Pi (TMeasure{}) b) = b -- there can only be one measure!+eraseMeasure (Quant Pi a@(TBind{}) b)  = Quant Pi a $ eraseMeasure b+eraseMeasure (Quant Pi a@(TBound{}) b) = Quant Pi a $ eraseMeasure b+eraseMeasure (LLet a tel e b) = LLet a tel e $ eraseMeasure b+eraseMeasure t = t++-- inferable term = True/False+-- not needed for types or sizes+inferable :: Expr -> Bool+inferable Var{}   = True+inferable Sort{}  = True+inferable Zero{}  = True+inferable Infty{} = True+--inferable Con{}   = True+-- 2012-01-22 constructors are no longer inferable, since parameters are missing+inferable (Def (DefId { idKind = ConK{} }))  = False+inferable Def{} = True+inferable (App f e) = inferable f+-- inferable (Pair f e) = inferable f && inferable e  -- pairs are not inferable due to irrelevant sigma!+-- inferable Sing{}  = True  -- not with universes+inferable _       = False++-- | Collect the variables from the binders+class BoundVars a where+  boundVars :: Collection c Name => a -> c++instance BoundVars a => BoundVars [a] where+  boundVars = foldMap boundVars++instance BoundVars a => BoundVars (Maybe a) where+  boundVars = foldMap boundVars++instance (BoundVars a, BoundVars b) => BoundVars (a, b) where+  boundVars (a, b) = mconcat [boundVars a, boundVars b]++instance (BoundVars a, BoundVars b, BoundVars c) => BoundVars (a, b, c) where+  boundVars (a, b, c) = mconcat [boundVars a, boundVars b, boundVars c]++instance BoundVars (TBinding a) where+  boundVars (TBind x a)  = Coll.singleton x+  boundVars (TMeasure m) = mempty+  boundVars (TBound b)   = mempty++instance BoundVars Telescope where+  boundVars = boundVars . telescope++instance BoundVars (Pat e) where+  boundVars (VarP name)   = Coll.singleton name+  boundVars (SizeP x y)   = Coll.singleton y+  boundVars (SuccP p)     = boundVars p+  boundVars (ConP _ _ ps) = boundVars ps+  boundVars (PairP p p')  = boundVars (p, p')+  boundVars (ProjP _)     = mempty+  boundVars (DotP _)      = mempty+  boundVars (ErasedP p)   = boundVars p+  boundVars (AbsurdP)     = mempty+  boundVars (UnusableP p) = 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 = foldMap freeVars++instance FreeVars a => FreeVars (Maybe a) where+  freeVars = foldMap freeVars++instance FreeVars a => FreeVars (Sort a) where+  freeVars = foldMap freeVars++instance FreeVars a => FreeVars (Dom a) where+  freeVars = foldMap freeVars++instance FreeVars a => FreeVars (Measure a) where+  freeVars = foldMap freeVars++instance FreeVars a => FreeVars (Bound a) where+  freeVars = foldMap freeVars++instance FreeVars a => FreeVars (Tagged a) where+  freeVars = foldMap freeVars++instance (FreeVars a, FreeVars b) => FreeVars (a, b) where+  freeVars (a, b) = mconcat [freeVars a, freeVars b]++instance (FreeVars a, FreeVars b, FreeVars c) => FreeVars (a, b, c) where+  freeVars (a, b, c) = mconcat [freeVars a, freeVars b, freeVars c]++instance FreeVars a => FreeVars (TBinding a) where+  freeVars (TBind x a)  = freeVars a  -- Note: x is bound in the stuff to come, not in a.+  freeVars (TMeasure m) = freeVars m+  freeVars (TBound b)   = freeVars b++instance FreeVars Telescope where+  freeVars (Telescope [])         = mempty+  freeVars (Telescope (tb : tel)) = freeVars tb `Set.union`+                          (freeVars (Telescope tel) Set.\\ boundVars tb)++instance FreeVars Expr where+  freeVars e0 =+    case e0 of+      Sort s    -> freeVars s+      Zero      -> mempty+      Succ e    -> freeVars e+      Infty     -> mempty+      Var name  -> Set.singleton name+      Def{}     -> mempty+      Case e mt cls+                -> freeVars (e, mt, cls)+      LLet (TBind x dom) tel t u | null tel+                -> freeVars (dom, t) `Set.union` Set.delete x (freeVars u)+      Pair f e  -> freeVars (f, e)+      App  f e  -> freeVars (f, e)+      Max  es   -> freeVars es+      Plus es   -> freeVars es+      Lam _ x e -> Set.delete x (freeVars e)+      Quant pisig ta b -> freeVars ta `Set.union` (freeVars b Set.\\ boundVars ta)+{-+      Quant pisig tel ta b+                -> freeVars tel' `Set.union` (freeVars b Set.\\ boundVars tel')+                     where tel' = Telescope $ telescope tel ++ [ta]+-}+      Sing e t  -> freeVars (e, t)+      Below _ e -> freeVars e+      Ann te    -> freeVars te+      Irr       -> mempty+      e         -> error $ "freeVars " ++ show e ++ " not implemented"++instance FreeVars Clause where+  freeVars (Clause _ ps Nothing)  = mempty  -- absurd clause+  freeVars (Clause _ ps (Just e)) = freeVars e Set.\\ boundVars ps++patternVars :: Pattern -> [Name]+patternVars = 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 = foldMap usedDefs++instance UsedDefs a => UsedDefs (Maybe a) where+  usedDefs = foldMap usedDefs++instance UsedDefs a => UsedDefs (Sort a) where+  usedDefs = foldMap usedDefs++instance UsedDefs a => UsedDefs (Dom a) where+  usedDefs = foldMap usedDefs++instance UsedDefs a => UsedDefs (Measure a) where+  usedDefs = foldMap usedDefs++instance UsedDefs a => UsedDefs (Bound a) where+  usedDefs = foldMap usedDefs++instance UsedDefs a => UsedDefs (Tagged a) where+  usedDefs = foldMap usedDefs++instance (UsedDefs a, UsedDefs b) => UsedDefs (a, b) where+  usedDefs (a, b) = mconcat [usedDefs a, usedDefs b]++instance (UsedDefs a, UsedDefs b, UsedDefs c) => UsedDefs (a, b, c) where+  usedDefs (a, b, c) = mconcat [usedDefs a, usedDefs b, usedDefs c]++instance (UsedDefs a, UsedDefs b, UsedDefs c, UsedDefs d) => UsedDefs (a, b, c, d) where+  usedDefs (a, b, c, d) = mconcat [usedDefs a, usedDefs b, usedDefs c, usedDefs d]++instance UsedDefs a => UsedDefs (TBinding a) where+  usedDefs (TBind _ e)  = usedDefs e+  usedDefs (TMeasure m) = usedDefs m+  usedDefs (TBound b)   = usedDefs b++instance UsedDefs Telescope where+  usedDefs = usedDefs . telescope++instance UsedDefs DefId where+  usedDefs id+    | idKind id `elem` [FunK, DatK] = [unqual $ idName id]+    | otherwise                     = []++instance UsedDefs Clause where+  usedDefs = usedDefs . clExpr++instance UsedDefs Expr where+  usedDefs (Def id)           = usedDefs id+  usedDefs (Pair f e)         = usedDefs (f, e)+  usedDefs (App f e)          = usedDefs (f, e)+  usedDefs (Max es)           = usedDefs es+  usedDefs (Plus es)          = usedDefs es+  usedDefs (Lam _ x e)        = usedDefs e+  usedDefs (Sing a b)         = usedDefs (a, b)+  usedDefs (Below _ b)        = usedDefs b+--  usedDefs (Quant _ tel tb b) = usedDefs (tel, tb, b)+  usedDefs (Quant _ tb b)     = usedDefs (tb, b)+  usedDefs (LLet tb tel e1 e2)= usedDefs (tb, tel, e1, e2)+  usedDefs (Succ e)           = usedDefs e+  usedDefs (Case e mt cls)    = usedDefs (e, mt, cls)+  usedDefs (Ann e)            = usedDefs e+  usedDefs (Sort s)           = usedDefs s+  usedDefs Zero               = []+  usedDefs Infty              = []+  usedDefs Meta{}             = []+  usedDefs Var{}              = []+  usedDefs Proj{}             = []+  usedDefs (Record ri rs)     = foldMap (usedDefs . snd) rs+  usedDefs e                  = error $ "usedDefs " ++ show e ++ " not implemented"++rhsDefs :: [Clause] -> [Name]+rhsDefs cls = List.foldl (\ ns (Clause _ ps e) -> maybe [] usedDefs e ++ ns) [] cls++-- pretty printing expressions ---------------------------------------++[precArrL, precAppL, precAppR] = [1..3]++instance Pretty Name where+--  pretty x = text $ suggestion x+  pretty x = text $ show x++instance Pretty QName where+  pretty (Qual m n) = pretty m <> text "." <> pretty n+  pretty (QName n)  = pretty n++instance Pretty DefId where+--    pretty d = pretty $ name d+    pretty d = text $ show d++instance Pretty Expr where+  prettyPrec _ Irr         = text "."+  prettyPrec k (Sort s)    = prettyPrec k s+  prettyPrec _ Zero        = text "0"+  prettyPrec _ Infty       = text "#"+  prettyPrec _ (Meta i)    = text $ "?" ++ show i+  prettyPrec _ (Var n)     = pretty n+--  prettyPrec _ (Con _ n)   = text n+  prettyPrec _ (Def id)    = pretty id+--  prettyPrec _ (Let n)     = text n+  prettyPrec _ (Sing e t)  = angleBrackets $ pretty e <+> colon <+> pretty t+  prettyPrec k e@Succ{}    =+    case succView e of+      (n, Zero) -> text $ show n+      (n, e)    -> text (replicate n '$') <> prettyPrec precAppR e+--  prettyPrec k (Succ e)    = text "$" <> prettyPrec precAppR e+{-  prettyPrec k (Succ e)    = parensIf (precAppR <= k) $+                              text "$" <+> prettyPrec precAppR e   -}+  prettyPrec k (Max es)  = parensIf (precAppR <= k) $+    List.foldl (\ d e -> d <+> prettyPrec precAppR e) (text "max") es+  prettyPrec k (Plus (e:es))  = parensIf (1 < k) $+    List.foldl (\ d e -> d <+> text "+" <+> prettyPrec 1 e) (prettyPrec 1 e) es+  prettyPrec k (Proj Pre n)   = pretty n+  prettyPrec k (Proj Post n)  = text "." <> pretty n+  prettyPrec k (Record AnonRec []) = text "record" <+> braces empty+  prettyPrec k (Record AnonRec rs) = text "record" <+> prettyRecFields rs+  prettyPrec k (Record (NamedRec _ n _ dotted) []) = dotIf dotted $ pretty n+  prettyPrec k (Record (NamedRec _ n True dotted) rs) = dotIf dotted $ pretty n <+> prettyRecFields rs+  prettyPrec k (Record (NamedRec _ n False dotted) rs) =+   parensIf (not (null rs) && precAppR <= k) $ dotIf dotted $+     pretty n <+> hsep (List.map (prettyPrec precAppR . snd) rs)+  prettyPrec k (Pair e1 e2) = parens $ pretty e1 <+> comma <+> pretty e2+  prettyPrec k (App f e)  = parensIf (precAppR <= k) $+    prettyPrec precAppL f <+> prettyPrec precAppR 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 k (Case e mt cs) = parensIf (0 < k) $+    (text "case" <+> pretty e) <+> (maybe empty (\ t -> colon <+> pretty t) mt) $$ (vlist $ List.map prettyCase cs)+  prettyPrec k (Lam dec x e) = parensIf (0 < k) $+    (if erased dec then brackets else id) (text "\\" <+> pretty x <+> text "->")+      <+> pretty e+  prettyPrec k (LLet (TBind n (Domain mt ki dec)) tel e1 e2) | null tel = parensIf (0 < k) $+    (text "let" <+> ((if erased dec then lbrack else PP.empty) <>+       pretty n <+> vcat [ maybe empty (\ t -> colon <+> pretty t) mt+                           <> (if erased dec then rbrack else PP.empty)+                       , equals <+> pretty e1 ]))+    $$ (text "in" <+> pretty e2)+  prettyPrec k (LLet (TBind n (Domain mt ki dec)) tel e1 e2) = parensIf (0 < k) $+    (text "let" <+> ((if erased dec then brackets else id) $ pretty n)+                <+> pretty tel+                <+> vcat [ maybe empty (\ t -> colon <+> pretty t) mt+                         , equals <+> pretty e1 ])+    $$ (text "in" <+> pretty 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 k (Below ltle e) = pretty ltle <+> prettyPrec k e+  prettyPrec k (Quant Pi (TMeasure mu) t2) = parensIf (precArrL <= k) $+    (pretty mu <+> text "->" <+> pretty t2)+  prettyPrec k (Quant Pi (TBound beta) t2) = parensIf (precArrL <= k) $+    (pretty beta <+> text "->" <+> pretty t2)++  prettyPrec k (Quant pisig (TBind x (Domain t1 ki dec)) t2) | null (suggestion x) = parensIf (precArrL <= k) $+    ((if erased dec then ppol <> brackets (pretty t1)+       else ppol <+> prettyPrec precArrL t1)+      <+> pretty pisig <+> pretty t2)+    where pol = polarity dec+          ppol = if pol==defaultPol then PP.empty else text $ show pol++  prettyPrec k (Quant pisig (TBind x (Domain (Below ltle t1) ki dec)) t2) = parensIf (precArrL <= k) $+    ppol <>+    ((if erased dec then brackets else parens) $+      pretty x <+> pretty ltle <+> pretty t1) <+> pretty pisig <+> pretty t2+    where pol = polarity dec+          ppol = if pol==defaultPol then PP.empty else text $ show pol++  prettyPrec k (Quant pisig (TBind x (Domain t1 ki dec)) t2) = parensIf (precArrL <= k) $+    ppol <>+    ((if erased dec then brackets else parens) $+      pretty x <+> colon <+> pretty t1) <+> pretty pisig <+> pretty t2+    where pol = polarity dec+          ppol = if pol==defaultPol then PP.empty else text $ show pol++  prettyPrec k (Ann e) = pretty e++class DotIf a where+  dotIf :: a -> Doc -> Doc++instance DotIf Bool where+  dotIf False d = d+  dotIf True  d = text "." <> d++instance DotIf Dotted where+  dotIf c = dotIf (isDotted c)++instance Pretty TBind where+  prettyPrec k (TMeasure mu) = pretty mu+  prettyPrec k (TBound beta) = pretty beta++  prettyPrec k (TBind x (Domain (Below ltle t1) ki dec)) =+    ppol <>+    ((if erased dec then brackets else parens) $+      pretty x <+> pretty ltle <+> pretty t1)+    where pol = polarity dec+          ppol = if pol==defaultPol then PP.empty else text $ show pol++  prettyPrec k (TBind x (Domain t1 ki dec)) =+    ppol <>+    ((if erased dec then brackets else parens) $+      pretty x <+> colon <+> pretty t1)+    where pol = polarity dec+          ppol = if pol==defaultPol then PP.empty else text $ show pol++instance Pretty Telescope where+  prettyPrec k tel = sep $ map pretty $ telescope tel++prettyRecFields rs =+    let l:ls = List.map (\ (n, e) -> pretty n <+> equals <+> prettyPrec 0 e) rs+    in  cat $ (lbrace <+> l) : List.map (semi <+>) ls ++ [empty <+> rbrace]++prettyCase (Clause _ [p] Nothing)  = pretty p+prettyCase (Clause _ [p] (Just e)) = pretty p <+> text "->" <+> pretty e++instance Pretty PiSigma where+  pretty Pi    = text "->"+  pretty Sigma = text "&"++vlist :: [Doc] -> Doc+vlist [] = lbrace <> rbrace+vlist ds = (vcat $ zipWith (<+>) (lbrace : repeat semi) ds) $$ rbrace++instance Pretty (Measure Expr) where+  pretty (Measure es) = text "|" <> hsepBy comma (List.map pretty es) <> text "|"++instance Pretty LtLe where+  pretty Lt = text "<"+  pretty Le = text "<="++instance Pretty (Bound Expr) where+  pretty (Bound ltle mu mu') = pretty mu <+> pretty ltle <+> pretty 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 k (SortC c)  = text $ show c+  prettyPrec k (Set Zero) = text "Set" -- print as Set for backwards compat.+  prettyPrec k (Set e) =  parensIf (precAppR <= k) $+    text "Set" <+> prettyPrec precAppR e+  prettyPrec k (CoSet e) = parensIf (precAppR <= k) $+    text "CoSet" <+> prettyPrec precAppR e++instance Pretty Pattern where+  prettyPrec k (VarP x)       = pretty x+  prettyPrec k (ConP co c ps) = parensIf (not (null ps) && precAppR <= k) $+    -- (if dottedPat co then text "." else empty) <>+    dotIf (dottedPat co) $ pretty c <+> hsep (List.map (prettyPrec precAppR) ps)+  prettyPrec k (SuccP p)      = text "$" <> prettyPrec k p+  prettyPrec k (SizeP x y)    = parensIf (precAppR <= k) $ pretty y <+> text "<" <+> pretty x+  prettyPrec k (PairP p p')   = parens $ pretty p <> comma <+> pretty p'+  prettyPrec k (UnusableP p)  = prettyPrec k p+  prettyPrec k (ProjP x)      = text "." <> pretty x+  prettyPrec k (DotP p)       = text "." <> prettyPrec precAppR p+  prettyPrec k (AbsurdP)      = text "()"+  prettyPrec k (ErasedP p)    = brackets $ prettyPrec 0 p+++instance Show Expr where+  showsPrec k e s = render (prettyPrec k e) ++ s+  -- show = render . pretty -- showExpr++instance Show Pattern where+  show = render . pretty++showCase (Clause _ [p] Nothing) = render (prettyPrec precAppR p)+showCase (Clause _ [p] (Just e)) = render (prettyPrec precAppR p) ++ " -> " ++ show e+showCases = showList "; " 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 phi p =+  let phi' x = maybe (Var x) patternToExpr $ lookup x phi+  in+  case p of+    VarP n -> maybe p id $ lookup n phi+    ConP pi n ps -> ConP pi n $ List.map (patSubst phi) ps+    SuccP p      -> SuccP $ patSubst phi p+    SizeP e y    -> SizeP (parSubst phi' e) y+    PairP p1 p2  -> PairP (patSubst phi p1) (patSubst phi p2)+    ProjP x      -> p+    DotP e       -> DotP $ parSubst phi' e+    AbsurdP      -> p+    ErasedP p    -> ErasedP $ patSubst phi p+    UnusableP p   -> UnusableP $ patSubst phi 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 = map . parSubst++instance ParSubst a => ParSubst (Maybe a) where+  parSubst = fmap . parSubst++instance ParSubst a => ParSubst (Dom a) where+  parSubst = fmap . parSubst++instance ParSubst a => ParSubst (Measure a) where+  parSubst = fmap . parSubst++instance ParSubst a => ParSubst (Bound a) where+  parSubst = fmap . parSubst++instance ParSubst a => ParSubst (Tagged a) where+  parSubst = fmap . parSubst++instance ParSubst a => ParSubst (TBinding a) where+  parSubst phi (TBind x a)  = TBind x  $ parSubst phi a+  parSubst phi (TMeasure m) = TMeasure $ parSubst phi m+  parSubst phi (TBound b)   = TBound   $ parSubst phi b++instance ParSubst a => ParSubst (Sort a) where+  parSubst phi (CoSet e) = CoSet $ parSubst phi e+  parSubst phi (Set e)   = Set   $ parSubst phi e+  parSubst phi s         = s++instance ParSubst Telescope where+  parSubst phi = Telescope . parSubst phi . telescope++instance ParSubst Clause where+  parSubst phi (Clause tel ps e) = Clause tel ps $ parSubst phi e++-- TODO: Refactor!+instance ParSubst Expr where+  parSubst phi (Sort s)              =  Sort $ parSubst phi s+  parSubst phi (Succ e)              = Succ (parSubst phi e)+  parSubst phi e@Zero                = e+  parSubst phi e@Infty               = e+  parSubst phi e@Meta{}              = e+  parSubst phi e@Proj{}              = e+  parSubst phi (Var x)               = phi x+  parSubst phi e@Def{}               = e+  parSubst phi (Case e mt cls)       = Case (parSubst phi e) (parSubst phi mt) (parSubst phi cls)+  parSubst phi (LLet ta tel b c)     = LLet (parSubst phi ta) (parSubst phi tel) (parSubst phi b) (parSubst phi c)+  parSubst phi (Pair f e)            = Pair (parSubst phi f) (parSubst phi e)+  parSubst phi (App f e)             = App (parSubst phi f) (parSubst phi e)+  parSubst phi (Record ri rs)        = Record ri (mapAssoc (parSubst phi) rs)+  parSubst phi (Max es)              = Max (parSubst phi es)+  parSubst phi (Plus es)             = Plus (parSubst phi es)+  parSubst phi (Lam dec x e)         = Lam dec x (parSubst phi e)+  parSubst phi (Below ltle e)        = Below ltle (parSubst phi e)+  parSubst phi (Quant pisig a b)     = Quant pisig (parSubst phi a) (parSubst phi b)+--  parSubst phi (Quant pisig tel a b) = Quant pisig (parSubst phi tel) (parSubst phi a) (parSubst phi b)+  parSubst phi (Sing a b)            = Sing (parSubst phi a) (parSubst phi b)+  parSubst phi (Ann e)               = Ann $ parSubst phi e+  parSubst phi e                     = error $ "Abstract.parSubst phi (" ++ show e ++ ") 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 = map . subst++instance Substitute a => Substitute (Maybe a) where+  subst = fmap . subst++instance Substitute a => Substitute (Dom a) where+  subst = fmap . subst++instance Substitute a => Substitute (Measure a) where+  subst = fmap . subst++instance Substitute a => Substitute (Bound a) where+  subst = fmap . subst++instance Substitute a => Substitute (Tagged a) where+  subst = fmap . subst++instance Substitute a => Substitute (TBinding a) where+  subst phi (TBind x a)  = TBind x  $ subst phi a+  subst phi (TMeasure m) = TMeasure $ subst phi m+  subst phi (TBound b)   = TBound   $ subst phi b++instance Substitute a => Substitute (Sort a) where+  subst phi (CoSet e) = CoSet $ subst phi e+  subst phi (Set e)   = Set   $ subst phi e+  subst phi s         = s++instance Substitute Telescope where+  subst phi = Telescope . subst phi . telescope++instance Substitute Clause where+  subst phi (Clause tel ps e) = Clause tel ps $ subst phi e++instance Substitute Expr where+  subst phi (Sort s)              = Sort $ subst phi s+  subst phi (Succ e)              = Succ (subst phi e)+  subst phi e@Zero                = e+  subst phi e@Infty               = e+  subst phi e@(Meta i)            = Map.findWithDefault e i phi+  subst phi e@Var{}               = e+  subst phi e@Def{}               = e+  subst phi e@Proj{}              = e+  subst phi (Case e mt cls)       = Case (subst phi e) (subst phi mt) (subst phi cls)+  subst phi (LLet ta tel b c)     = LLet (subst phi ta) (subst phi tel) (subst phi b) (subst phi c)+  subst phi (Pair f e)            = Pair (subst phi f) (subst phi e)+  subst phi (App f e)             = App (subst phi f) (subst phi e)+  subst phi (Record ri rs)        = Record ri (mapAssoc (subst phi) rs)+  subst phi (Max es)              = Max (subst phi es)+  subst phi (Plus es)             = Plus (subst phi es)+  subst phi (Lam dec x e)         = Lam dec x (subst phi e)+  subst phi (Below ltle e)        = Below ltle (subst phi e)+  subst phi (Quant pisig a b)     = Quant pisig (subst phi a) (subst phi b)+--  subst phi (Quant pisig tel a b) = Quant pisig (subst phi tel) (subst phi a) (subst phi b)+  subst phi (Sing a b)            = Sing (subst phi a) (subst phi b)+  subst phi (Ann e)               = Ann $ subst phi e+  subst phi e                     = error $ "Abstract.subst phi (" ++ show e ++ ") 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 f cls = vlist $ List.map (prettyClause f) cls++prettyClause f (Clause _ ps Nothing) = pretty f <+> hsep (List.map (prettyPrec precAppR) ps)+prettyClause f (Clause _ ps (Just e)) = pretty f+  <+> hsep (List.map (prettyPrec precAppR) ps)+  <+> equals <+> pretty 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 (Eq, Show)++type Destructor = (Type, Arity, Clause)++data FieldInfo = FieldInfo+  { fDec   :: Dec+  , fName  :: Name        -- ^ Empty "" for anonymous fields.+  , fType  :: Type        -- ^ Naked type (no preceeding telescope).+--  , fLazy  :: Bool        -- lazy (coinductive occ) or strict (everything else) -- see TCM.hs ConSig+  , fClass :: FieldClass+  }++instance Show FieldInfo where+  show (FieldInfo dec name t fcl) =+    (if fcl == Index then "index " else "field ") +++    bracketsIf (erased dec) (show name ++ " : " -- ++ (if lazy then "?" else "")+                                      ++ show 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 (Eq, Ord, Show)++data ConstructorInfo = ConstructorInfo+  { cName   :: QName+--  , cType   :: TVal+  , cPars   :: ParamPats  -- ^ Constructor parameters if unequal to data parameters.+  , cFields :: [FieldInfo]+  , cTyCore :: Type+  , cPatFam :: (PatternsType, [Pattern])+  , cEtaExp :: Bool -- all destructors are defined, family pattern is non-overlapping with family patterns of other constructors+  , cRec    :: Bool -- constructor has recursive fields+  } deriving Show++corePat :: ConstructorInfo -> [Pattern]+corePat = snd . 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 = foldMap injectiveVars++instance InjectiveVars a => InjectiveVars (Maybe a) where+  injectiveVars = foldMap injectiveVars++instance InjectiveVars a => InjectiveVars (Sort a) where+  injectiveVars = foldMap injectiveVars++instance InjectiveVars a => InjectiveVars (Dom a) where+  injectiveVars = foldMap injectiveVars++instance InjectiveVars a => InjectiveVars (Measure a) where+  injectiveVars = foldMap injectiveVars++instance InjectiveVars a => InjectiveVars (Bound a) where+  injectiveVars = foldMap injectiveVars++instance InjectiveVars a => InjectiveVars (Tagged a) where+  injectiveVars = foldMap injectiveVars++instance (InjectiveVars a, InjectiveVars b) => InjectiveVars (a, b) where+  injectiveVars (a, b) = mconcat [injectiveVars a, injectiveVars b]++instance (InjectiveVars a, InjectiveVars b, InjectiveVars c) => InjectiveVars (a, b, c) where+  injectiveVars (a, b, c) = mconcat [injectiveVars a, injectiveVars b, injectiveVars c]++instance InjectiveVars a => InjectiveVars (TBinding a) where+  injectiveVars (TBind x a)  = injectiveVars a+  injectiveVars (TMeasure m) = injectiveVars m+  injectiveVars (TBound b)   = injectiveVars b++instance InjectiveVars Telescope where+  injectiveVars (Telescope []) = mempty+  injectiveVars (Telescope (tb : tel)) = injectiveVars tb `Set.union`+                          (injectiveVars (Telescope tel) Set.\\ boundVars tb)++instance InjectiveVars Expr where+  injectiveVars e =+   case spineView e of+    (Var name            , []) -> Set.singleton name+    (Def (DefId DatK{} _), es) -> injectiveVars es+    (Def (DefId ConK{} _), es) -> injectiveVars es+    (Record ri rs        , []) -> Set.unions $ List.map (injectiveVars . snd) rs+    (Succ e              , []) -> injectiveVars e+    (Lam _ x e           , []) -> Set.delete x (injectiveVars e)+    (Quant _ ta b , []) -> injectiveVars ta `Set.union` (injectiveVars b Set.\\ boundVars 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 e              , []) -> injectiveVars e+    _                         -> Set.empty++classifyFields :: Co -> Name -> Type -> [FieldInfo]+classifyFields co dataName ty = List.map (classifyField fvs) $ telescope tele+  where (tele, core) = typeToTele ty+        fvs = freeVars core+        ivs = injectiveVars core+        classifyField fvs (TBind name (Domain ty ki dec)) = FieldInfo+          { fDec = dec+          , fName  = name+          , fType  = ty+--          , fLazy  = co == CoInd && maybeRecursiveOccurrence dataName ty+          , fClass = if name `Set.member` fvs then+                       if name `Set.member` ivs then Index else NotErasableIndex+                      else Field Nothing+          }++isField :: FieldClass -> Bool+isField Field{} = True+isField _       = False++isNamedField :: FieldInfo -> Bool+isNamedField f = isField (fClass f) && not (erased $ fDec f) && not (emptyName $ fName f)++destructorNames :: [FieldInfo] -> [Name]+destructorNames fields = List.map fName $ filter isNamedField fields++analyzeConstructor :: Co -> Name -> Telescope -> Constructor -> ConstructorInfo+analyzeConstructor co dataName dataPars (Constructor constrName conPars ty) =+  let (_, core)  = typeToTele ty+      pars       = maybe dataPars fst conPars+      fields     = classifyFields co dataName ty+      -- freshenFieldName fi = fi { fName = freshen $ fName fi }+      -- freshfields = List.map freshenFieldName fields+      -- generate destructors+      -- choose a name for the record to destroy+      indices    = filter (\ f -> fClass f == Index) fields+      indexTele  = Telescope $ List.map (\ f -> TBind (fName f) $ Domain (fType f) defaultKind (fDec f)) indices+      indexNames  = List.map fName indices+      -- do not generated destructors for erased arguments+      destrNames = destructorNames fields+      recName    = internal $ name constrName -- "constructed_by_" ++ constrName+      parNames   = List.map boundName $ telescope pars+      parAndIndexNames = parNames ++ indexNames+      -- substitute variable "fst" by application "fst A B p"+      phi x = if x `elem` destrNames+                then List.foldl App ({-fun x-} letdef x) (List.map Var (parAndIndexNames ++ [recName]))+                else Var x+      -- prefix d =  "destructor_argument_" ++ d+      prefix d = d { suggestion = "#" ++ suggestion d }+      -- modifiedDestrNames = List.map prefix destrNames+      -- TODO: Index arguments are not always before fields+      pattern = ConP (PatternInfo (coToConK co) False False) -- to bootstrap destructor, not irrefutable+          constrName+          ( -- 2012-01-22 PARS GONE!   List.map (DotP . Var) parNames +++            List.map (\ fi -> (case fClass fi of+                            Index   -> DotP . Var+                            Field{} -> VarP . prefix)+                         (fName fi))+              fields)+      destrType t = -- teleToTypeErase (pars ++ indexTele)+                    teleToTypeErase pars $ teleToType indexTele $+                      pi (TBind recName $ defaultDomain core) $ parSubst phi t+      destrBody (dn) = clause (List.map VarP parAndIndexNames ++ [pattern]) (Just (Var dn))+      fields' = mapOver fields $+        \ f -> if isNamedField f then+                  f { fClass = Field $ Just+                         ( destrType (fType f)+                         , let npars = size pars+                           in  Arity { fullArity = npars + size indexTele + 1+                                     , isProjection = Just npars+                                     }+                         , destrBody (prefix (fName f)) )}+                else f+      computeLinearity :: (Bool, [Pattern]) -> (PatternsType, [Pattern])+      computeLinearity (False, ps) = (NotPatterns, ps)+      computeLinearity (True , ps) = (if linear then LinearPatterns else NonLinearPatterns, ps) where+        linear = List.null ps || (List.null $ List.foldl1 List.intersect $ List.map patternVars ps)++      result = ConstructorInfo+       { cName   = constrName+       , cPars   = conPars+       , cFields = fields'+       , cTyCore = core+       -- check whether core is D ps and store pats; also compute whether ps are linear+       , cPatFam = computeLinearity $ fromAllWriter $ isPatIndFamC core+       , cEtaExp = destructorNamesPresent fields+       , cRec    = True  -- we don't know here, assume the worst+       }+   in -- trace ("analyzeConstructor returns " ++ show result) $+        result++-- can only eta expand if I can generate all destructors+destructorNamesPresent :: [FieldInfo] -> Bool+destructorNamesPresent fields =+  all (\ f -> fClass f /= NotErasableIndex &&  -- no bad index+              (fClass f == Index ||+               not (erased $ fDec f) && not (emptyName $ fName f))) -- no erased or unnamed field+    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 dataName pars cs =+  let cis = List.map (analyzeConstructor co dataName pars) cs+      -- check if patterns overlaps with any other+      overlapList = zipWith (\ ci n -> any (overlaps (corePat ci)) $ List.map corePat $ take n cis ++ drop (n+1) cis) cis [0..] -- worst case quadratic, could be improved by exploiting symmetry+      result = zipWith (\ ci ov -> if ov then ci { cEtaExp = False } else ci) cis overlapList+  in result++-- | Build constructor type from constructor info, erasing all indices.+reassembleConstructor :: ConstructorInfo -> Constructor+reassembleConstructor ci = Constructor (cName ci) (cPars ci) (reassembleConstructorType ci)++-- | Assumes that all the indices (even from data telescope) are contained+--   in fields.+reassembleConstructorType :: ConstructorInfo -> Type+reassembleConstructorType ci = buildPi (cFields ci) where+  buildPi [] = cTyCore ci+  buildPi (f:fs) = pi (TBind (fName f) $ Domain (fType f) defaultKind (decor (fDec f) (fClass f))) $ buildPi fs+    where decor dec Index = irrelevantDec -- DONE: SWITCH ON!+          decor 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 (Def id) = return []+isPatIndFamC (App f e) = do+  ps <- isPatIndFamC f+  p  <- exprToDotPat' e+  return $ ps ++ [p]+-- isPatIndFamC (App e es) = do+--   ps  <- isPatIndFamC e+--   ps' <- mapM exprToDotPat' es+--   return $ ps ++ ps'+isPatIndFamC (Quant Pi _ e) = isPatIndFamC e+isPatIndFamC _ = tell (All False) >> return []++-- Pattern auxiliary functions ---------------------------------------++-- extract all subpatterns of the form y > x and arrange them in a+-- TreeShapedOrder+tsoFromPatterns :: [Pattern] -> TSO Name+tsoFromPatterns ps = TSO.fromList $ List.concat $ List.map loop ps where+  loop (SizeP (Var father) son) = [(son,(1,father))]+  loop (SizeP (Succ (Var father)) son) = [(son,(0,father))]+  loop (SizeP e      son) = []+  loop (ConP _ _ ps)      = List.concat $ List.map loop ps+  loop (PairP p p')       = loop p ++ loop p'+  loop (SuccP   p)        = loop p+  loop (ErasedP p)        = loop 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 (VarP _) p' = True+overlap p (VarP _)  = True+overlap (ConP _ c ps) (ConP _ c' ps') = c == c' && overlaps ps ps' -- only source of non-overlap+overlap (PairP p1 p2) (PairP p1' p2') = overlaps [p1,p2] [p1',p2']+overlap (ProjP n) (ProjP n') = n == n' -- another source of non-overlap+-- size patterns always overlap+overlap (SuccP p) _ = True+overlap _ (SuccP p) = True+overlap SizeP{} _   = True+overlap _ SizeP{}   = True+-- dot patterns always overlap (safe approximation)+overlap (DotP _) _ = True+overlap _ (DotP _) = 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 ps ps' = and $ zipWith overlap ps ps'++-- | @exprToPattern@ is used in the termination checker to convert+--   dot patterns into proper patterns.+exprToPattern :: Expr -> Maybe Pattern+exprToPattern (Def (DefId (ConK co) n)) = return $ ConP pi n []+  where pi = PatternInfo co False False -- not irrefutable (TODO: good enough?)+exprToPattern (Var n)       = return $ VarP n+exprToPattern (Pair e e')   = PairP <$> exprToPattern e <*> exprToPattern e'+exprToPattern (Succ e)      = SuccP <$> exprToPattern e+exprToPattern (Proj Post n) = return $ ProjP n+exprToPattern (App f e)     = patApp ==<< (exprToPattern f, exprToPattern e)+-- exprToPattern (Infty)    = return $ DotP Infty -- leads to non-term in compareExpr+exprToPattern _ = fail "exprToPattern"++-- | Only constructor patterns can be applied to a pattern.+patApp :: Pattern -> Pattern -> Maybe Pattern+patApp (ConP co n ps) p = Just $ ConP co n (ps ++ [p])+patApp _              _ = 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 = fromAllWriter . exprToDotPat'++exprToDotPat' :: Expr -> Writer All Pattern+exprToDotPat' e = do+  let fallback = tell (All False) >> return (DotP e)+  case e of+    Def (DefId (ConK co) n) -> return $ ConP pi n [] where+      pi = PatternInfo co False False -- not irrefutable (TODO: good enough?)+    Proj Post n -> return $ ProjP n+    Var n       -> return $ VarP n+    Pair e e'   -> PairP <$> exprToDotPat' e <*> exprToDotPat' e'+    Infty       -> return $ DotP Infty+    Succ e      -> SuccP <$> exprToDotPat' e+    App f e     -> maybe fallback return =<< do+      patApp <$> exprToDotPat' f <*> exprToDotPat' 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+-}+    _ -> fallback++patternToExpr :: Pattern -> Expr+patternToExpr (VarP n)       = Var n+patternToExpr (SizeP m n)    = Var n+patternToExpr (ConP pi n ps) = List.foldl App (con (coPat pi) n) (List.map patternToExpr ps)+-- patternToExpr (ConP co n ps) = Con co n `App` (List.map patternToExpr ps)+patternToExpr (PairP p p')   = Pair (patternToExpr p) (patternToExpr p')+patternToExpr (SuccP p)      = Succ (patternToExpr p)+patternToExpr (UnusableP p)  = patternToExpr p+patternToExpr (ProjP n)      = Proj Post n+patternToExpr (DotP e)       = e -- cannot put Irr here because introPatType wants to compute the value of a dot pattern (after all bindings have been introduced)+patternToExpr (ErasedP p)    = erasedExpr $ patternToExpr p+patternToExpr (AbsurdP)      = Irr++-- | Dot all constructor subpatterns.  Used when expanding a dotted patsyn.+dotConstructors :: Pattern -> Pattern+dotConstructors p =+  case p of+    ConP pi c ps -> ConP pi{ dottedPat = True } c $ List.map dotConstructors ps+    PairP p1 p2  -> PairP (dotConstructors p1) (dotConstructors p2)+    _            -> p++-- admissible pattern ------------------------------------------------++-- completeP is used in admPattern, should not be True for UnusableP+completeP :: Pattern -> Bool+completeP (DotP _) = True+completeP (VarP _) = True+completeP SizeP{}  = False -- True+completeP (UnusableP p) = completeP p+completeP (ErasedP p)   = completeP p+completeP _ = False++isDotPattern :: Pattern -> Bool+isDotPattern (DotP _ ) = True+isDotPattern _ = False++-- isSuccessorPattern is used in admPattern, should not be True for UnusableP+isSuccessorPattern :: Pattern -> Bool+isSuccessorPattern (SuccP _)   = True+isSuccessorPattern (DotP e)    = isSuccessor e+isSuccessorPattern (ErasedP p) = isSuccessorPattern p+isSuccessorPattern _ = False++isSuccessor :: Expr -> Bool+isSuccessor (Ann e)  = isSuccessor (unTag e)+isSuccessor (Succ e) = True+isSuccessor _        = False++shallowSuccP :: Pattern -> Bool+shallowSuccP p = case p of+     (SuccP p)   -> isVarP p+     (ErasedP p) -> shallowSuccP p+     (DotP e)    -> shallowSuccE e+     _           -> False++   where isVarP (VarP _)         = True+         isVarP (DotP e)         = isVarE e+         isVarP (ErasedP p)      = isVarP p+         isVarP _                = False++         isVarE (Ann e)          = isVarE (unTag e)+         isVarE (Var _)          = True+         isVarE _                = False++         shallowSuccE (Ann e)    = shallowSuccE (unTag e)+         shallowSuccE (Succ e)   = isVarE e+         shallowSuccE _          = False++-- telescopes --------------------------------------------------------++---- construction++-- | typeToTele ((x : A) -> (y : B) -> C) = ([(x,A),(y,B)], C)+typeToTele :: Type -> (Telescope, Type)+typeToTele = typeToTele' (-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' k t = mapFst Telescope $ ttt k 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 k (Quant Pi tb t2) tel | k /= 0 = ttt (k-1) t2 (tb : tel)+      ttt k t tel = (reverse tel, t)++---- modification++instance LensDec Telescope where+  getDec   = error "getDec not defined for Telescope"+  mapDec f = Telescope . List.map (mapDec f) . telescope++---- destruction++teleLam :: Telescope -> Expr -> Expr+teleLam tel e = foldr (uncurry Lam) e $+  List.map (\ tb -> (decor $ boundDom tb, boundName tb)) $ telescope tel++teleToType' :: (Dec -> Dec) -> Telescope -> Type -> Type+teleToType' mod tel t = foldr (\ tb -> pi (mapDec mod tb)) t $ telescope tel+{-+teleToType' mod []       t = t+teleToType' mod (tb:tel) t = Pi (mapDec mod tb) (teleToType' mod tel t)+-}++teleToType :: Telescope -> Type -> Type+teleToType = teleToType' id++teleToTypeErase :: Telescope -> Type -> Type+teleToTypeErase = teleToType' demote -- (\ dec -> dec { erased = True })++adjustTopDecs :: (Dec -> Dec) -> Type -> Type+adjustTopDecs f t = teleToType' f tel core where+  (tel, core) = typeToTele t++teleToTypeM :: (Applicative m) => (Dec -> m Dec) -> Telescope -> Type -> m Type+teleToTypeM mod tel t =+  foldr (\ tb mt -> pi <$> mapDecM mod tb <*> mt) (pure t) $ telescope tel++adjustTopDecsM :: (Applicative m) => (Dec -> m Dec) -> Type -> m Type+adjustTopDecsM f t = teleToTypeM f tel core where+  (tel, core) = typeToTele 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+++-}
+ src/Abstract.hs-boot view
@@ -0,0 +1,4 @@+module Abstract where++data TBinding a+
+ src/Collection.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}++module Collection where++import Data.List as List+import Data.Monoid++import Data.Set (Set)+import qualified Data.Set as Set++class Monoid c => Collection c e | c -> e where+{-+  empty     :: c+  append    :: c -> c -> c+  concat    :: [c] -> c+-}+  singleton :: e -> c+  delete    :: e -> c -> c+  (\\)      :: c -> c -> c++instance Eq a => Collection [a] a where+{-+  empty     = []+  append    = (++)+  concat    = List.concat+-}+  singleton = (:[])+  delete    = List.delete+  (\\)      = (List.\\)++instance Ord a => Collection (Set a) a where+{-+  empty     = Set.empty+  append    = Set.union+  concat    = Set.unions+-}+  singleton = Set.singleton+  delete    = Set.delete+  (\\)      = (Set.\\)
+ src/Concrete.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE NamedFieldPuns #-}+-- concrete syntax+module Concrete where++import Prelude hiding (null)++import Util+import Abstract (Co,Sized,PiSigma(..),Decoration(..),Dec,Override(..),Measure(..),Bound(..),HasPred(..),LtLe(..),polarity)+import qualified Abstract as A+import Polarity++-- | Concrete names.+data Name = Name { theName :: String }+  deriving (Eq,Ord)++instance Show Name where+  show (Name n) = n++-- | Possibly qualified names.+data QName+  = Qual  { qual :: Name, name :: Name }  -- ^ @X.x@ e.g. qualified constructor.+  | QName { name :: Name }                -- ^ @x@.+  deriving (Eq,Ord)++unqual (QName n) = n++instance Show QName where+  show (Qual m n) = show m ++ "." ++ show n+  show (QName n)  = show n++set0 = Set Zero+ident n = Ident (QName n)++-- | Concrete expressions syntax.+data Expr+  = Set Expr                        -- ^ Universe @Set e@; @Set@ for @Set 0@.+  | CoSet Expr+  | Size                            -- ^ @Size@ type of sizes.+  | Succ Expr                       -- ^ @$e@.+  | Zero                            -- ^ @0@.+  | Infty                           -- ^ @#@.+  | Max                             -- ^ @max@.+  | Plus Expr Expr                  -- ^ @e + e'@.+  | RApp Expr Expr                  -- ^ @e |> f@.+  | App Expr [Expr]                 -- ^ @f e1 ... en@ or @f <| e@.+  | Lam Name Expr                   -- ^ @\ x -> e@.+  | Case Expr (Maybe Type) [Clause] -- ^ @case e : A { cls }@.+  | LLet LetDef Expr                -- ^ @let x = e in e'@ local let.+  | Quant PiSigma Telescope Expr    -- ^ @(x : A) -> B@, @[x : A] -> B@, @(x : A) & B@.+  | Pair Expr Expr                  -- ^ @e , e'@.+  | Record [([Name],Expr)]          -- ^ @record { x = e, x' y = e' }@.+  | Proj Name                       -- ^ @.x@.+  | Ident QName                     -- ^ @x@ or @D.c@.+  | Unknown                         -- ^ @_@.+  | Sing Expr Expr                  -- ^ @<e : A>@ singleton type.+--  | EBind TBind Expr                -- ^ @[x : A] B@+  deriving (Eq)++data LetDef = LetDef+  { letDefDec :: Dec+  , letDefName :: Name+  , letDefTel  ::  Telescope+  , letDefType :: (Maybe Type)+  , letDefExpr :: Expr+  } deriving (Eq, Show)++instance Show Expr where+    show = prettyExpr++instance HasPred Expr where+  predecessor (Succ e) = Just e+  predecessor _ = Nothing++data Declaration+  = DataDecl Name Sized Co Telescope Type [Constructor]+      [Name] -- list of field names+  | RecordDecl Name Telescope Type Constructor+      [Name] -- list of field names+  | FunDecl Co TypeSig [Clause]+  | LetDecl Bool LetDef -- True = if eval+--  | LetDecl Bool Name Telescope (Maybe Type) Expr -- True = if eval+  | PatternDecl Name [Name] Pattern+  | MutualDecl [Declaration]+  | OverrideDecl Override [Declaration] -- fail etc.+    deriving (Eq,Show)++data TypeSig = TypeSig Name Type+             deriving (Eq)++instance Show TypeSig where+  show (TypeSig n t) = show n ++ " : " ++ show t++type Type = Expr++data Constructor = Constructor+  { conName :: Name+  , conTel  :: Telescope+  , conType :: Maybe Type -- can be omitted *but* for families+  } deriving (Eq)++instance Show Constructor where+  show (Constructor n tel (Just t)) = show n ++ " " ++ show tel ++ " : " ++ show t+  show (Constructor n tel  Nothing) = show n ++ " " ++ show tel++type TBind = TBinding Type+type LBind = TBinding (Maybe Type)  -- possibly domain-free++data TBinding a = TBind+  { boundDec   :: Dec+  , boundNames :: [Name] -- [] if no name is given, then its a single bind+  , boundType  :: a+  }+  | TBounded  -- bounded quantification+  { boundDec   :: Dec+  , boundName  :: Name -- [] if no name is given, then its a single bind+  , ltle       :: LtLe+  , upperBound :: Expr+--  , boundMType :: Maybe Type -- type is inferred from upperBound+  }+  | TMeasure (Measure Expr)+  | TBound (Bound Expr)+--  | TSized { boundName :: Name } -- the size parameter of a sized record+    deriving (Eq,Show)++type Telescope = [TBind]++data DefClause = DefClause+   Name         -- function identifier+   [Elim]+   (Maybe Expr) -- Nothing for absurd pattern clause+ deriving (Eq,Show)++data Elim+  = EApp Pattern          -- application to a pattern+  | EProj Name [Pattern]  -- projection with arguments+    deriving (Eq,Show)++data Clause = Clause+                (Maybe Name) -- Just funId | Nothing for case clauses+                [Pattern]+                (Maybe Expr) -- Nothing for absurd pattern clause+            deriving (Eq,Show)++data Pattern+  = ConP Bool QName [Pattern] -- ^ @(c ps)@ if @False; @(.c ps)@ if @True@.+  | PairP Pattern Pattern     -- ^ @(p, p')@+  | SuccP Pattern             -- ^ @($ p)@+  | DotP Expr                 -- ^ @.e@+  | IdentP QName              -- ^ @x@ or @c@ or @D.c@.+  | SizeP Expr Name           -- ^ @(x > y)@ or @y < #@ or ...+  | AbsurdP                   -- ^ @()@+    deriving (Eq,Show)++type Case = (Pattern,Expr)++-- | Used in Parser.+patApp :: Pattern -> [Pattern] -> Pattern+patApp (IdentP c)         ps' = ConP False  c ps'+patApp (ConP dotted c ps) ps' = ConP dotted c (ps ++ ps')++-- * Pretty printing.++prettyLBind :: LBind -> String+-- prettyLBind (TSized x)                   = prettyTBind False (TSized x)+prettyLBind (TMeasure mu)                = prettyTBind False (TMeasure mu)+prettyLBind (TBound (Bound ltle mu mu')) = prettyTBind False (TBound (Bound ltle mu mu'))+prettyLBind (TBounded dec x ltle e)      = prettyTBind False (TBounded dec x ltle e)+prettyLBind (TBind dec xs (Just t))      = prettyTBind False (TBind dec xs t)+prettyLBind (TBind dec xs Nothing) =+  if erased dec then addPol False $ brackets binding+   else addPol True binding+  where binding = Util.showList " " show xs+        pol = polarity dec+        addPol b x = if pol==defaultPol+                      then x+                      else show pol ++ (if b then " " else "") ++ x+++prettyTBind :: Bool -> TBind -> String+-- prettyTBind inPi (TSized x) = parens ("sized " ++ x)+prettyTBind inPi (TMeasure mu) = "|" +++  (Util.showList ","  prettyExpr (measure mu)) ++ "|"+prettyTBind inPi (TBound (Bound ltle mu mu')) = "|" +++  (Util.showList ","  prettyExpr (measure mu))  ++ "| " ++ show ltle ++ " |" +++  (Util.showList ","  prettyExpr (measure mu')) ++ "|"+prettyTBind inPi (TBind dec xs t) =+  if erased dec then addPol False $ brackets binding+   else if (null xs) then addPol True s+   else addPol (not inPi) $ (if inPi then parens else id) binding+  where s = prettyExpr t+        binding = if null xs then s else+          foldr (\ x s -> show x ++ " " ++ s) (": " ++ s) xs+        pol = polarity dec+        addPol b x = if pol==defaultPol+                      then x+                      else show pol ++ (if b then " " else "") ++ x+prettyTBind inPi (TBounded dec x ltle e) =+  if erased dec then addPol False $ brackets binding+   else addPol (not inPi) $ (if inPi then parens else id) binding+  where binding = show x ++ " < " ++ prettyExpr e+        pol = polarity dec+        addPol b x = if pol==defaultPol+                      then x+                      else show pol ++ (if b then " " else "") ++ x+{-+prettyTBind :: Bool -> TBind -> String+prettyTBind inPi (TBind dec x t) =+  if erased dec then addPol False $ brackets binding+   else if x=="" then addPol True s+   else addPol (not inPi) $ (if inPi then parens else id) binding+  where s = prettyExpr t+        binding = if x == "" then s else x ++ " : " ++ s+        pol = polarity dec+        addPol b x = if pol==Mixed then x+                      else show pol ++ (if b then " " else "") ++ x+-}+prettyLetBody :: String -> Expr -> String+prettyLetBody s e = parens $ s ++ " in " ++ prettyExpr e++prettyLetAssign :: String -> Expr -> String+prettyLetAssign s e = "let " ++ s ++ " = " ++ prettyExpr e++prettyLetDef :: LetDef -> String+prettyLetDef (LetDef dec n [] mt e) = prettyLetAssign (prettyLBind tb) e+  where tb = TBind dec [n] mt+prettyLetDef (LetDef dec n tel mt e) = prettyLetAssign s e+  where s = prettyDecId dec n ++ " " ++ prettyTel False tel ++ prettyMaybeType mt++prettyDecId :: Dec -> Name -> String+prettyDecId dec x+  | erased dec = brackets $ show x+  | otherwise  =+     let pol = polarity dec+     in  if pol == defaultPol then show x else show pol ++ show x++prettyTel :: Bool -> Telescope -> String+prettyTel inPi = Util.showList " " (prettyTBind inPi)++prettyMaybeType = maybe "" $ \ t -> " : " ++ prettyExpr t++prettyExpr :: Expr -> String+prettyExpr e =+    case e of+      -- Type e          -> "Type " ++ prettyExpr e+      CoSet e         -> "CoSet " ++ prettyExpr e+      Set e         -> "CoSet " ++ prettyExpr e+      -- Set             -> "Set"+      Size            -> "Size"+      Max             -> "max"+      Succ e          -> "$ " ++ prettyExpr e -- ++ ")"+      Zero            -> "0"+      Infty           -> "#"+      Plus e1 e2      -> "(" ++ prettyExpr e1 ++ " + " ++  prettyExpr e2 ++ ")"+      Pair e1 e2      -> "(" ++ prettyExpr e1 ++ " , " ++  prettyExpr e2 ++ ")"+      App e1 el       -> "(" ++ prettyExprs (e1:el) ++ ")"+      Lam x e1        -> "(\\" ++ show x ++ " -> " ++ prettyExpr e1 ++ ")"+      Case e Nothing cs -> "case " ++ prettyExpr e ++ " { " ++ Util.showList "; " prettyCase cs ++ " } "+      Case e (Just t) cs -> "case " ++ prettyExpr e ++ " : " ++ prettyExpr t ++ " { " ++ Util.showList "; " prettyCase cs ++ " } "+      LLet letdef e -> prettyLetBody (prettyLetDef letdef) e+{-+      LLet tb e1 e2 -> "(let " ++ prettyLBind tb ++ " = " ++ prettyExpr e1 ++ " in " ++ prettyExpr e2 ++ ")"+-}+      Record rs       -> "record {" ++ Util.showList "; " prettyRecordLine rs ++ "}"+      Proj n          -> "." ++ show n+      Ident n         -> show n+      Unknown         -> "_"+      Sing e t        -> "<" ++ prettyExpr e ++ " : " ++ prettyExpr t ++ ">"+--      Quant pisig tb t2 -> parens $ prettyTBind True tb+      Quant pisig tel t2 -> parens $ prettyTel True tel+                                  ++ " " ++ show pisig ++ " " ++ prettyExpr t2++prettyRecordLine (xs, e) = Util.showList " " show xs ++ " = " ++ prettyExpr e++prettyCase (Clause Nothing [p] Nothing)  = prettyPattern p+prettyCase (Clause Nothing [p] (Just e)) = prettyPattern p ++ " -> " ++ prettyExpr e++prettyPattern :: Pattern -> String+prettyPattern (ConP dotted c ps) = parens $ foldl (\ acc p -> acc ++ " " ++ prettyPattern p) (if dotted then "." ++ show c else show c) ps+prettyPattern (PairP p1 p2) = parens $ prettyPattern p1 ++ ", " +++                                prettyPattern p2+prettyPattern (SuccP p)   = parens $ "$ " ++ prettyPattern p+prettyPattern (DotP e)    = "." ++ prettyExpr e+prettyPattern (IdentP x)  = show x+prettyPattern (SizeP e y) = parens $ prettyExpr e ++ " > " ++ show y+prettyPattern (AbsurdP)   = parens ""++prettyExprs :: [Expr] -> String+prettyExprs = Util.showList " " prettyExpr++prettyDecl (PatternDecl n ns p) = "pattern " ++ (Util.showList " " show (n:ns)) ++ " = " ++ prettyPattern p++teleToType :: Telescope -> Type -> Type+teleToType [] t = t+teleToType (tb:tel) t2 = Quant Pi [tb] (teleToType tel t2)+--teleToType (PosTB dec n t:tel) t2 = Pi dec n t (teleToType tel t2)++typeToTele :: Type -> (Telescope, Type)+typeToTele (Quant Pi tel0 c) =+  let (tel, a) = typeToTele c in (tel0 ++ tel, a)+typeToTele a = ([],a)++{-+teleToType :: Telescope -> Type -> Type+teleToType [] t = t+teleToType (tb:tel) t2 = Quant Pi tb (teleToType tel t2)+--teleToType (PosTB dec n t:tel) t2 = Pi dec n t (teleToType tel t2)++typeToTele :: Type -> (Telescope, Type)+typeToTele = typeToTele' (-1)++typeToTele' :: Int -> Type -> (Telescope, Type)+typeToTele' k (Quant A.Pi tb c) | k /= 0 =+  let (tel, a) = typeToTele' (k-1) c in (tb:tel, a)+typeToTele' _ a = ([],a)+-}++teleNames :: Telescope -> [Name]+teleNames tel = concat $ map tbindNames tel++tbindNames :: TBind -> [Name]+tbindNames TBind{ boundNames }   = boundNames+tbindNames TBounded{ boundName } = [boundName]+-- tbindNames TSized{ boundName }   = [boundName]+tbindNames tb = error $ "tbindNames (" ++ show tb ++ ")"
+ src/Eval.hs view
@@ -0,0 +1,2359 @@+{-# LANGUAGE TupleSections, FlexibleInstances, FlexibleContexts, NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-}++-- Activate this flag if i < $i should only hold for i < #.+-- #define STRICTINFTY++module Eval where++import Prelude hiding (mapM, null, pi)++import Control.Applicative+import Control.Monad.Identity hiding (mapM)+import Control.Monad.State hiding (mapM)+import Control.Monad.Except hiding (mapM)+import Control.Monad.Reader hiding (mapM)++import qualified Data.Array as Array+import Data.Maybe -- fromMaybe+import Data.Monoid hiding ((<>))+import Data.List as List hiding (null) -- find+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Foldable (foldMap)+import Data.Traversable (Traversable, mapM, traverse)+import qualified Data.Traversable as Traversable++import Debug.Trace (trace)++import Abstract+import Polarity as Pol+import Value+import TCM+import PrettyTCM+import Warshall  -- positivity checking++import TraceError+import Util+++traceEta msg a = a -- trace msg a+traceEtaM msg = return () -- traceM msg+{-+traceEta msg a = trace msg a+traceEtaM msg = traceM msg+-}++traceRecord msg a = a+traceRecordM msg = return ()+++traceMatch msg a = a -- trace msg a+traceMatchM msg = return () -- traceM msg+{-+traceMatch msg a = trace msg a+traceMatchM msg = traceM msg+-}++traceLoop msg a = a -- trace msg a+traceLoopM msg = return () -- traceM msg+{-+traceLoop msg a = trace msg a+traceLoopM msg = traceM msg+-}++traceSize msg a = a -- trace msg a+traceSizeM msg = return () -- traceM msg+{-+traceSize msg a = trace msg a+traceSizeM msg = traceM msg+-}++failValInv :: (MonadError TraceError m) => Val -> m a+failValInv v = throwErrorMsg $ "internal error: value " ++ show v ++ " violates representation invariant"++-- evaluation with rewriting -------------------------------------++{-++Rewriting rules have the form++  blocked --> pattern++this means that at the root, at most one rewriting step is possible.+Rewriting rules are considered computational, since they trigger new+(symbolic) computations.  At least they have to be applied in++- pattern matching+- equality checking+When a new rule b --> p is added, b should be in --> normal form.+Otherwise there could be inconsistencies, like adding both rules++  b --> true+  b --> false++If after adding b --> true b is rewritten to nf, then the second rule+would be true --> false, which can be captured by MiniAgda.++Also, after adding a new rule, it could be used to rewrite the old rules.++Implementation:++- add a set of local rewriting rules to the context (not to the state)+- keep values in --> weak head normal form+- untyped equality test between values++ -}++class Reval a where+  reval' :: Valuation -> a -> TypeCheck a+  reval  :: a -> TypeCheck a+  reval = reval' emptyVal++instance Reval a => Reval (Maybe a) where+  reval' valu ma = Traversable.traverse (reval' valu) ma++instance Reval b => Reval (a,b) where+  reval' valu (x,v) = (x,) <$> reval' valu v++instance Reval a => Reval [a] where+  reval' valu vs = mapM (reval' valu) vs++instance Reval Env where+  reval' valu (Environ rho mmeas) =+   flip Environ mmeas <$> reval' valu rho+   -- no need to reevaluate mmeas, since only sizes++-- | When combining valuations, the old one takes priority.+--   @[sigma][tau]v = [[sigma]tau]v@+instance Reval Valuation where+  reval' valu (Valuation valu') = Valuation . (++ valuation valu) <$>+    reval' valu valu'++instance Reval a => Reval (Measure a) where+  reval' valu beta = Traversable.traverse (reval' valu) beta++instance Reval a => Reval (Bound a) where+  reval' valu beta = Traversable.traverse (reval' valu) beta++instance Reval Val where+  reval' valu u = traceLoop ("reval " ++ show u) $ do+    let reval v   = reval' valu v+        reEnv rho = reval' valu rho+        reFun fv  = reval' valu fv+    case u of+      VSort (CoSet v) -> VSort . CoSet <$> reval v+      VSort{} -> return u+      VInfty  -> return u+      VZero   -> return u+      VSucc{} -> return u  -- no rewriting in size expressions+      VMax{}  -> return u+      VPlus{}  -> return u+      VProj{}  -> return u -- cannot rewrite projection+      VPair v1 v2 -> VPair <$> reval v1 <*> reval v2+      VRecord ri rho -> VRecord ri <$> mapAssocM reval rho++      VApp v vl          -> do+        v'  <- reval v+        vl' <- mapM reval vl+        w   <- foldM app v' vl'+        reduce w  -- since we only have rewrite rules at base types+                  -- we do not need to reduces prefixes of w++      VDef{} -> return $ VApp u [] -- restore invariant+                                   -- CAN'T rewrite defined fun/data+      VGen i -> reduce (valuateGen i valu)  -- CAN rewrite variable++      VCase v tv env cl -> do+        v' <- reval v+        tv' <- reval tv+        env' <- reEnv env+        evalCase v' tv' env' cl++      VBelow ltle v         -> VBelow ltle <$> reval v+      VGuard beta v         -> VGuard <$> reval beta <*> reval v+      VQuant pisig x dom fv ->+        VQuant pisig x+          <$> Traversable.mapM reval dom+          <*> reFun fv+    {-+      VQuant pisig x dom env b -> do+        dom' <- Traversable.mapM reval dom+        env' <- reEnv env+        return $ VQuant pisig x dom' env' b+    -}+      VConst v           -> VConst <$> reval' valu v+      VLam x env e       -> flip (VLam x) e <$> reval' valu env+      VAbs x i v valu'   -> VAbs x i v <$> reval' valu valu'+      VUp v tv           -> up False ==<< (reval' valu v, reval' valu tv)  -- do not force at this point++      VClos env e        -> do env' <- reEnv env+                               return $ VClos env' e++      VMeta i env k      -> do env' <- reEnv env+                               return $ VMeta i env' k++      VSing v tv         -> vSing ==<< (reval v, reval tv)+      VIrr -> return u+      v -> throwErrorMsg $ "NYI : reval " ++ show v+++-- TODO: singleton Sigma types+-- <t : Pi x:a.f> = Pi x:a <t x : f x>+-- <t : A -> B  > = Pi x:A <t x : B>+-- <t : <t' : a>> = <t' : a>+vSing :: Val -> TVal -> TypeCheck TVal+vSing v (VQuant Pi x' dom fv) = do+  let x = fresh $ if emptyName x' then "xSing#" else suggestion x'+  VQuant Pi x dom <$> do+  underAbs_ x dom fv $ \ i xv bv -> do+    v <- app v xv+    vAbs x i <$> vSing v bv+vSing _ tv@(VSing{}) = return $ tv+vSing v tv           = return $ VSing v tv+{-+-- This is a bit of a hack (finding a fresh name)+-- <t : Pi x:a.b> = Pi x:a <t x : b>+-- <t : Pi x:a.f> = Pi x:a <t x : f x>+-- <t : <t' : a>> = <t' : a>+vSing :: Val -> TVal -> TVal+vSing v (VQuant Pi x dom env b)+  | not (emptyName x) = -- xv `seq` x' `seq`+     (VQuant Pi x dom (update env xv v) $ Sing (App (Var xv) (Var x)) b)+      where xv = fresh ("vSing#" ++ suggestion x)+vSing v (VQuant Pi x dom env b) =+--  | otherwise =+     (VQuant Pi x' dom (update env xv v) $ Sing (App (Var xv) (Var x')) b')+      where xv = fresh ("vSing#" ++ suggestion x)+            x' = fresh $ if emptyName x then "xSing#" else suggestion x+            b' = parSubst (\ y -> Var $ if y == x then x' else y) b+vSing _ tv@(VSing{}) = tv+vSing v tv           = VSing v tv+-}++-- reduce the root of a value+reduce :: Val -> TypeCheck Val+reduce v = traceLoop ("reduce " ++ show v) $+ do+  rewrules <- asks rewrites+  mr <- findM (\ rr -> equal v (lhs rr)) rewrules+  case mr of+     Nothing -> return v+     Just rr -> traceRew ("firing " ++ show rr) $ return (rhs rr)++-- equal v v'  tests values for untyped equality+-- precond: v v' are in --> whnf+equal :: Val -> Val -> TypeCheck Bool+equal u1 u2 = traceLoop ("equal " ++ show u1 ++ " =?= " ++ show u2) $+  case (u1,u2) of+    (v1,v2) | v1 == v2 -> return True -- includes all size expressions+--    (VSucc v1, VSucc v2) -> equal v1 v2  -- NO REDUCING NECC. HERE (Size expr)+    (VApp v1 vl1, VApp v2 vl2) ->+       (equal v1 v2) `andLazy` (equals' vl1 vl2)+    (VQuant pisig1 x1 dom1 fv1, VQuant pisig2 x2 dom2 fv2) | pisig1 == pisig2 ->+       andLazy (equal (typ dom1) (typ dom2)) $  -- NO RED. NECC. (Type)+         new x1 dom1 $ \ vx -> equal ==<< (app fv1 vx, app fv2 vx)+    (VProj _ p, VProj _ q) -> return $ p == q+    (VPair v1 w1, VPair v2 w2) -> (equal v1 v2) `andLazy` (equal w1 w2)+    (VBelow ltle1 v1, VBelow ltle2 v2) | ltle1 == ltle2 -> equal v1 v2+    (VSing v1 tv1, VSing v2 tv2) -> (equal v1 v2) `andLazy` (equal tv1 tv2)++    (fv1, fv2) | isFun fv1, isFun fv2 -> -- PROBLEM: DOM. MISSING, CAN'T "up" fresh variable+      addName (bestName [absName fv1, absName fv2]) $ \ vx ->+        equal ==<< (app fv1 vx, app fv2 vx)+{-+    (VLam x1 env1 b1, VLam x2 env2 b2) -> -- PROBLEM: DOMAIN MISSING+         addName x1 $ \ vx -> do          -- CAN'T "up" fresh variable+               do v1 <- whnf (update env1 x1 vx) b1+                  v2 <- whnf (update env2 x2 vx) b2+                  equal v1 v2+-}+    (VRecord ri1 rho1, VRecord ri2 rho2) | notDifferentNames ri1 ri2 -> and <$>+      zipWithM (\ (n1,v1) (n2,v2) -> ((n1 == n2) &&) <$> equal' v1 v2) rho1 rho2+    _ -> return False++notDifferentNames :: RecInfo -> RecInfo -> Bool+notDifferentNames (NamedRec _ n _ _) (NamedRec _ n' _ _) = n == n'+notDifferentNames _ _ = True++equals' :: [Val] -> [Val] -> TypeCheck Bool+equals' [] []             = return True+equals' (w1:vs1) (w2:vs2) = (equal' w1 w2) `andLazy` (equals' vs1 vs2)+equals' vl1 vl2           = return False++equal' w1 w2 = whnfClos w1 >>= \ v1 -> equal v1 =<< whnfClos w2++{- LEADS TO NON-TERMINATION+-- equal' v1 v2  tests values for untyped equality+-- v1 v2 are not necessarily in --> whnf+equal' v1 v2 = do+  v1' <- reduce v1+  v2' <- reduce v2+  equal v1' v2'+-}++-- normalization -----------------------------------------------------++reify :: Val -> TypeCheck Expr+reify v = reify' (5, True) v++-- normalize to depth m+reify' :: (Int, Bool) -> Val -> TypeCheck Expr+reify' m v0 = do+  let reify = reify' m  -- default recursive call+  case v0 of+    (VClos rho e)        -> whnf rho e >>= reify+    (VZero)              -> return $ Zero+    (VInfty)             -> return $ Infty+    (VSucc v)            -> Succ <$> reify v+    (VMax vs)            -> maxE <$> mapM reify vs+    (VPlus vs)           -> Plus <$> mapM reify vs+    (VMeta x rho n)      -> -- error $ "cannot reify meta-variable " ++ show v0+                            return $ iterate Succ (Meta x) !! n+    (VSort (CoSet v))    -> Sort . CoSet <$> reify v+    (VSort s)            -> return $ Sort $ vSortToSort s+    (VBelow ltle v)      -> Below ltle <$> reify v+    (VQuant pisig x dom fv) -> do+          dom' <- Traversable.mapM reify dom+          underAbs_ x dom fv $ \ k xv vb -> do+            let x' = unsafeName (suggestion x ++ "~" ++ show k)+            piSig pisig (TBind x' dom') <$> reify vb+    (VSing v tv)         -> liftM2 Sing (reify v) (reify tv)+    fv | isFun fv        -> do+          let x = absName fv+          addName x $ \ xv@(VGen k) -> do+            vb <- app fv xv+            let x' = unsafeName (suggestion x ++ "~" ++ show k)+            Lam defaultDec x' <$> reify vb  -- TODO: dec!?+    (VUp v tv)           -> reify v -- TODO: type directed reification+    (VGen k)             -> return $ Var $ unsafeName $ "~" ++ show k+    (VDef d)             -> return $ Def d+    (VProj fx n)         -> return $ Proj fx n+    (VPair v1 v2)        -> Pair <$> reify v1 <*> reify v2+    (VRecord ri rho)     -> Record ri <$> mapAssocM reify rho+    (VApp v vl)          -> if fst m > 0 && snd m+                             then force v0 >>= reify' (fst m - 1, True) -- forgotten the meaning of the boolean, WAS: False)+                             else let m' = (fst m, True) in+                               liftM2 (foldl App) (reify' m' v) (mapM (reify' m') vl)+    (VCase v tv rho cls) -> do+          e <- reify v+          t <- reify tv+          return $ Case e (Just t) cls -- TODO: properly evaluate clauses!!+    (VIrr)               -> return $ Irr+    v -> failDoc (text "Eval.reify" <+> prettyTCM v <+> text "not implemented")++-- printing (conversion to Expr) -------------------------------------++-- similar to reify+toExpr :: Val -> TypeCheck Expr+toExpr v =+  case v of+    VClos rho e     -> closToExpr rho e+    VZero           -> return $ Zero+    VInfty          -> return $ Infty+    (VSucc v)       -> Succ <$> toExpr v+    VMax vs         -> maxE <$> mapM toExpr vs+    VPlus vs        -> Plus <$> mapM toExpr vs+    VMeta x rho n   -> metaToExpr x rho n+    VSort s         -> Sort <$> mapM toExpr s+{-+    VSort (CoSet v) -> (Sort . CoSet) <$> toExpr v+    VSort (Set v)   -> (Sort . Set) <$> toExpr v+    VSort (SortC s) -> return $ Sort (SortC s)+-}+    VMeasured mu bv -> pi <$> (TMeasure <$> mapM toExpr mu) <*> toExpr bv+    VGuard beta bv  -> pi <$> (TBound <$> mapM toExpr beta) <*> toExpr bv+    VBelow Le VInfty -> return $ Sort $ SortC Size+    VBelow ltle bv  -> Below ltle <$> toExpr bv+    VQuant pisig x dom fv -> underAbs' x fv $ \ xv bv ->+      piSig pisig <$> (TBind x <$> mapM toExpr dom) <*> toExpr bv+    VSing v tv      -> Sing <$> toExpr v <*> toExpr tv+    fv | isFun fv   -> addName (absName fv) $ \ xv -> toExpr =<< app fv xv+{-+    VLam x rho e    -> addNameEnv x rho $ \ x rho ->+      Lam defaultDec x <$> closToExpr rho e+-}+    VUp v tv        -> toExpr v+    VGen k          -> Var <$> nameOfGen k+    VDef d          -> return $ Def d+    VProj fx n      -> return $ Proj fx n+    VPair v1 v2     -> Pair <$> toExpr v1 <*> toExpr v2+    VRecord ri rho  -> Record ri <$> mapAssocM toExpr rho+    VApp v vl       -> liftM2 (foldl App) (toExpr v) (mapM toExpr vl)+    VCase v tv rho cls -> Case <$> toExpr v <*> (Just <$> toExpr tv) <*> mapM (clauseToExpr rho) cls+    VIrr            -> return $ Irr++{-+addBindEnv :: TBind -> Env -> (Env -> TypeCheck a) -> TypeCheck a+addBindEnv (TBind x dom) rho cont = do+  let dom' = fmap (VClos rho) dom+  newWithGen x dom' $ \ k _ ->+    cont (update rho x (VGen k))+-}++addNameEnv :: Name -> Env -> (Name -> Env -> TypeCheck a) -> TypeCheck a+--addNameEnv "" rho cont = cont "" rho+addNameEnv x rho cont = do+  let dom' = defaultDomain VIrr -- error $ "internal error: variable " ++ show x ++ " comes without domain"+  newWithGen x dom' $ \ k _ -> do+    x' <- nameOfGen k+    cont x' (update rho x (VGen k))++addPatternEnv :: Pattern -> Env -> (Pattern -> Env -> TypeCheck a) -> TypeCheck a+addPatternEnv p rho cont =+  case p of+    VarP x       -> addNameEnv     x  rho $ cont . VarP -- \ x rho -> cont (VarP x) rho+    SizeP e x    -> addNameEnv     x  rho $ cont . VarP+    PairP p1 p2  -> addPatternEnv  p1 rho $ \ p1 rho ->+                     addPatternEnv p2 rho $ \ p2 rho -> cont (PairP p1 p2) rho+    ConP pi n ps -> addPatternsEnv ps rho $ cont . ConP pi n -- \ ps rho -> cont (ConP pi n ps) rho+    SuccP p      -> addPatternEnv  p  rho $ cont . SuccP+    UnusableP p  -> addPatternEnv  p  rho $ cont . UnusableP+    DotP e       -> do { e <- closToExpr rho e ; cont (DotP e) rho }+    AbsurdP      -> cont AbsurdP rho+    ErasedP p    -> addPatternEnv  p  rho $ cont . ErasedP++addPatternsEnv :: [Pattern] -> Env -> ([Pattern] -> Env -> TypeCheck a) -> TypeCheck a+addPatternsEnv []     rho cont = cont [] rho+addPatternsEnv (p:ps) rho cont =+  addPatternEnv p rho $ \ p rho ->+    addPatternsEnv ps rho $ \ ps rho ->+      cont (p:ps) rho++{-+class BindClosToExpr a where+  bindClosToExpr :: Env -> a -> (Env -> a -> TCM b) -> TCM b++instance ClosToExpr a => BindClosToExpr (TBinding a) where+  bindClosToExpr+-}++class ClosToExpr a where+  closToExpr     :: Env -> a -> TypeCheck a+  bindClosToExpr :: Env -> a -> (Env -> a -> TypeCheck b) -> TypeCheck b++  -- default : no binding+  closToExpr rho a = bindClosToExpr rho a $ \ rho a -> return a+  bindClosToExpr rho a cont = cont rho =<< closToExpr rho a++instance ClosToExpr a => ClosToExpr [a] where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (Maybe a) where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (Dom a) where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (Sort a) where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (Measure a) where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (Bound a) where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (Tagged a) where+  closToExpr = traverse . closToExpr++instance ClosToExpr a => ClosToExpr (TBinding a) where+  bindClosToExpr rho (TBind x a) cont = do+    a <- closToExpr rho a+    addNameEnv x rho $ \ x rho -> cont rho $ TBind x a+  bindClosToExpr rho (TMeasure mu) cont = cont rho . TMeasure =<< closToExpr rho mu+  bindClosToExpr rho (TBound beta) cont = cont rho . TBound =<< closToExpr rho beta++instance ClosToExpr Telescope where+  bindClosToExpr rho (Telescope tel) cont = loop rho tel $ \ rho -> cont rho . Telescope+    where+      loop rho []         cont = cont rho []+      loop rho (tb : tel) cont = bindClosToExpr rho tb $ \ rho tb ->+        loop rho tel $ \ rho tel -> cont rho $ tb : tel++instance ClosToExpr Expr where+  closToExpr rho e =+    case e of+      Sort s         -> Sort <$> closToExpr rho s+      Zero           -> return e+      Succ e         -> Succ <$> closToExpr rho e+      Infty          -> return e+      Max es         -> Max  <$> closToExpr rho es+      Plus es        -> Plus <$> closToExpr rho es+      Meta x         -> return e+      Var x          -> toExpr =<< whnf rho e+      Def d          -> return e+      Case e mt cls  -> Case <$> closToExpr rho e <*> closToExpr rho mt <*> mapM (clauseToExpr rho) cls+      LLet tb tel e1 e2 | null tel -> do+        e1 <- closToExpr rho e1+        bindClosToExpr rho tb $ \ rho tb -> LLet tb tel e1 <$> closToExpr rho e2+      Proj fx n      -> return e+      Record ri rs   -> Record ri <$> mapAssocM (closToExpr rho) rs+      Pair e1 e2     -> Pair <$> closToExpr rho e1 <*> closToExpr rho e2+      App e1 e2      -> App <$> closToExpr rho e1 <*> closToExpr rho e2+      Lam dec x e    -> addNameEnv x rho $ \ x rho ->+        Lam dec x <$> closToExpr rho e+      Below ltle e   -> Below ltle <$> closToExpr rho e+{-+      Quant Pi tel mu@TMeasure{} e | null tel -> pi <$> closToExpr rho mu   <*> closToExpr rho e+      Quant Pi tel beta@TBound{} e | null tel -> pi <$> closToExpr rho beta <*> closToExpr rho e+-}+      Quant piSig tb e -> bindClosToExpr rho tb $ \ rho tb -> Quant piSig tb <$> closToExpr rho e+--       Quant piSig tel tb e -> bindClosToExpr rho tel $ \ rho tel ->+--         bindClosToExpr rho tb $ \ rho tb -> Quant piSig tel tb <$> closToExpr rho e+      Sing e1 e2     -> Sing <$> closToExpr rho e1 <*> closToExpr rho e2+      Ann taggedE    -> Ann <$> closToExpr rho taggedE+      Irr            -> return e++metaToExpr :: Int -> Env -> Int -> TypeCheck Expr+metaToExpr x rho k = return $ iterate Succ (Meta x) !! k++clauseToExpr :: Env -> Clause -> TypeCheck Clause+clauseToExpr rho (Clause vtel ps me) = addPatternsEnv ps rho $ \ ps rho ->+   Clause vtel ps <$> mapM (closToExpr rho) me++-- evaluation --------------------------------------------------------++-- | Weak head normal form.+--   Monadic, since it reads the globally defined constants from the signature.+--   @let@s are expanded away.++whnf :: Env -> Expr -> TypeCheck Val+whnf env e = enter ("whnf " ++ show e) $+  case e of+    Meta i -> do let v = VMeta i env 0+                 traceMetaM $ "whnf meta " ++ show v+                 return v+    LLet (TBind x dom) tel e1 e2 | null tel -> do+      let v1 = mkClos env e1+      whnf (update env x v1) e2+{-+-- ALT: remove erased lambdas entirely+    Lam dec x e1 | erased dec -> whnf env e1+                 | otherwise -> return $ VLam x env e1+-}+    Lam dec x e1 -> return $ vLam x env e1+    Below ltle e -> VBelow ltle <$> whnf env e+    Quant pisig (TBind x dom) b -> do+      dom' <- Traversable.mapM (whnf env) dom  -- Pi is strict in its first argument+      return $ VQuant pisig x dom' $ vLam x env b++    -- a measured type evaluates to+    -- * a bounded type if measure present in environment (rhs of funs)+    -- * otherwise to a measured type (lhs of funs)+    Quant Pi (TMeasure mu) b -> do+      muv <- whnfMeasure env mu+      bv  <- whnf env b -- not adding measure constraint to context!+      case (envBound env) of+        Nothing   -> return $ VMeasured muv bv+           -- throwErrorMsg $ "panic: whnf " ++ show e ++ " : no measure in environment " ++ show env+        Just muv' -> return $ VGuard (Bound Lt muv muv') bv++    Quant Pi (TBound (Bound ltle mu mu')) b -> do+          muv  <- whnfMeasure env mu+          muv' <- whnfMeasure env mu'+          bv   <- whnf env b  -- not adding measure constraint to context!+          return $ VGuard (Bound ltle muv muv') bv++    Sing e t  -> do tv <- whnf env t+                    sing env e tv++    Pair e1 e2 -> VPair <$> whnf env e1 <*> whnf env e2+    Proj fx n  -> return $ VProj fx n++    Record ri@(NamedRec Cons _ _ _) rs -> VRecord ri <$> mapAssocM (whnf env) rs++    -- coinductive and anonymous records are treated lazily:+    Record ri rs -> return $ VRecord ri $ mapAssoc (mkClos env) rs++{-+-- ALT: filter out all erased arguments from application+    App e1 el -> do v1 <- whnf env e1+                    vl <- liftM (filter (/= VIrr)) $ mapM (whnf env) el+                    app v1 vl+-}+    App f e   -> do vf <- whnf env f+                    let ve = mkClos env e+                    app vf ve+{-+    App e1 el -> do v1 <- whnf env e1+                    vl <- mapM (whnf env) el+                    app v1 vl+-}++    Case e (Just t) cs -> do+      v  <- whnf env e+      vt <- whnf env t+      evalCase v vt env cs+                  -- trace ("case head evaluates to " ++ showVal v) $ return ()++    Sort s -> whnfSort env s >>= return . vSort+    Infty -> return VInfty+    Zero -> return VZero+    Succ e1 -> do v <- whnf env e1           -- succ is strict+                  return $ succSize v++    Max es  -> do vs <- mapM (whnf env) es   -- max is strict+                  return $ maxSize vs+    Plus es -> do vs <- mapM (whnf env) es   -- plus is strict+                  return $ plusSizes vs++    Def (DefId LetK n) -> do+        item <- lookupSymbQ n+        whnfClos (definingVal item)++    Def (DefId (ConK DefPat) n) -> whnfClos . definingVal =<< lookupSymbQ n+--    Def (DefId (ConK DefPat) n) -> throwErrorMsg $ "internal error: whnf of defined pattern " ++ show n+    Def id   -> return $ vDef id+{-+    Con co n -> return $ VCon co n++    Def n -> return $ VDef n++    Let n -> do sig <- gets signature+                let (LetSig _ v) = lookupSig n sig+                return v+--                let (LetSig _ e) = lookupSig n sig+--                whnf [] e+-}+    Var y -> lookupEnv env y >>= whnfClos+    Ann e -> whnf env (unTag e) -- return VIrr -- NEED TO KEEP because of eta-exp!+    Irr -> return VIrr+    e   -> throwErrorMsg $ "NYI whnf " ++ show e++whnfMeasure :: Env -> Measure Expr -> TypeCheck (Measure Val)+whnfMeasure rho (Measure mu) = mapM (whnf rho) mu >>= return . Measure++whnfSort :: Env -> Sort Expr -> TypeCheck (Sort Val)+whnfSort rho (SortC c) = return $ SortC c+whnfSort rho (CoSet e) = whnf rho e >>= return . CoSet+whnfSort rho (Set e)   = whnf rho e >>= return . Set++whnfClos :: Clos -> TypeCheck Val+whnfClos v = -- trace ("whnfClos " ++ show v) $+  case v of+    (VClos e rho) -> whnf e rho+    -- (VApp (VProj Pre n) [u]) -> app u (VProj Post n) -- NO EFFECT+    (VApp (VDef (DefId FunK n)) vl) -> appDef n vl -- THIS IS TO SOLVE A PROBLEM+    v -> return v+{- THE PROBLEM IS that+  (tail (x Up Stream)) Up Stream is a whnf, because Up Stream is lazy+  in equality checking this is a problem when the Up is removed.+-}++-- evaluate in standard environment+whnf' :: Expr -> TypeCheck Val+whnf' e = do+  env <- getEnv+  whnf env e++-- <t : Pi x:a.b> = Pi x:a <t x : b>+-- <t : <t' : a>> = <t' : a>+sing :: Env -> Expr -> TVal -> TypeCheck TVal+sing rho e tv = do+  let v = mkClos rho e -- v <- whnf rho e+  vSing v tv+{-+sing env' e (VPi dec x av env b)  = do+  return $ VPi dec x' av env'' (Sing (App e (Var x')) b)+    where env'' = env' ++ env  -- super ugly HACK+          x'    = if x == "" then fresh env'' else x+    -- Should work with just x since shadowing is forbidden+sing _ _ tv@(VSing{}) = return $ tv+sing env e tv = do v <- whnf env e      -- singleton strict, is this OK?!+                   return $ VSing v tv+-}++sing' :: Expr -> TVal -> TypeCheck TVal+sing' e tv = do+  env <- getEnv+  sing env e tv++evalCase :: Val -> TVal -> Env -> [Clause] -> TypeCheck Val+evalCase v tv env cs = do+  m  <- matchClauses env cs [v]+  case m of+    Nothing -> return $ VCase v tv env cs+    Just v' -> return $ v'++piApp :: TVal -> Clos -> TypeCheck TVal+piApp (VGuard beta bv) w = piApp bv w+piApp (VQuant Pi x dom fv) w = app fv w+piApp tv@(VApp (VDef (DefId DatK n)) vl) (VProj Post p) = projectType tv p VIrr -- no rec value here+piApp tv w = failDoc (text "piApp: IMPOSSIBLE to instantiate" <+> prettyTCM tv <+> text "to argument" <+> prettyTCM w)++piApps :: TVal -> [Clos] -> TypeCheck TVal+piApps tv [] = return tv+piApps tv (v:vs) = do tv' <- piApp tv v+                      piApps tv' vs++updateValu valu i v = reval' (sgVal i v) valu++-- in app u v, u might be a VDef (e.g. when coming from reval)+app :: Val -> Clos -> TypeCheck Val+app = app' True++-- | Application of arguments and projections.+app' :: Bool -> Val -> Clos -> TypeCheck Val+app' expandDefs u v = do+         let app = app' expandDefs+             appDef' True  f vs = appDef f vs+             appDef' False f vs = return $ VDef (DefId FunK f) `VApp` vs+             appDef_ = appDef' expandDefs+         case u of+            VProj Pre n -> flip (app' expandDefs) (VProj Post n) =<< whnfClos v+            VRecord ri rho -> do+              let VProj Post n = v+              maybe (throwErrorMsg $ "app: projection " ++ show n ++ " not found in " ++ show u)+                whnfClos (lookup n rho)+            VDef (DefId FunK n) -> appDef_ n [v]+            VApp (VDef (DefId FunK n)) vl -> appDef_ n (vl ++ [v])+            VApp h@(VDef (DefId (ConK Cons) n)) vl -> do+              v <- whnfClos v      -- inductive constructors are strict!+              return $ VApp h (vl ++ [v])+--            VDef n -> appDef n [v]+--            VApp (VDef id) vl -> VApp (VDef id) (vl ++ [v])+            VApp v1 vl -> return $ VApp v1 (vl ++ [v])++-- VSing is a type!+--           VSing u (VQuant Pi x dom fu) -> vSing <$> app u v <*> app fu v++            VLam x env e    -> whnf (update env x v) e+            VConst u        -> whnfClos u+            VAbs x i u valu -> flip reval' u =<< updateValu valu i v+            VUp u (VQuant Pi x dom fu) -> up False ==<< (app u v, app fu v)++{-+            VUp u1 (VQuant Pi x dom rho b) -> do+{-+-- ALT: erased functions are not applied to their argument!+              v1 <- if erased dec then return v else app v [w]  -- eta-expand w ??+-}+              v1 <- app u1 v  -- eta-expand v ??+              bv <- whnf (update rho x v) b+              up False v1 bv+-}+            VUp u1 (VApp (VDef (DefId DatK n)) vl) -> do+              u' <- force u+              app u' v++            VIrr -> return VIrr+{- 2010-11-01 this breaks extraction for System U example+            VIrr -> throwErrorMsg $ "app internal error: " ++ show (VApp u [v])+-}+            _ -> return $ VApp u [v]+--+-- app :: Val -> [Val] -> TypeCheck Val+-- app u [] = return $ u+-- app u c = do+--          case (u,c) of+--             (VApp u2 c2,_) -> app u2 (c2 ++ c)+--             (VLam x env e,(v:vl))  -> do v' <- whnf (update env x v) e+--                                          app v' vl+--             (VDef n,_) -> appDef n c+--             (VUp v (VPi dec x av rho b), w:wl) -> do+-- {-+-- -- ALT: erased functions are not applied to their argument!+--               v1 <- if erased dec then return v else app v [w]  -- eta-expand w ??+-- -}+--               v1 <- app v [w]  -- eta-expand w ??+--               bv <- whnf (update rho x w) b+--               v2 <- up v1 bv+--               app v2 wl+-- {-+-- -- ALT: VIrr consumes applications+--             (VIrr,_) -> return VIrr+--  -}+--             (VIrr,_) -> throwErrorMsg $ "app internal error: " ++ show (VApp u c)+--             _ -> return $ VApp u c+++-- unroll a corecursive definition one time (until constructor appears)+force' :: Bool -> Val -> TypeCheck (Bool, Val)+force' b (VSing v tv) = do  -- for singleton types, force type!+  (b',tv') <- force' b tv+  return (b', VSing v tv')+force' b (VUp v tv) = up True v tv >>= \ v' -> return (True, v')  -- force eta expansion+force' b (VClos rho e) = do+  v <- whnf rho e+  force' b v+force' b v@(VDef (DefId FunK n)) = failValInv v+{-+ --trace ("force " ++ show v) $+    do sig <- gets signature+       case lookupSig n sig of+         (FunSig CoInd t cl True) -> do m <- matchClauses [] cl []+                                        case m of+                                          Just v' -> force v'+                                          Nothing -> return v+         _ -> return v+-}+force' b v@(VApp (VDef (DefId FunK n)) vl) = enterDoc (text "force" <+> prettyTCM v) $+    do sig <- gets signature+       case Map.lookup n sig of+         Just (FunSig isCo t ki ar cl True _) -> traceMatch ("forcing " ++ show v) $+            do m <- matchClauses emptyEnv cl vl+               case m of+                 Just v' -> traceMatch ("forcing " ++ show n ++ " succeeded") $+                   force' True v'+                 Nothing -> traceMatch ("forcing " ++ show n ++ " failed") $+                   return (b, v)+         _ -> return (b, v)+force' b v = return (b, v)++force :: Val -> TypeCheck Val+force v = -- trace ("forcing " ++ show v) $+  liftM snd $ force' False v++-- apply a recursive function+-- corecursive ones are not expanded even if the arity is exceeded+-- this is because a coinductive type needs to be destructed by pattern matching+appDef :: QName -> [Val] -> TypeCheck Val+appDef n vl = --trace ("appDef " ++ n) $+    do+      -- identifier might not be in signature yet, e.g. ind.-rec.def.+      sig <- gets signature+      case (Map.lookup n sig) of+        Just (FunSig { isCo = Ind, arity = ar, clauses = cl, isTypeChecked = True })+         | length vl >= fullArity ar -> do+           m <- matchClauses emptyEnv cl vl+           case m of+              Nothing -> return $ VApp (VDef (DefId FunK n)) vl+              Just v2 -> return v2+        _ -> return $ VApp (VDef (DefId FunK n)) vl++-- reflection and reification  ---------------------------------------++-- TODO: eta for builtin sigma-types !?++-- up force v tv+-- force==True also expands at coinductive type+up :: Bool -> Val -> TVal -> TypeCheck Val+up f (VUp v tv') tv                              = up f v tv+up f v           tv@VQuant{ vqPiSig = Pi }       = return $ VUp v tv+up f _           (VSing v vt)                    = up f v vt+up f v           (VDef d)                        = failValInv $ VDef d+up f v           (VApp (VDef (DefId DatK d)) vl) = upData f v d vl+up f v           _                               = return v++{- Most of the code to eta expand on data types is in+   TypeChecker.hs "typeCheckDeclaration"++ Currently, eta expansion only happens at data *types* with exactly+one constructor.  In a first step, this will be extended to+non-recursive pattern inductive families.++The strategy is: match type value with result type for all the constructors+0. if there are no matches, eta expand to * (VIrr)+1. if there is exactly one match, eta expand accordingly using destructors+2. if there are more matches, do not eta-expand++up{Vec A (suc n)} x = vcons A n (head A n x) (tail A n x)++up{Vec Bool (suc zero)} x+  = vcons Bool zero (head Bool zero x) (tail Bool zero x)++For vcons+- the patterns of  Vec : (A : Set) -> Nat -> Set  are  [A,suc n]+- matching  Bool,suc zero  against  A,suc n  yields A=Bool,n=zero+- this means we can eta expand to vcons+- go through the fields of vcons+  - if Index use value obtained by matching+  - if Field destr, use  destr <all pars> <all indices> x++-}++-- matchingConstructors is for use in checkPattern+-- matchingConstructors (D vs)  returns all the constructors+-- each as tuple (ci,rho)+-- of family D whose target matches (D vs) under substitution rho+matchingConstructors :: Val -> TypeCheck (Maybe [(ConstructorInfo,Env)])+matchingConstructors v@(VDef d) = failValInv v -- matchingConstructors' d []+matchingConstructors (VApp (VDef (DefId DatK d)) vl) = matchingConstructors' d vl >>= return . Just+matchingConstructors v = return Nothing+-- throwErrorMsg $ "matchingConstructors: not a data type: " ++ show v -- return []++matchingConstructors' :: QName -> [Val] -> TypeCheck [(ConstructorInfo,Env)]+matchingConstructors' n vl = do+  sige <- lookupSymbQ n+  case sige of+    (DataSig {symbTyp = dv, constructors = cs}) -> -- if (null cs) then ret [] else do -- no constructor+      matchingConstructors'' True vl dv cs++-- matchingConstructors''+-- Arguments:+--   symm     symmetric match+--   vl       arguments to D (instance of D)+--   dv       complete type value of D+--   cs       constructors+-- Returns a list [(ci,rho)] of matching constructors together with the+--   environments which are solutions for the free variables in the constr.type+-- this is also for use in upData+matchingConstructors'' :: Bool -> [Val] -> Val -> [ConstructorInfo] -> TypeCheck [(ConstructorInfo,Env)]+matchingConstructors'' symm vl dv cs = do+  vl <- mapM whnfClos vl+  compressMaybes <$> do+    forM cs $ \ ci -> do+      let ps = snd (cPatFam ci)+          -- list of patterns ps where D ps is the constructor target+      fmap (ci,) <$> nonLinMatchList symm emptyEnv ps vl dv+++data MatchingConstructors a+  = NoConstructor+  | OneConstructor a+  | ManyConstructors+  | UnknownConstructors+    deriving (Eq,Show)++getMatchingConstructor+  :: Bool           -- eta   : must the field etaExpand be set of the data type+  -> QName          -- d     : the name of the data types+  -> [Val]          -- vl    : the arguments of the data type+  -> TypeCheck (MatchingConstructors+     ( Co           -- co    : coinductive type?+     , [Val]        -- parvs : the parameter half of the arguments+     , Env          -- rho   : the substitution for the index variables to arrive at d vl+     , [Val]        -- indvs : the index values of the constructor+     , ConstructorInfo -- ci : the only matching constructor+     ))+getMatchingConstructor eta n vl = traceRecord ("getMatchingConstructor " ++ show (n, vl)) $+ do+  -- when checking a mutual data decl, the sig entry of the second data+  -- is not yet in place when checking the first, thus, lookup may fail+  sig <- gets signature+  case Map.lookup n sig of+    Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand}) | eta `implies` etaExpand ->+     if (null cs) then return NoConstructor else do -- no constructor: empty type+       -- for each constructor, match its core against the type+      -- produces a list of maybe (c.info, environment)+      cenvs <- matchingConstructors'' False vl dv cs+      traceRecordM $ "Matching constructors: " ++ show cenvs+      case cenvs of+        -- exactly one matching constructor: can eta expand+--        [(ci,env)] -> if not (eta `implies` cEtaExp ci) then return UnknownConstructors else do+        [(ci,env)] -> if eta && not (cEtaExp ci) then return UnknownConstructors else do+          -- get list of index values from environment+          let fis = cFields ci+          let indices = filter (\ fi -> fClass fi == Index) fis+          let indvs = map (\ fi -> lookupPure env (fName fi)) indices+          let (pars, _) = splitAt npars vl+          return $ OneConstructor (co, pars, env, indvs, ci)+        -- more or less than one matching constructors: cannot eta expand+        l -> -- trace ("getMatchingConstructor: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $+               return ManyConstructors+    _ -> traceRecord ("no eta expandable type") $ return UnknownConstructors++getFieldsAtType+  :: QName          -- d     : the name of the data types+  -> [Val]          -- vl    : the arguments of the data type+  -> TypeCheck+     (Maybe         -- Nothing if not a record type+       [(Name       -- list of projection names+        ,TVal)])    -- and their instantiated type R ... -> C+getFieldsAtType n vl = do+  mc <- getMatchingConstructor False n vl+  case mc of+    OneConstructor (_, pars, _, indvs, ci) -> do+      let pi = pars ++ indvs+      -- for each argument of constructor, get value+      let arg (FieldInfo { fName = x, fClass = Index }) = return []+          arg (FieldInfo { fName = d, fClass = Field _ }) = do+            -- lookup type sig  t  of destructor  d+            t <- lookupSymbTyp d+            -- pi-apply destructor type to parameters and indices+            t' <- piApps t pi+            return [(d,t')]+      Just . concat <$> mapM arg (cFields ci)+    _ -> return Nothing++-- similar to piApp, but for record types and projections+projectType :: TVal -> Name -> Val -> TypeCheck TVal+projectType tv p rv = do+  let fail1 = failDoc (text "expected record type when taking the projection" <+> prettyTCM (Proj Post p) <> comma <+> text "but found type" <+> prettyTCM tv)+  let fail2 = failDoc (text "record type" <+> prettyTCM tv <+> text "does not have field" <+> prettyTCM p)+  case tv of+    VApp (VDef (DefId DatK d)) vl -> do+      mfs <- getFieldsAtType d vl+      case mfs of+        Nothing -> fail1+        Just ptvs ->+          case lookup p ptvs of+            Nothing -> fail2+            Just tv -> piApp tv rv -- apply to record arg+    _ -> fail1++-- eta expand  v  at data type  n vl+upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val+upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $+ do+  let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ show n ++ show vl) $ return v'+  mc <- getMatchingConstructor True n vl+  case mc of+    NoConstructor -> ret VIrr+    OneConstructor (co, pars, env, indvs, ci) ->+      -- lazy eta-expansion for coinductive records like streams!+      if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId DatK n) vl) else do+          -- get list of index values from environment+          let fis = cFields ci+          let piv = pars ++ indvs ++ [v]+          -- for each argument of constructor, get value+          let arg (FieldInfo { fName = x, fClass = Index }) =+                lookupEnv env x+              arg (FieldInfo { fName = d, fClass = Field _ }) = do+                -- lookup type sig  t  of destructor  d+                LetSig {symbTyp = t, definingVal = w} <- lookupSymb d+                -- pi-apply destructor type to parameters, indices and value v+                t' <- piApps t piv+                -- recursively eta expand  (d <pars> v)+                -- OLD, defined projections:+                -- w <- foldM (app' False) w piv -- LAZY: only unfolds let, not def+                -- NEW, builtin projections:+                w <- app' False v (VProj Post d)+                up False w t' -- now: LAZY++          vs <- mapM arg fis+          let fs = map fName fis+              v' = VRecord (NamedRec (coToConK co) (cName ci) False notDotted) $ zip fs vs+--          v' <- foldM app (vCon (coToConK co) (cName ci)) vs -- 2012-01-22 PARS GONE: (pars ++ vs)+          ret v'+    -- more constructors or unknown situation: do not eta expand+    _ -> return v++{-+-- eta expand  v  at data type  n vl+upData :: Bool -> Val -> Name -> [Val] -> TypeCheck Val+upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $+ do+  let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ n ++ show vl) $ return v'+  -- when checking a mutual data decl, the sig entry of the second data+  -- is not yet in place when checking the first, thus, lookup may fail+  sig <- gets signature+  case Map.lookup n sig of+    Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand = True}) -> if (null cs) then ret VIrr else do -- no constructor: empty type+      let (pars, inds) = splitAt npars vl+      -- for each constructor, match its core against the type+      -- produces a list of maybe (c.info, environment)+      cenvs <- matchingConstructors'' False vl dv cs+      -- traceM $ "Matching constructors: " ++ show cenvs+      case cenvs of+        -- exactly one matching constructor: can eta expand+        [(ci,env)] -> if not (cEtaExp ci) then return v else+         if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId Dat n) vl) else do+          -- get list of index values from environment+          let fis = cFields ci+          let indices = filter (\ fi -> fClass fi == Index) fis+          let indvs = map (\ fi -> lookupPure env (fName fi)) indices+          let piv = pars ++ indvs ++ [v]+          -- for each argument of constructor, get value+          let arg (FieldInfo { fName = x, fClass = Index }) =+                lookupEnv env x+              arg (FieldInfo { fName = d, fClass = Field _ }) = do+                -- lookup type sig  t  of destructor  d+                t <- lookupSymbTyp d+                -- pi-apply destructor type to parameters, indices and value v+                t' <- piApps t piv+                -- recursively eta expand  (d <pars> v)+                -- WAS: up (VDef (DefId Fun d) `VApp` piv) t'+                up False (VDef (DefId Fun d) `VApp` piv) t' -- now: LAZY+          vs <- mapM arg fis+          v' <- foldM app (vCon co (cName ci)) (pars ++ vs)+          ret v'+        -- more or less than one matching constructors: cannot eta expand+        l -> -- trace ("Eta: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $+               return v+    _ -> return v+-}++{-+      let matchC (c, ps, ds) =+            do menv <- nonLinMatchList [] ps inds dv+               case menv of+                 Nothing -> return False+                 Just env -> do+                   let grps = groupBy (\ (x,_) (y,_) -> x == y) env+                   -- TODO: now compare elements in the group+                   -- NEED types for equality check+                   -- trivial if groups are singletons+                   return $ all (\ l -> length l <= 1) grps+      cs' <- filterM matchC cs+      case cs' of+        [] -> return $ VIrr+        [(c,_,ds)] ->  do+          let parsv = pars ++ [v]+          let aux d = do+               -- lookup type sig  t  of destructor  d+               let FunSig { symbTyp = t } = lookupSig d sig+               -- pi-apply destructor type to parameters and value v+               t' <- piApps t parsv+               -- recursively eta expand  (d <pars> v)+               up (VDef d `VApp` parsv) t'+          vs <- mapM aux ds+          app (VCon co c) (pars ++ vs)+        _ -> return v+    _ -> return v+-}++{-+refl : [A : Set] -> [a : A] -> Id A a a+up{Id T t t'} x+  Id T t t' =?= Id A a a  --> A = T, a = t, a = t'+-}++{- OLD CODE FOR NON-DEPENDENT RECORDS ONLY+    -- erase if n is a empty type+    (DataSig {constructors = []}) -> return $ VIrr+    -- eta expand v if n is a tuple type+    (DataSig {isCo = co, constructors = [c], destructors = Just ds}) -> do+       let vlv = vl ++ [v]+       let aux d = do -- lookup type sig  t  of destructor  d+                      let FunSig { symbTyp = t } = lookupSig d sig+                      -- pi-apply destructor type to parameters and value v+                      t' <- piApps t vlv+                      -- recursively eta expand  (d <pars> v)+                      up (VDef d `VApp` vlv) t'+       vs <- mapM aux ds+       app (VCon co c) (vl ++ vs) -- (map (\d -> VDef d `VApp` (vl ++ [v])) ds)+    _ -> return v+END OLD CODE -}++-- pattern matching ---------------------------------------------------++matchClauses :: Env -> [Clause] -> [Val] -> TypeCheck (Maybe Val)+matchClauses env cl vl0 = do+  vl <- mapM reduce vl0  -- REWRITE before matching (2010-07-12 dysfunctional because of lazy?)+  loop cl vl+    where loop [] vl = return Nothing+          loop (Clause _ pl Nothing : cl2) vl = loop cl2 vl -- no need to try absurd clauses+          loop (Clause _ pl (Just rhs) : cl2) vl =+              do x <- matchClause env pl rhs vl+                 case x of+                   Nothing -> loop cl2 vl+                   Just v -> return $ Just v++bindMaybe :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)+bindMaybe mma k = mma >>= maybe (return Nothing) k++matchClause :: Env -> [Pattern] -> Expr -> [Val] -> TypeCheck (Maybe Val)+matchClause env pl rhs vl =+  case (pl, vl) of+    (p:pl, v:vl) -> match env p v `bindMaybe` \ env' -> matchClause env' pl rhs vl++    -- done matching: eval clause body in env and apply it to remaining arsg+    ([], _)      -> Just <$> do flip (foldM app) vl =<< whnf env rhs++    -- too few arguments to fire clause: give up+    (_, [])      -> return Nothing+++match :: Env -> Pattern -> Val -> TypeCheck (Maybe Env)+match env p v0 = --trace (show env ++ show v0) $+  do+    -- force against constructor pattern or pair pattern+    v <- case p of+           ConP{}  -> do v <- force v0; traceMatch ("matching pattern " ++ show (p,v)) $ return v+           PairP{} -> do v <- force v0; traceMatch ("matching pattern " ++ show (p,v)) $ return v+           _ -> whnfClos v0+    case (p,v) of+--      (ErasedP _,_) -> return $ Just env  -- TOO BAD, DOES NOT WORK (eta!)+      (ErasedP p,_) -> match env p v+      (AbsurdP{},_) -> return $ Just env+      (DotP _,   _) -> return $ Just env+      (VarP x,   _) -> return $ Just (update env x v)+      (SizeP _ x,_) -> return $ Just (update env x v)+      (ProjP x, VProj Post y) | x == y -> return $ Just env+      (PairP p1 p2, VPair v1 v2) -> matchList env [p1,p2] [v1,v2]+      (ConP _ x [],VDef (DefId (ConK _) y)) -> failValInv v -- | x == y -> return $ Just env+--  The following case is NOT IMPOSSIBLE:+--      (ConP _ x pl,VApp (VDef (DefId (ConK _) y)) vl) -> failValInv v+      (ConP _ x pl,VApp (VDef (DefId (ConK _) y)) vl) | nameInstanceOf x  y -> matchList env pl vl+      -- If a value is a dotted record value, we do not succeed, since+      -- it is not sure this is the correct constructor.+      (ConP _ x pl,VRecord (NamedRec ri y _ dotted) rs) | nameInstanceOf x y && not (isDotted dotted) ->+         matchList env pl $ map snd rs+      (p@(ConP pi _ _), v) | coPat pi == DefPat -> do+        p <- expandDefPat p+        match env p v+      (SuccP p', v) -> (predSize <$> whnfClos v) `bindMaybe` match env p'+      (UnusableP p,_) -> throwErrorMsg ("internal error: match " ++ show (p,v))+      _ -> return Nothing++matchList :: Env -> [Pattern] -> [Val] -> TypeCheck (Maybe Env)+matchList env []     []     = return $ Just env+matchList env (p:pl) (v:vl) =+  match env p v `bindMaybe` \ env' ->+  matchList env' pl vl+matchList env pl     vl     = throwErrorMsg $ "matchList internal error: inequal length while trying to match patterns " ++ show pl ++ " against values " ++ show vl++-- * Typed Non-linear Matching -----------------------------------------++type GenToPattern = [(Int,Pattern)]+type MatchState = (Env, GenToPattern)++-- @nonLinMatch True@ allows also instantiation in v0+-- this is useful for finding all matching constructors+-- for an erased argument in checkPattern+nonLinMatch :: Bool -> Bool -> MatchState -> Pattern -> Val -> TVal -> TypeCheck (Maybe MatchState)+nonLinMatch undot symm st p v0 tv = traceMatch ("matching pattern " ++ show (p,v0)) $ do+  -- force against constructor pattern+  v <- case p of+         ConP{}  -> force v0+         PairP{} -> force v0+         _ -> whnfClos v0+  case (p,v) of+    (ErasedP{}, _) -> return $ Just st+    (DotP{}   , _) -> return $ Just st+    (_,    VGen i) | symm -> return $ Just $ mapSnd ((i,p):) st -- no check in case of non-lin!+    (VarP    x, _) -> matchVarP x v+    (SizeP _ x, _) -> matchVarP x v+    (ProjP x,     VProj Post y) | x == y -> return $ Just st+    (ConP _ c pl, VApp (VDef (DefId (ConK _) c')) vl) | nameInstanceOf c c' -> do+      vc <- conLType c tv+      nonLinMatchList' undot symm st pl vl vc+    -- Here, we do accept dotted constructors, since we are abusing this for unification.+    (ConP _ c pl, VRecord (NamedRec _ c' _ dotted) rs) | nameInstanceOf c c' -> do+      when undot $ clearDotted dotted+      vc <- conLType c tv+      nonLinMatchList' undot symm st pl (map snd rs) vc+    -- if the match against an unconfirmed constructor+    -- we can succeed, but not compute a sensible environment+    (_, VRecord (NamedRec _ c' _ dotted) rs) | isDotted dotted && not undot -> return $ Just st+    (p@(ConP pi _ _), v) | coPat pi == DefPat -> do+      p <- expandDefPat p+      nonLinMatch undot symm st p v tv+    (PairP p1 p2, VPair v1 v2) -> do+      tv <- force tv+      case tv of+        VQuant Sigma x dom fv -> do+          nonLinMatch undot symm st p1 v1 (typ dom) `bindMaybe` \ st -> do+          nonLinMatch undot symm st p2 v2 =<< app fv v1+        _ -> failDoc $ text "nonLinMatch: expected" <+> prettyTCM tv <+> text "to be a Sigma-type (&)"+    (SuccP p', v) -> (predSize <$> whnfClos v) `bindMaybe` \ v' ->+      nonLinMatch undot symm st p' v' tv+    _ -> return Nothing+  where+    -- Check that the previous solution for @x@ is equal to @v@.+    -- Here, we need the type!+    matchVarP x v = do+      let env = fst st+      case find ((x ==) . fst) $ envMap $ fst st of+        Nothing     -> return $ Just $ mapFst (\ env -> update env x v) st+        Just (y,v') -> ifM (eqValBool tv v v') (return $ Just st) (return Nothing)++-- nonLinMatchList symm env ps vs tv+-- typed non-linear matching of patterns ps against values vs at type tv+--   env   is the accumulator for the solution of the matching+nonLinMatchList :: Bool -> Env -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe Env)+nonLinMatchList symm env ps vs tv =+  fmap fst <$> nonLinMatchList' False symm (env, []) ps vs tv++nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState)+nonLinMatchList' undot symm st [] [] tv = return $ Just st+nonLinMatchList' undot symm st (p:pl) (v:vl) tv = do+  tv <- force tv+  case tv of+    VQuant Pi x dom fv ->+      nonLinMatch undot symm st p v (typ dom) `bindMaybe` \ st' ->+      nonLinMatchList' undot symm st' pl vl =<< app fv v+    _ -> throwErrorMsg $ "nonLinMatchList': cannot match in absence of pi-type"+nonLinMatchList' _ _ _ _ _ _ = return Nothing+++-- | Expand a top-level pattern synonym+expandDefPat :: Pattern -> TypeCheck Pattern+expandDefPat p@(ConP pi c ps) | coPat pi == DefPat = do+  PatSig ns pat v <- lookupSymbQ c+  unless (length ns == length ps) $+    throwErrorMsg ("underapplied defined pattern in " ++ show p)+  let pat' = if dottedPat pi then dotConstructors pat else pat+  return $ patSubst (zip ns ps) pat'+expandDefPat p = return p++---------------------------------------------------------------------------+-- * Unification+---------------------------------------------------------------------------++instance Monoid (TypeCheck Bool) where+  mempty  = return True+  mappend = andLazy+  mconcat = andM++-- | Occurrence check @nocc ks v@ (used by 'SPos' and 'TypeCheck').+--   Checks that generic values @ks@ does not occur in value @v@.+--   In the process, @tv@ is normalized.+class Nocc a where+  nocc :: [Int] -> a -> TypeCheck Bool++instance Nocc a => Nocc [a] where+  nocc = foldMap . nocc++instance Nocc a => Nocc (Dom a) where+  nocc = foldMap . nocc++instance Nocc a => Nocc (Measure a) where+  nocc = foldMap . nocc++instance Nocc a => Nocc (Bound a) where+  nocc = foldMap . nocc++instance (Nocc a, Nocc b) => Nocc (a,b) where+  nocc ks (a, b) = nocc ks a `andLazy` nocc ks b++instance Nocc a => Nocc (Sort a) where+  nocc ks (Set   v) = nocc ks v+  nocc ks (CoSet v) = nocc ks v+  nocc ks (SortC _) = mempty++instance Nocc Val where+  nocc ks v = do+    -- traceM ("nocc " ++ show v)+    v <- whnfClos v+    case v of+      -- neutrals+      VGen k                -> return $ not $ k `elem` ks+      VApp v1 vl            -> nocc ks $ v1 : vl+      VDef{}                -> mempty+      VProj{}               -> mempty+      -- Binders:+      -- ALT: do not evaluate under binders (just check environment).+      -- This is less precise but more efficient. Can give false alarms.+      -- Still sound. (Should maybe done first, like in Agda).+      VQuant pisig x dom fv -> nocc ks dom `mappend` do+                               underAbs  x dom  fv $ \ _i _xv bv -> nocc ks bv+      fv@(VLam x env b)     -> underAbs' x      fv $ \ _xv bv -> nocc ks bv+      fv@(VAbs x i u valu)  -> underAbs' x      fv $ \ _xv bv -> nocc ks bv+      fv@(VConst v)         -> underAbs' noName fv $ \ _xv bv -> nocc ks bv+      -- pairs+      VRecord _ rs          -> nocc ks $ map snd rs+      VPair v w             -> nocc ks (v, w)+      -- sizes+      VZero                 -> mempty+      VSucc v               -> nocc ks v+      VInfty                -> mempty+      VMax vl               -> nocc ks vl+      VPlus vl              -> nocc ks vl+      VSort s               -> nocc ks s+      VMeasured mu tv       -> nocc ks (mu, tv)+      VGuard beta tv        -> nocc ks (beta, tv)+      VBelow ltle v         -> nocc ks v+      VSing v tv            -> nocc ks (v, tv)+      VUp v tv              -> nocc ks (v, tv)+      VIrr                  -> mempty+      VCase v tv env cls    -> nocc ks $ v : tv : map snd (envMap env)+      -- impossible: closure (reduced away)+      VClos{}               -> throwErrorMsg $ "internal error: nocc " ++ show (ks,v)+++-- heterogeneous typed equality and subtyping ------------------------++eqValBool :: TVal -> Val -> Val -> TypeCheck Bool+eqValBool tv v v' = errorToBool $ eqVal tv v v'+-- eqValBool tv v v' = (eqVal tv v v' >> return True) `catchError` (\ _ -> return False)++eqVal :: TVal -> Val -> Val -> TypeCheck ()+eqVal tv = leqVal' N mixed (Just (One tv))+++-- force history+data Force = N | L | R -- not yet, left , right+    deriving (Eq,Show)++class Switchable a where+  switch :: a -> a++instance Switchable Force where+  switch L = R+  switch R = L+  switch N = N++instance Switchable Pol where+  switch = polNeg++instance Switchable (a,a) where+  switch (a,b) = (b,a)++instance Switchable a => Switchable (Maybe a) where+  switch = fmap switch++{-+-- WONTFIX: FOR THE FOLLOWING TO BE SOUND, ONE NEEDS COERCIVE SUBTYPING!+-- the problem is that after extraction, erased arguments are gone!+-- a function which does not use its argument can be used as just a function+-- [A] -> A <= A -> A+-- A <= [A]+leqDec :: Pol -> Dec -> Dec -> Bool+leqDec SPos  dec1 dec2 = erased dec2 || not (erased dec1)+leqDec Neg   dec1 dec2 = erased dec1 || not (erased dec2)+leqDec mixed   dec1 dec2 = erased dec1 == erased dec2+-}++-- subtyping for erasure disabled+-- but subtyping for polarities!+leqDec :: Pol -> Dec -> Dec -> Bool+leqDec p dec1 dec2 = erased dec1 == erased dec2+  && relPol p leqPol (polarity dec1) (polarity dec2)++-- subtyping ---------------------------------------------------------++subtype :: Val -> Val -> TypeCheck ()+subtype v1 v2 = -- enter ("subtype " ++ show v1 ++ "  <=  " ++ show v2) $+  leqVal' N Pos Nothing v1 v2++-- Pol ::= Pos | Neg | mixed+leqVal :: Pol -> TVal -> Val -> Val -> TypeCheck ()+leqVal p tv = leqVal' N p (Just (One tv))++type MT12 = Maybe (OneOrTwo TVal)++-- view the shape of a type or a pair of types+data TypeShape+  = ShQuant PiSigma+            (OneOrTwo Name)+            (OneOrTwo Domain)+            (OneOrTwo FVal)      -- both are function types+  | ShSort  SortShape            -- sort of same shape+  | ShData  QName (OneOrTwo TVal)-- same data, but with possibly different args+  | ShNe    (OneOrTwo TVal)      -- both neutral+  | ShSing  Val TVal             -- 1 and singleton+  | ShSingL Val TVal TVal        -- 2 and the left is a singleton+  | ShSingR TVal Val TVal        -- 2 and the right is a singleton+  | ShNone+    deriving (Eq, Ord)++data SortShape+  = ShSortC Class              -- same sort constant+  | ShSet   (OneOrTwo Val)     -- Set i and Set j+  | ShCoSet (OneOrTwo Val)     -- CoSet i and CoSet j+    deriving (Eq, Ord)++shSize = ShSort (ShSortC Size)++-- typeView does not normalize!+typeView :: TVal -> TypeShape+typeView tv =+  case tv of+    VQuant pisig x dom fv        -> ShQuant pisig (One x) (One dom) (One fv)+    VBelow{}                     -> shSize+    VSort s                      -> ShSort (sortView s)+    VSing v tv                   -> ShSing v tv+    VApp (VDef (DefId DatK n)) vs -> ShData n (One tv)+    VApp (VDef (DefId FunK n)) vs -> ShNe (One tv)  -- stuck fun+    VApp (VGen i) vs             -> ShNe (One tv)  -- type variable+    VGen i                       -> ShNe (One tv)  -- type variable+    VCase{}                      -> ShNe (One tv)  -- stuck case+    _                            -> ShNone -- error $ "typeView " ++ show tv++sortView :: Sort Val -> SortShape+sortView s =+  case s of+    SortC c -> ShSortC c+    Set   v -> ShSet   (One v)+    CoSet v -> ShCoSet (One v)++typeView12 :: (Functor m, Monad m, MonadError TraceError m) => OneOrTwo TVal -> m TypeShape+-- typeView12 :: OneOrTwo TVal -> TypeCheck TypeShape+typeView12 (One tv) = return $ typeView tv+typeView12 (Two tv1 tv2) =+  case (tv1, tv2) of+    (VQuant pisig1 x1 dom1 fv1, VQuant pisig2 x2 dom2 fv2)+      | pisig1 == pisig2 && erased (decor dom1) == erased (decor dom2) ->+        return $ ShQuant pisig1 (Two x1 x2) (Two dom1 dom2) (Two fv1 fv2)+    (VSort s1, VSort s2) -> ShSort <$> sortView12 (Two s1 s2)+    (VSing v tv, _)      -> return $ ShSingL v tv tv2+    (_, VSing v tv)      -> return $ ShSingR tv1 v tv+    _ -> case (typeView tv1, typeView tv2) of+           (ShSort s1, ShSort s2) | s1 == s2 -> return $ ShSort $ s1+           (ShData n1 _, ShData n2 _) | n1 == n2 -> return $ ShData n1 (Two tv1 tv2)+           (ShNe{}     , ShNe{}     )            -> return $ ShNe (Two tv1 tv2)+           _ -> throwErrorMsg $ "type " ++ show tv1 ++ " has different shape than " ++ show tv2++sortView12 :: (Monad m, MonadError TraceError m) => OneOrTwo (Sort Val) -> m SortShape+sortView12 (One s) = return $ sortView s+sortView12 (Two s1 s2) =+  case (s1, s2) of+    (SortC c1, SortC c2) | c1 == c2 -> return $ ShSortC c1+    (Set v1, Set v2)                -> return $ ShSet (Two v1 v2)+    (CoSet v1, CoSet v2)            -> return $ ShCoSet (Two v1 v2)+    _ -> throwErrorMsg $ "sort " ++ show s1 ++ " has different shape than " ++ show s2++whnf12 :: OneOrTwo Env -> OneOrTwo Expr -> TypeCheck (OneOrTwo Val)+whnf12 env12 e12 = Traversable.traverse id $ zipWith12 whnf env12 e12++app12 ::  OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val)+app12 fv12 v12 = Traversable.traverse id $ zipWith12 app fv12 v12++-- if m12 = Nothing, we are checking subtyping, otherwise we are+-- comparing objects or higher-kinded types+-- if two types are given (heterogeneous equality), they need to be+-- of the same shape, otherwise they cannot contain common terms+leqVal' :: Force -> Pol -> MT12 -> Val -> Val -> TypeCheck ()+leqVal' f p mt12 u1' u2' = local (\ cxt -> cxt { consistencyCheck = False }) $ do+ -- 2013-03-30 During subtyping, it is fine to add any size hypotheses.+ l <- getLen+ ren <- getRen+ enterDoc (case mt12 of+  Nothing -> -- text ("leqVal' (subtyping) " ++ show  (Map.toList $ ren) ++ " |-")+             text "leqVal' (subtyping) "+             <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ")+             <+> prettyTCM u2'+  Just (One tv) -> -- text ("leqVal' " ++ show  (Map.toList $ ren) ++ " |-")+             text "leqVal' "+             <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ")+             <+> prettyTCM u2' <+> colon+             <+> prettyTCM tv+  Just (Two tv1 tv2) -> -- text ("leqVal' " ++ show  (Map.toList $ ren) ++ " |-")+             text "leqVal' "+             <+> prettyTCM u1' <+> colon+             <+> prettyTCM tv1 <+> text (" <=" ++ show p ++ " ")+             <+> prettyTCM u2' <+> colon+             <+> prettyTCM tv2) $ do+{-+    ce <- ask+    trace  (("rewrites: " +?+ show (rewrites ce)) ++ "  leqVal': " ++ show ce ++ "\n |- " ++ show u1' ++ "\n  <=" ++ show p ++ "  " ++ show u2') $+-}+    mt12f <- mapM (mapM force) mt12 -- leads to LOOP, see HungryEta.ma+    sh12 <- case mt12f of+              Nothing -> return Nothing+              Just tv12 -> case runExcept $ typeView12 tv12 of+                Right sh -> return $ Just sh+                Left err -> (recoverFail $ show err) >> return Nothing+    case sh12 of++      -- subtyping directed by common type shape++      Just (ShSing{}) -> return () -- two terms are equal at singleton type!+      Just (ShSingL v1 tv1' tv2) -> leqVal' f p (Just (Two tv1' tv2)) v1 u2'+      Just (ShSingR tv1 v2 tv2') -> leqVal' f p (Just (Two tv1 tv2')) u1' v2+      Just (ShSort (ShSortC Size)) -> leqSize p u1' u2'++{-  functions are compared pointwise++   Gamma, p(x:A) |- t x : B  <=  Gamma', p'(x:A') |- t' x : B'+   ----------------------------------------------------------+   Gamma |- t : p(x:A) -> B  <=  Gamma' |- t' : p'(x:A') -> B'+-}+      Just (ShQuant Pi x12 dom12 fv12) -> do+         x <- do+           let x = name12 x12+           if null (suggestion x) then do+             case (u1', u2') of+               (VLam x _ _, _) -> return x+               (_, VLam x _ _) -> return x+               _ -> return x+            else return x+         newVar x dom12 $ \ _ xv12 -> do+            u1' <- app u1' (first12  xv12)+            u2' <- app u2' (second12 xv12)+            tv12 <- app12 fv12 xv12+            leqVal' f p (Just tv12) u1' u2'+{-+      Just (VPi x1 dom1 env1 b1, VPi x2 dom2 env2 b2)  ->+         new2 x1 (dom1, dom2) $ \ (xv1, xv2) -> do+            u1' <- app u1' xv1+            u2' <- app u2' xv2+            tv1' <- whnf (update env1 x1 xv1) b1+            tv2' <- whnf (update env2 x2 xv2) b2+            leqVal' f p (Just (tv1', tv2')) u1' u2'+-}+++      -- structural subtyping (not directed by types)++      _ -> do+       u1 <- reduce =<< whnfClos u1'+       u2 <- reduce =<< whnfClos u2'++       let tryForcing fallback = do+            (f1,u1f) <- force' False u1+            (f2,u2f) <- force' False u2+            case (f1,f2) of -- (u1f /= u1,u2f /= u2) of++              (True,False) | f /= R -> -- only unroll one side+                 enter ("forcing LHS") $+                           leqVal' L p mt12 u1f u2+              (False,True) | f /= L ->+                 enter ("forcing RHS") $+                           leqVal' R p mt12 u1 u2f+              _ -> -- enter ("not forcing " ++ show (f1,f2,f)) $+                     fallback++           leqCons n1 vl1 n2 vl2 = do+                 unless (n1 == n2) $+                  recoverFail $+                    "leqVal': head mismatch "  ++ show u1 ++ " != " ++ show u2+                 case mt12 of+                   Nothing -> recoverFail $ "leqVal': cannot compare constructor terms without type"+                   Just tv12 -> do+                     ct12 <- Traversable.mapM (conType n1) tv12+                     leqVals' f p ct12 vl1 vl2+                     return ()+{-+       leqStructural u1 u2 where+          leqStructural u1 u2 =+-}+       case (u1,u2) of++{-+  C = C'  (proper: C' entails C, but I do not want to implement entailment)+  Gamma, C |- A  <=  Gamma', C' |- A'+  -----------------------------------------+  Gamma |- C ==> A  <=  Gamma' |- C' ==> A'+-}+              (VGuard beta1 bv1, VGuard beta2 bv2) -> do+                 entailsGuard (switch p) beta1 beta2+                 leqVal' f p Nothing bv1 bv2++              (VGuard beta u1, u2) | p `elem` [Neg,Pos] ->+                addOrCheckGuard (switch p) beta $+                  leqVal' f p Nothing u1 u2++              (u1, VGuard beta u2) | p `elem` [Neg,Pos] ->+                addOrCheckGuard p beta $+                  leqVal' f p Nothing u1 u2+ {-+  p' <= p+  Gamma' |- A' <= Gamma |- A+  Gamma, p(x:A) |- B <= Gamma', p'(x:A') |- B'+  ---------------------------------------------------------+  Gamma |- p(x:A) -> B : s <= Gamma' |- p'(x:A') -> B' : s'+-}+              (VQuant piSig1 x1 dom1@(Domain av1 _ dec1) fv1,+               VQuant piSig2 x2 dom2@(Domain av2 _ dec2) fv2) -> do+                 let p' = if piSig1 == Pi then switch p else p+                 if piSig1 /= piSig2 || not (leqDec p' dec1 dec2) then+                    recoverFailDoc $ text "subtyping" <+> prettyTCM u1 <+> text (" <=" ++ show p ++ " ") <+> prettyTCM u2 <+> text "failed"+                  else do+                    leqVal' (switch f) p' Nothing av1 av2+                    -- take smaller domain+                    let dom = if (p' == Neg) then dom2 else dom1+                    let x = bestName $ if p' == Neg then [x2,x1] else [x1,x2]+                    new x dom $ \ xv -> do+                      bv1 <- app fv1 xv+                      bv2 <- app fv2 xv+                      enterDoc (text "comparing codomain" <+> prettyTCM bv1 <+> text "with" <+> prettyTCM bv2) $+                        leqVal' f p Nothing bv1 bv2++              (VSing v1 av1, VSing v2 av2) -> do+                  leqVal' f p Nothing av1 av2+                  leqVal' N mixed (Just (Two av1 av2)) v1 v2  -- compare for eq.++              (VSing v1 av1, VBelow ltle v2) | av1 == vSize && p == Pos -> do+                 v1 <- whnfClos v1+                 leSize ltle p v1 v2++{- 2012-01-28 now vSize is VBelow Le Infty++              -- extra cases since vSize is not implemented as VBelow Le Infty+              (u1,u2) | isVSize u1 && isVSize u2 -> return ()+              (VSort (SortC Size), VBelow{}) -> leqStructural (VBelow Le VInfty) u2+              (VBelow{}, VSort (SortC Size)) -> leqStructural u1 (VBelow Le VInfty)+-}+              -- care needed to not make <=# a subtype of <#+              (VBelow ltle1 v1, VBelow ltle2 v2) ->+                case (p, ltle1, ltle2) of+                  _ | ltle1 == ltle2 -> leSize Le p v1 v2+                  (Neg, Le, Lt) -> leSize Le p (vSucc v1) v2+                  (Neg, Lt, Le) -> leSize Lt p v1 v2  -- careful here+                  (p  , Lt, Le) -> leSize Le p v1 (vSucc v2)+                  (p  , Le, Lt) -> leSize Lt p v1 v2  -- careful here++              -- unresolved eta-expansions (e.g. at coinductive type)+              (VUp v1 av1, VUp v2 av2) -> do+                  -- leqVal' f p Nothing av1 av2      -- do not compare types+                  leqVal' f p (Just (Two av1 av2)) v1 v2  -- OR: Just(tv1,tv2) ?+              (VUp v1 av1, u2) -> leqVal' f p mt12 v1 u2+              (u1, VUp v2 av2) -> leqVal' f p mt12 u1 v2++              (VRecord (NamedRec _ n1 _ _) rs1, VRecord (NamedRec _ n2 _ _) rs2) ->+                 leqCons n1 (map snd rs1) n2 (map snd rs2)++{-+              -- the following three cases should be impossible+              -- but aren't.  I gave up on this bug -- 2012-01-25+              -- FOUND IT++              (VRecord (NamedRec _ n1 _) rs1,+               VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 (map snd rs1) n2 vl2++              (VApp v1@(VDef (DefId (ConK _) n1)) vl1,+               VRecord (NamedRec _ n2 _) rs2) -> leqCons n1 vl1 n2 (map snd rs2)++              (VApp v1@(VDef (DefId (ConK _) n1)) vl1,+               VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 vl1 n2 vl2+-}++              -- smart equality is not transitive+              (VCase v1 tv1 env1 cl1, VCase v2 tv2 env2 cl2) -> do+                 leqVal' f p (Just (Two tv1 tv2)) v1 v2 -- FIXED: do not have type here, but v1,v2 are neutral+                 leqClauses f p mt12 v1 tv1 env1 cl1 env2 cl2++{- REMOVED, NOT TRANSITIVE+              (VCase v env cl, v2) -> leqCases (switch f) (switch p) (switch mt12) v2 v env cl+              (v1, VCase v env cl) -> leqCases f p mt12 v1 v env cl+-}+              (VSing v1 av1, av2)  -> leqVal' f p Nothing av1 av2  -- subtyping ax+              (VSort s1, VSort s2) -> leqSort p s1 s2+              (a1,a2) | a1 == a2 -> return ()+              (u1,u2) -> tryForcing $+                case (u1,u2) of+                  (VApp v1 vl1, VApp v2 vl2) -> leqApp f p v1 vl1 v2 vl2+                  (VApp v1 vl1, u2) -> leqApp f p v1 vl1 u2 []+                  (u1, VApp v2 vl2) -> leqApp f p u1 []  v2 vl2+                  _ -> leqApp f p u1 [] u2 []++leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck ()+leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where+  loop cls1 cls2 = case (cls1,cls2) of+    ([],[]) -> return ()+    (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do+      ns <- flip execStateT [] $ alphaPattern p1 p2+      case (mrhs1, mrhs2) of+        (Nothing, Nothing) -> return ()+        (Just e1, Just e2) -> do+            let tv = maybe vTopSort first12 mt12+            let tv012 = maybe [] toList12 mt12+            addPattern (tvp `arrow` tv) p2 env2 $ \ _ pv env2' ->+              addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do+                let env1' = env2' { envMap = compAssoc ns (envMap env2') }+                v1  <- whnf (appendEnv env1' env1) e1+                v2  <- whnf (appendEnv env2' env2) e2+                leqVal' f pol (toMaybe12 tv012) v1 v2+            loop cls1' cls2'+{-+-- naive implementation for now+leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck ()+leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where+  loop cls1 cls2 = case (cls1,cls2) of+    ([],[]) -> return ()+    (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do+      eqPattern p1 p2+      case (mrhs1, mrhs2) of+        (Nothing, Nothing) -> return ()+        (Just e1, Just e2) -> do+            let tv = maybe vTopSort first12 mt12+            let tv012 = maybe [] toList12 mt12+            addPattern (tvp `arrow` tv) p1 env1 $ \ _ pv env' ->+              addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do+                v1  <- whnf (appendEnv env' env1) e1+                v2  <- whnf (appendEnv env' env2) e2+                leqVal' f pol (toMaybe12 tv012) v1 v2+            loop cls1' cls2'++eqPattern :: Pattern -> Pattern -> TypeCheck ()+eqPattern p1 p2 = if p1 == p2 then return () else throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2+-}++type NameMap = [(Name,Name)]++alphaPattern :: Pattern -> Pattern -> StateT NameMap TypeCheck ()+alphaPattern p1 p2 = do+  let failure = throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2+      alpha x1 x2 = do+        ns <- get+        case lookup x1 ns of+          Nothing -> put $ (x1,x2) : ns+          Just x2' | x2 == x2' -> return ()+                   | otherwise -> failure+  case (p1,p2) of+    (VarP x1, VarP x2) -> alpha x1 x2+    (ConP pi1 n1 ps1, ConP pi2 n2 ps2) | pi1 == pi2 && n1 == n2 ->+      zipWithM_ alphaPattern ps1 ps2+    (SuccP p1, SuccP p2) -> alphaPattern p1 p2+    (SizeP _ x1, SizeP _ x2) -> alpha x1 x2+    (PairP p11 p12, PairP p21 p22) -> do+      alphaPattern p11 p21+      alphaPattern p12 p22+    (ProjP n1, ProjP n2) -> unless (n1 == n2) failure+    (DotP _, DotP _) -> return ()+    (AbsurdP, AbsurdP) -> return ()+    (ErasedP p1, ErasedP p2) -> alphaPattern p1 p2+    (UnusableP p1, UnusableP p2) -> alphaPattern p1 p2+    _ -> failure++-- leqCases f p tv1 v1 v tv env cl+-- checks whether  v1 <=p (VCase v tv env cl) : tv1+leqCases :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> [Clause] -> TypeCheck ()+leqCases f pol mt12 v1 v tvp env cl = do+  vcase <- evalCase v tvp env cl+  case vcase of+    (VCase v tvp env cl) -> mapM_ (leqCase f pol mt12 v1 v tvp env) cl+    v2 -> leqVal' f pol mt12 v1 v2++-- absurd cases need not be checked+leqCase :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> Clause -> TypeCheck ()+leqCase f pol mt12 v1 v tvp env (Clause _ [p] Nothing) = return ()+leqCase f pol mt12 v1 v tvp env (Clause _ [p] (Just e)) = enterDoc (text "leqCase" <+> prettyTCM v <+> text " --> " <+> text (show p ++ "  |- ") <+> prettyTCM v1 <+> text (" <=" ++ show pol ++ " ") <+> prettyTCM (VClos env e)) $ do    -- ++ "  :  " ++ show mt12) $+-- the dot patterns inside p are only valid in environment env+  let tv = case mt12 of+             Nothing -> vTopSort+             Just tv12 -> second12 tv12+  addPattern (tvp `arrow` tv) p env $ \ _ pv env' ->+    addRewrite (Rewrite v pv) [tv,v1] $ \ [tv',v1'] -> do+      v2  <- whnf (appendEnv env' env) e+      v2' <- reval v2 -- 2010-09-10, WHY?+      let mt12' = fmap (mapSecond12 (const tv')) mt12+      leqVal' f pol mt12' v1' v2'++-- compare spines (see rule Al-App-Ne, Abel, MSCS 08)+-- q ::= mixed | Pos | Neg+leqVals' :: Force -> Pol -> OneOrTwo TVal -> [Val] -> [Val] -> TypeCheck (OneOrTwo TVal)+leqVals' f q tv12 vl1 vl2 = do+  sh12 <- typeView12 =<< mapM force tv12+  case (vl1, vl2, sh12) of++    ([], [], _) -> return tv12++    (VProj Post p1 : vs1, VProj Post p2 : vs2, ShData d _) -> do+      unless (p1 == p2) $+        recoverFailDoc $ text "projections"+          <+> prettyTCM p1 <+> text "and"+          <+> prettyTCM p2 <+> text "differ!"+        -- recoverFail $ "projections " ++ show p1 ++ " and " ++ show p2 ++ " differ!"+      tv12 <- mapM (\ tv -> projectType tv p1 VIrr) tv12+      leqVals' f q tv12 vs1 vs2++    (w1:vs1, w2:vs2, ShQuant Pi x12 dom12 fv12) -> do+      let p = oneOrTwo id polAnd (fmap (polarity . decor) dom12)+      let dec = Dec p -- WAS: , erased = erased $ decor $ first12 dom12 }+      v1 <- whnfClos w1+      v2 <- whnfClos w2+      tv12 <- do+        if erased p -- WAS: (erased dec || p == Pol.Const)+         -- we have skipped an argument, so proceed with two types!+         then app12 (toTwo fv12) (Two v1 v2)+         else do+           let q' = polComp p q+           applyDec dec $+             leqVal' f q' (Just $ fmap typ dom12) v1 v2+           -- we have not skipped comparison, so proceed (1/2) as we came in+           case fv12 of+             Two{}  -> app12 fv12 (Two v1 v2)+             One fv -> One <$> app fv v1+               -- type is invariant, so it does not matter which one we take+      leqVals' f q tv12 vs1 vs2++    _ -> failDoc $ text "leqVals': not (compatible) function types or mismatch number of arguments when comparing "+           <+> prettyTCM vl1 <+> text " to "+           <+> prettyTCM vl2 <+> text " at type "+           <+> prettyTCM tv12+--    _ -> throwErrorMsg $ "leqVals': not (compatible) function types or mismatch number of arguments when comparing  " ++ show vl1 ++ "  to  " ++ show vl2 ++ "  at type  " ++ show tv12++{-+leqVals' f q (VPi x1 dom1@(Domain av1 _ dec1) env1 b1,+              VPi x2 dom2@(Domain av2 _ dec2) env2 b2)+         (w1:vs1) (w2:vs2) | dec1 == dec2 = do+  let p = polarity dec1+  v1 <- whnfClos w1+  v2 <- whnfClos w2+  when (not (erased dec1)) $+    applyDec dec1 $ leqVal' f (polComp p q) (Just (av1,av2)) v1 v2+  tv1 <- whnf (update env1 x1 v1) b1+  tv2 <- whnf (update env2 x2 v2) b2+  leqVals' f q (tv1,tv2) vs1 vs2+-}++{-+leqNe :: Force -> Val -> Val -> TypeCheck TVal+leqNe f v1 v2 = --trace ("leqNe " ++ show v1 ++ "<=" ++ show v2) $+  do case (v1,v2) of+      (VGen k1, VGen k2) -> if k1 == k2 then do+                                 dom <- lookupGem k1+                                 return $ typ dom+                               else throwErrorMsg $ "gen mismatch "  ++ show k1 ++ " " ++ show k2+-}++-- leqApp f pol v1 vs1 v2 vs2    checks   v1 vs1 <=pol v2 vs2+-- pol ::= Param | Pos | Neg+leqApp :: Force -> Pol -> Val -> [Val] -> Val -> [Val] -> TypeCheck ()+leqApp f pol v1 w1 v2 w2 = {- trace ("leqApp: " -- ++ show delta ++ " |- "+                                  ++ show v1 ++ show w1 ++ " <=" ++ show pol ++ " " ++ show v2 ++ show w2) $ -}+{-+  do let headMismatch = recoverFail $+            "leqApp: head mismatch "  ++ show v1 ++ " != " ++ show v2+-}+  do let headMismatch = recoverFailDoc $ text "leqApp: head mismatch"+           <+> prettyTCM v1 <+> text "!=" <+> prettyTCM v2+     let emptyOrUnit u1 u2 =+          unlessM (isEmptyType u1) $ unlessM (isUnitType u2) $ headMismatch+     case (v1,v2) of+{-  IMPOSSIBLE:+      (VApp v1 [], v2) -> leqApp f pol v1 w1 v2 w2+      (v1, VApp v2 []) -> leqApp f pol v1 w1 v2 w2+-}+{-+      (VApp{}, _)    -> throwErrorMsg $ "leqApp: internal error: hit application v1 = " ++ show v1+      (_, VApp{})    -> throwErrorMsg $ "leqApp: internal error: hit application v2 = " ++ show v2+-}++      (VUp v1 _, v2) -> leqApp f pol v1 w1 v2 w2+      (v1, VUp v2 _) -> leqApp f pol v1 w1 v2 w2++      (VGen k1, VGen k2) | k1 == k2 -> do+        tv12 <- (fmap typ . domain) <$> lookupGen k1+        leqVals' f pol tv12 w1 w2+        return ()+{-+      (VGen k1, VGen k2) ->+        if k1 /= k2+          then headMismatch+          else do tv12 <- (fmap typ . domain) <$> lookupGen k1+                  leqVals' f pol tv12 w1 w2+                  return ()+-}+{-+      (VCon _ n, VCon _ m) ->+        if n /= m+         then throwErrorMsg $+            "leqApp: head mismatch "  ++ show v1 ++ " != " ++ show v2+         else do+          sige <- lookupSymb n+          case sige of+            (ConSig tv) -> -- constructor+               leqVals' f tv (repeat mixed) w1 w2 >> return ()+-}++      (VDef n, VDef m) | n == m ->  do+        tv <- lookupSymbTypQ (idName n)+        leqVals' f pol (One tv) w1 w2+        return ()++      -- check for least or greatest type++      (u1,u2) -> if pol == Pos then emptyOrUnit u1 u2 else+                 if pol == Neg then emptyOrUnit u2 u1 else headMismatch++{-+      -- least type+      (VDef (DefId DatK n), v2) | pol == Pos ->+        ifM (isEmptyData n) (return ()) headMismatch+      (v1, VDef (DefId DatK n)) | pol == Neg ->+        ifM (isEmptyData n) (return ()) headMismatch+-}+{-+      (VDef n, VDef m) ->+        if (name n) /= (name m) then do+           bot <- if pol==Neg then isEmptyData $ name m else+                  if pol==Pos then isEmptyData $ name n else return False+           if bot then return () else headMismatch+         else do+           tv <- lookupSymbTyp (name n)+           leqVals' f pol (One tv) w1 w2+           return ()+-}+{-+          sig <- gets signature+          case lookupSig (name n) sig of+            (DataSig{ numPars = p, positivity = pos, isSized = s, isCo = co, symbTyp = tv }) -> -- data type+               let positivitySizeIndex = if s /= Sized then mixed else+                                           if co == Ind then Pos else Neg+                   pos' = -- trace ("leqApp:  posOrig = " ++ show (pos ++ [positivitySizeIndex])) $+                     map (polComp pol) (pos ++ positivitySizeIndex : repeat mixed) -- the polComp will replace all SPos by Pos+               in leqVals' f tv pos' w1 w2+                    >> return ()++-- otherwise, we are dealing with a (co) recursive function or a constructor+            entry -> leqVals' f (symbTyp entry) (repeat mixed) w1 w2 >> return ()+-}++{-+      _ -> headMismatch++      _ -> recoverFail $ "leqApp: " ++ show v1 ++ show w1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ show w2+-}++isEmptyType :: TVal -> TypeCheck Bool+isEmptyType (VDef (DefId DatK n)) = isEmptyData n+isEmptyType _ = return False++isUnitType :: TVal -> TypeCheck Bool+isUnitType (VDef (DefId DatK n)) = isUnitData n+isUnitType _ = return False++-- comparing sorts and sizes -----------------------------------------++leqSort :: Pol -> Sort Val -> Sort Val -> TypeCheck ()+leqSort p = relPolM p leqSort'+{-+leqSort mixed s1 s2 = leqSort' s1 s2 >> leqSort' s2 s1+leqSort Neg s1 s2 = leqSort' s2 s1+leqSort Pos s1 s2 = leqSort' s1 s2+-}++leqSort' :: Sort Val -> Sort Val -> TypeCheck ()+leqSort' s1 s2 = do+--  let err = "universe test " ++ show s1 ++ " <= " ++ show s2 ++ " failed"+  let err = text "universe test"+            <+> prettyTCM s1 <+> text "<="+            <+> prettyTCM s2 <+> text "failed"+  case (s1,s2) of+     (_            , Set VInfty)         -> return ()+     (SortC c      , SortC c') | c == c' -> return ()+     (Set v1       , Set v2)             -> leqSize Pos v1 v2+     (CoSet VInfty , Set v)              -> return ()+     (Set VZero    , CoSet{})            -> return ()+     (CoSet v1     , CoSet v2)           -> leqSize Neg v1 v2+     _ -> recoverFailDoc err++minSize :: Val -> Val -> Maybe Val+minSize v1 v2 =+  case (v1,v2) of+    (VZero,_)  -> return VZero+    (_,VZero)  -> return VZero+    (VInfty,_) -> return v2+    (_,VInfty) -> return v1+    (VMax vs,_) -> maxMins $ map (\ v -> minSize v v2) vs+    (_,VMax vs) -> maxMins $ map (\ v -> minSize v1 v) vs+    (VSucc v1', VSucc v2') -> fmap succSize $ minSize v1' v2'+    (VGen i, VGen j) -> if i == j then return $ VGen i else Nothing+    (VSucc v1', VGen j) -> minSize v1' v2+    (VGen i, VSucc v2') -> minSize v1 v2'++maxMins :: [Maybe Val] -> Maybe Val+maxMins mvs = case compressMaybes mvs of+                     [] -> Nothing+                     vs' -> return $ maxSize vs'++-- substaging on size values+leqSize :: Pol -> Val -> Val -> TypeCheck ()+leqSize = leSize Le++ltSize :: Val -> Val -> TypeCheck ()+ltSize = leSize Lt Pos++leSize :: LtLe -> Pol -> Val -> Val -> TypeCheck ()+leSize ltle pol v1 v2 = enterDoc (text "leSize"+      <+> prettyTCM v1 <+> text (show ltle ++ show pol)+      <+> prettyTCM v2) $+-- enter ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $+    traceSize ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $+    do case (v1,v2) of+         _ | v1 == v2 && ltle == Le -> return () -- TODO: better handling of sums!+         (VSucc v1,VSucc v2) -> leSize ltle pol v1 v2+{-+         (VGen i1,VGen i2) -> do+           d <- getSizeDiff i1 i2 -- check size relation from constraints+           case d of+             Nothing -> recoverFail $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2+             Just k -> case (pol,k) of+               (_, 0) | pol == mixed -> return ()+               (Pos, _) | k >= 0 -> return ()+               (Neg, _) | k <= 0 -> return ()+               _ ->  recoverFail $ "leqSize: " ++ show v1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ " failed"+-}+{-+           if v1 == v2 then return ()+           else throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2+-}+         (VInfty,VInfty) | ltle == Le -> return ()+                         | otherwise -> recoverFail "leSize: # < # failed"+         (VApp h1 tl1,VApp h2 tl2) -> leqApp N pol h1 tl1 h2 tl2+         _ -> relPolM pol (leSize' ltle) v1 v2++leqSize' :: Val -> Val -> TypeCheck ()+leqSize' = leSize' Le++leSize' :: LtLe -> Val -> Val -> TypeCheck ()+leSize' ltle v1 v2 = -- enter ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $+  enterDoc (text "leSize'" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2) $+    traceSize ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $+    do let failure = recoverFailDoc $ text "leSize':"+             <+> prettyTCM v1 <+> text (show ltle)+             <+> prettyTCM v2 <+> text "failed"+           -- err = "leSize': " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 ++ " failed"+       case (v1,v2) of+         (VZero,_) | ltle == Le -> return ()+         (VSucc{}, VZero) -> failure+         (VInfty, VZero) -> failure+         (VGen{}, VZero) -> failure+         (VMax vs,_) -> mapM_ (\ v -> leSize' ltle v v2) vs -- all v in vs <= v2+         (_,VMax vs)  -> foldr1 orM $ map (leSize' ltle v1) vs -- this produces a disjunction+--         (_,VMax _)  -> addLe ltle v1 v2 -- this produces a disjunction+         (_,VInfty) | ltle == Le -> return ()+         (VZero, VInfty) -> return ()+         (VMeta{},VZero) -> addLe ltle v1 v2+{-+         (0,VMeta i n', VMeta j m') ->+           let (n,m) = if bal <= 0 then (n', m' - bal) else (n' + bal, m') in+-}+         (VMeta i rho n, VMeta j rho' m) ->+               addLe ltle (VMeta i rho  (n - min n m))+                        (VMeta j rho' (m - min n m))+         (VMeta i rho n, VSucc v2) | n > 0 -> leSize' ltle (VMeta i rho (n-1)) v2+         (VMeta i rho n, v2)  -> addLe ltle v1 v2+         (VSucc v1, VMeta i rho n) | n > 0 -> leSize' ltle v1 (VMeta i rho (n-1))+         (v1,VMeta i rho n) -> addLe ltle v1 v2+         _ -> leSize'' ltle 0 v1 v2+{- HANDLED BY leSize'' ltle+         (VSucc{}, VGen{}) -> throwErrorMsg err+         (VSucc{}, VPlus{}) -> throwErrorMsg err+-}+-- leSize'' ltle bal v v'  checks whether  Succ^bal v `lt` v'+-- invariant: bal is zero in cases for VMax and VMeta+leSize'' :: LtLe -> Int -> Val -> Val -> TypeCheck ()+leSize'' ltle bal v1 v2 = traceSize ("leSize'' " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2) $+    do let failure = recoverFailDoc (text "leSize'':" <+> prettyTCM v1 <+> text ("+ " ++ show bal) <+> text (show ltle) <+> prettyTCM v2 <+> text "failed")+           check mb = ifM mb (return ()) failure+           ltlez = case ltle of { Le -> 0 ; Lt -> -1 }+       case (v1,v2) of+#ifdef STRICTINFTY+-- Only cancel variables < #+         _ | v1 == v2 && ltle == Le && bal <= 0 -> return ()+         (VGen i, VGen j) | i == j && bal <= -1 -> check $ isBelowInfty i+#else+-- Allow cancelling of all variables+         _ | v1 == v2 && bal <= ltlez -> return () -- TODO: better handling of sums!+#endif+         (VGen i, VInfty) | ltle == Lt -> check $ isBelowInfty i+         (VZero,_) | bal <= ltlez -> return ()+         (VZero,VInfty) -> return ()+         (VZero,VGen _) | bal > ltlez -> recoverFailDoc $ text "0 not <" <+> prettyTCM v2+         (VSucc v1, v2) -> leSize'' ltle (bal + 1) v1 v2+         (v1, VSucc v2) -> leSize'' ltle (bal - 1) v1 v2+         (VPlus vs1, VPlus vs2) -> leSizePlus ltle bal vs1 vs2+         (VPlus vs1, VZero) -> leSizePlus ltle bal vs1 []+         (VZero, VPlus vs2) -> leSizePlus ltle bal [] vs2+         (VPlus vs1, _) -> leSizePlus ltle bal vs1 [v2]+         (_, VPlus vs2) -> leSizePlus ltle bal [v1] vs2+         (VZero,_) -> leSizePlus ltle bal [] [v2]+         (_,VZero) -> leSizePlus ltle bal [v1] []+         _ -> leSizePlus ltle bal [v1] [v2]++#if (defined STRICTINFTY)+{-  2012-02-06 this modification cancels only variables < #+    However, omega-instantiation is valid [i < #] -> F i subseteq F #+    because every chain has a limit at #.+-}+leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()+leSizePlus Lt bal vs1 vs2 = do+  vs2' <- filterM varBelowInfty vs2+  vs1' <- filterM varBelowInfty vs1+  leSizePlus' Lt bal (vs1 List.\\ vs2') (vs2 List.\\ vs1')+leSizePlus Le bal vs1 vs2 =+  leSizePlus' Le bal (vs1 List.\\ vs2) (vs2 List.\\ vs1)+#else+leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()+leSizePlus ltle bal vs1 vs2 =+  leSizePlus' ltle bal (vs1 List.\\ vs2) (vs2 List.\\ vs1)+#endif+++varBelowInfty :: Val -> TypeCheck Bool+varBelowInfty (VGen i) = isBelowInfty i+varBelowInfty _        = return False++leSizePlus' :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck ()+leSizePlus' ltle bal vs1 vs2 = do+  let v1 = plusSizes vs1+  let v2 = plusSizes vs2+  let exit True  = return ()+      exit False | bal >= 0  = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text ("+ " ++ show bal ++ " " ++ show ltle) <+> prettyTCM v2 <+> text "failed")+                 | otherwise = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2 <+> text ("+ " ++ show (-bal) ++ " failed"))+  traceSizeM ("leSizePlus' ltle " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2)+  let ltlez = case ltle of { Le -> 0 ; Lt -> -1 }+  case (vs1,vs2) of+    ([],_) | bal <= ltlez -> return ()+    ([],[VGen i]) -> do+      n <- getMinSize i+      -- traceM ("getMinSize = " ++ show n)+      case n of+        Nothing -> exit False -- height of VGen i == 0+        Just n  -> exit (bal <= n + ltlez)+    ([VGen i1],[VGen i2]) -> do+      d <- sizeVarBelow i1 i2+      traceSizeM ("sizeVarBelow " ++ show (i1,i2) ++ " returns " ++ show d)+      case d of+        Nothing -> tryIrregularBound i1 i2 (ltlez - bal)+-- recoverFail $ "leSize: head mismatch: " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2+        Just k -> exit (bal <= k + ltlez)+    _ -> exit False++-- BAD HACK!+-- check (VGen i1) <= (VGen i2) + k+tryIrregularBound :: Int -> Int -> Int -> TypeCheck ()+tryIrregularBound i1 i2 k = do+  betas <- asks bounds+  let beta = Bound Le (Measure [VGen i1]) (Measure [iterate VSucc (VGen i2) !! k])+  foldl (\ result beta' -> result `orM` entailsGuard Pos beta' beta)+    (recoverFail "bound not entailed")+    betas++{-+leqSize' :: Val -> Val -> TypeCheck ()+leqSize' v1 v2 = --trace ("leqSize' " ++ show v1 ++ show v2) $+    do case (v1,v2) of+         (VMax vs,_) -> mapM_ (\ v -> leqSize' v v2) vs -- all v in vs <= v2+         (_,VMax _)  -> addLeq v1 v2 -- this produces a disjunction+         (VSucc v1,VSucc v2) -> leqSize' v1 v2+         (VGen v1,VGen v2) -> do+           d <- getSizeDiff v1 v2+           case d of+             Nothing -> throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2+             Just k -> if k >= 0 then return () else throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 ++ " failed"+         (_,VInfty) -> return ()+         (VMeta i n, VSucc v2) | n > 0 -> leqSize' (VMeta i (n-1)) v2+         (VMeta i n, VMeta j m) -> addLeq (VMeta i (n - min n m))+                                          (VMeta j (m - min n m))+         (VMeta i n, v2) -> addLeq v1 v2+         (VSucc v1, VMeta i n) | n > 0 -> leqSize' v1 (VMeta i (n-1))+         (v1,VMeta i n) -> addLeq v1 v2+         (v1,VSucc v2) -> leqSize' v1 v2+         _ -> throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2+-}++-- measures and guards -----------------------------------------------++{-+-- compare lexicographically+-- precondition: same length+ltMeasure :: Measure Val -> Measure Val -> TypeCheck ()+ltMeasure  (Measure mu1) (Measure mu2) =+  -- enter ("checking " ++ show mu1 ++ " < " ++ show mu2) $+    lexSizes Lt mu1 mu2+-}++{-+leqMeasure :: Pol -> Measure Val -> Measure Val -> TypeCheck ()+leqMeasure mixed (Measure mu1) (Measure mu2) = do+  zipWithM (leqSize mixed) mu1 mu2+  return ()+leqMeasure Pos (Measure mu1) (Measure mu2) = lexSizes mu1 mu2+leqMeasure Neg (Measure mu1) (Measure mu2) = lexSizes mu2 mu1+-}++-- lexSizes True  mu mu' checkes mu <  mu'+-- lexSizes False mu mu' checkes mu <= mu'+lexSizes :: LtLe -> [Val] -> [Val] -> TypeCheck ()+lexSizes ltle mu1 mu2 = traceSize ("lexSizes " ++ show (ltle,mu1,mu2)) $+  case (ltle, mu1, mu2) of+    (Lt, [], []) -> recoverFail $ "lexSizes: no descent detected"+    (Le, [], []) -> return ()+    (lt, a1:mu1, a2:mu2) -> do+      b <- newAssertionHandling Failure $ errorToBool $ leSize ltle Pos a1 a2+      case (lt,b) of+        (Le,False) -> recoverFailDoc $ text "lexSizes: expected" <+> prettyTCM a1 <+> text "<=" <+> prettyTCM a2+            -- recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2+        (Lt,True) -> return ()+        _ -> lexSizes ltle mu1 mu2++{-+      r <- compareSize a1 a2+      case r of+        LT -> return ()+        EQ -> lexSizes ltle mu1 mu2+        GT -> recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2+-}++{-+-- TODO: reprogram leqSize in terms of a proper compareSize+compareSize :: Val -> Val -> TypeCheck Ordering+compareSize a1 a2 = do+  let ret o = trace ("compareSize: " ++ show a1 ++ " compared to " ++ show a2 ++ " returns " ++ show o) $ return o+  le <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a1 a2+  ge <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a2 a1+  case (le,ge) of+    (True,False) -> ret LT -- THIS IS COMPLETE BOGUS!!!+    (True,True)  -> ret EQ+    (False,True) -> ret GT+    (False,False) -> throwErrorMsg $ "compareSize (" ++ show a1 ++ ", " ++ show a2 ++ "): sizes incomparable"+-}++{- Bound entailment++1. (mu1 <  mu1') ==> (mu2 <  mu2') if mu2 <= mu1 and mu1' <= mu2'+2. (mu1 <= mu1') ==> (mu2 <  mu2') one of these <= strict (<)+3. (mu1 <  mu1') ==> (mu2 <= mu2') as 1.+4. (mu1 <= mu1') ==> (mu2 <= mu2') as 1.++-}+entailsGuard :: Pol -> Bound Val -> Bound Val -> TypeCheck ()+entailsGuard pol beta1@(Bound ltle1 (Measure mu1) (Measure mu1')) beta2@(Bound ltle2 (Measure mu2) (Measure mu2')) = enterDoc (text ("entailsGuard:") <+> prettyTCM beta1 <+> text (show pol ++ "==>") <+> prettyTCM beta2) $ do+  case pol of+    _ | pol == mixed -> do+      assert (ltle1 == ltle2) $ "unequal bound types"+      zipWithM (leqSize mixed) mu1  mu2+      zipWithM (leqSize mixed) mu1' mu2'+      return ()+    Pos | ltle1 == Lt || ltle2 == Le  -> do+      lexSizes Le mu2  mu1  -- not strictly smaller+      lexSizes Le mu1' mu2'+      return ()+    Pos -> do+      (lexSizes Lt mu2  mu1 >> lexSizes Le mu1' mu2')+      `orM`+      (lexSizes Le mu2  mu1 >> lexSizes Lt mu1' mu2')+    Neg   -> entailsGuard (switch pol) beta2 beta1++{-+eqGuard :: Bound Val -> Bound Val -> TypeCheck ()+eqGuard (Bound (Measure mu1) (Measure mu1')) (Bound (Measure mu2) (Measure mu2')) = do+  zipWithM (leqSize mixed) mu1 mu2+  zipWithM (leqSize mixed) mu1' mu2'+  return ()+-}++checkGuard :: Bound Val -> TypeCheck ()+checkGuard beta@(Bound ltle mu mu') =+  enterDoc (text "checkGuard" <+> prettyTCM beta) $+    lexSizes ltle (measure mu) (measure mu')++addOrCheckGuard :: Pol -> Bound Val -> TypeCheck a -> TypeCheck a+addOrCheckGuard Neg beta cont = checkGuard beta >> cont+addOrCheckGuard Pos beta cont = addBoundHyp beta cont++-- comparing polarities -------------------------------------------------++leqPolM :: Pol -> PProd -> TypeCheck ()+leqPolM p (PProd Pol.Const _) = return ()+leqPolM p (PProd q m) | Map.null m && not (isPVar p) =+  if leqPol p q then return ()+   else recoverFail $ "polarity check " ++ show p ++ " <= " ++ show q ++ " failed"+leqPolM p q = do+  traceM $ "adding polarity constraint " ++ show p ++ " <= " ++ show q++leqPolPoly :: Pol -> PPoly -> TypeCheck ()+leqPolPoly p (PPoly l) = mapM_ (leqPolM p) l++-- adding an edge to the positivity graph+addPosEdge :: DefId -> DefId -> PProd -> TypeCheck ()+addPosEdge src tgt p = unless (src == tgt && isSPos p) $ do+  -- traceM ("adding interesting positivity graph edge  " ++ show src ++ " --[ " ++ show p ++ " ]--> " ++ show tgt)+  st <- get+  put $ st { positivityGraph = Arc (Rigid src) (ppoly p) (Rigid tgt) : positivityGraph st }++checkPositivityGraph :: TypeCheck ()+checkPositivityGraph = enter ("checking positivity") $ do+  st <- get+  let cs = positivityGraph st+  let gr = buildGraph cs+  let n  = nextNode gr+  let m0 = mkMatrix n (graph gr)+  let m  = warshall m0+  let isDataId i = case Map.lookup i (intMap gr) of+                     Just (Rigid (DefId DatK _)) -> True+                     _ -> False+  let dataDiag = [ m Array.! (i,i) | i <- [0..n-1], isDataId i ]+  mapM_ (\ x -> leqPolPoly oone x) dataDiag+{-+  let solvable = all (\ x -> leqPol oone x)+  unless solvable $ recoverFail $ "positivity check failed"+-}+  -- TODO: solve constraints+  put $ st { positivityGraph = [] }++-- telescopes --------------------------------------------------------++telView :: TVal -> TypeCheck ([(Val, TBinding TVal)], TVal)+telView tv = do+  case tv of+    VQuant Pi x dom fv -> underAbs_ x dom fv $ \ _ xv bv -> do+      (vTel, core) <- telView bv+      return ((xv, TBind x dom) : vTel, core)+    _ -> return ([], tv)++-- | Turn a fully applied constructor value into a named record value.+mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val+mkConVal dotted co n vs vc = do+  (vTel, _) <- telView vc+  let fieldNames = map (boundName . snd) vTel+  return $ VRecord (NamedRec co n False dotted) $ zip fieldNames vs
+ src/Eval.hs-boot view
@@ -0,0 +1,39 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Eval where++import Abstract+import Value+import {-# SOURCE #-} TCM (TypeCheck)++class Reval a where+  reval' :: Valuation -> a -> TypeCheck a+  reval  :: a -> TypeCheck a+  reval = reval' emptyVal++instance Reval Val+instance Reval Env++toExpr :: Val -> TypeCheck Expr++whnf  :: Env -> Expr -> TypeCheck Val+whnf' :: Expr -> TypeCheck Val+app   :: Val -> Val -> TypeCheck Val++whnfClos :: Val -> TypeCheck Val+force :: Val -> TypeCheck Val+piApps :: TVal -> [Clos] -> TypeCheck TVal++matchList :: Env -> [Pattern] -> [Val] -> TypeCheck (Maybe Env)++type GenToPattern = [(Int,Pattern)]+type MatchState = (Env, GenToPattern)+nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState)++projectType :: TVal -> Name -> Val -> TypeCheck TVal++up    :: Bool -> Val -> TVal -> TypeCheck Val++leqSize' :: Val -> Val -> TypeCheck ()++mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val
+ src/Extract.hs view
@@ -0,0 +1,690 @@+{-# LANGUAGE TupleSections, NamedFieldPuns #-}++module Extract where++{- extract to Fomega++Examples:+---------++MiniAgda++  data Vec (A : Set) : Nat -> Set+  { vnil  : Vec A zero+  ; vcons : [n : Nat] -> (head : A) -> (tail : Vec A n) -> Vec A (suc n)+  } fields head, tail++  fun length : [A : Set] -> [n : Nat] -> Vec A n -> <n : Nat>+  { length .A .zero    (vnil A)         = zero+  ; length .A .(suc n) (vcons A n a as) = suc (length A n as)+  }++Fomega++  data Vec (A : Set) : Set+  { vnil  : Vec A+  ; vcons : (head : A) -> (tail : Vec A) -> Vec A+  }++  fun head : [A : Set] -> Vec A -> A+  { head (vcons 'head 'tail) = 'head+  }++  fun tail : [A : Set] -> Vec A -> A+  { head (vcons 'head 'tail) = 'tail+  }++  fun length : [A : Set] -> Vec A -> Nat+  { length [A]  vnil             = zero+  ; length [A] (vcons [.A] a as) = suc (length [A] as)+  }+++Bidirectional extraction+========================++Types++  Base ::= D As         data type+         | ?            inexpressible type++  A,B ::= Base | A -> B | [x:K] -> B | [] -> B  with erasure markers+  A0, B0 ::= Base | A0 -> B0 | [x:K0] -> B0     without erasure markers++  |.| erase erasure markers++Inference mode:++  Term extraction:  Gamma |- t :> A  --> e    |Gamma| |- e : |A|+  Type extraction:  Gamma |- T :> K  --> A    |Gamma| |- A : |K|+  Kind extraction:  Gamma |- U :> [] --> K    |Gamma| |- K : []++Checking mode:++  Term extraction:  Gamma |- t <: A  --> e    |Gamma| |- e : |A|+  Type extraction:  Gamma |- T <: K  --> A    |Gamma| |- A : |K|+  Kind extraction:  Gamma |- U <: [] --> K    |Gamma| |- K : []++Type and kind extraction keep erasure markers!++Checking abstraction:++  Relevant abstraction:+  Gamma, x:A |- t <: B --> e+  --------------------------------+  Gamma |- \x.t <: A -> B --> \x.e++  Type abstraction:+  Gamma, x:K |- t <: B --> e : B0+  ----------------------------------------+  Gamma |- \[x].t <: [x:K] -> B --> \[x].e+      also \xt++  Irrelevant abstraction:+  Gamma |- t : B --> e+  -------------------------------+  Gamma |- \[x].t : [] -> B --> e+      also \xt++  Relevant abstraction at unknown type:+  Gamma, x:? |- t : ? --> e+  --------------------------+  Gamma |- \x.t : ? --> \x.e++  Irrelevant abstraction at unknown type:+  Gamma |- t : ? --> e+  -------------------------+  Gamma |- \[x].t : ? --> e++Checking by inference:++  Gamma |- t :> A --> e    e : |A| <: |B| --> e'+  ----------------------------------------------+  Gamma |- t <: B --> e' : B0++Casting:++  ------------------ A0 does not contain ?+  e : A0 <: A0 --> e++  ----------------------- A0 != B0 or one does contain ?+  e : A0 <: B0 --> cast e++Inferring variable:++  ----------------------------+  Gamma |- x :> Gamma(x) --> x++Inferring application:++  Relevant application:+  Gamma |- t :> A -> B --> f     Gamma |- u <: A --> e+  ----------------------------------------------------+  Gamma |- t u :> B --> f e++  Type application:+  Gamma |- t :> [x:K] -> B --> f   Gamma |- u <: K --> A+  ------------------------------------------------------+  Gamma |- t [u] :> : B[A/x] --> f [A]+      also  t u++  Irrelevant application:+  Gamma |- t :> [] -> B --> f+  ---------------------------+  Gamma |- t [u] :> B --> f+      also  t u++  Relevant application at unknown type:+  Gamma |- t :> ? --> f     Gamma |- u <: ? --> e+  -----------------------------------------------+  Gamma |- t u :> ? --> f e++  Irrelevant application at unknown type:+  Gamma |- t :> ? --> f+  -------------------------+  Gamma |- t [u] :> ? --> f++++-}++import Prelude hiding (pi, null)++import Control.Applicative+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State++import Data.Char+import Data.Traversable (Traversable)+import qualified Data.Traversable as Traversable+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe++import Text.PrettyPrint++import Polarity as Pol+import Abstract+import Value+import Eval+import TCM+import TraceError+import Util++traceExtrM s = return ()++runExtract sig k = runExceptT (runReaderT (runStateT k (initWithSig sig)) emptyContext)++-- extraction++type FExpr        = Expr+type FDeclaration = Declaration+type FClause      = Clause+type FPattern     = Pattern+type FConstructor = Constructor+type FTypeSig     = TypeSig+type FFun         = Fun+type FTelescope   = Telescope++type FTVal        = TVal++extractDecls :: [EDeclaration] -> TypeCheck [FDeclaration]+extractDecls ds = concat <$> mapM extractDecl ds++extractDecl :: EDeclaration -> TypeCheck [FDeclaration]+extractDecl d =+  case d of+    MutualDecl _ ds -> extractDecls ds -- TODO!+    OverrideDecl{} -> throwErrorMsg $ "extractDecls internal error: overrides impossible"+    MutualFunDecl _ co funs -> extractFuns co funs+    FunDecl co fun -> extractFun co fun+    LetDecl evl x tel (Just t) e | null tel -> extractLet evl x t e+    PatternDecl{}    -> return []+    DataDecl n _ co _ tel ty cs fields -> extractDataDecl n co tel ty cs++extractFuns :: Co -> [Fun] -> TypeCheck [FDeclaration]+extractFuns co funs = do+  funs <- concat <$> mapM extractFunTypeSig funs+  concat <$> mapM (extractFun co) funs++extractFun :: Co -> Fun -> TypeCheck [FDeclaration]+extractFun co (Fun (TypeSig n t) n' ar cls) = do+  tv <- whnf' t+  cls <- concat <$> mapM (extractClause n tv) cls+  return [ FunDecl co $ Fun (TypeSig n t) n' ar cls+         -- , LetDecl False (TypeSig n' t) (Var n)  -- no longer needed, since n and n' print the same+         ]++{- OLD+extractFun :: Co -> Fun -> TypeCheck [FDeclaration]+extractFun co (TypeSig n t, (ar, cls)) = extractIfTerm n $ do+  tv0 <- whnf' t+  t <- extractType tv0+  setExtrTyp n t+  let n' = mkExtName n+  setExtrTyp n' t+  tv <- whnf' t+  cls <- concat <$> mapM (extractClause n tv) cls+  return [ FunDecl co (TypeSig n t, (ar, cls))+         , LetDecl False (TypeSig n' t) (Var n)+         ]+-}+{-+extractFunTypeSigs :: [Fun] -> TypeCheck [Fun]+extractFunTypeSigs = mapM extractFunTypeSig+-}++-- only extract type sigs+extractFunTypeSig :: Fun -> TypeCheck [Fun]+extractFunTypeSig (Fun ts@(TypeSig n t) n' ar cls) = extractIfTerm n $ do+  ts@(TypeSig n t) <- extractTypeSig ts+  setExtrTyp n' t+  return [Fun ts n' ar cls]++extractLet :: Bool -> Name -> Type -> Expr -> TypeCheck [FDeclaration]+extractLet evl n t e = extractIfTerm n $ do+  TypeSig n t <- extractTypeSig (TypeSig n t)+  e <- extractCheck e =<< whnf' t+  return [LetDecl evl n emptyTel (Just t) e]++extractTypeSig :: TypeSig -> TypeCheck FTypeSig+extractTypeSig (TypeSig n t) = do+  t <- extractType =<< whnf' t+  setExtrTyp n t+  return $ TypeSig n t++extractIfTerm :: Name -> TypeCheck [a] -> TypeCheck [a]+extractIfTerm n cont = do+  k <- symbolKind <$> lookupSymb n+  if k == NoKind || lowerKind k == SortC Tm then cont else return []++extractDataDecl :: Name -> Co -> Telescope -> Type -> [Constructor] -> TypeCheck [FDeclaration]+extractDataDecl n co tel ty cs = do+  -- k    <- extrTyp <$> lookupSymb n+  tel' <- extractKindTel tel+  Just core <- addBinds tel $ extractKind =<< whnf' ty+  -- (_, core) = typeToTele' (length tel') k+  cs   <- mapM (extractConstructor tel) cs+  return [DataDecl n NotSized co [] tel' core cs []]++extractConstructor :: Telescope -> Constructor -> TypeCheck FConstructor+extractConstructor tel0 (Constructor n pars t) = do+{- fails for HEq+  -- 2012-01-22: remove irrelevant parameters+  let tel = filter (\ (TBind _ dom) -> not $ erased $ decor dom)  tel0+-}+  let tel = tel0+  -- compute full extracted constructor type and add to the signature+  t' <- extractType =<< whnf emptyEnv (teleToTypeErase tel t)+  setExtrTypQ n t'+  let (tel',core) = typeToTele' (size tel) t'+  return $ Constructor n pars core+  -- compute type minus telescope+  -- TypeSig n <$> (extractType =<< whnf' t)++extractClause :: Name -> FTVal -> Clause -> TypeCheck [FClause]+extractClause f tv (Clause _ pl Nothing) = return [] -- discard absurd clauses+extractClause f tv cl@(Clause vtel pl (Just rhs)) = do+  traceM ("extracting clause " ++ render (prettyClause f cl)+          ++ "\n at type " ++ show tv)+{-+  tel <- introPatterns pl tv0 $ \ _ _ -> do+           vtel <- getContextTele+           extractTeleVal vtel+  addBinds tel $+-}+  introPatVars pl $+    extractPatterns tv pl $ \ pl tv -> do+      rhs <- extractCheck rhs tv+      return [Clause vtel pl (Just rhs)] -- TODO: return FTelescope (type!)++-- the pattern variables are already in context+extractPatterns :: FTVal -> [Pattern] ->+                   ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a+extractPatterns tv [] cont = cont [] tv+extractPatterns tv (p:ps) cont =+  extractPattern tv p $ \ pl tv ->+    extractPatterns tv ps $ \ ps tv ->+      cont (pl ++ ps) tv++extractPattern :: FTVal -> Pattern ->+                  ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a+extractPattern tv p cont = do+  traceM ("extracting pattern " ++ render (pretty p) ++ " at type " ++ show tv)+  fv <- funView tv+  case fv of+    EraseArg tv -> cont [] tv  -- skip erased patterns++    Forall x dom fv -> do+      xv <- whnf' (patternToExpr p) -- pattern variables are already in scope+      bv <- app fv xv -- TODO!+      case p of+        ErasedP (VarP y) -> setTypeOfName y dom $ cont [] bv+        _ -> cont [] bv+{-+    Forall x ki env t -> new x ki $ \ xv ->+      cont [] =<< whnf (update env x xv) t -- TODO!+-}+    Arrow av bv -> extractPattern' av p (flip cont bv)++extractPattern' :: FTVal -> Pattern ->+                  ([FPattern] -> TypeCheck a) -> TypeCheck a+extractPattern' av p cont =+      case p of+        VarP y -> setTypeOfName y (defaultDomain av) $+          cont [VarP y]+        PairP p1 p2 -> do+          view <- prodView av+          -- hack to avoid IMPOSSIBLE+          let (av1, av2) = case view of+                             Prod av1 av2 -> (av1, av2)+                             _ -> (av, av) -- HACK+          extractPattern' av1 p1 $ \ ps1 -> do+            extractPattern' av2 p2 $ \ ps2 ->+               let ps [] ps2    = ps2+                   ps ps1 []    = ps1+                   ps [p1] [p2] = [PairP p1 p2]+               in  cont $ ps ps1 ps2++{-+          case view of+            Prod av1 av2 ->+              extractPattern' av1 p1 $ \ [p1] -> do+                extractPattern' av2 p2 $ \ [p2] -> cont [PairP p1 p2]+            _ -> throwErrorMsg $ "extractPattern': IMPOSSIBLE: pattern " +++                          show p ++ " : " ++ show av+-}+        ConP pi n ps -> do+--          tv <- whnf' =<< extrTyp <$> lookupSymb n+          tv <- extrConType n av+          extractPatterns tv ps $ \ ps _ ->+            cont [ConP pi n ps]+        _ -> cont []++extrConType :: QName -> FTVal -> TypeCheck FTVal+extrConType c av = do+  ConSig { conPars, extrTyp, dataPars } <- lookupSymbQ c+  traceExtrM ("extrConType " ++ show c ++ " has extrTyp = " ++ show extrTyp)+  tv <- whnf' extrTyp+  numPars <- maybe (return dataPars) (const $ throwErrorMsg $ "NYI: extrConType for pattern parameters") conPars+  case numPars of+   0 -> return tv+   _ -> do+    case av of+      VApp (VDef (DefId DatK d)) vs -> do+        DataSig { positivity } <- lookupSymbQ d+        traceExtrM ("extrConType " ++ show c ++ "; data type has positivity = " ++ show positivity)+        let pars 0 pols vs = []+            pars n (pol:pols) vs | erased pol = VIrr : pars (n-1) pols vs+            pars n (pol:pols) (v:vs) = v : pars (n-1) pols vs+            pars n pols vs = error $ "pars " ++ show n ++ show pols ++ show vs+        piApps tv $ pars numPars positivity $ vs ++ repeat VIrr+{-+        let (pars, inds) = splitAt numPars vs+        piApps tv pars+-}+      _ -> piApps tv $ replicate numPars VIrr+--      _ -> throwErrorMsg $ "extrConType " ++ show c ++ ": expected datatype, found " ++ show av++-- extracting a term from a term -------------------------------------++extractInfer :: Expr -> TypeCheck (FExpr, FTVal)+extractInfer e = do+  case e of++    Var x -> (Var x,) . typ . domain <$> lookupName1 x++    App f e0 -> do+      let (er, e) = isErasedExpr e0+      (f, tv) <- extractInfer f+      fv <- funView tv+      case fv of+        EraseArg bv -> return (f,bv)+        Forall x dom fv -> do+          e <- extractTypeAt e (typ dom)+          bv <- app fv =<< whnf' e+          return $ (App f (erasedExpr e), bv)+        Arrow av bv -> return (if er then f else App f e, bv)+        NotFun -> return (if er then f else castExpr f `App` e, VIrr)++    Def f -> (Def f,) <$> do (whnf' . extrTyp) =<< lookupSymbQ (idName f)++    Pair{} -> throwErrorMsg $ "extractInfer: IMPOSSIBLE: pair " ++ show e+    -- other expressions are erased or types++    _ -> return (Irr, VIrr)++extractCheck :: Expr -> FTVal -> TypeCheck (FExpr)+extractCheck e tv = do+  case e of+    Lam dec y e -> do+      fv <- funView tv+      case fv of+        EraseArg bv        -> extractCheck e bv -- discard lambda+        Forall x dom fv    ->+          Lam (decor dom) y <$> do+            newWithGen y dom $ \ i xv ->+              extractCheck e =<< app fv (VGen i) -- no eta-expansion+        Arrow av bv        ->+          if erased dec then extractCheck e bv+           else Lam dec y <$> do+             new' y (defaultDomain av) $+               extractCheck e bv+        NotFun            -> castExpr <$>+          if erased dec then extractCheck e VIrr+           else Lam dec y <$> do+             new' y (defaultDomain VIrr) $+               extractCheck e VIrr++    LLet (TBind x dom0) tel e1 e2 | null tel -> do+      let dom = fmap Maybe.fromJust dom0+      if erased (decor dom) then extractCheck e2 tv else do -- discard let+       vdom <- Traversable.mapM whnf' dom         -- MiniAgda type val+       dom  <- Traversable.mapM extractType vdom  -- Fomega type+       vdom <- Traversable.mapM whnf' dom         -- Fomega type val+       e1  <- extractCheck e1 (typ vdom)+       LLet (TBind x (fmap Just dom)) emptyTel e1 <$> do+         new' x vdom $ extractCheck e2 tv++    Pair e1 e2 -> do+      view <- prodView tv+      let (av1,av2) = case view of+                        Prod av1 av2 -> (av1, av2)+                        _ -> (tv,tv) -- HACK!!+      Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2+{-+      case view of+        Prod av1 av2 -> Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2+        _ -> throwErrorMsg $ "extractCheck: tuple type expected " ++ show e ++ " : " ++ show tv+-}++    -- TODO: case++    _ -> fallback+  where+    fallback = do+      (e,tv') <- extractInfer e+      insertCast e tv tv'++insertCast :: FExpr -> FTVal -> FTVal -> TypeCheck FExpr+insertCast e tv1 tv2 = loop tv1 tv2 where+  loop tv1 tv2 =+    case (tv1,tv2) of+      (VIrr,_) -> return $ castExpr e+      (_,VIrr) -> return $ castExpr e+      _  -> return e -- TODO!++funView :: FTVal -> TypeCheck FunView+funView tv =+  case tv of+    -- erasure mark+    VQuant Pi x dom fv | erased (decor dom) && typ dom == VIrr ->+      EraseArg <$> app fv VIrr+    -- forall+    VQuant Pi x dom fv | erased (decor dom) ->+      return $ Forall x dom fv+    -- function type+    VQuant Pi x dom fv ->+      Arrow (typ dom) <$> app fv VIrr+    -- any other type can be a function type, but this needs casts!+    _ -> return NotFun -- $ Arrow VIrr VIrr++data FunView+  = Arrow    FTVal FTVal            -- A -> B+  | Forall   Name Domain FTVal      -- forall X:K. A+  | EraseArg FTVal                  -- [] -> B+  | NotFun                          -- ()++prodView :: FTVal -> TypeCheck ProdView+prodView tv =+  case tv of+    VQuant Sigma x dom fv -> Prod (typ dom) <$> app fv VIrr+    _                     -> return $ NotProd++data ProdView+  = Prod FTVal FTVal -- A * B+  | NotProd++-- extracting a kind from a value ------------------------------------++type FKind = Expr -- FKind ::= Set | FKind -> FKind | [Irr] -> FKind++star :: FKind+star = Sort $ Set Zero++extractSet :: Sort Val -> Maybe FKind+extractSet s =+  case s of+    SortC _ -> Nothing+    Set _   -> Just $ star+    CoSet _ -> Just $ star++-- keep irrelevant entries+extractKindTel :: Telescope -> TypeCheck FTelescope+extractKindTel (Telescope tel) = Telescope <$> loop tel where+  loop [] = return []+  loop (TBind x dom : tel) = do+    dom  <- Traversable.mapM whnf' dom+    dom' <- extractKindDom dom+    if erased (decor dom') then+      newIrr x $+        (TBind x dom' :) <$> loop tel+     else newTyVar x (typ dom') $ \ i -> do+        x <- nameOfGen i+        (TBind x dom' :) <$> loop tel++{-+-- keep irrelevant entries+extractKindTel :: Telescope -> TypeCheck FTelescope+extractKindTel tel = do+  tv     <- whnf' (teleToType tel star)+  Just k <- extractKind tv+  let (tel, s) = typeToTele k+  return tel+  -- throw away erasure marks+  -- return $ filter (\ tb -> not $ erased $ decor $ boundDom tb) tel+-}++extractKindDom :: Domain -> TypeCheck (Dom FKind)+extractKindDom dom =+  maybe (defaultIrrDom Irr) defaultDomain <$>+    if erased (decor dom) then return Nothing+     else extractKind (typ dom)++extractKind :: TVal -> TypeCheck (Maybe FKind)+extractKind tv =+  case tv of+    VSort s -> return $ extractSet s+    VMeasured mu vb -> extractKind vb+    VGuard beta vb -> extractKind vb+    VQuant Pi x dom fv -> new' x dom $ do+       bv  <- app fv VIrr+       mk' <- extractKind bv+       case mk' of+         Nothing -> return Nothing+         Just k' -> do+           dom' <- extractKindDom dom+           let x = fresh ""+           return $ Just $ pi (TBind x dom') k'+    _ -> return Nothing++-- extracting a type constructor from a value ------------------------++type FType = Expr+{- FType ::= Irr                 -- not expressible in Fomega+           | D FTypes            -- data type+           | X FTypes            -- type variable+           | FType -> FType      -- function type+           | [X:FKind] -> FType  -- polymorphic type+           | [Irr] -> FType      -- erasure marker+ -}++-- tyVarName i = fresh $ "a" ++ show i++newTyVar :: Name -> FKind -> (Int -> TypeCheck a) -> TypeCheck a+newTyVar x k cont = newWithGen x (defaultDomain (VClos emptyEnv k)) $+  \ i _ -> cont i                  -- store kinds unevaluated++addFKindTel :: FTelescope -> TypeCheck a -> TypeCheck a+addFKindTel (Telescope tel) = loop tel where+  loop []                  cont = cont+  loop (TBind x dom : tel) cont = newTyVar x (typ dom) $ \ _ ->+    loop tel cont++extractTeleVal :: TeleVal -> TypeCheck FTelescope+extractTeleVal = Telescope <.> loop where+  loop []          = return []+  loop (tb : vtel) = do+    tb <- Traversable.mapM extractType tb+    addBind tb $ do+      (tb :) <$> loop vtel++extractType :: TVal -> TypeCheck FType+extractType = extractTypeAt star++extractTypeAt :: FKind -> TVal -> TypeCheck FType+extractTypeAt k tv = do+  case (tv,k) of++    (VMeasured mu vb, _) -> extractTypeAt k vb+    (VGuard beta vb, _) -> extractTypeAt k vb++    -- relevant function space / sigma type --> non-dependent+    (VQuant pisig x dom fv, _) | not (erased (decor dom)) -> do+      a <- extractType (typ dom)+      -- new' x dom $ do+      bv <- app fv VIrr+      b  <- extractType bv+      let x = fresh ""+      return $ piSig pisig (TBind x (defaultDomain a)) b++    -- irrelevant function space --> forall or erasure marker+    (VQuant Pi x dom fv, _) | erased (decor dom) -> do+      mk <- extractKind (typ dom)+      case mk of+        Nothing -> do -- new' x dom $ do+          bv <- app fv VIrr+          b  <- extractType bv+          let x = fresh ""+          return $ pi (TBind x (defaultIrrDom Irr)) b+        Just k' -> do+          newTyVar x k' $ \ i -> do+            bv <- app fv $ VGen i+            b  <- extractType bv+            x  <- nameOfGen i+            return $ pi (TBind x (defaultIrrDom k')) b++    (VApp (VDef (DefId DatK n)) vs, _) -> do+      k  <- extrTyp <$> lookupSymbQ n  -- get kind of dname from signature+      as <- extractTypes k vs  -- turn vs into types as at kind k+      return $ foldl App (Def (DefId DatK n)) as++    (VGen i,_) -> do+--      VClos _ k <- (typ . fromOne . domain) <$> lookupGen i  -- get kind of var from cxt+      Var <$> nameOfGen i+      -- return $ Var (tyVarName i)++    (VApp (VGen i) vs,_) -> do+      VClos _ k <- (typ . fromOne . domain) <$> lookupGen i  -- get kind of var from cxt+      as <- extractTypes k vs  -- turn vs into types as at kind k+      x <- nameOfGen i+      return $ foldl App (Var x) as++    (VLam x env e, Quant Pi (TBind _ dom) k) | erased (decor dom) -> do+      tv <- whnf (update env x VIrr) e+      extractTypeAt k tv++    (VLam x env e, Quant Pi (TBind _ dom) k) -> newTyVar x (typ dom) $ \ i -> do+      tv <- whnf (update env x (VGen i)) e+      x  <- nameOfGen i+      Lam defaultDec x <$> extractTypeAt k tv++    (VLam{},_) -> error $ "panic! extractTypeAt " ++ show (tv,k)++    (VSing _ tv,_) -> extractTypeAt k tv++    (VUp v _,_)    -> extractTypeAt k v++    _ -> return Irr++extractTypes :: FKind -> [TVal] -> TypeCheck [FType]+extractTypes k vs =+  case (k,vs) of+    (_, []) -> return []+    (Quant Pi (TBind _ dom) k, v:vs) | erased (decor dom) -> extractTypes k vs+    (Quant Pi (TBind _ dom) k, v:vs) -> do+      v  <- whnfClos v+      a  <- extractTypeAt (typ dom) v+      as <- extractTypes k vs+      return $ a : as+    _ -> error $ "panic! extractTypes  " ++ show k ++ "  " ++ show vs++-- auxiliary functions -----------------------------------------------++{- this is setExtrTyp+addFTypeSig :: Name -> FType -> TypeCheck ()+addFTypeSig n t = modifySig n (\ item -> item { extrTyp = t })+-}
+ src/HsSyntax.hs view
@@ -0,0 +1,129 @@+{- 2010-09-17 haskell syntax tools -}++module HsSyntax where++import Abstract (PiSigma(..))+import Language.Haskell.Exts.Syntax++noLoc :: SrcLoc+noLoc = SrcLoc "" 0 0++mkQual :: String -> String -> QName+mkQual m s = Qual (ModuleName m) (Ident s)++mkModule :: [Decl] -> Module+mkModule hs = Module noLoc main_mod pragmas warning exports imports decls where+  pragmas = [ LanguagePragma noLoc $ map Ident+    [ "NoImplicitPrelude"+    , "GADTs"+    , "KindSignatures"+    ]]+  warning = Nothing+  exports = Nothing+  imports =+    [ mkQualImport "GHC.Show" "Show"+    , mkQualImport "System.IO" "IO"+    , mkQualImport "Unsafe.Coerce" "Coerce"+    ]+  decls   = hs +++    [ TypeSig noLoc [ main_name ] io+    , FunBind [ mkClause main_name [] rhs ]+    ] where rhs  = Var (mkQual "IO" "putStrLn") `App` Lit (String "Hello, world!")+            io   = TyCon (mkQual "IO" "IO") `TyApp` unit_tycon++mkQualImport :: String -> String -> ImportDecl+mkQualImport modName asName =+  ImportDecl+  { importLoc       = noLoc+  , importModule    = ModuleName modName+  , importQualified = True+  , importSrc       = False+  , importPkg       = Nothing+  , importAs        = Just $ ModuleName asName+  , importSpecs     = Nothing+  }++noContext = []+noDeriving = []+noTyVarBind = []+showDeriving = (mkQual "Show" "Show", [])++mkDataDecl :: Name -> [TyVarBind] -> Kind -> [GadtDecl] -> Decl+mkDataDecl n tel k cs = GDataDecl noLoc DataType noContext n tel (Just k) cs [showDeriving]++mkConDecl :: Name -> Type -> GadtDecl+mkConDecl n t = GadtDecl noLoc n [] t++mkKindFun :: Kind -> Kind -> Kind+mkKindFun = KindFn+{-+mkKindFun k k' = parens k `KindFn` k'+      where parens H.KindStar = H.KindStar+            parens k          = H.KindParen k+-}++mkTyPiSig :: PiSigma -> Type -> Type -> Type+mkTyPiSig Pi    = mkTyFun+mkTyPiSig Sigma = mkTyProd++mkTyProd :: Type -> Type -> Type+mkTyProd a b = TyTuple Boxed [a,b]++mkTyFun :: Type -> Type -> Type+mkTyFun = TyFun+-- mkTyFun a b = mkTyParen a `TyFun` b++mkForall :: Name -> Kind -> Type -> Type+mkForall x k t = TyForall (Just $ [KindedVar x k]) noContext t++mkTyParen :: Type -> Type+mkTyParen a@(TyVar{}) = a+mkTyParen a@(TyCon{}) = a+mkTyParen a = TyParen a++mkTyApp :: Type -> Type -> Type+mkTyApp f a = TyApp f a++noBinds = BDecls []++mkTypeSig :: Name -> Type -> Decl+mkTypeSig x t = TypeSig noLoc [x] t++-- create a simple function clause x = t+mkLet :: Name -> Exp -> Decl+mkLet x e = FunBind [mkClause x [] e]++mkClause :: Name -> [Pat] -> Exp -> Match+mkClause f ps e = Match noLoc f ps Nothing (UnGuardedRhs e) Nothing++mkCast :: Exp -> Exp+mkCast e = Var (mkQual "Coerce" "unsafeCoerce") `App` e++mkCon :: Name -> Exp+mkCon = Con . UnQual++mkVar :: Name -> Exp+mkVar = Var . UnQual++mkLam :: Name -> Exp -> Exp+mkLam x (Lambda _ ps e) = Lambda noLoc (PVar x : ps) e+mkLam x  e              = Lambda noLoc [PVar x] e++mkParen :: Exp -> Exp+mkParen e@(Var{}) = e+mkParen e@(Con{}) = e+mkParen e = Paren e++mkApp :: Exp -> Exp -> Exp+mkApp f e = App f e -- (mkParen e)++mkLLet :: Name -> Maybe Type -> Exp -> Exp -> Exp+mkLLet x t e e' = Let (BDecls [mkLet x e]) e'++mkPair :: Exp -> Exp -> Exp+mkPair e1 e2 = Tuple Boxed [e1,e2]++{- this is already predefined as unit_con+hsDummyExp :: HsExp+hsDummyExp = HsCon $ Special $ HsUnitCon  -- Haskell's '()'+-}
+ src/Lexer.hs view
@@ -0,0 +1,635 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+{-# LINE 2 "Lexer.x" #-}+++module Lexer where+++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Array.Base (unsafeAt)+#else+import Array+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 8 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 8 "<command-line>" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.+++++++import Data.Word (Word8)+{-# LINE 28 "templates/wrappers.hs" #-}++import Data.Char (ord)+import qualified Data.Bits++-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+utf8Encode :: Char -> [Word8]+utf8Encode = map fromIntegral . go . ord+ where+  go oc+   | oc <= 0x7f       = [oc]++   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)+                        , 0x80 + oc Data.Bits..&. 0x3f+                        ]++   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)+                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+                        , 0x80 + oc Data.Bits..&. 0x3f+                        ]+   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)+                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)+                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+                        , 0x80 + oc Data.Bits..&. 0x3f+                        ]++++type Byte = Word8++-- -----------------------------------------------------------------------------+-- The input type+++type AlexInput = (AlexPosn,     -- current position,+                  Char,         -- previous char+                  [Byte],       -- pending bytes on current char+                  String)       -- current input string++ignorePendingBytes :: AlexInput -> AlexInput+ignorePendingBytes (p,c,ps,s) = (p,c,[],s)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (p,c,bs,s) = c++alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)+alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s))+alexGetByte (p,c,[],[]) = Nothing+alexGetByte (p,_,[],(c:s))  = let p' = alexMove p c +                                  (b:bs) = utf8Encode c+                              in p' `seq`  Just (b, (p', c, bs, s))+++{-# LINE 101 "templates/wrappers.hs" #-}++{-# LINE 119 "templates/wrappers.hs" #-}++{-# LINE 137 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text.  It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.+++data AlexPosn = AlexPn !Int !Int !Int+        deriving (Eq,Show)++alexStartPos :: AlexPosn+alexStartPos = AlexPn 0 1 1++alexMove :: AlexPosn -> Char -> AlexPosn+alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1)+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1+alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)+++-- -----------------------------------------------------------------------------+-- Default monad++{-# LINE 271 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)++{-# LINE 374 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper++{-# LINE 401 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version++{-# LINE 421 "templates/wrappers.hs" #-}++{-# LINE 437 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.+++--alexScanTokens :: String -> [token]+alexScanTokens str = go (alexStartPos,'\n',[],str)+  where go inp@(pos,_,_,str) =+          case alexScan inp 0 of+                AlexEOF -> []+                AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column)+                AlexSkip  inp' len     -> go inp'+                AlexToken inp' len act -> act pos (take len str) : go inp'++++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version++{-# LINE 470 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.++alex_tab_size :: Int+alex_tab_size = 8+alex_base :: Array Int Int+alex_base = listArray (0,160) [-8,10,221,202,349,560,688,415,0,801,0,929,1057,1313,1249,0,0,1362,0,1427,1683,1619,0,-3,1865,2076,0,1837,2293,2377,2461,2545,2629,2713,2797,2881,2965,3049,3133,3217,3301,3385,3469,3553,3637,3721,3805,3889,0,0,3973,0,0,4057,-34,0,0,0,0,0,-50,0,0,0,0,0,-30,-31,0,0,0,0,0,0,0,0,0,-36,0,70,4141,4225,4309,4393,4477,4561,4645,4729,4813,4897,4981,5065,5149,5233,5317,5401,5485,5569,5653,5737,5821,5905,5989,6073,6157,6241,6325,6409,6493,6577,6661,6745,6829,6913,6997,7081,7165,7249,7333,7417,7501,7585,7669,7753,7837,7921,8005,8089,8173,8257,8341,8425,8509,8593,8677,8761,8845,8929,9013,9097,9181,9265,9349,9433,9517,9601,9685,9769,9853,9937,10021,10105,10189,10273,10357,10441,10525,10609,10693,10777,10861]++alex_table :: Array Int Int+alex_table = listArray (0,11116) [0,23,23,23,23,23,23,23,23,23,23,5,49,65,24,0,0,0,0,0,0,0,0,0,23,73,0,51,52,23,71,72,58,59,69,66,63,67,64,68,79,79,79,79,79,79,79,79,79,79,62,61,77,74,78,2,0,124,124,116,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,100,110,124,124,124,124,124,124,56,75,57,70,76,48,124,124,106,93,134,90,124,124,152,124,124,94,102,124,124,120,124,117,112,128,124,124,124,124,124,124,54,60,55,79,79,79,79,79,79,79,79,79,79,0,0,0,0,0,0,0,26,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,25,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,20,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,1,14,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,4,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,7,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,19,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,21,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,20,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,21,4,18,18,18,18,18,18,18,18,18,18,18,18,18,18,19,6,16,16,16,17,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,28,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,29,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,31,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,35,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,41,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,42,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,43,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,45,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,50,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,159,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,96,124,124,124,124,124,124,124,114,124,124,124,124,124,124,124,124,124,124,124,157,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,156,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,83,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,145,124,124,124,154,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,153,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,151,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,150,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,84,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,85,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,149,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,148,124,124,124,138,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,147,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,146,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,130,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,144,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,143,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,141,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,92,124,124,124,124,124,124,107,124,124,124,124,124,124,135,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,97,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,140,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,99,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,139,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,101,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,137,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,104,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,136,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,133,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,111,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,113,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,115,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,131,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,129,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,119,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,121,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,127,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,126,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,123,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,122,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,118,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,132,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,109,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,108,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,105,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,98,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,95,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,103,124,91,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,142,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,89,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,88,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,87,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,86,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,155,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,82,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,158,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,81,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,80,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,53,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,47,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,46,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,44,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,40,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,39,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,125,38,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,37,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,36,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,34,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,33,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,32,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,30,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,27,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,160,0,0,0,0,0,0,0,0,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,0,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,160,0,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]++alex_check :: Array Int Int+alex_check = listArray (0,11116) [-1,9,10,11,12,13,9,10,11,12,13,45,62,43,45,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,61,-1,35,36,32,38,62,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,45,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,124,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,125,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,125,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,10,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1]++alex_deflt :: Array Int Int+alex_deflt = listArray (0,160) [-1,5,5,-1,-1,5,-1,15,15,8,8,-1,-1,5,5,5,18,18,22,22,24,24,24,-1,24,5,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1]++alex_accept = listArray (0::Int,160) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAcc (alex_action_6),AlexAcc (alex_action_7),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAcc (alex_action_30),AlexAcc (alex_action_31),AlexAcc (alex_action_32),AlexAcc (alex_action_33),AlexAcc (alex_action_34),AlexAcc (alex_action_35),AlexAcc (alex_action_36),AlexAcc (alex_action_37),AlexAcc (alex_action_38),AlexAcc (alex_action_39),AlexAcc (alex_action_40),AlexAcc (alex_action_41),AlexAcc (alex_action_42),AlexAcc (alex_action_43),AlexAcc (alex_action_44),AlexAcc (alex_action_45),AlexAcc (alex_action_46),AlexAcc (alex_action_47),AlexAcc (alex_action_48),AlexAcc (alex_action_49),AlexAcc (alex_action_50),AlexAcc (alex_action_51),AlexAcc (alex_action_52),AlexAcc (alex_action_53),AlexAcc (alex_action_54),AlexAcc (alex_action_55),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_57)]+{-# LINE 80 "Lexer.x" #-}++data Token = Id String AlexPosn+           | QualId (String, String) AlexPosn+     	   | Number String AlexPosn+     	   | Sized AlexPosn+           | Data AlexPosn+	   | CoData AlexPosn+	   | Record AlexPosn+	   | Fields AlexPosn+	   | Mutual AlexPosn+           | Fun AlexPosn+           | CoFun AlexPosn+           | Pattern AlexPosn+	   | Case AlexPosn+	   | Def AlexPosn+	   | Let AlexPosn+	   | In AlexPosn+           | Type AlexPosn+           | Set AlexPosn+           | CoSet AlexPosn+	   | Eval AlexPosn+	   | Fail AlexPosn+	   | Check AlexPosn+	   | TrustMe AlexPosn+	   | Impredicative AlexPosn+           -- size type+           | Size AlexPosn+           | Infty AlexPosn+           | Succ AlexPosn+           | Max AlexPosn+           --+           | LTri AlexPosn+           | RTri AlexPosn+           | AngleOpen AlexPosn+           | AngleClose AlexPosn+           | BrOpen AlexPosn+           | BrClose AlexPosn+           | BracketOpen AlexPosn+           | BracketClose AlexPosn+           | PrOpen AlexPosn+           | PrClose AlexPosn+           | Bar AlexPosn+           | Sem AlexPosn+           | Col AlexPosn+	   | Comma AlexPosn+	   | Dot AlexPosn+           | Arrow AlexPosn+           | Leq AlexPosn+           | Eq AlexPosn+	   | PlusPlus AlexPosn+	   | Plus AlexPosn+	   | Minus AlexPosn+	   | Slash AlexPosn+	   | Times AlexPosn+	   | Hat AlexPosn+	   | Amp AlexPosn+           | Lam AlexPosn+           | Underscore AlexPosn+           | NotUsed AlexPosn -- so happy doesn't generate overlap case pattern warning+             deriving (Eq)++qualId s p = let (m, '.':n) = break (== '.') s in QualId (m,n) p++prettyTok :: Token -> String+prettyTok c = "\"" ++ tk ++ "\" at " ++ (prettyAlexPosn pos) where+  (tk,pos) = case c of+    (Id s p) -> (show s,p)+    (QualId (m, n) p) -> (show m ++ "." ++ show n, p)+    (Number i p) -> (i,p)+    Sized p -> ("sized",p)+    Data p -> ("data",p)+    CoData p -> ("codata",p)+    Record p -> ("record",p)+    Fields p -> ("fields",p)+    Mutual p -> ("mutual",p)+    Fun p -> ("fun",p)+    CoFun p -> ("cofun",p)+    Pattern p -> ("pattern",p)+    Case p -> ("case",p)+    Def p -> ("def",p)+    Let p -> ("let",p)+    In p -> ("in",p)+    Eval p -> ("eval",p)+    Fail p -> ("fail",p)+    Check p -> ("check",p)+    TrustMe p -> ("trustme",p)+    Impredicative p -> ("impredicative",p)+    Type p -> ("Type",p)+    Set p -> ("Set",p)+    CoSet p -> ("CoSet",p)+    Size p -> ("Size",p)+    Infty p -> ("#",p)+    Succ p -> ("$",p)+    Max p -> ("max",p)+    LTri p -> ("<|",p)+    RTri p -> ("|>",p)+    AngleOpen p -> ("<",p)+    AngleClose p -> (">",p)+    BrOpen p -> ("{",p)+    BrClose p -> ("}",p)+    BracketOpen p -> ("[",p)+    BracketClose p -> ("]",p)+    PrOpen p -> ("(",p)+    PrClose p -> (")",p)+    Bar p -> ("|",p)+    Sem p -> (";",p)+    Col p -> (":",p)+    Comma p -> (",",p)+    Dot p -> (".",p)+    Arrow p -> ("->",p)+    Leq p -> ("<=",p)+    Eq p -> ("=",p)+    PlusPlus p -> ("++",p)+    Plus p -> ("+",p)+    Minus p -> ("-",p)+    Slash p -> ("/",p)+    Times p -> ("*",p)+    Hat p -> ("^",p)+    Amp p -> ("&",p)+    Lam p -> ("\\",p)+    Underscore p -> ("_",p)+    _ -> error "not used"+++prettyAlexPosn (AlexPn _ line row) = "line " ++ show line ++ ", row " ++ show row++tok f p s = f p s+++alex_action_3 =  tok (\p s -> Sized p) +alex_action_4 =  tok (\p s -> Data p) +alex_action_5 =  tok (\p s -> CoData p) +alex_action_6 =  tok (\p s -> Record p) +alex_action_7 =  tok (\p s -> Fields p) +alex_action_8 =  tok (\p s -> Fun p) +alex_action_9 =  tok (\p s -> CoFun p) +alex_action_10 =  tok (\p s -> Pattern p) +alex_action_11 =  tok (\p s -> Case p) +alex_action_12 =  tok (\p s -> Def p) +alex_action_13 =  tok (\p s -> Let p) +alex_action_14 =  tok (\p s -> In p) +alex_action_15 =  tok (\p s -> Eval p)+alex_action_16 =  tok (\p s -> Fail p)+alex_action_17 =  tok (\p s -> Check p)+alex_action_18 =  tok (\p s -> TrustMe p)+alex_action_19 =  tok (\p s -> Impredicative p)+alex_action_20 =  tok (\p s -> Mutual p) +alex_action_21 =  tok (\p s -> Type p) +alex_action_22 =  tok (\p s -> Set p) +alex_action_23 =  tok (\p s -> CoSet p) +alex_action_24 =  tok (\p s -> LTri p) +alex_action_25 =  tok (\p s -> RTri p) +alex_action_26 =  tok (\p s -> Size p) +alex_action_27 =  tok (\p s -> Infty p) +alex_action_28 =  tok (\p s -> Succ p) +alex_action_29 =  tok (\p s -> Max p) +alex_action_30 =  tok (\p s -> BrOpen p) +alex_action_31 =  tok (\p s -> BrClose p) +alex_action_32 =  tok (\p s -> BracketOpen p) +alex_action_33 =  tok (\p s -> BracketClose p) +alex_action_34 =  tok (\p s -> PrOpen p) +alex_action_35 =  tok (\p s -> PrClose p) +alex_action_36 =  tok (\p s -> Bar p) +alex_action_37 =  tok (\p s -> Sem p) +alex_action_38 =  tok (\p s -> Col p) +alex_action_39 =  tok (\p s -> Comma p) +alex_action_40 =  tok (\p s -> Dot p) +alex_action_41 =  tok (\p s -> PlusPlus p) +alex_action_42 =  tok (\p s -> Plus p) +alex_action_43 =  tok (\p s -> Minus p) +alex_action_44 =  tok (\p s -> Slash p) +alex_action_45 =  tok (\p s -> Times p) +alex_action_46 =  tok (\p s -> Hat p) +alex_action_47 =  tok (\p s -> Amp p) +alex_action_48 =  tok (\p s -> Arrow p)  +alex_action_49 =  tok (\p s -> Leq p)  +alex_action_50 =  tok (\p s -> Eq p) +alex_action_51 =  tok (\p s -> Lam p) +alex_action_52 =  tok (\p s -> Underscore p) +alex_action_53 =  tok (\p s -> AngleOpen p) +alex_action_54 =  tok (\p s -> AngleClose p) +alex_action_55 =  tok (\p s -> (Number s p )) +alex_action_56 =  tok (\p s -> (Id s p )) +alex_action_57 =  tok (\p s -> (qualId s p)) +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}++++++++# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 7 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 21 "templates/GenericTemplate.hs" #-}++{-# LINE 51 "templates/GenericTemplate.hs" #-}++{-# LINE 72 "templates/GenericTemplate.hs" #-}+alexIndexInt16OffAddr arr off = arr ! off+++{-# LINE 93 "templates/GenericTemplate.hs" #-}+alexIndexInt32OffAddr arr off = arr ! off+++{-# LINE 105 "templates/GenericTemplate.hs" #-}+quickIndex arr i = arr ! i+++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+  = AlexEOF+  | AlexError  !AlexInput+  | AlexSkip   !AlexInput !Int+  | AlexToken  !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (sc)+  = alexScanUser undefined input (sc)++alexScanUser user input (sc)+  = case alex_scan_tkn user input (0) input sc AlexNone of+        (AlexNone, input') ->+                case alexGetByte input of+                        Nothing -> ++++                                   AlexEOF+                        Just _ ->++++                                   AlexError input'++        (AlexLastSkip input'' len, _) ->++++                AlexSkip input'' len++        (AlexLastAcc k input''' len, _) ->++++                AlexToken input''' len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+  input `seq` -- strict in the input+  let +        new_acc = (check_accs (alex_accept `quickIndex` (s)))+  in+  new_acc `seq`+  case alexGetByte input of+     Nothing -> (new_acc, input)+     Just (c, new_input) -> ++++      case fromIntegral c of { (ord_c) ->+        let+                base   = alexIndexInt32OffAddr alex_base s+                offset = (base + ord_c)+                check  = alexIndexInt16OffAddr alex_check offset+                +                new_s = if (offset >= (0)) && (check == ord_c)+                          then alexIndexInt16OffAddr alex_table offset+                          else alexIndexInt16OffAddr alex_deflt s+        in+        case new_s of+            (-1) -> (new_acc, input)+                -- on an error, we want to keep the input *before* the+                -- character that failed, not after.+            _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len)+                                                -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+                        new_input new_s new_acc+      }+  where+        check_accs (AlexAccNone) = last_acc+        check_accs (AlexAcc a  ) = AlexLastAcc a input (len)+        check_accs (AlexAccSkip) = AlexLastSkip  input (len)++        check_accs (AlexAccPred a predx rest)+           | predx user orig_input (len) input+           = AlexLastAcc a input (len)+           | otherwise+           = check_accs rest+        check_accs (AlexAccSkipPred predx rest)+           | predx user orig_input (len) input+           = AlexLastSkip input (len)+           | otherwise+           = check_accs rest+++data AlexLastAcc a+  = AlexNone+  | AlexLastAcc a !AlexInput !Int+  | AlexLastSkip  !AlexInput !Int++instance Functor AlexLastAcc where+    fmap _ AlexNone = AlexNone+    fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z+    fmap _ (AlexLastSkip x y) = AlexLastSkip x y++data AlexAcc a user+  = AlexAccNone+  | AlexAcc a+  | AlexAccSkip++  | AlexAccPred a   (AlexAccPred user) (AlexAcc a user)+  | AlexAccSkipPred (AlexAccPred user) (AlexAcc a user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+  = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input)++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (sc) user _ _ input = +     case alex_scan_tkn user input (0) input sc AlexNone of+          (AlexNone, _) -> False+          _ -> True+        -- TODO: there's no need to find the longest+        -- match when checking the right context, just+        -- the first match will do.
+ src/Lexer.x view
@@ -0,0 +1,208 @@++{++module Lexer where++}++%wrapper "posn"++$digit = 0-9			-- digits+$alpha = [a-zA-Z]		-- alphabetic characters+$u     = [ . \n ]               -- universal: any character+@ident = $alpha ($alpha | $digit | \_ | \')*  -- identifier++tokens :-++$white+				;+"--".*				;+"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;+++sized	    	     	   	{ tok (\p s -> Sized p) }+data				{ tok (\p s -> Data p) }+codata				{ tok (\p s -> CoData p) }+record				{ tok (\p s -> Record p) }+fields                          { tok (\p s -> Fields p) }+fun				{ tok (\p s -> Fun p) }+cofun				{ tok (\p s -> CoFun p) }+pattern                         { tok (\p s -> Pattern p) }+case                            { tok (\p s -> Case p) }+def				{ tok (\p s -> Def p) }+let				{ tok (\p s -> Let p) }+in				{ tok (\p s -> In p) }+eval				{ tok (\p s -> Eval p)}+fail				{ tok (\p s -> Fail p)}+check				{ tok (\p s -> Check p)}+trustme				{ tok (\p s -> TrustMe p)}+impredicative                 	{ tok (\p s -> Impredicative p)}+mutual				{ tok (\p s -> Mutual p) }+Type				{ tok (\p s -> Type p) }+Set				{ tok (\p s -> Set p) }+CoSet				{ tok (\p s -> CoSet p) }+"<|"                            { tok (\p s -> LTri p) }+"|>"                            { tok (\p s -> RTri p) }+Size				{ tok (\p s -> Size p) }+\#				{ tok (\p s -> Infty p) }+\$				{ tok (\p s -> Succ p) }+max                             { tok (\p s -> Max p) }++\{				{ tok (\p s -> BrOpen p) }+\}				{ tok (\p s -> BrClose p) }+\[				{ tok (\p s -> BracketOpen p) }+\]				{ tok (\p s -> BracketClose p) }+\(				{ tok (\p s -> PrOpen p) }+\)				{ tok (\p s -> PrClose p) }+\|				{ tok (\p s -> Bar p) }+\;				{ tok (\p s -> Sem p) }+\:				{ tok (\p s -> Col p) }+\,				{ tok (\p s -> Comma p) }+\.				{ tok (\p s -> Dot p) }+\+\+                            { tok (\p s -> PlusPlus p) }+\+				{ tok (\p s -> Plus p) }+\-				{ tok (\p s -> Minus p) }+\/				{ tok (\p s -> Slash p) }+\*				{ tok (\p s -> Times p) }+\^				{ tok (\p s -> Hat p) }+\&				{ tok (\p s -> Amp p) }+"->"				{ tok (\p s -> Arrow p)  }+"<="                            { tok (\p s -> Leq p)  }+=				{ tok (\p s -> Eq p) }+\\				{ tok (\p s -> Lam p) }+\_				{ tok (\p s -> Underscore p) }+\<                              { tok (\p s -> AngleOpen p) }+\>                              { tok (\p s -> AngleClose p) }++[$digit]+		        { tok (\p s -> (Number s p )) }+@ident                          { tok (\p s -> (Id s p )) }+@ident \. @ident                { tok (\p s -> (qualId s p)) }++{+data Token = Id String AlexPosn+           | QualId (String, String) AlexPosn+     	   | Number String AlexPosn+     	   | Sized AlexPosn+           | Data AlexPosn+	   | CoData AlexPosn+	   | Record AlexPosn+	   | Fields AlexPosn+	   | Mutual AlexPosn+           | Fun AlexPosn+           | CoFun AlexPosn+           | Pattern AlexPosn+	   | Case AlexPosn+	   | Def AlexPosn+	   | Let AlexPosn+	   | In AlexPosn+           | Type AlexPosn+           | Set AlexPosn+           | CoSet AlexPosn+	   | Eval AlexPosn+	   | Fail AlexPosn+	   | Check AlexPosn+	   | TrustMe AlexPosn+	   | Impredicative AlexPosn+           -- size type+           | Size AlexPosn+           | Infty AlexPosn+           | Succ AlexPosn+           | Max AlexPosn+           --+           | LTri AlexPosn+           | RTri AlexPosn+           | AngleOpen AlexPosn+           | AngleClose AlexPosn+           | BrOpen AlexPosn+           | BrClose AlexPosn+           | BracketOpen AlexPosn+           | BracketClose AlexPosn+           | PrOpen AlexPosn+           | PrClose AlexPosn+           | Bar AlexPosn+           | Sem AlexPosn+           | Col AlexPosn+	   | Comma AlexPosn+	   | Dot AlexPosn+           | Arrow AlexPosn+           | Leq AlexPosn+           | Eq AlexPosn+	   | PlusPlus AlexPosn+	   | Plus AlexPosn+	   | Minus AlexPosn+	   | Slash AlexPosn+	   | Times AlexPosn+	   | Hat AlexPosn+	   | Amp AlexPosn+           | Lam AlexPosn+           | Underscore AlexPosn+           | NotUsed AlexPosn -- so happy doesn't generate overlap case pattern warning+             deriving (Eq)++qualId s p = let (m, '.':n) = break (== '.') s in QualId (m,n) p++prettyTok :: Token -> String+prettyTok c = "\"" ++ tk ++ "\" at " ++ (prettyAlexPosn pos) where+  (tk,pos) = case c of+    (Id s p) -> (show s,p)+    (QualId (m, n) p) -> (show m ++ "." ++ show n, p)+    (Number i p) -> (i,p)+    Sized p -> ("sized",p)+    Data p -> ("data",p)+    CoData p -> ("codata",p)+    Record p -> ("record",p)+    Fields p -> ("fields",p)+    Mutual p -> ("mutual",p)+    Fun p -> ("fun",p)+    CoFun p -> ("cofun",p)+    Pattern p -> ("pattern",p)+    Case p -> ("case",p)+    Def p -> ("def",p)+    Let p -> ("let",p)+    In p -> ("in",p)+    Eval p -> ("eval",p)+    Fail p -> ("fail",p)+    Check p -> ("check",p)+    TrustMe p -> ("trustme",p)+    Impredicative p -> ("impredicative",p)+    Type p -> ("Type",p)+    Set p -> ("Set",p)+    CoSet p -> ("CoSet",p)+    Size p -> ("Size",p)+    Infty p -> ("#",p)+    Succ p -> ("$",p)+    Max p -> ("max",p)+    LTri p -> ("<|",p)+    RTri p -> ("|>",p)+    AngleOpen p -> ("<",p)+    AngleClose p -> (">",p)+    BrOpen p -> ("{",p)+    BrClose p -> ("}",p)+    BracketOpen p -> ("[",p)+    BracketClose p -> ("]",p)+    PrOpen p -> ("(",p)+    PrClose p -> (")",p)+    Bar p -> ("|",p)+    Sem p -> (";",p)+    Col p -> (":",p)+    Comma p -> (",",p)+    Dot p -> (".",p)+    Arrow p -> ("->",p)+    Leq p -> ("<=",p)+    Eq p -> ("=",p)+    PlusPlus p -> ("++",p)+    Plus p -> ("+",p)+    Minus p -> ("-",p)+    Slash p -> ("/",p)+    Times p -> ("*",p)+    Hat p -> ("^",p)+    Amp p -> ("&",p)+    Lam p -> ("\\",p)+    Underscore p -> ("_",p)+    _ -> error "not used"+++prettyAlexPosn (AlexPn _ line row) = "line " ++ show line ++ ", row " ++ show row++tok f p s = f p s++}
+ src/Main.hs view
@@ -0,0 +1,136 @@+module Main where++import Prelude hiding (null)++import System.Environment+import System.Exit+import System.IO (stdout, hSetBuffering, BufferMode(..))++import qualified Language.Haskell.Exts.Syntax as H+import qualified Language.Haskell.Exts.Pretty as H++import Lexer+import Parser++import qualified Concrete as C+import qualified Abstract as A+import Abstract (Name)+import ScopeChecker+import Value+import TCM+import TypeChecker+import Extract+import ToHaskell++import Util++main :: IO ()+main = do+  hSetBuffering stdout NoBuffering+  putStrLn "MiniAgda by Andreas Abel and Karl Mehltretter"+  args <- getArgs+  mapM_ mainFile args++mainFile :: String -> IO ()+mainFile fileName = do+  putStrLn $ "--- opening " ++ show fileName ++ " ---"+  file <- readFile fileName+  let t = alexScanTokens file+  let cdecls =  parse t+  -- putStrLn "--- parsing ---"+  -- mapM (putStrLn . show) cdecls+  putStrLn "--- scope checking ---"+  adecls <- doScopeCheck cdecls+  -- mapM (putStrLn . show) adecls+  putStrLn "--- type checking ---"+  (edecls, sig) <- doTypeCheck adecls+  putStrLn "--- evaluating ---"+  showAll sig adecls+{-+  putStrLn "--- extracting ---"+  edecls <- doExtract sig edecls+  hsmodule <- doTranslate edecls+  putStrLn $ H.prettyPrint hsmodule+  -- printHsDecls hsdecls+-}+  putStrLn $ "--- closing " ++ show fileName ++ " ---"++-- print extracted program++ppHsMode :: H.PPHsMode+ppHsMode = H.PPHsMode  -- H.defaultMode+  { H.classIndent  = 2+  , H.doIndent     = 3+  , H.caseIndent   = 3+  , H.letIndent    = 4+  , H.whereIndent  = 2+  , H.onsideIndent = 1+  , H.spacing      = False+  , H.layout       = H.PPOffsideRule+  , H.linePragmas  = False+  }++printHsDecls :: [H.Decl] -> IO ()+printHsDecls hs = mapM_ (putStrLn . H.prettyPrintWithMode ppHsMode) hs++-- all let declarations+allLet :: Signature -> [A.Declaration] -> [(Name,A.Expr)]+allLet sig [] = []+allLet sig (decl:xs) =+    case decl of+      (A.LetDecl True n tel _ e) | null tel ->+          (n,e):(allLet sig xs)+      _ -> allLet sig xs+++showAll :: Signature -> [A.Declaration] -> IO ()+showAll sig decl = mapM_ (showLet sig) $ allLet sig decl++showLet :: Signature -> (Name,A.Expr) -> IO ()+showLet sig (n,e) = do+  r <- doWhnf sig e+  case r of+    Right (v,_) -> putStrLn $ show n ++ " has whnf " ++ show v+    Left err    -> do putStrLn $ "error during evaluation:\n" ++ show err+                      exitFailure+  r <- doNf sig e+  case r of+    Right (v,_) -> putStrLn $ show n ++ " evaluates to " ++ show v+    Left err    -> do putStrLn $ "error during evaluation:\n" ++ show err+                      exitFailure++doExtract :: Signature -> [A.EDeclaration] -> IO [A.EDeclaration]+doExtract sig decls = do+  k <- runExtract sig $ extractDecls decls+  case k of+    Left err -> do+      putStrLn $ "error during extraction:\n" ++ show err+      exitFailure+    Right (hs, _) ->+      return hs++doTranslate :: [A.EDeclaration] -> IO H.Module+doTranslate decls = do+  k <- runTranslate $ translateModule decls+  case k of+    Left err -> do+      putStrLn $ "error during extraction:\n" ++ show err+      exitFailure+    Right hs ->+      return hs++doTypeCheck :: [A.Declaration] -> IO ([A.EDeclaration], Signature)+doTypeCheck decls = do+  k <- typeCheck decls+  case k of+    Left err -> do+      putStrLn $ "error during typechecking:\n" ++ show err+      exitFailure+    Right (edecls, st) ->+      return (edecls, signature st)++doScopeCheck :: [C.Declaration] -> IO [A.Declaration]+doScopeCheck decl = case scopeCheck decl of+     Left err -> do putStrLn $ "scope check error: " ++ show err+                    exitFailure+     Right (decl',_) -> return $ decl'
+ src/Parser.hs view
@@ -0,0 +1,6844 @@+{-# OPTIONS_GHC -w #-}+{-# LANGUAGE BangPatterns #-}+module Parser where++import qualified Lexer as T+import qualified Concrete as C++import Abstract (Decoration(..),Dec,defaultDec,Override(..))+import Polarity (Pol(..))+import qualified Abstract as A+import qualified Polarity as A+import Concrete (Name,patApp)+import Control.Applicative(Applicative(..))+import Control.Monad (ap)++-- parser produced by Happy Version 1.19.5++data HappyAbsSyn +	= HappyTerminal (T.Token)+	| HappyErrorToken Int+	| HappyAbsSyn4 ([C.Declaration])+	| HappyAbsSyn6 (C.Declaration)+	| HappyAbsSyn12 ((C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name]))+	| HappyAbsSyn13 ((C.Name, C.Telescope, C.Type, C.Constructor, [C.Name]))+	| HappyAbsSyn18 (C.LetDef)+	| HappyAbsSyn19 (Bool)+	| HappyAbsSyn20 (Maybe C.Type)+	| HappyAbsSyn22 ([Name])+	| HappyAbsSyn23 (Name)+	| HappyAbsSyn26 (Pol)+	| HappyAbsSyn27 (A.Measure C.Expr)+	| HappyAbsSyn28 ([C.Expr])+	| HappyAbsSyn29 (A.Bound C.Expr)+	| HappyAbsSyn31 (C.Telescope)+	| HappyAbsSyn32 (C.TBind)+	| HappyAbsSyn35 (C.LBind)+	| HappyAbsSyn36 ((Dec, C.Name))+	| HappyAbsSyn40 (C.Expr)+	| HappyAbsSyn48 (C.QName)+	| HappyAbsSyn49 ([([Name],C.Expr)])+	| HappyAbsSyn50 (([Name],C.Expr))+	| HappyAbsSyn51 (C.TypeSig)+	| HappyAbsSyn52 (C.Constructor)+	| HappyAbsSyn53 ([C.Constructor ])+	| HappyAbsSyn54 ([C.Clause])+	| HappyAbsSyn55 (C.Clause)+	| HappyAbsSyn56 ([C.Pattern])+	| HappyAbsSyn58 (C.Pattern)+	| HappyAbsSyn64 ([C.Clause ])++{- to allow type-synonyms as our monads (likely+ - with explicitly-specified bind and return)+ - in Haskell98, it seems that with+ - /type M a = .../, then /(HappyReduction M)/+ - is not allowed.  But Happy is a+ - code-generator that can just substitute it.+type HappyReduction m = +	   Int +	-> (T.Token)+	-> HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> m HappyAbsSyn)+	-> [HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> m HappyAbsSyn)] +	-> HappyStk HappyAbsSyn +	-> [(T.Token)] -> m HappyAbsSyn+-}++action_0,+ action_1,+ action_2,+ action_3,+ action_4,+ action_5,+ action_6,+ action_7,+ action_8,+ action_9,+ action_10,+ action_11,+ action_12,+ action_13,+ action_14,+ action_15,+ action_16,+ action_17,+ action_18,+ action_19,+ action_20,+ action_21,+ action_22,+ action_23,+ action_24,+ action_25,+ action_26,+ action_27,+ action_28,+ action_29,+ action_30,+ action_31,+ action_32,+ action_33,+ action_34,+ action_35,+ action_36,+ action_37,+ action_38,+ action_39,+ action_40,+ action_41,+ action_42,+ action_43,+ action_44,+ action_45,+ action_46,+ action_47,+ action_48,+ action_49,+ action_50,+ action_51,+ action_52,+ action_53,+ action_54,+ action_55,+ action_56,+ action_57,+ action_58,+ action_59,+ action_60,+ action_61,+ action_62,+ action_63,+ action_64,+ action_65,+ action_66,+ action_67,+ action_68,+ action_69,+ action_70,+ action_71,+ action_72,+ action_73,+ action_74,+ action_75,+ action_76,+ action_77,+ action_78,+ action_79,+ action_80,+ action_81,+ action_82,+ action_83,+ action_84,+ action_85,+ action_86,+ action_87,+ action_88,+ action_89,+ action_90,+ action_91,+ action_92,+ action_93,+ action_94,+ action_95,+ action_96,+ action_97,+ action_98,+ action_99,+ action_100,+ action_101,+ action_102,+ action_103,+ action_104,+ action_105,+ action_106,+ action_107,+ action_108,+ action_109,+ action_110,+ action_111,+ action_112,+ action_113,+ action_114,+ action_115,+ action_116,+ action_117,+ action_118,+ action_119,+ action_120,+ action_121,+ action_122,+ action_123,+ action_124,+ action_125,+ action_126,+ action_127,+ action_128,+ action_129,+ action_130,+ action_131,+ action_132,+ action_133,+ action_134,+ action_135,+ action_136,+ action_137,+ action_138,+ action_139,+ action_140,+ action_141,+ action_142,+ action_143,+ action_144,+ action_145,+ action_146,+ action_147,+ action_148,+ action_149,+ action_150,+ action_151,+ action_152,+ action_153,+ action_154,+ action_155,+ action_156,+ action_157,+ action_158,+ action_159,+ action_160,+ action_161,+ action_162,+ action_163,+ action_164,+ action_165,+ action_166,+ action_167,+ action_168,+ action_169,+ action_170,+ action_171,+ action_172,+ action_173,+ action_174,+ action_175,+ action_176,+ action_177,+ action_178,+ action_179,+ action_180,+ action_181,+ action_182,+ action_183,+ action_184,+ action_185,+ action_186,+ action_187,+ action_188,+ action_189,+ action_190,+ action_191,+ action_192,+ action_193,+ action_194,+ action_195,+ action_196,+ action_197,+ action_198,+ action_199,+ action_200,+ action_201,+ action_202,+ action_203,+ action_204,+ action_205,+ action_206,+ action_207,+ action_208,+ action_209,+ action_210,+ action_211,+ action_212,+ action_213,+ action_214,+ action_215,+ action_216,+ action_217,+ action_218,+ action_219,+ action_220,+ action_221,+ action_222,+ action_223,+ action_224,+ action_225,+ action_226,+ action_227,+ action_228,+ action_229,+ action_230,+ action_231,+ action_232,+ action_233,+ action_234,+ action_235,+ action_236,+ action_237,+ action_238,+ action_239,+ action_240,+ action_241,+ action_242,+ action_243,+ action_244,+ action_245,+ action_246,+ action_247,+ action_248,+ action_249,+ action_250,+ action_251,+ action_252,+ action_253,+ action_254,+ action_255,+ action_256,+ action_257,+ action_258,+ action_259,+ action_260,+ action_261,+ action_262,+ action_263,+ action_264,+ action_265,+ action_266,+ action_267,+ action_268,+ action_269,+ action_270,+ action_271,+ action_272,+ action_273,+ action_274,+ action_275,+ action_276,+ action_277,+ action_278,+ action_279,+ action_280,+ action_281,+ action_282,+ action_283,+ action_284,+ action_285,+ action_286,+ action_287,+ action_288,+ action_289,+ action_290,+ action_291,+ action_292,+ action_293,+ action_294,+ action_295,+ action_296,+ action_297,+ action_298,+ action_299,+ action_300,+ action_301,+ action_302,+ action_303,+ action_304,+ action_305,+ action_306,+ action_307,+ action_308,+ action_309,+ action_310,+ action_311,+ action_312,+ action_313,+ action_314,+ action_315,+ action_316,+ action_317,+ action_318,+ action_319,+ action_320,+ action_321,+ action_322,+ action_323,+ action_324,+ action_325,+ action_326,+ action_327,+ action_328,+ action_329,+ action_330,+ action_331,+ action_332,+ action_333,+ action_334,+ action_335,+ action_336,+ action_337,+ action_338,+ action_339,+ action_340,+ action_341,+ action_342,+ action_343,+ action_344,+ action_345,+ action_346,+ action_347,+ action_348,+ action_349,+ action_350,+ action_351,+ action_352,+ action_353,+ action_354,+ action_355,+ action_356,+ action_357,+ action_358,+ action_359,+ action_360,+ action_361,+ action_362,+ action_363,+ action_364,+ action_365,+ action_366,+ action_367,+ action_368,+ action_369,+ action_370,+ action_371,+ action_372,+ action_373,+ action_374,+ action_375,+ action_376,+ action_377,+ action_378,+ action_379,+ action_380,+ action_381,+ action_382,+ action_383,+ action_384,+ action_385,+ action_386,+ action_387,+ action_388,+ action_389,+ action_390,+ action_391,+ action_392,+ action_393,+ action_394,+ action_395,+ action_396,+ action_397 :: () => Int -> ({-HappyReduction (HappyIdentity) = -}+	   Int +	-> (T.Token)+	-> HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)+	-> [HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)] +	-> HappyStk HappyAbsSyn +	-> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)++happyReduce_1,+ happyReduce_2,+ happyReduce_3,+ happyReduce_4,+ happyReduce_5,+ happyReduce_6,+ happyReduce_7,+ happyReduce_8,+ happyReduce_9,+ happyReduce_10,+ happyReduce_11,+ happyReduce_12,+ happyReduce_13,+ happyReduce_14,+ happyReduce_15,+ happyReduce_16,+ happyReduce_17,+ happyReduce_18,+ happyReduce_19,+ happyReduce_20,+ happyReduce_21,+ happyReduce_22,+ happyReduce_23,+ happyReduce_24,+ happyReduce_25,+ happyReduce_26,+ happyReduce_27,+ happyReduce_28,+ happyReduce_29,+ happyReduce_30,+ happyReduce_31,+ happyReduce_32,+ happyReduce_33,+ happyReduce_34,+ happyReduce_35,+ happyReduce_36,+ happyReduce_37,+ happyReduce_38,+ happyReduce_39,+ happyReduce_40,+ happyReduce_41,+ happyReduce_42,+ happyReduce_43,+ happyReduce_44,+ happyReduce_45,+ happyReduce_46,+ happyReduce_47,+ happyReduce_48,+ happyReduce_49,+ happyReduce_50,+ happyReduce_51,+ happyReduce_52,+ happyReduce_53,+ happyReduce_54,+ happyReduce_55,+ happyReduce_56,+ happyReduce_57,+ happyReduce_58,+ happyReduce_59,+ happyReduce_60,+ happyReduce_61,+ happyReduce_62,+ happyReduce_63,+ happyReduce_64,+ happyReduce_65,+ happyReduce_66,+ happyReduce_67,+ happyReduce_68,+ happyReduce_69,+ happyReduce_70,+ happyReduce_71,+ happyReduce_72,+ happyReduce_73,+ happyReduce_74,+ happyReduce_75,+ happyReduce_76,+ happyReduce_77,+ happyReduce_78,+ happyReduce_79,+ happyReduce_80,+ happyReduce_81,+ happyReduce_82,+ happyReduce_83,+ happyReduce_84,+ happyReduce_85,+ happyReduce_86,+ happyReduce_87,+ happyReduce_88,+ happyReduce_89,+ happyReduce_90,+ happyReduce_91,+ happyReduce_92,+ happyReduce_93,+ happyReduce_94,+ happyReduce_95,+ happyReduce_96,+ happyReduce_97,+ happyReduce_98,+ happyReduce_99,+ happyReduce_100,+ happyReduce_101,+ happyReduce_102,+ happyReduce_103,+ happyReduce_104,+ happyReduce_105,+ happyReduce_106,+ happyReduce_107,+ happyReduce_108,+ happyReduce_109,+ happyReduce_110,+ happyReduce_111,+ happyReduce_112,+ happyReduce_113,+ happyReduce_114,+ happyReduce_115,+ happyReduce_116,+ happyReduce_117,+ happyReduce_118,+ happyReduce_119,+ happyReduce_120,+ happyReduce_121,+ happyReduce_122,+ happyReduce_123,+ happyReduce_124,+ happyReduce_125,+ happyReduce_126,+ happyReduce_127,+ happyReduce_128,+ happyReduce_129,+ happyReduce_130,+ happyReduce_131,+ happyReduce_132,+ happyReduce_133,+ happyReduce_134,+ happyReduce_135,+ happyReduce_136,+ happyReduce_137,+ happyReduce_138,+ happyReduce_139,+ happyReduce_140,+ happyReduce_141,+ happyReduce_142,+ happyReduce_143,+ happyReduce_144,+ happyReduce_145,+ happyReduce_146,+ happyReduce_147,+ happyReduce_148,+ happyReduce_149,+ happyReduce_150,+ happyReduce_151,+ happyReduce_152,+ happyReduce_153,+ happyReduce_154,+ happyReduce_155,+ happyReduce_156,+ happyReduce_157,+ happyReduce_158,+ happyReduce_159,+ happyReduce_160,+ happyReduce_161,+ happyReduce_162,+ happyReduce_163,+ happyReduce_164,+ happyReduce_165,+ happyReduce_166,+ happyReduce_167,+ happyReduce_168,+ happyReduce_169,+ happyReduce_170,+ happyReduce_171,+ happyReduce_172,+ happyReduce_173,+ happyReduce_174,+ happyReduce_175,+ happyReduce_176,+ happyReduce_177,+ happyReduce_178,+ happyReduce_179,+ happyReduce_180,+ happyReduce_181,+ happyReduce_182,+ happyReduce_183,+ happyReduce_184,+ happyReduce_185,+ happyReduce_186,+ happyReduce_187,+ happyReduce_188 :: () => ({-HappyReduction (HappyIdentity) = -}+	   Int +	-> (T.Token)+	-> HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)+	-> [HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)] +	-> HappyStk HappyAbsSyn +	-> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)++action_0 (4) = happyGoto action_3+action_0 (5) = happyGoto action_2+action_0 _ = happyReduce_2++action_1 (5) = happyGoto action_2+action_1 _ = happyFail++action_2 (70) = happyShift action_16+action_2 (71) = happyShift action_17+action_2 (72) = happyShift action_18+action_2 (73) = happyShift action_19+action_2 (75) = happyShift action_20+action_2 (76) = happyShift action_21+action_2 (77) = happyShift action_22+action_2 (78) = happyShift action_23+action_2 (83) = happyShift action_24+action_2 (84) = happyShift action_25+action_2 (85) = happyShift action_26+action_2 (86) = happyShift action_27+action_2 (87) = happyShift action_28+action_2 (122) = happyReduce_1+action_2 (6) = happyGoto action_4+action_2 (7) = happyGoto action_5+action_2 (8) = happyGoto action_6+action_2 (9) = happyGoto action_7+action_2 (10) = happyGoto action_8+action_2 (11) = happyGoto action_9+action_2 (14) = happyGoto action_10+action_2 (15) = happyGoto action_11+action_2 (16) = happyGoto action_12+action_2 (17) = happyGoto action_13+action_2 (19) = happyGoto action_14+action_2 (21) = happyGoto action_15+action_2 _ = happyReduce_36++action_3 (122) = happyAccept+action_3 _ = happyFail++action_4 _ = happyReduce_3++action_5 _ = happyReduce_4++action_6 _ = happyReduce_6++action_7 _ = happyReduce_5++action_8 _ = happyReduce_7++action_9 _ = happyReduce_8++action_10 _ = happyReduce_9++action_11 _ = happyReduce_10++action_12 _ = happyReduce_11++action_13 _ = happyReduce_12++action_14 (81) = happyShift action_51+action_14 _ = happyFail++action_15 _ = happyReduce_13++action_16 (67) = happyShift action_39+action_16 (12) = happyGoto action_50+action_16 (23) = happyGoto action_49+action_16 _ = happyFail++action_17 (67) = happyShift action_39+action_17 (12) = happyGoto action_48+action_17 (23) = happyGoto action_49+action_17 _ = happyFail++action_18 (67) = happyShift action_39+action_18 (13) = happyGoto action_46+action_18 (23) = happyGoto action_47+action_18 _ = happyFail++action_19 (70) = happyShift action_44+action_19 (71) = happyShift action_45+action_19 _ = happyFail++action_20 (99) = happyShift action_43+action_20 _ = happyFail++action_21 (67) = happyShift action_39+action_21 (23) = happyGoto action_40+action_21 (51) = happyGoto action_42+action_21 _ = happyFail++action_22 (67) = happyShift action_39+action_22 (23) = happyGoto action_40+action_22 (51) = happyGoto action_41+action_22 _ = happyFail++action_23 (67) = happyShift action_39+action_23 (23) = happyGoto action_37+action_23 (24) = happyGoto action_38+action_23 _ = happyFail++action_24 _ = happyReduce_37++action_25 (70) = happyShift action_16+action_25 (71) = happyShift action_17+action_25 (72) = happyShift action_18+action_25 (73) = happyShift action_19+action_25 (75) = happyShift action_20+action_25 (76) = happyShift action_21+action_25 (77) = happyShift action_22+action_25 (78) = happyShift action_23+action_25 (83) = happyShift action_24+action_25 (84) = happyShift action_25+action_25 (85) = happyShift action_26+action_25 (86) = happyShift action_27+action_25 (87) = happyShift action_28+action_25 (99) = happyShift action_36+action_25 (6) = happyGoto action_35+action_25 (7) = happyGoto action_5+action_25 (8) = happyGoto action_6+action_25 (9) = happyGoto action_7+action_25 (10) = happyGoto action_8+action_25 (11) = happyGoto action_9+action_25 (14) = happyGoto action_10+action_25 (15) = happyGoto action_11+action_25 (16) = happyGoto action_12+action_25 (17) = happyGoto action_13+action_25 (19) = happyGoto action_14+action_25 (21) = happyGoto action_15+action_25 _ = happyReduce_36++action_26 (70) = happyShift action_16+action_26 (71) = happyShift action_17+action_26 (72) = happyShift action_18+action_26 (73) = happyShift action_19+action_26 (75) = happyShift action_20+action_26 (76) = happyShift action_21+action_26 (77) = happyShift action_22+action_26 (78) = happyShift action_23+action_26 (83) = happyShift action_24+action_26 (84) = happyShift action_25+action_26 (85) = happyShift action_26+action_26 (86) = happyShift action_27+action_26 (87) = happyShift action_28+action_26 (99) = happyShift action_34+action_26 (6) = happyGoto action_33+action_26 (7) = happyGoto action_5+action_26 (8) = happyGoto action_6+action_26 (9) = happyGoto action_7+action_26 (10) = happyGoto action_8+action_26 (11) = happyGoto action_9+action_26 (14) = happyGoto action_10+action_26 (15) = happyGoto action_11+action_26 (16) = happyGoto action_12+action_26 (17) = happyGoto action_13+action_26 (19) = happyGoto action_14+action_26 (21) = happyGoto action_15+action_26 _ = happyReduce_36++action_27 (70) = happyShift action_16+action_27 (71) = happyShift action_17+action_27 (72) = happyShift action_18+action_27 (73) = happyShift action_19+action_27 (75) = happyShift action_20+action_27 (76) = happyShift action_21+action_27 (77) = happyShift action_22+action_27 (78) = happyShift action_23+action_27 (83) = happyShift action_24+action_27 (84) = happyShift action_25+action_27 (85) = happyShift action_26+action_27 (86) = happyShift action_27+action_27 (87) = happyShift action_28+action_27 (99) = happyShift action_32+action_27 (6) = happyGoto action_31+action_27 (7) = happyGoto action_5+action_27 (8) = happyGoto action_6+action_27 (9) = happyGoto action_7+action_27 (10) = happyGoto action_8+action_27 (11) = happyGoto action_9+action_27 (14) = happyGoto action_10+action_27 (15) = happyGoto action_11+action_27 (16) = happyGoto action_12+action_27 (17) = happyGoto action_13+action_27 (19) = happyGoto action_14+action_27 (21) = happyGoto action_15+action_27 _ = happyReduce_36++action_28 (70) = happyShift action_16+action_28 (71) = happyShift action_17+action_28 (72) = happyShift action_18+action_28 (73) = happyShift action_19+action_28 (75) = happyShift action_20+action_28 (76) = happyShift action_21+action_28 (77) = happyShift action_22+action_28 (78) = happyShift action_23+action_28 (83) = happyShift action_24+action_28 (84) = happyShift action_25+action_28 (85) = happyShift action_26+action_28 (86) = happyShift action_27+action_28 (87) = happyShift action_28+action_28 (99) = happyShift action_30+action_28 (6) = happyGoto action_29+action_28 (7) = happyGoto action_5+action_28 (8) = happyGoto action_6+action_28 (9) = happyGoto action_7+action_28 (10) = happyGoto action_8+action_28 (11) = happyGoto action_9+action_28 (14) = happyGoto action_10+action_28 (15) = happyGoto action_11+action_28 (16) = happyGoto action_12+action_28 (17) = happyGoto action_13+action_28 (19) = happyGoto action_14+action_28 (21) = happyGoto action_15+action_28 _ = happyReduce_36++action_29 _ = happyReduce_14++action_30 (5) = happyGoto action_80+action_30 _ = happyReduce_2++action_31 _ = happyReduce_20++action_32 (5) = happyGoto action_79+action_32 _ = happyReduce_2++action_33 _ = happyReduce_18++action_34 (5) = happyGoto action_78+action_34 _ = happyReduce_2++action_35 _ = happyReduce_16++action_36 (5) = happyGoto action_77+action_36 _ = happyReduce_2++action_37 (67) = happyShift action_39+action_37 (23) = happyGoto action_37+action_37 (24) = happyGoto action_76+action_37 _ = happyReduce_44++action_38 (112) = happyShift action_75+action_38 _ = happyFail++action_39 _ = happyReduce_43++action_40 (108) = happyShift action_74+action_40 _ = happyFail++action_41 (99) = happyShift action_73+action_41 _ = happyFail++action_42 (99) = happyShift action_72+action_42 _ = happyFail++action_43 (5) = happyGoto action_71+action_43 _ = happyReduce_2++action_44 (67) = happyShift action_39+action_44 (12) = happyGoto action_70+action_44 (23) = happyGoto action_49+action_44 _ = happyFail++action_45 (67) = happyShift action_39+action_45 (12) = happyGoto action_69+action_45 (23) = happyGoto action_49+action_45 _ = happyFail++action_46 _ = happyReduce_26++action_47 (101) = happyShift action_66+action_47 (103) = happyShift action_67+action_47 (109) = happyShift action_57+action_47 (113) = happyShift action_58+action_47 (114) = happyShift action_59+action_47 (115) = happyShift action_60+action_47 (117) = happyShift action_61+action_47 (118) = happyShift action_62+action_47 (26) = happyGoto action_63+action_47 (65) = happyGoto action_64+action_47 (66) = happyGoto action_68+action_47 _ = happyReduce_187++action_48 _ = happyReduce_24++action_49 (101) = happyShift action_66+action_49 (103) = happyShift action_67+action_49 (109) = happyShift action_57+action_49 (113) = happyShift action_58+action_49 (114) = happyShift action_59+action_49 (115) = happyShift action_60+action_49 (117) = happyShift action_61+action_49 (118) = happyShift action_62+action_49 (26) = happyGoto action_63+action_49 (65) = happyGoto action_64+action_49 (66) = happyGoto action_65+action_49 _ = happyReduce_187++action_50 _ = happyReduce_22++action_51 (67) = happyShift action_39+action_51 (101) = happyShift action_56+action_51 (109) = happyShift action_57+action_51 (113) = happyShift action_58+action_51 (114) = happyShift action_59+action_51 (115) = happyShift action_60+action_51 (117) = happyShift action_61+action_51 (118) = happyShift action_62+action_51 (18) = happyGoto action_52+action_51 (23) = happyGoto action_53+action_51 (26) = happyGoto action_54+action_51 (36) = happyGoto action_55+action_51 _ = happyFail++action_52 _ = happyReduce_34++action_53 _ = happyReduce_81++action_54 (67) = happyShift action_39+action_54 (23) = happyGoto action_153+action_54 _ = happyFail++action_55 (99) = happyShift action_125+action_55 (101) = happyShift action_151+action_55 (103) = happyShift action_152+action_55 (105) = happyShift action_128+action_55 (109) = happyShift action_57+action_55 (113) = happyShift action_58+action_55 (114) = happyShift action_59+action_55 (115) = happyShift action_60+action_55 (117) = happyShift action_61+action_55 (118) = happyShift action_62+action_55 (26) = happyGoto action_147+action_55 (27) = happyGoto action_148+action_55 (31) = happyGoto action_149+action_55 (32) = happyGoto action_150+action_55 (33) = happyGoto action_110+action_55 (34) = happyGoto action_111+action_55 _ = happyReduce_60++action_56 (67) = happyShift action_39+action_56 (23) = happyGoto action_146+action_56 _ = happyFail++action_57 _ = happyReduce_51++action_58 _ = happyReduce_48++action_59 _ = happyReduce_49++action_60 _ = happyReduce_50++action_61 _ = happyReduce_53++action_62 _ = happyReduce_52++action_63 (103) = happyShift action_145+action_63 _ = happyFail++action_64 (101) = happyShift action_66+action_64 (103) = happyShift action_67+action_64 (109) = happyShift action_57+action_64 (113) = happyShift action_58+action_64 (114) = happyShift action_59+action_64 (115) = happyShift action_60+action_64 (117) = happyShift action_61+action_64 (118) = happyShift action_62+action_64 (26) = happyGoto action_63+action_64 (65) = happyGoto action_64+action_64 (66) = happyGoto action_144+action_64 _ = happyReduce_187++action_65 (99) = happyShift action_142+action_65 (108) = happyShift action_143+action_65 _ = happyFail++action_66 (67) = happyShift action_39+action_66 (23) = happyGoto action_138+action_66 (25) = happyGoto action_141+action_66 _ = happyFail++action_67 (67) = happyShift action_39+action_67 (114) = happyShift action_140+action_67 (23) = happyGoto action_138+action_67 (25) = happyGoto action_139+action_67 _ = happyFail++action_68 (99) = happyShift action_136+action_68 (108) = happyShift action_137+action_68 _ = happyFail++action_69 _ = happyReduce_25++action_70 _ = happyReduce_23++action_71 (70) = happyShift action_16+action_71 (71) = happyShift action_17+action_71 (72) = happyShift action_18+action_71 (73) = happyShift action_19+action_71 (75) = happyShift action_20+action_71 (76) = happyShift action_21+action_71 (77) = happyShift action_22+action_71 (78) = happyShift action_23+action_71 (83) = happyShift action_24+action_71 (84) = happyShift action_25+action_71 (85) = happyShift action_26+action_71 (86) = happyShift action_27+action_71 (87) = happyShift action_28+action_71 (100) = happyShift action_135+action_71 (6) = happyGoto action_4+action_71 (7) = happyGoto action_5+action_71 (8) = happyGoto action_6+action_71 (9) = happyGoto action_7+action_71 (10) = happyGoto action_8+action_71 (11) = happyGoto action_9+action_71 (14) = happyGoto action_10+action_71 (15) = happyGoto action_11+action_71 (16) = happyGoto action_12+action_71 (17) = happyGoto action_13+action_71 (19) = happyGoto action_14+action_71 (21) = happyGoto action_15+action_71 _ = happyReduce_36++action_72 (67) = happyShift action_39+action_72 (23) = happyGoto action_130+action_72 (55) = happyGoto action_131+action_72 (63) = happyGoto action_134+action_72 (64) = happyGoto action_133+action_72 _ = happyReduce_182++action_73 (67) = happyShift action_39+action_73 (23) = happyGoto action_130+action_73 (55) = happyGoto action_131+action_73 (63) = happyGoto action_132+action_73 (64) = happyGoto action_133+action_73 _ = happyReduce_182++action_74 (67) = happyShift action_39+action_74 (68) = happyShift action_93+action_74 (69) = happyShift action_119+action_74 (72) = happyShift action_95+action_74 (79) = happyShift action_120+action_74 (81) = happyShift action_121+action_74 (89) = happyShift action_122+action_74 (90) = happyShift action_123+action_74 (91) = happyShift action_96+action_74 (92) = happyShift action_97+action_74 (93) = happyShift action_124+action_74 (94) = happyShift action_99+action_74 (97) = happyShift action_100+action_74 (99) = happyShift action_125+action_74 (101) = happyShift action_126+action_74 (103) = happyShift action_127+action_74 (105) = happyShift action_128+action_74 (109) = happyShift action_57+action_74 (113) = happyShift action_58+action_74 (114) = happyShift action_59+action_74 (115) = happyShift action_60+action_74 (117) = happyShift action_61+action_74 (118) = happyShift action_62+action_74 (120) = happyShift action_129+action_74 (121) = happyShift action_103+action_74 (23) = happyGoto action_104+action_74 (26) = happyGoto action_105+action_74 (27) = happyGoto action_106+action_74 (29) = happyGoto action_107+action_74 (31) = happyGoto action_108+action_74 (32) = happyGoto action_109+action_74 (33) = happyGoto action_110+action_74 (34) = happyGoto action_111+action_74 (39) = happyGoto action_112+action_74 (42) = happyGoto action_113+action_74 (43) = happyGoto action_114+action_74 (44) = happyGoto action_115+action_74 (45) = happyGoto action_116+action_74 (46) = happyGoto action_117+action_74 (47) = happyGoto action_118+action_74 (48) = happyGoto action_87+action_74 _ = happyReduce_60++action_75 (67) = happyShift action_39+action_75 (68) = happyShift action_93+action_75 (69) = happyShift action_94+action_75 (72) = happyShift action_95+action_75 (91) = happyShift action_96+action_75 (92) = happyShift action_97+action_75 (93) = happyShift action_98+action_75 (94) = happyShift action_99+action_75 (97) = happyShift action_100+action_75 (103) = happyShift action_101+action_75 (109) = happyShift action_102+action_75 (121) = happyShift action_103+action_75 (23) = happyGoto action_85+action_75 (47) = happyGoto action_86+action_75 (48) = happyGoto action_87+action_75 (58) = happyGoto action_88+action_75 (59) = happyGoto action_89+action_75 (60) = happyGoto action_90+action_75 (61) = happyGoto action_91+action_75 (62) = happyGoto action_92+action_75 _ = happyFail++action_76 _ = happyReduce_45++action_77 (70) = happyShift action_16+action_77 (71) = happyShift action_17+action_77 (72) = happyShift action_18+action_77 (73) = happyShift action_19+action_77 (75) = happyShift action_20+action_77 (76) = happyShift action_21+action_77 (77) = happyShift action_22+action_77 (78) = happyShift action_23+action_77 (83) = happyShift action_24+action_77 (84) = happyShift action_25+action_77 (85) = happyShift action_26+action_77 (86) = happyShift action_27+action_77 (87) = happyShift action_28+action_77 (100) = happyShift action_84+action_77 (6) = happyGoto action_4+action_77 (7) = happyGoto action_5+action_77 (8) = happyGoto action_6+action_77 (9) = happyGoto action_7+action_77 (10) = happyGoto action_8+action_77 (11) = happyGoto action_9+action_77 (14) = happyGoto action_10+action_77 (15) = happyGoto action_11+action_77 (16) = happyGoto action_12+action_77 (17) = happyGoto action_13+action_77 (19) = happyGoto action_14+action_77 (21) = happyGoto action_15+action_77 _ = happyReduce_36++action_78 (70) = happyShift action_16+action_78 (71) = happyShift action_17+action_78 (72) = happyShift action_18+action_78 (73) = happyShift action_19+action_78 (75) = happyShift action_20+action_78 (76) = happyShift action_21+action_78 (77) = happyShift action_22+action_78 (78) = happyShift action_23+action_78 (83) = happyShift action_24+action_78 (84) = happyShift action_25+action_78 (85) = happyShift action_26+action_78 (86) = happyShift action_27+action_78 (87) = happyShift action_28+action_78 (100) = happyShift action_83+action_78 (6) = happyGoto action_4+action_78 (7) = happyGoto action_5+action_78 (8) = happyGoto action_6+action_78 (9) = happyGoto action_7+action_78 (10) = happyGoto action_8+action_78 (11) = happyGoto action_9+action_78 (14) = happyGoto action_10+action_78 (15) = happyGoto action_11+action_78 (16) = happyGoto action_12+action_78 (17) = happyGoto action_13+action_78 (19) = happyGoto action_14+action_78 (21) = happyGoto action_15+action_78 _ = happyReduce_36++action_79 (70) = happyShift action_16+action_79 (71) = happyShift action_17+action_79 (72) = happyShift action_18+action_79 (73) = happyShift action_19+action_79 (75) = happyShift action_20+action_79 (76) = happyShift action_21+action_79 (77) = happyShift action_22+action_79 (78) = happyShift action_23+action_79 (83) = happyShift action_24+action_79 (84) = happyShift action_25+action_79 (85) = happyShift action_26+action_79 (86) = happyShift action_27+action_79 (87) = happyShift action_28+action_79 (100) = happyShift action_82+action_79 (6) = happyGoto action_4+action_79 (7) = happyGoto action_5+action_79 (8) = happyGoto action_6+action_79 (9) = happyGoto action_7+action_79 (10) = happyGoto action_8+action_79 (11) = happyGoto action_9+action_79 (14) = happyGoto action_10+action_79 (15) = happyGoto action_11+action_79 (16) = happyGoto action_12+action_79 (17) = happyGoto action_13+action_79 (19) = happyGoto action_14+action_79 (21) = happyGoto action_15+action_79 _ = happyReduce_36++action_80 (70) = happyShift action_16+action_80 (71) = happyShift action_17+action_80 (72) = happyShift action_18+action_80 (73) = happyShift action_19+action_80 (75) = happyShift action_20+action_80 (76) = happyShift action_21+action_80 (77) = happyShift action_22+action_80 (78) = happyShift action_23+action_80 (83) = happyShift action_24+action_80 (84) = happyShift action_25+action_80 (85) = happyShift action_26+action_80 (86) = happyShift action_27+action_80 (87) = happyShift action_28+action_80 (100) = happyShift action_81+action_80 (6) = happyGoto action_4+action_80 (7) = happyGoto action_5+action_80 (8) = happyGoto action_6+action_80 (9) = happyGoto action_7+action_80 (10) = happyGoto action_8+action_80 (11) = happyGoto action_9+action_80 (14) = happyGoto action_10+action_80 (15) = happyGoto action_11+action_80 (16) = happyGoto action_12+action_80 (17) = happyGoto action_13+action_80 (19) = happyGoto action_14+action_80 (21) = happyGoto action_15+action_80 _ = happyReduce_36++action_81 _ = happyReduce_15++action_82 _ = happyReduce_21++action_83 _ = happyReduce_19++action_84 _ = happyReduce_17++action_85 (67) = happyReduce_176+action_85 (70) = happyReduce_176+action_85 (71) = happyReduce_176+action_85 (72) = happyReduce_176+action_85 (73) = happyReduce_176+action_85 (75) = happyReduce_176+action_85 (76) = happyReduce_176+action_85 (77) = happyReduce_176+action_85 (78) = happyReduce_176+action_85 (81) = happyReduce_176+action_85 (83) = happyReduce_176+action_85 (84) = happyReduce_176+action_85 (85) = happyReduce_176+action_85 (86) = happyReduce_176+action_85 (87) = happyReduce_176+action_85 (93) = happyReduce_176+action_85 (95) = happyReduce_176+action_85 (97) = happyShift action_241+action_85 (100) = happyReduce_176+action_85 (103) = happyReduce_176+action_85 (104) = happyReduce_176+action_85 (106) = happyReduce_176+action_85 (107) = happyReduce_176+action_85 (109) = happyReduce_176+action_85 (112) = happyReduce_176+action_85 (122) = happyReduce_176+action_85 _ = happyReduce_138++action_86 (98) = happyShift action_240+action_86 _ = happyFail++action_87 _ = happyReduce_130++action_88 _ = happyReduce_172++action_89 _ = happyReduce_40++action_90 (106) = happyShift action_239+action_90 _ = happyReduce_168++action_91 (67) = happyShift action_39+action_91 (93) = happyShift action_235+action_91 (95) = happyShift action_238+action_91 (103) = happyShift action_236+action_91 (109) = happyShift action_102+action_91 (23) = happyGoto action_233+action_91 (58) = happyGoto action_237+action_91 (62) = happyGoto action_231+action_91 _ = happyReduce_169++action_92 (67) = happyShift action_39+action_92 (93) = happyShift action_235+action_92 (103) = happyShift action_236+action_92 (109) = happyShift action_102+action_92 (23) = happyGoto action_233+action_92 (58) = happyGoto action_234+action_92 (62) = happyGoto action_231+action_92 _ = happyReduce_163++action_93 _ = happyReduce_137++action_94 _ = happyReduce_135++action_95 (99) = happyShift action_232+action_95 _ = happyFail++action_96 _ = happyReduce_127++action_97 _ = happyReduce_129++action_98 (67) = happyShift action_39+action_98 (68) = happyShift action_93+action_98 (69) = happyShift action_94+action_98 (72) = happyShift action_95+action_98 (91) = happyShift action_96+action_98 (92) = happyShift action_97+action_98 (93) = happyShift action_98+action_98 (94) = happyShift action_99+action_98 (97) = happyShift action_100+action_98 (103) = happyShift action_101+action_98 (109) = happyShift action_102+action_98 (121) = happyShift action_103+action_98 (23) = happyGoto action_229+action_98 (47) = happyGoto action_191+action_98 (48) = happyGoto action_87+action_98 (58) = happyGoto action_230+action_98 (62) = happyGoto action_231+action_98 _ = happyFail++action_99 _ = happyReduce_128++action_100 (67) = happyShift action_39+action_100 (68) = happyShift action_93+action_100 (69) = happyShift action_119+action_100 (72) = happyShift action_95+action_100 (79) = happyShift action_120+action_100 (81) = happyShift action_121+action_100 (89) = happyShift action_122+action_100 (90) = happyShift action_123+action_100 (91) = happyShift action_96+action_100 (92) = happyShift action_97+action_100 (93) = happyShift action_124+action_100 (94) = happyShift action_99+action_100 (97) = happyShift action_100+action_100 (99) = happyShift action_125+action_100 (101) = happyShift action_126+action_100 (103) = happyShift action_127+action_100 (105) = happyShift action_128+action_100 (109) = happyShift action_57+action_100 (113) = happyShift action_58+action_100 (114) = happyShift action_59+action_100 (115) = happyShift action_60+action_100 (117) = happyShift action_61+action_100 (118) = happyShift action_62+action_100 (120) = happyShift action_129+action_100 (121) = happyShift action_103+action_100 (23) = happyGoto action_104+action_100 (26) = happyGoto action_105+action_100 (27) = happyGoto action_106+action_100 (29) = happyGoto action_107+action_100 (31) = happyGoto action_108+action_100 (32) = happyGoto action_109+action_100 (33) = happyGoto action_110+action_100 (34) = happyGoto action_111+action_100 (39) = happyGoto action_112+action_100 (40) = happyGoto action_228+action_100 (41) = happyGoto action_200+action_100 (42) = happyGoto action_157+action_100 (43) = happyGoto action_114+action_100 (44) = happyGoto action_115+action_100 (45) = happyGoto action_116+action_100 (46) = happyGoto action_117+action_100 (47) = happyGoto action_118+action_100 (48) = happyGoto action_87+action_100 _ = happyReduce_60++action_101 (67) = happyShift action_39+action_101 (68) = happyShift action_93+action_101 (69) = happyShift action_119+action_101 (72) = happyShift action_95+action_101 (79) = happyShift action_120+action_101 (81) = happyShift action_121+action_101 (89) = happyShift action_122+action_101 (90) = happyShift action_123+action_101 (91) = happyShift action_96+action_101 (92) = happyShift action_97+action_101 (93) = happyShift action_98+action_101 (94) = happyShift action_99+action_101 (97) = happyShift action_100+action_101 (99) = happyShift action_125+action_101 (101) = happyShift action_126+action_101 (103) = happyShift action_225+action_101 (104) = happyShift action_226+action_101 (105) = happyShift action_128+action_101 (109) = happyShift action_227+action_101 (113) = happyShift action_58+action_101 (114) = happyShift action_59+action_101 (115) = happyShift action_60+action_101 (117) = happyShift action_61+action_101 (118) = happyShift action_62+action_101 (120) = happyShift action_129+action_101 (121) = happyShift action_103+action_101 (23) = happyGoto action_85+action_101 (26) = happyGoto action_105+action_101 (27) = happyGoto action_106+action_101 (29) = happyGoto action_107+action_101 (31) = happyGoto action_108+action_101 (32) = happyGoto action_109+action_101 (33) = happyGoto action_110+action_101 (34) = happyGoto action_111+action_101 (39) = happyGoto action_112+action_101 (40) = happyGoto action_185+action_101 (41) = happyGoto action_200+action_101 (42) = happyGoto action_157+action_101 (43) = happyGoto action_114+action_101 (44) = happyGoto action_115+action_101 (45) = happyGoto action_116+action_101 (46) = happyGoto action_117+action_101 (47) = happyGoto action_223+action_101 (48) = happyGoto action_87+action_101 (58) = happyGoto action_88+action_101 (59) = happyGoto action_224+action_101 (60) = happyGoto action_90+action_101 (61) = happyGoto action_91+action_101 (62) = happyGoto action_92+action_101 _ = happyReduce_60++action_102 (67) = happyShift action_39+action_102 (68) = happyShift action_93+action_102 (69) = happyShift action_94+action_102 (72) = happyShift action_95+action_102 (89) = happyShift action_222+action_102 (91) = happyShift action_96+action_102 (92) = happyShift action_97+action_102 (93) = happyShift action_124+action_102 (94) = happyShift action_99+action_102 (97) = happyShift action_100+action_102 (103) = happyShift action_192+action_102 (121) = happyShift action_103+action_102 (23) = happyGoto action_220+action_102 (47) = happyGoto action_221+action_102 (48) = happyGoto action_87+action_102 _ = happyFail++action_103 _ = happyReduce_133++action_104 _ = happyReduce_138++action_105 (67) = happyShift action_39+action_105 (68) = happyShift action_93+action_105 (69) = happyShift action_119+action_105 (72) = happyShift action_95+action_105 (89) = happyShift action_122+action_105 (90) = happyShift action_123+action_105 (91) = happyShift action_96+action_105 (92) = happyShift action_97+action_105 (93) = happyShift action_124+action_105 (94) = happyShift action_99+action_105 (97) = happyShift action_100+action_105 (99) = happyShift action_125+action_105 (101) = happyShift action_218+action_105 (103) = happyShift action_219+action_105 (105) = happyShift action_128+action_105 (109) = happyShift action_57+action_105 (113) = happyShift action_58+action_105 (114) = happyShift action_59+action_105 (115) = happyShift action_60+action_105 (117) = happyShift action_61+action_105 (118) = happyShift action_62+action_105 (121) = happyShift action_103+action_105 (23) = happyGoto action_104+action_105 (26) = happyGoto action_212+action_105 (27) = happyGoto action_213+action_105 (29) = happyGoto action_214+action_105 (32) = happyGoto action_215+action_105 (33) = happyGoto action_110+action_105 (34) = happyGoto action_111+action_105 (43) = happyGoto action_216+action_105 (44) = happyGoto action_115+action_105 (45) = happyGoto action_217+action_105 (46) = happyGoto action_117+action_105 (47) = happyGoto action_118+action_105 (48) = happyGoto action_87+action_105 _ = happyFail++action_106 (97) = happyShift action_210+action_106 (99) = happyShift action_125+action_106 (101) = happyShift action_151+action_106 (103) = happyShift action_152+action_106 (105) = happyShift action_128+action_106 (109) = happyShift action_57+action_106 (110) = happyReduce_96+action_106 (111) = happyShift action_211+action_106 (113) = happyShift action_58+action_106 (114) = happyShift action_59+action_106 (115) = happyShift action_60+action_106 (117) = happyShift action_61+action_106 (118) = happyShift action_62+action_106 (26) = happyGoto action_147+action_106 (27) = happyGoto action_148+action_106 (31) = happyGoto action_163+action_106 (32) = happyGoto action_150+action_106 (33) = happyGoto action_110+action_106 (34) = happyGoto action_111+action_106 _ = happyReduce_116++action_107 (119) = happyReduce_117+action_107 _ = happyReduce_97++action_108 _ = happyReduce_98++action_109 (99) = happyShift action_125+action_109 (101) = happyShift action_151+action_109 (103) = happyShift action_152+action_109 (105) = happyShift action_128+action_109 (109) = happyShift action_57+action_109 (110) = happyReduce_95+action_109 (113) = happyShift action_58+action_109 (114) = happyShift action_59+action_109 (115) = happyShift action_60+action_109 (117) = happyShift action_61+action_109 (118) = happyShift action_62+action_109 (26) = happyGoto action_147+action_109 (27) = happyGoto action_148+action_109 (31) = happyGoto action_160+action_109 (32) = happyGoto action_150+action_109 (33) = happyGoto action_110+action_109 (34) = happyGoto action_111+action_109 _ = happyReduce_115++action_110 _ = happyReduce_69++action_111 _ = happyReduce_70++action_112 (110) = happyShift action_209+action_112 _ = happyFail++action_113 _ = happyReduce_143++action_114 (110) = happyReduce_92+action_114 _ = happyReduce_106++action_115 (119) = happyShift action_208+action_115 _ = happyFail++action_116 (95) = happyShift action_205+action_116 (96) = happyShift action_206+action_116 (114) = happyShift action_207+action_116 (119) = happyReduce_112+action_116 _ = happyReduce_110++action_117 (67) = happyShift action_39+action_117 (68) = happyShift action_93+action_117 (69) = happyShift action_94+action_117 (72) = happyShift action_95+action_117 (89) = happyShift action_203+action_117 (91) = happyShift action_96+action_117 (92) = happyShift action_97+action_117 (93) = happyShift action_124+action_117 (94) = happyShift action_99+action_117 (97) = happyShift action_100+action_117 (103) = happyShift action_192+action_117 (109) = happyShift action_204+action_117 (121) = happyShift action_103+action_117 (23) = happyGoto action_104+action_117 (47) = happyGoto action_202+action_117 (48) = happyGoto action_87+action_117 _ = happyReduce_118++action_118 _ = happyReduce_123++action_119 (117) = happyShift action_201+action_119 _ = happyReduce_135++action_120 (67) = happyShift action_39+action_120 (68) = happyShift action_93+action_120 (69) = happyShift action_119+action_120 (72) = happyShift action_95+action_120 (79) = happyShift action_120+action_120 (81) = happyShift action_121+action_120 (89) = happyShift action_122+action_120 (90) = happyShift action_123+action_120 (91) = happyShift action_96+action_120 (92) = happyShift action_97+action_120 (93) = happyShift action_124+action_120 (94) = happyShift action_99+action_120 (97) = happyShift action_100+action_120 (99) = happyShift action_125+action_120 (101) = happyShift action_126+action_120 (103) = happyShift action_127+action_120 (105) = happyShift action_128+action_120 (109) = happyShift action_57+action_120 (113) = happyShift action_58+action_120 (114) = happyShift action_59+action_120 (115) = happyShift action_60+action_120 (117) = happyShift action_61+action_120 (118) = happyShift action_62+action_120 (120) = happyShift action_129+action_120 (121) = happyShift action_103+action_120 (23) = happyGoto action_104+action_120 (26) = happyGoto action_105+action_120 (27) = happyGoto action_106+action_120 (29) = happyGoto action_107+action_120 (31) = happyGoto action_108+action_120 (32) = happyGoto action_109+action_120 (33) = happyGoto action_110+action_120 (34) = happyGoto action_111+action_120 (39) = happyGoto action_112+action_120 (40) = happyGoto action_199+action_120 (41) = happyGoto action_200+action_120 (42) = happyGoto action_157+action_120 (43) = happyGoto action_114+action_120 (44) = happyGoto action_115+action_120 (45) = happyGoto action_116+action_120 (46) = happyGoto action_117+action_120 (47) = happyGoto action_118+action_120 (48) = happyGoto action_87+action_120 _ = happyReduce_60++action_121 (67) = happyShift action_39+action_121 (101) = happyShift action_198+action_121 (109) = happyShift action_57+action_121 (113) = happyShift action_58+action_121 (114) = happyShift action_59+action_121 (115) = happyShift action_60+action_121 (117) = happyShift action_61+action_121 (118) = happyShift action_62+action_121 (18) = happyGoto action_195+action_121 (23) = happyGoto action_53+action_121 (26) = happyGoto action_196+action_121 (36) = happyGoto action_55+action_121 (37) = happyGoto action_197+action_121 _ = happyFail++action_122 (67) = happyShift action_39+action_122 (68) = happyShift action_93+action_122 (69) = happyShift action_94+action_122 (72) = happyShift action_95+action_122 (91) = happyShift action_96+action_122 (92) = happyShift action_97+action_122 (93) = happyShift action_124+action_122 (94) = happyShift action_99+action_122 (97) = happyShift action_100+action_122 (103) = happyShift action_192+action_122 (121) = happyShift action_103+action_122 (23) = happyGoto action_104+action_122 (47) = happyGoto action_194+action_122 (48) = happyGoto action_87+action_122 _ = happyReduce_120++action_123 (67) = happyShift action_39+action_123 (68) = happyShift action_93+action_123 (69) = happyShift action_94+action_123 (72) = happyShift action_95+action_123 (91) = happyShift action_96+action_123 (92) = happyShift action_97+action_123 (93) = happyShift action_124+action_123 (94) = happyShift action_99+action_123 (97) = happyShift action_100+action_123 (103) = happyShift action_192+action_123 (121) = happyShift action_103+action_123 (23) = happyGoto action_104+action_123 (47) = happyGoto action_193+action_123 (48) = happyGoto action_87+action_123 _ = happyFail++action_124 (67) = happyShift action_39+action_124 (68) = happyShift action_93+action_124 (69) = happyShift action_94+action_124 (72) = happyShift action_95+action_124 (91) = happyShift action_96+action_124 (92) = happyShift action_97+action_124 (93) = happyShift action_124+action_124 (94) = happyShift action_99+action_124 (97) = happyShift action_100+action_124 (103) = happyShift action_192+action_124 (121) = happyShift action_103+action_124 (23) = happyGoto action_104+action_124 (47) = happyGoto action_191+action_124 (48) = happyGoto action_87+action_124 _ = happyFail++action_125 (67) = happyShift action_39+action_125 (23) = happyGoto action_189+action_125 (25) = happyGoto action_190+action_125 _ = happyFail++action_126 (67) = happyShift action_39+action_126 (68) = happyShift action_93+action_126 (69) = happyShift action_119+action_126 (72) = happyShift action_95+action_126 (79) = happyShift action_120+action_126 (81) = happyShift action_121+action_126 (89) = happyShift action_122+action_126 (90) = happyShift action_123+action_126 (91) = happyShift action_96+action_126 (92) = happyShift action_97+action_126 (93) = happyShift action_124+action_126 (94) = happyShift action_99+action_126 (97) = happyShift action_100+action_126 (99) = happyShift action_125+action_126 (101) = happyShift action_126+action_126 (103) = happyShift action_127+action_126 (105) = happyShift action_128+action_126 (109) = happyShift action_57+action_126 (113) = happyShift action_58+action_126 (114) = happyShift action_59+action_126 (115) = happyShift action_60+action_126 (117) = happyShift action_61+action_126 (118) = happyShift action_62+action_126 (120) = happyShift action_129+action_126 (121) = happyShift action_103+action_126 (23) = happyGoto action_187+action_126 (25) = happyGoto action_159+action_126 (26) = happyGoto action_105+action_126 (27) = happyGoto action_106+action_126 (29) = happyGoto action_107+action_126 (31) = happyGoto action_108+action_126 (32) = happyGoto action_109+action_126 (33) = happyGoto action_110+action_126 (34) = happyGoto action_111+action_126 (39) = happyGoto action_112+action_126 (42) = happyGoto action_188+action_126 (43) = happyGoto action_114+action_126 (44) = happyGoto action_115+action_126 (45) = happyGoto action_116+action_126 (46) = happyGoto action_117+action_126 (47) = happyGoto action_118+action_126 (48) = happyGoto action_87+action_126 _ = happyReduce_60++action_127 (67) = happyShift action_39+action_127 (68) = happyShift action_93+action_127 (69) = happyShift action_119+action_127 (72) = happyShift action_95+action_127 (79) = happyShift action_120+action_127 (81) = happyShift action_121+action_127 (89) = happyShift action_122+action_127 (90) = happyShift action_123+action_127 (91) = happyShift action_96+action_127 (92) = happyShift action_97+action_127 (93) = happyShift action_124+action_127 (94) = happyShift action_99+action_127 (97) = happyShift action_100+action_127 (99) = happyShift action_125+action_127 (101) = happyShift action_126+action_127 (103) = happyShift action_127+action_127 (105) = happyShift action_128+action_127 (109) = happyShift action_57+action_127 (113) = happyShift action_58+action_127 (114) = happyShift action_59+action_127 (115) = happyShift action_60+action_127 (117) = happyShift action_61+action_127 (118) = happyShift action_62+action_127 (120) = happyShift action_129+action_127 (121) = happyShift action_103+action_127 (23) = happyGoto action_154+action_127 (26) = happyGoto action_105+action_127 (27) = happyGoto action_106+action_127 (29) = happyGoto action_107+action_127 (30) = happyGoto action_155+action_127 (31) = happyGoto action_108+action_127 (32) = happyGoto action_109+action_127 (33) = happyGoto action_110+action_127 (34) = happyGoto action_111+action_127 (39) = happyGoto action_112+action_127 (40) = happyGoto action_185+action_127 (41) = happyGoto action_186+action_127 (42) = happyGoto action_157+action_127 (43) = happyGoto action_114+action_127 (44) = happyGoto action_115+action_127 (45) = happyGoto action_116+action_127 (46) = happyGoto action_117+action_127 (47) = happyGoto action_118+action_127 (48) = happyGoto action_87+action_127 _ = happyReduce_60++action_128 (67) = happyShift action_39+action_128 (68) = happyShift action_93+action_128 (69) = happyShift action_119+action_128 (72) = happyShift action_95+action_128 (79) = happyShift action_120+action_128 (81) = happyShift action_121+action_128 (89) = happyShift action_122+action_128 (90) = happyShift action_123+action_128 (91) = happyShift action_96+action_128 (92) = happyShift action_97+action_128 (93) = happyShift action_124+action_128 (94) = happyShift action_99+action_128 (97) = happyShift action_100+action_128 (99) = happyShift action_125+action_128 (101) = happyShift action_126+action_128 (103) = happyShift action_127+action_128 (105) = happyShift action_128+action_128 (109) = happyShift action_57+action_128 (113) = happyShift action_58+action_128 (114) = happyShift action_59+action_128 (115) = happyShift action_60+action_128 (117) = happyShift action_61+action_128 (118) = happyShift action_62+action_128 (120) = happyShift action_129+action_128 (121) = happyShift action_103+action_128 (23) = happyGoto action_104+action_128 (26) = happyGoto action_105+action_128 (27) = happyGoto action_106+action_128 (28) = happyGoto action_183+action_128 (29) = happyGoto action_107+action_128 (31) = happyGoto action_108+action_128 (32) = happyGoto action_109+action_128 (33) = happyGoto action_110+action_128 (34) = happyGoto action_111+action_128 (39) = happyGoto action_112+action_128 (42) = happyGoto action_184+action_128 (43) = happyGoto action_114+action_128 (44) = happyGoto action_115+action_128 (45) = happyGoto action_116+action_128 (46) = happyGoto action_117+action_128 (47) = happyGoto action_118+action_128 (48) = happyGoto action_87+action_128 _ = happyReduce_60++action_129 (67) = happyShift action_39+action_129 (23) = happyGoto action_37+action_129 (24) = happyGoto action_182+action_129 _ = happyFail++action_130 (56) = happyGoto action_180+action_130 (57) = happyGoto action_181+action_130 _ = happyReduce_158++action_131 _ = happyReduce_181++action_132 (100) = happyShift action_179+action_132 _ = happyFail++action_133 (107) = happyShift action_178+action_133 _ = happyReduce_178++action_134 (100) = happyShift action_177+action_134 _ = happyFail++action_135 _ = happyReduce_33++action_136 (67) = happyShift action_39+action_136 (23) = happyGoto action_168+action_136 (52) = happyGoto action_176+action_136 _ = happyFail++action_137 (67) = happyShift action_39+action_137 (68) = happyShift action_93+action_137 (69) = happyShift action_119+action_137 (72) = happyShift action_95+action_137 (79) = happyShift action_120+action_137 (81) = happyShift action_121+action_137 (89) = happyShift action_122+action_137 (90) = happyShift action_123+action_137 (91) = happyShift action_96+action_137 (92) = happyShift action_97+action_137 (93) = happyShift action_124+action_137 (94) = happyShift action_99+action_137 (97) = happyShift action_100+action_137 (99) = happyShift action_125+action_137 (101) = happyShift action_126+action_137 (103) = happyShift action_127+action_137 (105) = happyShift action_128+action_137 (109) = happyShift action_57+action_137 (113) = happyShift action_58+action_137 (114) = happyShift action_59+action_137 (115) = happyShift action_60+action_137 (117) = happyShift action_61+action_137 (118) = happyShift action_62+action_137 (120) = happyShift action_129+action_137 (121) = happyShift action_103+action_137 (23) = happyGoto action_104+action_137 (26) = happyGoto action_105+action_137 (27) = happyGoto action_106+action_137 (29) = happyGoto action_107+action_137 (31) = happyGoto action_108+action_137 (32) = happyGoto action_109+action_137 (33) = happyGoto action_110+action_137 (34) = happyGoto action_111+action_137 (39) = happyGoto action_112+action_137 (42) = happyGoto action_175+action_137 (43) = happyGoto action_114+action_137 (44) = happyGoto action_115+action_137 (45) = happyGoto action_116+action_137 (46) = happyGoto action_117+action_137 (47) = happyGoto action_118+action_137 (48) = happyGoto action_87+action_137 _ = happyReduce_60++action_138 (106) = happyShift action_174+action_138 _ = happyReduce_46++action_139 (108) = happyShift action_173+action_139 _ = happyFail++action_140 (67) = happyShift action_39+action_140 (23) = happyGoto action_138+action_140 (25) = happyGoto action_172+action_140 _ = happyFail++action_141 (108) = happyShift action_171+action_141 _ = happyFail++action_142 (67) = happyShift action_39+action_142 (23) = happyGoto action_168+action_142 (52) = happyGoto action_169+action_142 (53) = happyGoto action_170+action_142 _ = happyReduce_149++action_143 (67) = happyShift action_39+action_143 (68) = happyShift action_93+action_143 (69) = happyShift action_119+action_143 (72) = happyShift action_95+action_143 (79) = happyShift action_120+action_143 (81) = happyShift action_121+action_143 (89) = happyShift action_122+action_143 (90) = happyShift action_123+action_143 (91) = happyShift action_96+action_143 (92) = happyShift action_97+action_143 (93) = happyShift action_124+action_143 (94) = happyShift action_99+action_143 (97) = happyShift action_100+action_143 (99) = happyShift action_125+action_143 (101) = happyShift action_126+action_143 (103) = happyShift action_127+action_143 (105) = happyShift action_128+action_143 (109) = happyShift action_57+action_143 (113) = happyShift action_58+action_143 (114) = happyShift action_59+action_143 (115) = happyShift action_60+action_143 (117) = happyShift action_61+action_143 (118) = happyShift action_62+action_143 (120) = happyShift action_129+action_143 (121) = happyShift action_103+action_143 (23) = happyGoto action_104+action_143 (26) = happyGoto action_105+action_143 (27) = happyGoto action_106+action_143 (29) = happyGoto action_107+action_143 (31) = happyGoto action_108+action_143 (32) = happyGoto action_109+action_143 (33) = happyGoto action_110+action_143 (34) = happyGoto action_111+action_143 (39) = happyGoto action_112+action_143 (42) = happyGoto action_167+action_143 (43) = happyGoto action_114+action_143 (44) = happyGoto action_115+action_143 (45) = happyGoto action_116+action_143 (46) = happyGoto action_117+action_143 (47) = happyGoto action_118+action_143 (48) = happyGoto action_87+action_143 _ = happyReduce_60++action_144 _ = happyReduce_188++action_145 (67) = happyShift action_39+action_145 (23) = happyGoto action_138+action_145 (25) = happyGoto action_166+action_145 _ = happyFail++action_146 (102) = happyShift action_165+action_146 _ = happyFail++action_147 (103) = happyShift action_164+action_147 _ = happyFail++action_148 (99) = happyShift action_125+action_148 (101) = happyShift action_151+action_148 (103) = happyShift action_152+action_148 (105) = happyShift action_128+action_148 (109) = happyShift action_57+action_148 (113) = happyShift action_58+action_148 (114) = happyShift action_59+action_148 (115) = happyShift action_60+action_148 (117) = happyShift action_61+action_148 (118) = happyShift action_62+action_148 (26) = happyGoto action_147+action_148 (27) = happyGoto action_148+action_148 (31) = happyGoto action_163+action_148 (32) = happyGoto action_150+action_148 (33) = happyGoto action_110+action_148 (34) = happyGoto action_111+action_148 _ = happyReduce_60++action_149 (108) = happyShift action_162+action_149 (20) = happyGoto action_161+action_149 _ = happyReduce_38++action_150 (99) = happyShift action_125+action_150 (101) = happyShift action_151+action_150 (103) = happyShift action_152+action_150 (105) = happyShift action_128+action_150 (109) = happyShift action_57+action_150 (113) = happyShift action_58+action_150 (114) = happyShift action_59+action_150 (115) = happyShift action_60+action_150 (117) = happyShift action_61+action_150 (118) = happyShift action_62+action_150 (26) = happyGoto action_147+action_150 (27) = happyGoto action_148+action_150 (31) = happyGoto action_160+action_150 (32) = happyGoto action_150+action_150 (33) = happyGoto action_110+action_150 (34) = happyGoto action_111+action_150 _ = happyReduce_60++action_151 (67) = happyShift action_39+action_151 (23) = happyGoto action_158+action_151 (25) = happyGoto action_159+action_151 _ = happyFail++action_152 (67) = happyShift action_39+action_152 (68) = happyShift action_93+action_152 (69) = happyShift action_119+action_152 (72) = happyShift action_95+action_152 (79) = happyShift action_120+action_152 (81) = happyShift action_121+action_152 (89) = happyShift action_122+action_152 (90) = happyShift action_123+action_152 (91) = happyShift action_96+action_152 (92) = happyShift action_97+action_152 (93) = happyShift action_124+action_152 (94) = happyShift action_99+action_152 (97) = happyShift action_100+action_152 (99) = happyShift action_125+action_152 (101) = happyShift action_126+action_152 (103) = happyShift action_127+action_152 (105) = happyShift action_128+action_152 (109) = happyShift action_57+action_152 (113) = happyShift action_58+action_152 (114) = happyShift action_59+action_152 (115) = happyShift action_60+action_152 (117) = happyShift action_61+action_152 (118) = happyShift action_62+action_152 (120) = happyShift action_129+action_152 (121) = happyShift action_103+action_152 (23) = happyGoto action_154+action_152 (26) = happyGoto action_105+action_152 (27) = happyGoto action_106+action_152 (29) = happyGoto action_107+action_152 (30) = happyGoto action_155+action_152 (31) = happyGoto action_108+action_152 (32) = happyGoto action_109+action_152 (33) = happyGoto action_110+action_152 (34) = happyGoto action_111+action_152 (39) = happyGoto action_112+action_152 (41) = happyGoto action_156+action_152 (42) = happyGoto action_157+action_152 (43) = happyGoto action_114+action_152 (44) = happyGoto action_115+action_152 (45) = happyGoto action_116+action_152 (46) = happyGoto action_117+action_152 (47) = happyGoto action_118+action_152 (48) = happyGoto action_87+action_152 _ = happyReduce_60++action_153 _ = happyReduce_83++action_154 (97) = happyShift action_303+action_154 (111) = happyShift action_304+action_154 _ = happyReduce_138++action_155 (108) = happyShift action_302+action_155 _ = happyFail++action_156 _ = happyReduce_59++action_157 (106) = happyShift action_301+action_157 _ = happyReduce_100++action_158 (97) = happyShift action_275+action_158 (106) = happyShift action_174+action_158 (111) = happyShift action_276+action_158 _ = happyReduce_46++action_159 (108) = happyShift action_300+action_159 _ = happyFail++action_160 _ = happyReduce_61++action_161 (112) = happyShift action_299+action_161 _ = happyFail++action_162 (67) = happyShift action_39+action_162 (68) = happyShift action_93+action_162 (69) = happyShift action_119+action_162 (72) = happyShift action_95+action_162 (79) = happyShift action_120+action_162 (81) = happyShift action_121+action_162 (89) = happyShift action_122+action_162 (90) = happyShift action_123+action_162 (91) = happyShift action_96+action_162 (92) = happyShift action_97+action_162 (93) = happyShift action_124+action_162 (94) = happyShift action_99+action_162 (97) = happyShift action_100+action_162 (99) = happyShift action_125+action_162 (101) = happyShift action_126+action_162 (103) = happyShift action_127+action_162 (105) = happyShift action_128+action_162 (109) = happyShift action_57+action_162 (113) = happyShift action_58+action_162 (114) = happyShift action_59+action_162 (115) = happyShift action_60+action_162 (117) = happyShift action_61+action_162 (118) = happyShift action_62+action_162 (120) = happyShift action_129+action_162 (121) = happyShift action_103+action_162 (23) = happyGoto action_104+action_162 (26) = happyGoto action_105+action_162 (27) = happyGoto action_106+action_162 (29) = happyGoto action_107+action_162 (31) = happyGoto action_108+action_162 (32) = happyGoto action_109+action_162 (33) = happyGoto action_110+action_162 (34) = happyGoto action_111+action_162 (39) = happyGoto action_112+action_162 (42) = happyGoto action_298+action_162 (43) = happyGoto action_114+action_162 (44) = happyGoto action_115+action_162 (45) = happyGoto action_116+action_162 (46) = happyGoto action_117+action_162 (47) = happyGoto action_118+action_162 (48) = happyGoto action_87+action_162 _ = happyReduce_60++action_163 _ = happyReduce_62++action_164 (67) = happyShift action_39+action_164 (68) = happyShift action_93+action_164 (69) = happyShift action_119+action_164 (72) = happyShift action_95+action_164 (79) = happyShift action_120+action_164 (81) = happyShift action_121+action_164 (89) = happyShift action_122+action_164 (90) = happyShift action_123+action_164 (91) = happyShift action_96+action_164 (92) = happyShift action_97+action_164 (93) = happyShift action_124+action_164 (94) = happyShift action_99+action_164 (97) = happyShift action_100+action_164 (99) = happyShift action_125+action_164 (101) = happyShift action_126+action_164 (103) = happyShift action_127+action_164 (105) = happyShift action_128+action_164 (109) = happyShift action_57+action_164 (113) = happyShift action_58+action_164 (114) = happyShift action_59+action_164 (115) = happyShift action_60+action_164 (117) = happyShift action_61+action_164 (118) = happyShift action_62+action_164 (120) = happyShift action_129+action_164 (121) = happyShift action_103+action_164 (23) = happyGoto action_296+action_164 (26) = happyGoto action_105+action_164 (27) = happyGoto action_106+action_164 (29) = happyGoto action_107+action_164 (30) = happyGoto action_297+action_164 (31) = happyGoto action_108+action_164 (32) = happyGoto action_109+action_164 (33) = happyGoto action_110+action_164 (34) = happyGoto action_111+action_164 (39) = happyGoto action_112+action_164 (41) = happyGoto action_156+action_164 (42) = happyGoto action_157+action_164 (43) = happyGoto action_114+action_164 (44) = happyGoto action_115+action_164 (45) = happyGoto action_116+action_164 (46) = happyGoto action_117+action_164 (47) = happyGoto action_118+action_164 (48) = happyGoto action_87+action_164 _ = happyReduce_60++action_165 _ = happyReduce_82++action_166 (108) = happyShift action_295+action_166 _ = happyFail++action_167 (99) = happyShift action_294+action_167 _ = happyFail++action_168 (99) = happyShift action_125+action_168 (101) = happyShift action_151+action_168 (103) = happyShift action_152+action_168 (105) = happyShift action_128+action_168 (109) = happyShift action_57+action_168 (113) = happyShift action_58+action_168 (114) = happyShift action_59+action_168 (115) = happyShift action_60+action_168 (117) = happyShift action_61+action_168 (118) = happyShift action_62+action_168 (26) = happyGoto action_147+action_168 (27) = happyGoto action_148+action_168 (31) = happyGoto action_293+action_168 (32) = happyGoto action_150+action_168 (33) = happyGoto action_110+action_168 (34) = happyGoto action_111+action_168 _ = happyReduce_60++action_169 _ = happyReduce_148++action_170 (100) = happyShift action_291+action_170 (107) = happyShift action_292+action_170 _ = happyFail++action_171 (67) = happyShift action_39+action_171 (68) = happyShift action_93+action_171 (69) = happyShift action_119+action_171 (72) = happyShift action_95+action_171 (79) = happyShift action_120+action_171 (81) = happyShift action_121+action_171 (89) = happyShift action_122+action_171 (90) = happyShift action_123+action_171 (91) = happyShift action_96+action_171 (92) = happyShift action_97+action_171 (93) = happyShift action_124+action_171 (94) = happyShift action_99+action_171 (97) = happyShift action_100+action_171 (99) = happyShift action_125+action_171 (101) = happyShift action_126+action_171 (103) = happyShift action_127+action_171 (105) = happyShift action_128+action_171 (109) = happyShift action_57+action_171 (113) = happyShift action_58+action_171 (114) = happyShift action_59+action_171 (115) = happyShift action_60+action_171 (117) = happyShift action_61+action_171 (118) = happyShift action_62+action_171 (120) = happyShift action_129+action_171 (121) = happyShift action_103+action_171 (23) = happyGoto action_104+action_171 (26) = happyGoto action_105+action_171 (27) = happyGoto action_106+action_171 (29) = happyGoto action_107+action_171 (31) = happyGoto action_108+action_171 (32) = happyGoto action_109+action_171 (33) = happyGoto action_110+action_171 (34) = happyGoto action_111+action_171 (39) = happyGoto action_112+action_171 (42) = happyGoto action_290+action_171 (43) = happyGoto action_114+action_171 (44) = happyGoto action_115+action_171 (45) = happyGoto action_116+action_171 (46) = happyGoto action_117+action_171 (47) = happyGoto action_118+action_171 (48) = happyGoto action_87+action_171 _ = happyReduce_60++action_172 (108) = happyShift action_289+action_172 _ = happyFail++action_173 (67) = happyShift action_39+action_173 (68) = happyShift action_93+action_173 (69) = happyShift action_119+action_173 (72) = happyShift action_95+action_173 (79) = happyShift action_120+action_173 (81) = happyShift action_121+action_173 (89) = happyShift action_122+action_173 (90) = happyShift action_123+action_173 (91) = happyShift action_96+action_173 (92) = happyShift action_97+action_173 (93) = happyShift action_124+action_173 (94) = happyShift action_99+action_173 (97) = happyShift action_100+action_173 (99) = happyShift action_125+action_173 (101) = happyShift action_126+action_173 (103) = happyShift action_127+action_173 (105) = happyShift action_128+action_173 (109) = happyShift action_57+action_173 (113) = happyShift action_58+action_173 (114) = happyShift action_59+action_173 (115) = happyShift action_60+action_173 (117) = happyShift action_61+action_173 (118) = happyShift action_62+action_173 (120) = happyShift action_129+action_173 (121) = happyShift action_103+action_173 (23) = happyGoto action_104+action_173 (26) = happyGoto action_105+action_173 (27) = happyGoto action_106+action_173 (29) = happyGoto action_107+action_173 (31) = happyGoto action_108+action_173 (32) = happyGoto action_109+action_173 (33) = happyGoto action_110+action_173 (34) = happyGoto action_111+action_173 (39) = happyGoto action_112+action_173 (42) = happyGoto action_288+action_173 (43) = happyGoto action_114+action_173 (44) = happyGoto action_115+action_173 (45) = happyGoto action_116+action_173 (46) = happyGoto action_117+action_173 (47) = happyGoto action_118+action_173 (48) = happyGoto action_87+action_173 _ = happyReduce_60++action_174 (67) = happyShift action_39+action_174 (23) = happyGoto action_138+action_174 (25) = happyGoto action_287+action_174 _ = happyFail++action_175 (99) = happyShift action_286+action_175 _ = happyFail++action_176 (100) = happyShift action_285+action_176 _ = happyFail++action_177 _ = happyReduce_31++action_178 (67) = happyShift action_39+action_178 (23) = happyGoto action_130+action_178 (55) = happyGoto action_284+action_178 _ = happyReduce_180++action_179 _ = happyReduce_32++action_180 (112) = happyShift action_283+action_180 _ = happyReduce_156++action_181 (67) = happyShift action_39+action_181 (93) = happyShift action_235+action_181 (95) = happyShift action_282+action_181 (103) = happyShift action_236+action_181 (109) = happyShift action_102+action_181 (23) = happyGoto action_233+action_181 (58) = happyGoto action_281+action_181 (62) = happyGoto action_231+action_181 _ = happyReduce_157++action_182 (110) = happyShift action_280+action_182 _ = happyFail++action_183 _ = happyReduce_54++action_184 (105) = happyShift action_278+action_184 (106) = happyShift action_279+action_184 _ = happyFail++action_185 (104) = happyShift action_277+action_185 _ = happyFail++action_186 (108) = happyReduce_59+action_186 _ = happyReduce_99++action_187 (97) = happyShift action_275+action_187 (106) = happyShift action_174+action_187 (108) = happyReduce_46+action_187 (111) = happyShift action_276+action_187 _ = happyReduce_138++action_188 (102) = happyShift action_274+action_188 _ = happyFail++action_189 (97) = happyShift action_272+action_189 (106) = happyShift action_174+action_189 (111) = happyShift action_273+action_189 _ = happyReduce_46++action_190 (108) = happyShift action_271+action_190 _ = happyFail++action_191 _ = happyReduce_134++action_192 (67) = happyShift action_39+action_192 (68) = happyShift action_93+action_192 (69) = happyShift action_119+action_192 (72) = happyShift action_95+action_192 (79) = happyShift action_120+action_192 (81) = happyShift action_121+action_192 (89) = happyShift action_122+action_192 (90) = happyShift action_123+action_192 (91) = happyShift action_96+action_192 (92) = happyShift action_97+action_192 (93) = happyShift action_124+action_192 (94) = happyShift action_99+action_192 (97) = happyShift action_100+action_192 (99) = happyShift action_125+action_192 (101) = happyShift action_126+action_192 (103) = happyShift action_127+action_192 (105) = happyShift action_128+action_192 (109) = happyShift action_57+action_192 (113) = happyShift action_58+action_192 (114) = happyShift action_59+action_192 (115) = happyShift action_60+action_192 (117) = happyShift action_61+action_192 (118) = happyShift action_62+action_192 (120) = happyShift action_129+action_192 (121) = happyShift action_103+action_192 (23) = happyGoto action_104+action_192 (26) = happyGoto action_105+action_192 (27) = happyGoto action_106+action_192 (29) = happyGoto action_107+action_192 (31) = happyGoto action_108+action_192 (32) = happyGoto action_109+action_192 (33) = happyGoto action_110+action_192 (34) = happyGoto action_111+action_192 (39) = happyGoto action_112+action_192 (40) = happyGoto action_185+action_192 (41) = happyGoto action_200+action_192 (42) = happyGoto action_157+action_192 (43) = happyGoto action_114+action_192 (44) = happyGoto action_115+action_192 (45) = happyGoto action_116+action_192 (46) = happyGoto action_117+action_192 (47) = happyGoto action_118+action_192 (48) = happyGoto action_87+action_192 _ = happyReduce_60++action_193 _ = happyReduce_119++action_194 _ = happyReduce_121++action_195 _ = happyReduce_84++action_196 (67) = happyShift action_39+action_196 (103) = happyShift action_270+action_196 (23) = happyGoto action_153+action_196 _ = happyFail++action_197 (82) = happyShift action_269+action_197 _ = happyFail++action_198 (67) = happyShift action_39+action_198 (23) = happyGoto action_268+action_198 _ = happyFail++action_199 (108) = happyShift action_162+action_199 (20) = happyGoto action_267+action_199 _ = happyReduce_38++action_200 _ = happyReduce_99++action_201 (67) = happyShift action_39+action_201 (68) = happyShift action_93+action_201 (69) = happyShift action_119+action_201 (72) = happyShift action_95+action_201 (89) = happyShift action_122+action_201 (90) = happyShift action_123+action_201 (91) = happyShift action_96+action_201 (92) = happyShift action_97+action_201 (93) = happyShift action_124+action_201 (94) = happyShift action_99+action_201 (97) = happyShift action_100+action_201 (103) = happyShift action_192+action_201 (121) = happyShift action_103+action_201 (23) = happyGoto action_104+action_201 (45) = happyGoto action_266+action_201 (46) = happyGoto action_117+action_201 (47) = happyGoto action_118+action_201 (48) = happyGoto action_87+action_201 _ = happyFail++action_202 _ = happyReduce_124++action_203 _ = happyReduce_126++action_204 (67) = happyShift action_39+action_204 (23) = happyGoto action_265+action_204 _ = happyFail++action_205 (67) = happyShift action_39+action_205 (68) = happyShift action_93+action_205 (69) = happyShift action_119+action_205 (72) = happyShift action_95+action_205 (79) = happyShift action_120+action_205 (81) = happyShift action_121+action_205 (89) = happyShift action_122+action_205 (90) = happyShift action_123+action_205 (91) = happyShift action_96+action_205 (92) = happyShift action_97+action_205 (93) = happyShift action_124+action_205 (94) = happyShift action_99+action_205 (97) = happyShift action_100+action_205 (99) = happyShift action_125+action_205 (101) = happyShift action_126+action_205 (103) = happyShift action_127+action_205 (105) = happyShift action_128+action_205 (109) = happyShift action_57+action_205 (113) = happyShift action_58+action_205 (114) = happyShift action_59+action_205 (115) = happyShift action_60+action_205 (117) = happyShift action_61+action_205 (118) = happyShift action_62+action_205 (120) = happyShift action_129+action_205 (121) = happyShift action_103+action_205 (23) = happyGoto action_104+action_205 (26) = happyGoto action_105+action_205 (27) = happyGoto action_106+action_205 (29) = happyGoto action_107+action_205 (31) = happyGoto action_108+action_205 (32) = happyGoto action_109+action_205 (33) = happyGoto action_110+action_205 (34) = happyGoto action_111+action_205 (39) = happyGoto action_112+action_205 (42) = happyGoto action_264+action_205 (43) = happyGoto action_114+action_205 (44) = happyGoto action_115+action_205 (45) = happyGoto action_116+action_205 (46) = happyGoto action_117+action_205 (47) = happyGoto action_118+action_205 (48) = happyGoto action_87+action_205 _ = happyReduce_60++action_206 (67) = happyShift action_39+action_206 (68) = happyShift action_93+action_206 (69) = happyShift action_119+action_206 (72) = happyShift action_95+action_206 (79) = happyShift action_120+action_206 (81) = happyShift action_121+action_206 (89) = happyShift action_122+action_206 (90) = happyShift action_123+action_206 (91) = happyShift action_96+action_206 (92) = happyShift action_97+action_206 (93) = happyShift action_124+action_206 (94) = happyShift action_99+action_206 (97) = happyShift action_100+action_206 (99) = happyShift action_125+action_206 (101) = happyShift action_126+action_206 (103) = happyShift action_127+action_206 (105) = happyShift action_128+action_206 (109) = happyShift action_57+action_206 (113) = happyShift action_58+action_206 (114) = happyShift action_59+action_206 (115) = happyShift action_60+action_206 (117) = happyShift action_61+action_206 (118) = happyShift action_62+action_206 (120) = happyShift action_129+action_206 (121) = happyShift action_103+action_206 (23) = happyGoto action_104+action_206 (26) = happyGoto action_105+action_206 (27) = happyGoto action_106+action_206 (29) = happyGoto action_107+action_206 (31) = happyGoto action_108+action_206 (32) = happyGoto action_109+action_206 (33) = happyGoto action_110+action_206 (34) = happyGoto action_111+action_206 (39) = happyGoto action_112+action_206 (42) = happyGoto action_263+action_206 (43) = happyGoto action_114+action_206 (44) = happyGoto action_115+action_206 (45) = happyGoto action_116+action_206 (46) = happyGoto action_117+action_206 (47) = happyGoto action_118+action_206 (48) = happyGoto action_87+action_206 _ = happyReduce_60++action_207 (67) = happyShift action_39+action_207 (68) = happyShift action_93+action_207 (69) = happyShift action_119+action_207 (72) = happyShift action_95+action_207 (79) = happyShift action_120+action_207 (81) = happyShift action_121+action_207 (89) = happyShift action_122+action_207 (90) = happyShift action_123+action_207 (91) = happyShift action_96+action_207 (92) = happyShift action_97+action_207 (93) = happyShift action_124+action_207 (94) = happyShift action_99+action_207 (97) = happyShift action_100+action_207 (99) = happyShift action_125+action_207 (101) = happyShift action_126+action_207 (103) = happyShift action_127+action_207 (105) = happyShift action_128+action_207 (109) = happyShift action_57+action_207 (113) = happyShift action_58+action_207 (114) = happyShift action_59+action_207 (115) = happyShift action_60+action_207 (117) = happyShift action_61+action_207 (118) = happyShift action_62+action_207 (120) = happyShift action_129+action_207 (121) = happyShift action_103+action_207 (23) = happyGoto action_104+action_207 (26) = happyGoto action_105+action_207 (27) = happyGoto action_106+action_207 (29) = happyGoto action_107+action_207 (31) = happyGoto action_108+action_207 (32) = happyGoto action_109+action_207 (33) = happyGoto action_110+action_207 (34) = happyGoto action_111+action_207 (39) = happyGoto action_112+action_207 (42) = happyGoto action_262+action_207 (43) = happyGoto action_114+action_207 (44) = happyGoto action_115+action_207 (45) = happyGoto action_116+action_207 (46) = happyGoto action_117+action_207 (47) = happyGoto action_118+action_207 (48) = happyGoto action_87+action_207 _ = happyReduce_60++action_208 (67) = happyShift action_39+action_208 (68) = happyShift action_93+action_208 (69) = happyShift action_119+action_208 (72) = happyShift action_95+action_208 (89) = happyShift action_122+action_208 (90) = happyShift action_123+action_208 (91) = happyShift action_96+action_208 (92) = happyShift action_97+action_208 (93) = happyShift action_124+action_208 (94) = happyShift action_99+action_208 (97) = happyShift action_100+action_208 (99) = happyShift action_125+action_208 (101) = happyShift action_218+action_208 (103) = happyShift action_127+action_208 (105) = happyShift action_128+action_208 (109) = happyShift action_57+action_208 (113) = happyShift action_58+action_208 (114) = happyShift action_59+action_208 (115) = happyShift action_60+action_208 (117) = happyShift action_61+action_208 (118) = happyShift action_62+action_208 (121) = happyShift action_103+action_208 (23) = happyGoto action_104+action_208 (26) = happyGoto action_212+action_208 (27) = happyGoto action_213+action_208 (29) = happyGoto action_214+action_208 (32) = happyGoto action_215+action_208 (33) = happyGoto action_110+action_208 (34) = happyGoto action_111+action_208 (43) = happyGoto action_260+action_208 (44) = happyGoto action_115+action_208 (45) = happyGoto action_261+action_208 (46) = happyGoto action_117+action_208 (47) = happyGoto action_118+action_208 (48) = happyGoto action_87+action_208 _ = happyFail++action_209 (67) = happyShift action_39+action_209 (68) = happyShift action_93+action_209 (69) = happyShift action_119+action_209 (72) = happyShift action_95+action_209 (79) = happyShift action_120+action_209 (81) = happyShift action_121+action_209 (89) = happyShift action_122+action_209 (90) = happyShift action_123+action_209 (91) = happyShift action_96+action_209 (92) = happyShift action_97+action_209 (93) = happyShift action_124+action_209 (94) = happyShift action_99+action_209 (97) = happyShift action_100+action_209 (99) = happyShift action_125+action_209 (101) = happyShift action_126+action_209 (103) = happyShift action_127+action_209 (105) = happyShift action_128+action_209 (109) = happyShift action_57+action_209 (113) = happyShift action_58+action_209 (114) = happyShift action_59+action_209 (115) = happyShift action_60+action_209 (117) = happyShift action_61+action_209 (118) = happyShift action_62+action_209 (120) = happyShift action_129+action_209 (121) = happyShift action_103+action_209 (23) = happyGoto action_104+action_209 (26) = happyGoto action_105+action_209 (27) = happyGoto action_106+action_209 (29) = happyGoto action_107+action_209 (31) = happyGoto action_108+action_209 (32) = happyGoto action_109+action_209 (33) = happyGoto action_110+action_209 (34) = happyGoto action_111+action_209 (39) = happyGoto action_112+action_209 (42) = happyGoto action_259+action_209 (43) = happyGoto action_114+action_209 (44) = happyGoto action_115+action_209 (45) = happyGoto action_116+action_209 (46) = happyGoto action_117+action_209 (47) = happyGoto action_118+action_209 (48) = happyGoto action_87+action_209 _ = happyReduce_60++action_210 (105) = happyShift action_128+action_210 (27) = happyGoto action_258+action_210 _ = happyFail++action_211 (105) = happyShift action_128+action_211 (27) = happyGoto action_257+action_211 _ = happyFail++action_212 (67) = happyShift action_39+action_212 (68) = happyShift action_93+action_212 (69) = happyShift action_119+action_212 (72) = happyShift action_95+action_212 (89) = happyShift action_122+action_212 (90) = happyShift action_123+action_212 (91) = happyShift action_96+action_212 (92) = happyShift action_97+action_212 (93) = happyShift action_124+action_212 (94) = happyShift action_99+action_212 (97) = happyShift action_100+action_212 (103) = happyShift action_256+action_212 (121) = happyShift action_103+action_212 (23) = happyGoto action_104+action_212 (45) = happyGoto action_255+action_212 (46) = happyGoto action_117+action_212 (47) = happyGoto action_118+action_212 (48) = happyGoto action_87+action_212 _ = happyFail++action_213 (97) = happyShift action_210+action_213 (111) = happyShift action_211+action_213 _ = happyReduce_116++action_214 _ = happyReduce_117++action_215 _ = happyReduce_115++action_216 _ = happyReduce_94++action_217 (119) = happyReduce_114+action_217 _ = happyReduce_110++action_218 (67) = happyShift action_39+action_218 (68) = happyShift action_93+action_218 (69) = happyShift action_119+action_218 (72) = happyShift action_95+action_218 (79) = happyShift action_120+action_218 (81) = happyShift action_121+action_218 (89) = happyShift action_122+action_218 (90) = happyShift action_123+action_218 (91) = happyShift action_96+action_218 (92) = happyShift action_97+action_218 (93) = happyShift action_124+action_218 (94) = happyShift action_99+action_218 (97) = happyShift action_100+action_218 (99) = happyShift action_125+action_218 (101) = happyShift action_126+action_218 (103) = happyShift action_127+action_218 (105) = happyShift action_128+action_218 (109) = happyShift action_57+action_218 (113) = happyShift action_58+action_218 (114) = happyShift action_59+action_218 (115) = happyShift action_60+action_218 (117) = happyShift action_61+action_218 (118) = happyShift action_62+action_218 (120) = happyShift action_129+action_218 (121) = happyShift action_103+action_218 (23) = happyGoto action_187+action_218 (25) = happyGoto action_159+action_218 (26) = happyGoto action_105+action_218 (27) = happyGoto action_106+action_218 (29) = happyGoto action_107+action_218 (31) = happyGoto action_108+action_218 (32) = happyGoto action_109+action_218 (33) = happyGoto action_110+action_218 (34) = happyGoto action_111+action_218 (39) = happyGoto action_112+action_218 (42) = happyGoto action_254+action_218 (43) = happyGoto action_114+action_218 (44) = happyGoto action_115+action_218 (45) = happyGoto action_116+action_218 (46) = happyGoto action_117+action_218 (47) = happyGoto action_118+action_218 (48) = happyGoto action_87+action_218 _ = happyReduce_60++action_219 (67) = happyShift action_39+action_219 (68) = happyShift action_93+action_219 (69) = happyShift action_119+action_219 (72) = happyShift action_95+action_219 (79) = happyShift action_120+action_219 (81) = happyShift action_121+action_219 (89) = happyShift action_122+action_219 (90) = happyShift action_123+action_219 (91) = happyShift action_96+action_219 (92) = happyShift action_97+action_219 (93) = happyShift action_124+action_219 (94) = happyShift action_99+action_219 (97) = happyShift action_100+action_219 (99) = happyShift action_125+action_219 (101) = happyShift action_126+action_219 (103) = happyShift action_127+action_219 (105) = happyShift action_128+action_219 (109) = happyShift action_57+action_219 (113) = happyShift action_58+action_219 (114) = happyShift action_59+action_219 (115) = happyShift action_60+action_219 (117) = happyShift action_61+action_219 (118) = happyShift action_62+action_219 (120) = happyShift action_129+action_219 (121) = happyShift action_103+action_219 (23) = happyGoto action_252+action_219 (26) = happyGoto action_105+action_219 (27) = happyGoto action_106+action_219 (29) = happyGoto action_107+action_219 (30) = happyGoto action_253+action_219 (31) = happyGoto action_108+action_219 (32) = happyGoto action_109+action_219 (33) = happyGoto action_110+action_219 (34) = happyGoto action_111+action_219 (39) = happyGoto action_112+action_219 (40) = happyGoto action_185+action_219 (41) = happyGoto action_186+action_219 (42) = happyGoto action_157+action_219 (43) = happyGoto action_114+action_219 (44) = happyGoto action_115+action_219 (45) = happyGoto action_116+action_219 (46) = happyGoto action_117+action_219 (47) = happyGoto action_118+action_219 (48) = happyGoto action_87+action_219 _ = happyReduce_60++action_220 (67) = happyReduce_177+action_220 (70) = happyReduce_177+action_220 (71) = happyReduce_177+action_220 (72) = happyReduce_177+action_220 (73) = happyReduce_177+action_220 (75) = happyReduce_177+action_220 (76) = happyReduce_177+action_220 (77) = happyReduce_177+action_220 (78) = happyReduce_177+action_220 (81) = happyReduce_177+action_220 (83) = happyReduce_177+action_220 (84) = happyReduce_177+action_220 (85) = happyReduce_177+action_220 (86) = happyReduce_177+action_220 (87) = happyReduce_177+action_220 (93) = happyReduce_177+action_220 (95) = happyReduce_177+action_220 (100) = happyReduce_177+action_220 (103) = happyReduce_177+action_220 (104) = happyReduce_177+action_220 (106) = happyReduce_177+action_220 (107) = happyReduce_177+action_220 (109) = happyReduce_177+action_220 (110) = happyReduce_177+action_220 (112) = happyReduce_177+action_220 (122) = happyReduce_177+action_220 _ = happyReduce_177++action_221 _ = happyReduce_166++action_222 _ = happyReduce_165++action_223 (98) = happyShift action_240+action_223 _ = happyReduce_123++action_224 (104) = happyShift action_251+action_224 _ = happyFail++action_225 (67) = happyShift action_39+action_225 (68) = happyShift action_93+action_225 (69) = happyShift action_119+action_225 (72) = happyShift action_95+action_225 (79) = happyShift action_120+action_225 (81) = happyShift action_121+action_225 (89) = happyShift action_122+action_225 (90) = happyShift action_123+action_225 (91) = happyShift action_96+action_225 (92) = happyShift action_97+action_225 (93) = happyShift action_98+action_225 (94) = happyShift action_99+action_225 (97) = happyShift action_100+action_225 (99) = happyShift action_125+action_225 (101) = happyShift action_126+action_225 (103) = happyShift action_225+action_225 (104) = happyShift action_226+action_225 (105) = happyShift action_128+action_225 (109) = happyShift action_227+action_225 (113) = happyShift action_58+action_225 (114) = happyShift action_59+action_225 (115) = happyShift action_60+action_225 (117) = happyShift action_61+action_225 (118) = happyShift action_62+action_225 (120) = happyShift action_129+action_225 (121) = happyShift action_103+action_225 (23) = happyGoto action_250+action_225 (26) = happyGoto action_105+action_225 (27) = happyGoto action_106+action_225 (29) = happyGoto action_107+action_225 (30) = happyGoto action_155+action_225 (31) = happyGoto action_108+action_225 (32) = happyGoto action_109+action_225 (33) = happyGoto action_110+action_225 (34) = happyGoto action_111+action_225 (39) = happyGoto action_112+action_225 (40) = happyGoto action_185+action_225 (41) = happyGoto action_186+action_225 (42) = happyGoto action_157+action_225 (43) = happyGoto action_114+action_225 (44) = happyGoto action_115+action_225 (45) = happyGoto action_116+action_225 (46) = happyGoto action_117+action_225 (47) = happyGoto action_223+action_225 (48) = happyGoto action_87+action_225 (58) = happyGoto action_88+action_225 (59) = happyGoto action_224+action_225 (60) = happyGoto action_90+action_225 (61) = happyGoto action_91+action_225 (62) = happyGoto action_92+action_225 _ = happyReduce_60++action_226 _ = happyReduce_161++action_227 (67) = happyShift action_39+action_227 (68) = happyShift action_93+action_227 (69) = happyShift action_94+action_227 (72) = happyShift action_95+action_227 (89) = happyShift action_222+action_227 (91) = happyShift action_96+action_227 (92) = happyShift action_97+action_227 (93) = happyShift action_124+action_227 (94) = happyShift action_99+action_227 (97) = happyShift action_100+action_227 (103) = happyShift action_192+action_227 (121) = happyShift action_103+action_227 (23) = happyGoto action_220+action_227 (47) = happyGoto action_221+action_227 (48) = happyGoto action_87+action_227 _ = happyReduce_51++action_228 (108) = happyShift action_249+action_228 _ = happyFail++action_229 (67) = happyReduce_176+action_229 (70) = happyReduce_176+action_229 (71) = happyReduce_176+action_229 (72) = happyReduce_176+action_229 (73) = happyReduce_176+action_229 (75) = happyReduce_176+action_229 (76) = happyReduce_176+action_229 (77) = happyReduce_176+action_229 (78) = happyReduce_176+action_229 (81) = happyReduce_176+action_229 (83) = happyReduce_176+action_229 (84) = happyReduce_176+action_229 (85) = happyReduce_176+action_229 (86) = happyReduce_176+action_229 (87) = happyReduce_176+action_229 (93) = happyReduce_176+action_229 (95) = happyReduce_176+action_229 (100) = happyReduce_176+action_229 (103) = happyReduce_176+action_229 (104) = happyReduce_176+action_229 (106) = happyReduce_176+action_229 (107) = happyReduce_176+action_229 (109) = happyReduce_176+action_229 (112) = happyReduce_176+action_229 (122) = happyReduce_176+action_229 _ = happyReduce_138++action_230 _ = happyReduce_164++action_231 _ = happyReduce_163++action_232 (67) = happyShift action_39+action_232 (23) = happyGoto action_37+action_232 (24) = happyGoto action_246+action_232 (49) = happyGoto action_247+action_232 (50) = happyGoto action_248+action_232 _ = happyReduce_141++action_233 _ = happyReduce_176++action_234 _ = happyReduce_174++action_235 (67) = happyShift action_39+action_235 (93) = happyShift action_235+action_235 (103) = happyShift action_236+action_235 (109) = happyShift action_102+action_235 (23) = happyGoto action_233+action_235 (58) = happyGoto action_230+action_235 (62) = happyGoto action_231+action_235 _ = happyFail++action_236 (67) = happyShift action_39+action_236 (68) = happyShift action_93+action_236 (69) = happyShift action_94+action_236 (72) = happyShift action_95+action_236 (91) = happyShift action_96+action_236 (92) = happyShift action_97+action_236 (93) = happyShift action_98+action_236 (94) = happyShift action_99+action_236 (97) = happyShift action_100+action_236 (103) = happyShift action_101+action_236 (104) = happyShift action_226+action_236 (109) = happyShift action_102+action_236 (121) = happyShift action_103+action_236 (23) = happyGoto action_85+action_236 (47) = happyGoto action_86+action_236 (48) = happyGoto action_87+action_236 (58) = happyGoto action_88+action_236 (59) = happyGoto action_224+action_236 (60) = happyGoto action_90+action_236 (61) = happyGoto action_91+action_236 (62) = happyGoto action_92+action_236 _ = happyFail++action_237 _ = happyReduce_175++action_238 (67) = happyShift action_39+action_238 (68) = happyShift action_93+action_238 (69) = happyShift action_94+action_238 (72) = happyShift action_95+action_238 (91) = happyShift action_96+action_238 (92) = happyShift action_97+action_238 (93) = happyShift action_98+action_238 (94) = happyShift action_99+action_238 (97) = happyShift action_100+action_238 (103) = happyShift action_101+action_238 (109) = happyShift action_102+action_238 (121) = happyShift action_103+action_238 (23) = happyGoto action_85+action_238 (47) = happyGoto action_86+action_238 (48) = happyGoto action_87+action_238 (58) = happyGoto action_88+action_238 (60) = happyGoto action_245+action_238 (61) = happyGoto action_91+action_238 (62) = happyGoto action_92+action_238 _ = happyFail++action_239 (67) = happyShift action_39+action_239 (68) = happyShift action_93+action_239 (69) = happyShift action_94+action_239 (72) = happyShift action_95+action_239 (91) = happyShift action_96+action_239 (92) = happyShift action_97+action_239 (93) = happyShift action_98+action_239 (94) = happyShift action_99+action_239 (97) = happyShift action_100+action_239 (103) = happyShift action_101+action_239 (109) = happyShift action_102+action_239 (121) = happyShift action_103+action_239 (23) = happyGoto action_85+action_239 (47) = happyGoto action_86+action_239 (48) = happyGoto action_87+action_239 (58) = happyGoto action_88+action_239 (59) = happyGoto action_244+action_239 (60) = happyGoto action_90+action_239 (61) = happyGoto action_91+action_239 (62) = happyGoto action_92+action_239 _ = happyFail++action_240 (67) = happyShift action_39+action_240 (23) = happyGoto action_243+action_240 _ = happyFail++action_241 (67) = happyShift action_39+action_241 (68) = happyShift action_93+action_241 (69) = happyShift action_94+action_241 (72) = happyShift action_95+action_241 (91) = happyShift action_96+action_241 (92) = happyShift action_97+action_241 (93) = happyShift action_124+action_241 (94) = happyShift action_99+action_241 (97) = happyShift action_100+action_241 (103) = happyShift action_192+action_241 (121) = happyShift action_103+action_241 (23) = happyGoto action_104+action_241 (47) = happyGoto action_242+action_241 (48) = happyGoto action_87+action_241 _ = happyFail++action_242 _ = happyReduce_171++action_243 _ = happyReduce_170++action_244 _ = happyReduce_167++action_245 _ = happyReduce_173++action_246 (112) = happyShift action_346+action_246 _ = happyFail++action_247 (100) = happyShift action_345+action_247 _ = happyFail++action_248 (107) = happyShift action_344+action_248 _ = happyReduce_140++action_249 (67) = happyShift action_39+action_249 (68) = happyShift action_93+action_249 (69) = happyShift action_119+action_249 (72) = happyShift action_95+action_249 (79) = happyShift action_120+action_249 (81) = happyShift action_121+action_249 (89) = happyShift action_122+action_249 (90) = happyShift action_123+action_249 (91) = happyShift action_96+action_249 (92) = happyShift action_97+action_249 (93) = happyShift action_124+action_249 (94) = happyShift action_99+action_249 (97) = happyShift action_100+action_249 (99) = happyShift action_125+action_249 (101) = happyShift action_126+action_249 (103) = happyShift action_127+action_249 (105) = happyShift action_128+action_249 (109) = happyShift action_57+action_249 (113) = happyShift action_58+action_249 (114) = happyShift action_59+action_249 (115) = happyShift action_60+action_249 (117) = happyShift action_61+action_249 (118) = happyShift action_62+action_249 (120) = happyShift action_129+action_249 (121) = happyShift action_103+action_249 (23) = happyGoto action_104+action_249 (26) = happyGoto action_105+action_249 (27) = happyGoto action_106+action_249 (29) = happyGoto action_107+action_249 (31) = happyGoto action_108+action_249 (32) = happyGoto action_109+action_249 (33) = happyGoto action_110+action_249 (34) = happyGoto action_111+action_249 (39) = happyGoto action_112+action_249 (42) = happyGoto action_343+action_249 (43) = happyGoto action_114+action_249 (44) = happyGoto action_115+action_249 (45) = happyGoto action_116+action_249 (46) = happyGoto action_117+action_249 (47) = happyGoto action_118+action_249 (48) = happyGoto action_87+action_249 _ = happyReduce_60++action_250 (67) = happyReduce_176+action_250 (93) = happyReduce_176+action_250 (97) = happyShift action_342+action_250 (103) = happyReduce_176+action_250 (104) = happyReduce_176+action_250 (106) = happyReduce_176+action_250 (109) = happyReduce_176+action_250 (111) = happyShift action_304+action_250 _ = happyReduce_138++action_251 _ = happyReduce_162++action_252 (97) = happyShift action_340+action_252 (111) = happyShift action_341+action_252 _ = happyReduce_138++action_253 (108) = happyShift action_339+action_253 _ = happyFail++action_254 (102) = happyShift action_338+action_254 _ = happyFail++action_255 _ = happyReduce_114++action_256 (67) = happyShift action_39+action_256 (68) = happyShift action_93+action_256 (69) = happyShift action_119+action_256 (72) = happyShift action_95+action_256 (79) = happyShift action_120+action_256 (81) = happyShift action_121+action_256 (89) = happyShift action_122+action_256 (90) = happyShift action_123+action_256 (91) = happyShift action_96+action_256 (92) = happyShift action_97+action_256 (93) = happyShift action_124+action_256 (94) = happyShift action_99+action_256 (97) = happyShift action_100+action_256 (99) = happyShift action_125+action_256 (101) = happyShift action_126+action_256 (103) = happyShift action_127+action_256 (105) = happyShift action_128+action_256 (109) = happyShift action_57+action_256 (113) = happyShift action_58+action_256 (114) = happyShift action_59+action_256 (115) = happyShift action_60+action_256 (117) = happyShift action_61+action_256 (118) = happyShift action_62+action_256 (120) = happyShift action_129+action_256 (121) = happyShift action_103+action_256 (23) = happyGoto action_296+action_256 (26) = happyGoto action_105+action_256 (27) = happyGoto action_106+action_256 (29) = happyGoto action_107+action_256 (30) = happyGoto action_297+action_256 (31) = happyGoto action_108+action_256 (32) = happyGoto action_109+action_256 (33) = happyGoto action_110+action_256 (34) = happyGoto action_111+action_256 (39) = happyGoto action_112+action_256 (40) = happyGoto action_185+action_256 (41) = happyGoto action_186+action_256 (42) = happyGoto action_157+action_256 (43) = happyGoto action_114+action_256 (44) = happyGoto action_115+action_256 (45) = happyGoto action_116+action_256 (46) = happyGoto action_117+action_256 (47) = happyGoto action_118+action_256 (48) = happyGoto action_87+action_256 _ = happyReduce_60++action_257 _ = happyReduce_58++action_258 _ = happyReduce_57++action_259 _ = happyReduce_102++action_260 _ = happyReduce_111++action_261 (119) = happyReduce_112+action_261 _ = happyReduce_110++action_262 _ = happyReduce_107++action_263 _ = happyReduce_109++action_264 _ = happyReduce_108++action_265 _ = happyReduce_125++action_266 _ = happyReduce_122++action_267 (99) = happyShift action_337+action_267 _ = happyFail++action_268 (102) = happyShift action_165+action_268 (108) = happyShift action_336+action_268 _ = happyFail++action_269 (67) = happyShift action_39+action_269 (68) = happyShift action_93+action_269 (69) = happyShift action_119+action_269 (72) = happyShift action_95+action_269 (79) = happyShift action_120+action_269 (81) = happyShift action_121+action_269 (89) = happyShift action_122+action_269 (90) = happyShift action_123+action_269 (91) = happyShift action_96+action_269 (92) = happyShift action_97+action_269 (93) = happyShift action_124+action_269 (94) = happyShift action_99+action_269 (97) = happyShift action_100+action_269 (99) = happyShift action_125+action_269 (101) = happyShift action_126+action_269 (103) = happyShift action_127+action_269 (105) = happyShift action_128+action_269 (109) = happyShift action_57+action_269 (113) = happyShift action_58+action_269 (114) = happyShift action_59+action_269 (115) = happyShift action_60+action_269 (117) = happyShift action_61+action_269 (118) = happyShift action_62+action_269 (120) = happyShift action_129+action_269 (121) = happyShift action_103+action_269 (23) = happyGoto action_104+action_269 (26) = happyGoto action_105+action_269 (27) = happyGoto action_106+action_269 (29) = happyGoto action_107+action_269 (31) = happyGoto action_108+action_269 (32) = happyGoto action_109+action_269 (33) = happyGoto action_110+action_269 (34) = happyGoto action_111+action_269 (39) = happyGoto action_112+action_269 (40) = happyGoto action_335+action_269 (41) = happyGoto action_200+action_269 (42) = happyGoto action_157+action_269 (43) = happyGoto action_114+action_269 (44) = happyGoto action_115+action_269 (45) = happyGoto action_116+action_269 (46) = happyGoto action_117+action_269 (47) = happyGoto action_118+action_269 (48) = happyGoto action_87+action_269 _ = happyReduce_60++action_270 (67) = happyShift action_39+action_270 (23) = happyGoto action_334+action_270 _ = happyFail++action_271 (67) = happyShift action_39+action_271 (68) = happyShift action_93+action_271 (69) = happyShift action_119+action_271 (72) = happyShift action_95+action_271 (79) = happyShift action_120+action_271 (81) = happyShift action_121+action_271 (89) = happyShift action_122+action_271 (90) = happyShift action_123+action_271 (91) = happyShift action_96+action_271 (92) = happyShift action_97+action_271 (93) = happyShift action_124+action_271 (94) = happyShift action_99+action_271 (97) = happyShift action_100+action_271 (99) = happyShift action_125+action_271 (101) = happyShift action_126+action_271 (103) = happyShift action_127+action_271 (105) = happyShift action_128+action_271 (109) = happyShift action_57+action_271 (113) = happyShift action_58+action_271 (114) = happyShift action_59+action_271 (115) = happyShift action_60+action_271 (117) = happyShift action_61+action_271 (118) = happyShift action_62+action_271 (120) = happyShift action_129+action_271 (121) = happyShift action_103+action_271 (23) = happyGoto action_104+action_271 (26) = happyGoto action_105+action_271 (27) = happyGoto action_106+action_271 (29) = happyGoto action_107+action_271 (31) = happyGoto action_108+action_271 (32) = happyGoto action_109+action_271 (33) = happyGoto action_110+action_271 (34) = happyGoto action_111+action_271 (39) = happyGoto action_112+action_271 (42) = happyGoto action_333+action_271 (43) = happyGoto action_114+action_271 (44) = happyGoto action_115+action_271 (45) = happyGoto action_116+action_271 (46) = happyGoto action_117+action_271 (47) = happyGoto action_118+action_271 (48) = happyGoto action_87+action_271 _ = happyReduce_60++action_272 (67) = happyShift action_39+action_272 (68) = happyShift action_93+action_272 (69) = happyShift action_119+action_272 (72) = happyShift action_95+action_272 (79) = happyShift action_120+action_272 (81) = happyShift action_121+action_272 (89) = happyShift action_122+action_272 (90) = happyShift action_123+action_272 (91) = happyShift action_96+action_272 (92) = happyShift action_97+action_272 (93) = happyShift action_124+action_272 (94) = happyShift action_99+action_272 (97) = happyShift action_100+action_272 (99) = happyShift action_125+action_272 (101) = happyShift action_126+action_272 (103) = happyShift action_127+action_272 (105) = happyShift action_128+action_272 (109) = happyShift action_57+action_272 (113) = happyShift action_58+action_272 (114) = happyShift action_59+action_272 (115) = happyShift action_60+action_272 (117) = happyShift action_61+action_272 (118) = happyShift action_62+action_272 (120) = happyShift action_129+action_272 (121) = happyShift action_103+action_272 (23) = happyGoto action_104+action_272 (26) = happyGoto action_105+action_272 (27) = happyGoto action_106+action_272 (29) = happyGoto action_107+action_272 (31) = happyGoto action_108+action_272 (32) = happyGoto action_109+action_272 (33) = happyGoto action_110+action_272 (34) = happyGoto action_111+action_272 (39) = happyGoto action_112+action_272 (42) = happyGoto action_332+action_272 (43) = happyGoto action_114+action_272 (44) = happyGoto action_115+action_272 (45) = happyGoto action_116+action_272 (46) = happyGoto action_117+action_272 (47) = happyGoto action_118+action_272 (48) = happyGoto action_87+action_272 _ = happyReduce_60++action_273 (67) = happyShift action_39+action_273 (68) = happyShift action_93+action_273 (69) = happyShift action_119+action_273 (72) = happyShift action_95+action_273 (79) = happyShift action_120+action_273 (81) = happyShift action_121+action_273 (89) = happyShift action_122+action_273 (90) = happyShift action_123+action_273 (91) = happyShift action_96+action_273 (92) = happyShift action_97+action_273 (93) = happyShift action_124+action_273 (94) = happyShift action_99+action_273 (97) = happyShift action_100+action_273 (99) = happyShift action_125+action_273 (101) = happyShift action_126+action_273 (103) = happyShift action_127+action_273 (105) = happyShift action_128+action_273 (109) = happyShift action_57+action_273 (113) = happyShift action_58+action_273 (114) = happyShift action_59+action_273 (115) = happyShift action_60+action_273 (117) = happyShift action_61+action_273 (118) = happyShift action_62+action_273 (120) = happyShift action_129+action_273 (121) = happyShift action_103+action_273 (23) = happyGoto action_104+action_273 (26) = happyGoto action_105+action_273 (27) = happyGoto action_106+action_273 (29) = happyGoto action_107+action_273 (31) = happyGoto action_108+action_273 (32) = happyGoto action_109+action_273 (33) = happyGoto action_110+action_273 (34) = happyGoto action_111+action_273 (39) = happyGoto action_112+action_273 (42) = happyGoto action_331+action_273 (43) = happyGoto action_114+action_273 (44) = happyGoto action_115+action_273 (45) = happyGoto action_116+action_273 (46) = happyGoto action_117+action_273 (47) = happyGoto action_118+action_273 (48) = happyGoto action_87+action_273 _ = happyReduce_60++action_274 (119) = happyReduce_113+action_274 _ = happyReduce_93++action_275 (67) = happyShift action_39+action_275 (68) = happyShift action_93+action_275 (69) = happyShift action_119+action_275 (72) = happyShift action_95+action_275 (79) = happyShift action_120+action_275 (81) = happyShift action_121+action_275 (89) = happyShift action_122+action_275 (90) = happyShift action_123+action_275 (91) = happyShift action_96+action_275 (92) = happyShift action_97+action_275 (93) = happyShift action_124+action_275 (94) = happyShift action_99+action_275 (97) = happyShift action_100+action_275 (99) = happyShift action_125+action_275 (101) = happyShift action_126+action_275 (103) = happyShift action_127+action_275 (105) = happyShift action_128+action_275 (109) = happyShift action_57+action_275 (113) = happyShift action_58+action_275 (114) = happyShift action_59+action_275 (115) = happyShift action_60+action_275 (117) = happyShift action_61+action_275 (118) = happyShift action_62+action_275 (120) = happyShift action_129+action_275 (121) = happyShift action_103+action_275 (23) = happyGoto action_104+action_275 (26) = happyGoto action_105+action_275 (27) = happyGoto action_106+action_275 (29) = happyGoto action_107+action_275 (31) = happyGoto action_108+action_275 (32) = happyGoto action_109+action_275 (33) = happyGoto action_110+action_275 (34) = happyGoto action_111+action_275 (39) = happyGoto action_112+action_275 (42) = happyGoto action_330+action_275 (43) = happyGoto action_114+action_275 (44) = happyGoto action_115+action_275 (45) = happyGoto action_116+action_275 (46) = happyGoto action_117+action_275 (47) = happyGoto action_118+action_275 (48) = happyGoto action_87+action_275 _ = happyReduce_60++action_276 (67) = happyShift action_39+action_276 (68) = happyShift action_93+action_276 (69) = happyShift action_119+action_276 (72) = happyShift action_95+action_276 (79) = happyShift action_120+action_276 (81) = happyShift action_121+action_276 (89) = happyShift action_122+action_276 (90) = happyShift action_123+action_276 (91) = happyShift action_96+action_276 (92) = happyShift action_97+action_276 (93) = happyShift action_124+action_276 (94) = happyShift action_99+action_276 (97) = happyShift action_100+action_276 (99) = happyShift action_125+action_276 (101) = happyShift action_126+action_276 (103) = happyShift action_127+action_276 (105) = happyShift action_128+action_276 (109) = happyShift action_57+action_276 (113) = happyShift action_58+action_276 (114) = happyShift action_59+action_276 (115) = happyShift action_60+action_276 (117) = happyShift action_61+action_276 (118) = happyShift action_62+action_276 (120) = happyShift action_129+action_276 (121) = happyShift action_103+action_276 (23) = happyGoto action_104+action_276 (26) = happyGoto action_105+action_276 (27) = happyGoto action_106+action_276 (29) = happyGoto action_107+action_276 (31) = happyGoto action_108+action_276 (32) = happyGoto action_109+action_276 (33) = happyGoto action_110+action_276 (34) = happyGoto action_111+action_276 (39) = happyGoto action_112+action_276 (42) = happyGoto action_329+action_276 (43) = happyGoto action_114+action_276 (44) = happyGoto action_115+action_276 (45) = happyGoto action_116+action_276 (46) = happyGoto action_117+action_276 (47) = happyGoto action_118+action_276 (48) = happyGoto action_87+action_276 _ = happyReduce_60++action_277 _ = happyReduce_132++action_278 _ = happyReduce_55++action_279 (67) = happyShift action_39+action_279 (68) = happyShift action_93+action_279 (69) = happyShift action_119+action_279 (72) = happyShift action_95+action_279 (79) = happyShift action_120+action_279 (81) = happyShift action_121+action_279 (89) = happyShift action_122+action_279 (90) = happyShift action_123+action_279 (91) = happyShift action_96+action_279 (92) = happyShift action_97+action_279 (93) = happyShift action_124+action_279 (94) = happyShift action_99+action_279 (97) = happyShift action_100+action_279 (99) = happyShift action_125+action_279 (101) = happyShift action_126+action_279 (103) = happyShift action_127+action_279 (105) = happyShift action_128+action_279 (109) = happyShift action_57+action_279 (113) = happyShift action_58+action_279 (114) = happyShift action_59+action_279 (115) = happyShift action_60+action_279 (117) = happyShift action_61+action_279 (118) = happyShift action_62+action_279 (120) = happyShift action_129+action_279 (121) = happyShift action_103+action_279 (23) = happyGoto action_104+action_279 (26) = happyGoto action_105+action_279 (27) = happyGoto action_106+action_279 (28) = happyGoto action_328+action_279 (29) = happyGoto action_107+action_279 (31) = happyGoto action_108+action_279 (32) = happyGoto action_109+action_279 (33) = happyGoto action_110+action_279 (34) = happyGoto action_111+action_279 (39) = happyGoto action_112+action_279 (42) = happyGoto action_184+action_279 (43) = happyGoto action_114+action_279 (44) = happyGoto action_115+action_279 (45) = happyGoto action_116+action_279 (46) = happyGoto action_117+action_279 (47) = happyGoto action_118+action_279 (48) = happyGoto action_87+action_279 _ = happyReduce_60++action_280 (67) = happyShift action_39+action_280 (68) = happyShift action_93+action_280 (69) = happyShift action_119+action_280 (72) = happyShift action_95+action_280 (79) = happyShift action_120+action_280 (81) = happyShift action_121+action_280 (89) = happyShift action_122+action_280 (90) = happyShift action_123+action_280 (91) = happyShift action_96+action_280 (92) = happyShift action_97+action_280 (93) = happyShift action_124+action_280 (94) = happyShift action_99+action_280 (97) = happyShift action_100+action_280 (99) = happyShift action_125+action_280 (101) = happyShift action_126+action_280 (103) = happyShift action_127+action_280 (105) = happyShift action_128+action_280 (109) = happyShift action_57+action_280 (113) = happyShift action_58+action_280 (114) = happyShift action_59+action_280 (115) = happyShift action_60+action_280 (117) = happyShift action_61+action_280 (118) = happyShift action_62+action_280 (120) = happyShift action_129+action_280 (121) = happyShift action_103+action_280 (23) = happyGoto action_104+action_280 (26) = happyGoto action_105+action_280 (27) = happyGoto action_106+action_280 (29) = happyGoto action_107+action_280 (31) = happyGoto action_108+action_280 (32) = happyGoto action_109+action_280 (33) = happyGoto action_110+action_280 (34) = happyGoto action_111+action_280 (39) = happyGoto action_112+action_280 (40) = happyGoto action_327+action_280 (41) = happyGoto action_200+action_280 (42) = happyGoto action_157+action_280 (43) = happyGoto action_114+action_280 (44) = happyGoto action_115+action_280 (45) = happyGoto action_116+action_280 (46) = happyGoto action_117+action_280 (47) = happyGoto action_118+action_280 (48) = happyGoto action_87+action_280 _ = happyReduce_60++action_281 _ = happyReduce_159++action_282 (67) = happyShift action_39+action_282 (68) = happyShift action_93+action_282 (69) = happyShift action_94+action_282 (72) = happyShift action_95+action_282 (91) = happyShift action_96+action_282 (92) = happyShift action_97+action_282 (93) = happyShift action_98+action_282 (94) = happyShift action_99+action_282 (97) = happyShift action_100+action_282 (103) = happyShift action_101+action_282 (109) = happyShift action_102+action_282 (121) = happyShift action_103+action_282 (23) = happyGoto action_85+action_282 (47) = happyGoto action_86+action_282 (48) = happyGoto action_87+action_282 (58) = happyGoto action_88+action_282 (60) = happyGoto action_326+action_282 (61) = happyGoto action_91+action_282 (62) = happyGoto action_92+action_282 _ = happyFail++action_283 (67) = happyShift action_39+action_283 (68) = happyShift action_93+action_283 (69) = happyShift action_119+action_283 (72) = happyShift action_95+action_283 (79) = happyShift action_120+action_283 (81) = happyShift action_121+action_283 (89) = happyShift action_122+action_283 (90) = happyShift action_123+action_283 (91) = happyShift action_96+action_283 (92) = happyShift action_97+action_283 (93) = happyShift action_124+action_283 (94) = happyShift action_99+action_283 (97) = happyShift action_100+action_283 (99) = happyShift action_125+action_283 (101) = happyShift action_126+action_283 (103) = happyShift action_127+action_283 (105) = happyShift action_128+action_283 (109) = happyShift action_57+action_283 (113) = happyShift action_58+action_283 (114) = happyShift action_59+action_283 (115) = happyShift action_60+action_283 (117) = happyShift action_61+action_283 (118) = happyShift action_62+action_283 (120) = happyShift action_129+action_283 (121) = happyShift action_103+action_283 (23) = happyGoto action_104+action_283 (26) = happyGoto action_105+action_283 (27) = happyGoto action_106+action_283 (29) = happyGoto action_107+action_283 (31) = happyGoto action_108+action_283 (32) = happyGoto action_109+action_283 (33) = happyGoto action_110+action_283 (34) = happyGoto action_111+action_283 (39) = happyGoto action_112+action_283 (40) = happyGoto action_325+action_283 (41) = happyGoto action_200+action_283 (42) = happyGoto action_157+action_283 (43) = happyGoto action_114+action_283 (44) = happyGoto action_115+action_283 (45) = happyGoto action_116+action_283 (46) = happyGoto action_117+action_283 (47) = happyGoto action_118+action_283 (48) = happyGoto action_87+action_283 _ = happyReduce_60++action_284 _ = happyReduce_179++action_285 (74) = happyShift action_319+action_285 (22) = happyGoto action_324+action_285 _ = happyReduce_41++action_286 (67) = happyShift action_39+action_286 (23) = happyGoto action_168+action_286 (52) = happyGoto action_323+action_286 _ = happyFail++action_287 _ = happyReduce_47++action_288 (104) = happyShift action_322+action_288 _ = happyFail++action_289 (67) = happyShift action_39+action_289 (68) = happyShift action_93+action_289 (69) = happyShift action_119+action_289 (72) = happyShift action_95+action_289 (79) = happyShift action_120+action_289 (81) = happyShift action_121+action_289 (89) = happyShift action_122+action_289 (90) = happyShift action_123+action_289 (91) = happyShift action_96+action_289 (92) = happyShift action_97+action_289 (93) = happyShift action_124+action_289 (94) = happyShift action_99+action_289 (97) = happyShift action_100+action_289 (99) = happyShift action_125+action_289 (101) = happyShift action_126+action_289 (103) = happyShift action_127+action_289 (105) = happyShift action_128+action_289 (109) = happyShift action_57+action_289 (113) = happyShift action_58+action_289 (114) = happyShift action_59+action_289 (115) = happyShift action_60+action_289 (117) = happyShift action_61+action_289 (118) = happyShift action_62+action_289 (120) = happyShift action_129+action_289 (121) = happyShift action_103+action_289 (23) = happyGoto action_104+action_289 (26) = happyGoto action_105+action_289 (27) = happyGoto action_106+action_289 (29) = happyGoto action_107+action_289 (31) = happyGoto action_108+action_289 (32) = happyGoto action_109+action_289 (33) = happyGoto action_110+action_289 (34) = happyGoto action_111+action_289 (39) = happyGoto action_112+action_289 (42) = happyGoto action_321+action_289 (43) = happyGoto action_114+action_289 (44) = happyGoto action_115+action_289 (45) = happyGoto action_116+action_289 (46) = happyGoto action_117+action_289 (47) = happyGoto action_118+action_289 (48) = happyGoto action_87+action_289 _ = happyReduce_60++action_290 (102) = happyShift action_320+action_290 _ = happyFail++action_291 (74) = happyShift action_319+action_291 (22) = happyGoto action_318+action_291 _ = happyReduce_41++action_292 (67) = happyShift action_39+action_292 (23) = happyGoto action_168+action_292 (52) = happyGoto action_317+action_292 _ = happyReduce_147++action_293 (108) = happyShift action_316+action_293 _ = happyReduce_145++action_294 (67) = happyShift action_39+action_294 (23) = happyGoto action_168+action_294 (52) = happyGoto action_169+action_294 (53) = happyGoto action_315+action_294 _ = happyReduce_149++action_295 (67) = happyShift action_39+action_295 (68) = happyShift action_93+action_295 (69) = happyShift action_119+action_295 (72) = happyShift action_95+action_295 (79) = happyShift action_120+action_295 (81) = happyShift action_121+action_295 (89) = happyShift action_122+action_295 (90) = happyShift action_123+action_295 (91) = happyShift action_96+action_295 (92) = happyShift action_97+action_295 (93) = happyShift action_124+action_295 (94) = happyShift action_99+action_295 (97) = happyShift action_100+action_295 (99) = happyShift action_125+action_295 (101) = happyShift action_126+action_295 (103) = happyShift action_127+action_295 (105) = happyShift action_128+action_295 (109) = happyShift action_57+action_295 (113) = happyShift action_58+action_295 (114) = happyShift action_59+action_295 (115) = happyShift action_60+action_295 (117) = happyShift action_61+action_295 (118) = happyShift action_62+action_295 (120) = happyShift action_129+action_295 (121) = happyShift action_103+action_295 (23) = happyGoto action_104+action_295 (26) = happyGoto action_105+action_295 (27) = happyGoto action_106+action_295 (29) = happyGoto action_107+action_295 (31) = happyGoto action_108+action_295 (32) = happyGoto action_109+action_295 (33) = happyGoto action_110+action_295 (34) = happyGoto action_111+action_295 (39) = happyGoto action_112+action_295 (42) = happyGoto action_314+action_295 (43) = happyGoto action_114+action_295 (44) = happyGoto action_115+action_295 (45) = happyGoto action_116+action_295 (46) = happyGoto action_117+action_295 (47) = happyGoto action_118+action_295 (48) = happyGoto action_87+action_295 _ = happyReduce_60++action_296 (97) = happyShift action_312+action_296 (111) = happyShift action_313+action_296 _ = happyReduce_138++action_297 (108) = happyShift action_311+action_297 _ = happyFail++action_298 _ = happyReduce_39++action_299 (67) = happyShift action_39+action_299 (68) = happyShift action_93+action_299 (69) = happyShift action_119+action_299 (72) = happyShift action_95+action_299 (79) = happyShift action_120+action_299 (81) = happyShift action_121+action_299 (89) = happyShift action_122+action_299 (90) = happyShift action_123+action_299 (91) = happyShift action_96+action_299 (92) = happyShift action_97+action_299 (93) = happyShift action_124+action_299 (94) = happyShift action_99+action_299 (97) = happyShift action_100+action_299 (99) = happyShift action_125+action_299 (101) = happyShift action_126+action_299 (103) = happyShift action_127+action_299 (105) = happyShift action_128+action_299 (109) = happyShift action_57+action_299 (113) = happyShift action_58+action_299 (114) = happyShift action_59+action_299 (115) = happyShift action_60+action_299 (117) = happyShift action_61+action_299 (118) = happyShift action_62+action_299 (120) = happyShift action_129+action_299 (121) = happyShift action_103+action_299 (23) = happyGoto action_104+action_299 (26) = happyGoto action_105+action_299 (27) = happyGoto action_106+action_299 (29) = happyGoto action_107+action_299 (31) = happyGoto action_108+action_299 (32) = happyGoto action_109+action_299 (33) = happyGoto action_110+action_299 (34) = happyGoto action_111+action_299 (39) = happyGoto action_112+action_299 (40) = happyGoto action_310+action_299 (41) = happyGoto action_200+action_299 (42) = happyGoto action_157+action_299 (43) = happyGoto action_114+action_299 (44) = happyGoto action_115+action_299 (45) = happyGoto action_116+action_299 (46) = happyGoto action_117+action_299 (47) = happyGoto action_118+action_299 (48) = happyGoto action_87+action_299 _ = happyReduce_60++action_300 (67) = happyShift action_39+action_300 (68) = happyShift action_93+action_300 (69) = happyShift action_119+action_300 (72) = happyShift action_95+action_300 (79) = happyShift action_120+action_300 (81) = happyShift action_121+action_300 (89) = happyShift action_122+action_300 (90) = happyShift action_123+action_300 (91) = happyShift action_96+action_300 (92) = happyShift action_97+action_300 (93) = happyShift action_124+action_300 (94) = happyShift action_99+action_300 (97) = happyShift action_100+action_300 (99) = happyShift action_125+action_300 (101) = happyShift action_126+action_300 (103) = happyShift action_127+action_300 (105) = happyShift action_128+action_300 (109) = happyShift action_57+action_300 (113) = happyShift action_58+action_300 (114) = happyShift action_59+action_300 (115) = happyShift action_60+action_300 (117) = happyShift action_61+action_300 (118) = happyShift action_62+action_300 (120) = happyShift action_129+action_300 (121) = happyShift action_103+action_300 (23) = happyGoto action_104+action_300 (26) = happyGoto action_105+action_300 (27) = happyGoto action_106+action_300 (29) = happyGoto action_107+action_300 (31) = happyGoto action_108+action_300 (32) = happyGoto action_109+action_300 (33) = happyGoto action_110+action_300 (34) = happyGoto action_111+action_300 (39) = happyGoto action_112+action_300 (42) = happyGoto action_309+action_300 (43) = happyGoto action_114+action_300 (44) = happyGoto action_115+action_300 (45) = happyGoto action_116+action_300 (46) = happyGoto action_117+action_300 (47) = happyGoto action_118+action_300 (48) = happyGoto action_87+action_300 _ = happyReduce_60++action_301 (67) = happyShift action_39+action_301 (68) = happyShift action_93+action_301 (69) = happyShift action_119+action_301 (72) = happyShift action_95+action_301 (79) = happyShift action_120+action_301 (81) = happyShift action_121+action_301 (89) = happyShift action_122+action_301 (90) = happyShift action_123+action_301 (91) = happyShift action_96+action_301 (92) = happyShift action_97+action_301 (93) = happyShift action_124+action_301 (94) = happyShift action_99+action_301 (97) = happyShift action_100+action_301 (99) = happyShift action_125+action_301 (101) = happyShift action_126+action_301 (103) = happyShift action_127+action_301 (105) = happyShift action_128+action_301 (109) = happyShift action_57+action_301 (113) = happyShift action_58+action_301 (114) = happyShift action_59+action_301 (115) = happyShift action_60+action_301 (117) = happyShift action_61+action_301 (118) = happyShift action_62+action_301 (120) = happyShift action_129+action_301 (121) = happyShift action_103+action_301 (23) = happyGoto action_104+action_301 (26) = happyGoto action_105+action_301 (27) = happyGoto action_106+action_301 (29) = happyGoto action_107+action_301 (31) = happyGoto action_108+action_301 (32) = happyGoto action_109+action_301 (33) = happyGoto action_110+action_301 (34) = happyGoto action_111+action_301 (39) = happyGoto action_112+action_301 (41) = happyGoto action_308+action_301 (42) = happyGoto action_157+action_301 (43) = happyGoto action_114+action_301 (44) = happyGoto action_115+action_301 (45) = happyGoto action_116+action_301 (46) = happyGoto action_117+action_301 (47) = happyGoto action_118+action_301 (48) = happyGoto action_87+action_301 _ = happyReduce_60++action_302 (67) = happyShift action_39+action_302 (68) = happyShift action_93+action_302 (69) = happyShift action_119+action_302 (72) = happyShift action_95+action_302 (79) = happyShift action_120+action_302 (81) = happyShift action_121+action_302 (89) = happyShift action_122+action_302 (90) = happyShift action_123+action_302 (91) = happyShift action_96+action_302 (92) = happyShift action_97+action_302 (93) = happyShift action_124+action_302 (94) = happyShift action_99+action_302 (97) = happyShift action_100+action_302 (99) = happyShift action_125+action_302 (101) = happyShift action_126+action_302 (103) = happyShift action_127+action_302 (105) = happyShift action_128+action_302 (109) = happyShift action_57+action_302 (113) = happyShift action_58+action_302 (114) = happyShift action_59+action_302 (115) = happyShift action_60+action_302 (117) = happyShift action_61+action_302 (118) = happyShift action_62+action_302 (120) = happyShift action_129+action_302 (121) = happyShift action_103+action_302 (23) = happyGoto action_104+action_302 (26) = happyGoto action_105+action_302 (27) = happyGoto action_106+action_302 (29) = happyGoto action_107+action_302 (31) = happyGoto action_108+action_302 (32) = happyGoto action_109+action_302 (33) = happyGoto action_110+action_302 (34) = happyGoto action_111+action_302 (39) = happyGoto action_112+action_302 (42) = happyGoto action_307+action_302 (43) = happyGoto action_114+action_302 (44) = happyGoto action_115+action_302 (45) = happyGoto action_116+action_302 (46) = happyGoto action_117+action_302 (47) = happyGoto action_118+action_302 (48) = happyGoto action_87+action_302 _ = happyReduce_60++action_303 (67) = happyShift action_39+action_303 (68) = happyShift action_93+action_303 (69) = happyShift action_119+action_303 (72) = happyShift action_95+action_303 (79) = happyShift action_120+action_303 (81) = happyShift action_121+action_303 (89) = happyShift action_122+action_303 (90) = happyShift action_123+action_303 (91) = happyShift action_96+action_303 (92) = happyShift action_97+action_303 (93) = happyShift action_124+action_303 (94) = happyShift action_99+action_303 (97) = happyShift action_100+action_303 (99) = happyShift action_125+action_303 (101) = happyShift action_126+action_303 (103) = happyShift action_127+action_303 (105) = happyShift action_128+action_303 (109) = happyShift action_57+action_303 (113) = happyShift action_58+action_303 (114) = happyShift action_59+action_303 (115) = happyShift action_60+action_303 (117) = happyShift action_61+action_303 (118) = happyShift action_62+action_303 (120) = happyShift action_129+action_303 (121) = happyShift action_103+action_303 (23) = happyGoto action_104+action_303 (26) = happyGoto action_105+action_303 (27) = happyGoto action_106+action_303 (29) = happyGoto action_107+action_303 (31) = happyGoto action_108+action_303 (32) = happyGoto action_109+action_303 (33) = happyGoto action_110+action_303 (34) = happyGoto action_111+action_303 (39) = happyGoto action_112+action_303 (42) = happyGoto action_306+action_303 (43) = happyGoto action_114+action_303 (44) = happyGoto action_115+action_303 (45) = happyGoto action_116+action_303 (46) = happyGoto action_117+action_303 (47) = happyGoto action_118+action_303 (48) = happyGoto action_87+action_303 _ = happyReduce_60++action_304 (67) = happyShift action_39+action_304 (68) = happyShift action_93+action_304 (69) = happyShift action_119+action_304 (72) = happyShift action_95+action_304 (79) = happyShift action_120+action_304 (81) = happyShift action_121+action_304 (89) = happyShift action_122+action_304 (90) = happyShift action_123+action_304 (91) = happyShift action_96+action_304 (92) = happyShift action_97+action_304 (93) = happyShift action_124+action_304 (94) = happyShift action_99+action_304 (97) = happyShift action_100+action_304 (99) = happyShift action_125+action_304 (101) = happyShift action_126+action_304 (103) = happyShift action_127+action_304 (105) = happyShift action_128+action_304 (109) = happyShift action_57+action_304 (113) = happyShift action_58+action_304 (114) = happyShift action_59+action_304 (115) = happyShift action_60+action_304 (117) = happyShift action_61+action_304 (118) = happyShift action_62+action_304 (120) = happyShift action_129+action_304 (121) = happyShift action_103+action_304 (23) = happyGoto action_104+action_304 (26) = happyGoto action_105+action_304 (27) = happyGoto action_106+action_304 (29) = happyGoto action_107+action_304 (31) = happyGoto action_108+action_304 (32) = happyGoto action_109+action_304 (33) = happyGoto action_110+action_304 (34) = happyGoto action_111+action_304 (39) = happyGoto action_112+action_304 (42) = happyGoto action_305+action_304 (43) = happyGoto action_114+action_304 (44) = happyGoto action_115+action_304 (45) = happyGoto action_116+action_304 (46) = happyGoto action_117+action_304 (47) = happyGoto action_118+action_304 (48) = happyGoto action_87+action_304 _ = happyReduce_60++action_305 (104) = happyShift action_375+action_305 _ = happyFail++action_306 (104) = happyShift action_374+action_306 _ = happyFail++action_307 (104) = happyShift action_373+action_307 _ = happyFail++action_308 _ = happyReduce_101++action_309 (102) = happyShift action_372+action_309 _ = happyFail++action_310 _ = happyReduce_35++action_311 (67) = happyShift action_39+action_311 (68) = happyShift action_93+action_311 (69) = happyShift action_119+action_311 (72) = happyShift action_95+action_311 (79) = happyShift action_120+action_311 (81) = happyShift action_121+action_311 (89) = happyShift action_122+action_311 (90) = happyShift action_123+action_311 (91) = happyShift action_96+action_311 (92) = happyShift action_97+action_311 (93) = happyShift action_124+action_311 (94) = happyShift action_99+action_311 (97) = happyShift action_100+action_311 (99) = happyShift action_125+action_311 (101) = happyShift action_126+action_311 (103) = happyShift action_127+action_311 (105) = happyShift action_128+action_311 (109) = happyShift action_57+action_311 (113) = happyShift action_58+action_311 (114) = happyShift action_59+action_311 (115) = happyShift action_60+action_311 (117) = happyShift action_61+action_311 (118) = happyShift action_62+action_311 (120) = happyShift action_129+action_311 (121) = happyShift action_103+action_311 (23) = happyGoto action_104+action_311 (26) = happyGoto action_105+action_311 (27) = happyGoto action_106+action_311 (29) = happyGoto action_107+action_311 (31) = happyGoto action_108+action_311 (32) = happyGoto action_109+action_311 (33) = happyGoto action_110+action_311 (34) = happyGoto action_111+action_311 (39) = happyGoto action_112+action_311 (42) = happyGoto action_371+action_311 (43) = happyGoto action_114+action_311 (44) = happyGoto action_115+action_311 (45) = happyGoto action_116+action_311 (46) = happyGoto action_117+action_311 (47) = happyGoto action_118+action_311 (48) = happyGoto action_87+action_311 _ = happyReduce_60++action_312 (67) = happyShift action_39+action_312 (68) = happyShift action_93+action_312 (69) = happyShift action_119+action_312 (72) = happyShift action_95+action_312 (79) = happyShift action_120+action_312 (81) = happyShift action_121+action_312 (89) = happyShift action_122+action_312 (90) = happyShift action_123+action_312 (91) = happyShift action_96+action_312 (92) = happyShift action_97+action_312 (93) = happyShift action_124+action_312 (94) = happyShift action_99+action_312 (97) = happyShift action_100+action_312 (99) = happyShift action_125+action_312 (101) = happyShift action_126+action_312 (103) = happyShift action_127+action_312 (105) = happyShift action_128+action_312 (109) = happyShift action_57+action_312 (113) = happyShift action_58+action_312 (114) = happyShift action_59+action_312 (115) = happyShift action_60+action_312 (117) = happyShift action_61+action_312 (118) = happyShift action_62+action_312 (120) = happyShift action_129+action_312 (121) = happyShift action_103+action_312 (23) = happyGoto action_104+action_312 (26) = happyGoto action_105+action_312 (27) = happyGoto action_106+action_312 (29) = happyGoto action_107+action_312 (31) = happyGoto action_108+action_312 (32) = happyGoto action_109+action_312 (33) = happyGoto action_110+action_312 (34) = happyGoto action_111+action_312 (39) = happyGoto action_112+action_312 (42) = happyGoto action_370+action_312 (43) = happyGoto action_114+action_312 (44) = happyGoto action_115+action_312 (45) = happyGoto action_116+action_312 (46) = happyGoto action_117+action_312 (47) = happyGoto action_118+action_312 (48) = happyGoto action_87+action_312 _ = happyReduce_60++action_313 (67) = happyShift action_39+action_313 (68) = happyShift action_93+action_313 (69) = happyShift action_119+action_313 (72) = happyShift action_95+action_313 (79) = happyShift action_120+action_313 (81) = happyShift action_121+action_313 (89) = happyShift action_122+action_313 (90) = happyShift action_123+action_313 (91) = happyShift action_96+action_313 (92) = happyShift action_97+action_313 (93) = happyShift action_124+action_313 (94) = happyShift action_99+action_313 (97) = happyShift action_100+action_313 (99) = happyShift action_125+action_313 (101) = happyShift action_126+action_313 (103) = happyShift action_127+action_313 (105) = happyShift action_128+action_313 (109) = happyShift action_57+action_313 (113) = happyShift action_58+action_313 (114) = happyShift action_59+action_313 (115) = happyShift action_60+action_313 (117) = happyShift action_61+action_313 (118) = happyShift action_62+action_313 (120) = happyShift action_129+action_313 (121) = happyShift action_103+action_313 (23) = happyGoto action_104+action_313 (26) = happyGoto action_105+action_313 (27) = happyGoto action_106+action_313 (29) = happyGoto action_107+action_313 (31) = happyGoto action_108+action_313 (32) = happyGoto action_109+action_313 (33) = happyGoto action_110+action_313 (34) = happyGoto action_111+action_313 (39) = happyGoto action_112+action_313 (42) = happyGoto action_369+action_313 (43) = happyGoto action_114+action_313 (44) = happyGoto action_115+action_313 (45) = happyGoto action_116+action_313 (46) = happyGoto action_117+action_313 (47) = happyGoto action_118+action_313 (48) = happyGoto action_87+action_313 _ = happyReduce_60++action_314 (104) = happyShift action_368+action_314 _ = happyFail++action_315 (100) = happyShift action_367+action_315 (107) = happyShift action_292+action_315 _ = happyFail++action_316 (67) = happyShift action_39+action_316 (68) = happyShift action_93+action_316 (69) = happyShift action_119+action_316 (72) = happyShift action_95+action_316 (79) = happyShift action_120+action_316 (81) = happyShift action_121+action_316 (89) = happyShift action_122+action_316 (90) = happyShift action_123+action_316 (91) = happyShift action_96+action_316 (92) = happyShift action_97+action_316 (93) = happyShift action_124+action_316 (94) = happyShift action_99+action_316 (97) = happyShift action_100+action_316 (99) = happyShift action_125+action_316 (101) = happyShift action_126+action_316 (103) = happyShift action_127+action_316 (105) = happyShift action_128+action_316 (109) = happyShift action_57+action_316 (113) = happyShift action_58+action_316 (114) = happyShift action_59+action_316 (115) = happyShift action_60+action_316 (117) = happyShift action_61+action_316 (118) = happyShift action_62+action_316 (120) = happyShift action_129+action_316 (121) = happyShift action_103+action_316 (23) = happyGoto action_104+action_316 (26) = happyGoto action_105+action_316 (27) = happyGoto action_106+action_316 (29) = happyGoto action_107+action_316 (31) = happyGoto action_108+action_316 (32) = happyGoto action_109+action_316 (33) = happyGoto action_110+action_316 (34) = happyGoto action_111+action_316 (39) = happyGoto action_112+action_316 (42) = happyGoto action_366+action_316 (43) = happyGoto action_114+action_316 (44) = happyGoto action_115+action_316 (45) = happyGoto action_116+action_316 (46) = happyGoto action_117+action_316 (47) = happyGoto action_118+action_316 (48) = happyGoto action_87+action_316 _ = happyReduce_60++action_317 _ = happyReduce_146++action_318 _ = happyReduce_28++action_319 (67) = happyShift action_39+action_319 (23) = happyGoto action_138+action_319 (25) = happyGoto action_365+action_319 _ = happyFail++action_320 _ = happyReduce_184++action_321 (104) = happyShift action_364+action_321 _ = happyFail++action_322 _ = happyReduce_183++action_323 (100) = happyShift action_363+action_323 _ = happyFail++action_324 _ = happyReduce_30++action_325 _ = happyReduce_155++action_326 _ = happyReduce_160++action_327 _ = happyReduce_103++action_328 _ = happyReduce_56++action_329 (102) = happyShift action_362+action_329 _ = happyFail++action_330 (102) = happyShift action_361+action_330 _ = happyFail++action_331 (100) = happyShift action_360+action_331 _ = happyFail++action_332 (100) = happyShift action_359+action_332 _ = happyFail++action_333 (100) = happyShift action_358+action_333 _ = happyFail++action_334 (108) = happyShift action_357+action_334 _ = happyFail++action_335 _ = happyReduce_104++action_336 (67) = happyShift action_39+action_336 (68) = happyShift action_93+action_336 (69) = happyShift action_119+action_336 (72) = happyShift action_95+action_336 (79) = happyShift action_120+action_336 (81) = happyShift action_121+action_336 (89) = happyShift action_122+action_336 (90) = happyShift action_123+action_336 (91) = happyShift action_96+action_336 (92) = happyShift action_97+action_336 (93) = happyShift action_124+action_336 (94) = happyShift action_99+action_336 (97) = happyShift action_100+action_336 (99) = happyShift action_125+action_336 (101) = happyShift action_126+action_336 (103) = happyShift action_127+action_336 (105) = happyShift action_128+action_336 (109) = happyShift action_57+action_336 (113) = happyShift action_58+action_336 (114) = happyShift action_59+action_336 (115) = happyShift action_60+action_336 (117) = happyShift action_61+action_336 (118) = happyShift action_62+action_336 (120) = happyShift action_129+action_336 (121) = happyShift action_103+action_336 (23) = happyGoto action_104+action_336 (26) = happyGoto action_105+action_336 (27) = happyGoto action_106+action_336 (29) = happyGoto action_107+action_336 (31) = happyGoto action_108+action_336 (32) = happyGoto action_109+action_336 (33) = happyGoto action_110+action_336 (34) = happyGoto action_111+action_336 (39) = happyGoto action_112+action_336 (42) = happyGoto action_356+action_336 (43) = happyGoto action_114+action_336 (44) = happyGoto action_115+action_336 (45) = happyGoto action_116+action_336 (46) = happyGoto action_117+action_336 (47) = happyGoto action_118+action_336 (48) = happyGoto action_87+action_336 _ = happyReduce_60++action_337 (67) = happyShift action_39+action_337 (93) = happyShift action_235+action_337 (103) = happyShift action_236+action_337 (109) = happyShift action_102+action_337 (23) = happyGoto action_233+action_337 (54) = happyGoto action_354+action_337 (58) = happyGoto action_355+action_337 (62) = happyGoto action_231+action_337 _ = happyReduce_154++action_338 _ = happyReduce_113++action_339 (67) = happyShift action_39+action_339 (68) = happyShift action_93+action_339 (69) = happyShift action_119+action_339 (72) = happyShift action_95+action_339 (79) = happyShift action_120+action_339 (81) = happyShift action_121+action_339 (89) = happyShift action_122+action_339 (90) = happyShift action_123+action_339 (91) = happyShift action_96+action_339 (92) = happyShift action_97+action_339 (93) = happyShift action_124+action_339 (94) = happyShift action_99+action_339 (97) = happyShift action_100+action_339 (99) = happyShift action_125+action_339 (101) = happyShift action_126+action_339 (103) = happyShift action_127+action_339 (105) = happyShift action_128+action_339 (109) = happyShift action_57+action_339 (113) = happyShift action_58+action_339 (114) = happyShift action_59+action_339 (115) = happyShift action_60+action_339 (117) = happyShift action_61+action_339 (118) = happyShift action_62+action_339 (120) = happyShift action_129+action_339 (121) = happyShift action_103+action_339 (23) = happyGoto action_104+action_339 (26) = happyGoto action_105+action_339 (27) = happyGoto action_106+action_339 (29) = happyGoto action_107+action_339 (31) = happyGoto action_108+action_339 (32) = happyGoto action_109+action_339 (33) = happyGoto action_110+action_339 (34) = happyGoto action_111+action_339 (39) = happyGoto action_112+action_339 (42) = happyGoto action_353+action_339 (43) = happyGoto action_114+action_339 (44) = happyGoto action_115+action_339 (45) = happyGoto action_116+action_339 (46) = happyGoto action_117+action_339 (47) = happyGoto action_118+action_339 (48) = happyGoto action_87+action_339 _ = happyReduce_60++action_340 (67) = happyShift action_39+action_340 (68) = happyShift action_93+action_340 (69) = happyShift action_119+action_340 (72) = happyShift action_95+action_340 (79) = happyShift action_120+action_340 (81) = happyShift action_121+action_340 (89) = happyShift action_122+action_340 (90) = happyShift action_123+action_340 (91) = happyShift action_96+action_340 (92) = happyShift action_97+action_340 (93) = happyShift action_124+action_340 (94) = happyShift action_99+action_340 (97) = happyShift action_100+action_340 (99) = happyShift action_125+action_340 (101) = happyShift action_126+action_340 (103) = happyShift action_127+action_340 (105) = happyShift action_128+action_340 (109) = happyShift action_57+action_340 (113) = happyShift action_58+action_340 (114) = happyShift action_59+action_340 (115) = happyShift action_60+action_340 (117) = happyShift action_61+action_340 (118) = happyShift action_62+action_340 (120) = happyShift action_129+action_340 (121) = happyShift action_103+action_340 (23) = happyGoto action_104+action_340 (26) = happyGoto action_105+action_340 (27) = happyGoto action_106+action_340 (29) = happyGoto action_107+action_340 (31) = happyGoto action_108+action_340 (32) = happyGoto action_109+action_340 (33) = happyGoto action_110+action_340 (34) = happyGoto action_111+action_340 (39) = happyGoto action_112+action_340 (42) = happyGoto action_352+action_340 (43) = happyGoto action_114+action_340 (44) = happyGoto action_115+action_340 (45) = happyGoto action_116+action_340 (46) = happyGoto action_117+action_340 (47) = happyGoto action_118+action_340 (48) = happyGoto action_87+action_340 _ = happyReduce_60++action_341 (67) = happyShift action_39+action_341 (68) = happyShift action_93+action_341 (69) = happyShift action_119+action_341 (72) = happyShift action_95+action_341 (79) = happyShift action_120+action_341 (81) = happyShift action_121+action_341 (89) = happyShift action_122+action_341 (90) = happyShift action_123+action_341 (91) = happyShift action_96+action_341 (92) = happyShift action_97+action_341 (93) = happyShift action_124+action_341 (94) = happyShift action_99+action_341 (97) = happyShift action_100+action_341 (99) = happyShift action_125+action_341 (101) = happyShift action_126+action_341 (103) = happyShift action_127+action_341 (105) = happyShift action_128+action_341 (109) = happyShift action_57+action_341 (113) = happyShift action_58+action_341 (114) = happyShift action_59+action_341 (115) = happyShift action_60+action_341 (117) = happyShift action_61+action_341 (118) = happyShift action_62+action_341 (120) = happyShift action_129+action_341 (121) = happyShift action_103+action_341 (23) = happyGoto action_104+action_341 (26) = happyGoto action_105+action_341 (27) = happyGoto action_106+action_341 (29) = happyGoto action_107+action_341 (31) = happyGoto action_108+action_341 (32) = happyGoto action_109+action_341 (33) = happyGoto action_110+action_341 (34) = happyGoto action_111+action_341 (39) = happyGoto action_112+action_341 (42) = happyGoto action_351+action_341 (43) = happyGoto action_114+action_341 (44) = happyGoto action_115+action_341 (45) = happyGoto action_116+action_341 (46) = happyGoto action_117+action_341 (47) = happyGoto action_118+action_341 (48) = happyGoto action_87+action_341 _ = happyReduce_60++action_342 (67) = happyShift action_39+action_342 (68) = happyShift action_93+action_342 (69) = happyShift action_119+action_342 (72) = happyShift action_95+action_342 (79) = happyShift action_120+action_342 (81) = happyShift action_121+action_342 (89) = happyShift action_122+action_342 (90) = happyShift action_123+action_342 (91) = happyShift action_96+action_342 (92) = happyShift action_97+action_342 (93) = happyShift action_124+action_342 (94) = happyShift action_99+action_342 (97) = happyShift action_100+action_342 (99) = happyShift action_125+action_342 (101) = happyShift action_126+action_342 (103) = happyShift action_127+action_342 (105) = happyShift action_128+action_342 (109) = happyShift action_57+action_342 (113) = happyShift action_58+action_342 (114) = happyShift action_59+action_342 (115) = happyShift action_60+action_342 (117) = happyShift action_61+action_342 (118) = happyShift action_62+action_342 (120) = happyShift action_129+action_342 (121) = happyShift action_103+action_342 (23) = happyGoto action_104+action_342 (26) = happyGoto action_105+action_342 (27) = happyGoto action_106+action_342 (29) = happyGoto action_107+action_342 (31) = happyGoto action_108+action_342 (32) = happyGoto action_109+action_342 (33) = happyGoto action_110+action_342 (34) = happyGoto action_111+action_342 (39) = happyGoto action_112+action_342 (42) = happyGoto action_306+action_342 (43) = happyGoto action_114+action_342 (44) = happyGoto action_115+action_342 (45) = happyGoto action_116+action_342 (46) = happyGoto action_117+action_342 (47) = happyGoto action_350+action_342 (48) = happyGoto action_87+action_342 _ = happyReduce_60++action_343 (98) = happyShift action_349+action_343 _ = happyFail++action_344 (67) = happyShift action_39+action_344 (23) = happyGoto action_37+action_344 (24) = happyGoto action_246+action_344 (49) = happyGoto action_348+action_344 (50) = happyGoto action_248+action_344 _ = happyReduce_141++action_345 _ = happyReduce_136++action_346 (67) = happyShift action_39+action_346 (68) = happyShift action_93+action_346 (69) = happyShift action_119+action_346 (72) = happyShift action_95+action_346 (79) = happyShift action_120+action_346 (81) = happyShift action_121+action_346 (89) = happyShift action_122+action_346 (90) = happyShift action_123+action_346 (91) = happyShift action_96+action_346 (92) = happyShift action_97+action_346 (93) = happyShift action_124+action_346 (94) = happyShift action_99+action_346 (97) = happyShift action_100+action_346 (99) = happyShift action_125+action_346 (101) = happyShift action_126+action_346 (103) = happyShift action_127+action_346 (105) = happyShift action_128+action_346 (109) = happyShift action_57+action_346 (113) = happyShift action_58+action_346 (114) = happyShift action_59+action_346 (115) = happyShift action_60+action_346 (117) = happyShift action_61+action_346 (118) = happyShift action_62+action_346 (120) = happyShift action_129+action_346 (121) = happyShift action_103+action_346 (23) = happyGoto action_104+action_346 (26) = happyGoto action_105+action_346 (27) = happyGoto action_106+action_346 (29) = happyGoto action_107+action_346 (31) = happyGoto action_108+action_346 (32) = happyGoto action_109+action_346 (33) = happyGoto action_110+action_346 (34) = happyGoto action_111+action_346 (39) = happyGoto action_112+action_346 (40) = happyGoto action_347+action_346 (41) = happyGoto action_200+action_346 (42) = happyGoto action_157+action_346 (43) = happyGoto action_114+action_346 (44) = happyGoto action_115+action_346 (45) = happyGoto action_116+action_346 (46) = happyGoto action_117+action_346 (47) = happyGoto action_118+action_346 (48) = happyGoto action_87+action_346 _ = happyReduce_60++action_347 _ = happyReduce_142++action_348 _ = happyReduce_139++action_349 _ = happyReduce_131++action_350 (104) = happyReduce_171+action_350 (106) = happyReduce_171+action_350 _ = happyReduce_123++action_351 (104) = happyShift action_388+action_351 _ = happyFail++action_352 (104) = happyShift action_387+action_352 _ = happyFail++action_353 (104) = happyShift action_386+action_353 _ = happyFail++action_354 (100) = happyShift action_385+action_354 _ = happyFail++action_355 (107) = happyShift action_383+action_355 (110) = happyShift action_384+action_355 _ = happyReduce_153++action_356 (102) = happyShift action_382+action_356 _ = happyFail++action_357 (67) = happyShift action_39+action_357 (68) = happyShift action_93+action_357 (69) = happyShift action_119+action_357 (72) = happyShift action_95+action_357 (79) = happyShift action_120+action_357 (81) = happyShift action_121+action_357 (89) = happyShift action_122+action_357 (90) = happyShift action_123+action_357 (91) = happyShift action_96+action_357 (92) = happyShift action_97+action_357 (93) = happyShift action_124+action_357 (94) = happyShift action_99+action_357 (97) = happyShift action_100+action_357 (99) = happyShift action_125+action_357 (101) = happyShift action_126+action_357 (103) = happyShift action_127+action_357 (105) = happyShift action_128+action_357 (109) = happyShift action_57+action_357 (113) = happyShift action_58+action_357 (114) = happyShift action_59+action_357 (115) = happyShift action_60+action_357 (117) = happyShift action_61+action_357 (118) = happyShift action_62+action_357 (120) = happyShift action_129+action_357 (121) = happyShift action_103+action_357 (23) = happyGoto action_104+action_357 (26) = happyGoto action_105+action_357 (27) = happyGoto action_106+action_357 (29) = happyGoto action_107+action_357 (31) = happyGoto action_108+action_357 (32) = happyGoto action_109+action_357 (33) = happyGoto action_110+action_357 (34) = happyGoto action_111+action_357 (39) = happyGoto action_112+action_357 (42) = happyGoto action_381+action_357 (43) = happyGoto action_114+action_357 (44) = happyGoto action_115+action_357 (45) = happyGoto action_116+action_357 (46) = happyGoto action_117+action_357 (47) = happyGoto action_118+action_357 (48) = happyGoto action_87+action_357 _ = happyReduce_60++action_358 _ = happyReduce_74++action_359 _ = happyReduce_75++action_360 _ = happyReduce_76++action_361 _ = happyReduce_72++action_362 _ = happyReduce_73++action_363 (74) = happyShift action_319+action_363 (22) = happyGoto action_380+action_363 _ = happyReduce_41++action_364 _ = happyReduce_186++action_365 _ = happyReduce_42++action_366 _ = happyReduce_144++action_367 (74) = happyShift action_319+action_367 (22) = happyGoto action_379+action_367 _ = happyReduce_41++action_368 _ = happyReduce_185++action_369 (104) = happyShift action_378+action_369 _ = happyFail++action_370 (104) = happyShift action_377+action_370 _ = happyFail++action_371 (104) = happyShift action_376+action_371 _ = happyFail++action_372 _ = happyReduce_71++action_373 _ = happyReduce_63++action_374 _ = happyReduce_64++action_375 _ = happyReduce_65++action_376 _ = happyReduce_66++action_377 _ = happyReduce_67++action_378 _ = happyReduce_68++action_379 _ = happyReduce_27++action_380 _ = happyReduce_29++action_381 (104) = happyShift action_392+action_381 _ = happyFail++action_382 (112) = happyShift action_391+action_382 _ = happyFail++action_383 (67) = happyShift action_39+action_383 (93) = happyShift action_235+action_383 (103) = happyShift action_236+action_383 (109) = happyShift action_102+action_383 (23) = happyGoto action_233+action_383 (54) = happyGoto action_390+action_383 (58) = happyGoto action_355+action_383 (62) = happyGoto action_231+action_383 _ = happyReduce_154++action_384 (67) = happyShift action_39+action_384 (68) = happyShift action_93+action_384 (69) = happyShift action_119+action_384 (72) = happyShift action_95+action_384 (79) = happyShift action_120+action_384 (81) = happyShift action_121+action_384 (89) = happyShift action_122+action_384 (90) = happyShift action_123+action_384 (91) = happyShift action_96+action_384 (92) = happyShift action_97+action_384 (93) = happyShift action_124+action_384 (94) = happyShift action_99+action_384 (97) = happyShift action_100+action_384 (99) = happyShift action_125+action_384 (101) = happyShift action_126+action_384 (103) = happyShift action_127+action_384 (105) = happyShift action_128+action_384 (109) = happyShift action_57+action_384 (113) = happyShift action_58+action_384 (114) = happyShift action_59+action_384 (115) = happyShift action_60+action_384 (117) = happyShift action_61+action_384 (118) = happyShift action_62+action_384 (120) = happyShift action_129+action_384 (121) = happyShift action_103+action_384 (23) = happyGoto action_104+action_384 (26) = happyGoto action_105+action_384 (27) = happyGoto action_106+action_384 (29) = happyGoto action_107+action_384 (31) = happyGoto action_108+action_384 (32) = happyGoto action_109+action_384 (33) = happyGoto action_110+action_384 (34) = happyGoto action_111+action_384 (39) = happyGoto action_112+action_384 (40) = happyGoto action_389+action_384 (41) = happyGoto action_200+action_384 (42) = happyGoto action_157+action_384 (43) = happyGoto action_114+action_384 (44) = happyGoto action_115+action_384 (45) = happyGoto action_116+action_384 (46) = happyGoto action_117+action_384 (47) = happyGoto action_118+action_384 (48) = happyGoto action_87+action_384 _ = happyReduce_60++action_385 _ = happyReduce_105++action_386 (119) = happyReduce_66+action_386 _ = happyReduce_66++action_387 (119) = happyReduce_67+action_387 _ = happyReduce_67++action_388 (119) = happyReduce_68+action_388 _ = happyReduce_68++action_389 (107) = happyShift action_395+action_389 _ = happyReduce_151++action_390 _ = happyReduce_152++action_391 (67) = happyShift action_39+action_391 (68) = happyShift action_93+action_391 (69) = happyShift action_119+action_391 (72) = happyShift action_95+action_391 (79) = happyShift action_120+action_391 (81) = happyShift action_121+action_391 (89) = happyShift action_122+action_391 (90) = happyShift action_123+action_391 (91) = happyShift action_96+action_391 (92) = happyShift action_97+action_391 (93) = happyShift action_124+action_391 (94) = happyShift action_99+action_391 (97) = happyShift action_100+action_391 (99) = happyShift action_125+action_391 (101) = happyShift action_126+action_391 (103) = happyShift action_127+action_391 (105) = happyShift action_128+action_391 (109) = happyShift action_57+action_391 (113) = happyShift action_58+action_391 (114) = happyShift action_59+action_391 (115) = happyShift action_60+action_391 (117) = happyShift action_61+action_391 (118) = happyShift action_62+action_391 (120) = happyShift action_129+action_391 (121) = happyShift action_103+action_391 (23) = happyGoto action_104+action_391 (26) = happyGoto action_105+action_391 (27) = happyGoto action_106+action_391 (29) = happyGoto action_107+action_391 (31) = happyGoto action_108+action_391 (32) = happyGoto action_109+action_391 (33) = happyGoto action_110+action_391 (34) = happyGoto action_111+action_391 (39) = happyGoto action_112+action_391 (42) = happyGoto action_394+action_391 (43) = happyGoto action_114+action_391 (44) = happyGoto action_115+action_391 (45) = happyGoto action_116+action_391 (46) = happyGoto action_117+action_391 (47) = happyGoto action_118+action_391 (48) = happyGoto action_87+action_391 _ = happyReduce_60++action_392 (112) = happyShift action_393+action_392 _ = happyFail++action_393 (67) = happyShift action_39+action_393 (68) = happyShift action_93+action_393 (69) = happyShift action_119+action_393 (72) = happyShift action_95+action_393 (79) = happyShift action_120+action_393 (81) = happyShift action_121+action_393 (89) = happyShift action_122+action_393 (90) = happyShift action_123+action_393 (91) = happyShift action_96+action_393 (92) = happyShift action_97+action_393 (93) = happyShift action_124+action_393 (94) = happyShift action_99+action_393 (97) = happyShift action_100+action_393 (99) = happyShift action_125+action_393 (101) = happyShift action_126+action_393 (103) = happyShift action_127+action_393 (105) = happyShift action_128+action_393 (109) = happyShift action_57+action_393 (113) = happyShift action_58+action_393 (114) = happyShift action_59+action_393 (115) = happyShift action_60+action_393 (117) = happyShift action_61+action_393 (118) = happyShift action_62+action_393 (120) = happyShift action_129+action_393 (121) = happyShift action_103+action_393 (23) = happyGoto action_104+action_393 (26) = happyGoto action_105+action_393 (27) = happyGoto action_106+action_393 (29) = happyGoto action_107+action_393 (31) = happyGoto action_108+action_393 (32) = happyGoto action_109+action_393 (33) = happyGoto action_110+action_393 (34) = happyGoto action_111+action_393 (39) = happyGoto action_112+action_393 (42) = happyGoto action_397+action_393 (43) = happyGoto action_114+action_393 (44) = happyGoto action_115+action_393 (45) = happyGoto action_116+action_393 (46) = happyGoto action_117+action_393 (47) = happyGoto action_118+action_393 (48) = happyGoto action_87+action_393 _ = happyReduce_60++action_394 _ = happyReduce_85++action_395 (67) = happyShift action_39+action_395 (93) = happyShift action_235+action_395 (103) = happyShift action_236+action_395 (109) = happyShift action_102+action_395 (23) = happyGoto action_233+action_395 (54) = happyGoto action_396+action_395 (58) = happyGoto action_355+action_395 (62) = happyGoto action_231+action_395 _ = happyReduce_154++action_396 _ = happyReduce_150++action_397 _ = happyReduce_86++happyReduce_1 = happySpecReduce_1  4 happyReduction_1+happyReduction_1 (HappyAbsSyn4  happy_var_1)+	 =  HappyAbsSyn4+		 (reverse happy_var_1+	)+happyReduction_1 _  = notHappyAtAll ++happyReduce_2 = happySpecReduce_0  5 happyReduction_2+happyReduction_2  =  HappyAbsSyn4+		 ([]+	)++happyReduce_3 = happySpecReduce_2  5 happyReduction_3+happyReduction_3 (HappyAbsSyn6  happy_var_2)+	(HappyAbsSyn4  happy_var_1)+	 =  HappyAbsSyn4+		 (happy_var_2 : happy_var_1+	)+happyReduction_3 _ _  = notHappyAtAll ++happyReduce_4 = happySpecReduce_1  6 happyReduction_4+happyReduction_4 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_4 _  = notHappyAtAll ++happyReduce_5 = happySpecReduce_1  6 happyReduction_5+happyReduction_5 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_5 _  = notHappyAtAll ++happyReduce_6 = happySpecReduce_1  6 happyReduction_6+happyReduction_6 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_6 _  = notHappyAtAll ++happyReduce_7 = happySpecReduce_1  6 happyReduction_7+happyReduction_7 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_7 _  = notHappyAtAll ++happyReduce_8 = happySpecReduce_1  6 happyReduction_8+happyReduction_8 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_8 _  = notHappyAtAll ++happyReduce_9 = happySpecReduce_1  6 happyReduction_9+happyReduction_9 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_9 _  = notHappyAtAll ++happyReduce_10 = happySpecReduce_1  6 happyReduction_10+happyReduction_10 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_10 _  = notHappyAtAll ++happyReduce_11 = happySpecReduce_1  6 happyReduction_11+happyReduction_11 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_11 _  = notHappyAtAll ++happyReduce_12 = happySpecReduce_1  6 happyReduction_12+happyReduction_12 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_12 _  = notHappyAtAll ++happyReduce_13 = happySpecReduce_1  6 happyReduction_13+happyReduction_13 (HappyAbsSyn6  happy_var_1)+	 =  HappyAbsSyn6+		 (happy_var_1+	)+happyReduction_13 _  = notHappyAtAll ++happyReduce_14 = happySpecReduce_2  6 happyReduction_14+happyReduction_14 (HappyAbsSyn6  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (C.OverrideDecl Impredicative [happy_var_2]+	)+happyReduction_14 _ _  = notHappyAtAll ++happyReduce_15 = happyReduce 4 6 happyReduction_15+happyReduction_15 (_ `HappyStk`+	(HappyAbsSyn4  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.OverrideDecl Impredicative happy_var_3+	) `HappyStk` happyRest++happyReduce_16 = happySpecReduce_2  6 happyReduction_16+happyReduction_16 (HappyAbsSyn6  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (C.OverrideDecl Fail [happy_var_2]+	)+happyReduction_16 _ _  = notHappyAtAll ++happyReduce_17 = happyReduce 4 6 happyReduction_17+happyReduction_17 (_ `HappyStk`+	(HappyAbsSyn4  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.OverrideDecl Fail happy_var_3+	) `HappyStk` happyRest++happyReduce_18 = happySpecReduce_2  6 happyReduction_18+happyReduction_18 (HappyAbsSyn6  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (C.OverrideDecl Check [happy_var_2]+	)+happyReduction_18 _ _  = notHappyAtAll ++happyReduce_19 = happyReduce 4 6 happyReduction_19+happyReduction_19 (_ `HappyStk`+	(HappyAbsSyn4  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.OverrideDecl Check happy_var_3+	) `HappyStk` happyRest++happyReduce_20 = happySpecReduce_2  6 happyReduction_20+happyReduction_20 (HappyAbsSyn6  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (C.OverrideDecl TrustMe [happy_var_2]+	)+happyReduction_20 _ _  = notHappyAtAll ++happyReduce_21 = happyReduce 4 6 happyReduction_21+happyReduction_21 (_ `HappyStk`+	(HappyAbsSyn4  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.OverrideDecl TrustMe happy_var_3+	) `HappyStk` happyRest++happyReduce_22 = happySpecReduce_2  7 happyReduction_22+happyReduction_22 (HappyAbsSyn12  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (let (n,tel,t,cs,fs) = happy_var_2 in C.DataDecl n A.NotSized A.Ind tel t cs fs+	)+happyReduction_22 _ _  = notHappyAtAll ++happyReduce_23 = happySpecReduce_3  8 happyReduction_23+happyReduction_23 (HappyAbsSyn12  happy_var_3)+	_+	_+	 =  HappyAbsSyn6+		 (let (n,tel,t,cs,fs) = happy_var_3 in C.DataDecl n A.Sized A.Ind tel t cs fs+	)+happyReduction_23 _ _ _  = notHappyAtAll ++happyReduce_24 = happySpecReduce_2  9 happyReduction_24+happyReduction_24 (HappyAbsSyn12  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (let (n,tel,t,cs,fs) = happy_var_2 in C.DataDecl n A.NotSized A.CoInd tel t cs fs+	)+happyReduction_24 _ _  = notHappyAtAll ++happyReduce_25 = happySpecReduce_3  10 happyReduction_25+happyReduction_25 (HappyAbsSyn12  happy_var_3)+	_+	_+	 =  HappyAbsSyn6+		 (let (n,tel,t,cs,fs) = happy_var_3 in C.DataDecl n A.Sized A.CoInd tel t cs fs+	)+happyReduction_25 _ _ _  = notHappyAtAll ++happyReduce_26 = happySpecReduce_2  11 happyReduction_26+happyReduction_26 (HappyAbsSyn13  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (let (n,tel,t,c,fs) = happy_var_2 in C.RecordDecl n tel t c fs+	)+happyReduction_26 _ _  = notHappyAtAll ++happyReduce_27 = happyReduce 8 12 happyReduction_27+happyReduction_27 ((HappyAbsSyn22  happy_var_8) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn53  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn31  happy_var_2) `HappyStk`+	(HappyAbsSyn23  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn12+		 ((happy_var_1, happy_var_2, happy_var_4, reverse happy_var_6, happy_var_8)+	) `HappyStk` happyRest++happyReduce_28 = happyReduce 6 12 happyReduction_28+happyReduction_28 ((HappyAbsSyn22  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn53  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn31  happy_var_2) `HappyStk`+	(HappyAbsSyn23  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn12+		 ((happy_var_1, happy_var_2, C.set0, reverse happy_var_4, happy_var_6)+	) `HappyStk` happyRest++happyReduce_29 = happyReduce 8 13 happyReduction_29+happyReduction_29 ((HappyAbsSyn22  happy_var_8) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn52  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn31  happy_var_2) `HappyStk`+	(HappyAbsSyn23  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn13+		 ((happy_var_1, happy_var_2, happy_var_4, happy_var_6, happy_var_8)+	) `HappyStk` happyRest++happyReduce_30 = happyReduce 6 13 happyReduction_30+happyReduction_30 ((HappyAbsSyn22  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn52  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn31  happy_var_2) `HappyStk`+	(HappyAbsSyn23  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn13+		 ((happy_var_1, happy_var_2, C.set0, happy_var_4, happy_var_6)+	) `HappyStk` happyRest++happyReduce_31 = happyReduce 5 14 happyReduction_31+happyReduction_31 (_ `HappyStk`+	(HappyAbsSyn54  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn51  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.FunDecl A.Ind happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_32 = happyReduce 5 15 happyReduction_32+happyReduction_32 (_ `HappyStk`+	(HappyAbsSyn54  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn51  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.FunDecl A.CoInd happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_33 = happyReduce 4 16 happyReduction_33+happyReduction_33 (_ `HappyStk`+	(HappyAbsSyn4  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.MutualDecl (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_34 = happySpecReduce_3  17 happyReduction_34+happyReduction_34 (HappyAbsSyn18  happy_var_3)+	_+	(HappyAbsSyn19  happy_var_1)+	 =  HappyAbsSyn6+		 (C.LetDecl happy_var_1 happy_var_3+	)+happyReduction_34 _ _ _  = notHappyAtAll ++happyReduce_35 = happyReduce 5 18 happyReduction_35+happyReduction_35 ((HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn20  happy_var_3) `HappyStk`+	(HappyAbsSyn31  happy_var_2) `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn18+		 (let (dec,n) = happy_var_1 in C.LetDef dec n happy_var_2 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_36 = happySpecReduce_0  19 happyReduction_36+happyReduction_36  =  HappyAbsSyn19+		 (False+	)++happyReduce_37 = happySpecReduce_1  19 happyReduction_37+happyReduction_37 _+	 =  HappyAbsSyn19+		 (True+	)++happyReduce_38 = happySpecReduce_0  20 happyReduction_38+happyReduction_38  =  HappyAbsSyn20+		 (Nothing+	)++happyReduce_39 = happySpecReduce_2  20 happyReduction_39+happyReduction_39 (HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn20+		 (Just happy_var_2+	)+happyReduction_39 _ _  = notHappyAtAll ++happyReduce_40 = happyReduce 4 21 happyReduction_40+happyReduction_40 ((HappyAbsSyn58  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 (C.PatternDecl (head happy_var_2) (tail happy_var_2) happy_var_4+	) `HappyStk` happyRest++happyReduce_41 = happySpecReduce_0  22 happyReduction_41+happyReduction_41  =  HappyAbsSyn22+		 ([]+	)++happyReduce_42 = happySpecReduce_2  22 happyReduction_42+happyReduction_42 (HappyAbsSyn22  happy_var_2)+	_+	 =  HappyAbsSyn22+		 (happy_var_2+	)+happyReduction_42 _ _  = notHappyAtAll ++happyReduce_43 = happySpecReduce_1  23 happyReduction_43+happyReduction_43 (HappyTerminal (T.Id happy_var_1 _))+	 =  HappyAbsSyn23+		 (C.Name happy_var_1+	)+happyReduction_43 _  = notHappyAtAll ++happyReduce_44 = happySpecReduce_1  24 happyReduction_44+happyReduction_44 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn22+		 ([happy_var_1]+	)+happyReduction_44 _  = notHappyAtAll ++happyReduce_45 = happySpecReduce_2  24 happyReduction_45+happyReduction_45 (HappyAbsSyn22  happy_var_2)+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn22+		 (happy_var_1 : happy_var_2+	)+happyReduction_45 _ _  = notHappyAtAll ++happyReduce_46 = happySpecReduce_1  25 happyReduction_46+happyReduction_46 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn22+		 ([happy_var_1]+	)+happyReduction_46 _  = notHappyAtAll ++happyReduce_47 = happySpecReduce_3  25 happyReduction_47+happyReduction_47 (HappyAbsSyn22  happy_var_3)+	_+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn22+		 (happy_var_1 : happy_var_3+	)+happyReduction_47 _ _ _  = notHappyAtAll ++happyReduce_48 = happySpecReduce_1  26 happyReduction_48+happyReduction_48 _+	 =  HappyAbsSyn26+		 (SPos+	)++happyReduce_49 = happySpecReduce_1  26 happyReduction_49+happyReduction_49 _+	 =  HappyAbsSyn26+		 (Pos+	)++happyReduce_50 = happySpecReduce_1  26 happyReduction_50+happyReduction_50 _+	 =  HappyAbsSyn26+		 (Neg+	)++happyReduce_51 = happySpecReduce_1  26 happyReduction_51+happyReduction_51 _+	 =  HappyAbsSyn26+		 (Const+	)++happyReduce_52 = happySpecReduce_1  26 happyReduction_52+happyReduction_52 _+	 =  HappyAbsSyn26+		 (Param+	)++happyReduce_53 = happySpecReduce_1  26 happyReduction_53+happyReduction_53 _+	 =  HappyAbsSyn26+		 (Rec+	)++happyReduce_54 = happySpecReduce_2  27 happyReduction_54+happyReduction_54 (HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn27+		 (A.Measure happy_var_2+	)+happyReduction_54 _ _  = notHappyAtAll ++happyReduce_55 = happySpecReduce_2  28 happyReduction_55+happyReduction_55 _+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_55 _ _  = notHappyAtAll ++happyReduce_56 = happySpecReduce_3  28 happyReduction_56+happyReduction_56 (HappyAbsSyn28  happy_var_3)+	_+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn28+		 (happy_var_1 : happy_var_3+	)+happyReduction_56 _ _ _  = notHappyAtAll ++happyReduce_57 = happySpecReduce_3  29 happyReduction_57+happyReduction_57 (HappyAbsSyn27  happy_var_3)+	_+	(HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn29+		 (A.Bound A.Lt happy_var_1 happy_var_3+	)+happyReduction_57 _ _ _  = notHappyAtAll ++happyReduce_58 = happySpecReduce_3  29 happyReduction_58+happyReduction_58 (HappyAbsSyn27  happy_var_3)+	_+	(HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn29+		 (A.Bound A.Le happy_var_1 happy_var_3+	)+happyReduction_58 _ _ _  = notHappyAtAll ++happyReduce_59 = happySpecReduce_1  30 happyReduction_59+happyReduction_59 (HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn22+		 (let { f (C.Ident (C.QName x)) = x+                            ; f e = error ("not an identifier: " ++ C.prettyExpr e)+                            } in map f happy_var_1+	)+happyReduction_59 _  = notHappyAtAll ++happyReduce_60 = happySpecReduce_0  31 happyReduction_60+happyReduction_60  =  HappyAbsSyn31+		 ([]+	)++happyReduce_61 = happySpecReduce_2  31 happyReduction_61+happyReduction_61 (HappyAbsSyn31  happy_var_2)+	(HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn31+		 (happy_var_1 : happy_var_2+	)+happyReduction_61 _ _  = notHappyAtAll ++happyReduce_62 = happySpecReduce_2  31 happyReduction_62+happyReduction_62 (HappyAbsSyn31  happy_var_2)+	(HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn31+		 (C.TMeasure happy_var_1 : happy_var_2+	)+happyReduction_62 _ _  = notHappyAtAll ++happyReduce_63 = happyReduce 5 32 happyReduction_63+happyReduction_63 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind   (Dec Default) happy_var_2      happy_var_4+	) `HappyStk` happyRest++happyReduce_64 = happyReduce 5 32 happyReduction_64+happyReduction_64 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded A.defaultDec happy_var_2 A.Lt happy_var_4+	) `HappyStk` happyRest++happyReduce_65 = happyReduce 5 32 happyReduction_65+happyReduction_65 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded A.defaultDec happy_var_2 A.Le happy_var_4+	) `HappyStk` happyRest++happyReduce_66 = happyReduce 6 32 happyReduction_66+happyReduction_66 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind    (Dec happy_var_1)     happy_var_3      happy_var_5+	) `HappyStk` happyRest++happyReduce_67 = happyReduce 6 32 happyReduction_67+happyReduction_67 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded (Dec happy_var_1)     happy_var_3 A.Lt happy_var_5+	) `HappyStk` happyRest++happyReduce_68 = happyReduce 6 32 happyReduction_68+happyReduction_68 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded (Dec happy_var_1)     happy_var_3 A.Le happy_var_5+	) `HappyStk` happyRest++happyReduce_69 = happySpecReduce_1  32 happyReduction_69+happyReduction_69 (HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn32+		 (happy_var_1+	)+happyReduction_69 _  = notHappyAtAll ++happyReduce_70 = happySpecReduce_1  32 happyReduction_70+happyReduction_70 (HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn32+		 (happy_var_1+	)+happyReduction_70 _  = notHappyAtAll ++happyReduce_71 = happyReduce 5 33 happyReduction_71+happyReduction_71 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind    A.irrelevantDec happy_var_2      happy_var_4+	) `HappyStk` happyRest++happyReduce_72 = happyReduce 5 33 happyReduction_72+happyReduction_72 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded A.irrelevantDec happy_var_2 A.Lt happy_var_4+	) `HappyStk` happyRest++happyReduce_73 = happyReduce 5 33 happyReduction_73+happyReduction_73 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded A.irrelevantDec happy_var_2 A.Le happy_var_4+	) `HappyStk` happyRest++happyReduce_74 = happyReduce 5 34 happyReduction_74+happyReduction_74 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind    A.Hidden happy_var_2      happy_var_4+	) `HappyStk` happyRest++happyReduce_75 = happyReduce 5 34 happyReduction_75+happyReduction_75 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded A.Hidden happy_var_2 A.Lt happy_var_4+	) `HappyStk` happyRest++happyReduce_76 = happyReduce 5 34 happyReduction_76+happyReduction_76 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBounded A.Hidden happy_var_2 A.Le happy_var_4+	) `HappyStk` happyRest++happyReduce_77 = happySpecReduce_1  35 happyReduction_77+happyReduction_77 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn35+		 (C.TBind A.defaultDec [happy_var_1] Nothing+	)+happyReduction_77 _  = notHappyAtAll ++happyReduce_78 = happySpecReduce_3  35 happyReduction_78+happyReduction_78 _+	(HappyAbsSyn23  happy_var_2)+	_+	 =  HappyAbsSyn35+		 (C.TBind A.irrelevantDec [happy_var_2] Nothing+	)+happyReduction_78 _ _ _  = notHappyAtAll ++happyReduce_79 = happySpecReduce_2  35 happyReduction_79+happyReduction_79 (HappyAbsSyn23  happy_var_2)+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn35+		 (C.TBind (Dec happy_var_1) [happy_var_2] Nothing+	)+happyReduction_79 _ _  = notHappyAtAll ++happyReduce_80 = happyReduce 4 35 happyReduction_80+happyReduction_80 (_ `HappyStk`+	(HappyAbsSyn23  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn35+		 (C.TBind (Dec happy_var_1) [happy_var_3] Nothing+	) `HappyStk` happyRest++happyReduce_81 = happySpecReduce_1  36 happyReduction_81+happyReduction_81 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn36+		 ((A.defaultDec   , happy_var_1)+	)+happyReduction_81 _  = notHappyAtAll ++happyReduce_82 = happySpecReduce_3  36 happyReduction_82+happyReduction_82 _+	(HappyAbsSyn23  happy_var_2)+	_+	 =  HappyAbsSyn36+		 ((A.irrelevantDec, happy_var_2)+	)+happyReduction_82 _ _ _  = notHappyAtAll ++happyReduce_83 = happySpecReduce_2  36 happyReduction_83+happyReduction_83 (HappyAbsSyn23  happy_var_2)+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn36+		 ((Dec happy_var_1         , happy_var_2)+	)+happyReduction_83 _ _  = notHappyAtAll ++happyReduce_84 = happySpecReduce_1  37 happyReduction_84+happyReduction_84 (HappyAbsSyn18  happy_var_1)+	 =  HappyAbsSyn18+		 (happy_var_1+	)+happyReduction_84 _  = notHappyAtAll ++happyReduce_85 = happyReduce 7 37 happyReduction_85+happyReduction_85 ((HappyAbsSyn40  happy_var_7) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn18+		 (C.LetDef A.irrelevantDec happy_var_2 [] (Just happy_var_4) happy_var_7+	) `HappyStk` happyRest++happyReduce_86 = happyReduce 8 37 happyReduction_86+happyReduction_86 ((HappyAbsSyn40  happy_var_8) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn18+		 (C.LetDef (Dec happy_var_1) happy_var_3 [] (Just happy_var_5) happy_var_8+	) `HappyStk` happyRest++happyReduce_87 = happySpecReduce_1  38 happyReduction_87+happyReduction_87 (HappyAbsSyn35  happy_var_1)+	 =  HappyAbsSyn35+		 (happy_var_1+	)+happyReduction_87 _  = notHappyAtAll ++happyReduce_88 = happySpecReduce_3  38 happyReduction_88+happyReduction_88 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn35+		 (C.TBind A.defaultDec [happy_var_1] (Just happy_var_3)+	)+happyReduction_88 _ _ _  = notHappyAtAll ++happyReduce_89 = happyReduce 5 38 happyReduction_89+happyReduction_89 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn35+		 (C.TBind A.defaultDec [happy_var_2] (Just happy_var_4)+	) `HappyStk` happyRest++happyReduce_90 = happyReduce 5 38 happyReduction_90+happyReduction_90 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn35+		 (C.TBind A.irrelevantDec [happy_var_2] (Just happy_var_4)+	) `HappyStk` happyRest++happyReduce_91 = happyReduce 6 38 happyReduction_91+happyReduction_91 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn35+		 (C.TBind (Dec happy_var_1) [happy_var_3] (Just happy_var_5)+	) `HappyStk` happyRest++happyReduce_92 = happySpecReduce_1  39 happyReduction_92+happyReduction_92 (HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn31+		 ([C.TBind (Dec Default) {- A.defaultDec -} [] happy_var_1]+	)+happyReduction_92 _  = notHappyAtAll ++happyReduce_93 = happySpecReduce_3  39 happyReduction_93+happyReduction_93 _+	(HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn31+		 ([C.TBind A.irrelevantDec [] happy_var_2]+	)+happyReduction_93 _ _ _  = notHappyAtAll ++happyReduce_94 = happySpecReduce_2  39 happyReduction_94+happyReduction_94 (HappyAbsSyn40  happy_var_2)+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn31+		 ([C.TBind (Dec happy_var_1) [] happy_var_2]+	)+happyReduction_94 _ _  = notHappyAtAll ++happyReduce_95 = happySpecReduce_1  39 happyReduction_95+happyReduction_95 (HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn31+		 ([happy_var_1]+	)+happyReduction_95 _  = notHappyAtAll ++happyReduce_96 = happySpecReduce_1  39 happyReduction_96+happyReduction_96 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn31+		 ([C.TMeasure happy_var_1]+	)+happyReduction_96 _  = notHappyAtAll ++happyReduce_97 = happySpecReduce_1  39 happyReduction_97+happyReduction_97 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn31+		 ([C.TBound happy_var_1]+	)+happyReduction_97 _  = notHappyAtAll ++happyReduce_98 = happySpecReduce_1  39 happyReduction_98+happyReduction_98 (HappyAbsSyn31  happy_var_1)+	 =  HappyAbsSyn31+		 (happy_var_1+	)+happyReduction_98 _  = notHappyAtAll ++happyReduce_99 = happySpecReduce_1  40 happyReduction_99+happyReduction_99 (HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn40+		 (foldr1 C.Pair happy_var_1+	)+happyReduction_99 _  = notHappyAtAll ++happyReduce_100 = happySpecReduce_1  41 happyReduction_100+happyReduction_100 (HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_100 _  = notHappyAtAll ++happyReduce_101 = happySpecReduce_3  41 happyReduction_101+happyReduction_101 (HappyAbsSyn28  happy_var_3)+	_+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn28+		 (happy_var_1 : happy_var_3+	)+happyReduction_101 _ _ _  = notHappyAtAll ++happyReduce_102 = happySpecReduce_3  42 happyReduction_102+happyReduction_102 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn31  happy_var_1)+	 =  HappyAbsSyn40+		 (C.Quant A.Pi happy_var_1 happy_var_3+	)+happyReduction_102 _ _ _  = notHappyAtAll ++happyReduce_103 = happyReduce 4 42 happyReduction_103+happyReduction_103 ((HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn40+		 (foldr C.Lam happy_var_4 happy_var_2+	) `HappyStk` happyRest++happyReduce_104 = happyReduce 4 42 happyReduction_104+happyReduction_104 ((HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn18  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn40+		 (C.LLet happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_105 = happyReduce 6 42 happyReduction_105+happyReduction_105 (_ `HappyStk`+	(HappyAbsSyn54  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn20  happy_var_3) `HappyStk`+	(HappyAbsSyn40  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn40+		 (C.Case happy_var_2 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_106 = happySpecReduce_1  42 happyReduction_106+happyReduction_106 (HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn40+		 (happy_var_1+	)+happyReduction_106 _  = notHappyAtAll ++happyReduce_107 = happySpecReduce_3  42 happyReduction_107+happyReduction_107 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn40+		 (C.Plus happy_var_1 happy_var_3+	)+happyReduction_107 _ _ _  = notHappyAtAll ++happyReduce_108 = happySpecReduce_3  42 happyReduction_108+happyReduction_108 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn40+		 (C.App happy_var_1 [happy_var_3]+	)+happyReduction_108 _ _ _  = notHappyAtAll ++happyReduce_109 = happySpecReduce_3  42 happyReduction_109+happyReduction_109 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn40+		 (C.App happy_var_3 [happy_var_1]+	)+happyReduction_109 _ _ _  = notHappyAtAll ++happyReduce_110 = happySpecReduce_1  43 happyReduction_110+happyReduction_110 (HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn40+		 (happy_var_1+	)+happyReduction_110 _  = notHappyAtAll ++happyReduce_111 = happySpecReduce_3  43 happyReduction_111+happyReduction_111 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn40+		 (C.Quant A.Sigma [happy_var_1] happy_var_3+	)+happyReduction_111 _ _ _  = notHappyAtAll ++happyReduce_112 = happySpecReduce_1  44 happyReduction_112+happyReduction_112 (HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn32+		 (C.TBind (Dec Default) {- A.defaultDec -} [] happy_var_1+	)+happyReduction_112 _  = notHappyAtAll ++happyReduce_113 = happySpecReduce_3  44 happyReduction_113+happyReduction_113 _+	(HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn32+		 (C.TBind A.irrelevantDec [] happy_var_2+	)+happyReduction_113 _ _ _  = notHappyAtAll ++happyReduce_114 = happySpecReduce_2  44 happyReduction_114+happyReduction_114 (HappyAbsSyn40  happy_var_2)+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn32+		 (C.TBind (Dec happy_var_1) [] happy_var_2+	)+happyReduction_114 _ _  = notHappyAtAll ++happyReduce_115 = happySpecReduce_1  44 happyReduction_115+happyReduction_115 (HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn32+		 (happy_var_1+	)+happyReduction_115 _  = notHappyAtAll ++happyReduce_116 = happySpecReduce_1  44 happyReduction_116+happyReduction_116 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn32+		 (C.TMeasure happy_var_1+	)+happyReduction_116 _  = notHappyAtAll ++happyReduce_117 = happySpecReduce_1  44 happyReduction_117+happyReduction_117 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn32+		 (C.TBound happy_var_1+	)+happyReduction_117 _  = notHappyAtAll ++happyReduce_118 = happySpecReduce_1  45 happyReduction_118+happyReduction_118 (HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn40+		 (let (f : args) = reverse happy_var_1 in+                if null args then f else C.App f args+	)+happyReduction_118 _  = notHappyAtAll ++happyReduce_119 = happySpecReduce_2  45 happyReduction_119+happyReduction_119 (HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn40+		 (C.CoSet happy_var_2+	)+happyReduction_119 _ _  = notHappyAtAll ++happyReduce_120 = happySpecReduce_1  45 happyReduction_120+happyReduction_120 _+	 =  HappyAbsSyn40+		 (C.Set C.Zero+	)++happyReduce_121 = happySpecReduce_2  45 happyReduction_121+happyReduction_121 (HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn40+		 (C.Set happy_var_2+	)+happyReduction_121 _ _  = notHappyAtAll ++happyReduce_122 = happySpecReduce_3  45 happyReduction_122+happyReduction_122 (HappyAbsSyn40  happy_var_3)+	_+	(HappyTerminal (T.Number happy_var_1 _))+	 =  HappyAbsSyn40+		 (let n = read happy_var_1 in+                            if n==0 then C.Zero else+                            iterate (C.Plus happy_var_3) happy_var_3 !! (n-1)+	)+happyReduction_122 _ _ _  = notHappyAtAll ++happyReduce_123 = happySpecReduce_1  46 happyReduction_123+happyReduction_123 (HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_123 _  = notHappyAtAll ++happyReduce_124 = happySpecReduce_2  46 happyReduction_124+happyReduction_124 (HappyAbsSyn40  happy_var_2)+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (happy_var_2 : happy_var_1+	)+happyReduction_124 _ _  = notHappyAtAll ++happyReduce_125 = happySpecReduce_3  46 happyReduction_125+happyReduction_125 (HappyAbsSyn23  happy_var_3)+	_+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (C.Proj happy_var_3 : happy_var_1+	)+happyReduction_125 _ _ _  = notHappyAtAll ++happyReduce_126 = happySpecReduce_2  46 happyReduction_126+happyReduction_126 _+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (C.Set C.Zero : happy_var_1+	)+happyReduction_126 _ _  = notHappyAtAll ++happyReduce_127 = happySpecReduce_1  47 happyReduction_127+happyReduction_127 _+	 =  HappyAbsSyn40+		 (C.Size+	)++happyReduce_128 = happySpecReduce_1  47 happyReduction_128+happyReduction_128 _+	 =  HappyAbsSyn40+		 (C.Max+	)++happyReduce_129 = happySpecReduce_1  47 happyReduction_129+happyReduction_129 _+	 =  HappyAbsSyn40+		 (C.Infty+	)++happyReduce_130 = happySpecReduce_1  47 happyReduction_130+happyReduction_130 (HappyAbsSyn48  happy_var_1)+	 =  HappyAbsSyn40+		 (C.Ident happy_var_1+	)+happyReduction_130 _  = notHappyAtAll ++happyReduce_131 = happyReduce 5 47 happyReduction_131+happyReduction_131 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn40  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn40+		 (C.Sing happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_132 = happySpecReduce_3  47 happyReduction_132+happyReduction_132 _+	(HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn40+		 (happy_var_2+	)+happyReduction_132 _ _ _  = notHappyAtAll ++happyReduce_133 = happySpecReduce_1  47 happyReduction_133+happyReduction_133 _+	 =  HappyAbsSyn40+		 (C.Unknown+	)++happyReduce_134 = happySpecReduce_2  47 happyReduction_134+happyReduction_134 (HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn40+		 (C.Succ happy_var_2+	)+happyReduction_134 _ _  = notHappyAtAll ++happyReduce_135 = happySpecReduce_1  47 happyReduction_135+happyReduction_135 (HappyTerminal (T.Number happy_var_1 _))+	 =  HappyAbsSyn40+		 (iterate C.Succ C.Zero !! (read happy_var_1)+	)+happyReduction_135 _  = notHappyAtAll ++happyReduce_136 = happyReduce 4 47 happyReduction_136+happyReduction_136 (_ `HappyStk`+	(HappyAbsSyn49  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn40+		 (C.Record happy_var_3+	) `HappyStk` happyRest++happyReduce_137 = happySpecReduce_1  48 happyReduction_137+happyReduction_137 (HappyTerminal (T.QualId happy_var_1 _))+	 =  HappyAbsSyn48+		 (let (m,n) = happy_var_1 in C.Qual (C.Name m) (C.Name n)+	)+happyReduction_137 _  = notHappyAtAll ++happyReduce_138 = happySpecReduce_1  48 happyReduction_138+happyReduction_138 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn48+		 (C.QName happy_var_1+	)+happyReduction_138 _  = notHappyAtAll ++happyReduce_139 = happySpecReduce_3  49 happyReduction_139+happyReduction_139 (HappyAbsSyn49  happy_var_3)+	_+	(HappyAbsSyn50  happy_var_1)+	 =  HappyAbsSyn49+		 (happy_var_1 : happy_var_3+	)+happyReduction_139 _ _ _  = notHappyAtAll ++happyReduce_140 = happySpecReduce_1  49 happyReduction_140+happyReduction_140 (HappyAbsSyn50  happy_var_1)+	 =  HappyAbsSyn49+		 ([happy_var_1]+	)+happyReduction_140 _  = notHappyAtAll ++happyReduce_141 = happySpecReduce_0  49 happyReduction_141+happyReduction_141  =  HappyAbsSyn49+		 ([]+	)++happyReduce_142 = happySpecReduce_3  50 happyReduction_142+happyReduction_142 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn22  happy_var_1)+	 =  HappyAbsSyn50+		 ((happy_var_1,happy_var_3)+	)+happyReduction_142 _ _ _  = notHappyAtAll ++happyReduce_143 = happySpecReduce_3  51 happyReduction_143+happyReduction_143 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn51+		 (C.TypeSig happy_var_1 happy_var_3+	)+happyReduction_143 _ _ _  = notHappyAtAll ++happyReduce_144 = happyReduce 4 52 happyReduction_144+happyReduction_144 ((HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn31  happy_var_2) `HappyStk`+	(HappyAbsSyn23  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn52+		 (C.Constructor happy_var_1 happy_var_2 (Just happy_var_4)+	) `HappyStk` happyRest++happyReduce_145 = happySpecReduce_2  52 happyReduction_145+happyReduction_145 (HappyAbsSyn31  happy_var_2)+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn52+		 (C.Constructor happy_var_1 happy_var_2 Nothing+	)+happyReduction_145 _ _  = notHappyAtAll ++happyReduce_146 = happySpecReduce_3  53 happyReduction_146+happyReduction_146 (HappyAbsSyn52  happy_var_3)+	_+	(HappyAbsSyn53  happy_var_1)+	 =  HappyAbsSyn53+		 (happy_var_3 : happy_var_1+	)+happyReduction_146 _ _ _  = notHappyAtAll ++happyReduce_147 = happySpecReduce_2  53 happyReduction_147+happyReduction_147 _+	(HappyAbsSyn53  happy_var_1)+	 =  HappyAbsSyn53+		 (happy_var_1+	)+happyReduction_147 _ _  = notHappyAtAll ++happyReduce_148 = happySpecReduce_1  53 happyReduction_148+happyReduction_148 (HappyAbsSyn52  happy_var_1)+	 =  HappyAbsSyn53+		 ([happy_var_1]+	)+happyReduction_148 _  = notHappyAtAll ++happyReduce_149 = happySpecReduce_0  53 happyReduction_149+happyReduction_149  =  HappyAbsSyn53+		 ([]+	)++happyReduce_150 = happyReduce 5 54 happyReduction_150+happyReduction_150 ((HappyAbsSyn54  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn40  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn58  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn54+		 ((C.Clause Nothing [happy_var_1] (Just happy_var_3)) : happy_var_5+	) `HappyStk` happyRest++happyReduce_151 = happySpecReduce_3  54 happyReduction_151+happyReduction_151 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn54+		 ((C.Clause Nothing [happy_var_1] (Just happy_var_3)) : []+	)+happyReduction_151 _ _ _  = notHappyAtAll ++happyReduce_152 = happySpecReduce_3  54 happyReduction_152+happyReduction_152 (HappyAbsSyn54  happy_var_3)+	_+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn54+		 ((C.Clause Nothing [happy_var_1] Nothing) : happy_var_3+	)+happyReduction_152 _ _ _  = notHappyAtAll ++happyReduce_153 = happySpecReduce_1  54 happyReduction_153+happyReduction_153 (HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn54+		 ((C.Clause Nothing [happy_var_1] Nothing) : []+	)+happyReduction_153 _  = notHappyAtAll ++happyReduce_154 = happySpecReduce_0  54 happyReduction_154+happyReduction_154  =  HappyAbsSyn54+		 ([]+	)++happyReduce_155 = happyReduce 4 55 happyReduction_155+happyReduction_155 ((HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn56  happy_var_2) `HappyStk`+	(HappyAbsSyn23  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn55+		 (C.Clause (Just happy_var_1) happy_var_2 (Just happy_var_4)+	) `HappyStk` happyRest++happyReduce_156 = happySpecReduce_2  55 happyReduction_156+happyReduction_156 (HappyAbsSyn56  happy_var_2)+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn55+		 (C.Clause (Just happy_var_1) happy_var_2 Nothing+	)+happyReduction_156 _ _  = notHappyAtAll ++happyReduce_157 = happySpecReduce_1  56 happyReduction_157+happyReduction_157 (HappyAbsSyn56  happy_var_1)+	 =  HappyAbsSyn56+		 (reverse happy_var_1+	)+happyReduction_157 _  = notHappyAtAll ++happyReduce_158 = happySpecReduce_0  57 happyReduction_158+happyReduction_158  =  HappyAbsSyn56+		 ([]+	)++happyReduce_159 = happySpecReduce_2  57 happyReduction_159+happyReduction_159 (HappyAbsSyn58  happy_var_2)+	(HappyAbsSyn56  happy_var_1)+	 =  HappyAbsSyn56+		 (happy_var_2 : happy_var_1+	)+happyReduction_159 _ _  = notHappyAtAll ++happyReduce_160 = happySpecReduce_3  57 happyReduction_160+happyReduction_160 (HappyAbsSyn58  happy_var_3)+	_+	(HappyAbsSyn56  happy_var_1)+	 =  HappyAbsSyn56+		 (happy_var_3 : happy_var_1+	)+happyReduction_160 _ _ _  = notHappyAtAll ++happyReduce_161 = happySpecReduce_2  58 happyReduction_161+happyReduction_161 _+	_+	 =  HappyAbsSyn58+		 (C.AbsurdP+	)++happyReduce_162 = happySpecReduce_3  58 happyReduction_162+happyReduction_162 _+	(HappyAbsSyn58  happy_var_2)+	_+	 =  HappyAbsSyn58+		 (happy_var_2+	)+happyReduction_162 _ _ _  = notHappyAtAll ++happyReduce_163 = happySpecReduce_1  58 happyReduction_163+happyReduction_163 (HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (happy_var_1+	)+happyReduction_163 _  = notHappyAtAll ++happyReduce_164 = happySpecReduce_2  58 happyReduction_164+happyReduction_164 (HappyAbsSyn58  happy_var_2)+	_+	 =  HappyAbsSyn58+		 (C.SuccP happy_var_2+	)+happyReduction_164 _ _  = notHappyAtAll ++happyReduce_165 = happySpecReduce_2  58 happyReduction_165+happyReduction_165 _+	_+	 =  HappyAbsSyn58+		 (C.DotP (C.Set C.Zero)+	)++happyReduce_166 = happySpecReduce_2  58 happyReduction_166+happyReduction_166 (HappyAbsSyn40  happy_var_2)+	_+	 =  HappyAbsSyn58+		 (C.DotP happy_var_2+	)+happyReduction_166 _ _  = notHappyAtAll ++happyReduce_167 = happySpecReduce_3  59 happyReduction_167+happyReduction_167 (HappyAbsSyn58  happy_var_3)+	_+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (C.PairP happy_var_1 happy_var_3+	)+happyReduction_167 _ _ _  = notHappyAtAll ++happyReduce_168 = happySpecReduce_1  59 happyReduction_168+happyReduction_168 (HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (happy_var_1+	)+happyReduction_168 _  = notHappyAtAll ++happyReduce_169 = happySpecReduce_1  60 happyReduction_169+happyReduction_169 (HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (happy_var_1+	)+happyReduction_169 _  = notHappyAtAll ++happyReduce_170 = happySpecReduce_3  60 happyReduction_170+happyReduction_170 (HappyAbsSyn23  happy_var_3)+	_+	(HappyAbsSyn40  happy_var_1)+	 =  HappyAbsSyn58+		 (C.SizeP happy_var_1 happy_var_3+	)+happyReduction_170 _ _ _  = notHappyAtAll ++happyReduce_171 = happySpecReduce_3  60 happyReduction_171+happyReduction_171 (HappyAbsSyn40  happy_var_3)+	_+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn58+		 (C.SizeP happy_var_3 happy_var_1+	)+happyReduction_171 _ _ _  = notHappyAtAll ++happyReduce_172 = happySpecReduce_1  60 happyReduction_172+happyReduction_172 (HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (happy_var_1+	)+happyReduction_172 _  = notHappyAtAll ++happyReduce_173 = happySpecReduce_3  60 happyReduction_173+happyReduction_173 (HappyAbsSyn58  happy_var_3)+	_+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (patApp happy_var_1 [happy_var_3]+	)+happyReduction_173 _ _ _  = notHappyAtAll ++happyReduce_174 = happySpecReduce_2  61 happyReduction_174+happyReduction_174 (HappyAbsSyn58  happy_var_2)+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (patApp happy_var_1 [happy_var_2]+	)+happyReduction_174 _ _  = notHappyAtAll ++happyReduce_175 = happySpecReduce_2  61 happyReduction_175+happyReduction_175 (HappyAbsSyn58  happy_var_2)+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (patApp happy_var_1 [happy_var_2]+	)+happyReduction_175 _ _  = notHappyAtAll ++happyReduce_176 = happySpecReduce_1  62 happyReduction_176+happyReduction_176 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn58+		 (C.IdentP (C.QName happy_var_1)+	)+happyReduction_176 _  = notHappyAtAll ++happyReduce_177 = happySpecReduce_2  62 happyReduction_177+happyReduction_177 (HappyAbsSyn23  happy_var_2)+	_+	 =  HappyAbsSyn58+		 (C.ConP True (C.QName happy_var_2) []+	)+happyReduction_177 _ _  = notHappyAtAll ++happyReduce_178 = happySpecReduce_1  63 happyReduction_178+happyReduction_178 (HappyAbsSyn64  happy_var_1)+	 =  HappyAbsSyn54+		 (reverse happy_var_1+	)+happyReduction_178 _  = notHappyAtAll ++happyReduce_179 = happySpecReduce_3  64 happyReduction_179+happyReduction_179 (HappyAbsSyn55  happy_var_3)+	_+	(HappyAbsSyn64  happy_var_1)+	 =  HappyAbsSyn64+		 (happy_var_3 : happy_var_1+	)+happyReduction_179 _ _ _  = notHappyAtAll ++happyReduce_180 = happySpecReduce_2  64 happyReduction_180+happyReduction_180 _+	(HappyAbsSyn64  happy_var_1)+	 =  HappyAbsSyn64+		 (happy_var_1+	)+happyReduction_180 _ _  = notHappyAtAll ++happyReduce_181 = happySpecReduce_1  64 happyReduction_181+happyReduction_181 (HappyAbsSyn55  happy_var_1)+	 =  HappyAbsSyn64+		 ([happy_var_1]+	)+happyReduction_181 _  = notHappyAtAll ++happyReduce_182 = happySpecReduce_0  64 happyReduction_182+happyReduction_182  =  HappyAbsSyn64+		 ([]+	)++happyReduce_183 = happyReduce 5 65 happyReduction_183+happyReduction_183 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind (Dec Default) happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_184 = happyReduce 5 65 happyReduction_184+happyReduction_184 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind A.irrelevantDec happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_185 = happyReduce 6 65 happyReduction_185+happyReduction_185 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind (Dec happy_var_1) happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_186 = happyReduce 6 65 happyReduction_186+happyReduction_186 (_ `HappyStk`+	(HappyAbsSyn40  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn22  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn32+		 (C.TBind (Dec SPos) happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_187 = happySpecReduce_0  66 happyReduction_187+happyReduction_187  =  HappyAbsSyn31+		 ([]+	)++happyReduce_188 = happySpecReduce_2  66 happyReduction_188+happyReduction_188 (HappyAbsSyn31  happy_var_2)+	(HappyAbsSyn32  happy_var_1)+	 =  HappyAbsSyn31+		 (happy_var_1 : happy_var_2+	)+happyReduction_188 _ _  = notHappyAtAll ++happyNewToken action sts stk [] =+	action 122 122 notHappyAtAll (HappyState action) sts stk []++happyNewToken action sts stk (tk:tks) =+	let cont i = action i i tk (HappyState action) sts stk tks in+	case tk of {+	T.Id happy_dollar_dollar _ -> cont 67;+	T.QualId happy_dollar_dollar _ -> cont 68;+	T.Number happy_dollar_dollar _ -> cont 69;+	T.Data _ -> cont 70;+	T.CoData _ -> cont 71;+	T.Record _ -> cont 72;+	T.Sized _ -> cont 73;+	T.Fields _ -> cont 74;+	T.Mutual _ -> cont 75;+	T.Fun _ -> cont 76;+	T.CoFun _ -> cont 77;+	T.Pattern _ -> cont 78;+	T.Case _ -> cont 79;+	T.Def _ -> cont 80;+	T.Let _ -> cont 81;+	T.In _ -> cont 82;+	T.Eval _ -> cont 83;+	T.Fail _ -> cont 84;+	T.Check _ -> cont 85;+	T.TrustMe _ -> cont 86;+	T.Impredicative _ -> cont 87;+	T.Type _ -> cont 88;+	T.Set _ -> cont 89;+	T.CoSet _ -> cont 90;+	T.Size _ -> cont 91;+	T.Infty _ -> cont 92;+	T.Succ _ -> cont 93;+	T.Max _ -> cont 94;+	T.LTri _ -> cont 95;+	T.RTri _ -> cont 96;+	T.AngleOpen _ -> cont 97;+	T.AngleClose _ -> cont 98;+	T.BrOpen _ -> cont 99;+	T.BrClose _ -> cont 100;+	T.BracketOpen _ -> cont 101;+	T.BracketClose _ -> cont 102;+	T.PrOpen _ -> cont 103;+	T.PrClose _ -> cont 104;+	T.Bar _ -> cont 105;+	T.Comma _ -> cont 106;+	T.Sem _ -> cont 107;+	T.Col _ -> cont 108;+	T.Dot _ -> cont 109;+	T.Arrow _ -> cont 110;+	T.Leq _ -> cont 111;+	T.Eq _ -> cont 112;+	T.PlusPlus _ -> cont 113;+	T.Plus _ -> cont 114;+	T.Minus _ -> cont 115;+	T.Slash _ -> cont 116;+	T.Times _ -> cont 117;+	T.Hat _ -> cont 118;+	T.Amp _ -> cont 119;+	T.Lam _ -> cont 120;+	T.Underscore _ -> cont 121;+	_ -> happyError' (tk:tks)+	}++happyError_ 122 tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++newtype HappyIdentity a = HappyIdentity a+happyIdentity = HappyIdentity+happyRunIdentity (HappyIdentity a) = a++instance Functor HappyIdentity where+    fmap f (HappyIdentity a) = HappyIdentity (f a)++instance Applicative HappyIdentity where+    pure  = return+    (<*>) = ap+instance Monad HappyIdentity where+    return = HappyIdentity+    (HappyIdentity p) >>= q = q p++happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+happyThen = (>>=)+happyReturn :: () => a -> HappyIdentity a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> HappyIdentity a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(T.Token)] -> HappyIdentity a+happyError' = HappyIdentity . parseError++parse tks = happyRunIdentity happySomeParser where+  happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })++happySeq = happyDontSeq+++parseError :: [T.Token] -> a+parseError [] = error "Parse error at EOF"+parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x)+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<command-line>" #-}++++++++# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 7 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 13 "templates/GenericTemplate.hs" #-}++{-# LINE 46 "templates/GenericTemplate.hs" #-}+++++++++{-# LINE 67 "templates/GenericTemplate.hs" #-}++{-# LINE 77 "templates/GenericTemplate.hs" #-}++{-# LINE 86 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is (1), it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =+        happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +         (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++{-# LINE 155 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++++newtype HappyState b c = HappyState+        (Int ->                    -- token number+         Int ->                    -- token number (yes, again)+         b ->                           -- token semantic value+         HappyState b c ->              -- current state+         [HappyState b c] ->            -- state stack+         c)++++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =+     let i = (case x of { HappyErrorToken (i) -> i }) in+--     trace "shifting the error token" $+     new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk+     = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k - ((1) :: Int)) sts of+         sts1@(((st1@(HappyState (action))):(_))) ->+                let r = fn stk in  -- it doesn't hurt to always seq here...+                happyDoSeq r (action nt j tk st1 sts1 r)++happyMonadReduce k nt fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+      case happyDrop k ((st):(sts)) of+        sts1@(((st1@(HappyState (action))):(_))) ->+          let drop_stk = happyDropStk k stk in+          happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+      case happyDrop k ((st):(sts)) of+        sts1@(((st1@(HappyState (action))):(_))) ->+         let drop_stk = happyDropStk k stk++++++             new_state = action++          in+          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop (0) l = l+happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t++happyDropStk (0) l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction++{-# LINE 256 "templates/GenericTemplate.hs" #-}+happyGoto action j tk st = action j j tk (HappyState action)+++-----------------------------------------------------------------------------+-- Error recovery ((1) is the error token)++-- parse error if we are in recovery and we fail again+happyFail (1) tk old_st _ stk@(x `HappyStk` _) =+     let i = (case x of { HappyErrorToken (i) -> i }) in+--      trace "failing" $ +        happyError_ i tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  (1) tk old_st (((HappyState (action))):(sts)) +                                                (saved_tok `HappyStk` _ `HappyStk` stk) =+--      trace ("discarding state, depth " ++ show (length stk))  $+        action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (HappyState (action)) sts stk =+--      trace "entering error recovery" $+        action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions++++++++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--      happySeq = happyDoSeq+-- otherwise it emits+--      happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.++{-# LINE 322 "templates/GenericTemplate.hs" #-}+{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ src/Parser.y view
@@ -0,0 +1,520 @@+{+{-# LANGUAGE BangPatterns #-}+module Parser where++import qualified Lexer as T+import qualified Concrete as C++import Abstract (Decoration(..),Dec,defaultDec,Override(..))+import Polarity (Pol(..))+import qualified Abstract as A+import qualified Polarity as A+import Concrete (Name,patApp)+}++%name parse+%tokentype { T.Token }+%error { parseError }++%token++id      { T.Id $$ _ }+qualid  { T.QualId $$ _ }+number  { T.Number $$ _ }+data    { T.Data _ }+codata  { T.CoData _ }+record  { T.Record _ }+sized   { T.Sized _ }+fields  { T.Fields _ }+mutual  { T.Mutual _ }+fun     { T.Fun _ }+cofun   { T.CoFun _ }+pattern { T.Pattern _ }+case    { T.Case _ }+def     { T.Def _ }+let     { T.Let _ }+in      { T.In _ }+eval    { T.Eval _ }+fail    { T.Fail _ }+check   { T.Check _ }+trustme { T.TrustMe _ }+impredicative { T.Impredicative _ }+type    { T.Type _ }+set     { T.Set _ }+coset   { T.CoSet _ }+size    { T.Size _ }+infty   { T.Infty _ }+succ    { T.Succ _ }+max     { T.Max _ }+'<|'    { T.LTri _ }+'|>'    { T.RTri _ }+'<'     { T.AngleOpen _ }+'>'     { T.AngleClose _ }+'{'     { T.BrOpen _ }+'}'     { T.BrClose _ }+'['     { T.BracketOpen _ }+']'     { T.BracketClose _ }+'('     { T.PrOpen _ }+')'     { T.PrClose _ }+'|'     { T.Bar _ }+','     { T.Comma _ }+';'     { T.Sem _ }+':'     { T.Col _ }+'.'     { T.Dot _ }+'->'    { T.Arrow _ }+'<='    { T.Leq _ }+'='     { T.Eq _ }+'++'    { T.PlusPlus _ }+'+'     { T.Plus _ }+'-'     { T.Minus _ }+'/'     { T.Slash _ } -- UNUSED+'*'     { T.Times _ } -- UNUSED+'^'     { T.Hat _ }+'&'     { T.Amp _ }+'\\'    { T.Lam _ }+'_'     { T.Underscore _ }++%%++TopLevel :: { [C.Declaration] }+TopLevel : Declarations { reverse $1}+++Declarations :: { [C.Declaration] }+Declarations : {- empty -} { [] }+             | Declarations Declaration { $2 : $1 }++Declaration :: { C.Declaration }+Declaration : Data                      { $1 }+           | CoData                     { $1 }+           | SizedData                  { $1 }+           | SizedCoData                { $1 }+           | RecordDecl                 { $1 }+           | Fun                        { $1 }+           | CoFun                      { $1 }+           | Mutual                     { $1 }+           | Let                        { $1 }+           | PatternDecl                { $1 }+           | impredicative Declaration          { C.OverrideDecl Impredicative [$2] }+           | impredicative '{' Declarations '}' { C.OverrideDecl Impredicative $3 }+           | fail Declaration             { C.OverrideDecl Fail [$2] }+           | fail '{' Declarations '}'    { C.OverrideDecl Fail $3 }+           | check Declaration            { C.OverrideDecl Check [$2] }+           | check '{' Declarations '}'   { C.OverrideDecl Check $3 }+           | trustme Declaration          { C.OverrideDecl TrustMe [$2] }+           | trustme '{' Declarations '}' { C.OverrideDecl TrustMe $3 }+{-+Data :: { C.Declaration }+Data : data Id DataTelescope ':' Expr '{' Constructors '}' OptFields+   { C.DataDecl $2 A.NotSized A.Ind $3 $5 (reverse $7) $9 }++SizedData :: { C.Declaration }+SizedData : sized data Id DataTelescope ':' Expr '{' Constructors '}' OptFields+   { C.DataDecl $3 A.Sized A.Ind $4 $6 (reverse $8) $10 }++CoData :: { C.Declaration }+CoData : codata Id DataTelescope ':' Expr '{' Constructors '}' OptFields+       { C.DataDecl $2 A.NotSized A.CoInd $3 $5 (reverse $7) $9 }++SizedCoData :: { C.Declaration }+SizedCoData : sized codata Id DataTelescope ':' Expr '{' Constructors '}' OptFields+       { C.DataDecl $3 A.Sized A.CoInd $4 $6 (reverse $8) $10 }++RecordDecl :: { C.Declaration }+RecordDecl : record Id DataTelescope ':' Expr '{' Constructor '}'  OptFields+   { C.RecordDecl $2 $3 $5 $7 $9 }+-}++Data :: { C.Declaration }+Data : data DataDef+  { let (n,tel,t,cs,fs) = $2 in C.DataDecl n A.NotSized A.Ind tel t cs fs }++SizedData :: { C.Declaration }+SizedData : sized data DataDef+  { let (n,tel,t,cs,fs) = $3 in C.DataDecl n A.Sized A.Ind tel t cs fs }++CoData :: { C.Declaration }+CoData : codata DataDef+  { let (n,tel,t,cs,fs) = $2 in C.DataDecl n A.NotSized A.CoInd tel t cs fs }++SizedCoData :: { C.Declaration }+SizedCoData : sized codata DataDef+  { let (n,tel,t,cs,fs) = $3 in C.DataDecl n A.Sized A.CoInd tel t cs fs }++RecordDecl :: { C.Declaration }+RecordDecl : record DataDef1+  { let (n,tel,t,c,fs) = $2 in C.RecordDecl n tel t c fs }++DataDef :: { (C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name]) }+DataDef : Id DataTelescope ':' Expr '{' Constructors '}' OptFields+            { ($1, $2, $4, reverse $6, $8)}+        | Id DataTelescope '{' Constructors '}' OptFields+            { ($1, $2, C.set0, reverse $4, $6)}++DataDef1 :: { (C.Name, C.Telescope, C.Type, C.Constructor, [C.Name]) }+DataDef1 : Id DataTelescope ':' Expr '{' Constructor '}' OptFields+            { ($1, $2, $4, $6, $8)}+         | Id DataTelescope '{' Constructor '}' OptFields+            { ($1, $2, C.set0, $4, $6)}++Fun :: { C.Declaration }+Fun : fun TypeSig '{' Clauses '}' { C.FunDecl A.Ind $2 $4 }++CoFun :: { C.Declaration }+CoFun : cofun TypeSig '{' Clauses '}' { C.FunDecl A.CoInd $2 $4  }++Mutual :: { C.Declaration }+Mutual : mutual '{' Declarations '}' { C.MutualDecl (reverse $3) }++Let :: { C.Declaration }+Let : Eval let LetDef { C.LetDecl $1 $3 }++{-+Let : Eval let Id Telescope TypeOpt '=' ExprT { C.LetDecl $1 $3 $4 $5 $7 }+-- Let : Eval let Id Telescope ':' Expr '=' ExprT { C.LetDecl $1 $3 $4 $6 $8 }+-}++LetDef :: { C.LetDef }+LetDef : PolId Telescope TypeOpt '=' ExprT { let (dec,n) = $1 in C.LetDef dec n $2 $3 $5 }++Eval :: { Bool }+Eval : {- nothing -}  { False }+     | eval           { True  }++TypeOpt :: { Maybe C.Type }+TypeOpt : {- nothing -} { Nothing }+        | ':' Expr      { Just $2 }++{-+Let :: { C.Declaration }+Let : let TypeSig '=' ExprT { C.LetDecl False $2 $4 }+      | eval let TypeSig '=' ExprT { C.LetDecl True $3 $5 }+-}++PatternDecl :: { C.Declaration }+PatternDecl : pattern SpcIds '=' PairP { C.PatternDecl (head $2) (tail $2) $4 }+++OptFields :: { [Name] }+OptFields : {- empty -}  { [] }+          | fields Ids   { $2 }+-----++Id :: { Name }+Id : id { C.Name $1 }+-- no longer  number { $1 }++SpcIds :: { [Name] } -- non-empty list+SpcIds : Id     { [$1] }+       | Id SpcIds { $1 : $2 }++Ids :: { [Name] } -- non-empty list+Ids : Id              { [$1] }+    | Id ',' Ids { $1 : $3 }++Pol :: { Pol }+Pol : '++'         { SPos  }+    | '+'          { Pos   }+    | '-'          { Neg   }+    | '.'          { Const } -- use bracket [..]+    | '^'          { Param }+    | '*'          { Rec   } -- recursive+--    | {- empty -}  { Mixed }++Measure :: { A.Measure C.Expr }+Measure : '|' Meas { A.Measure $2 }++Meas :: { [C.Expr] }+Meas : Expr '|'      { [$1] }+     | Expr ',' Meas { $1 : $3 }++Bound :: { A.Bound C.Expr }+Bound : Measure '<' Measure { A.Bound A.Lt $1 $3 }+      | Measure '<=' Measure { A.Bound A.Le $1 $3 } {- (A.succMeasure C.Succ $3) } -}++EIds :: { [Name] } -- non-empty list+EIds : ExprList       { let { f (C.Ident (C.QName x)) = x+                            ; f e = error ("not an identifier: " ++ C.prettyExpr e)+                            } in map f $1+                      }++Telescope :: { C.Telescope }+Telescope :  {- empty -}          { [] }+              | TBind Telescope { $1 : $2 }+              | Measure Telescope { C.TMeasure $1 : $2 }++-- Binding.+TBind :: { C.TBind }+TBind+  :     '(' EIds ':' Expr ')' { C.TBind   (Dec Default) $2      $4 }+  |     '(' Id  '<'  Expr ')' { C.TBounded A.defaultDec $2 A.Lt $4 }+  |     '(' Id  '<=' Expr ')' { C.TBounded A.defaultDec $2 A.Le $4 }+  | Pol '(' EIds ':' Expr ')' { C.TBind    (Dec $1)     $3      $5 }+  | Pol '(' Id  '<'  Expr ')' { C.TBounded (Dec $1)     $3 A.Lt $5 }+  | Pol '(' Id '<='  Expr ')' { C.TBounded (Dec $1)     $3 A.Le $5 }+  | EBind                     { $1 }+  | HBind                     { $1 }++-- Erased binding+EBind :: { C.TBind }+EBind+  : '[' Ids ':' Expr ']' { C.TBind    A.irrelevantDec $2      $4 }+  | '[' Id '<'  Expr ']' { C.TBounded A.irrelevantDec $2 A.Lt $4 }+  | '[' Id '<=' Expr ']' { C.TBounded A.irrelevantDec $2 A.Le $4 }++-- Hidden binding+HBind :: { C.TBind }+HBind+  : '{' Ids ':' Expr '}' { C.TBind    A.Hidden $2      $4 }+  | '{' Id '<'  Expr '}' { C.TBounded A.Hidden $2 A.Lt $4 }+  | '{' Id '<=' Expr '}' { C.TBounded A.Hidden $2 A.Le $4 }+++UntypedBind :: { C.LBind }+UntypedBind : Id              { C.TBind A.defaultDec [$1] Nothing }+            | '[' Id ']'      { C.TBind A.irrelevantDec [$2] Nothing }+            | Pol Id          { C.TBind (Dec $1) [$2] Nothing }+            | Pol '(' Id ')'  { C.TBind (Dec $1) [$3] Nothing }++PolId :: { (Dec, C.Name) }+PolId : Id              {  (A.defaultDec   , $1) }+      | '[' Id ']'      {  (A.irrelevantDec, $2) }+      | Pol Id          {  (Dec $1         , $2) }++LLetDef :: { C.LetDef }+LLetDef : LetDef        { $1 }+-- legacy forms+        |  '[' Id ':' Expr ']' '=' Expr     { C.LetDef A.irrelevantDec $2 [] (Just $4) $7 }  -- erased binding+        |  Pol '(' Id ':' Expr ')' '=' Expr { C.LetDef (Dec $1) $3 [] (Just $5) $8 } -- ordinary binding++-- let binding+LBind :: { C.LBind }+LBind :  UntypedBind         { $1 }+      |  Id ':' Expr         { C.TBind A.defaultDec [$1] (Just $3) } -- ordinary binding+      |  '(' Id ':' Expr ')' { C.TBind A.defaultDec [$2] (Just $4) } -- ordinary binding+      |  '[' Id ':' Expr ']' { C.TBind A.irrelevantDec [$2] (Just $4) }  -- erased binding+      |  Pol '(' Id ':' Expr ')' { C.TBind (Dec $1) [$3] (Just $5) } -- ordinary binding+--      |  Pol '[' Id ':' Expr ']' { C.TBind (Dec True $1) [$3] $5 }  -- erased binding++Domain :: { C.Telescope }+Domain : Expr0             { [C.TBind (Dec Default) {- A.defaultDec -} [] $1] }+       | '[' Expr ']'      { [C.TBind A.irrelevantDec [] $2] }+       | Pol Expr0         { [C.TBind (Dec $1) [] $2] }+--       | Pol '[' Expr ']'  { [C.TBind (Dec True  $1) [] $3] }+       | TBind             { [$1] }+       | Measure           { [C.TMeasure $1] }+       | Bound             { [C.TBound $1] }+       | Telescope         { $1 }+++-- expressions which can be tuples e , e'+ExprT :: { C.Expr}+ExprT : ExprList           { foldr1 C.Pair $1 }++ExprList :: { [C.Expr] }+ExprList : Expr               { [$1] }+         | Expr ',' ExprList     { $1 : $3 }+++-- general form of expression+Expr :: { C.Expr }+Expr : Domain '->' Expr                 { C.Quant A.Pi $1 $3 }+     | '\\' SpcIds '->' ExprT           { foldr C.Lam $4 $2 }+     | let LLetDef in ExprT             { C.LLet $2 $4 }+     | case ExprT TypeOpt '{' Cases '}' { C.Case $2 $3 $5 }+     | Expr0                            { $1 }                -- Sigma type+     | Expr1 '+' Expr                   { C.Plus $1 $3 }+     | Expr1 '<|' Expr                  { C.App $1 [$3] }+     | Expr1 '|>' Expr                  { C.App $3 [$1] }++-- Sigma types (A & B, (x : A) & B)+Expr0 :: { C.Expr }+Expr0 : Expr1                            { $1 }+      | SigDom '&' Expr0                 { C.Quant A.Sigma [$1] $3 }++-- SigDom ~ Domain, but no Telescope and no Expr0+SigDom :: { C.TBind }+SigDom : Expr1             { C.TBind (Dec Default) {- A.defaultDec -} [] $1 }+       | '[' Expr ']'      { C.TBind A.irrelevantDec [] $2 }+       | Pol Expr1         { C.TBind (Dec $1) [] $2 }+--       | Pol '[' Expr ']'  { C.TBind (Dec True  $1) [] $3 }+       | TBind             { $1 }+       | Measure           { C.TMeasure $1 }+       | Bound             { C.TBound $1   }  -- constraint++-- perform applications+Expr1 :: { C.Expr }+Expr1 : Expr2 { let (f : args) = reverse $1 in+                if null args then f else C.App f args+	      }+       | coset Expr3      { C.CoSet $2 }+       | set              { C.Set C.Zero }+       | set Expr3        { C.Set $2 }+       | number '*' Expr1 { let n = read $1 in+                            if n==0 then C.Zero else+                            iterate (C.Plus $3) $3 !! (n-1) }+--       | EBind Expr1      { C.EBind $1 $2 }++-- gather applications+Expr2 :: { [C.Expr] }+Expr2 : Expr3 { [$1] }+       | Expr2 Expr3 { $2 : $1 }+       | Expr2 '.' Id { C.Proj $3 : $1 }+       | Expr2 set   { C.Set C.Zero : $1 }+--       | succ SE { [C.Succ $2] }++-- atoms+Expr3 :: { C.Expr }+Expr3 : size                      { C.Size }+      | max                       { C.Max }+      | infty                     { C.Infty }+      | QName                     { C.Ident $1}+      | '<' ExprT ':' Expr '>'    { C.Sing $2 $4 }+      | '(' ExprT ')'             { $2 }+      | '_'                       { C.Unknown }+      | succ Expr3                { C.Succ $2 }  -- succ is a prefix op+      | number                    { iterate C.Succ C.Zero !! (read $1) }+      | record '{' RecordDefs '}' { C.Record $3 }++QName :: { C.QName }+QName : qualid { let (m,n) = $1 in C.Qual (C.Name m) (C.Name n) }+      | Id     { C.QName $1}++{-+-- general form of type expression+Type :: { C.Expr }+Type : Domain '->' Type                 { C.Quant A.Pi $1 $3 }+     | let LBind '=' ExprT in Type      { C.LLet $2 $4 $6 }+     | case ExprT '{' Cases '}'         { C.Case $2 $4 }+     | Type1                            { $1 }++-- perform applications+Type1 :: { C.Expr }+Type1 : Type2 { let (f : args) = reverse $1 in+                if null args then f else C.App f args+	      }+       | coset Expr3                      { C.CoSet $2 }+       | set                              { C.Set C.Zero }+       | set Expr3                        { C.Set $2 }+       | Domain '&' Type1                 { C.Quant A.Sigma $1 $3 }++-- gather applications+Type2 :: { [C.Expr] }+Type2 : Type3 { [$1] }+      | Type2 Expr3 { $2 : $1 }+      | Type2 '.' Id { C.Proj $3 : $1 }+      | Type2 set   { C.Set C.Zero : $1 }++-- type atoms+Type3 :: { C.Expr }+Type3 : size                      { C.Size }+      | Id                        { C.Ident $1}+      | '(' Type ')'              { $2 }+      | '_'                       { C.Unknown }+-}++RecordDefs :: { [([Name],C.Expr)] }+RecordDefs+  : RecordDef ';' RecordDefs   { $1 : $3 }+  | RecordDef                  { [$1] }+  | {- empty -}                { [] }++RecordDef :: { ([Name],C.Expr) }+RecordDef : SpcIds '=' ExprT    { ($1,$3) }++TypeSig :: { C.TypeSig }+TypeSig : Id ':' Expr { C.TypeSig $1 $3 }++Constructor :: { C.Constructor }+Constructor : Id Telescope ':' Expr { C.Constructor $1 $2 (Just $4) }+            | Id Telescope          { C.Constructor $1 $2 Nothing }++Constructors :: { [C.Constructor ] }+Constructors :+      Constructors ';' Constructor { $3 : $1 }+    | Constructors ';' { $1 }+    | Constructor { [$1] }+    | {- empty -} { [] }++Cases :: { [C.Clause] }+Cases : Pattern '->' ExprT ';' Cases  { (C.Clause Nothing [$1] (Just $3)) : $5 }+      | Pattern '->' ExprT            { (C.Clause Nothing [$1] (Just $3)) : [] }+      | Pattern ';' Cases             { (C.Clause Nothing [$1] Nothing) : $3 }+      | Pattern                       { (C.Clause Nothing [$1] Nothing) : [] }+      | {- empty -}                   { [] }++Clause :: { C.Clause }+Clause : Id LHS '=' ExprT { C.Clause (Just $1) $2 (Just $4) }+       | Id LHS           { C.Clause (Just $1) $2 Nothing }++LHS :: { [C.Pattern] }+LHS : Patterns { reverse $1 }++Patterns :: { [C.Pattern] }+Patterns : {- empty -} { [] }+--    | Pattern Patterns { $1 : $2 }+    | Patterns Pattern { $2 : $1 }+    | Patterns '<|' ElemP { $3 : $1 }++-- atomic patterns+Pattern :: { C.Pattern }+Pattern : '(' ')'            { C.AbsurdP     }+        | '(' PairP ')'      { $2            }+        | DotId              { $1            }+        | succ Pattern       { C.SuccP $2    }+        | '.' set            { C.DotP (C.Set C.Zero) }+        | '.' Expr3          { C.DotP $2     }++-- pattern tuples+PairP :: { C.Pattern }+PairP : ElemP ',' PairP     { C.PairP $1 $3 }+      | ElemP               { $1 }++ElemP :: { C.Pattern }+ElemP : ConP                { $1 }+      | Expr3 '>' Id        { C.SizeP $1 $3 }+      | Id '<' Expr3        { C.SizeP $3 $1 }+      | Pattern             { $1 }+      | ConP '<|' ElemP     { patApp $1 [$3] } -- '<|' is Haskell's '$' (appl.)++-- constructor with at least one argument pattern+ConP :: { C.Pattern }+ConP : DotId Pattern       { patApp $1 [$2] }+     | ConP Pattern        { patApp $1 [$2] }++DotId :: { C.Pattern }+DotId : Id                 { C.IdentP (C.QName $1) }+      | '.' Id             { C.ConP True (C.QName $2) [] }+++Clauses :: { [C.Clause] }+Clauses : RClauses { reverse $1 }++RClauses :: { [C.Clause ] }+RClauses+ : RClauses ';' Clause { $3 : $1 }+ | RClauses ';'        { $1      }+ | Clause              { [$1]    }+ | {- empty -}         { []      }++-- Binding in data telescope, supports (+ X : Set) for backwards compatibility+TBindSP :: { C.TBind }+TBindSP+  :     '(' Ids ':' Expr ')' { C.TBind (Dec Default) $2 $4 } -- ordinary binding+  |     '[' Ids ':' Expr ']' { C.TBind A.irrelevantDec $2 $4 }  -- erased bind.+  | Pol '(' Ids ':' Expr ')' { C.TBind (Dec $1) $3 $5 }+  | '(' '+' Ids ':' Expr ')' { C.TBind (Dec SPos) $3 $5 }++--  | '(' sized Id ')'     { C.TSized $3 }++DataTelescope :: { C.Telescope }+DataTelescope :  {- empty -}          { [] }+              | TBindSP DataTelescope { $1 : $2 }++{++parseError :: [T.Token] -> a+parseError [] = error "Parse error at EOF"+parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x)++}
+ src/Polarity.hs view
@@ -0,0 +1,421 @@+{- In the context of polarities, we use "recursive" in the sense of+"computable" rather than syntactic recursion. -}++module Polarity where++import Util+import Warshall++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.List as List++{- 2010-10-09 Fusing polarity and irrelevance++     .      constant (= irrelevant) function+    / \+  ++   |    strictly positive function (types only)+   |   |+   +   -    positive/negative function (types only)+    \ /+     ^      parametric function (lambda cube), default for types+     |+     *      recursive function (pattern matching), default for terms+++ Composition (AC)++  . p = .+  * p = *  (p not .)+  ^ p = ^  (p not .,*)+ ++ p = p+  + p = p  (p not ++)+  - - = +++Equality/subtyping <=p++  x <=. y  iff  true+  x <=- y  iff  x >= y+  x <=^ y  iff  x == y+  x <=* y  iff  x == y+ -}++-- polarities and strict positivity ----------------------------------++class Polarity pol where+  erased    :: pol -> Bool+  compose   :: pol -> pol -> pol+  neutral   :: pol                 -- ^ neutral for compose.+  promote   :: pol -> pol+  demote    :: pol -> pol+  hidden    :: pol                 -- ^ corresponding to hidden quantification++type PVarId = Int++data Pol+  = Const -- non-occurring, irrelevant+  | SPos  -- strictly positive+  | Pos   -- positive+  | Neg   -- negative, used internally for contravariance of sized codata+  | Param -- parametric (lambda) function+  | Rec   -- recursive (takes decision)+  | Default     -- no polarity given (for parsing)+  | PVar PVarId -- flexible polarity variable+         deriving (Eq,Ord)++mixed = Rec+defaultPol = Rec+{-+mixed = Param -- TODO: Rec+defaultPol = Param -- TODO: Rec+-}+instance Polarity Pol where+  erased  = (==) Const+  compose = polComp+  neutral = SPos+  promote = invComp Const+  demote  = invComp Rec+  hidden  = Const++instance Show Pol where+  show Const = "."+  show SPos  = "++"+  show Pos   = "+"+  show Neg   = "-"+  show Param = "^"+  show Rec   = "*"+  show Default = "{default polarity}"+  show (PVar i) = showPVar i++showPVar i = "?p" ++ show i++isPVar (PVar{}) = True+isPVar _ = False++-- information ordering+leqPol :: Pol -> Pol -> Bool+leqPol x Const  = True   -- Const is top+leqPol Const x  = False+leqPol Rec y    = True   -- Rec is bottom+leqPol x Rec    = False+leqPol Param y  = True   -- Param is second bottom+leqPol x Param  = False+leqPol Pos SPos = True+leqPol x   y    = x == y++{- RETIRED+isSPos :: Pol -> Bool+isSPos SPos = True+isSPos Const = True+isSPos _ = False+-}++{- NOT USED+isPos :: Pol -> Bool+isPos Pos = True+isPos x = isSPos x+-}++-- polarity negation+-- used in Eval.hs leqVals' for switching sides+-- this means it is only applied to Pos, Neg, Param,+-- never to SPos, Const, or polarity expressions+polNeg :: Pol -> Pol+polNeg Const  = Const+polNeg SPos  = Neg+polNeg Pos   = Neg+polNeg Neg   = Pos+polNeg Param = Param+polNeg Rec   = Rec++-- polarity composition+-- used in Eval.hs leqVals'+polComp :: Pol -> Pol -> Pol+polComp Const  x  = Const   -- most dominant+polComp x Const   = Const+polComp Rec x     = Rec  -- dominant except for Const+polComp x Rec     = Rec+polComp Param x   = Param  -- dominant except for Const, Rec+polComp x Param   = Param+polComp SPos  x   = x      -- neutral+polComp x SPos    = x+polComp Pos  x    = x      -- neutral except for SPos+polComp x Pos     = x+polComp Neg Neg   = Pos    -- order 2+{- pol.comp. is ass., comm., with neutral ++, and infinity Const+   cancellation does not hold, since composition with anything by ++ is+   information loss:+     q p <= q p' ==> p <= p'+   only if q = ++ (then it is trivial anyway) -}++-- polarity inverse composition (see Abel, MSCS 2008)+-- invComp p q1 <= q2  <==> q1 <= polComp p q2+-- used in TCM.hs cxtApplyDec+invComp :: Pol -> Pol -> Pol+invComp Rec   Rec   = Rec       -- in rec. arg. keep only rec. vars+invComp Rec   x     = Const     -- all others are declared unusable+invComp Param Param = Param     -- in parametric mixed arg, keep only mixed vars+invComp Param x     = Const+invComp Const x     = Param     -- a constant function can take any argument+invComp SPos  x     = x         -- SPos is the identity+invComp p     SPos  = Const     -- SPos preserved only under SPos+invComp Pos   x     = x         -- x not SPos+invComp Neg   x     = polNeg x  -- x not SPos++{- UNUSED+invCompExpr :: Pol -> PExpr -> PExpr+invCompExpr q (PValue p)   = PValue $ invComp q p+invCompExpr q (PExpr q' i) = PExpr (polComp q q') i+-}++-- polarity conjuction (infimum)+-- used in comparing spines+polAnd :: Pol -> Pol -> Pol+polAnd Const x = x      -- most information+polAnd x Const = x+polAnd Rec   x = Rec   -- least information+polAnd x   Rec = Rec+{-+polAnd Param x  = Param   -- 2nd least information+polAnd x Param  = Param+-}+polAnd x y | x == y = x       -- same information+polAnd SPos Pos = Pos     -- SPos is more informative than Pos+polAnd Pos SPos = Pos+{-+polAnd SPos Neg = Param+polAnd Neg SPos = Param+-}+polAnd _ _      = Param     -- remaining cases: conflicting info or Param++instance SemiRing Pol where+  oplus  = polAnd+  otimes = polComp+  ozero  = Const    -- dominant for composition, neutral for infimum+  oone   = SPos     -- neutral  for composition++-- computing a relation from <=+relPol :: Pol -> (a -> a -> Bool) -> (a -> a -> Bool)+relPol Const r a b = True+relPol Rec   r a b = r a b && r b a+relPol Param r a b = r a b && r b a+relPol Neg   r a b = r b a+relPol Pos   r a b = r a b+relPol SPos  r a b = r a b++relPolM :: (Monad m) => Pol -> (a -> a -> m ()) -> (a -> a -> m ())+relPolM Const r a b = return ()+relPolM Rec   r a b = r a b >> r b a+relPolM Param r a b = r a b >> r b a+relPolM Neg   r a b = r b a+relPolM Pos   r a b = r a b+relPolM SPos  r a b = r a b++-- polarity product (composition of polarities) ----------------------++data Multiplicity = POne | PTwo deriving (Eq, Ord)++instance Show Multiplicity where+  show POne = "1"+  show PTwo = "2"++-- addition modulo 2+addMultiplicity :: Multiplicity -> Multiplicity -> Multiplicity+addMultiplicity PTwo y = y+addMultiplicity x PTwo = x+addMultiplicity POne POne = PTwo++type VarMults = Map PVarId Multiplicity -- multiplicity of variables (1 or 2)++showMults :: VarMults -> String+showMults mults =+  let ml = Map.toList mults  -- get list of (key,value) pairs+      l  = concat $ map f ml where+             f (k, POne) = [k]+             f (k, PTwo) = [k,k]+  in Util.showList "." showPVar l++multsEmpty = Map.empty++multsSingle :: Int -> VarMults+multsSingle i = Map.insert i POne multsEmpty+++data PProd = PProd+  { coeff    :: Pol      -- a coefficient, excluding PVar+  , varMults :: VarMults -- multiplicity of variables (1 or 2)+  } deriving (Eq,Ord)++instance Polarity PProd where+  erased  = erased . coeff+  compose = polProd+  neutral = PProd SPos multsEmpty+  demote  = undefined+  promote = undefined+  hidden  = PProd hidden multsEmpty++instance Show PProd where+  show (PProd Const _) = show Const+  show (PProd SPos m) = if Map.null m then show SPos else showMults m+  show (PProd q m) = separate "." (show q) (showMults m)++pprod :: Pol -> PProd+pprod (PVar i) = PProd SPos (multsSingle i)+pprod q = PProd q multsEmpty++-- | fails if not a simple polarity+fromPProd :: PProd -> Maybe Pol+fromPProd (PProd Const _)          = Just Const+fromPProd (PProd p m) | Map.null m = Just p+fromPProd _                        = Nothing++isSPos :: PProd -> Bool+isSPos (PProd Const _) = True+isSPos (PProd SPos m) = Map.null m+isSPos _ = False++-- multiply two products++polProd :: PProd -> PProd -> PProd+polProd (PProd q1 m1) (PProd q2 m2) = PProd (polComp q1 q2) $+  Map.unionWith addMultiplicity m1 m2++-- polarity expressions are polynomials ------------------------------++data PPoly = PPoly { monomials :: [PProd] } deriving (Eq,Ord)++instance Show PPoly where+  show (PPoly []) = show Const+  show (PPoly [m]) = show m+  show (PPoly l)   = Util.showList "/\\" show l++ppoly :: PProd -> PPoly+ppoly (PProd Const _) = PPoly []+ppoly pp = PPoly [pp]++polSum :: PPoly -> PPoly -> PPoly+polSum (PPoly x) (PPoly y) = PPoly $ List.nub $ x ++ y++polProduct :: PPoly -> PPoly -> PPoly+polProduct (PPoly l1) (PPoly l2) =+  let ps = [ polProd x y | x <- l1, y <- l2]+  in PPoly $ List.nub $ ps++instance SemiRing PPoly where+  oplus  = polSum+  otimes = polProduct+  ozero  = PPoly []+  oone   = PPoly [PProd SPos Map.empty]++{-+data PExpr+  = PValue Pol     -- constant polarity+  | PExpr Pol Int  -- PExpr q pi means q^_1 pi  (pi is the number of the var)++-- a polarity variable+pvar :: Int -> PExpr+pvar = PExpr SPos  -- ++ is the neutral element of inverse polarity composition++instance Show PExpr where+  show (PValue p) = show p+  show (PExpr SPos i) = "?p" ++ show i+  show (PExpr q i) = show q ++ "^-1(?p" ++ show i ++ ")"+-}+++{- ML-style Polarity inference++Preliminaries:+1. constructor types are mixed-variant function types only+2. matching is only allowed on mixed-variant arguments+  1+2 are both consequences that only type-valued functions have variance+  and 1. data constructors are not types, 2. types are not matched on++Concrete syntax++  f : (xs : As) -> C   (C not a Pi-type)+  f = t++is parsed as abstract syntax++  f : pis(xs : As) -> C+  f = t++where pi_1..n are fresh polarity variables++Then t is type-checked to infer the polarity variables, e.g.++  f xs = t++  pis(xs : As) |- t : C++Now what can happen?++Variable:  t = x_i.  Then we add a constraint  pi_i <= ++++Application t = u v  where u : q(x:B) -> D++  q^-1(pis(xs: As)) |- v : B++  A term q^-1 pi arises where q is a polarity constant (!, ML-inference)+  or a polarity variable (recursion!, e.g. u = f)+  and pi is a polarity expression++In the context, keep SOLL and HABEN++  SOLL  is the original polarity (variable or constant)+  HABEN is a (ordered) list of pol.vars. and a pol.const. (default: ++)++Variable   : add constraint SOLL <= HABEN+Application: add q to HABEN by polarity multiplication (q is a var or const)+Abstraction: \xt : q(x:A) -> B:  continue with x (SOLL = q, HABEN = ++)++What kind of constraints do arise+1) q  <= pi    [ from variables , pi is a Pol-product ]+2) ++ <= pis  [ from positivity graph, pis is a sum of Pol-products ]+   this means ++ <= pi for all pi in pis++Solving constraints++- discard  o <= pi  and q <= /  (do not even need to add them)+- all pvars which are not bounded below (appearing in one q in 1)+  can be instantiated to /  which will remove some constraints+++-}++{- Mutual recursion++In mutual declarations, use the following Ansatz:  data/codata ++, functions o++  A = B -> A+  B = A -> B++A (B) is positive in its own body and negative in the body of B (A)++  F A B = B -> A   F(-,++)+  G A B = A -> B   G(-,++)++  F A B = G A B -> F A B+  G A B = F A B -> G A B++  Polarities:+  F : fa * -> fb * -> *+  G : ga * -> gb * -> *++  A : -fa, B : -fb |- G A B : *  ==> -fa <= ga, -fb <= gb+  A : -ga, B : -gb |- F A B : *  ==> -ga <= fa, -gb <= fb++-}++{- Pure polarity inference++Judgement:  pis(xs:As) |- t : B ---> C++Variable:   pis(xs:As) |- xi : Ai ---> pi_i <= ++++Application: Delta |- u : q(x:A) -> B ---> C1+             Delta |- v : A           ---> C2+             --------------------------------------------------+             Delta |- u v : B[u/x] ---> C1,C2,q(Delta) <= Delta+-}
+ src/PrettyTCM.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module PrettyTCM where++import Prelude hiding (sequence, mapM)++import Abstract+import {-# SOURCE #-} Eval+import {-# SOURCE #-} TCM+import qualified Util+import Value++import Control.Applicative hiding (empty)+import Control.Monad ((<=<))+import Data.Traversable++import qualified Text.PrettyPrint as P+++-- from Agda.TypeChecking.Pretty++type Doc = P.Doc++empty, comma, colon :: Monad m => m Doc++empty	   = return P.empty+comma	   = return P.comma+colon      = text ":"+pretty x   = return $ Util.pretty x+-- prettyA x  = P.prettyA x+text s	   = return $ P.text s+pwords s   = map return $ Util.pwords s+fwords s   = return $ Util.fwords s+sep ds	   = P.sep <$> sequence ds+fsep ds    = P.fsep <$> sequence ds+hsep ds    = P.hsep <$> sequence ds+vcat ds    = P.vcat <$> sequence ds+d1 $$ d2   = (P.$$) <$> d1 <*> d2+d1 <> d2   = (P.<>) <$> d1 <*> d2+d1 <+> d2  = (P.<+>) <$> d1 <*> d2+nest n d   = P.nest n <$> d+braces d   = P.braces <$> d+brackets d = P.brackets <$> d+parens d   = P.parens <$> d++prettyList ds = brackets $ fsep $ punctuate comma ds++punctuate _ [] = []+punctuate d ds = zipWith (<>) ds (replicate n d ++ [empty])+    where+	n = length ds - 1++-- monadic pretty printing++class ToExpr a where+  toExpression :: a -> TypeCheck Expr++instance ToExpr Expr where+  toExpression = return++instance ToExpr Val where+  toExpression = toExpr+++class PrettyTCM a where+  prettyTCM :: a -> TypeCheck Doc++instance PrettyTCM Name where+  prettyTCM = pretty++instance PrettyTCM Pattern where+  prettyTCM = pretty++instance PrettyTCM [Pattern] where+  prettyTCM = sep . map pretty++instance PrettyTCM Expr where+  prettyTCM = pretty++instance PrettyTCM (Sort Expr) where+  prettyTCM = pretty++instance PrettyTCM Val where+  prettyTCM = pretty <=< toExpr++instance PrettyTCM [Val] where+  prettyTCM = sep . map (pretty <=< toExpr)++instance PrettyTCM (Sort Val) where+  prettyTCM = pretty <=< mapM toExpr++instance PrettyTCM a => PrettyTCM (OneOrTwo a) where+  prettyTCM (One a)     = prettyTCM a+  prettyTCM (Two a1 a2) = prettyTCM a1 <+> text "||" <+> prettyTCM a2++instance (ToExpr a) => PrettyTCM (Measure a) where+  prettyTCM mu = pretty =<< mapM toExpression mu++instance (ToExpr a) => PrettyTCM (Bound a) where+  prettyTCM beta = pretty =<< mapM toExpression beta++instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where+  prettyTCM (a,b) = parens $ prettyTCM a <> comma <+> prettyTCM b
+ src/ScopeChecker.hs view
@@ -0,0 +1,1124 @@+-- NOTE: insertion of polarity variables disabled here, must be done+-- in TypeChecker++{-# LANGUAGE TupleSections, DeriveFunctor, GeneralizedNewtypeDeriving,+      FlexibleContexts, FlexibleInstances, UndecidableInstances,+      MultiParamTypeClasses #-}++module ScopeChecker (scopeCheck) where++import Prelude hiding (mapM, null)++import Control.Applicative+import Control.Monad.Identity hiding (mapM)+import Control.Monad.Reader hiding (mapM)+import Control.Monad.State hiding (mapM)+import Control.Monad.Except hiding (mapM)++import Data.List as List hiding (null)+import Data.Maybe+import Data.Traversable (mapM)++import Debug.Trace++import Polarity(Pol(..))+import qualified Polarity as A+import Abstract (Sized,mkExtRef,Co,ConK(..),PrePost(..),MVar,Decoration(..),Override(..),Measure(..),adjustTopDecsM,Arity,polarity,LensPol(..))+import qualified Abstract as A+import qualified Concrete as C++import TraceError++import Util++-- * scope checker+-- check that all identifiers are in scope and global identifiers are only used once+-- replaces Ident with Con, Def, Let or Var+-- replaces IdentP with ConP or VarP in patterns+-- replaces Unknown by a new Meta-Variable+-- check pattern length is equal in each clause+-- group mutual declarations++-- | Entry point for scope checker.+scopeCheck :: [C.Declaration] -> Either TraceError ([A.Declaration],SCState)+scopeCheck dl = runScopeCheck initCtx initSt (scopeCheckDecls dl)++-- * Local identifiers.++-- ** local environment of scope checker++data SCCxt = SCCxt+  { stack             :: Stack     -- ^ Local names in scope.+    -- We keep a stack of these to disallow shadowing on the same level.+  , defaultPolarity   :: Pol       -- ^ Replacement for @Default@ polarity.+  , constraintAllowed :: Bool      -- ^ Is a constraint @|m| < |m'|@ legal now, since we just parsed a quantifier?+  }++type Stack = [Context]++initCtx :: SCCxt+initCtx = SCCxt+  { stack             = [[]]  -- one empty context to begin with+  , defaultPolarity   = A.Rec -- POL VARS DISABLED!!+  , constraintAllowed = False+  }++-- ** A lens for @constraintAllowed@++class LensConstraintAllowed a where+  mapConstraintAllowed :: (Bool -> Bool) -> a -> a+  setConstraintAllowed :: Bool -> a -> a+  setConstraintAllowed b = mapConstraintAllowed (const b)++instance LensConstraintAllowed SCCxt where+  mapConstraintAllowed f sc = sc { constraintAllowed = f (constraintAllowed sc) }++instance (LensConstraintAllowed r, MonadReader r m) => LensConstraintAllowed (m a) where+  mapConstraintAllowed f = local (mapConstraintAllowed f)++-- ** Managing the stack of local contexts.++newLevel :: ScopeCheck a -> ScopeCheck a+newLevel = local $ \ cxt -> cxt { stack = [] : stack cxt }++thisLevel :: SCCxt -> Context+thisLevel cxt = head (stack cxt)++instance Push Local SCCxt where+  push nx sc = sc { stack = push nx (stack sc) }++-- ** translating concrete names to abstract names++type Local   = (C.Name,A.Name)+type Context = [Local]++emptyCtx :: Context+emptyCtx = []++newLocal :: Push Local b => C.Name -> b -> (A.Name, b)+newLocal n cxt = (x, push (n, x) cxt)+  where x = A.fresh $ C.theName n++lookupLocal :: C.Name -> ScopeCheck (Maybe A.Name)+lookupLocal n = retrieve n <$> asks stack++lookupGlobal :: C.QName -> ScopeCheck (Maybe DefI)+lookupGlobal n = lookupSig n <$> getSig++addContext :: Context -> SCCxt -> SCCxt+addContext delta sc = sc { stack = delta : stack sc }++-- * Global identifiers.++-- | Kind of identifier.+data IKind+  = DataK+  | ConK ConK+  | FunK Bool  -- ^ @False@ = inside body, @True@ = outside body+  | ProjK      -- ^ a record projection+  | LetK++-- | Global identifier.+data DefI = DefI { ikind :: IKind, aname :: A.QName }++-- | Scope check signature.+type Sig = [(C.QName,DefI)]++emptySig :: Sig+emptySig = []++lookupSigU :: C.Name -> Sig -> Maybe DefI+lookupSigU n = lookupSig (C.QName n)++lookupSig :: C.QName -> Sig -> Maybe DefI+lookupSig n [] = Nothing+lookupSig n ((x,k):xs) = if (x == n) then Just k else lookupSig n xs++-- ** State of scope checker.++data SCState = SCState+  { signature  :: Sig+  , nextMeta   :: MVar+  , nextPolVar :: MVar+  }++initSt = SCState emptySig 0 0++-- * The scope checking monad.++-- | Scope checking monad.+--+-- Reader monad for local environment of variables (used in expresssions and patterns).+-- State monad (hidden) for global signature.+-- Error monad for reporting scope violations.+newtype ScopeCheck a = ScopeCheck { unScopeCheck ::+  ReaderT SCCxt (StateT SCState (ExceptT TraceError Identity)) a }+  deriving (Functor, Applicative, Monad,+    MonadReader SCCxt, MonadError TraceError)++runScopeCheck+  :: SCCxt          -- ^ Local variable mapping.+  -> SCState        -- ^ Global identifier mapping.+  -> ScopeCheck a   -- ^ The computation.+  -> Either TraceError (a, SCState)+runScopeCheck ctx st (ScopeCheck sc) = runIdentity $ runExceptT $+  runStateT (runReaderT sc ctx) st++-- ** Local state.++-- | Add a local identifier.+--   (Not tail recursive, since it also returns the generate id.)+addBind' :: Show e => e -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck (A.Name, a)+addBind' e n k = do+  ctx <- ask+  case retrieve n (thisLevel ctx) of+    Just _  -> errorAlreadyInContext e n+    Nothing -> do+      let (x, ctx') = newLocal n ctx -- addCtx' n ctx+      a <- local (const ctx') $ k x+      return (x, a)++addBind :: Show e => e -> C.Name -> ScopeCheck a -> ScopeCheck (A.Name, a)+addBind e n k = addBind' e n $ const k++addBinds :: Show e => e -> [C.Name] -> ScopeCheck a -> ScopeCheck ([A.Name], a)+addBinds e ns k = foldr step start ns where+  start    = do+    a <- k+    return ([], a)+  step n k = do+    (x, (xs, a)) <- addBind e n k+    return (x:xs, a)++-- | Add local variable without checking shadowing.+addLocal :: C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a+addLocal n k = do+  ctx <- ask+  let (x, ctx') = newLocal n ctx+  local (const ctx') $ k x++addTel :: C.Telescope -> A.Telescope -> ScopeCheck a -> ScopeCheck a+addTel ctel atel = local (addContext nxs)+  where nxs = reverse $ zipTels ctel atel++zipTels :: C.Telescope -> A.Telescope -> [(C.Name,A.Name)]+zipTels ctel atel = zip ns xs+  where ns = collectTelescopeNames ctel+        xs = map A.boundName $ A.telescope atel++-- ** Global state.++getSig :: ScopeCheck Sig+getSig = ScopeCheck $ gets signature++-- | Add a global identifier.+addName :: IKind -> C.Name -> ScopeCheck A.Name+addName k n = do+  sig <- getSig+  when (isJust (lookupSig (C.QName n) sig)) $+    errorAlreadyInSignature "shadowing of global definitions forbidden" n+  let x = A.fresh $ C.theName n+  addANameU k n x+  return x++-- addNameU :: IKind -> C.Name -> ScopeCheck A.Name+-- addNameU k n = A.unqual <$> addName k (C.QName n)++-- | Add an already translated global identifier.+addAName :: IKind -> C.QName -> A.QName -> ScopeCheck ()+addAName k n x = ScopeCheck $ modify $ \ st ->+  st { signature = (n, DefI k x) : signature st }++addANameU :: IKind -> C.Name -> A.Name -> ScopeCheck ()+addANameU ki n x = addAName ki (C.QName n) (A.QName x)++-- | Add or reuse an unqualified name.+overloadName :: IKind -> C.Name -> ScopeCheck A.Name+overloadName k n = do+  sig <- getSig+  case lookupSigU n sig of+    Nothing -> do+      let x = A.fresh $ C.theName n+      addANameU k n x+      return x+    Just (DefI k' (A.QName x)) -> return x++{- UNUSED+addDecl :: C.Declaration -> ScopeCheck A.Name+addDecl (C.DataDecl n _ _ _ _ _ _) = addName DataK n+addDecl (C.RecordDecl n _ _ _ _)   = addName DataK n+-}+{- UNUSED+addFunDecl :: Bool -> C.Declaration -> ScopeCheck A.Name+addFunDecl b (C.FunDecl _ ts _) = addTypeSig (FunK b) ts+-}++addTypeSig :: IKind -> C.TypeSig -> A.TypeSig -> ScopeCheck ()+addTypeSig kind (C.TypeSig n _) (A.TypeSig x _) = addANameU kind n x++{- UNUSED+-- | Add a global identifier.  Fail if already in signature.+addGlobal :: Show d => d -> IKind -> C.Name -> ScopeCheck A.Name+addGlobal d k n = enterShow n $ do+  sig <- getSig+  case lookupSig n sig of+    Just _  -> errorAlreadyInSignature d n+    Nothing -> addName k n+-}++-- | Create a meta variable.+nextMVar :: (MVar -> ScopeCheck a) -> ScopeCheck a+nextMVar f = ScopeCheck $ do+  st <- get+  put $ st { nextMeta = nextMeta st + 1 }+  unScopeCheck $ f (nextMeta st)++-- | Create a polarity meta variable.+nextPVar :: (MVar -> ScopeCheck a) -> ScopeCheck a+nextPVar f = ScopeCheck $ do+  st <- get+  put $ st { nextPolVar = nextPolVar st + 1 }+  unScopeCheck $ f (nextPolVar st)++-- ** Additional services of scope monad.++-- | Default polarity is context-sensitive.+setDefaultPolarity :: Pol -> ScopeCheck a -> ScopeCheck a+setDefaultPolarity p = local (\ sccxt -> sccxt { defaultPolarity = p })+{-+insertingPolVars :: Bool -> ScopeCheck a -> ScopeCheck a+insertingPolVars b = local (\ sccxt -> sccxt { insertPolVars = b })+-}++-- | Insert polarity variables for omitted polarities.+generalizeDec :: A.Dec -> ScopeCheck A.Dec+generalizeDec dec@A.Hidden = return dec+generalizeDec dec@A.Dec{}  =+  if (polarity dec == Default) then do+    p0 <- asks defaultPolarity+    case p0 of+      PVar{} -> nextPVar $ \ i ->+                  return $ setPol (PVar i) dec+      _      -> return $ setPol p0 dec+   else return dec++generalizeTBind :: C.TBind -> ScopeCheck C.TBind+generalizeTBind tb@C.TMeasure{} = return tb+generalizeTBind tb = do+  dec' <- generalizeDec (C.boundDec tb)+  return $ tb { C.boundDec = dec' }++-- | Insert polarity variables in telescope.+generalizeTel :: C.Telescope -> ScopeCheck C.Telescope+generalizeTel = mapM generalizeTBind++-- * Scope checking concrete syntax.+----------------------------------------------------------------------++scopeCheckDecls :: [C.Declaration] -> ScopeCheck [A.Declaration]+scopeCheckDecls = mapM scopeCheckDeclaration++scopeCheckDeclaration :: C.Declaration -> ScopeCheck A.Declaration++scopeCheckDeclaration (C.OverrideDecl Check ds) = ScopeCheck $ do+  st <- get+  as <- unScopeCheck $ scopeCheckDecls ds -- declarations need to scope check+  put st                   -- but then forget their effect: restore old state+  return $ A.OverrideDecl Check as++scopeCheckDeclaration (C.OverrideDecl Fail ds) = ScopeCheck $ do+  st <- get+  as <- unScopeCheck $ scopeCheckDecls ds+               `catchError` (const $ return [])  --on error discard block+  put st+  return $ A.OverrideDecl Fail as+{-+scopeCheckDeclaration (C.OverrideDecl Fail ds) = do+  st <- get+  (as,st') <- (do as  <- scopeCheckDecls ds+                  st' <- get+                  return (as,st'))+               `catchError` (const $ return ([],st))  --on error discard block+  put st'+  return $ A.OverrideDecl Fail as+-}+scopeCheckDeclaration (C.OverrideDecl override ds) = do -- TrustMe,Impredicative+  as <- scopeCheckDecls ds+  return $ A.OverrideDecl override as++scopeCheckDeclaration (C.RecordDecl n tel t c fields) =+  scopeCheckRecordDecl n tel t c fields++scopeCheckDeclaration d@(C.DataDecl{}) =+  scopeCheckDataDecl d -- >>= return . (:[])++scopeCheckDeclaration d@(C.FunDecl co _ _) =+  scopeCheckFunDecls co [d] -- >>= return . (:[])++scopeCheckDeclaration (C.LetDecl eval letdef@C.LetDef{ C.letDefDec = dec, C.letDefName = n }) = do+  unless (dec == A.defaultDec) $+    throwErrorMsg $ "polarity annotation not supported in global let definition of " ++ show n+  (tel, mt, e) <- scopeCheckLetDef letdef+  x <- addName LetK n+  return $ A.LetDecl eval x tel mt e++scopeCheckDeclaration d@(C.PatternDecl n ns p) = do+  let errorHead = "invalid pattern declaration\n" ++ C.prettyDecl d ++ "\n"+  -- check pattern+  (p, delta) <- runStateT (scopeCheckPattern p) emptyCtx+  p <- local (addContext delta) $ scopeCheckDotPattern p+  -- ensure that pattern variables are the declared variables+  unless (sort ns == sort (map fst delta)) $ do+    let usedNames = map fst delta+        unusedNames = ns \\ usedNames+        undeclaredNames = usedNames \\ ns+    when (not (null unusedNames)) $ throwErrorMsg $+      errorHead ++ "unsed variables in pattern: "+        ++ Util.showList " " show unusedNames+    when (not (null undeclaredNames)) $ throwErrorMsg $+      errorHead ++ "undeclared variables in pattern: "+        ++ Util.showList " " show undeclaredNames+  --  when (n `elem` ns) $ throwErrorMsg $ errorHead ++ "pattern"+  x <- addName (ConK DefPat) n+  let xs = map (fromJust . flip lookup delta) ns+  return (A.PatternDecl x xs p)++-- we support+-- - mutual (co)funs+-- - mutual (co)data++scopeCheckDeclaration (C.MutualDecl []) = throwErrorMsg "empty mutual block"+scopeCheckDeclaration (C.MutualDecl l@(C.DataDecl{}:xl)) =+  scopeCheckMutual l+scopeCheckDeclaration (C.MutualDecl l@(C.FunDecl  co _ _:xl)) =+  scopeCheckFunDecls co l  -- >>= return . (:[])+scopeCheckDeclaration (C.MutualDecl _) = throwErrorMsg "mutual combination not supported"++scopeCheckLetDef :: C.LetDef -> ScopeCheck (A.Telescope, Maybe (A.Type), A.Expr)+scopeCheckLetDef (C.LetDef dec n tel mt e) =  setDefaultPolarity A.Rec $ do+  tel <- generalizeTel tel+  (tel, (mt, e)) <- scopeCheckTele tel $ do+     (,) <$> mapM scopeCheckExprN mt  -- allow shadowing after : in type+         <*> scopeCheckExprN e        -- allow shadowing after =+  return (tel, mt, e)++{- scopeCheck Mutual block+first check signatures+then bodies+-}+scopeCheckMutual :: [C.Declaration] -> ScopeCheck A.Declaration+scopeCheckMutual ds0 = do+  -- flatten nested mutual blocks and override decls+  ds <- mutualFlattenDecls ds0+  -- extract, check, and add type signatures+  let ktsigs = map mutualGetTypeSig ds+  (mmm, tsigs') <- unzip <$> mapM checkAndAddTypeSig ktsigs+  -- funs have been added with internal names+  -- check that all functions are unmeasured or have a same length measure+  let (ns, mll) = unzip $ compressMaybes mmm+  let measured = null mll || isJust (head mll)+  let ok = null mll || all ((head mll)==) (tail mll)+  when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length"+{-+  -- switch to internal fun ids+  let funNames = [ n | (FunK _ , A.TypeSig n _) <- ktsigs ] -- internal fun names+{- SAME W/O COMPR+  let funNames = map (\ (_, C.TypeSig n _) -> n) $ filter aux ktsigs where+                   aux (FunK _, _) = True+                   aux _ = False+-}+  mapM_ (addName (FunK False)) funNames -- TODO+-}+  -- check bodies of declarations+  ds' <- mapM (setDefaultPolarity A.Rec . checkBody) (zip tsigs' ds)+  -- switch back to external fun ids+  let funNames = [ x | A.FunDecl _ (A.Fun _ x _ _) <- ds' ] -- external fun names+  zipWithM_ (addANameU (LetK)) ns funNames+--  zipWithM_ (addAName (FunK True)) ns funNames+  return $ A.MutualDecl measured ds'++scopeCheckTele :: C.Telescope -> ScopeCheck a -> ScopeCheck (A.Telescope, a)+scopeCheckTele []         cont = (A.emptyTel,) <$> cont+scopeCheckTele (tb : tel) cont = do+  (tbs, (A.Telescope tel, a)) <- scopeCheckTBind tb $ scopeCheckTele tel cont+  return (A.Telescope $ tbs ++ tel, a)++scopeCheckTBind :: C.TBind -> ScopeCheck a -> ScopeCheck ([A.TBind], a)+scopeCheckTBind tb cont = do+  let contYes = setConstraintAllowed True  cont+      contNo  = setConstraintAllowed False cont+  case tb of+    C.TBind dec [] t -> do -- non-dependent function type+      t       <- scopeCheckExprN t+      ([A.noBind $ A.Domain t A.defaultKind dec],) <$> contNo+    C.TBind dec ns t -> do+      t       <- scopeCheckExprN t+      (xs, a) <- addBinds tb ns $ contYes+      return (map (\ x -> A.TBind x (A.Domain t A.defaultKind dec)) xs, a)+    C.TBounded dec n ltle e -> do+      e <- scopeCheckExprN e+      (x, a) <- addBind tb n $ contYes+      return ([A.TBind x (A.Domain (A.Below ltle e) A.defaultKind dec)], a)+    C.TMeasure mu -> do+      mu <- scopeCheckMeasure mu+      ([A.TMeasure mu],) <$> cont+--    C.TMeasure mu -> throwErrorMsg $ "measure not allowed in telescope"+    C.TBound beta -> do+      unlessM (asks constraintAllowed) $+        errorConstraintNotAllowed beta+      beta <- scopeCheckBound beta+      ([A.TBound beta],) <$> cont++checkBody :: (A.TypeSig, C.Declaration) -> ScopeCheck A.Declaration+checkBody (A.TypeSig x tt, C.DataDecl n sz co tel _ cs fields) =+  checkDataBody tt n x sz co tel cs fields+checkBody (ts@(A.TypeSig n t), d@(C.FunDecl co tsig cls)) = do+  (ar,cls') <- scopeCheckFunClauses d+  let n' = A.mkExtName n+  return $ A.FunDecl co $ A.Fun ts n' ar cls'++mutualFlattenDecls :: [C.Declaration] -> ScopeCheck [C.Declaration]+mutualFlattenDecls ds = mapM mutualFlattenDecl ds >>= return . concat++mutualFlattenDecl :: C.Declaration -> ScopeCheck [C.Declaration]+mutualFlattenDecl (C.MutualDecl ds) = mutualFlattenDecls ds+mutualFlattenDecl (C.OverrideDecl Fail _) = throwErrorMsg $ "fail declaration not supported in mutual block"+mutualFlattenDecl (C.OverrideDecl o ds) = do+  ds' <- mutualFlattenDecls ds+  return $ map (\ d -> C.OverrideDecl o [d]) ds'+mutualFlattenDecl (C.LetDecl{}) = throwErrorMsg $ "let in mutual block not supported"+mutualFlattenDecl d = return $ [d]++-- extract type sigs of a mutual block in order, error on nested mutual+mutualGetTypeSig :: C.Declaration -> (IKind, C.TypeSig)+mutualGetTypeSig (C.DataDecl n sz co tel t cs fields) =+  (DataK, C.TypeSig n (C.teleToType tel t))+mutualGetTypeSig (C.FunDecl co tsig cls) =+  (FunK False, tsig) -- fun id for use inside defining body+mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel Nothing e)) =+  error $ "let declaration of " ++ show n ++ ": type required in mutual block"+mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel (Just t) e)) =+  (LetK, C.TypeSig n (C.teleToType tel t))+{- mutualGetTypeSig (C.LetDecl ev tsig e) =+  (LetK, tsig) -}+mutualGetTypeSig (C.OverrideDecl _ [d]) =+  mutualGetTypeSig d+++scopeCheckRecordDecl :: C.Name -> C.Telescope -> C.Type -> C.Constructor -> [C.Name] ->+  ScopeCheck A.Declaration+scopeCheckRecordDecl n tel t c cfields = enterShow n $ do+  setDefaultPolarity A.Param $ do+    tel <- generalizeTel tel+    -- STALE COMMENT: we do not infer at all: -- do not infer polarities in index arguments+    (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t)+    addANameU DataK n x+    let names = collectTelescopeNames tel+        target = C.App (C.ident n) (map C.ident names)  -- R pars+        (tel',t') = A.typeToTele' (length names) tt'+    c' <- scopeCheckConstructor n x (zipTels tel tel') A.CoInd target c+    let delta = contextFromConstructors c c'+    afields <- addFields ProjK delta cfields+    return $ A.RecordDecl x tel' t' c' afields++contextFromConstructors :: C.Constructor -> A.Constructor -> Context+contextFromConstructors (C.Constructor _ ctel0 mct) (A.Constructor _ _ at) = delta+  where ctel = maybe [] (fst . C.typeToTele) mct+        (atel, _) = A.typeToTele at+        delta = zipTels (ctel0 ++ ctel) atel++scopeCheckField :: Context -> C.Name -> ScopeCheck A.Name+scopeCheckField delta n =+  case lookup n delta of+    Nothing -> errorNotAField n+    Just x  -> return $ x++addFields :: IKind -> Context -> [C.Name] -> ScopeCheck [A.Name]+addFields kind delta cfields = do+    afields <- mapM (scopeCheckField delta) cfields+    mapM (uncurry $ addANameU kind) $ zip cfields afields+    return afields++scopeCheckDataDecl :: C.Declaration -> ScopeCheck A.Declaration+scopeCheckDataDecl decl@(C.DataDecl n sz co tel0 t cs fields) = enterShow n $ do+  setDefaultPolarity A.Param $ do+    tel <- generalizeTel tel0+    -- STALE: -- do not infer polarities in index arguments+    (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t)+    addANameU DataK n x+    checkDataBody tt' n x sz co tel cs fields++-- precondition: name already added to signature+checkDataBody :: A.Type -> C.Name -> A.Name -> Sized -> Co -> C.Telescope -> [C.Constructor] -> [C.Name] -> ScopeCheck A.Declaration+checkDataBody tt' n x sz co tel cs fields = do+      let cnames = collectTelescopeNames tel         -- parameters+          target = C.App (C.ident n) $ map C.ident cnames  -- D pars+          (tel',t') = A.typeToTele' (length cnames) tt'+      cs' <- mapM (scopeCheckConstructor n x (zipTels tel tel') co target) cs+{- NO LONGER INFER DESTRUCTORS+      -- traceM ("constructors: " ++ show cs')+--      when (t' == A.Sort A.Set && length cs' == 1) $ do+--      when (length cs' == 1) $ do  -- TOO STRICT, DOES NOT TREAT Vec right+      let cis = A.analyzeConstructors co n tel' cs'+      flip mapM_ cis $ \ ci -> when (A.cEtaExp ci) $ do+-- Add destructor names+        let fields = A.cFields ci -- A.classifyFields co n (A.typePart c)+        -- TODO Check for recursive occurrence!+        -- when (A.etaExpandable fields) $+        let destrNames =  A.destructorNames fields+        --when (not (null (destrNames))) $+        -- traceM ("fields: " ++ show fields)+        -- traceM ("destructors: " ++ show destrNames)+        mapM_ (addName (FunK True)) $ destrNames -- destructors are also upped+ {-+        let (ctel,_) = A.typeToTele (A.typePart (head cs'))+        let destrNames = map (\(_,x,_) -> x) ctel+        when (all (/= "") destrNames) $+          mapM_ (addName (FunK True)) destrNames -- destructors are also upped+-}+-}+      -- add declared destructor names+      let delta = concat $ map (uncurry contextFromConstructors) $ zip cs cs'+      -- fields <- addFields (LetK) delta fields+      -- 2012-01-26 register as projections+      fields <- addFields ProjK delta fields+      let pos = map (A.polarity . A.decor . A.boundDom) $ A.telescope tel'+      return $ A.DataDecl x sz co pos tel' t' cs' fields++-- check whether all declarations in mutual block are (co)funs+checkFunMutual :: Co -> [C.Declaration] -> ScopeCheck ()+checkFunMutual co [] = return ()+checkFunMutual co (C.FunDecl co' _ _:xl) | co == co' = checkFunMutual co xl+checkFunMutual _ _ = throwErrorMsg "mutual combination not supported"++scopeCheckFunDecls :: Co -> [C.Declaration] -> ScopeCheck A.Declaration+scopeCheckFunDecls co l = do+  -- check for uniformity of mutual block (all funs/all cofuns)+  checkFunMutual co l+  -- check signatures and look for measures+  r <- mapM (\ (C.FunDecl _ tysig _) -> scopeCheckFunSig tysig) l+  let (ml:mll, tsl') = unzip r+  let ok = all (ml==) mll+  when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length"+  -- add names as internal ids and check bodies+  let nxs = zipWith (\ (C.FunDecl _ (C.TypeSig n _) _) (A.TypeSig x _) -> (n,x)) l tsl'+  --let addFuns b = mapM (uncurry $ addAName $ FunK b) nxs+--  let addFuns b = mapM (\ (n,x) -> addAName (FunK b) n x) nxs+  -- addFuns False+  mapM (uncurry $ addANameU $ FunK False) nxs+  arcll' <- mapM (setDefaultPolarity A.Rec . scopeCheckFunClauses) l+  -- add names as external ids+  --addFuns True+  let nxs' = map (mapPair id A.mkExtName) nxs+  mapM (uncurry $ addANameU (LetK)) nxs'+--  mapM (uncurry $ addAName (FunK True)) nxs'+  return $ A.MutualFunDecl (isJust ml) co $+    zipWith3 (\ ts (_, x') (ar, cls) -> A.Fun ts x' ar cls) tsl' nxs' arcll'++-- | Does not add name to signature.+scopeCheckFunSig :: C.TypeSig -> ScopeCheck (Maybe Int, A.TypeSig)+scopeCheckFunSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do+    (ml, t') <- scopeCheckFunType t+    return (ml, A.TypeSig x t')++-- scope check type of mutual function, return length of measure (if present)+-- a fun type is a telescope followed by (maybe) a measure and a type expression+scopeCheckFunType :: C.Expr -> ScopeCheck (Maybe Int, A.Expr)+scopeCheckFunType t =+  case t of++      -- found a measure: continue normal scope checking+      C.Quant A.Pi [C.TMeasure mu] e1 -> do+        mu' <- scopeCheckMeasure mu+        e1' <- scopeCheckExprN e1+        return (Just $ length (measure mu'), A.pi (A.TMeasure mu') e1')++      -- bounds are allowed here, since we check a function type+      C.Quant A.Pi [C.TBound beta] e1 -> do+        beta'     <- scopeCheckBound beta+        (ml, e1') <- scopeCheckFunType e1+        return (ml, A.pi (A.TBound beta') e1')++      C.Quant A.Pi tel e -> do+        tel <- generalizeTel tel+        (tel, (ml, e)) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $+          scopeCheckTele tel $ setConstraintAllowed True $ scopeCheckFunType e+        ml' <- findMeasure tel+        ml <- case (ml,ml') of+                 (Nothing,ml') -> return ml'+                 (ml, Nothing) -> return ml+                 (Just{}, Just{}) -> errorOnlyOneMeasure+        return (ml, A.teleToType tel e)++      t -> (Nothing,) <$> scopeCheckExpr t -- no measure found++findMeasure :: A.Telescope -> ScopeCheck (Maybe Int)+findMeasure (A.Telescope tel) =+  case [ mu | A.TMeasure mu <- tel ] of+    []           -> return Nothing+    [Measure mu] -> return $ Just $ length mu+    _            -> errorOnlyOneMeasure++-- | Check whether concrete name is already in signature.+--   If yes, fail. If no, create abstract name and continue.+checkInSig :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a+checkInSig d n k = enterShow n $ do+  sig <- getSig+  case lookupSig (C.QName n) sig of+    Just _  -> errorAlreadyInSignature d n+    Nothing -> k (A.fresh $ C.theName n)++-- checkInSigU :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a+-- checkInSigU d n k = checkInSig d (C.QName n) (k . A.unqual)++scopeCheckFunClauses :: C.Declaration -> ScopeCheck (Arity, [A.Clause])+scopeCheckFunClauses (C.FunDecl _ (C.TypeSig n _) cl) = enterShow n $ do+  cl <- mapM (scopeCheckClause (Just n)) cl+  let m = if null cl then 0 else+       List.foldl1 min $ map (length . A.clPatterns) cl+  return (A.Arity m Nothing, cl)+{-+       let b = checkPatternLength cl+       case b of+          Just m  -> return $ (A.Arity m Nothing, cl)+          Nothing -> throwErrorMsg $ " pattern length differs"+-}++-- | Check the type of a signature and generate abstract name.+--   Does not add abstract name to signature.+scopeCheckTypeSig :: C.TypeSig -> ScopeCheck A.TypeSig+scopeCheckTypeSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do+    t' <- scopeCheckExpr t+    return $ A.TypeSig x t'++-- | Results:+--+--     @Nothing@            Not a function declaration.+--+--     @Just (n, Nothing)@  Unmeasured function.+--+--     @Just (n, Just m)@   Function with measure of length m+checkAndAddTypeSig :: (IKind, C.TypeSig) -> ScopeCheck (Maybe (C.Name, Maybe Int), A.TypeSig)+checkAndAddTypeSig (kind, ts@(C.TypeSig n _)) = do+  (mm, ts'@(A.TypeSig x _)) <-+    case kind of+      FunK _ -> mapPair (Just . (n,)) id <$> scopeCheckFunSig ts+{-+        do+        (mi, ts) <- scopeCheckFunSig ts+        return (Just mi, ts)+-}+      _ -> (Nothing,) <$> scopeCheckTypeSig ts+  addANameU kind n x  -- or: addTypeSig kind ts ts'+  return (mm, ts')++collectTelescopeNames :: C.Telescope -> [C.Name]+collectTelescopeNames = concat . map C.boundNames++-- | Check whether concrete name is already in signature.+--   If yes, fail. If no, create abstract name and continue.+checkConsInSig :: Show decl => decl -> C.Name -> A.Name -> IKind -> C.Name -> (A.QName -> ScopeCheck a) -> ScopeCheck a+checkConsInSig decl d dx ki n cont = enterShow n $ do+  -- first check whether the datatype has this constructor already+  ifJustM (lookupSig (C.Qual d n) <$> getSig) (const $ errorAlreadyInSignature decl n) $ do+  -- then check the overloaded name and possibly add it+  x <- overloadName ki n+  -- the qualified name is added in the continuation+  cont $ A.Qual dx x++-- | @cxt@ is the data telescope.+scopeCheckConstructor :: C.Name -> A.Name -> Context -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor+scopeCheckConstructor d dx cxt co t0 a@(C.Constructor n tel mt) = do+  let ki = ConK $ A.coToConK co+  checkConsInSig a d dx ki n $ \ x -> do++  let finish t mcxt = local (addContext $ maybe cxt id mcxt) $ do+       t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t+       t <- adjustTopDecsM defaultToParam t+       addAName ki (C.Qual d n) x+       let dummyDom = A.Domain A.Irr A.NoKind $ A.Dec Param+           mtel     = fmap (map (\ (n,x) -> A.TBind x dummyDom)) mcxt+           ps       = [] -- patterns computed during type checking+       return $ A.Constructor x (fmap ((,ps) . A.Telescope) mtel) t++  case mt of++    -- no target given, then add the data tel to the scope+    Nothing -> finish t0 Nothing++    -- target given, then the target binds the parameter names+    Just t -> do+      -- get the final target+      let (_, target) = C.typeToTele t++          fallback = finish t Nothing+          continue d' es = do+            -- unless (d == d') $ errorWrongTarget n d d'+            if (d /= d') then fallback else do+            -- get the parameters of target+            let (pars, inds) = splitAt (length cxt) es+            unless (length pars == length cxt) $ errorNotEnoughParameters n target+            -- if parameters are just data parameters, do it old style+            if and (zipWith isTelPar cxt pars) then fallback else do+            -- scopeCheck the parameters as patterns+            finish t . Just =<< parameterVariables pars++      case target of+        C.Ident (C.QName d')            -> continue d' []+        C.App (C.Ident (C.QName d')) es -> continue d' es+        _ -> fallback -- errorTargetMustBeAppliedName n target++{- OLD CODE+scopeCheckConstructor :: C.Telescope -> A.Telescope -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor+scopeCheckConstructor ctel atel co t0 a@(C.Constructor n tel mt) = addTel ctel atel $ checkInSig a n $ \ x -> do+    let t = maybe t0 id mt+    t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t+    t <- adjustTopDecsM defaultToParam t+    addAName (ConK $ A.coToConK co) n x+    return $ A.TypeSig x t+-}+  where isTelPar (c,_) (C.Ident (C.QName x)) = c == x+        isTelPar _     _                     = False+        defaultToParam dec = case (A.polarity dec) of+          A.Default -> return $ setPol A.Param dec+          A.Param   -> return dec+          A.Const   -> return dec+          A.PVar{}  -> return dec+          _         -> throwErrorMsg $ "illegal polarity " ++ show (polarity dec) ++ " in type of constructor " ++ show a++-- | Allow shadowing of previous locals.+--   Always if we enter a subexpression which is not the body+--   of a binder.+scopeCheckExprN :: C.Expr -> ScopeCheck A.Expr+scopeCheckExprN = newLevel . scopeCheckExpr++scopeCheckExpr :: C.Expr -> ScopeCheck A.Expr+scopeCheckExpr e = setConstraintAllowed False $ scopeCheckExpr' e++scopeCheckExpr' :: C.Expr -> ScopeCheck A.Expr+scopeCheckExpr' e =+    case e of+      -- replace underscore by next meta-variable+      C.Unknown -> nextMVar (return . A.Meta)+      C.Set   e -> A.Sort . A.Set   <$> scopeCheckExprN e+      C.CoSet e -> A.Sort . A.CoSet <$> scopeCheckExprN e+      C.Size    -> return $ A.Sort (A.SortC A.Size)+      C.Succ e1 -> A.Succ <$> scopeCheckExprN e1+      C.Zero    -> return A.Zero+      C.Infty   -> return A.Infty+      C.Plus e1 e2 -> do+        e1 <- scopeCheckExprN e1+        e2 <- scopeCheckExprN e2+        return $ A.Plus [e1, e2]+      C.Pair e1 e2   -> A.Pair <$> scopeCheckExprN e1 <*> scopeCheckExprN e2+      C.Sing e1 et   -> A.Sing <$> scopeCheckExprN e1 <*> scopeCheckExprN et+      C.App C.Max el -> do+        el' <- mapM scopeCheckExprN el+        when (length el' < 2) $ throwErrorMsg "max expects at least 2 arguments"+        return $ A.Max el'+      C.App e1 el -> foldl A.App <$> scopeCheckExprN e1 <*> mapM scopeCheckExprN el+      C.Case e mt cl -> do+        e'  <- scopeCheckExprN e+        mt' <- mapM scopeCheckExprN mt+        cl' <- mapM (scopeCheckClause Nothing) cl+        return $ A.Case e' mt' cl'++      -- measure & bound+      -- measures can only appear in fun sigs!+      C.Quant pisig [C.TMeasure mu] e1 -> do+        throwErrorMsg $ "measure not allowed in expression " ++ show e++      -- measure bound mu < mu'+      C.Quant A.Pi [C.TBound beta] e1 -> do+        unlessM (asks constraintAllowed) $ errorConstraintNotAllowed beta+        beta' <- scopeCheckBound beta+        e1'   <- scopeCheckExpr' e1+        return $ A.pi (A.TBound beta') e1'++      C.Quant A.Sigma [C.TBound beta] e1 -> throwErrorMsg $+        "measure bound not allowed in expression " ++ show e++      C.Quant pisig tel e -> do+        tel <- generalizeTel tel+        pol <- asks defaultPolarity+        (A.Telescope tel, e) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $ scopeCheckTele tel $+           setDefaultPolarity pol $ scopeCheckExpr' e+        return $ quant pisig tel e where+--          quant A.Sigma [tb] = A.Quant A.Sigma tb+          quant A.Sigma tel e = foldr (A.Quant A.Sigma) e tel+          quant A.Pi    tel e = A.teleToType (A.Telescope tel) e++      C.Lam n e1 -> do+        (n, e1') <- addBind e n $ scopeCheckExpr e1+        return $ A.Lam A.defaultDec n e1' -- dec. in Lam is ignored in t.c.++      C.LLet letdef e2 -> do+        let dec = C.letDefDec letdef+        (tel, mt, e1) <- scopeCheckLetDef letdef+        (x, e2) <- addBind e (C.letDefName letdef) $ scopeCheckExpr e2+        return $ A.LLet (A.TBind x $ A.Domain mt A.defaultKind dec) tel e1 e2++      C.Record rs -> do+        let fields = map fst rs+        if (hasDuplicate fields) then (errorDuplicateField e) else do+          rs <- mapM scopeCheckRecordLine rs+          return $ A.Record A.AnonRec rs++      C.Proj n -> A.Proj Post <$> scopeCheckProj n++      C.Ident n@C.Qual{} -> scopeCheckGlobalVar n++      C.Ident n@C.QName{} -> do+        res <- lookupLocal (C.name n)+        case res of+          Just x -> return $ A.Var x+          Nothing -> scopeCheckGlobalVar n++      _ -> throwErrorMsg $ "NYI: scopeCheckExpr " ++ show e++scopeCheckGlobalVar :: C.QName -> ScopeCheck A.Expr+scopeCheckGlobalVar n = do+  res <- lookupGlobal n+  case res of+    Just (DefI k x) -> case k of+      (ConK co)  -> return $ A.con co x+      LetK       -> return $ A.letdef (A.unqual x)+      -- references to recursive functions are coded differently+      -- outside the mutual block+      FunK True  -> return $ A.fun x -- A.letdef x -- A.mkExtRef x+      FunK False -> return $ A.fun x+      DataK      -> return $ A.dat x+      ProjK      -> return $ A.Proj A.Pre (A.unqual x) -- errorProjectionUsedAsExpression n+    Nothing -> errorIdentifierUndefined n++scopeCheckLocalVar :: C.Name -> ScopeCheck A.Name+scopeCheckLocalVar n = maybe (errorIdentifierUndefined n) return =<< do+  lookupLocal n++scopeCheckRecordLine :: ([C.Name], C.Expr) -> ScopeCheck (A.Name, A.Expr)+scopeCheckRecordLine (n : ns, e) = do+  x <- scopeCheckProj n+  (x,) <$> scopeCheckExprN (foldr C.Lam e ns)++scopeCheckProj :: C.Name -> ScopeCheck A.Name+scopeCheckProj n = do+  sig <- getSig+  case lookupSigU n sig of+    Just (DefI ProjK x) -> return $ A.unqual x+    _                   -> errorNotAField n+++-- | @isProjIdent n = n@ if defined and the name of a projection.+isProjIdent :: C.QName -> ScopeCheck (Maybe A.Name)+isProjIdent n = do+  sig <- getSig+  return $+    case lookupSig n sig of+      Just (DefI ProjK x) -> Just $ A.unqual x+      _ -> Nothing++isProjection :: C.Expr -> ScopeCheck (Maybe A.Name)+isProjection (C.Ident n) = isProjIdent n+isProjection _           = return Nothing++scopeCheckMeasure :: A.Measure C.Expr -> ScopeCheck (A.Measure A.Expr)+scopeCheckMeasure (A.Measure es) = do+  es' <- mapM scopeCheckExprN es+  return $ A.Measure es'++scopeCheckBound :: A.Bound C.Expr -> ScopeCheck (A.Bound A.Expr)+scopeCheckBound (A.Bound ltle e1 e2) = do+  [e1',e2'] <- mapM scopeCheckMeasure [e1,e2]+  return $ A.Bound ltle e1' e2'++checkPatternLength :: [C.Clause] -> Maybe Int+checkPatternLength [] = Just 0 -- arity 0+checkPatternLength (C.Clause _ pl _:cl) = cpl (length pl) cl+ where+   cpl k [] = Just k+   cpl k (C.Clause _ pl _ : cl) = if (length pl == k) then (cpl k cl) else Nothing++scopeCheckClause :: Maybe C.Name -> C.Clause -> ScopeCheck A.Clause+scopeCheckClause mname' (C.Clause mname pl mrhs) = do+  when (mname /= mname') $ errorClauseIdentifier mname mname'+  (pl, delta) <- runStateT (mapM scopeCheckPattern pl) emptyCtx+  local (addContext delta) $ do+    pl <- mapM scopeCheckDotPattern pl+    case mrhs of+      Nothing  -> return $ A.clause pl Nothing+      Just rhs -> A.clause pl . Just <$> scopeCheckExprN rhs+++type PatCtx = Context+type SPS = StateT PatCtx ScopeCheck++scopeCheckPatVar :: C.QName -> SPS (A.Pat C.Expr)+scopeCheckPatVar n = do+      sig <- lift $ getSig+      case lookupSig n sig of+        Just (DefI (ConK co) n) -> return $ A.ConP (A.PatternInfo co False False) n []+                             -- a nullary constructor+        Just _  -> errorPatternNotConstructor n+        Nothing -> A.VarP <$> addUnique (C.unqual n)++scopeCheckPattern :: C.Pattern -> SPS (A.Pat C.Expr)+scopeCheckPattern p =+  case p of++    -- case n+    C.IdentP n        -> scopeCheckPatVar n+    C.ConP False n [] -> scopeCheckPatVar n++    -- case (i > j):+    C.SizeP m n -> do+      -- m   <- lift $ scopeCheckLocalVar m+      A.SizeP m <$> addUnique n++    -- case $p+    C.SuccP p2    -> A.SuccP <$> scopeCheckPattern p2++    -- case (p1,p2)+    C.PairP p1 p2 -> A.PairP <$> scopeCheckPattern p1 <*> scopeCheckPattern p2++    -- case .n+    C.ConP True n [] -> do+      -- try projection+      ifJustM (lift $ isProjIdent n) (return . A.ProjP) $ do+      -- try constructor+      sig <- lift $ getSig+      case lookupSig n sig of+        Just (DefI (ConK co) n) ->+              return $ A.ConP (A.PatternInfo co False True) n []+      -- fallback: dot pattern+        _  -> return $ A.DotP (C.Ident n)++    -- case [.]c ps+    C.ConP dotted n pl -> do+      sig <- lift $ getSig+      case lookupSig n sig of+        Just (DefI (ConK co) x) ->+          A.ConP (A.PatternInfo co False dotted) x <$> mapM scopeCheckPattern pl+        _  -> errorPatternNotConstructor n++    -- case .e+    C.DotP e  -> do+      isProj <- lift $ isProjection e+      case isProj of+       Just n  -> return $ A.ProjP n+       Nothing -> return $ A.DotP e -- dot patterns checked later++    -- case ()+    C.AbsurdP -> return $ A.AbsurdP++-- | Add pattern variable to pattern context, must not be present yet.+addUnique :: C.Name -> SPS A.Name+addUnique = addPatVar True++addNonUnique :: C.Name -> SPS A.Name+addNonUnique = addPatVar False++addPatVar :: Bool -> C.Name -> SPS A.Name+addPatVar linear n = do+  delta <- get+  case retrieve n delta of+    Just x -> if linear then errorPatternNotLinear n else return x+    Nothing -> do+      let (x, delta') = newLocal n delta+      put delta'+      return x++scopeCheckDotPattern :: A.Pat C.Expr -> ScopeCheck A.Pattern+scopeCheckDotPattern p =+    case p of+      A.DotP e -> A.DotP <$> scopeCheckExprN e+      A.PairP p1 p2 -> A.PairP <$> scopeCheckDotPattern p1 <*>  scopeCheckDotPattern p2+      A.SuccP p -> A.SuccP <$> scopeCheckDotPattern p+      A.ConP co n pl -> A.ConP co n <$> mapM scopeCheckDotPattern pl+--      A.SizeP m n -> flip A.SizeP n <$> scopeCheckLocalVar m -- return $ A.SizeP m n+      A.SizeP e n    -> flip A.SizeP n <$> scopeCheckExprN e+      A.VarP n       -> return $ A.VarP n  -- even though p = A.VarP n, it has wrong type!!+      A.ProjP n      -> return $ A.ProjP n+      A.AbsurdP      -> return $ A.AbsurdP+      -- impossible cases: ErasedP, UnusableP+++-- * Scope checking parameters++parameterVariables :: [C.Expr] -> ScopeCheck Context+parameterVariables es = do+  execStateT (mapM_ scopeCheckParameter es) emptyCtx++-- | Extract variables bound by data parameters.+--   We consider a more liberal set of patterns, everything+--   that is injective and does not bind variables.+scopeCheckParameter :: C.Expr -> SPS ()+scopeCheckParameter e =+  case e of+    C.Set e'             -> scopeCheckParameter e'+    C.CoSet e'           -> scopeCheckParameter e'+    C.Size               -> return ()+    C.Succ e'            -> scopeCheckParameter e'+    C.Zero               -> return ()+    C.Infty              -> return ()+    C.Pair e1 e2         -> scopeCheckParameter e1 >> scopeCheckParameter e2+    C.Record fs          -> mapM_ (scpField e) fs+    C.Ident n            -> scpApp e n []+    C.App (C.Ident n) es -> scpApp e n es+    C.App C.App{} es     -> throwErrorMsg $ "scopeCheckParameter " ++ show e ++ ": internal invariant violated"+    _ -> errorInvalidParameter e+  where+    -- we can only treat a record expression as pattern+    -- if it does not bind any variables+    scpField :: C.Expr -> ([C.Name], C.Expr) -> SPS ()+    scpField e ([f], e') = scopeCheckParameter e'+    scpField e _         = errorInvalidParameter e++    scpApp :: C.Expr -> C.QName -> [C.Expr] -> SPS ()+    scpApp e n es = do+      sig <- lift $ getSig+      case lookupSig n sig of+        Just (DefI ConK{} n) -> mapM_ scopeCheckParameter es+        Just (DefI DataK  n) -> mapM_ scopeCheckParameter es+        Just _  -> errorInvalidParameter e+        Nothing -> void $ addNonUnique (C.unqual n) -- allow non-linearity++-- * Scope checking errors++errorAlreadyInSignature s n = throwErrorMsg $ show s  ++ ": Identifier " ++ show n ++ " already in signature"++errorAlreadyInContext s n = throwErrorMsg $ show s ++ ": Identifier " ++ show n ++ " already in context"++-- errorPatternNotVariable n = throwErrorMsg $ "pattern " ++ n ++ ": Identifier expected"++errorPatternNotConstructor n = throwErrorMsg $ "pattern " ++ show n ++ " is not a constructor"++errorNotAField n = throwErrorMsg $ "record field " ++ show n ++ " unknown"+-- errorUnknownProjection n = throwErrorMsg $ "projection " ++ n ++ " unknown"++errorDuplicateField r = throwErrorMsg $ show r ++ " assigns a field twice"+++errorProjectionUsedAsExpression n = throwErrorMsg $ "projection " ++ show n ++ " used as expression"++errorIdentifierUndefined n = throwErrorMsg $ "Identifier " ++ show n ++ " undefined"++errorPatternNotLinear n = throwErrorMsg $ "pattern not linear: " ++ show n++errorClauseIdentifier (Just n) (Just n') = throwErrorMsg $ "Expected identifier " ++ show n' ++ " as clause head, found " ++ show n++errorOnlyOneMeasure = throwErrorMsg "only one measure allowed in a function type"++errorConstraintNotAllowed beta = throwErrorMsg $+  show beta ++ ": constraints must follow a quantifier"++errorTargetMustBeAppliedName n t = throwErrorMsg $+  "constructor " ++ show n ++ ": target must be data/record type applied to parameters and indices; however, I found " ++ show t++errorWrongTarget c d d' = throwErrorMsg $+  "constructor " ++ show c ++ " should target data/record type " ++ show d ++ "; however, I found " ++ show d'++errorNotEnoughParameters c t = throwErrorMsg $+  "constructor " ++ show c ++ ": target " ++ show t ++ " is missing parameters"++errorInvalidParameter e = throwErrorMsg $+  "expression " ++ show e ++ " is not valid in a parameter"
+ src/Semiring.hs view
@@ -0,0 +1,101 @@+-- {-# LANGUAGE UndecidableInstances #-}++-- | Semirings.  Original: Agda.Terminatio.Semiring++module Semiring+  ( HasZero(..), SemiRing(..)+  , Semiring(..)+--  , semiringInvariant+  , integerSemiring+  , boolSemiring+  ) where++import Data.Monoid+++{- | SemiRing type class.  Additive monoid with multiplication operation.+Inherit addition and zero from Monoid. -}++class (Eq a, Monoid a) => SemiRing a where+--  isZero   :: a -> Bool+  multiply :: a -> a -> a+++-- | @HasZero@ is needed for sparse matrices, to tell which is the element+--   that does not have to be stored.+--   It is a cut-down version of @SemiRing@ which is definable+--   without the implicit @?cutoff@.+class Eq a => HasZero a where+  zeroElement :: a++-- | Semirings.++data Semiring a+  = Semiring { add  :: a -> a -> a  -- ^ Addition.+             , mul  :: a -> a -> a  -- ^ Multiplication.+             , zero :: a            -- ^ Zero.+-- The one is never used in matrix multiplication+--             , one  :: a            -- ^ One.+             }++-- | Semiring invariant.++-- I think it's OK to use the same x, y, z triple for all the+-- properties below.++{-+semiringInvariant :: (Arbitrary a, Eq a, Show a)+                  => Semiring a+                  -> a -> a -> a -> Bool+semiringInvariant (Semiring { add = (+), mul = (*)+                            , zero = zero --, one = one+                            }) = \x y z ->+  associative (+)           x y z &&+  identity zero (+)         x     &&+  commutative (+)           x y   &&+  associative (*)           x y z &&+--  identity one (*)          x     &&+  leftDistributive (*) (+)  x y z &&+  rightDistributive (*) (+) x y z &&+  isZero zero (*)           x+-}++------------------------------------------------------------------------+-- Specific semirings++-- | The standard semiring on 'Integer's.++instance HasZero Integer where+  zeroElement = 0++instance Monoid Integer where+  mempty = 0+  mappend = (+)++instance SemiRing Integer where+  multiply = (*)+++integerSemiring :: Semiring Integer+integerSemiring = Semiring { add = (+), mul = (*), zero = 0 } -- , one = 1 }++-- prop_integerSemiring = semiringInvariant integerSemiring++-- | The standard semiring on 'Bool's.++boolSemiring :: Semiring Bool+boolSemiring =+  Semiring { add = (||), mul = (&&), zero = False } --, one = True }++-- prop_boolSemiring = semiringInvariant boolSemiring++------------------------------------------------------------------------+-- All tests++{-+tests :: IO Bool+tests = runTests "Agda.Termination.Semiring"+  [ quickCheck' prop_integerSemiring+  , quickCheck' prop_boolSemiring+  ]+-}
+ src/SparseMatrix.hs view
@@ -0,0 +1,459 @@+{- | Sparse matrices.  Original: Agda.Termination.SparseMatrix++We assume the matrices to be very sparse, so we just implement them as+sorted association lists.++ -}++module SparseMatrix+  ( -- * Basic data types+    Matrix(M)+  , matrixInvariant+  , Size(..)+  , sizeInvariant+  , MIx (..)+  , mIxInvariant+    -- * Generating and creating matrices+  , fromLists+  , fromIndexList+  , toLists+--  , matrix+--  , matrixUsingRowGen+    -- * Combining and querying matrices+  , size+  , square+  , isEmpty+  , isSingleton+  , SparseMatrix.all, SparseMatrix.any+  , add, intersectWith, SparseMatrix.zip+  , mul+  , transpose+  , diagonal+    -- * Modifying matrices+  , addRow+  , addColumn+    -- * Tests+  ) where++import Data.Array+import qualified Data.List as List+import Data.Monoid++-- import Test.QuickCheck++import Semiring (HasZero(..), SemiRing, Semiring)+import qualified Semiring as Semiring++++------------------------------------------------------------------------+-- Basic data types++-- | This matrix type is used for tests.++type TM = Matrix Integer Integer++-- | Size of a matrix.++data Size i = Size { rows :: i, cols :: i }+  deriving (Eq, Ord, Show)++sizeInvariant :: (Ord i, Num i) => Size i -> Bool+sizeInvariant sz = rows sz >= 0 && cols sz >= 0++{-+instance (Arbitrary i, Integral i) => Arbitrary (Size i) where+  arbitrary = do+    r <- natural+    c <- natural+    return $ Size { rows = fromInteger r, cols = fromInteger c }++instance CoArbitrary i => CoArbitrary (Size i) where+  coarbitrary (Size rs cs) = coarbitrary rs . coarbitrary cs++prop_Arbitrary_Size :: Size Integer -> Bool+prop_Arbitrary_Size = sizeInvariant+-}++-- | Converts a size to a set of bounds suitable for use with+-- the matrices in this module.++toBounds :: Num i => Size i -> (MIx i, MIx i)+toBounds sz = (MIx { row = 1, col = 1 }, MIx { row = rows sz, col = cols sz })++-- | Type of matrix indices (row, column).++data MIx i = MIx { row, col :: i }+  deriving (Eq, Show, Ix, Ord)++{-+instance (Arbitrary i, Integral i) => Arbitrary (MIx i) where+  arbitrary = do+    r <- positive+    c <- positive+    return $ MIx { row = r, col = c }++instance CoArbitrary i => CoArbitrary (MIx i) where+  coarbitrary (MIx r c) = coarbitrary r . coarbitrary c+-}++-- | No nonpositive indices are allowed.++mIxInvariant :: (Ord i, Num i) => MIx i -> Bool+mIxInvariant i = row i >= 1 && col i >= 1++prop_Arbitrary_MIx :: MIx Integer -> Bool+prop_Arbitrary_MIx = mIxInvariant++-- | Type of matrices, parameterised on the type of values.++data Matrix i b = M { size :: Size i, unM :: [(MIx i, b)] }+  deriving (Ord)++instance (Ord i, Eq a, HasZero a) => Eq (Matrix i a) where+  m1 == m2 = size m1 == size m2 && +    SparseMatrix.all (uncurry (==)) (SparseMatrix.zip m1 m2)++instance Functor (Matrix i) where+  fmap f (M sz m) = M sz (map (\ (i,a) -> (i, f a)) m)++matrixInvariant :: (Num i, Ix i) => Matrix i b -> Bool+matrixInvariant m = List.all (\ (MIx i j, b) -> 1 <= i && i <= rows sz+                                             && 1 <= j && j <= cols sz) (unM m)+  && strictlySorted (MIx 0 0) (unM m)+  && sizeInvariant sz+  where sz = size m++-- matrix indices are lexicographically sorted with no duplicates+-- Ord MIx should be the lexicographic one already (Haskell report)++strictlySorted :: (Ord i) => i -> [(i, b)] -> Bool+strictlySorted i [] = True+strictlySorted i ((i', b) : l) = i < i' && strictlySorted i' l+{-+strictlySorted (MIx i j) [] = True+strictlySorted (MIx i j) ((MIx i' j', b) : l) =+  (i < i' || i == i' &&  j < j' ) && strictlySorted (MIx i' j') b+-}++instance (Ord i, Integral i, Enum i, Show i, Show b, HasZero b) => Show (Matrix i b) where+  showsPrec _ m =+    showString "SparseMatrix.fromLists " . shows (size m) .+    showString " " . shows (toLists m)++{-+instance (Integral i, HasZero b, Pretty b) =>+         Pretty (Matrix i b) where+  pretty = vcat . map (hsep . map pretty) . toLists++instance (Arbitrary i, Num i, Integral i, Arbitrary b, HasZero b)+         => Arbitrary (Matrix i b) where+  arbitrary     = matrix =<< arbitrary++instance (Ord i, Integral i, Enum i, CoArbitrary b, HasZero b) => CoArbitrary (Matrix i b) where+  coarbitrary m = coarbitrary (toLists m)+++prop_Arbitrary_Matrix :: TM -> Bool+prop_Arbitrary_Matrix = matrixInvariant+-}++------------------------------------------------------------------------+-- Generating and creating matrices++-- | Generates a matrix of the given size, using the given generator+-- to generate the rows.++{-+matrixUsingRowGen :: (Arbitrary i, Integral i, Arbitrary b, HasZero b)+  => Size i+  -> (i -> Gen [b])+     -- ^ The generator is parameterised on the size of the row.+  -> Gen (Matrix i b)+matrixUsingRowGen sz rowGen = do+  rows <- vectorOf (fromIntegral $ rows sz) (rowGen $ cols sz)+  return $ fromLists sz rows+-}++-- | Generates a matrix of the given size.++{-+matrix :: (Arbitrary i, Integral i, Arbitrary b, HasZero b)+  => Size i -> Gen (Matrix i b)+matrix sz = matrixUsingRowGen sz (\n -> vectorOf (fromIntegral n) arbitrary)++prop_matrix sz = forAll (matrix sz :: Gen TM) $ \m ->+--  matrixInvariant m &&+  size m == sz+-}++-- | Constructs a matrix from a list of (index, value)-pairs.++-- compareElt = (\ (i,_) (j,_) -> compare i j)+-- normalize = filter (\ (i,b) -> b /= zeroElement)++fromIndexList :: (Ord i, HasZero b) => Size i -> [(MIx i, b)] -> Matrix i b+fromIndexList sz = M sz . List.sortBy (\ (i,_) (j,_) -> compare i j) . filter (\ (i,b) -> b /= zeroElement)++prop_fromIndexList :: TM -> Bool+prop_fromIndexList m = matrixInvariant m' && m' == m+  where vs = unM m+        m' = fromIndexList (size m) vs++-- | @'fromLists' sz rs@ constructs a matrix from a list of lists of+-- values (a list of rows).+--+-- Precondition: @'length' rs '==' 'rows' sz '&&' 'all' (('==' 'cols' sz) . 'length') rs@.++fromLists :: (Ord i, Num i, Enum i, HasZero b) => Size i -> [[b]] -> Matrix i b+fromLists sz bs = fromIndexList sz $ +  List.zip ([ MIx i j | i <- [1..rows sz] , j <- [1..cols sz]]) (concat bs)++-- | Converts a sparse matrix to a sparse list of rows++toSparseRows :: (Num i, Enum i, Eq i) => Matrix i b -> [(i,[(i,b)])]+toSparseRows m = aux 1 [] (unM m)+  where aux i' [] []  = []+        aux i' row [] = [(i', reverse row)]+        aux i' row ((MIx i j, b) : m)+            | i' == i   = aux i' ((j,b):row) m+            | otherwise = (i', reverse row) : aux i [(j,b)] m++-- sparse vectors cannot have two entries in one column+blowUpSparseVec :: (Eq i, Ord i, Num i, Enum i, Show i) => b -> i -> [(i,b)] -> [b]+blowUpSparseVec zero n l = aux 1 l+  where aux i [] | i > n = []+                 | otherwise = zero : aux (i+1) []+        aux i ((j,b):l) | i <= n && j == i = b : aux (succ i) l+        aux i ((j,b):l) | i <= n && j >= i = zero : aux (succ i) ((j,b):l)+        aux i l = error $ "blowUpSparseVec (n = " ++ show n ++ ") aux i=" ++ show i ++ " j=" ++ show (fst (head l)) ++ " length l = " ++ show (length l)+-- __IMPOSSIBLE__++-- | Converts a matrix to a list of row lists.++toLists :: (Ord i, Integral i, Enum i, HasZero b, Show i) => Matrix i b -> [[b]]+toLists m = blowUpSparseVec emptyRow (rows sz) $+    map (\ (i,r) -> (i, blowUpSparseVec zeroElement (cols sz) r)) $ toSparseRows m+--            [ [ maybe zeroElement id $ lookup (MIx { row = r, col = c }) (unM m)+--            | c <- [1 .. cols sz] ] | r <- [1 .. rows sz] ]+  where sz = size m+        emptyRow = take (fromIntegral (cols sz)) $ repeat zeroElement++prop_fromLists_toLists :: TM -> Bool+prop_fromLists_toLists m = fromLists (size m) (toLists m) == m++------------------------------------------------------------------------+-- Combining and querying matrices++-- | The size of a matrix.++{-+size :: Ix i => Matrix i b -> Size i+size m = Size { rows = row b, cols = col b }+  where (_, b) = bounds $ unM m+-}++prop_size :: TM -> Bool+prop_size m = sizeInvariant (size m)+++prop_size_fromIndexList :: Size Int -> Bool+prop_size_fromIndexList sz =+  size (fromIndexList sz ([] :: [(MIx Int, Integer)])) == sz++-- | 'True' iff the matrix is square.++square :: Ix i => Matrix i b -> Bool+square m = rows (size m) == cols (size m)++-- | Returns 'True' iff the matrix is empty.++isEmpty :: (Num i, Ix i) => Matrix i b -> Bool+isEmpty m = rows sz <= 0 || cols sz <= 0+  where sz = size m++-- | Returns 'Just b' iff it is a 1x1 matrix with just one entry 'b'.++isSingleton :: (Num i, Ix i, HasZero b) => Matrix i b -> Maybe b+isSingleton m = if (rows sz == 1 || cols sz == 1) then+    case unM m of+      [(_,b)] -> Just b+      []      -> Just zeroElement+  else Nothing+  where sz = size m++-- | Transposition+transposeSize (Size { rows = n, cols = m }) = Size { rows = m, cols = n }+transpose m = M { size = transposeSize (size m)+                , unM  = List.sortBy (\ (i,a) (j,b) -> compare i j) $+                           map (\(MIx i j, b) -> (MIx j i, b)) $ unM m }++all :: (a -> Bool) -> Matrix i a -> Bool+all p m = List.all (\ (i,a) -> p a) (unM m)++any :: (a -> Bool) -> Matrix i a -> Bool+any p m = List.any (\ (i,a) -> p a) (unM m)++-- | @'zip' m1 m2@ zips @m1@ and @m2@. +--+-- Precondition: @'size' m1 == 'size' m2@.++zip :: (Ord i, HasZero a) => Matrix i a -> Matrix i a -> Matrix i (a,a)+zip m1 m2 = M (size m1) $ zips (unM m1) (unM m2) where+  zips [] m = map (\ (i,b) -> (i,(zeroElement,b))) m+  zips l [] = map (\ (i,a) -> (i,(a,zeroElement))) l+  zips l@((i,a):l') m@((j,b):m')+    | i < j = (i,(a,zeroElement)) : zips l' m+    | i > j = (j,(zeroElement,b)) : zips l m'+    | otherwise = (i,(a,b)) : zips l' m'++-- | @'add' (+) m1 m2@ adds @m1@ and @m2@. Uses @(+)@ to add values.+--+-- Precondition: @'size' m1 == 'size' m2@.++add :: (Ord i) => (a -> a -> a) -> Matrix i a -> Matrix i a -> Matrix i a+add plus m1 m2 = M (size m1) $ mergeAssocWith plus (unM m1) (unM m2)++-- | assoc list union+mergeAssocWith :: (Ord i) => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)]+mergeAssocWith f [] m = m+mergeAssocWith f l [] = l+mergeAssocWith f l@((i,a):l') m@((j,b):m')+    | i < j = (i,a) : mergeAssocWith f l' m+    | i > j = (j,b) : mergeAssocWith f l m'+    | otherwise = (i, f a b) : mergeAssocWith f l' m'++-- | @'intersectWith' f m1 m2@ build the pointwise conjunction @m1@ and @m2@.+--   Uses @f@ to combine non-zero values.+--+-- Precondition: @'size' m1 == 'size' m2@.++intersectWith :: (Ord i) => (a -> a -> a) -> Matrix i a -> Matrix i a -> Matrix i a+intersectWith f m1 m2 = M (size m1) $ interAssocWith f (unM m1) (unM m2)++-- | assoc list intersection+interAssocWith :: (Ord i) => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)]+interAssocWith f [] m = []+interAssocWith f l [] = []+interAssocWith f l@((i,a):l') m@((j,b):m')+    | i < j = interAssocWith f l' m+    | i > j = interAssocWith f l m'+    | otherwise = (i, f a b) : interAssocWith f l' m'++{-+prop_add sz =+  forAll (three (matrix sz :: Gen TM)) $ \(m1, m2, m3) ->+    let m' = add (+) m1 m2 in+      associative (add (+)) m1 m2 m3 &&+      commutative (add (+)) m1 m2 &&+      matrixInvariant m' &&+      size m' == size m1+-}++-- | @'mul' semiring m1 m2@ multiplies @m1@ and @m2@. Uses the+-- operations of the semiring @semiring@ to perform the+-- multiplication.+--+-- Precondition: @'cols' ('size' m1) == rows ('size' m2)@.++{- mul A B works as follows:+* turn A into a list of sparse rows and the transposed B as well+* form the crossproduct using the inner vector product to compute els+* the inner vector product is summing up+  after intersecting with the muliplication op of the semiring+-}++mul :: (Enum i, Num i, Ix i, Eq a)+    => Semiring a -> Matrix i a -> Matrix i a -> Matrix i a+mul semiring m1 m2 = M (Size { rows = rows (size m1), cols = cols (size m2) }) $+  filter (\ (i,b) -> b /= Semiring.zero semiring) $+  [ (MIx i j, foldl (Semiring.add semiring) (Semiring.zero semiring) $+                map snd $ interAssocWith (Semiring.mul semiring) v w)+    | (i,v) <- toSparseRows m1+    , (j,w) <- toSparseRows $ transpose m2 ]++{-+prop_mul sz =+  sized $ \n -> resize (n `div` 2) $+  forAll (two natural) $ \(c2, c3) ->+  forAll (matrix sz :: Gen TM) $ \m1 ->+  forAll (matrix (Size { rows = cols sz, cols = c2 })) $ \m2 ->+  forAll (matrix (Size { rows = c2, cols = c3 })) $ \m3 ->+    let m' = mult m1 m2 in+      associative mult m1 m2 m3 &&+      matrixInvariant m' &&+      size m' == Size { rows = rows sz, cols = c2 }+  where mult = mul Semiring.integerSemiring+-}++-- | @'diagonal' m@ extracts the diagonal of @m@.+--+-- Precondition: @'square' m@.++diagonal :: (Enum i, Num i, Ix i, Show i, HasZero b) => Matrix i b -> [b]+diagonal m = blowUpSparseVec zeroElement (rows sz) $+  map (\ ((MIx i j),b) -> (i,b)) $ filter (\ ((MIx i j),b) -> i==j) (unM m)+  where sz = size m++{-+diagonal :: (Enum i, Num i, Ix i, HasZero b) => Matrix i b -> Array i b+diagonal m = listArray (1, rows sz) $ blowUpSparseVec zeroElement (rows sz) $+  map (\ ((MIx i j),b) -> (i,b)) $ filter (\ ((MIx i j),b) -> i==j) (unM m)+  where sz = size m+-}++{-+prop_diagonal =+  forAll natural $ \n ->+  forAll (matrix (Size n n) :: Gen TM) $ \m ->+    bounds (diagonal m) == (1, n)+-}++------------------------------------------------------------------------+-- Modifying matrices++-- | @'addColumn' x m@ adds a new column to @m@, after the columns+-- already existing in the matrix. All elements in the new column get+-- set to @x@.++addColumn :: (Num i, HasZero b) => b -> Matrix i b -> Matrix i b+addColumn x m | x == zeroElement = m { size = (size m) { cols = cols (size m) + 1 }}+--              | otherwise = __IMPOSSIBLE__++{-+prop_addColumn :: TM -> Bool+prop_addColumn m =+  matrixInvariant m'+  &&+  map init (toLists m') == toLists m+  where+  m' = addColumn zeroElement m+-}++-- | @'addRow' x m@ adds a new row to @m@, after the rows already+-- existing in the matrix. All elements in the new row get set to @x@.++addRow :: (Num i, HasZero b) => b -> Matrix i b -> Matrix i b+addRow x m | x == zeroElement = m { size = (size m) { rows = rows (size m) + 1 }}+--           | otherwise = __IMPOSSIBLE__++prop_addRow :: TM -> Bool+prop_addRow m =+  matrixInvariant m'+  &&+  init (toLists m') == toLists m+  where+  m' = addRow zeroElement m++------------------------------------------------------------------------+-- Zipping (assumes non-empty matrices)++{- use mergeAssocList or interAssocList instead+zipWith :: (a -> b -> c) ->+           Matrix Integer a -> Matrix Integer b -> Matrix Integer c+zipWith f m1 m2+  = fromLists (Size { rows = toInteger $ length ll,+                      cols = toInteger $ length (head ll) }) ll+    where ll = List.zipWith (List.zipWith f) (toLists m1) (toLists m2)+-}+
+ src/TCM.hs view
@@ -0,0 +1,1494 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, PatternGuards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, DeriveFoldable, DeriveTraversable, TupleSections #-}++module TCM where++import Prelude hiding (null)++import Control.Monad+import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Reader++import Control.Applicative+import Data.Foldable (Foldable)+import qualified Data.Foldable as Foldable+import Data.Traversable (Traversable)+import qualified Data.Traversable as Traversable+import Data.Monoid++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe++import Debug.Trace++import Abstract+import Polarity+import Value+import {-# SOURCE #-} Eval -- (up,whnf')+import PrettyTCM++-- import CallStack+import TraceError++import TreeShapedOrder (TSO)+import qualified TreeShapedOrder as TSO++import Util++import Warshall++-- traceSig msg a = trace msg a+traceSig msg a = a++traceRew msg a = a -- trace msg a+traceRewM msg = return () -- traceM msg+{-+traceRew msg a = trace msg a+traceRewM msg = traceM msg+-}++-- metavariables and constraints++traceMeta msg a = a -- trace msg a+traceMetaM msg = return () -- traceM msg+{-+traceMeta msg a = trace msg a+traceMetaM msg = traceM msg+-}+++-- type checking monad -----------------------------------------------++class (MonadCxt m, MonadSig m, MonadMeta m, MonadError TraceError m) =>+  MonadTCM m where+++-- lists of exactly one or two elements ------------------------------++-- this would have been better implemented by just lists and a view+--   type OneOrTwo a = [a]+--   data View12 a = One a | Two a a+--   fromList12+-- then one could still get completeness of pattern matching!+-- now we have lots of boilerplate code++data OneOrTwo a = One a | Two a a deriving (Eq, Ord, Functor, Foldable, Traversable)++instance Show a => Show (OneOrTwo a) where+  show (One a)   = show a+  show (Two a b) = show a ++ "||" ++ show b++name12 :: OneOrTwo Name -> Name+name12 (One n) = n+name12 (Two n1 n2)+  | null (suggestion n2) = n1+  | null (suggestion n1) = n2+  | suggestion n1 == suggestion n2 = n1+  | otherwise = fresh (suggestion n1 ++ "||" ++ suggestion n2)++{-+instance Functor OneOrTwo where+  fmap f (One a)   = One (f a)+  fmap f (Two a b) = Two (f a) (f b)++instance Foldable OneOrTwo where+  foldMap f (One a) = f a+  foldMap f (Two a b) = f a `mappend` f b++-- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)+instance Traversable OneOrTwo where+  traverse f (One a) = One <$> f a+  traverse f (Two a b) = Two <$> f a <*> f b+-}++-- eliminator+oneOrTwo :: (a -> b) -> (a -> a -> b) -> OneOrTwo a -> b+oneOrTwo f g (One a) = f a+oneOrTwo f g (Two a1 a2) = g a1 a2++fromOne :: OneOrTwo a -> a+fromOne (One a) = a++toTwo :: OneOrTwo a -> OneOrTwo a+toTwo = oneOrTwo (\ a -> Two a a) Two++first12 :: OneOrTwo a -> a+first12 (One a) = a+first12 (Two a1 a2) = a1++second12 :: OneOrTwo a -> a+second12 (One a) = a+second12 (Two a1 a2) = a2++mapSecond12 :: (a -> a) -> OneOrTwo a -> OneOrTwo a+mapSecond12 f (One a) = One (f a)+mapSecond12 f (Two a1 a2) = Two a1 (f a2)++zipWith12 :: (a -> b -> c) -> OneOrTwo a -> OneOrTwo b -> OneOrTwo c+zipWith12 f (One a) (One b) = One (f a b)+zipWith12 f (Two a a') (Two b b') = Two (f a b) (f a' b')++zipWith123 :: (a -> b -> c -> d) ->+              OneOrTwo a -> OneOrTwo b -> OneOrTwo c -> OneOrTwo d+zipWith123 f (One a) (One b) (One c) = One (f a b c)+zipWith123 f (Two a a') (Two b b') (Two c c') = Two (f a b c) (f a' b' c')++toList12 :: OneOrTwo a -> [a]+toList12 (One a) = [a]+toList12 (Two a1 a2) = [a1,a2]++fromList12 :: Show a => [a] -> OneOrTwo a+fromList12 [a]     = One a+fromList12 [a1,a2] = Two a1 a2+fromList12 l = error $ "fromList12 " ++ show l++toMaybe12 :: Show a => [a] -> Maybe (OneOrTwo a)+toMaybe12 []      = Nothing+toMaybe12 [a]     = Just $ One a+toMaybe12 [a1,a2] = Just $ Two a1 a2+toMaybe12 l = error $ "toMaybe12 " ++ show l+++-- reader monad for local environment++data TCContext = TCContext+  { context   :: SemCxt+  , renaming  :: Ren       -- assigning de Bruijn Levels to names+  , naming    :: Map Int Name  -- assigning names to de Bruijn levels+--  , nameVariants :: Map Name Int -- how many variants of the name+  , environ   :: Env2+  , rewrites  :: Rewrites+  , sizeRels  :: TSO Int   -- relations of universal (rigid) size variables+                           -- collected from size patterns (x > y)+  , belowInfty:: [Int]     -- list of size variables < #+  , bounds    :: [Bound Val]  -- bound hyps that do not fit in sizeRels+  , consistencyCheck :: Bool -- ^ Do we need to check that new size relations are consistent with every valuation of the current @sizeRels@? [See ICFP 2013 paper]+  , checkingConType :: Bool  -- different PTS rules for constructor types (parametric function space!)+  , assertionHandling :: AssertionHandling -- recover from errors?+  , impredicative :: Bool       -- use impredicative PTS rules+  -- checking measured functions+  , funsTemplate :: Map Name (Kinded Fun) -- types of mutual funs with measures checking body+  , mutualFuns :: Map Name SigDef -- types of mutual funs while checking body+  , mutualCo :: Co                -- mutual block (co)recursive ?+  , mutualNames :: [Name] -- ^ The defined names of the current mutual block (and parents).+  , checkingMutualName :: Maybe DefId -- which body of a mutual block am I checking?+  , callStack :: [QName] -- ^ Used to avoid looping when going into recursive data definitions.+  }++instance Show TCContext where+    show ce = show (environ ce) ++ "; " ++ show (context ce)++emptyContext = TCContext+  { context  = cxtEmpty+  , renaming = Map.empty+  , naming   = Map.empty+  , environ  = emptyEnv+  , rewrites = emptyRewrites+  , sizeRels = TSO.empty+  , belowInfty = []+  , bounds   = []+  , consistencyCheck = False -- initially, no consistency check, turned on when entering rhs+  , checkingConType = False+  , assertionHandling = Failure  -- default is not to ignore any errors+  , impredicative = False+  , funsTemplate = Map.empty+  , mutualFuns = Map.empty+  , mutualCo = Ind+  , mutualNames = []+  , checkingMutualName = Nothing+  , callStack = []+  }++-- state monad for global signature++data TCState = TCState+  { signature   :: Signature+  , metaVars    :: MetaVars+  , constraints :: Constraints+  , positivityGraph :: PositivityGraph+  -- , dots        :: Dots -- UNUSED+  }++type MetaVars = Map MVar MetaVar+emptyMetaVars = Map.empty++type MScope = [Name] -- ^ names of size variables which are in scope of mvar+data MetaVar = MetaVar+  { mscope   :: MScope+  , solution :: Maybe Val+  }++type PosConstrnt = Constrnt PPoly DefId ()+type PositivityGraph = [PosConstrnt]+emptyPosGraph = []++-- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO))+type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO))++instance MonadAssert TypeCheck where+  assert b s = do+    h <- asks assertionHandling+    assert' h b s+  newAssertionHandling h = local ( \ ce -> ce { assertionHandling = h })++{- mtl-2 provides these instances+-- TypeCheck is applicative since every monad is.+-- I do not know why this ain't in the libraries...+instance Applicative TypeCheck where+  pure      = return+  mf <*> ma = mf >>= \ f -> ma >>= \ a -> pure (f a)+-}++{- NOT NEEDED++-- | Dotted constructors (the top one in the pattern).+type Dots = [(Dotted,Pattern)]++emptyDots = []++class LensDots a where+  getDots :: a -> Dots+  setDots :: Dots -> a -> a+  setDots = mapDots . const+  mapDots :: (Dots -> Dots) -> a -> a+  mapDots f a = setDots (f (getDots a)) a++instance LensDots TCState where+  getDots = dots+  setDots d st = st { dots = d }++newDotted :: Pattern -> TypeCheck Dotted+newDotted p = do+  d <- mkDotted True+  modify $ mapDots $ ((d,p):)+  return d++clearDots :: TypeCheck ()+clearDots = modify $ setDots emptyDots++openDots :: TypeCheck [Pattern]+openDots = map snd . filter (isDotted . fst) <$> gets dots+-}++-- rewriting rules -----------------------------------------------++data Rewrite  = Rewrite { lhs :: Val,  rhs :: Val }+type Rewrites = [Rewrite]++emptyRewrites = []++instance Show Rewrite where+  show rr = show (lhs rr) ++ " --> " ++ show (rhs rr)++{- renaming ------------------------------------------------------++  A renaming maps names to de Bruijn levels (= generic values).+-}++type Ren = Map Name Int++type Env2 = Environ (OneOrTwo Val)++type Context a = Map Int a+type Context2 a = Context (OneOrTwo a)++{- context -------------------------------------------------------++A context maps generic values to their type value.++During type checking, named variables are mapped to+generic values via a renaming.  Thus, looking up the type of a+name involves first looking up the generic value, and then its type.++-}++{-+-- data Domain = Domain { typ :: TVal, decor :: Dec }+data Domain = Domain { typ :: TVal, kind :: Class, decor :: Dec }++mapTyp :: (TVal -> TVal) -> Domain -> Domain+mapTyp f dom = dom { typ = f (typ dom) }++mapTypM :: Monad m => (TVal -> m TVal) -> Domain -> m Domain+mapTypM f dom = do+  t' <- f (typ dom)+  return $ dom { typ = t' }++instance Show Domain where+  show item = (if erased (decor item) then brackets else id) (show (typ item))+-}++-- During heterogeneous equality, a variable might have+-- two different types, one on the left and one on the right.+-- We implement this as Two tl tr.++data CxtE a = CxtEntry { domain :: a, upperDec :: UDec }+type CxtEntry  = CxtE (OneOrTwo Domain)+type CxtEntry1 = CxtE Domain++data SemCxt = SemCxt+  { len   :: Int+  , cxt   :: Context2 Domain  -- fixed part of context+  , upperDecs :: Context UDec -- the "should be below" decoration for each var.; this is updated by resurrection+  }+{- invariant: length (cxt delta) = length (upperDecs delta) = len+     cxt(i) = Two ... iff  upperDecs(i) = Two ...+ -}++instance Show SemCxt where+  show delta =+    show $ zip (Map.elems (cxt delta))+               (Map.elems (upperDecs delta))+{-+  show delta = show $ zip (+    zipWith3 (zipWith12 Domain)+--    zipWith (\ entry dec -> fmap ((flip Domain) dec) entry)+      (Map.elems (cxt delta))+      (Map.elems (kinds delta))+      (Map.elems (decs delta))+    ) (Map.elems (upperDecs delta))+-}+cxtEmpty = SemCxt+  { len = 0+  , cxt = Map.empty+--  , kinds = Map.empty+--  , decs = Map.empty+  , upperDecs = Map.empty+  }++-- push a new type declaration on context+cxtPush' :: OneOrTwo Domain -> SemCxt -> SemCxt+cxtPush' entry delta =+  delta { len = k + 1+        , cxt  = Map.insert k entry (cxt delta)+--        , cxt  = Map.insert k (fmap typ   entry) (cxt delta)+--        , decs = Map.insert k (fmap decor entry) (decs delta)+        , upperDecs = Map.insert k defaultUpperDec (upperDecs delta)+        }+  where k = len delta+{-+cxtPush' (tv12, dec) delta =+  delta { len = k + 1+        , cxt  = Map.insert k tv12 (cxt delta)+        , decs = Map.insert k dec (decs delta) }+  where k = len delta+-}+{-+cxtPush :: Dec -> TVal -> SemCxt -> (Int, SemCxt)+cxtPush dec v delta = (len delta, cxtPush' (One (Domain v dec)) delta)+-- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta)+-}++cxtPushEntry :: OneOrTwo Domain -> SemCxt -> (Int, SemCxt)+cxtPushEntry ce delta = (len delta, cxtPush' ce delta)++cxtPush :: Domain -> SemCxt -> (Int, SemCxt)+cxtPush dom delta = cxtPushEntry (One dom) delta+-- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta)++-- push a variable with a left and a right type+cxtPush2 :: Domain -> Domain -> SemCxt -> (Int, SemCxt)+cxtPush2 doml domr delta = cxtPushEntry (Two doml domr) delta+--  (len delta, cxtPush' (Two doml domr) delta)++{-+-- push a variable with a left and a right type+cxtPush2 :: Dec -> TVal -> TVal -> SemCxt -> (Int, SemCxt)+cxtPush2 dec tvl tvr delta =+  (len delta, cxtPush' (Two tvl tvr, dec) delta)+-}++cxtPushGen ::  Name -> SemCxt -> (Int, SemCxt)+cxtPushGen x delta = cxtPush bot delta+  where bot = error $ "IMPOSSIBLE: name " ++ show x ++ " is not bound to any type"++-- only defined for single bindings+cxtSetType :: Int -> Domain -> SemCxt -> SemCxt+cxtSetType k dom delta =+  delta { cxt  = Map.insert k (One dom) (cxt delta)+        -- upperDecs need not be updated+        }++-- | Version of 'Map.lookup' that throws 'TraceError'.+lookupM :: (MonadError TraceError m, Show k, Ord k) => k -> Map k v -> m v+lookupM k m = maybe (throwErrorMsg $ "lookupM: unbound key " ++ show k) return $ Map.lookup k m++cxtLookupGen :: MonadError TraceError m => SemCxt -> Int -> m CxtEntry+cxtLookupGen delta k = do+  dom12 <- lookupM k (cxt delta)+  udec  <- lookupM k (upperDecs delta)+  return $ CxtEntry dom12 udec++cxtLookupName :: MonadError TraceError m => SemCxt -> Ren -> Name -> m CxtEntry+cxtLookupName delta ren x = do+  i <- lookupM x ren+  cxtLookupGen delta i++-- apply decoration, possibly resurrecting (see Pfenning, LICS 2001)+-- and changing polarities (see Abel, MSCS 2008)+cxtApplyDec :: Dec -> SemCxt -> SemCxt+cxtApplyDec dec delta = delta { upperDecs = Map.map (compDec dec) (upperDecs delta) }+-- cxtApplyDec dec delta =  delta { decs = Map.map (fmap $ invCompDec dec) (decs delta) }++{- RETIRED, use cxtApplyDec instead+-- clear all "erased" flags (see Pfenning, LICS 2001)+-- UPDATE: resurrection sets "target" status to erased+--         (as opposed to setting "source" status to non-erased)+cxtResurrect :: SemCxt -> SemCxt+cxtResurrect delta = delta { upperDecs = Map.map (\ dec -> dec { erased = True}) (upperDecs delta) }+-- cxtResurrect delta = delta { decs = Map.map (fmap resurrectDec) (decs delta) }+-}++-- manipulating the context ------------------------------------------++{-+-- | Size decrements in bounded quantification do not count for termination+data LamPi+  = LamBind -- ^ add a lambda binding to the context+  | PiBind  -- ^ add a pi binding to the context+-}++class Monad m => MonadCxt m where+--  bind     :: Name -> Domain -> Val -> m a -> m a+--  new performs eta-expansion "up" of new gen+  -- adding types (Two t1 t2) returns values (Two (Up t1 vi) (Up t2 vi))+  newVar     :: Name -> OneOrTwo Domain -> (Int -> OneOrTwo Val -> m a) -> m a+  newWithGen :: Name -> Domain -> (Int -> Val -> m a) -> m a+  newWithGen x d k = newVar x (One d)+    (\ i (One v) -> k i v)+  new2WithGen:: Name -> (Domain, Domain) -> (Int -> (Val, Val) -> m a) -> m a+  new2WithGen x (doml, domr) k = newVar x (Two doml domr)+    (\ i (Two vl vr) -> k i (vl, vr))+  new        :: Name -> Domain -> (Val -> m a) -> m a+  new x d cont = newWithGen x d (\ _ -> cont)+  new2       :: Name -> (Domain, Domain) -> ((Val, Val) -> m a) -> m a+  new2 x d cont = new2WithGen x d (\ _ -> cont)+{-+  new2       :: Name -> (TVal, TVal, Dec) -> ((Val, Val) -> m a) -> m a+  new2 x d cont = new2WithGen x d (\ _ -> cont)+-}+  new'       :: Name -> Domain -> m a -> m a+  new' x d cont = new x d (\ _ -> cont)+  newIrr     :: Name -> m a -> m a  -- only add binding x = VIrr to env+  addName    :: Name -> (Val -> m a) -> m a+{- RETIRED+  addTypeSigs :: [TySig TVal] -> m a -> m a+  addTypeSigs [] k = k+  addTypeSigs (TypeSig n tv : tss) k =+    new' n (defaultDomain tv) $ addTypeSigs tss k+-}+  addKindedTypeSigs :: [Kinded (TySig TVal)] -> m a -> m a+  addKindedTypeSigs [] k = k+  addKindedTypeSigs (Kinded ki (TypeSig n tv) : ktss) k =+    new' n (Domain tv ki defaultDec) $ addKindedTypeSigs ktss k+--  addName x = new x dontCare+  setType    :: Int -> Domain -> m a -> m a+  setTypeOfName :: Name -> Domain -> m a -> m a+  genOfName  :: Name -> m Int+  nameOfGen  :: Int -> m Name+--  nameTaken  :: Name -> m Bool+  uniqueName :: Name -> Int -> m Name+  uniqueName x _ = return x -- $ freshen x -- TODO!  now freshen causes problems in extraction+{-+  uniqueName x k = ifM (nameTaken x) (return $ show x ++ "~" ++ show k) (return x)+-}+  lookupGen  :: Int -> m CxtEntry+  lookupGenType2 :: Int -> m (TVal, TVal)+  lookupGenType2 i = do+    entry <- lookupGen i+    case domain entry of+      One d1    -> return (typ d1, typ d1)+      Two d1 d2 -> return (typ d1, typ d2)+  lookupName :: Name -> m CxtEntry+  lookupName1 :: Name -> m CxtEntry1+  lookupName1 x = do+    e <- lookupName x+    return $ CxtEntry (fromOne (domain e)) (upperDec e)++  getContextTele :: m TeleVal  -- return context as telescope of type values+  getLen     :: m Int       -- return length of the context+  getEnv     :: m Env       -- return current environment+  getRen     :: m Ren       -- return current renaming+  applyDec   :: Dec -> m a -> m a  -- resurrect/adjust polarities+  resurrect  :: m a -> m a -- resurrect all erased variables in context+  resurrect = applyDec irrelevantDec+  addRewrite :: Rewrite -> [Val] -> ([Val] -> m a) -> m a+  addPattern :: TVal -> Pattern -> Env -> (TVal -> Val -> Env -> m a) -> m a -- step under pat+  addPatterns:: TVal -> [Pattern] -> Env -> (TVal -> [Val] -> Env -> m a) -> m a+  addSizeRel  :: Int -> Int -> Int -> m a -> m a+  addBelowInfty :: Int -> m a -> m a+  addBoundHyp :: Bound Val -> m a -> m a+  isBelowInfty :: Int -> m Bool+  sizeVarBelow :: Int -> Int -> m (Maybe Int)+--  getSizeDiff :: Int -> Int -> m (Maybe Int)+  getMinSize  :: Int -> m (Maybe Int)+  getSizeVarsInScope :: m [Name]+  checkingCon :: Bool -> m a -> m a+  checkingDom :: m a -> m a  -- check domain A of Pi x:A.B (takes care of polarities)+  setCo :: Co -> m a -> m a -- entering a recursive or corecursive function?+  installFuns :: Co -> [Kinded Fun] -> m a -> m a+  setMeasure  :: Measure Val -> m a -> m a+  activateFuns :: m a -> m a -- create instance of mutually recursive functions bounded by measure+  goImpredicative :: m a -> m a+  checkingMutual :: Maybe DefId -> m a -> m a++dontCare = error "Internal error: tried to retrieve unassigned type of variable"++instance MonadCxt TypeCheck where++  newIrr x = local (\ ce -> ce { environ = update (environ ce) x (One VIrr) })++  -- UPDATE to 2?+  addName x f = enter ("new " ++ show x ++ " : _") $ do+    cxtenv <- ask+    let (k, delta) = cxtPushGen x (context cxtenv)+    let v = VGen k+    let rho = update (environ cxtenv) x (One v)+    x' <- uniqueName x k+    local (\ cxt -> cxt { context = delta+                        , renaming = Map.insert x k (renaming cxtenv)+                        , naming = Map.insert k x' (naming cxt)+                        , environ = rho }) (f v)+++  newVar x dom12@(One (Domain (VBelow ltle v) ki dec)) f = do+    enter ("new " ++ show x ++ " " ++ show ltle ++ " " ++ show v) $ do+      cxtenv <- ask+      let (k, delta) = cxtPushEntry (One (Domain vSize kSize dec)) (context cxtenv)+      let xv  = VGen k+      let v12 = One xv+      let rho = update (environ cxtenv) x v12+      let beta = Bound ltle (Measure [xv]) (Measure [v])+      x' <- uniqueName x k+      local (\ cxt -> cxt { context = delta+                          , renaming = Map.insert x k (renaming cxtenv)+                          , naming = Map.insert k x' (naming cxtenv)+                          , environ = rho }) $+        addBoundHyp beta $ (f k v12)+++  newVar x dom12 f = do+    let tv12 = fmap typ dom12+    enter ("new " ++ show x ++ " : " ++ show tv12) $ do+      cxtenv <- ask+      let (k, delta) = cxtPushEntry dom12 (context cxtenv)+      v12 <- Traversable.mapM (up False (VGen k)) tv12+      let rho = update (environ cxtenv) x v12+      x' <- uniqueName x k+      local (\ cxt -> cxt { context = delta+                          , renaming = Map.insert x k (renaming cxtenv)+                          , naming = Map.insert k x' (naming cxtenv)+                          , environ = rho }) (f k v12)+{-+  newVar x (tv12, dec) f = enter ("new " ++ x ++ " : " ++ show tv12) $ do+    cxtenv <- ask+    let (k, delta) = cxtPushEntry (tv12, dec) (context cxtenv)+    v12 <- Traversable.mapM (up (VGen k)) tv12+    let rho = update (environ cxtenv) x v12+    local (\ cxt -> cxt { context = delta+                        , renaming = Map.insert x k (renaming cxtenv)+                        , environ = rho }) (f k v12)+-}+  setType k dom =+    local (\ ce -> ce { context = cxtSetType k dom (context ce) })++  setTypeOfName x dom cont = do+    ce <- ask+    let Just k = Map.lookup x (renaming ce)+    setType k dom cont++  genOfName x = do+    ce <- ask+    case Map.lookup x (renaming ce) of+      Nothing -> throwErrorMsg $ "internal error: variable not bound: " ++ show x+      Just k -> return k++  nameOfGen k = do+    ce <- ask+    case Map.lookup k (naming ce) of+      Nothing -> return $ fresh $ "error_unnamed_gen" ++ show k+       -- throwErrorMsg $ "internal error: no name for variable " ++ show k+      Just x -> return x++{-+  nameTaken "" = return True+  nameTaken x = do+    ce <- ask+    st <- get+    return (Map.member x (renaming ce) || Map.member x (signature st))+-}++  lookupGen k = do+    ce <- ask+    cxtLookupGen (context ce) k++  lookupName x = do+    ce <- ask+    cxtLookupName (context ce) (renaming ce) x++  -- does not work with shadowing!+  getContextTele = do+    ce <- ask+    let cxt = context ce+    let ren = renaming ce+    let env = envMap $ environ ce+    let mkTBind (x,_) = (TBind x .fromOne . domain) <$> cxtLookupName cxt ren x+    mapM mkTBind env++  getLen = do+    ce <- ask+    return $ len (context ce)++  getRen = do+    ce <- ask+    return $ renaming ce++  -- since we only use getEnv during type checking, no case for Two+  -- (during equality/subtype checking, we have values)+  getEnv = do+    ce <- ask+    let (Environ rho mmeas) = environ ce+    return $ Environ (map (\ (x, One v) -> (x, v)) rho) mmeas++  applyDec dec = local (\ ce -> ce { context = cxtApplyDec dec (context ce) })+--  applyDec dec = local (\ ce -> ce { upperDecs = Map.map (compDec dec) (upperDecs ce) })++  -- resurrection sets "target" status to erased+  -- (as opposed to setting "source" status to non-erased)+{-+  resurrect = local (\ ce -> ce { upperDecs =+    Map.map (\ dec -> dec { erased = True }) (upperDecs ce) })+-}+{-+  resurrect = local (\ ce -> ce { context = cxtResurrect (context ce) })+-}+++  -- PROBABLY TOO INEFFICIENT+  addRewrite rew vs cont = traceRew ("adding rewrite " ++ show rew) $+    -- add rewriting rule+    local (\ cxt -> cxt { rewrites = rew : (rewrites cxt) }) $ do+      ce <- ask+      -- normalize all types in context+      traceRewM "normalizing types in context"+      cx' <- mapMapM (Traversable.mapM (Traversable.mapM reval)) (cxt (context ce))  -- LOOP!+      -- normalize environment+      traceRewM "normalizing environment"+      let Environ rho mmeas = environ ce+      rho' <- mapM (\ (x,v12) -> Traversable.mapM reval v12 >>= \ v12' -> return (x, v12')) rho+      let en' = Environ rho' mmeas -- no need to rewrite in measure since only size expressions+      -- normalize given values+      vs' <- mapM reval vs+      -- continue in updated context+      local (\ ce -> ce { context = (context ce) { cxt = cx' }+                        , environ = en' }) $ cont vs'++  -- addPattern :: TVal -> Pattern -> (TVal -> Val -> Env -> m a) -> m a+  addPattern tv@(VQuant Pi x dom fv) p rho cont =+       case p of+          VarP y -> underAbs y dom fv $ \ _ xv bv -> do+              cont bv xv (update rho y xv)++          SizeP e y -> underAbs y dom fv $ \ j xv bv -> do+              ve <- whnf' e+              addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $+                cont bv xv (update rho y xv)+{-+          SizeP z y -> newWithGen y dom $ \ j xv -> do+              bv <- whnf (update env x xv) b+              VGen k <- whnf' (Var z)+              addSizeRel j 1 k $+                cont bv xv (update rho y xv)+-}+          ConP pi n pl -> do+              sige <- lookupSymbQ n+              vc <- conLType n (typ dom)+              addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl?+                pv0 <- mkConVal notDotted (coPat pi) n vpl vc+                pv  <- up False pv0 (typ dom)+                vb  <- app fv pv+                cont vb pv rho+{-+          ConP pi n pl -> do+              sige <- lookupSymb n+              let vc = symbTyp sige+              addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl?+                pv0 <- foldM app (vCon (coPat pi) n) vpl+                pv  <- up False pv0 (typ dom)+                vb  <- whnf (update env x pv) b+                cont vb pv rho+-}+          SuccP p2 -> do+              addPattern (vSize `arrow` vSize) p2 rho $ \ _ vp2 rho -> do+                let pv = succSize vp2+                vb  <- app fv pv+                cont vb pv rho++          ErasedP p -> addPattern tv p rho cont++-- for dot patterns, we have to do something smart, because they might+-- contain identifiers which are not yet in scope, only after adding+-- other patterns+-- the following trivial solution only works for trivial dot patterns, i.e.,+-- such that do not use yet undeclared identifiers++          DotP e -> do+              v  <- whnf rho e+              vb <- app fv v+              cont vb v rho -- [(x,v)]+++  addPatterns tv [] rho cont = cont tv [] rho+  addPatterns tv (p:ps) rho cont =+    addPattern tv p rho $ \ tv' v env ->+      addPatterns tv' ps env $ \ tv'' vs env' ->+        cont tv'' (v:vs) env' -- (env' ++ env)++  addSizeRel son dist father k = do+    let s = "v" ++ show son ++ " + " ++ show dist ++ " <= v" ++ show father+    enter -- enterTrace+      ("adding size rel. " ++ s) $ do+    let modBI belowInfty = if father `elem` belowInfty || dist > 0 then son : belowInfty else belowInfty+    whenM (asks consistencyCheck `andLazy` do+           TSO.increasesHeight son (dist, father) <$> asks sizeRels) $ do+      recoverFail $ "cannot add hypothesis " ++ s ++ " because it is not satisfyable under all possible valuations of the current hypotheses"+    -- if the new son is an ancestor of the father, we are cyclic+    whenJustM (TSO.isAncestor father son <$> asks sizeRels) $ \ n -> -- n steps from father up to son+      when (dist > - n) $ -- still ok if dist == n == 0, otherwise fail+        recoverFail$ "cannot add hypothesis " ++ s ++ " because it makes the set of hyptheses unsatisfiable"+    local (\ cxt -> cxt+      { sizeRels = TSO.insert son (dist, father) (sizeRels cxt)+      , belowInfty = modBI (belowInfty cxt)+      }) k++  addBelowInfty i = local $ \ cxt -> cxt { belowInfty = i : belowInfty cxt }++  addBoundHyp beta@(Bound ltle (Measure mu) (Measure mu')) cont =+    case (ltle, mu, mu') of+      (Le, _, [VInfty]) -> cont+--      (Lt, _, [VInfty]) -> failure  -- handle j < #+      (ltle, [v], [v']) -> loop (if ltle==Lt then 1 else 0) v v'+      _ -> failure+    where failure = do+--            recoverFail $ "adding hypothetical constraint " ++ show beta ++ " not supported"+            assertDoc' Warning False (text "hypothetical constraint" <+> prettyTCM beta <+> text "ignored")+            cont++          loop n (VGen i) VInfty = addBelowInfty i cont+          loop n (VGen i) (VGen j) | n >= 0 = addSizeRel i n j cont+                                   | otherwise = addIrregularBound i j (-n) cont+          loop n (VSucc v) v' = loop (n + 1) v v'+          loop n v (VSucc v') = loop (n - 1) v v'+          loop _ _ _ = failure++          addIrregularBound i j n = local (\ ce -> ce { bounds = beta : bounds ce }) where+              v' = iterate VSucc (VGen j) !! n+              beta = Bound Le (Measure [VGen i]) (Measure [v'])++  isBelowInfty i = (i `elem`) <$> asks belowInfty++{-+  isBelowInfty i = do+    belowInfty <- asks belowInfty+    if (i `elem` belowInfty) then return True else do+      tso <- asks sizeRels+      loop $ parents i tso where+        loop [] = return False+        loop [(_,j)] = return $ j `elem` belowInfty+        loop (x:xs)  = loop xs+-}++  sizeVarBelow son ancestor = do+    cxt <- ask+    return $ TSO.isAncestor son ancestor (sizeRels cxt)+{-+  getSizeDiff son ancestor = do+    cxt <- ask+    return $ TSO.diff son ancestor (sizeRels cxt)+-}+  getMinSize parent = do+    cxt <- ask+    return $ TSO.height parent (sizeRels cxt)++  getSizeVarsInScope = do+    TCContext { context = delta, naming = nam } <- ask+    -- get all the size variables with positive or mixed polarity+    let fSize (i, tv12) =+          case tv12 of+            One dom -> isVSize $ typ dom+            _ -> -- trace ("not a size variable " ++ show i ++ " : " ++ show tv12) $+                   False+    -- create a list of key (gen) and Domain pairs for the size variables+    let idl = filter fSize $ Map.toAscList (cxt delta)+    let udecs = upperDecs delta+    let fPos (i, One dom) =+         case fromPProd (polarity (Maybe.fromJust (Map.lookup i udecs))) of+           Just p -> leqPol (polarity (decor dom)) p+           Nothing -> False+    let fName (i, _) = Maybe.fromJust $ Map.lookup i nam+    return $ map fName $ filter fPos idl+++  checkingCon b = local (\ cxt -> cxt { checkingConType = b})++{-+  checkingDom = local $ \ cxt ->+    if checkingConType cxt then cxt+     else cxt { context = cxtApplyDec (Dec False Neg) (context cxt) }+-}+  -- check domain A of (x : A) -> B+  checkingDom k = do+    b <- asks checkingConType+    if b then k else applyDec (Dec Neg) k++  setCo co = local (\ cxt -> cxt { mutualCo = co })++  -- install functions for checking function clauses+  -- ==> use internal names+  installFuns co kfuns k = do+    let funt = foldl (\ m fun@(Kinded _ (Fun (TypeSig n _) n' _ _)) -> Map.insert n fun m)+                     Map.empty+                     kfuns+    local (\ cxt -> cxt { mutualCo = co, funsTemplate = funt }) k++  setMeasure mu k =  do+      rho0 <- getEnv+      let rho = rho0 { envBound = Just mu }+      local (\ cxt -> cxt+        { environ    = (environ cxt) { envBound = Just mu }+        }) k++  activateFuns k = do+      rho <- getEnv+      case (envBound rho) of+         Nothing -> k+         Just mu ->+           local (\ cxt -> cxt+             { mutualFuns =+                 Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt)+             }) k+    where boundFun :: Env -> Co -> Kinded Fun -> SigDef+          boundFun rho co (Kinded ki (Fun (TypeSig n t) n' ar cls)) =+            FunSig co (VClos rho t) ki ar cls False undefined++{-+  activateFuns mu k = do+      rho0 <- getEnv+      let rho = rho0 { envBound = Just mu }+      local (\ cxt -> cxt+        { environ    = (environ cxt) { envBound = Just mu }+        , mutualFuns =+            Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt)+        }) k+    where boundFun :: Env -> Co -> Fun -> SigDef+          boundFun rho co (TypeSig n t, (ar, cls)) =+            FunSig co (VClos rho t) ar cls False+ -}++  goImpredicative = local (\ cxt -> cxt { impredicative = True })++  checkingMutual mn = local (\ cxt -> cxt { checkingMutualName = mn })++-- | Go into the codomain of a Pi-type or open an abstraction.+underAbs  :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a+underAbs x dom fv cont = newWithGen x dom $ \ i xv -> cont i xv =<< app fv xv++-- | Do not check consistency preservation of context.+underAbs_  :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a+underAbs_ x dom fv cont = noConsistencyChecking $ underAbs x dom fv cont++noConsistencyChecking = local $ \ cxt -> cxt { consistencyCheck = False }++-- | No eta, no hypotheses.  First returned val is a @VGen i@.+underAbs' :: Name -> FVal -> (Val -> Val -> TypeCheck a) -> TypeCheck a+underAbs' x fv cont = addName x $ \ xv -> cont xv =<< app fv xv++-- addBind :: MonadTCM m => TBind -> m a -> m a+addBind :: TBind -> TypeCheck a -> TypeCheck a+addBind (TBind x dom) cont = do+  dom' <- (Traversable.mapM whnf' dom)+  new' x dom' cont++addBinds :: Telescope -> TypeCheck a -> TypeCheck a+addBinds tel k0 = foldr addBind k0 $ telescope tel++-- introduce patterns into context and environment -------------------+-- DOES NOT ETA-EXPAND VARIABLES!! -----------------------------------++introPatterns :: [Pattern] -> TVal -> ([(Pattern,Val)] -> TVal -> TypeCheck a) -> TypeCheck a+introPatterns ps tv cont =                -- Problem: NO ETA EXPANSION!+  introPatVars ps $ do                    -- first bind pattern variables+    vs <- mapM (whnf' . patternToExpr) ps -- now we can evaluate patterns+    let pvs = zip ps vs+    introPatTypes pvs tv (cont pvs)       -- now we can assign types to pvars++-- introduce variables bound in pattern into the environment+-- extend delta by generic values but do not introduce their types+-- this is to deal with dot patterns+introPatVar :: Pattern -> TypeCheck a -> TypeCheck a+introPatVar p cont =+    case p of+      VarP n -> addName n $ \ _ -> cont+      SizeP m n -> addName n $ \ _ -> cont+      ConP co n pl -> introPatVars pl cont+      PairP p1 p2 -> introPatVars [p1,p2] cont+      SuccP p -> introPatVar p cont+      ProjP{} -> cont+      DotP e -> cont+      AbsurdP -> cont+      ErasedP p -> introPatVar p cont++introPatVars :: [Pattern] -> TypeCheck a -> TypeCheck a+introPatVars [] cont = cont+introPatVars (p:ps) cont = introPatVar p $ introPatVars ps $ cont++-- if the bindings name->gen are already in the environment+-- we can now bind the gen to their types+introPatType :: (Pattern,Val) -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a+introPatType (p,v) tv cont = do+  case tv of+    VGuard beta bv -> addBoundHyp beta $ introPatType (p,v) bv cont+    VApp (VDef (DefId DatK d)) vl ->+      case p of+        ProjP n -> cont =<< projectType tv n VIrr -- no record value here+        _       -> throwErrorMsg $ "introPatType: internal error, expected projection pattern, found " ++ show p ++ " at type " ++ show tv+    VQuant Pi x dom fv -> do+       v  <- whnfClos v+       matchPatType (p,v) dom . cont =<< app fv v+    _ -> throwErrorMsg $ "introPatType: internal error, expected Pi-type, found " ++ show tv++introPatTypes :: [(Pattern,Val)] -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a+introPatTypes pvs tv f = do+  case pvs of+    [] -> f tv+    (pv:pvs') -> introPatType pv tv $ \ tv' -> introPatTypes pvs' tv' f++matchPatType :: (Pattern, Val) -> Domain -> TypeCheck a -> TypeCheck a+matchPatType (p,v) dom cont =+       case (p,v) of+                                                   -- erasure does not matter!+          (VarP y, VGen k) -> setType k dom $ cont++          (SizeP z y, VGen k) -> setType k dom $ cont++          (ConP co n [], _) -> cont++          (ConP co n pl, VApp (VDef (DefId ConK{} _)) vl) -> do+{-+             sige <- lookupSymb n+             let vc = symbTyp sige+-}+             vc <- conType n =<< force (typ dom)+             introPatTypes (zip pl vl) vc $ \ _ -> cont++          (SuccP p2, VSucc v2) -> matchPatType (p2, v2) (defaultDomain vSize) $ cont++          (PairP p1 p2, VPair v1 v2) -> do+             av <- force (typ dom)+             case av of+               VQuant Sigma x dom1@(Domain av1 ki dec) fv -> do+                 matchPatType (p1,v1) dom1 $ do+                   bv <- app fv v1+                   matchPatType (p2,v2) (Domain bv ki dec) cont+               _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show p ++ "  :  " ++ show dom++          (DotP e, _) -> cont+          (AbsurdP, _) -> cont+          (ErasedP p,_) -> matchPatType (p,v) dom cont+          _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show (p,v)+++-- Signature -----------------------------------------------------++-- input to and output of the type-checker++type Signature = Map QName SigDef++-- a signature entry is either+-- * a fun/cofun,+-- * a defined constant,+-- * a constructor, or+-- * a data type id with its kind+-- they share "symbTyp", the type signature of the definition+data SigDef+  = FunSig  { isCo          :: Co+            , symbTyp       :: TVal+            , symbolKind    :: Kind+            , arity         :: Arity+            , clauses       :: [Clause]+            , isTypeChecked :: Bool+            , extrTyp       :: Expr   -- ^ Fomega type.+            }+  | LetSig  { symbTyp       :: TVal+            , symbolKind    :: Kind+            , definingVal   :: Val+--            , definingExpr  :: Expr+            , extrTyp       :: Expr   -- ^ Fomega type.+            }+  | PatSig  { patVars       :: [Name]+            , definingPat   :: Pattern+            , definingVal   :: Val+            }+  | ConSig  { conPars       :: ConPars+              -- ^ Parameter patterns and no. of variable they bind.+              --   @Nothing@ if old-style parameters.+            , lhsTyp        :: LHSType+              -- ^ LHS type of constructor for pattern matching, e.g.+   -- rhs @cons : [A : Set] [i : Size]         -> A -> List A i -> List A $i@+   -- lhs @cons : [A : Set] [i : Size] [j < i] -> A -> List A j -> List A i@+   -- @Name@ is the name of the size parameter.+            , recOccs       :: [Bool]+              -- ^ @True@ if argument contains rec.occs.of the (co)data type?+            , symbTyp       :: TVal   -- ^ (RHS) type, includs parameter tel.+            , dataName      :: Name   -- ^ Its datatype.+            , dataPars      :: Int    -- ^ No. of parameters of its datatype.+            , extrTyp       :: Expr   -- ^ Fomega type.+            }+  | DataSig { numPars       :: Int+            , positivity    :: [Pol]+            , isSized       :: Sized+            , isCo          :: Co+            , symbTyp       :: TVal+            , symbolKind    :: Kind+            -- the following information is only needed for eta-expansion+            -- hence it is only provided for suitable ind.fams.+            , constructors  :: [ConstructorInfo]+            , etaExpand     :: Bool -- non-overlapping pattern inductive family+                                    -- with at least one eta-expandable constructor+            , isTuple       :: Bool -- each constructor is irrefutable+                                    -- must be (NEW: non-overlapping) pattern inductive family+                                    -- qualifies for target of corecursive fun+                                    -- NO LONGER: exactly one constructor+                                    -- NOW: at least one constructor+                                    -- can be recursive+            , extrTyp       :: Expr -- Fomega kind+{-+            , destructors   :: Maybe [Name] -- Nothing if not a record+            , isFamily      :: Bool+-}+            } -- # parameters, positivity of parameters  , sized , co , type+              deriving (Show)++-- | Parameter patterns and no. of variables they bind.+type ConPars = Maybe ([Name], [Pattern])++-- | LHS type plus name of size index.+type LHSType = Maybe (Name, TVal)++isEmptyData :: QName -> TypeCheck Bool+isEmptyData n = do+  sig <- lookupSymbQ n+  case sig of+    DataSig { constructors } -> return $ null constructors+    _ -> throwErrorMsg $ "internal error: isEmptyData " ++ show n ++ ": name of data type expected"++isUnitData :: QName -> TypeCheck Bool+isUnitData n = do+  sig <- lookupSymbQ n+  case sig of+    DataSig { constructors = [c], isTuple } -> return $+      isTuple && null (cFields c) && cPatFam c == (LinearPatterns, [])+    DataSig { constructors } -> return False+    _ -> throwErrorMsg $ "internal error: isUnitData " ++ show n ++ ": name of data type expected"+++undefinedFType :: QName -> Expr+undefinedFType n = Irr+-- undefinedFType n = error $ "no extracted type for " ++ show n++symbKind :: SigDef -> Kind+symbKind ConSig{}  = kTerm          -- constructors are always terms+symbKind d         = symbolKind d   -- else: lookup+{- Data types can be big!!+symbKind DataSig{} = kType          -- data types are never universes+-}++emptySig = Map.empty++-- Handling constructor types  ------------------------------------------++data DataView+  = Data Name [Clos]+  | NoData++-- | Check if type @tv@ is a datatype @D vs@.+dataView :: TVal -> TypeCheck DataView+dataView tv = do+  tv <- force tv+  case tv of+{- 2012-01-31 EVIL, LEADS TO UNBOUND VARS:+    VQuant Pi x dom env b         -> do+      new x dom $ \ xv -> dataView =<< whnf (update env x xv) b+-}+    VApp (VDef (DefId DatK n)) vs -> return $ Data (unqual n) vs+    VSing v dv                    -> dataView =<< whnfClos dv+    _                             -> return $ NoData++-- | Disambiguate possibly overloaded constructor @c@ at given type @tv@.+disambigCon ::  QName -> TVal -> TypeCheck QName+disambigCon c tv =+  case c of+    Qual{}  -> return c+    QName n -> do+      dv <- dataView tv+      case dv of+        Data d _ -> return $ Qual d n+        _ -> throwErrorMsg $ "cannot resolve constructor " ++ show n++-- | @conType c tv@ returns the type of constructor @c@ at datatype @tv@+--   with parameters instantiated.+conType :: QName -> TVal -> TypeCheck TVal+conType c tv = do+  c <- disambigCon c tv+  ConSig { conPars, symbTyp, dataName, dataPars } <- lookupSymbQ c+  instConType c conPars symbTyp dataName dataPars tv++-- | Get LHS type of constructor.+--+--   Constructors or sized data types internally have a lhs type+--   that differs from its rhs type.  E.g.,+--   rhs @suc : [i : Size] -> Nat i -> Nat $i@+--   lhs @suc : [i : Size] [j < i] -> Nat j -> Nat i@.+--   In the lhs type, @i@ turns into an additional parameter.+conLType :: QName -> TVal -> TypeCheck TVal+conLType c tv = do+  c <- disambigCon c tv+  ConSig { conPars, lhsTyp, symbTyp, dataName, dataPars } <- lookupSymbQ c+  case lhsTyp of+    Nothing        -> instConType c conPars symbTyp dataName dataPars tv+    Just (x, lTyp) -> instConType c (fmap (inc x) conPars) lTyp dataName (dataPars+1) tv+  where inc x (xs, ps) = (xs ++ [x], ps ++ [VarP x])++-- | Instantiate type of constructor to parameters obtained from+--   the data type.+--+--   @instConType c n symbTyp dataName tv@+--   instantiates type @symbTyp@ of constructor @c@ with first @n@ arguments+--   that @dataName@ is applied to in @tv@.+--   @@+--      instConType c n ((x1:A1..xn:An) -> B) d (d v1..vn ws) = B[vs/xs]+--   @@+instConType :: QName -> ConPars -> TVal -> Name -> Int -> TVal -> TypeCheck TVal+instConType c conPars symbTyp dataName dataPars tv =+  instConLType' c conPars symbTyp Nothing (Just dataName) dataPars tv+{-+instConType c numPars symbTyp dataName tv = do+  dv <- dataView tv+  case dv of+    NoData    -> failDoc (text ("conType " ++ show c ++ ": expected")+                   <+> prettyTCM tv <+> text "to be a data type")+    Data d vs -> do+      unless (d == dataName) $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show dataName+      let (pars, inds) = splitAt numPars vs+      unless (length pars == numPars) $+        failDoc (text ("conType " ++ show c ++ ": expected")+                   <+> prettyTCM tv+                   <+> text ("to be a data type applied to all of its " +++                     show numPars ++ " parameters"))+      piApps symbTyp pars+-}++-- | Get correct lhs type for constructor pattern.+--+--   @instConLType c numPars symbTyp Nothing isFlex tv@ behaves like+--   @instConLType c numPars symbType _ tv@.+--+--   But if the data types is sized and the constructor has a lhs type,+--   @instConLType c numPars symbTyp (Just ltv) isFlex tv@+--   uses the lhs type @ltv@ unless the variable instantiated for+--   the size argument is flexible (because then it wants to be+--   unified with the successor pattern of the rhs type.+instConLType :: QName -> ConPars -> TVal -> LHSType -> (Val -> Bool) -> Int -> TVal -> TypeCheck TVal+instConLType c conPars rhsTyp lhsTyp isFlex dataPars dataTyp =+  instConLType' c conPars rhsTyp (fmap (,isFlex) lhsTyp) Nothing dataPars dataTyp++-- | The common pattern behind @instConType@ and @instConLType@.+instConLType' :: QName -> ConPars -> TVal -> Maybe ((Name, TVal), Val -> Bool) -> Maybe Name -> Int -> TVal -> TypeCheck TVal+instConLType' c conPars symbTyp isSized md dataPars tv =+  enter ("instConLType'") $ do+  let failure = failDoc (text ("conType " ++ show c ++ ": expected")+                   <+> prettyTCM tv+                   <+> text ("to be a data type applied to all of its " +++                     show dataPars ++ " parameters"))+  dv <- dataView tv+  case dv of+    NoData    -> failDoc (text ("conType " ++ show c ++ ": expected")+                   <+> prettyTCM tv <+> text "to be a data type")+    Data d vs -> do+      whenJust md $ \ d' ->+        unless (d == d') $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show d'+      -- whenJust conPars $ throwErrorMsg $ "NYI: constructor with pattern parameters"+      let (pars, inds) = splitAt dataPars vs+      unless (length pars == dataPars) failure+      case (isSized, inds) of+        (Just _, []) -> failure+        -- if size index not flexible, use lhs type+        (Just ((x,ltv), isFlex), sizeInd:_) | not (isFlex sizeInd) ->+          continue d [x] ltv (pars ++ [sizeInd])+        -- otherwise, use rhs type+        _ -> continue d [] symbTyp pars+  where+    continue d ys tv pars = case conPars of+      Nothing      -> piApps tv pars+      Just (xs, ps) -> do+        let failure = failDoc $ sep+              [ text "instConType:"+              , text "cannot match parameters" <+> prettyList (map prettyTCM pars)+              , text "against patterns" <+> prettyList (map prettyTCM ps)+              , text "when instantiating type" <+> prettyTCM tv+              , text ("of constructor " ++ show c)+              ]+        -- clear dots here:+        mst <- nonLinMatchList' True True (emptyEnv, []) ps pars =<< lookupSymbTyp d+        case mst of+          Nothing  -> failure+          Just (Environ{ envMap = env0 }, psub) -> do+            let env = env0 ++ [ (x, VGen i) | (i, VarP x) <- psub ]+            -- if length env /= length xs then failure else do+            vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env+            piApps tv vs+{-+        menv <- matchList emptyEnv ps pars+        case menv of+          Nothing  -> failure+          Just Environ{ envMap = env } -> if length env /= length xs then failure else do+            vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env+            piApps tv vs+-}++{-+      case isSized of+        Nothing  -> piApps symbTyp pars+        Just ltv -> do+          when (null inds) failure+          let sizeInd = head inds+          if isFlex sizeInd then piApps symbTyp pars else piApps ltv (pars ++ [sizeInd])+-}++-- Signature specification -------------------------------------------++class MonadCxt m => MonadSig m where+  lookupSymbTypQ :: QName -> m TVal+  lookupSymbQ    :: QName -> m SigDef+  addSigQ        :: QName -> SigDef -> m ()+  modifySigQ     :: QName -> (SigDef -> SigDef) -> m ()+  setExtrTypQ    :: QName -> Expr -> m ()++  lookupSymbTyp  :: Name -> m TVal+  lookupSymbTyp  = lookupSymbTypQ . QName++  lookupSymb     :: Name -> m SigDef+  lookupSymb     = lookupSymbQ . QName++  addSig         :: Name -> SigDef -> m ()+  addSig         = addSigQ . QName++  modifySig      :: Name -> (SigDef -> SigDef) -> m ()+  modifySig      = modifySigQ . QName++  setExtrTyp     :: Name -> Expr -> m ()+  setExtrTyp     = setExtrTypQ . QName++-- Signature implementation ------------------------------------------++instance MonadSig TypeCheck where++  -- first in context, then in signature+  -- lookupSymbTyp :: Name -> TypeCheck TVal+  lookupSymbTyp n = do+    mdom <- errorToMaybe $ lookupName1 n+    case mdom of+      Just (CxtEntry dom udec) -> return (typ dom)+      Nothing -> symbTyp <$> lookupSymb n++  lookupSymbTypQ (QName n) = lookupSymbTyp n+  lookupSymbTypQ n@Qual{}  = symbTyp <$> lookupSymbQ n++  -- lookupSymb :: Name -> TypeCheck SigDef+  lookupSymb n = do+    cxt <- ask+    case Map.lookup n (mutualFuns cxt) of+      Just k  -> return $ k+      Nothing -> lookupSymbInSig (QName n)++  lookupSymbQ (QName n) = lookupSymb n+  lookupSymbQ n@Qual{}  = lookupSymbInSig n++  -- addSig :: Name -> SigDef -> TypeCheck ()+  addSigQ n def = traceSig ("addSig: " ++ show n ++ " is bound to " ++ show def) $do+    st <- get+    put $ st { signature = Map.insert n def $ signature st }++  -- modifySig :: Name -> (SigDef -> SigDef) -> TypeCheck ()+  modifySigQ n f = do+    st <- get+    put $ st { signature = Map.adjust f n $ signature st }++  -- setExtrTyp :: Name -> Expr -> TypeCheck ()+  setExtrTypQ n t = modifySigQ n (\ d -> d { extrTyp = t })++lookupSymbInSig :: QName -> TypeCheck SigDef+lookupSymbInSig n = lookupSig n =<< gets signature+    where+      -- lookupSig :: Name -> Signature -> TypeCheck SigDef+      lookupSig n sig =+        case (Map.lookup n sig) of+          Nothing -> throwErrorMsg $ "identifier " ++ show n ++ " not in signature "  ++ show (Map.keys sig)+          Just k -> return k+++-- more on the type checking monad -------------------------------++initSt :: TCState+initSt = TCState emptySig emptyMetaVars emptyConstraints emptyPosGraph -- emptyDots++initWithSig :: Signature -> TCState+initWithSig sig = initSt { signature = sig }++-- Meta-variable and constraint handling specification ---------------++class Monad m => MonadMeta m where+  resetConstraints :: m ()+  mkConstraint     :: Val -> Val -> m (Maybe Constraint)+  addMeta          :: Ren -> MVar -> m ()+  addLeq           :: Val -> Val -> m ()++  addLe            :: LtLe -> Val -> Val -> m ()+  addLe Le v1 v2 = addLeq v1 v2+  addLe Lt v1 v2 = addLeq (succSize v1) v2 -- broken for #++  solveConstraints :: m Solution++  -- solve constraints and substitute solution into the analyzed expressions+  solveAndModify   :: [Expr] -> Env -> m [Expr]+  solveAndModify es rho = do+        sol <- solveConstraints+        let es' = map (subst (solToSubst sol rho)) es+        resetConstraints+        return es'++-- Constraints implementation ----------------------------------------++instance MonadMeta TypeCheck where++  --resetConstraints :: TypeCheck ()+  resetConstraints = do+    st <- get+    put $ st { constraints = emptyConstraints }++  -- mkConstraint :: Val -> Val -> TypeCheck (Maybe Constraint)+  mkConstraint v (VMax vs) = do+    bs <- mapM (errorToBool . leqSize' v) vs+    if any id bs then return Nothing else+     throwErrorMsg $ "cannot handle constraint " ++ show v ++ " <= " ++ show (VMax vs)+  mkConstraint w@(VMax vs) v = throwErrorMsg $ "cannot handle constraint " ++ show w ++ " <= " ++ show v+  mkConstraint (VMeta i rho n) (VMeta j rho' m) = retret $ arc (Flex i) (m-n) (Flex j)+  mkConstraint (VMeta i rho n) VInfty      = retret $ arc (Flex i) 0 (Rigid (RConst Infinite))+  mkConstraint (VMeta i rho n) v           = retret $ arc (Flex i) (m-n) (Rigid (RVar j))+    where (j,m) = vGenSuccs v 0+  mkConstraint VInfty (VMeta i rho n)      = retret $ arc (Rigid (RConst Infinite)) 0 (Flex i)+  mkConstraint v (VMeta j rho m)           = retret $ arc (Rigid (RVar i)) (m-n) (Flex j)+    where (i,n) = vGenSuccs v 0+  mkConstraint v1 v2 = throwErrorMsg $ "mkConstraint undefined for " ++ show (v1,v2)++  -- addMeta k x  adds a metavariable which can refer to VGens < k+  -- addMeta :: Ren -> MVar -> TypeCheck ()+  addMeta ren i = do+    scope <- getSizeVarsInScope+    traceMetaM ("addMeta " ++ show i ++ " scope " ++ show scope)+    st <- get+    put $ st { metaVars = Map.insert i (MetaVar scope Nothing) (metaVars st)+             , constraints = NewFlex i (\ k' -> True) -- k' < k)+            -- DO NOT ADD constraints of form <= infty !!+            --               : arc (Flex i) 0 (Rigid (RConst Infinite))+                           : constraints st }++  -- addLeq :: Val -> Val -> TypeCheck ()+  addLeq v1 v2 = traceMeta ("Constraint: " ++ show v1 ++ " <= " ++ show v2) $+    do mc <- mkConstraint v1 v2+       case mc of+         Nothing -> return ()+         Just c -> do+           st <- get+           put $ st { constraints = c : constraints st }++  -- solveConstraints :: TypeCheck Solution+  solveConstraints = do+    cs <- gets constraints+    if null cs then return emptySolution+     else case solve cs of+        Just subst -> traceMeta ("solution" ++ show subst) $+                      return subst+        Nothing    -> throwErrorMsg $ "size constraints " ++ show cs ++ " unsolvable"+++nameOf :: EnvMap -> Int -> Maybe Name+nameOf [] j = Nothing+nameOf ((x,VGen i):rho) j | i == j = Just x+nameOf (_:rho) j = nameOf rho j++vGenSuccs (VGen k)  m = (k,m)+vGenSuccs (VSucc v) m = vGenSuccs v (m+1)+vGenSuccs v m = error $ "vGenSuccs fails on " ++ Util.parens (show v) ++ " " ++ show m++retret = return . return++sizeExprToExpr :: Env -> SizeExpr -> Expr+sizeExprToExpr rho (SizeConst Infinite) = Infty+sizeExprToExpr rho (SizeVar i n) | Just x <- nameOf (envMap rho) i = add (Var x) n+  where add e n | n <= 0 = e+                | otherwise = add (Succ e) (n-1)+sizeExprToExpr rho e@(SizeVar i n) | Nothing <- nameOf (envMap rho) i = error $ "panic: sizeExprToExpr " ++ Util.parens (show e) ++ ": variable v" ++ show i ++ " not in scope " ++ show (envMap rho)+++maxExpr :: [Expr] -> Expr+maxExpr [] = Infty+maxExpr [e] = e+maxExpr l = if Infty `elem` l then Infty else Max l++solToSubst :: Solution -> Env -> Subst+solToSubst sol rho = Map.map (maxExpr . map (sizeExprToExpr rho)) sol+++{-+solToSubst :: Solution -> Env -> Subst+solToSubst sol rho = Map.foldWithKey step Map.empty sol+  where step k (SizeVar i n) sub | Just x <- nameOf rho i =+           Map.insert k (add (Var x) n) sub+        step k (SizeConst Infinite) sub = Map.insert k Infty sub+        step _ _ sub = sub++        add e n | n <= 0 = e+                | otherwise = add (Succ e) (n-1)+-}++-- pattern to Value ----------------------------------------------++{- RETIRED+patternToVal :: Pattern -> TypeCheck Val+patternToVal p = do+  k <- getLen+  return $ fst (p2v k p)++-- turn a pattern into a value+-- dot patterns get variables corresponding to their flexible generic value+p2v :: Int -> Pattern -> (Val,Int)+p2v k p =+    case p of+      VarP n -> (VGen k,k+1)+      ConP co n [] -> (VCon co n,k)+      ConP co n pl -> let (vl,k') = ps2vs k pl+                      in (VApp (VCon co n) vl,k')+      SuccP p -> let (v,k') = p2v k p+                 in (VSucc v,k')+      DotP e -> (VGen k,k+1)++ps2vs :: Int -> [Pattern] -> ([Val],Int)+ps2vs k []  = ([],k)+ps2vs k (p:pl) = let (v,k') = p2v k p+                     (vl,k'') = ps2vs k' pl+                 in+                   (v:vl,k'')+-}
+ src/TCM.hs-boot view
@@ -0,0 +1,17 @@+module TCM where++-- import CallStack+import TraceError++import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Reader++data OneOrTwo a = One a | Two a a++data TCContext+data TCState++-- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO))+type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO))
+ src/Termination.hs view
@@ -0,0 +1,896 @@+{-# LANGUAGE ImplicitParams, PatternGuards #-}++module Termination where++import Prelude hiding (null)++import Data.Monoid+import Control.Monad.Writer -- (Writer, runWriter, tell, listen, Any(..), ...)++import Data.List as List hiding (null)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Foldable (Foldable, foldMap)+import qualified Data.Foldable as Foldable++import Debug.Trace++--import System++import Abstract+import TraceError+import Util++import Semiring+import qualified SparseMatrix as M++import TreeShapedOrder (TSO)+import qualified TreeShapedOrder as TSO++traceTerm msg a = a -- trace msg a+traceTermM msg = return () -- traceM msg+{-+traceTerm msg a = trace msg a+traceTermM msg = traceM msg+-}+++traceProg msg a =  a+traceProgM msg = return ()+{-+traceProg msg a = trace msg a+traceProgM msg = traceM msg+-}++-- cutoff:  How far can we count?+-- cutoff = 0 : decrease of -infty,0,1 (original SCT)+-- cutoff = 1 : "           -infty,-1,0,1,2+-- etc.+-- this is a parameter to the termination checker++cutoff :: Int+cutoff = 2  -- we can trace descend of 3, ascend of 2+++type Matrix a = M.Matrix Int a++empty :: Matrix a+empty = M.M (M.Size 0 0) []++-- greater numbers shall mean more information for the term.checker.+data Order = Decr Int -- positive numbers: decrease, neg. numbers: increase+           | Un       -- infinite increase (- infty)+           | Mat (Matrix Order) -- square matrices only (rows = call arguments, cols = parameters of caller)+           deriving (Show,Eq,Ord)++instance HasZero Order where+  zeroElement = Un++-- smart constructor+orderMat :: Matrix Order -> Order+orderMat m | M.isEmpty m                = Decr 0+           | Just o <- M.isSingleton m  = o+           | otherwise                  = Mat m+{-+orderMat []    = Decr 0   -- 0x0 Matrix = neutral element+orderMat [[o]] = o        -- 1x1 Matrix+orderMat oss   = Mat oss  -- nxn Matrix+-}++-- smart constructor+decr :: (?cutoff :: Int) => Int -> Order+decr i | i < - ?cutoff = Un+       | i > ?cutoff  = Decr (?cutoff + 1)+       | otherwise   = Decr i++-- present order in terms of <,<=,?+abstract :: Order -> Order+abstract (Decr k) | k > 0 = Decr 1+                  | k == 0 = Decr 0+                  | k < 0  = Un+abstract Un = Un+abstract (Mat m) = Mat $ absCM m++absCM :: Matrix Order -> Matrix Order+absCM = fmap abstract+-- absCM = map (map abstract)++-- the one is never needed for matrix multiplication+ordRing :: (?cutoff :: Int) => Semiring Order+ordRing = Semiring { add = maxO , mul = comp , zero = Un } -- , one = Decr 0 }++-- composition = sequence of calls+comp :: (?cutoff :: Int) => Order -> Order -> Order+comp _ Un = Un+comp Un _ = Un+comp (Decr k) (Decr l) = decr (k + l)+comp (Mat m1) (Mat m2) = if (composable m1 m2) then+                             Mat $ M.mul ordRing m1 m2+                         else+                             comp (collapse m1) (collapse m2)+comp (Decr 0) (Mat m) = Mat m+comp (Mat m) (Decr 0) = Mat m+comp o (Mat m) = comp o (collapse m)+comp (Mat m) o = comp (collapse m) o++maxO :: (?cutoff :: Int) => Order -> Order -> Order+maxO o1 o2 = case (o1,o2) of+               (Un,_) -> o2+               (_,Un) -> o1+               (Decr k, Decr l) -> Decr (max k l) -- cutoff not needed+               (Mat m1, Mat m2) -> if (sameSize m1 m2) then+                                       Mat $ M.add maxO m1 m2+                                   else+                                       maxO (collapse m1) (collapse m2)+               (Mat m1,_) -> maxO (collapse m1) o2+               (_,Mat m2) -> maxO o1 (collapse m2)++minO :: (?cutoff :: Int) => Order -> Order -> Order+minO o1 o2 = case (o1,o2) of+               (Un,_) -> Un+               (_,Un) -> Un+               (Decr k, Decr l) -> decr (min k l)+               (Mat m1, Mat m2) -> if (sameSize m1 m2) then+                                       Mat $ minM m1 m2+                                   else+                                       minO (collapse m1) (collapse m2)+               (Mat m1,_) -> minO (collapse m1) o2+               (_,Mat m2) -> minO o1 (collapse m2)++{-+-- for non empty lists:+minimumO :: (?cutoff :: Int) => [Order] -> Order+minimumO = foldl1 minO+-}++-- | pointwise minimum+minM :: (?cutoff :: Int) => Matrix Order -> Matrix Order -> Matrix Order+minM = M.intersectWith minO+{-+minM m1 m2 = [ minV x y | (x,y) <- zip m1 m2]+ where+   minV :: Vector Order -> Vector Order -> Vector Order+   minV v1 v2 = [ minO x y | (x,y) <- zip v1 v2]+-}++maxL :: (?cutoff :: Int) => [Order] -> Order+maxL = foldl1 maxO++minL :: (?cutoff :: Int) => [Order] -> Order+minL = foldl1 minO++{- collapse m++We assume that m codes a permutation:  each row has at most one column+that is not Un.++To collapse a matrix into a single value, we take the best value of+each column and multiply them.  That means if one column is all Un,+i.e., no argument relates to that parameter, than the collapsed value+is also Un.++This makes order multiplication associative.+++collapse :: (?cutoff :: Int) => Matrix Order -> Order+collapse m = foldl1 comp (map maxL (M.transpose m))++-}+++{- collapse m++We assume that m codes a permutation:  each row has at most one column+that is not Un.++To collapse a matrix into a single value, we take the best value of+each column and multiply them.  That means if one column is all Un,+i.e., no argument relates to that parameter, than the collapsed value+is also Un.++This makes order multiplication associative.++-}+collapse :: (?cutoff :: Int) => Matrix Order -> Order+collapse m = case M.toLists (M.transpose m) of+--   [] -> __IMPOSSIBLE__   -- This can never happen if order matrices are generated by the smart constructor+   m' -> foldl1 comp $ map (foldl1 maxO) m'++++type Vector a = [a]+type NaiveMatrix a = [Vector a]++---+-- matrix stuff++{-+data Semiring a = Semiring { add :: (a -> a -> a) , mul :: (a -> a -> a) , one :: a , zero :: a }+-}++ssum :: Semiring a -> Vector a -> a+ssum sem v = foldl (add sem) (zero sem) v++vadd :: Semiring a -> Vector a -> Vector a -> Vector a+vadd sem v1 v2 = [ (add sem) x y | (x,y) <- zip v1 v2]++scalarProdukt :: Semiring a -> Vector a -> Vector a -> a+scalarProdukt sem xs ys = ssum sem [(mul sem) x y  | (x,y) <- zip xs ys]++madd :: Semiring a -> NaiveMatrix a -> NaiveMatrix a -> NaiveMatrix a+madd sem m1 m2 = [ vadd sem x y | (x,y) <- zip m1 m2]++transp :: NaiveMatrix a -> NaiveMatrix a+transp [] = []+transp y = [[ z!!j | z<-y] | j<-[0..s]]+    where+    s = length (head y)-1++mmul :: Show a => Semiring a -> NaiveMatrix a -> NaiveMatrix a -> NaiveMatrix a+mmul sem m1 m2 = let m =+                         [[scalarProdukt sem r c | c <- transp m2] | r<-m1 ]+                 in m+diag :: NaiveMatrix a -> Vector a+diag [] = []+diag m = [ (m !! j) !! j | j <- [ 0..s] ]+   where+     s = length (head m) - 1++elems :: NaiveMatrix a -> Vector a+elems m = concat m++{-+ok :: Matrix a -> Matrix a -> Bool+ok m1 m2 = (length m1) == length m2+-}++sameSize :: Matrix a -> Matrix a -> Bool+sameSize m1 m2 = M.size m1 == M.size m2++composable :: Matrix a -> Matrix a -> Bool+composable m1 m2 = M.rows (M.size m1) == M.cols (M.size m2)++---++-- create a call matrix+-- each row is for one argument  of the callee+-- each column for one parameter of the caller+compareArgs :: (?cutoff :: Int) => TSO Name -> [Pattern] -> [Expr] -> Arity -> Matrix Order+compareArgs tso _ [] _ = empty+compareArgs tso [] _ _ = empty+compareArgs tso pl el ar_g =+  M.fromLists (M.Size { M.rows = fullArity ar_g , M.cols = length pl }) $+    map (\ e -> map (\ p -> --traceTerm ("comparing " ++ show e ++ " to " ++ show p) $+                                    compareExpr tso e p) pl) el+{-+compareArgs tso pl el ar_g =+        let+            diff = ar_g - length el+            fill = if diff > 0 then+                       replicate diff (replicate (length pl) Un)+                   else []+            cmp = map (\ e -> (map (\ p -> --traceTerm ("comparing " ++ show e ++ " to " ++ show p) $+                                    compareExpr tso e p) pl)) el+        in+          cmp ++ fill+-}++{-+compareExpr :: (?cutoff :: Int) => Expr -> Pattern -> Order+compareExpr e p =+   case (e,p) of+      (_,UnusableP _) -> Un+      (_,DotP e') -> case exprToPattern e' of+                       Nothing -> if e == e' then Decr 0 else Un+                       Just p' -> compareExpr e p'+      (Var i,p) -> traceTerm ("compareVar " ++ show i ++ " " ++ show p) $ compareVar i p+      (App (Var i) _,p) -> compareVar i p+      (Con _ n1,ConP _ n2 [])  | n1 == n2 -> Decr 0+      (App (Con _ n1) [e1],ConP _ n2 [p1]) | n1 == n2 -> compareExpr e1 p1+      (App (Con _ n1) args,ConP _ n2 pl) | n1 == n2 && length args == length pl ->+              Mat (map (\ e -> (map (compareExpr e) pl)) args)+              -- without extended order :  minL $ zipWith compareExpr args pl+      (Succ e2,SuccP p2) -> compareExpr e2 p2+      -- new cases for counting constructors+      (Succ e2,p) -> Decr (-1) `comp` compareExpr e2 p+      (App (Con _ n1) args@(_:_), p) -> Decr (-1) `comp` minL (map (\e -> compareExpr e p) args)+      _ -> Un+-}++++compareExpr :: (?cutoff :: Int) => TSO Name -> Expr -> Pattern -> Order+compareExpr tso e p =+  let ret o = traceTerm ("comparing expression " ++ show e ++ " to pattern " ++ show p ++ " returns " ++ show o) o in+    ret $ compareExpr' tso e p++compareExpr' :: (?cutoff :: Int) => TSO Name -> Expr -> Pattern -> Order+compareExpr' tso (Ann e) p = compareExpr' tso (unTag e) p+compareExpr' tso e p =+   case (conView $ spineView e, p) of+      (_,UnusableP _) -> Un+--      (Erased e,_)    -> compareExpr' tso e p+      (_,ErasedP p)   -> compareExpr' tso e p+      (_,DotP e') -> case exprToPattern e' of+                       Nothing ->  if e == e' then Decr 0 else Un+                       Just p' -> compareExpr' tso e p'+      ((Var i,_), p) -> -- traceTerm ("compareVar " ++ show i ++ " " ++ show p) $+                         compareVar tso i p+--      (Con _ n1,ConP _ n2 [])  | n1 == n2 -> Decr 0+--      (App (Con _ n1) [e1],ConP _ n2 [p1]) | n1 == n2 -> compareExpr' tso e1 p1+      ((Def (DefId (ConK _) n1),args),ConP _ n2 pl) | n1 == n2 && length args == length pl ->+          let os = zipWith (compareExpr' tso) args pl+          in  trace ("compareExpr (con/con case): os = " ++ show os) $+              if null os then Decr 0 else minL os+{- 2011-12-16 deactivate structured (matrix) orders+          orderMat $+            M.fromLists (M.Size { M.rows = length args, M.cols = length pl }) $+               map (\ e -> map (compareExpr' tso e) pl) args+              -- without extended order :  minL $ zipWith compareExpr' tso args pl+-}+      ((Succ e2,_),SuccP p2) ->  compareExpr' tso e2 p2+      -- new cases for counting constructors+      ((Succ e2,_),p) ->  Decr (-1) `comp` compareExpr' tso e2 p+      ((Def (DefId (ConK Cons) n1),args@(_:_)), p) ->  Decr (-1) `comp` minL (map (\e -> compareExpr' tso e p) args)+      ((Proj Post n1,[]), ProjP n2) | n1 == n2 -> Decr 0+      _ -> Un++conView (Record (NamedRec co n _ _) rs, es) = (Def (DefId (ConK co) n), map snd rs ++ es)+conView p = p++compareVar :: (?cutoff :: Int) => TSO Name -> Name -> Pattern -> Order+compareVar tso n p =+  let ret o = o in -- traceTerm ("comparing variable " ++ n ++ " to " ++ show p ++ " returns " ++ show o) o in+    case p of+      UnusableP _ -> ret Un+      ErasedP p   -> compareVar tso n p+      VarP n2 -> if n == n2 then Decr 0 else+        case TSO.diff n n2 tso of -- if n2 is the k-th father of n, then it is a decrease by k+          Nothing -> ret Un+          Just k -> ret $ decr k+      SizeP n1 n2 -> if n == n2 then Decr 0 else+        case TSO.diff n n2 tso of -- if n2 is the k-th father of n, then it is a decrease by k+          Nothing -> ret Un+          Just k -> ret $ decr k+      PairP p1 p2 -> maxL (map (compareVar tso n) [p1,p2])+         -- no decrease in pair:  ALT: comp (Decr 1) (...)+      ConP pi c (p:pl) | coPat pi == Cons ->+        comp (Decr 1) (maxL (map (compareVar tso n) (p:pl)))+      ConP{}   -> ret Un+      ProjP{}  -> ret Un+      SuccP p2 -> comp (Decr 1) (compareVar tso n p2)+      DotP e -> case (exprToPattern e) of+                    Nothing -> ret $ Un+                    Just p' -> compareVar tso n p'+      _ -> error $ "NYI: compareVar " ++ show n ++ " to " ++ show p -- ret $ Un++---++type Index = Name++data Call = Call { source :: Index , target :: Index , matrix :: CallMatrix }+            deriving (Eq,Show,Ord)++-- call matrix:+-- each row is for one argument  of the callee (target)+-- each column for one parameter of the caller (source)++type CallMatrix = Matrix Order++-- for two matrices m m' of the same dimensions,+-- m `subsumes` m'  if  pointwise the entries of m are smaller than of m'+subsumes :: Matrix Order -> Matrix Order -> Bool+subsumes m m' = M.all (uncurry leq) mm'+  where mm' = M.zip m m' -- create one matrix of pairs+{-+subsumes m m' = all (all (uncurry leq)) mm'+  where mm' = zipWith zip m m' -- create one matrix of pairs+-}++-- Order forms itself a partial order+leq :: Order -> Order -> Bool+leq Un _ = True+leq (Decr k) (Decr l) = k <= l+leq (Mat m) (Mat m') = subsumes m m'+leq _ _ = False++-- for two matrices m m' such that m `subsumes` m'+-- m `progress` m'  any positive entry in m' is smaller in m+progress :: Matrix Order -> Matrix Order -> Bool+progress m m' = M.any (uncurry decrToward0) mm'+  where mm' = M.zip m m' -- create one matrix of pairs+{-+progress m m' = any (any (uncurry decrToward0)) mm'+  where mm' = zipWith zip m m' -- create one matrix of pairs+-}++decrToward0 :: Order -> Order -> Bool+decrToward0 Un (Decr l) = True && l >= 0+decrToward0 (Decr k) (Decr l) = k < l  && l >= 0+decrToward0 (Mat m) (Mat m') = progress m m'+decrToward0 _ _ = False+++{- call pathes++  are lists of names of length >=2++  [f,g,h] = f --> g --> h+-}++newtype CallPath = CallPath { getCallPath :: [Name] } deriving Eq++instance Show CallPath where+  show (CallPath [g]) = show g+  show (CallPath (f:l)) = show f ++ "-->" ++ show (CallPath l)++emptyCP :: CallPath+emptyCP = CallPath []++mkCP :: Name -> Name -> CallPath+mkCP src tgt = CallPath [src, tgt]++mulCP :: CallPath -> CallPath -> CallPath+mulCP cp1@(CallPath one) cp2@(CallPath (g:two)) =+  if last one == g then CallPath (one ++ two)+  else error ("internal error: Termination.mulCP: trying to compose callpath " ++ show cp1 ++ " with " ++ show cp2)++compatibleCP :: CallPath -> CallPath -> Bool+compatibleCP (CallPath one) (CallPath two) = head one == head two && last one == last two++{-+addCP :: CallPath -> CallPath -> CallPath+addCP (CallPath []) cp = cp+addCP cp (CallPath []) = cp+addCP cp1 cp2 = if cp1 == cp2 then cp1 else error ("internal error: Termination.addCP: trying to blend non-equal callpathes " ++ show cp1 ++ " and " ++ show cp2)++cpRing :: Semiring CallPath+cpRing = Semiring { add = addCP , mul = mulCP , one = undefined , zero = emptyCP }+-}++-- composed calls++type CompCall = (CallPath, CallMatrix)++mulCC :: (?cutoff :: Int) => CompCall -> CompCall -> CompCall+mulCC cc1@(cp1, m1) cc2@(cp2, m2) = zipPair mulCP (flip (M.mul ordRing)) cc1 cc2++subsumesCC :: CompCall -> CompCall -> Bool+subsumesCC cc1@(cp1, m1) cc2@(cp2, m2) =+  if compatibleCP cp1 cp2 then m1 `subsumes` m2+   else error ("internal error: Termination.subsumesCC: trying to compare composed call " ++ show cc2 ++ " with " ++ show cc1)++progressCC :: CompCall -> CompCall -> Bool+progressCC cc1@(cp1, m1) cc2@(cp2, m2) = progress m1 m2+++{- call graph completion++organize call graph as a square matrix++  Name * Name -> Set CallMatrix++the completion process finds new calls by composing old calls.+There are two qualities of new calls.++  1) a completely new call or a call matrix in which one cell+     progressed from (Decr k | k > 0) towards -infty, i.e. a positive+     entry got smaller++  2) a negative entry got smaller++As long as 1-calls are found, continue completion.+[ I think 2-calls can be ignored when deciding whether to cont. ]++ -}++-- sets of call matrices++type CMSet    = [CompCall]  -- normal form: no CM subsumes another++cmRing :: (?cutoff :: Int) => Semiring CMSet+cmRing = Semiring { add = unionCMSet , mul = mulCMSet , zero = [] } -- one = undefined ,++type Progress = Writer Any+type ProgressH = Writer (Any, Any)++firstHalf = (Any True, Any False)+secondHalf = (Any False, Any True)++-- fullProgress = Sum 2+-- halfProgress = Sum 1++-- we keep CMSets always in normal form+-- progress reported if m is "better" than one of ms+-- progress can only be reported if m is being added, i.e., not subsumed+addCMh :: CompCall -> CMSet -> ProgressH CMSet+addCMh m [] = traceProg ("adding new call " ++ show m) $ do+  tell firstHalf+  return $ [m]+addCMh m (m':ms) =+  if m' `subsumesCC` m then traceTerm ("discarding new call " ++ show m) $+     return $ m':ms -- terminate early+   else do (ms', (Any h1, Any h2)) <- listen $ addCMh m ms+           when (h1 && not h2 && m `progressCC` m') $ do+             traceProgM ("progress made by " ++ show m ++ " over " ++ show m')+             tell secondHalf -- $ Any True+           if m `subsumesCC` m' then traceTerm ("discarding old call " ++ show m') $+                 return ms'+            else return $ m' : ms'++addCM' :: CompCall -> CMSet -> Progress CMSet+addCM' m ms = mapWriter (\(ms, (Any h1, Any h2)) -> (ms, Any $ h1 && h2)) (addCMh m ms)++-- progress is reported if one of ms is "better" than ms'+-- or if the oldset was empty and is no longer+-- unionCMSet' addition oldset+unionCMSet' :: CMSet -> CMSet -> Progress CMSet+unionCMSet' [] []  = return []+unionCMSet' ms []  = tell (Any True) >> return ms+unionCMSet' ms ms' = foldM (flip addCM') ms' ms++-- non-monadic versions+addCM :: CompCall -> CMSet -> CMSet+addCM m ms = fst $ runWriter (addCM' m ms)++unionCMSet :: CMSet -> CMSet -> CMSet+unionCMSet ms ms' = fst $ runWriter (unionCMSet' ms ms')++mulCMSet :: (?cutoff :: Int) => CMSet -> CMSet -> CMSet+mulCMSet ms ms' = foldl (flip addCM) [] $ [ mulCC m m' | m <- ms, m' <- ms' ]++{- call graph entries++type CGEntry = (CallPath, CMSet)++cgeRing :: Semiring CGEntry+cgeRing = Semiring { add = zipPair addCP unionCMSet,+                     mul = zipPair mulCP mulCMSet,+                     one = undefined,+                     zero = (emptyCP, []) }++addCGEntry' :: CGEntry -> CGEntry -> Progress CGEntry+addCGEntry' (cp1, ms1) (cp2, ms2) = do+  let cp = addCP cp1 cp2+  traceTermM ("call")+  ms <- unionCMSet' ms1 ms2+  return $ (cp, ms)+-}++-- call graphs++type CallGraph = NaiveMatrix CMSet -- CGEntry++stepCG :: (?cutoff :: Int) => CallGraph -> Progress CallGraph+stepCG cg = do+  traceProgM ("next iteration")+  traceProgM ("old cg " ++ show cg)+  traceProgM ("composed calls " ++ show cg')+  traceProgM ("adding new calls to callgraph...")+  zipWithM (zipWithM unionCMSet') cg' cg+  where cg' = mmul cmRing cg cg++{- "each idempotent call f->f has a decreasing arg" is an invariant+   of good call graphs.  Thus, we can stop call graph completion+   as soon as we see it violated.++   "idempotent" is defined on abstracted call matrices, i.e.,+   those that only have <, <=, ? and are not counting.+ -}+complCGraph :: (?cutoff :: Int) => CallGraph -> CallGraph+complCGraph cg =+  let (cg', Any prog) = runWriter $ stepCG cg+  in  if prog && checkAll cg' then complCGraph cg' else cg'++checkAll :: (?cutoff :: Int) => CallGraph -> Bool+checkAll cg = all (all (checkIdem . snd)) $ diag cg++-- each idempotent call needs a decreasing diagonal entry+checkIdem :: (?cutoff :: Int) => CallMatrix -> Bool+checkIdem cm =+  let cm'   = M.mul ordRing cm cm+      eqAbs = (absCM cm) == (absCM cm')+      d     = M.diagonal cm+  in  traceTerm ("checkIdem: cm = " ++ show cm ++ " cm' = " ++ show cm ++ " eqAbs = " ++ show eqAbs ++ " d = " ++ show d) $+      -- if cm `subsumes` cm'+      if eqAbs+       then any isDecr d else True++{- generate a call graph from a list of names and list of calls+1. group calls by source, obtaining a list of row+-}++{- THIS IS WRONG:+makeCG :: [Name] -> [Call] -> CallGraph+makeCG names calls = map (\ tgt -> mkRow tgt [ c | c <- calls, target c == tgt ]) names+  where mkRow tgt calls = map (\ src ->  unionCMSet [ (mkCP src tgt, matrix c) | c <- calls, source c == src ] []) names+-}++makeCG :: [Name] -> [Call] -> CallGraph+makeCG names calls = map (\ src -> mkRow src [ c | c <- calls, source c == src ]) names+  where mkRow src calls = map (\ tgt ->  unionCMSet [ (mkCP src tgt, matrix c) | c <- calls, target c == tgt ] []) names++{-+callComb :: Call -> Call -> Call+callComb (Call s1 t1 m1) (Call s2 t2 m2) = Call s2 t1 (mmul ordRing m1 m2)++cgComb :: [Call] -> [Call] -> [Call]+cgComb cg1 cg2 = [ callComb c1 c2 | c1 <- cg1 , c2 <- cg2 , (source c1 == target c2)]++complete :: [Call] -> [Call]+complete cg = traceTerm ("call graph: " ++ show cg) $+  let cg' = complete' cg -- $ Set.fromList cg+  in -- traceTerm ("complete " ++ show cg')+       cg' -- Set.toList cg'++complete' :: [Call] -> [Call]  -- Set Call -> Set Call+complete' cg =+              let cgs = Set.fromList cg+                  cgs' = Set.union cgs (Set.fromList $ cgComb cg cg )+                  cg' = Set.toList cgs'+              in+                if (cgs == cgs') then cg else complete' cg'++checkAll :: [Call] -> Bool+checkAll x = all checkIdem x++-- each idempotent call needs a decreasing diagonal entry+checkIdem :: Call -> Bool+checkIdem c = let cc = callComb c c+                  d = diag (matrix cc)+                  containsDecr = any isDecr d+              in (not (c == cc)) || containsDecr+-}+isDecr :: Order -> Bool+isDecr o = case o of+             (Decr k) -> k > 0+             (Mat m) -> any isDecr (M.diagonal m)+             _ -> False+++-------------------++-- top level function+terminationCheck :: MonadAssert m => [Fun] -> m ()+terminationCheck funs = do+       let ?cutoff = cutoff+       traceTermM $ "terminationCheck " ++ show funs+       let tl = terminationCheckFuns funs+       let nl = map fst tl+       let bl = map snd tl+       let nl2 = [ n | (n,b) <- tl , b == False ]+       case (and bl) of+            True -> return ()+            False -> case nl of+                    [f] -> recoverFail ("Termination check for function " ++ show f ++ " fails ")+                    _   -> recoverFail ("Termination check for mutual block " ++ show nl ++ " fails for " ++ show nl2)+++terminationCheckFuns :: (?cutoff :: Int) => [Fun] -> [(Name,Bool)]+terminationCheckFuns funs =+   let namar = map (\ (Fun (TypeSig n _) _ ar _) -> (n, ar)) funs+               -- collectNames funs+       names = map fst namar+       cg0 = collectCGFunDecl namar funs+   in sizeChangeTermination names cg0++sizeChangeTermination :: (?cutoff :: Int) => [Name] -> [Call] -> [(Name,Bool)]+sizeChangeTermination names cg0 =+   let cg1 = makeCG names cg0+       cg = complCGraph $ cg1+       beh = zip names $ map (all (checkIdem . snd)) $ diag cg+   in traceTerm ("collected names: " ++ show names) $+      traceTerm ("call graph: " ++ show cg0) $+      traceTerm ("normalized call graph: " ++ show cg1) $+      traceTerm ("completed call graph: " ++ show cg) $+      traceTerm ("recursion behaviours" ++ show beh) $+      beh+++{-+terminationCheckFuns :: [ (TypeSig,[Clause]) ] -> [(Name,Bool)]+terminationCheckFuns funs =+    let beh = recBehaviours funs+    in+      traceTerm ("recursion behaviours" ++ show beh) $+        zip (map fst beh) (map (checkAll . snd ) beh )++-- This is the main driver.+recBehaviours :: [ (TypeSig,[Clause]) ] -> [(Name,[Call])]+recBehaviours funs = let names = map fst $ collectNames funs+                         cg0 = collectCGFunDecl funs+                         cg = complete cg0+                     in traceTerm ("collected names: " ++ show names) $+                        traceTerm ("call graph: " ++ show cg0) $+                        groupCalls names [ c | c <- cg , (target c == source c) ]+++groupCalls :: [Name] -> [Call] -> [(Name,[Call])]+groupCalls [] _ = []+groupCalls (n:nl) cl = (n, [ c | c <- cl , (source c == n) ]) : groupCalls nl cl+-}++{-+ccFunDecl :: [ ( TypeSig,[Clause]) ] -> [Call]+ccFunDecl funs = complete $ collectCGFunDecl funs+-}++collectCGFunDecl :: (?cutoff :: Int) => [(Name,Arity)] -> [Fun] -> [Call]+collectCGFunDecl names funs =+      concatMap (collectClauses names) funs+          where+            collectClauses :: [(Name,Arity)] -> Fun -> [Call]+            collectClauses names (Fun (TypeSig n _) _ ar cll) = collectClause names n cll+            collectClause :: [(Name,Arity)] -> Name -> [Clause] -> [Call]+            collectClause names n ((Clause _ pl Nothing):rest) = collectClause names n rest+            collectClause names n ((Clause _ pl (Just rhs)):rest) =+              traceTerm ("collecting calls in " ++ show rhs) $+                (collectCallsExpr names n pl rhs) ++ (collectClause names n rest)+            collectClause names n [] = []++{- RETIRED+arity :: [Clause] -> Int+arity [] = 0+arity (Clause pl e:l) = length pl+-}++{- RETIRED (map)+collectNames :: [Fun] -> [(Name,Arity)]+collectNames [] = []+collectNames (Fun (TypeSig n _) ar cls : rest) = (n,ar) : (collectNames rest)+-}++-- | harvest i > j  from  case i { $ j -> ...}+tsoCase :: TSO Name -> Expr -> [Clause] -> TSO Name+tsoCase tso (Var x) [Clause _ [SuccP (VarP y)] _] = TSO.insert y (1,x) tso+tsoCase tso _ _ = tso++-- | harvest i < j  from (i < j) -> ... or (i < j) & ...+tsoBind :: TSO Name -> TBind -> TSO Name+tsoBind tso (TBind x (Domain (Below ltle (Var y)) _ _)) = TSO.insert x (n ltle,y) tso+  where n Lt = 1+        n Le = 0+tsoBind tso _ = tso++collectCallsExpr :: (?cutoff :: Int) => [(Name,Arity)] -> Name -> [Pattern] -> Expr -> [Call]+collectCallsExpr nl f pl e = traceTerm ("collectCallsExpr " ++ show e) $+  loop tso e where+    tso = tsoFromPatterns pl+    loop tso (Ann e) = loop tso (unTag e)+    loop tso e = headcalls ++ argcalls where+      (hd, args) = spineView e -- $ ignoreTopErasure e+      argcalls = concatMap (loop tso) args+      headcalls = case hd of+          (Def (DefId FunK (QName g))) ->+              case lookup g nl of+                Nothing -> []+                Just ar_g ->+                  traceTerm ("found call from " ++ show f ++ " to " ++ show g) $+                             let (Just ar_f) = lookup f nl+                                 (Just f') = List.elemIndex (f,ar_f) nl+                                 (Just g') = List.elemIndex (g,ar_g) nl+                                 m = compareArgs tso pl args ar_g+                                 cg = Call { source = f+                                           , target = g+                                           , matrix = m }+                             in+                               traceTerm ("found call " ++ show cg) $+                                 [cg]+          (Case e _ cls) -> loop tso e ++ concatMap (loop (tsoCase tso e cls)) (map (maybe Irr id . clExpr) cls)+          (Lam _ _ e1) -> loop tso e1+          (LLet tb tel e1 e2) | null tel->+             (loop tso e1) ++ -- type won't get evaluated+             (loop tso e2)+          (Quant _ tb@(TBind x dom) e2) -> (loop tso (typ dom)) ++ (loop (tsoBind tso tb) e2)+          (Quant _ (TMeasure mu) e2) -> Foldable.foldMap (loop tso) mu ++ (loop tso e2)+          (Quant _ (TBound beta) e2) -> Foldable.foldMap (loop tso) beta ++ (loop tso e2)+          (Below ltle e) -> loop tso e+          (Sing e1 e2) -> (loop tso e1) ++ (loop tso e2)+          (Pair e1 e2) -> (loop tso e1) ++ (loop tso e2)+          (Succ e) -> loop tso e+          (Max es) -> concatMap (loop tso) es+          (Plus es) -> concatMap (loop tso) es+          Sort (SortC{})  -> []+          Sort (Set e)    -> loop tso e+          Sort (CoSet e)  -> loop tso e+          Var{}   -> []+          Zero{} -> []+          Infty{} -> []+          Def{}   -> []+          Irr{}   -> []+          Proj{}   -> []+          Record ri rs -> Foldable.foldMap (loop tso . snd) rs+          Ann e1 -> loop tso (unTag e1)+--          Con{}   -> []+--          Let{}   -> []+          Meta{}  -> error $ "collect calls in unresolved meta variable " ++ show e+          _ -> error $ "NYI: collect calls in " ++ show e++{-+collectCallsExpr :: (?cutoff :: Int) => [(Name,Int)] -> Name -> [Pattern] -> Expr -> [Call]+collectCallsExpr nl f pl e =+  traceTerm ("collectCallsExpr " ++ show e) $+    case e of+      (App (Def g) args) ->+        let calls = concatMap (collectCallsExpr nl f pl) args+            gIn = lookup g nl+        in+         traceTerm ("found call from " ++ f ++ " to " ++ g) $+          case gIn of+            Nothing -> calls+            Just ar_g -> let (Just ar_f) = lookup f nl+                             (Just f') = List.elemIndex (f,ar_f) nl+                             (Just g') = List.elemIndex (g,ar_g) nl+                             m = compareArgs pl args ar_g+                             cg = Call { source = f+                                       , target = g+                                       , matrix = m }+                         in+                           traceTerm ("found call " ++ show cg) $+                             cg:calls+      (Def g) ->  collectCallsExpr nl f pl (App (Def g) [])+      (App e args) -> concatMap (collectCallsExpr nl f pl) (e:args)+      (Case e cls) -> concatMap (collectCallsExpr nl f pl) (e:map clExpr cls)+      (Lam _ _ e1) -> collectCallsExpr nl f pl e1+      (LLet _ e1 t1 e2) ->  (collectCallsExpr nl f pl e1) ++ -- type won't get evaluated+                            (collectCallsExpr nl f pl e2)+      (Pi _ _ e1 e2) -> (collectCallsExpr nl f pl e1) +++                              (collectCallsExpr nl f pl e2)+      (Sing e1 e2) -> (collectCallsExpr nl f pl e1) +++                              (collectCallsExpr nl f pl e2)+      (Succ e1) -> collectCallsExpr nl f pl e1+      Sort{}  -> []+      Var{}   -> []+      Infty{} -> []+      Con{}   -> []+      Let{}   -> []+      Meta{}  -> error $ "collect calls in unresolved meta variable " ++ show e+      _ -> error $ "NYI: collect calls in " ++ show e+-}++----------------------------------------------------------------------+{- Foetus II - Counting Lexicographic Termination (delta-Foetus)++delta-SCT [Ben-Amram 2006] is too inefficient, at least with the bound+given in the paper.++  B(G) = (k + 1)2^k · m^2 · 2^(2k+1) (m∆)^(3k+1) (k + 1)^(3k^2+3k+1)++is an upper bound on the length of the longest path to be looked at to+exclude non-termination.++I guess that both argument permutation and counting is not very+common.  So an approach would be++- try to show termination with SCT+- try to show termination with delta-Foetus++Call graph completion in delta-Foetus++1. Iterate as long new simple cycles show up (i.e. cycles with no subcycles)++2. Find the possible lexicographic termination orders to for each function++3. Continue iterating while any of the arguments involved in any of the termination orders gets worse.  Some termination order hypotheses might collapse.++4. Stop when all hypotheses have collapsed (FAIL) or when no standing hypotheses gets any worse (SUCCESS).++Implementation:++After 1. save for each function and each of its arguments the worst+recursive behavior in any of the calls.  This map will be used to+monitor progress.+++Careful:++  f x = f (x-1) | g (x - 100)+  g x = g (x+1) | f (x - 100)++Bad call f->f only found after 201 iterations of g!++Idea:  regular expressions over call matrices!++  (m1 + m2^*)^*++-}
+ src/ToHaskell.hs view
@@ -0,0 +1,292 @@+module ToHaskell where++{- type-directed extraction of Haskell programs with a lot of unsafeCoerce++Examples:+---------++MiniAgda++  data Vec (A : Set) : Nat -> Set+  { vnil  : Vec A zero+  ; vcons : [n : Nat] -> (head : A) -> (tail : Vec A n) -> Vec A (suc n)+  }++  fun length : [A : Set] -> [n : Nat] -> Vec A n -> <n : Nat>+  { length .A .zero    (vnil A)         = zero+  ; length .A .(suc n) (vcons A n a as) = suc (length A n as)+  }++Haskell++  {-# LANGUAGE NoImplicitPrelude #-}+  module Main where+  import qualified Text.Show as Show++  data Vec (a :: *)+    = Vec_vnil+    | Vec_vcons { vec_head :: a , vec_tail :: Vec a }+      deriving Show.Show++  length :: forall a. Vec a -> Nat+  length  Vec_vnil        = Nat_zero+  length (Vec_vcons a as) = Nat_suc (length as)++Components:+-----------++Translation from MiniAgda identifiers to Haskell identifiers++-}++import Prelude hiding (null)++import Data.Char++import Control.Applicative+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Traversable as Trav++import qualified Language.Haskell.Exts.Syntax as H+import Text.PrettyPrint++import Polarity+import Abstract+import Extract+import qualified HsSyntax as H+import TraceError+import Util++-- translation monad++type Translate = StateT TState (ReaderT TContext (ExceptT TraceError IO))++{- no longer needed with mtl-2+instance Applicative Translate where+  pure      = return+  mf <*> ma = do { f <- mf; a <- ma; return (f a) }+-}++data TState = TState++initSt :: TState+initSt = TState++data TContext = TContext++initCxt :: TContext+initCxt = TContext++runTranslate :: Translate a -> IO (Either TraceError a)+runTranslate t = runExceptT (runReaderT (evalStateT t initSt) initCxt)++-- translation++translateModule :: [EDeclaration] -> Translate (H.Module)+translateModule ds = do+  hs <- translateDecls ds+  return $ H.mkModule hs++translateDecls :: [EDeclaration] -> Translate [H.Decl]+translateDecls ds = concat <$> mapM translateDecl ds++translateDecl :: EDeclaration -> Translate [H.Decl]+translateDecl d =+  case d of+    MutualDecl _ ds -> translateDecls ds+    OverrideDecl{} -> throwErrorMsg $ "translateDecls internal error: overrides impossible"+    MutualFunDecl _ _ funs -> translateFuns funs+    FunDecl _ fun -> translateFun fun+    LetDecl _ x tel (Just t) e | null tel -> translateLet x t e+    DataDecl n _ _ _ tel fkind cs _ -> translateDataDecl n tel fkind cs++translateFuns :: [Fun] -> Translate [H.Decl]+translateFuns funs = concat <$> mapM translateFun funs++translateFun :: Fun -> Translate [H.Decl]+translateFun (Fun ts@(TypeSig n t) n' ar cls) = do+  ts@(H.TypeSig _ [n] t) <- translateTypeSig ts+  cls <- concat <$> mapM (translateClause n) cls+  return [ts, H.FunBind cls]++translateLet :: Name -> Type -> FExpr -> Translate [H.Decl]+translateLet n t e+  | isEtaAlias n = return []  -- skip internal decls+  | otherwise = do+      ts <- translateTypeSig $ TypeSig n t+      e  <- translateExpr e+      n  <- hsName (DefId LetK $ QName n)+      return [ ts, H.mkLet n e ]++translateTypeSig :: TypeSig -> Translate H.Decl+translateTypeSig (TypeSig n t) = do+  n <- hsName (DefId LetK $ QName n)+  t <- translateType t+  return $ H.mkTypeSig n t++translateDataDecl :: Name -> FTelescope -> FKind -> [FConstructor] -> Translate [H.Decl]+translateDataDecl n tel k cs = do+  n   <- hsName (DefId DatK $ QName n)+  tel <- translateTelescope tel+  let k' = translateKind k+  cs  <- mapM translateConstructor cs+  return [H.mkDataDecl n tel k' cs]++translateConstructor :: FConstructor -> Translate H.GadtDecl+translateConstructor (Constructor n pars t) = do+  n  <- hsName (DefId (ConK Cons) n)+  t' <- translateType t+  return $ H.mkConDecl n t'++translateClause :: H.Name -> Clause -> Translate [H.Match]+translateClause n (Clause _ ps (Just rhs)) = do+  ps <- mapM translatePattern ps+  rhs <- translateExpr rhs+  return [H.mkClause n ps rhs]++translateTelescope :: FTelescope -> Translate [H.TyVarBind]+translateTelescope (Telescope tel) = mapM translateTBind tel'+  -- throw away erasure marks+  where tel' = filter (\ tb -> not $ erased $ decor $ boundDom tb) tel++translateTBind :: TBind -> Translate H.TyVarBind+translateTBind (TBind x dom) = do+  x <- hsVarName x+  return $ H.KindedVar x $ translateKind (typ dom)++translateKind :: FKind -> H.Kind+translateKind k =+  case k of+    k | k == star -> H.KindStar+    Quant Pi (TBind _ dom) k' | erased (decor dom) -> translateKind k'+    Quant Pi (TBind _ dom) k' ->+      translateKind (typ dom) `H.mkKindFun` translateKind k'++translateType :: FType -> Translate H.Type+translateType t =+  case t of++    Irr -> return $ H.unit_tycon++    Quant piSig (TBind _ dom) b | not (erased (decor dom)) ->+      H.mkTyPiSig piSig <$> translateType (typ dom) <*> translateType b++    Quant Pi (TBind _ dom) b | typ dom == Irr -> translateType b++    Quant Pi (TBind x dom) b -> do+      x <- hsVarName x+      let k = translateKind (typ dom)+      -- todo: add x to context+      t <- translateType b+      return $ H.mkForall x k t++    App f a -> H.mkTyApp <$> translateType f <*> translateType a++    Def d@(DefId DatK n) -> (H.TyCon . H.UnQual) <$> hsName d++    Var x -> H.TyVar <$> hsVarName x++    _ -> return H.unit_tycon++{- TODO:+    _ -> throwErrorMsg $ "no Haskell representation for type " ++ show t+ -}++translateExpr :: FExpr -> Translate H.Exp+translateExpr e =+  case e of++    Var x -> H.mkVar <$> hsVarName x++    -- constructors+    Def f@(DefId (ConK{}) n) -> H.mkCon <$> hsName f++    -- function identifiers+    Def f@(DefId _ n) -> H.mkVar <$> hsName f++    -- discard type arguments+    App f e0 -> do+      f <- translateExpr f+      let (er, e) = isErasedExpr e0+      if er then return f else H.mkApp f <$> translateExpr e++    -- discard type lambdas+    Lam dec y e -> do+      y <- hsVarName y+      e <- translateExpr e+      return $ if erased dec then e else H.mkLam y e++    LLet (TBind x dom) tel e1 e2 | null tel-> do+      x  <- hsVarName x+      e2 <- translateExpr e2+      if erased (decor dom) then return e2 else do+        t  <- Trav.mapM translateType (typ dom)+        e1 <- translateExpr e1+        return $ H.mkLLet x t e1 e2++    Pair e1 e2 -> H.mkPair <$> translateExpr e1 <*> translateExpr e2++    -- TODO++    Ann (Tagged [Cast] e) -> H.mkCast <$> translateExpr e++    _ -> return $ H.unit_con++translatePattern :: Pattern -> Translate H.Pat+translatePattern p =+  case p of+    VarP y       -> H.PVar <$> hsVarName y+    PairP p1 p2  -> H.PTuple H.Boxed <$> mapM translatePattern [p1,p2]+    ConP pi n ps ->+       H.PApp <$> (H.UnQual <$> hsName (DefId (ConK $ coPat pi) n))+              <*> mapM translatePattern ps++{-+Name translation++  data names        : check capitalization, identity translation+  constructor names : prefix with Dataname_+  destructor names  : ditto+  type-valued lets  : check capitalization, identity+  type-valued funs  : reject!+  lets              : check lowercase+  funs/cofuns       : check lowercase+-}++hsVarName :: Name -> Translate H.Name+hsVarName x = return $ H.Ident $ show x++hsName :: DefId -> Translate H.Name+hsName id = enter ("error translating identifier " ++ show id) $+  case id of+  (DefId DatK (QName x)) -> do+    let n = suggestion x+    unless (isUpper $ head n) $+      throwErrorMsg $ "data names need to be capitalized"+    return $ H.Ident n+  (DefId (ConK co) (Qual d x)) -> do+    let n = suggestion x+        m = suggestion d+    return $ H.Ident $ m ++ "_" ++ n+    -- dataName <- getDataName x+    -- return $ H.Ident $ dataName ++ "_" ++ n+  -- lets, funs, cofuns. TODO: type-valued funs!+--   (DefId Let ('_':n)) | -> return $ H.Ident n+  (DefId _ x) -> do+    let n = suggestion $ unqual x+{- ignore for now+     unless (isLower $ head n) $+       throwErrorMsg $ "function names need to start with a lowercase letter"+ -}+    return $ H.Ident n++-- getDataName constructorName = return dataNamec+getDataName :: Name -> Translate String+getDataName n = return "DATA"
+ src/Tokens.hs view
@@ -0,0 +1,29 @@+module Tokens where++data Token +  = Id String+  | Data+  | Fun+  | Def+  | Mutual+  | Pattern+  | Set+  | Case+  -- size type+  | Size+  | Infty+  | Succ+  --+  | BrOpen+  | BrClose+  | PrOpen+  | PrClose+  | Sem+  | Col+  | Arrow+  | Eq+  | Lam+  | UScore+  | NotUsed -- so happy doesn't generate overlap case pattern warning+    deriving (Eq,Ord,Show)+
+ src/TraceError.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}++module TraceError where++import Control.Monad.Except+import Debug.Trace++import Util+import Text.PrettyPrint++data TraceError = Err String | TrErr String TraceError++-- instance Error TraceError where+--     noMsg = Err "no message"+--     strMsg s = Err s++instance Show TraceError where+    show (Err str) = str+    show (TrErr str err) = str ++ "\n/// " ++ show err++throwErrorMsg m = throwError (Err m)++-- newErrorMsg :: (MonadError TraceError m) => m a -> String -> m a+newErrorMsg c s = c `catchError` (\ _ -> throwErrorMsg s)+-- addErrorMsg c s = c `catchError` (\ s' -> throwErrorMsg (s' ++ "\n" ++ s))++-- extend the current error message by n+throwTrace x n = x `catchError` ( \e -> throwError $ TrErr n e)+enter n x = throwTrace x n+enterTrace n x = trace n $ throwTrace x n+enterShow n = enter (show n)++enterDoc :: (MonadError TraceError m, Pretty d) => m d -> m a -> m a+enterDoc md cont = do+  d <- md+  enter (render (pretty d)) cont++failDoc :: (MonadError TraceError m) => m Doc -> m a+failDoc d = throwErrorMsg . render =<< d++newErrorDoc :: (MonadError TraceError m) => m a -> m Doc -> m a+newErrorDoc c d = c `catchError` (\ _ -> failDoc d)++errorToMaybe :: (MonadError e m) => m a -> m (Maybe a)+errorToMaybe m = (m >>= return . Just) `catchError` (const $ return Nothing)++errorToBool :: (MonadError e m) => m () -> m Bool+errorToBool m = (m >> return True) `catchError` (\ _ -> return False)++boolToErrorDoc :: (MonadError TraceError m) => m Doc -> Bool -> m ()+boolToErrorDoc d True  = return ()+boolToErrorDoc d False = failDoc d++boolToError :: (MonadError TraceError m) => String -> Bool -> m ()+boolToError msg True  = return ()+boolToError msg False = throwErrorMsg msg++instance MonadError () Maybe where+  catchError Nothing k = k ()+  catchError (Just a) k = Just a+  throwError () = Nothing++orM :: (MonadError e m) => m a -> m a -> m a+orM m1 m2 = m1 `catchError` (const m2)++-- recoverable errors++data AssertionHandling = Failure | Warning | Ignore+                       deriving (Eq,Ord,Show)++assert' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> String -> m ()+assert' Ignore b s      = return ()+assert' h True s        = return ()+assert' Warning False s = liftIO $ putStrLn $ "warning: ignoring error: " ++ s+assert' Failure False s = throwErrorMsg s++assertDoc' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> m Doc -> m ()+assertDoc' h b md = assert' h b . render =<< md++class Monad m => MonadAssert m where+  assert :: Bool -> String -> m ()+  assertDoc :: Bool -> m Doc -> m ()+  assertDoc b md = assert b . render =<< md+  newAssertionHandling :: AssertionHandling -> m a -> m a+  recoverFail :: String -> m ()+  recoverFail = assert False+  recoverFailDoc :: m Doc -> m ()+  recoverFailDoc = assertDoc False++{-+assert' :: (MonadIO m) => AssertionHandling -> Bool -> String -> m a -> m a+assert' Ignore b s k = k+assert' h True s k = k+assert' Warning False s k = do+  liftIO $ putStrLn s+  k+assert' Failure False s k = fail s++class Monad m => MonadAssert m where+  assert :: Bool -> String -> m a -> m a+  newAssertionHandling :: AssertionHandling -> m a -> m a+-}
+ src/TreeShapedOrder.hs view
@@ -0,0 +1,164 @@+{- A data structure to represent a forest of upside down trees,+similar to union-find.  The idea is to manage a tree-shaped form of+strict inequations++  i1 > i2 > i3+     > j2 > j3 > j4 > j5+          > k3+          > l3 > l4++  m1 > m2++  n1++Checking inequalty x < y is then performed by just enumerating the+parents of x and checking wether y is a member of it.++2010-11-12 UPDATE: We generalize this to ">=" and more by attaching to+each link a non-negative number.++  0  means  >=+  1  means  >+  n  means  at least n units greater+-}++module TreeShapedOrder where++import Prelude hiding (null)+import Data.List hiding (insert, null) -- groupBy++import Data.Map (Map)+import qualified Data.Map as Map++import Data.Tree (Tree(..), Forest) -- rose trees+import qualified Data.Tree as Tree++import Util -- headM++-- | Tree-structured partial orders.+--   Represented as maps from children to parents plus a non-negative distance.+newtype TSO a = TSO { unTSO :: Map a (Int,a) } deriving (Eq, Ord)++-- | Empty TSO.+empty :: TSO a+empty = TSO $ Map.empty++-- | @insert a b o@  inserts a with parent b into order o.+-- It does not check whether the tree structure is preserved.+insert :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> TSO a+insert a b (TSO o) = TSO $ Map.insert a b o++-- | Construction from a list of child-distance-parent tuples.+fromList :: (Ord a, Eq a) => [(a,(Int,a))] -> TSO a+fromList l = foldl (\ o (a,b) -> insert a b o) empty l++-- | @parents a0 o = [(d1,a1),..,(dn,an)]@ lists the parents of @a0@ in order,+-- i.e., a(i+1) is parent of a(i) with distance d(i+1).+parents :: (Ord a, Eq a) => a -> TSO a -> [(Int,a)]+parents a (TSO o) = loop (Map.lookup a o) where+  loop Nothing  = []+  loop (Just (n,b)) = (n,b) : loop (Map.lookup b o)++-- | @parent a o@ returns the immediate parent, if it exists.+parent :: (Ord a, Eq a) => a -> TSO a -> Maybe (Int,a)+parent a t = headMaybe $ parents a t++-- | @isAncestor a b o = Just n@ if there are n steps up from a to b.+isAncestor :: (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int+isAncestor a b o = loop 0 ((0,a) : parents a o)+   where loop acc [] = Nothing+         loop acc ((n,a) : ps) | a == b    = Just (acc + n)+                               | otherwise = loop (acc + n) ps++-- | @diff a b o = Just k@ if there are k steps up from a to b+-- or (-k) steps down from b to a.+diff ::  (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int+diff a b o = maybe (fmap (\ k -> -k) $ isAncestor b a o) Just $ isAncestor a b o++-- | create a map from parents to list of sons, leaves have an empty list+invert :: (Ord a, Eq a) => TSO a -> Map a [(Int,a)]+invert (TSO o) = Map.foldrWithKey step Map.empty o where+  step son (dist, parent) m = Map.insertWith (++) son [] $+    Map.insertWith (++) parent [(dist, son)] m++-- | @height a t = Just k@ if $k$ is the length of the+--   longest path from @a@ to a leaf. @Nothing@ if @a@ not in @t@.+height :: (Ord a, Eq a) => a -> TSO a -> Maybe Int+height a t = do+  let m = invert t+  let loop parent = do+        sons <- Map.lookup parent m+        return $ if null sons then 0 else+                  maximum $ map (\ (n,son) -> maybe 0 (n +) $ loop son) sons+  loop a++-- | @increasesHeight a (n,b) t = True@ if @n > height b t@, i.e., if+--   the insertion of a with parent b will destroy an existing+--   minimal valuation of @t@+increasesHeight :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> Bool+increasesHeight a (n,b) t = n > maybe 0 id (height b t)++-- | get the leaves of the TSO forest+leaves :: (Ord a, Eq a) => TSO a -> [a]+leaves o = map fst $ filter (\ (parent,sons) -> null sons) $ Map.toList (invert o)++{- FLAWED BOTTOM-UP-ATTEMPT, DOES NOT WORK+{- How to invert a TSO?++1. Create a Map from parents to their list of children.++2. Keep a working set of nodes.+   Find the leafs in this working set (nodes that do not have children).+   Cluster them by their parents.+   Turn their parents into trees,+   Continue with the parents.+-}+-- | invert a tree shaped order into a forest.  This can be used for printing+toForest :: (Ord a, Eq a) => TSO a -> Forest a+toForest o = loop (step initialTrees) where+  initialTrees = map (flip Node []) $ leaves o+  -- step :: (Ord a, Eq a) => Forest a -> [(Maybe a, Forest a)]+  step ts = map (\ l -> (fst (head l), map snd l)) $+    groupBy (\ (p,t) (p',t') -> p == p') $+    sortBy (\ (p,t) (p',t') -> compare p p') $+    map (\ t -> (parent (rootLabel t) o, t)) ts+  -- loop :: (Ord a, Eq a) => [(Maybe a, Forest a)] -> Forest a+  loop [] = []+  -- the trees whose roots have no parents are parts of the final forest+  loop ((Nothing, roots) : nonroots) = roots ++ loop nonroots+  -- the trees whose roots have a parent are iterated+  loop nonroots = loop $ step $ map (\ (Just p, ts) -> Node p ts) nonroots+-}++-- take a lexicographically sorted list of pathes+-- and turn it into a forest by+-- gathering the lists by common prefixes+pathesToForest :: (Ord a, Eq a) => [[(Int,a)]] -> Forest (Int, a)+pathesToForest [] = []+pathesToForest ll =+  map (\ l -> Node (head (head l))+                   (pathesToForest $ filter (not . null) $ map tail l)) $+    groupBy (\ l l' -> head l == head l') ll++-- | invert a tree shaped order into a forest.  This can be used for printing.+toForest :: (Ord a, Eq a) => TSO a -> Forest (Int,a)+toForest o = pathesToForest $ sort $ map (\ a -> reverse ((0,a) : parents a o)) $ leaves o -- lex. sort++instance (Ord a, Eq a, Show a) => Show (TSO a) where+  show o = Tree.drawForest $ map (fmap show) $ toForest o++{-+draw :: (Ord a, Eq a, Show a) => TSO a -> String+draw o = Tree.drawForest $ map (fmap show) $ toForest o+-}++-- test++l1 = map (\ (k,l) -> ("i" ++ show k, (1, "i" ++ show l))) [(0,1),(1,2),(2,3),(3,4)]+     ++ [("j2",(1,"i3"))]+o1 = fromList l1+t1 = diff "i2" "i1" o1+t2 = diff "i2" "j2" o1+t3 = height "i2" o1+t4 = height "i4" o1+t5 = height "k" o1
+ src/TypeChecker.hs view
@@ -0,0 +1,3301 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,+      PatternGuards, TupleSections, NamedFieldPuns #-}++module TypeChecker where++import Prelude hiding (null)++import Control.Applicative hiding (Const) -- ((<$>))+import Control.Monad+import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Reader++import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Foldable as Foldable+import qualified Data.Traversable as Traversable++import Debug.Trace++import qualified Text.PrettyPrint as PP++import Util+import qualified Util as Util++import Abstract hiding (Substitute)+import Polarity as Pol+import Value+import TCM+import Eval+import Extract+-- import SPos (nocc) -- RETIRED+-- import CallStack+import PrettyTCM+import TraceError++import Warshall hiding (Flex) -- size constraint checking++import Termination++-- import Completness+++traceCheck msg a = a -- trace msg a+traceCheckM msg = return () -- traceM msg+{-+traceCheck msg a = trace msg a+traceCheckM msg = traceM msg+-}++traceSing msg a = a -- trace msg a+traceSingM msg = return () -- traceM msg+{-+traceSing msg a = trace msg a+traceSingM msg = traceM msg+-}++traceAdm msg a = a -- trace msg a+traceAdmM msg = return () -- traceM msg+{-+traceAdm msg a = trace msg a+traceAdmM msg = traceM msg+-}++{- DEAD CODE+runWhnf :: Signature -> TypeCheck a -> IO (Either TraceError (a,Signature))+runWhnf sig tc = (runExceptT (runStateT tc  sig))+-}++doNf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= reify) (initWithSig sig)) emptyContext)+doWhnf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= whnfClos) (initWithSig sig)) emptyContext)+++-- top-level functions -------------------------------------------++runTypeCheck :: TCState -> TypeCheck a -> IO (Either TraceError (a,TCState))+runTypeCheck st tc = runExceptT (runReaderT (runStateT tc st) emptyContext)+-- runTypeCheck st tc = runCallStackT (runReaderT (runStateT tc st) emptyContext) []++typeCheck dl = runTypeCheck initSt (typeCheckDecls dl)++-- checking top-level declarations -------------------------------++echo :: MonadIO m => String -> m ()+echo = liftIO . putStrLn++echoR = echo+-- echoR s = echo $ "R> " ++ s++echoTySig :: (Show n, MonadIO m) => n -> Expr -> m ()+echoTySig n t = return () -- echo $ "I> " ++ n ++ " : " ++ show t++echoKindedTySig :: (Show n, MonadIO m) => Kind -> n -> Expr -> m ()+echoKindedTySig ki n t = echo $ prettyKind ki ++ "  " ++ show n ++ " : " ++ show t++echoKindedDef :: (Show n, MonadIO m) => Kind -> n -> Expr -> m ()+echoKindedDef ki n t = echo $ prettyKind ki ++ "  " ++ show n ++ " = " ++ show t++echoEPrefix = "E> "++echoTySigE :: (Show n, MonadIO m) => n -> Expr -> m ()+echoTySigE n t = echo $ echoEPrefix ++ show n ++ " : " ++ show t++echoDefE :: (Show n, MonadIO m) => n -> Expr -> m ()+echoDefE n t = echo $ echoEPrefix ++ show n ++ " = " ++ show t++-- the type checker returns pruned (extracted) terms+-- with irrelevant subterms replaced by Irr+typeCheckDecls :: [Declaration] -> TypeCheck [EDeclaration]+typeCheckDecls []     = return []+typeCheckDecls (d:ds) = do+  de  <- typeCheckDeclaration d+  dse <- typeCheckDecls ds+  return (de ++ dse)++-- since a data declaration generates destructor declarations+-- we need to return a list here+typeCheckDeclaration :: Declaration -> TypeCheck [EDeclaration]+typeCheckDeclaration (OverrideDecl Check ds) = do+  st <- get+  typeCheckDecls ds+  put st             -- forget the effect of these decls+  return []+typeCheckDeclaration (OverrideDecl Fail ds) = do+  st <- get+  r <- (typeCheckDecls ds >> return True) `catchError`+        (\ s -> do liftIO $ putStrLn ("block fails as expected, error message:\n" ++ show s)+                   return False)+  if r then throwErrorMsg "unexpected success" else do+    put st+    return []++typeCheckDeclaration (OverrideDecl TrustMe ds) =+  newAssertionHandling Warning $ typeCheckDecls ds++typeCheckDeclaration (OverrideDecl Impredicative ds) =+  goImpredicative $ typeCheckDecls ds++typeCheckDeclaration (RecordDecl n tel t0 c fields) =+  -- just one "mutual" declaration+  checkingMutual (Just $ DefId DatK $ QName n) $ do+    result <- typeCheckDataDecl n NotSized CoInd [] tel t0 [c] fields+    checkPositivityGraph+    return result++typeCheckDeclaration (DataDecl n sz co pos0 tel t0 cs fields) =+  -- just one "mutual" declaration+  checkingMutual (Just $ DefId DatK $ QName n) $ do+    result <- typeCheckDataDecl n sz co pos0 tel t0 cs fields+    checkPositivityGraph+    return result++typeCheckDeclaration (LetDecl eval n tel mt e) = enter (show n) $ do+{- MOVED to checkLetDef+  (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer neutralDec e mt+  te <- return $ teleToType tel te+  ee <- return $ teleLam tel ee+  vt <- whnf' te+-}+  (vt, te, Kinded ki ee) <- checkLetDef neutralDec tel mt e+  rho <- getEnv -- is emptyEnv+  -- TODO: solve size constraints+  -- does not work with emptyEnv+  -- [te, ee] <- solveAndModify [te, ee] rho  -- solve size constraints+  let v = mkClos rho ee -- delay whnf computation+  -- v  <- whnf' ee -- WAS: whnf' e'+  addSig n (LetSig vt ki v $ undefinedFType $ QName n)    -- late (var -> expr) binding, but ok since no shadowing+--  addSig n (LetSig vt e')    -- late (var -> expr) binding, but ok since no shadowing+  echoKindedTySig ki n te+--  echoTySigE n te+--  echoDefE   n ee+  echoKindedDef ki n ee+  return [LetDecl eval n emptyTel (Just te) ee]++typeCheckDeclaration d@(PatternDecl x xs p) = do+{- WHY DOES THIS NOT TYPECHECK?+  let doc = (PP.text "pattern") <+> (PP.hsep (List.map Util.pretty (x:xs))) <+> PP.equals <+> Util.pretty p+  echo $ PP.render $ doc+-}+  echo $ "pattern " ++ Util.showList " " show (x:xs) ++ " = " ++ show p+  v <- whnf' $ foldr (Lam defaultDec) (patternToExpr p) xs+  addSig x (PatSig xs p v)+  return [d]++typeCheckDeclaration (MutualFunDecl False co funs) =+  -- traceCheck ("type checking a function block") $+  do+    funse <- typeCheckFuns co funs+    return $ [MutualFunDecl False co funse]++typeCheckDeclaration (MutualFunDecl True co funs) =+  -- traceCheck ("type checking a block of measured function") $+  do+    funse <- typeCheckMeasuredFuns co funs+    return $ [MutualFunDecl False co funse]++typeCheckDeclaration (MutualDecl measured ds) = do+  -- first check type signatures+  -- we add the typings into the context, not the signature+  ktss <- typeCheckMutualSigs ds+  -- register the mutually defined names+  let ns = for ktss $ \ (Kinded _ (TypeSig n _)) -> n+      addMutualNames = local $ \ e -> e { mutualNames = ns ++ mutualNames e }+  -- then check bodies+  -- we need to construct a positivity graph+  edss <- addKindedTypeSigs ktss $ addMutualNames $+    zipWithM (typeCheckMutualBody measured) (map (predKind . kindOf) ktss) ds+  -- check and reset positivity graph+  checkPositivityGraph+  return $ concat edss+++-- check signatures of a flattened mutual block+typeCheckMutualSigs :: [Declaration] -> TypeCheck [Kinded (TySig TVal)]+typeCheckMutualSigs [] = return []+typeCheckMutualSigs (d:ds) = do+  kts@(Kinded ki (TypeSig n tv)) <- typeCheckMutualSig d+  new' n (Domain tv ki defaultDec) $ do+    ktss <- typeCheckMutualSigs ds+    return $ kts : ktss++typeCheckSignature :: TySig Type -> TypeCheck (Kinded (TySig TVal))+typeCheckSignature (TypeSig n t) = do+  echoTySig n t+  Kinded ki te <- checkType t+  tv <- whnf' te+  return $ Kinded (predKind ki) $ TypeSig n tv++typeCheckMutualSig :: Declaration -> TypeCheck (Kinded (TySig TVal))+typeCheckMutualSig (LetDecl ev n tel (Just t) e) =+  typeCheckSignature $ TypeSig n $ teleToType tel t+typeCheckMutualSig (DataDecl n sz co pos tel t cs fields) = do+  Kinded ki ts <- typeCheckSignature (TypeSig n (teleToType tel t))+  return $ Kinded ki ts+typeCheckMutualSig (FunDecl co (Fun ts n' ar cls)) =+  typeCheckSignature ts+typeCheckMutualSig (OverrideDecl TrustMe [d]) =+  newAssertionHandling Warning $ typeCheckMutualSig d+typeCheckMutualSig (OverrideDecl Impredicative [d]) =+  goImpredicative $ typeCheckMutualSig d+typeCheckMutualSig d = throwErrorMsg $ "typeCheckMutualSig: panic: unexpected declaration " ++ show d++-- typeCheckMutualBody measured kindCandidate+typeCheckMutualBody :: Bool -> Kind -> Declaration -> TypeCheck [EDeclaration]+typeCheckMutualBody measured _ (DataDecl n sz co pos tel t cs fields) = do+  -- set name of mutual thing whose body we are checking+  checkingMutual (Just $ DefId DatK $ QName n) $+    --+    typeCheckDataDecl n sz co pos tel t cs fields+typeCheckMutualBody measured@False ki (FunDecl co fun@(Fun ts@(TypeSig n t) n' ar cls)) = do+  checkingMutual (Just $ DefId FunK $ QName n) $ do+    fun' <- typeCheckFunBody co ki fun+    return $ [FunDecl co fun']++typeCheckDataDecl :: Name -> Sized -> Co -> [Pol] -> Telescope -> Type -> [Constructor] -> [Name] -> TypeCheck [EDeclaration]+typeCheckDataDecl n sz co pos0 tel0 t0 cs0 fields = enter (show n) $+ (do -- sig <- gets signature+     let params = size tel0+     -- in case we are dealing with a sized type, check that+     -- the polarity annotation (if present) at the size arg. is correct.+     (p', pos, t) <- do+       case sz of+         Sized    -> do+           let polsz = if co==Ind then Pos else Neg+           t <- case t0 of+             Quant Pi (TBind x (Domain domt ki dec)) b | isSize domt ->+               case (polarity dec) of+                 -- insert correct polarity annotation if none was there+                 pol | pol `elem` [Param,Rec] -> return $ Quant Pi (TBind x $ Domain tSize kSize $ setPol polsz dec) b+                 pol | pol == polsz -> return t0+                 pol -> throwErrorMsg $ "sized type " ++ show n ++ " has wrong polarity annotation " ++ show pol ++ " at Size argument, it should be " ++ show polsz+             t0 -> return t0+           return (params + 1, pos0 ++ [polsz], t)+         NotSized -> return (params, pos0, t0)+     -- compute full type signature (including parameter telescope)+     let dt = (teleToType tel0 t)+     echoTySig n dt+     {- mmh, this does not work,  e.g.  data Id (A : Set)(a : A) : A -> Set+        then A -> Set is not distinguishable from Set -> Set (GADT)+        unclear what to do...+     dte <- checkTele tel $ \ tele -> do+       te <- checkSmallType t+       return (teleToType tele te)+      -}+     -- get the target sort ds of the datatype+     Kinded ki0 (ds, dte) <- checkDataType p' dt -- TODO?: use above code?+     let ki = dataKind ki0+     echoKindedTySig ki n dte+--     echoTySigE n dte+     v <- whnf emptyEnv dte+     Just fkind <- extractKind v+     -- get the updated telescope which contains the kinds+     let (tel, dtcore) = typeToTele' params dte+     -- compute the constructor telescopes+     cs0 <- mapM (insertConstructorTele tel dtcore) cs0+     let cis = analyzeConstructors co n tel cs0+     let cs  = map reassembleConstructor cis+     addSig n (DataSig { numPars = params+                       , positivity = pos+                       , isSized = sz+                       , isCo = co+                       , symbTyp = v+                       , symbolKind = ki+                       , constructors = cis+                       , etaExpand = False+                       , isTuple = False+-- if cs==[] then Just [] else Nothing+{- OLD CODE+                       , constructors = map namePart cs+                       -- at first, do not add destructors, get them out later+                       , destructors  = Nothing+                       , isFamily = t /= Set  -- currently UNUSED+ -}+                       , extrTyp = fkind+                       })+     when (sz == Sized) $+           szType co params v++     (isRecList, kcse) <- liftM unzip $+       mapM (typeCheckConstructor n dte sz co pos tel) cs++     -- compute the kind of the data type from the kinds of the+     -- constructor arguments  (mmh, DOES NOT WORK FOR MUTUAL DATA!)+     let newki = case (foldl unionKind NoKind (map kindOf kcse)) of+          NoKind  -> kType -- no non-rec constructor arguments+          AnyKind -> AnyKind+          Kind s s' -> Kind (Set Zero) s' -- a data type is always also a type+     -- echoKindedTySig newki n dte -- 2012-01-26 disabled (repetitive)++     -- solve for size variables+     sol <- solveConstraints+     -- TODO: substitute+     resetConstraints++     -- add destructors only for the constructors that are non-overlapping+     let decls = concat $ map mkDestrs cis+         -- cEtaExp = True means that all field names are present+         -- and constructor is not overlapping with others+         mkDestrs ci | cEtaExp ci = concat $ map mkDestr (cFields ci)+                     | otherwise  = []+         mkDestr fi =+          case (fClass fi) of+             Field (Just (ty, arity, cl)) | not (erased $ fDec fi) && not (emptyName $ fName fi) ->+               let n' = fName fi+                   n  = internal n'+               in+               [MutualFunDecl False Ind [Fun (TypeSig n ty) n' arity [cl]]]+             _ -> []++     when (not (null decls)) $+        traceCheckM $ "generated destructors: " ++ show decls+     declse <- mapM (\ d@(MutualFunDecl False co [Fun (TypeSig n t) n' ar cls]) -> do+                       -- echo $ "G> " ++ showFun co ++ " " ++ show n ++ " : " ++ show t+                       -- echo $ "G> " ++ PP.render (prettyFun n cls)+                       checkingMutual Nothing $ typeCheckDeclaration d)+                 decls++     -- decide whether to eta-expand at this type+     -- all patterns need to be proper and non-overlapping+     -- at least one constructor needs to be eta-expandable+     let isPatIndFam = all (\ ci -> fst (cPatFam ci) /= NotPatterns && cEtaExp ci) cis+--                    && not (or overlapList)+     -- do not eta-expand recursive constructors (might not terminate)+     let disableRec ci {-ov-} rec' = ci+          { cRec    = rec'+          , cEtaExp =  cEtaExp ci               -- all destructors present+           && fst (cPatFam ci) /= NotPatterns -- proper pattern to compute indices+--           && not ov                          -- non-overlapping+           && not (co==Ind && rec') }         -- non-recursive+     let cis' = zipWith disableRec cis {-overlapList-} isRecList+     let typeEtaExpandable = isPatIndFam && (null cis || any cEtaExp cis')+     traceEtaM $ "data " ++ show n ++ " eta-expandable " ++ show typeEtaExpandable ++ " constructors " ++ show cis'+     modifySig n (\ dataSig ->+                      dataSig { symbolKind = newki+                              , etaExpand = typeEtaExpandable+                              , constructors = cis'+                              , isTuple = length cis' >= 1 && isPatIndFam+                              })+     -- compute extracted data decl+     let (tele, te) = typeToTele' (size tel) dte+     return $ (DataDecl n sz co pos tele te (map valueOf kcse) fields) : concat declse++   ) -- `throwTrace` n  -- in case of an error, add name n to the trace+++insertConstructorTele :: Telescope -> Type -> Constructor -> TypeCheck Constructor+insertConstructorTele dtel dt c@(Constructor n Nothing t) = return c+insertConstructorTele dtel dt c@(Constructor n Just{}  t) = do+  res <- computeConstructorTele dtel dt t+  return $ Constructor n (Just res) t++-- | @computeConstructorTele dtel t = return ctel@+--   Computes the constructor telescope from the target.+computeConstructorTele :: Telescope -> Type -> Type -> TypeCheck (Telescope, [Pattern])+computeConstructorTele dtel dt t = do+  -- target is data name applied to parameters and indices+  let (_, target) = typeToTele t+      (_, es)     = spineView target+      pars = take (size dtel) es+  (cxt, ps) <- checkConstructorParams pars  =<< whnf' (teleToType dtel dt)+  (,ps) . setDec (Dec Param) <$> do local (const cxt) $ contextToTele cxt++-- | @checkConstructorParams pars tv = return cxt@+--   Checks that parameters @pars@ are patterns elimating the datatype @tv@.+--   Returns a context @cxt@ that binds the pattern variables in+--   left-to-right order.+checkConstructorParams :: [Expr] -> TVal -> TypeCheck (TCContext, [Pattern])+checkConstructorParams es tv = do+  -- for now, we only allow patterns in parameters+  -- could be extended to unifyable expressions in general+  ps <- mapM (\ e -> maybe (errorParamNotPattern e) return $ exprToPattern e) es+  -- no goals from dot patterns, no absurd pattern+  ([],_,cxt,_,_,_,False) <- checkPatterns defaultDec [] emptySub tv ps+  return (cxt, ps)++  where+    errorParamNotPattern e = throwErrorMsg $+      "expected parameter to be a pattern, but I found " ++ show es++-- |+--   Precondition: @ce@ is included in the current context.+contextToTele :: TCContext -> TypeCheck Telescope+contextToTele ce = do+  let n     :: Int+      n     = len (context ce)           -- context length+      delta :: Map Int (OneOrTwo Domain)+      delta = cxt (context ce)           -- types for dB levels+      names :: Map Int Name+      names = naming ce                  -- names for dB levels+  -- traverse the context from left to right+  Telescope <$> do+    forM [0..n-1] $ \ k -> do+      x       <- lookupM k names+      One dom <- lookupM k delta+      TBind x <$> Traversable.traverse toExpr dom++-- | @typeCheckConstructor d dt sz co pols tel (TypeSig c t)@+--+--   returns True if constructor has recursive argument+typeCheckConstructor :: Name -> Type -> Sized -> Co -> [Pol] -> Telescope -> Constructor -> TypeCheck (Bool, Kinded EConstructor)+typeCheckConstructor d dt sz co pos dtel (Constructor n mctel t) = enter ("constructor " ++ show n) $ do+  let tel = maybe dtel fst mctel+{-+  tel <- case cpars of+    -- old style data parameters+    Nothing -> return dtel+    -- new style pattern parameters+    Just{}  -> computeConstructorTele dtel dt t+-}+  sig <- gets signature+  let telE = setDec irrelevantDec tel -- need kinded tel!!+    -- parameters are erased in types of constructors+  let tt = teleToType telE t+  echoTySig n tt+  let params = size tel+  -- when checking constructor types,  do NOT resurrect telescope+  --   data T [A : Set] : Set { inn : A -> T A }+  -- should be rejected, since A ~= T A, and T A = T B means A ~=B for arb. A, B!+  -- add data name as spos var, to check positivity+  -- and as NoKind, to compute the true kind from the constructors+  let telWithD = Telescope $ (TBind d $ Domain dt NoKind $ Dec SPos) : telescope tel+  Kinded ki te <- addBinds telWithD $+    checkConType sz t -- do NOT resurrect telescope!!++  -- Check target of constructor.+  dv <- whnf' dt+  let (Telescope argts,target) = typeToTele te+  whenNothing mctel $ -- only for old-style parameters+    addBinds telWithD $ addBinds (Telescope argts) $ checkTarget d dv tel target++  -- Make type of a constructor a singleton type.+  let mkName i n | emptyName n = fresh $ "y" ++ show i+                 | otherwise   = n+      fields = map boundName argts+      argns  = zipWith mkName [0..] $ fields+      argtbs = zipWith (\ n tb -> tb { boundName = n }) argns argts+--      core   = (foldl App (con (coToConK co) n) $ map Var argns)+      core   = Record (NamedRec (coToConK co) n False notDotted) $ zip fields $ map Var argns+      tsing  = teleToType (Telescope argtbs) $ Sing core target++  let tte = teleToType telE tsing -- te -- DO resurrect here!+  vt <- whnf' tte++  -- Now, compute the remaining information concerning the constructor.++  {- old code was more accurate, since it evaluated before checking+     for recursive occurrence.+  recOccs <- sposConstructor d 0 pos vt -- get recursive occurrences+  -}+  mutualNames <- asks mutualNames+  let mutOcc tb = not $ null $ List.intersect (d:mutualNames) $ usedDefs $ boundType tb+      recOccs   = map mutOcc argts+      isRec     = or recOccs+  -- fType <- extractType vt -- moved to Extract+  let fType = undefinedFType n+  isSz <- if sz /= Sized then return Nothing else do+    szConstructor d co params vt -- check correct use of sizes+    if co == CoInd then return $ Just $ error "impossible lhs type of coconstructor" else do+    let (x, lte) = mapSnd (teleToType telE) $ mkConLType params te+    echoKindedTySig kTerm n lte+    ltv <- whnf' lte+    return $ Just (x, ltv)++  -- Add the type constructor to the signature.+  let cpars = fmap (mapFst (map boundName . telescope)) mctel -- deletes types, keeps names+  addSigQ n (ConSig cpars isSz recOccs vt d (size dtel) fType)+--  let (tele, te) = typeToTele (length tel) tte -- NOT NECESSARY+  echoKindedTySig kTerm n tte+  -- traceM ("kind of " ++ n ++ "'s args: " ++ show ki)+--  echoTySigE n tte+  return (isRec, Kinded ki $ Constructor n (fmap (mapFst (const telE)) mctel) te)++typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [EFun]+typeCheckMeasuredFuns co funs0 = do+    -- echo $ show funs+    kfse <- mapM typeCheckFunSig funs0 -- NO LONGER erases measure+    -- use erased type signatures with retaines measure+    let funs = zipWith (\ (Kinded ki ts) f -> f { funTypeSig = ts }) kfse funs0++    -- type check and solve size constraints+    -- return clauses with meta vars resolved+    kcle <- installFuns co (zipWith Kinded (map kindOf kfse) funs) $+      mapM typeCheckFunClauses funs+    let kis  = map kindOf kcle+    let clse = map valueOf kcle+{-+    -- replace old clauses by new ones in funs+    let funs' = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clss+-}+    -- get the list of mutually defined function names+    let funse = List.zipWith4 Fun+                  (map (fmap eraseMeasure . valueOf) kfse)+                  (map funExtName funs)+                  (map funArity funs)+                  clse+    -- print reconstructed clauses+    mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do+        -- echoR $ n ++ " : " ++ show t+        echoR $ (PP.render $ prettyFun n cls))+      funse+    -- replace in signature by erased clauses+    zipWithM (enableSig co) (zipWith intersectKind kis $ map kindOf kfse) funse+    return $ funse++  where+    enableSig :: Co -> Kind -> Fun -> TypeCheck ()+    enableSig co ki (Fun (TypeSig n t) n' ar' cl') = do+      vt <- whnf' t+      addSig n (FunSig co vt ki ar' cl' True $ undefinedFType $ QName n)+      -- add a let binding for external use+      v <- up False (vFun n) vt+      addSig n' (LetSig vt ki v $ undefinedFType $ QName n')++++-- type check the body of one function in a mutual block+-- type signature is already checked and added to local context+typeCheckFunBody :: Co -> Kind -> Fun -> TypeCheck EFun+typeCheckFunBody co ki0 fun@(Fun ts@(TypeSig n t) n' ar cls0) = do+    -- echo $ show fun+    addFunSig co $ Kinded ki0 fun+    -- type check and solve size constraints+    -- return clauses with meta vars resolved+    Kinded ki clse <- setCo co $ typeCheckFunClauses fun++    -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary+    -- TODO: proper cleanup, proper removal of admissibility check!+    -- clse <- admCheckFunSig co names ts clse++    -- print reconstructed clauses+    -- echoR $ n ++ " : " ++ show t+    echoR $ (PP.render $ prettyFun n clse)+    -- replace in signature by erased clauses+    let fune = Fun ts n' ar clse+    enableSig ki fune+    return fune+++typeCheckFuns :: Co -> [Fun] -> TypeCheck [EFun]+typeCheckFuns co funs0 = do+    -- echo $ show funs+    kfse <- mapM typeCheckFunSig funs0+    let kfuns = zipWith (\ (Kinded ki ts) (Fun ts0 n' ar cls) -> Kinded ki (Fun ts n' ar cls)) kfse funs0+    -- zipWithM (addFunSig co) (map kindOf kfse) funs+    mapM (addFunSig co) kfuns+    let funs = map valueOf kfuns+    -- type check and solve size constraints+    -- return clauses with meta vars resolved+    kce <- setCo co $ mapM typeCheckFunClauses funs+    let kis = map kindOf kce+    let clse = map valueOf kce+    -- get the list of mutually defined function names+    let names   = map (\ (Fun (TypeSig n t) n' ar cls) -> n) funs+    -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary+    -- TODO: proper cleanup, proper removal of admissibility check!+    clse <- zipWithM (\ (Fun tysig _ _ _) cls' -> admCheckFunSig co names tysig cls') funs clse+    -- replace old clauses by new ones in funs+    let funse = List.zipWith4 Fun+                  (map valueOf kfse)+                  (map funExtName funs)+                  (map funArity funs)+                  clse+--    let funse = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clse+    -- print reconstructed clauses+    mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do+        -- echoR $ n ++ " : " ++ show t+        echoR $ (PP.render $ prettyFun n cls))+      funse+    terminationCheck funse+    -- replace in signature by erased clauses+    zipWithM enableSig kis funse+    return $ funse++addFunSig :: Co -> Kinded Fun -> TypeCheck ()+addFunSig co (Kinded ki (Fun (TypeSig n t) n' ar cl)) = do+    sig <- gets signature+    vt <- whnf' t -- TODO: PROBLEM for internal extraction (would need te here)+    addSig n (FunSig co vt ki ar cl False $ undefinedFType $ QName n) --not yet type checked / termination checked++-- ADMCHECK FOR COFUN is not taking place in checking the lhs+-- TODO: proper analysis for size patterns!+-- admCheckFunSig mutualNames (TypeSig thisName thisType, clauses)+admCheckFunSig :: Co -> [Name] -> TypeSig -> [Clause] -> TypeCheck [Clause]+admCheckFunSig CoInd  mutualNames (TypeSig n t) cls = return cls+admCheckFunSig co@Ind mutualNames (TypeSig n t) cls = traceAdm ("admCheckFunSig: checking admissibility of " ++ show n ++ " : " ++ show t) $+   (+    do -- a function is not recursive if did does not mention any of the+       -- mutually defined function names+       let usedNames = rhsDefs cls+       let notRecursive = all (\ n -> not (n `elem` usedNames)) mutualNames+       -- for non-recursive functions, we can skip the admissibility check+       if notRecursive then+          -- trace ("function " ++ n ++ " is not recursive") $+            return cls+        else -- trace ("function " ++ n ++ " is recursive ") $+          do vt <- whnf' t+             admFunDef co cls vt+    ) `throwTrace` ("checking type of " ++ show n ++ " for admissibility")+++enableSig :: Kind -> Fun -> TypeCheck ()+enableSig ki (Fun (TypeSig n _) n' ar' cl') = do+  (FunSig co vt ki0 ar cl _ ftyp) <- lookupSymb n+  addSig n (FunSig co vt (intersectKind ki ki0) ar cl' True ftyp)+  -- add a let binding for external use+  v <- up False (vFun n) vt+  addSig n' (LetSig vt ki v ftyp)+++-- typeCheckFunSig (TypeSig thisName thisType, clauses)+typeCheckFunSig :: Fun -> TypeCheck (Kinded ETypeSig)+typeCheckFunSig (Fun (TypeSig n t) n' ar cls) = enter ("type of " ++ show n) $ do+  echoTySig n t+  Kinded ki0 te <- checkType t+  -- let te = eraseMeasure te0+  let ki = predKind ki0+  echoKindedTySig ki n (eraseMeasure te)+--  echoTySigE n te+  return $ Kinded ki $ TypeSig n te++typeCheckFunClauses :: Fun -> TypeCheck (Kinded [EClause])+typeCheckFunClauses (Fun (TypeSig n t) n' ar cl) = enter (show n) $+   do result@(Kinded _ cle) <- checkFun t cl+      -- traceCheck (show (TypeSig n t)) $+       -- traceCheck (show cl') $+      -- echo $ PP.render $ prettyFun n cle+      return result++-- checkConType sz t = Kinded ki te+-- the returned kind is the kind of the constructor arguments+-- check that result is a universe+--  ( params were already checked by checkDataType and are not included in t )+-- called initially in the context consisting of the parameter telescope+checkConType :: Sized -> Expr -> TypeCheck (Kinded Extr)+checkConType NotSized t = checkConType' t+checkConType Sized t =+    case t of+      Quant Pi tb@(TBind _ (Domain t1 _ _)) t2 | isSize t1 -> do+             addBind (mapDec (const paramDec) tb) $ do  -- size is parametric in constructor type+               Kinded ki t2e <- checkConType' t2+               return $ Kinded ki $ Quant Pi (mapDec (const irrelevantDec) tb) t2e -- size is irrelevant in constructor+      _ -> throwErrorMsg $ "checkConType: expecting size quantification, found " ++ show t++checkConType' :: Expr -> TypeCheck (Kinded Extr)+checkConType' t = do+  (s, kte) <- checkingCon True $ inferType t+  case s of+    Set{} -> return kte+    CoSet{} -> return kte+    _ -> throwErrorMsg $ "checkConType: type " ++ show t ++ " of constructor not a universe"++-- check that the data type and the parameter arguments (written down like declared in telescope)+-- precondition: target tg type checks in current context+checkTarget :: Name -> TVal -> Telescope -> Type -> TypeCheck ()+checkTarget d dv tel tg = do+  tv <- whnf' tg+  case tv of+    VApp (VDef (DefId DatK (QName n))) vs | n == d -> do+      telvs <- mapM (\ tb -> whnf' (Var (boundName tb))) $ telescope tel+      enter ("checking datatype parameters in constructor target") $+        leqVals' N mixed (One dv) (take (size tel) vs) telvs+      return ()+    _ -> throwErrorMsg $ "constructor should produce something in data type " ++ show d++{- RETIRED (syntactic check)+checkTarget :: Name -> Telescope -> Type -> TypeCheck ()+checkTarget d tel tg =+    case spineView tg of+      (Def (DefId Dat n), args) | n == d -> checkParams tel (take (length tel) args)+      _ -> throwErrorMsg $ "target mismatch"  ++ show tg++    where checkParams :: Telescope -> [Expr] -> TypeCheck ()+          checkParams [] [] = return ()+          checkParams (tb : tl) ((Var n') : el) | boundName tb == n'+            = checkParams tl el+          checkParams tl al = throwErrorMsg $ "target param mismatch " +++            d ++ " " ++ show tel ++ " != " ++ show tg ++ "\ncheckParams " ++ show tl ++ " " ++ show al ++ " failed"+-}++-- check that params are types+-- check that arguments are stypes+-- check that target is set+checkDataType :: Int -> Expr -> TypeCheck (Kinded (Sort Expr, Extr))+checkDataType p e = do+  traceCheckM ("checkDataType " ++ show e ++ " p=" ++ show p)+  case e of+     Quant Pi tb@(TBind x (Domain t1 _ dec)) t2 -> do+       k <- getLen+       traceCheckM ("length of context = " ++ show k)+       -- t1e <- checkingDom $ if k <= p then checkType t1 else checkSmallType t1+       (s1, Kinded ki0 t1e) <- checkingDom $ inferType t1+       let ki1 = predKind ki0+       addBind (TBind x (Domain t1 ki1 defaultDec)) $ do+         Kinded ki2 (s, t2e) <- checkDataType p t2+         -- when k <= p $ ltSort s1 s -- check size of indices (disabled)+         return $ Kinded ki2 (s, Quant Pi (TBind x (Domain t1e ki1 dec)) t2e)+     Sort s@(Set e1)   -> do+       (_, e1e) <- checkLevel e1+       return $ Kinded (kUniv e1e) (s, Sort $ Set e1e)+     Sort s@(CoSet e1) -> do+       e1e <- checkSize e1+       return $ Kinded (kUniv Zero) (s, Sort $ CoSet e1e)+     _ -> throwErrorMsg "doesn't target Set or CoSet"++{-+checkSize :: Expr -> TypeCheck Extr+checkSize Infty = return Infty+checkSize e = valueOf <$> checkExpr e vSize+-}++checkSize :: Expr -> TypeCheck Extr+checkSize e =+  case e of+    Meta i  -> do+      ren <- asks renaming+      addMeta ren i+      return e+    e       -> inferSize e++inferSize :: Expr -> TypeCheck Extr+inferSize e =+  case e of+    Zero  -> return e+    Infty -> return e+    Succ e  -> Succ <$> checkSize e+    Plus es -> Plus <$> mapM checkSize es+    Max  es -> maxE <$> mapM checkSize es+    e -> do+      (v, Kinded ki e) <- inferExpr e+      subtype v vSize+      return e++checkBelow :: Expr -> LtLe -> Val -> TypeCheck Extr+checkBelow e Le VInfty = checkSize e+checkBelow e ltle v = do+  e' <- checkSize e+  v' <- whnf' e+  leSize ltle Pos v' v+  return e'+++-- checkLevel e = (value of e, ee)+-- if e : Size and value of e != Infty+checkLevel :: Expr -> TypeCheck (Val, Extr)+checkLevel e = do+  Kinded _ ee <- checkExpr e vSize+  v  <- whnf' e+  when (v == VInfty) $ recoverFail $ "# is not a valid universe level"+  return (v, ee)++{- Kind inference++          i    : Size              : Type+      t : Nat  : Set  : Set1 : ... : Type = Set\omega+  p : P : Prop : Set  : ...++Functional, cumulative PTS (s,s',s') written (s,s')++  (Size,s)   s != Size    size-dependency+  (s,Prop)                impredicative Prop+  (Set_i,Set_j)  i <= j   predicativity++Kind    can be used to construct Kinds+term t  terms, types, universes, proofs, propositions+type T  types, universes, propositions+size i  types, universes, propositions+prf  p  proofs+pred P  types, universes, propositions++We like to infer kinds of expressions++  Tm < Set < Set1 < Set2 < ...++For  t : A  if kind(A) = Tm then t is a term,+                       = Set then t is a type,+                       = Set1 then t is a type1 (e.g, a universe) ...++Then,  if  t : (x : A) -> B+      and  kind(A) `irrelevantFor` kind(B)   [ with irrelevantFor := > ]++we can change the type signature to++           t : [x : A] -> B++This is because you cannot eliminate a type to produce a term.++  kind(Set)  = Set+  kind(Size) = Size -- this means that we treat sizes as types, they cannot+  kind(s)    = s    -- if s is a sort+  kind((x : A) -> B) = kind(B)+  kind(A : Set0) = Tm+  kind(A : Prop) = Prf+  kind(A : Size) = <<impossible>>+  kind(A : Setk) = k-1++irrFor Tm  _    = False+irrFor Ty Tm    = True+irrFor Ty Prf   = True+irrFor Ty _     = False+irrFor Size Tm  = True+irrFor Size Prf = True++One problem is that we cannot infer exact kinds, e.g.++  fun T : Bool -> Set 1 -- T is a type+  { T true  = Bool      -- T true is a type+  ; T false = Set 0     -- T false is a universe+  }++T is either a type or a universe.  So we can only assign intervals.+This is like in Augustsson's Cayenne [not in his paper, though].++A datatype is always a type.  A size is a type.+A constructor is always a term.++-}+++-- type checking++-- checkExpr e tv = (e', ki)+-- e' is the version of e with erasure marker at irrelevant positions+-- ki is the kind of e (Tm, Ty, Set ...)+-- ki is at most the predecessor of the sort of tv+--+-- this is *internal* extraction in the style of Barras and Bernardo+-- e.g., does not prune t : Id A a b+-- thus, we can use the pruned version for evaluation!+checkExpr :: Expr -> TVal -> TypeCheck (Kinded Extr)+checkExpr e v = do+  l <- getLen+  enterDoc (text ("checkExpr " ++ show l ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do++   ce <- ask+   traceCheck ("checkExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " : " ++ show v ++ " in env" ++ show (environ ce)) $ do++    (case (e, v) of++{- In the presence of full bracket types,+   we could implement the following "resurrecting version of let"++   Gamma |- s : [A]+   Gamma, x:A |- t : C   Gamma, x:A, y:A |- t = t[y/x] : C+   -------------------------------------------------------+   Gamma |- let x:[A] = s in t : C++ -}++      (App (Lam dec x f) e, v) | inferable e -> checkLet dec x emptyTel Nothing e f v++{-+      (LLet (TBind x (Domain Nothing _ dec)) e1 e2, v) -> checkUntypedLet x dec e1 e2 v+      (LLet (TBind x (Domain (Just t1) _ dec)) e1 e2, v) -> checkTypedLet x t1 dec e1 e2 v+-}+      (LLet (TBind x (Domain mt _ dec)) tel e1 e2, v) -> checkLet dec x tel mt e1 e2 v++      (Case (Var x) Nothing [Clause _ [SuccP (VarP y)] (Just rhs)], v) -> do+          (tv, _) <- resurrect $ inferExpr (Var x)+          subtype tv vSize+          vx@(VGen i) <- whnf' (Var x)+          endsInSizedCo i v+          let dom = Domain vSize kSize defaultDec+          newWithGen y dom $ \ j vy -> do+            let vp = VSucc vy+            addSizeRel j 1 i $+              addRewrite (Rewrite vx vp) [v] $ \ [v'] -> do+                Kinded ki2 rhse <- checkRHS emptySub rhs v'+                return $ Kinded ki2 $ Case (Var x) (Just tSize) [Clause [TBind y dom] [SuccP (VarP y)] (Just rhse)]+++      (Case e mt cs, v) -> do+          (tv, t, Kinded ki1 ee) <- checkOrInfer neutralDec e mt+          ve <- whnf' ee+          -- tv' <- sing' ee tv -- DOES NOT WORK+          Kinded ki2 cle <- checkCases ve (arrow tv v) cs+          return $ Kinded ki2 $ Case ee (Just t) cle+{-+      (Case e Nothing cs, _) -> do+          (tv, Kinded ki1 ee) <- inferExpr e+          ve <- whnf' ee+          -- tv' <- sing' ee tv -- DOES NOT WORK+          Kinded ki2 cle <- checkCases ve (arrow tv v) cs+          t <- toExpr tv+          return $ Kinded ki2 $ Case ee (Just t) cle+-}+      (_, VGuard beta bv) ->+        addBoundHyp beta $ checkExpr e bv++      (e,v) | inferable e -> do+          (v2, Kinded ki1 ee) <- inferExpr e+          checkSubtype ee v2 v+          return $ Kinded ki1 ee++      _ -> checkForced e v++      ) -- >> (trace ("checkExpr successful: " ++ show e ++ ":" ++ show v) $ return ())++-- | checkLet @let .x tel : t = e1 in e2@+checkLet :: Dec -> Name -> Telescope -> Maybe Type -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)+checkLet dec x tel mt1 e1 e2 v = do+  (v_t1, t1e, Kinded ki1 e1e) <- checkLetDef dec tel mt1 e1+--  (v_t1, t1e, Kinded ki1 e1e) <- checkOrInfer dec e1 mt1+  checkLetBody x t1e v_t1 ki1 dec e1e e2 v++-- | checkLetDef @.x tel : t = e@ becomes @.x : tel -> t = \ tel -> e@+checkLetDef :: Dec -> Telescope -> Maybe Type -> Expr -> TypeCheck (TVal, EType, Kinded Extr)+checkLetDef dec tel mt e = local (\ cxt -> cxt {consistencyCheck = True}) $ do+  -- 2013-04-01+  -- since a let telescope is treated like a lambda abstraction+  -- and the let-defined symbol reduces by itself, we need to+  -- do the context consistency check at each introduction.+  (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer dec e mt+  te <- return $ teleToType tel te+  ee <- return $ teleLam tel ee+  vt <- whnf' te+  return (vt, te, Kinded ki ee)++{-+checkTypedLet :: Name -> Type -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)+checkTypedLet x t1 dec e1 e2 v = do+  Kinded kit t1e <- checkType t1+  v_t1 <- whnf' t1+  Kinded ki0 e1e <- applyDec dec $ checkExpr e1 v_t1+  let ki1 = intersectKind ki0 (predKind kit)+  checkLetBody x t1e v_t1 ki1 dec e1e e2 v+{-+  v_e1 <- whnf' e1+  new x (Domain v_t1 ki1 dec) $ \ vx -> do+    addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do+      Kinded ki2 e2e <- checkExpr e2 v'+      return $ Kinded ki2 $ LLet (TBind x (Domain t1e ki1 dec)) e1e e2e  -- if e2e==Irr then Irr else LLet n t1e e1e e2e+-}++checkUntypedLet :: Name -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr)+checkUntypedLet x dec e1 e2 v = do+  (v_t1, Kinded ki1 e1e) <- applyDec dec $ inferExpr e1+  v_e1 <- whnf' e1+  t1e <- toExpr v_t1+  checkLetBody x t1e v_t1 ki1 dec e1e e2 v+-}++checkLetBody :: Name -> EType -> TVal -> Kind -> Dec -> Extr -> Expr -> TVal -> TypeCheck (Kinded Extr)+checkLetBody x t1e v_t1 ki1 dec e1e e2 v = do+  v_e1 <- whnf' e1e+  new x (Domain v_t1 ki1 dec) $ \ vx -> do+    addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do+      Kinded ki2 e2e <- checkExpr e2 v'+      return $ Kinded ki2 $ LLet (TBind x (Domain (Just t1e) ki1 dec)) emptyTel e1e e2e+{-+-- Dependent let: not checkable in rho;Delta style+--            v_e1 <- whnf rho e1+--            checkExpr (update rho n v_e1) (v_t1 : delta) e2 v+-}++-- | @checkPair e1 e2 y dom env b@ checks @Pair e1 e2@ against+--   @VQuant Sigma y dom env b@.+checkPair :: Expr -> Expr -> Name -> Domain -> FVal -> TypeCheck (Kinded Expr)+checkPair e1 e2 y dom@(Domain av ki dec) fv = do+  case av of+    VBelow Lt VInfty -> do+      lowerSemi <- underAbs y dom fv $ \ i _ bv -> lowerSemiCont i bv+      continue $ if lowerSemi then VBelow Le VInfty else av+    _ -> continue av+  where+    continue av = do+      Kinded k1 e1 <- applyDec dec $ checkExpr e1 av+      v1 <- whnf' e1+      bv <- app fv v1+      Kinded k2 e2 <- checkExpr e2 bv+      return $ Kinded (unionKind k1 k2) $ Pair (maybeErase dec e1) e2++-- check expression after forcing the type+checkForced :: Expr -> TVal -> TypeCheck (Kinded Expr)+checkForced e v = do+  ren <- asks renaming+  v   <- force v+--  enter ("checkForced " ++ show ren ++ " |- " ++ show e ++ " : " ++ show v) $ do+  enterDoc (text ("checkForced " ++ show ren ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do+    case (e,v) of+{-+      (_, VGuard (Bound (Measure [VGen i]) (Measure [VGen j])) bv) ->+        addSizeRel i j $ checkForced e bv+-}+      (_, VGuard beta bv) ->+        addBoundHyp beta $ checkForced e bv++      (Pair e1 e2, VQuant Sigma y dom@(Domain av ki dec) fv) ->+        checkPair e1 e2 y dom fv++      (Record ri rs, t@(VApp (VDef (DefId DatK d)) vl)) -> do+         let fail1 = failDoc (text "expected" <+> prettyTCM t <+> text "to be a record type")+--         DataSig { numPars, isTuple } <- lookupSymb d+--         unless isTuple $ fail1+         mfs <- getFieldsAtType d vl+         case mfs of+           Nothing -> fail1+           Just ptv -> do+             let checkField :: (Name, Expr) -> TypeCheck (Kinded [(Name,Expr)]) -> TypeCheck (Kinded [(Name,Expr)])+                 checkField (p,e) cont =+                  case lookup p ptv of+                    Nothing -> failDoc (prettyTCM p <+> text "is not a field of record" <+> prettyTCM t)+                    Just tv -> do+                      tv <- piApp tv VIrr -- remove record argument (cannot be dependent!)+                      Kinded k e <- checkExpr e tv+                      Kinded k' es <- cont+                      return $ Kinded (unionKind k k') ((p,e) : es)+             Kinded k rs <- foldr checkField (return $ Kinded NoKind []) rs+             return $ Kinded k $ Record ri rs+++{- OLD:+Following Awodey/Bauer 2001, the following rule is valid++   Gamma, x:A |- t : B    Gamma, x:A, y:A |- t = t[y/x] : B+   --------------------------------------------------------+   Gamma |- \xt : Pi x:[A]. B++      (Lam _ y e1, VPi dec x va env t1) -> do+          rho <- getEnv  -- get the environment corresponding to Gamma+          new y (Domain va (resurrectDec dec)) $ \ vy -> do+            v_t1 <- whnf (update env x vy) t1+            -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1+            e1e <- checkExpr e1 v_t1+            when (erased dec) $ do  -- now check invariance of the e1+              new y (Domain va (resurrectDec dec)) $ \ vy' -> do+                ve  <- whnf (update rho y vy)  e1e+                ve' <- whnf (update rho y vy') e1e+                eqVal v_t1 ve ve'  -- BUT: ve' does not have type v_t1 !?+            -- prune the lambda if body has been pruned+            return $ if e1e==Irr then Irr else Lam y e1e+ -}++-- NOW just my rule (LICS 2010 draft) a la Barras/Bernardo++      (Lam _ y e1, VQuant Pi x dom fv) -> do+          -- rho <- getEnv  -- get the environment corresponding to Gamma+          underAbs y dom fv $ \ _ vy bv -> do+            -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1+            Kinded ki1 e1e <- checkExpr e1 bv+            -- the kind of a lambda is the kind of its body+            return $ Kinded ki1 $ Lam (decor dom) y e1e++      -- lone projection: eta-expand!+      (Proj Pre p, VQuant Pi x dom fv) -> do+         let y = nonEmptyName x "y"+         checkForced (Lam (decor dom) y $ App e (Var y)) v+{-+      -- should be subsumed by checkBelow:+      (e, v) | isVSize v -> Kinded kSize <$> checkSize e+-}+{-  MOVED to checkSize++      -- metavariables must have type size+      (Meta i, _) | isVSize v -> do+        addMeta ren i+        return $ Kinded kSize $ Meta i++     (Infty, v) | isVSize v -> return $ Kinded kSize $ Infty+      (Zero, v) | isVSize v -> return $ Kinded kSize $ Zero++      (Plus es, v) | isVSize v -> do+              ese <- mapM checkSize es+              return $ Kinded kSize $ Plus ese++      (Max es, v) | isVSize v -> do+              ese <- mapM checkSize es+              return $ Kinded kSize $ Max ese++      (Succ e2, v) | isVSize v -> do+              e2e <- checkSize e2+              return $ Kinded kSize $ Succ e2e+-}++      (e, VBelow ltle v) -> Kinded kSize <$> checkBelow e ltle v+{-+              -- prune sizes+              return $ if e2e==Irr then Irr else Succ e2e+-}+      (e,v) -> do+        case spineView e of++          -- unfold defined patterns+          (h@(Def (DefId (ConK DefPat) c)), es) -> do+             PatSig xs pat _ <- lookupSymbQ c+             let (xs1, xs2) = splitAt (length es) xs+                 phi x      = maybe (Var x) id $ lookup x (zip xs1 es)+                 body       = parSubst phi (patternToExpr pat)+                 e          = foldr (Lam defaultDec) body xs2+             checkForced e v++          -- check constructor term+          (h@(Def (DefId (ConK co) c)), es) -> checkConTerm co c es v+{-+          (h@(Def (DefId (ConK co) c)), es) -> do+             tv <- conType c v+             (knes, dv) <- checkSpine es tv+             let e = foldl App h $ map (snd . valueOf) knes+             checkSubtype e dv v+             e <- etaExpandPis e dv -- a bit similiar to checkSubtype, which computes a singleton+             return $ Kinded kTerm $ e+-}+          -- else infer+          _ -> do+            (v2,kee) <- inferExpr e+            checkSubtype (valueOf kee) v2 v+            return kee++-- | Check (partially applied) constructor term, eta-expand it and turn it+--   into a named record.+checkConTerm :: ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Extr)+checkConTerm co c es v = do+  case v of+    VQuant Pi x dom fv -> do+      let y = freshen $ nonEmptyName x "y"+      underAbs y dom fv $ \ _ _ bv -> do+        Kinded ki ee <- checkConTerm co c (es ++ [Var y]) bv+        return $ Kinded ki $ Lam (decor dom) y ee+    _ -> do+      c <- disambigCon c v+      tv <- conType c v+      (knes, dv) <- checkSpine es tv+      let ee = Record (NamedRec co c False notDotted) $ map valueOf knes+      checkSubtype ee dv v+      return $ Kinded kTerm ee++{-+-- | Check (partially applied) constructor term, eta-expand it and turn it+--   into a named record.+checkConTerm :: ConK -> Name -> [Expr] -> TVal -> TypeCheck (Kinded Extr)+checkConTerm co c es v = do+  tv <- conType c v+  (knes, dv) <- checkSpine es tv+  let e0 = foldl App (Def (DefId (ConK co) c)) $ map (snd . valueOf) knes+  checkSubtype e0 dv v+  (vTel, _) <- telView dv+  let xs   = map (boundName . snd) vTel+      decs = map (decor . boundDom . snd) vTel+      ys   = map freshen xs+      rs   = map valueOf knes ++ (zip xs $ map Var ys)+      e1   = Record (NamedRec co c False) rs+      e    = foldr (uncurry Lam) e1 (zip decs ys)+  return $ Kinded kTerm e+-}++{-+-- | Only eta-expand at function types, do not force.+etaExpandPis :: Expr -> TVal -> TypeCheck Expr+etaExpandPis e tv = do+  case tv of+    VQuant Pi x dom env b -> new x dom $ \ xv -> do+      let y = freshen x+      Lam (decor dom) y <$> do+        etaExpandPis (App e (Var y)) =<< whnf (update env x xv) b+    _ -> return e+-}++checkSpine :: [Expr] -> TVal -> TypeCheck ([Kinded (Name, Extr)], TVal)+checkSpine [] tv = return ([], tv)+checkSpine (e : es) tv = do+  (kne, tv) <- checkApp e tv+  (knes, tv) <- checkSpine es tv+  return (kne : knes, tv)++maybeErase dec = if erased dec then erasedExpr else id++-- | checking e against (x : A) -> B returns (x,e) and B[e/x]+checkApp :: Expr -> TVal -> TypeCheck (Kinded (Name, Extr), TVal)+checkApp e2 v = do+  v <- force v -- if v is a corecursively defined type in Set, unfold!+  enter ("checkApp " ++ show v ++ " eliminated by " ++ show e2) $ do+  case v of+    VQuant Pi x dom@(Domain av@(VBelow Lt VInfty) _ dec) fv -> do+      upperSemi <- underAbs x dom fv $ \ i _ bv -> upperSemiCont i bv+      continue $ if upperSemi then VQuant Pi x dom{ typ = VBelow Le VInfty} fv+                 else v+    _ -> continue v+ where+  continue v = case v of+    VQuant Pi x (Domain av _ dec) fv -> do+       (ki, v2, e2e) <- do+         if inferable e2 then do+       -- if e2 has a singleton type, we should not take v2 = whnf e2+       -- but use the single value of e2+       -- this is against the spirit of bidir. checking+              -- if checking a type we need to resurrect+              (av', Kinded ki e2e) <- applyDec dec $ inferExpr e2+              case av' of+                 VSing v2 av'' -> do subtype av' av+                                     return (ki, v2, e2e)+                 _ -> do checkSubtype e2e av' av+                         v2 <- whnf' e2e+                         return (ki, v2, e2e)+            else do+              Kinded ki e2e <- applyDec dec $ checkExpr e2 av+              v2 <- whnf' e2e+              return (ki, v2, e2e)+       bv <- app fv v2+       -- the kind of the application is the kind of its head+       return (Kinded ki $ (x,) $ maybeErase dec e2e, bv)+       -- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e])+    _ -> throwErrorMsg $ "checking application to " ++ show e2 ++ ": expected function type, found " ++ show v+++-- checkSubtype  expr : infered_type <= ascribed_type+checkSubtype :: Expr -> TVal -> TVal -> TypeCheck ()+checkSubtype e v2 v = do+    rho <- getEnv+    traceSingM $ "computing singleton <" ++ show e ++ " : " ++ show v2 ++ ">" -- ++ " in environment " ++ show rho+    v2principal <- sing rho e v2+    traceSingM $ "subtype checking " ++ show v2principal ++ " ?<= " ++ show v ++ " in environment " ++ show rho+    subtype v2principal v+++-- ptsRule s1 s2 = s  if (s1,s2,s) is a valid rule+-- precondition: s1,s2 are proper sorts, i.e., not Size or Tm+ptsRule :: Bool -> Sort Val -> Sort Val -> TypeCheck (Sort Val)+ptsRule er s1 s2 = do+  cxt <- ask+  let parametric = checkingConType cxt  -- are we dealing with a parametric pi?+  let err = "ptsRule " ++ show (s1,s2) ++ " " ++ (if parametric then "(in type of constructor)" else "") ++ ": "+  case (s1,s2) of+    (Set VInfty,_) -> throwErrorMsg $ err ++ "domain too big"+    (Set v1, Set v2) ->+      if parametric then do+         unless er $ leqSize Pos v1 v2 -- when we are checking a constructor, to reject+         {- data Bad : Set { bad : Set -> Bad } -}+         return s2+       else return $ Set $ maxSize [v1,v2]+    (CoSet v1, Set VZero)+       | parametric   -> return $ CoSet v1+       | v1 == VInfty -> return $ Set VZero+       | otherwise    -> throwErrorMsg $ err ++ "domain cannot be sized"+    (CoSet v1, CoSet v2)+       | parametric   -> do+           let v2' = maybe v2 id $ predSize v2+           case minSize v1 v2 of+             Just v  -> return $ CoSet v+             Nothing -> throwErrorMsg $ err ++ "min" ++ show (v1,v2) ++ " does not exist"+       | v1 == VInfty -> return $ CoSet $ succSize v2+       | otherwise    -> throwErrorMsg $ err ++ "domain cannot be sized"+    _ -> return s2++checkOrInfer :: Dec -> Expr -> Maybe Type -> TypeCheck (TVal, EType, Kinded Extr)+checkOrInfer dec e Nothing = do+  (tv, ke) <- applyDec dec $ inferExpr e+  te <- toExpr tv+  return (tv, te, ke)+checkOrInfer dec e (Just t) = do+  Kinded kt te <- checkType t+  tv <- whnf' te+  Kinded ke ee <- applyDec dec $ checkExpr e tv+  let ki = intersectKind ke $ predKind kt+  return $ (tv, te, Kinded ki ee)++-- inferType t = (s, te)+inferType :: Expr -> TypeCheck (Sort Val, Kinded Extr)+inferType t = do+  (sv, te) <- inferExpr t+  case sv of+    VSort s | not (s `elem` map SortC [Tm,Size]) -> return (s,te)+    _ -> throwErrorMsg $ "inferExpr: expected " ++ show t ++ " to be a type!"++-- inferExpr e = (tv, s, ee)+-- input : expr e | inferable e+-- output: type tv, kind s, and erased form ee of e+-- the kind tells whether e is a term, a size, a set, ...+inferExpr :: Expr -> TypeCheck (TVal, Kinded Extr)+inferExpr e = do+  (tv, ee) <- inferExpr' e+  case tv of+    VGuard beta vb -> do+      checkGuard beta+      return (vb, ee)+    _ -> return (tv, ee)++inferProj :: Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Extr)+inferProj e1 fx p = checkingCon False $ do+            (v, Kinded ki1 e1e) <- inferExpr e1+{-+            let fail1 = failDoc (text "expected" <+> prettyTCM e1 <+> text "to be of record type when taking the projection" <+> text p <> comma <+> text "but found type" <+> prettyTCM v)+            let fail2 = failDoc (text "record" <+> prettyTCM e1 <+> text "of type" <+> prettyTCM v <+> text "does not have field" <+> text p)+-}+            v <- force v -- if v is a corecursively defined type in Set, unfold!+            tv <- projectType v p =<< whnf' e1e+            return (tv, Kinded ki1 (proj e1e fx p))+{-+            case v of+              VApp (VDef (DefId Dat d)) vl -> do+                mfs <- getFieldsAtType d vl+                case mfs of+                  Nothing -> fail1+                  Just ptvs ->+                    case lookup p ptvs of+                      Nothing -> fail2+                      Just tv -> do+                        tv <- piApp tv VIrr -- cut of record arg+                        return (tv, Kinded ki1 (App e1e (Proj p)))+              _ -> fail1+-}+++-- inferExpr' might return a VGuard, this is removed in inferExpr+-- the returned kind for constructor type is computed as the union+-- of the kinds of the non-erased arguments+-- otherwise it is the kind of the target+inferExpr' :: Expr -> TypeCheck (TVal, Kinded Extr)+inferExpr' e = enter ("inferExpr' " ++ show e) $+  let returnSing (Kinded ki ee) tv = do+        tv' <- sing' ee tv+        return (tv', Kinded ki ee)+  in+    (case e of++      Var x -> do+        traceCheckM ("infer variable " ++ show x)+        item <- lookupName1 x+        traceCheckM ("infer variable: retrieved item ")+        let dom = domain item+            av  = typ dom+        traceCheckM ("infer variable: " ++ show av)+        enterDoc (text "inferExpr: variable" <+> prettyTCM x <+> colon <+> prettyTCM av <+> text "may not occur") $ do+          let dec  = decor dom+              udec = upperDec item+              pol  = polarity dec+              upol = polarity udec+          when (erased dec && not (erased udec)) $+            recoverFail ", because it is marked as erased"+          enter ", because of polarity" $+            leqPolM pol upol+        traceCheckM ("infer variable returns")+        traceCheckM ("infer variable " ++ show x ++ " : " ++ show av)+        return $ (av, Kinded (kind dom) $ Var x)+{-+        let err = "inferExpr: variable " ++ x ++ " : " ++ show (typ item) +++                  " may not occur"+        let dec = decor item+        let pol = polarity dec+        if erased dec then+          throwErrorMsg $ err ++ ", because it is marked as erased"+         else if not (leqPol pol SPos) then+          throwErrorMsg $ err ++ ", because it has polarity " ++ show pol+         else do+           -- traceCheckM ("infer variable " ++ x ++ " : " ++ show  (typ item))+           return $ (typ item, Var x) -- TODO: (typ item, kind item, Var x)+-}++      -- for constants, the kind coincides with the type!+      Sort (CoSet e) -> do+        ee <- checkSize e+        return (VSort (Set (VSucc VZero)), Kinded (kUniv Zero) $ Sort $ CoSet ee)+      Sort (Set e) ->  do+        (v, ee) <- checkLevel e+        return (VSort (Set (succSize v)), Kinded (kUniv ee) $ Sort $ Set ee)+      Sort (SortC Size) -> return (vTSize, Kinded kTSize $ e)+      Zero -> return (vSize, Kinded kSize Zero)+      Infty -> return (vSize, Kinded kSize Infty)+      Below ltle e -> do+        ee <- checkSize e+        return (vTSize, Kinded kTSize $ Below ltle ee)++      Quant pisig (TBind n (Domain t1 _ dec)) t2 -> do+        -- make sure that in a constructor declaration the constructor args are+        -- mixed-variant (there is no subtyping between constrs anyway)+        checkCon <- asks checkingConType+{- TODO+        when (checkCon && polarity dec /= Mixed) $+          throwErrorMsg $ "constructor arguments must be declared mixed-variant"+-}+        (s1, Kinded ki0 t1e) <- (if pisig==Pi then checkingDom else id) $+          checkingCon False $ inferType t1 -- switch off parametric Pi+        -- the kind of the bound variable is the precedessor of the kind of its type+        let ki1 = predKind ki0+        addBind (TBind n (Domain t1e ki1 $ defaultDec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric)+        -- TODO:+        -- addBind (TBind n (Domain t1e ki1 $ coDomainDec dec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric)+          (s2, Kinded ki2 t2e) <- inferType t2+          ce <- ask+          let er = erased dec+          s <- if impredicative ce && er && s2 == Set VZero then return s2 else ptsRule er s1 s2 -- Impredicativity!+          -- improve erasure annotation: irrelevant arguments can be erased!+          let (ki',dec') = if checkCon then+                 -- in case of constructor types the kind is the union+                 -- of the kinds of the constructor arguments+                 if ki0 == kTSize then (ki2, irrelevantDec)+                  else if erased dec then (ki2, dec) -- do not count erased args in+                 else (unionKind ki0 ki2, dec)+                else (ki2, if argKind ki0 `irrelevantFor` (predKind ki2)+                            then irrelevantDec+                            else dec)+          -- the kind of the Pi-type is the kind of its target (codomain)+          return (VSort s, Kinded ki' $ Quant pisig (TBind n (Domain t1e ki1 dec')) t2e)++      Quant Pi (TMeasure (Measure mu)) t2 -> do+        mue <- mapM checkSize mu+        (s, Kinded ki2 t2e) <- inferType t2+        return (VSort s, Kinded ki2 $ Quant Pi (TMeasure (Measure mue)) t2e)++      Quant Pi (TBound (Bound ltle (Measure mu) (Measure mu'))) t2 -> do+        (mue,mue') <- checkingDom $ do+          mue  <- checkingDom $ mapM checkSize mu+          mue' <- mapM checkSize mu'+          return (mue,mue')+        (s, Kinded ki2 t2e) <- inferType t2+        return (VSort s, Kinded ki2 $ Quant Pi (TBound (Bound ltle (Measure mue) (Measure mue'))) t2e)++      Sing e1 t -> do+        (s, Kinded ki te) <- inferType t+        tv <- whnf' te+        Kinded ki1 e1e <- checkExpr e1 tv+        return (VSort $ s, Kinded (intersectKind ki $ succKind ki1) -- not sure how useful the intersection is, maybe just ki is good enough+                             $ Sing e1e te)++{- Not safe to infer pairs because of irrelevance!+      Pair e1 e2 -> do+        (tv1, Kinded k1 e1) <- inferExpr e1+        (tv2, Kinded k2 e2) <- inferExpr e2+        let ki = unionKind k1 k2+            tv = prod tv1 tv2+        return (tv, Kinded ki $ Pair e1 e2)+-}++      App (Proj Pre p) e  -> inferProj e Pre p+      App e (Proj Post p) -> inferProj e Post p++      App e1 e2 -> checkingCon False $ do+        (v, Kinded ki1 e1e) <- inferExpr e1+        (Kinded ki2 (_, e2e), bv) <- checkApp e2 v+        -- the kind of the application is the kind of its head+        return (bv, Kinded ki1 $ App e1e e2e)+{-+            v <- force v -- if v is a corecursively defined type in Set, unfold!+            case v of+               VQuant Pi x (Domain av _ dec) env b -> do+                  (v2,e2e) <-+                    if inferable e2 then do+                  -- if e2 has a singleton type, we should not take v2 = whnf e2+                  -- but use the single value of e2+                  -- this is against the spirit of bidir. checking+                           -- if checking a type we need to resurrect+                           (av', Kinded _ e2e) <- applyDec dec $ inferExpr e2+                           case av' of+                              VSing v2 av'' -> do subtype av' av+                                                  return (v2,e2e)+                              _ -> do checkSubtype e2e av' av+                                      v2 <- whnf' e2e+                                      return (v2, e2e)+                         else do+                           Kinded _ e2e <- applyDec dec $ checkExpr e2 av+                           v2 <- whnf' e2+                           return (v2, e2e)+                  bv <- whnf (update env x v2) b+                  -- the kind of the application is the kind of its head+                  return (bv, Kinded ki1 $ App e1e (if erased dec then erasedExpr e2e else e2e))+-- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e])+               _ -> throwErrorMsg $ "inferExpr : expected Pi with expression : " ++ show e1 ++ "," ++ show v+-}++--      App e1 (e2:el) -> inferExpr $ (e1 `App` [e2]) `App` el+      -- 2012-01-22 no longer infer constructors+      (Def id@(DefId {idKind, idName = name})) | not (conKind idKind) -> do -- traceCheckM ("infer defined head " ++ show n)+         mitem <- errorToMaybe $ lookupName1 $ unqual name+         case mitem of -- first check if it is also a var name+           Just item -> do -- we are inside a mutual declaration (not erased!)+             let pol  = (polarity $ decor $ domain item)+             let upol = (polarity $ upperDec item)+             mId <- asks checkingMutualName+             case mId of+               Just srcId ->+                 -- we are checking constructors or function bodies+                 addPosEdge srcId id upol+               Nothing ->+                 -- we are checking signatures+                 enter ("recursive occurrence of " ++ show name ++ " not strictly positive") $+                   leqPolM pol upol+             return (typ $ domain item, Kinded (kind $ domain item) $ e)+           Nothing -> -- otherwise, it is not the data type name just being defined+                 do sige <- lookupSymbQ name+                    case sige of+                      -- data types have always kind Set 0!+                      (DataSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e)+                      (FunSig  { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e)+                      -- constructors are always terms+                      (ConSig  { symbTyp = tv }) -> returnSing (Kinded kTerm e) tv  -- constructors have sing.type!+                      (LetSig  { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) -- return $ vSing v tv+{-+      (Con _ n) -> do sig <- gets signature+                      case (lookupSig n sig) of+      (Let n) -> do sig <- gets signature+                    case (lookupSig n sig) of+-}+      _ -> throwErrorMsg $ "cannot infer type of " ++ show e+     ) >>= \ tv -> ask >>= \ ce ->+         traceCheck ("inferExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " :=> " ++ show tv ++ " in env" ++ show (environ ce)) $+--         traceCheck ("inferExpr: " ++ show e ++ " :=> " ++ show tv) $+           return tv+++{- BAD IDEA!+improveDec :: Dec -> TVal -> Dec+improveDec dec v = if v == VSet || v == VSize then erased else dec+-}++{-+-- entry point 3: resurrects+checkType :: Expr -> TypeCheck Extr+checkType e = (resurrect $ checkType' e) `throwTrace` ("not a type: " ++ show e )++checkType' :: Expr -> TypeCheck Extr+checkType' e = case e of+    Sort s -> return e+    Pi dec x t1 t2 -> do+        t1e <- checkType' t1+        -- ignore erasure flag in types!+--        t1v <- whnf' t1e+--        new' x (Domain (Dec False) t1v) $ do+        addBind x (Dec False) t1e $ do+          t2e <- checkType' t2+          return $ Pi dec x t1e t2e  -- Pi (improveDec dec t1v) x t1e t2e+    _ -> checkExpr' e $ VSort Set+-}++checkType :: Expr -> TypeCheck (Kinded Extr)+checkType t =+  enter ("not a type: " ++ show t) $+    resurrect $ do+      (s, te) <- inferType t+      leqSort Pos s (Set VInfty)+      return te++checkSmallType :: Expr -> TypeCheck (Kinded Extr)+checkSmallType t =+  enter ("not a set: " ++ show t) $+    resurrect $ do+      (s, te) <- inferType t+      case s of+        Set VZero -> return te+        CoSet{} -> return te+        _ -> throwErrorMsg $ "expected " ++ show s ++ " to be Set or CoSet _"++{-+-- small type+checkSmallType :: Expr -> TypeCheck Extr+checkSmallType e  = (resurrect $ checkExpr' e $ VSort Set) `throwTrace` ("not a set: " ++ show e )+-}++-- check telescope and add bindings to contexts+checkTele :: Telescope -> TypeCheck a -> TypeCheck (ETelescope, a)+checkTele (Telescope tel) k = loop tel where+  loop tel = case tel of+    []                                  -> (emptyTel,) <$> k+    tb@(TBind x (Domain t _ dec)) : tel -> do+      Kinded ki te <- checkType t+      let tb = TBind x (Domain te (predKind ki) dec)+      (tel, a) <- addBind tb $ loop tel+      return (Telescope $ tb : telescope tel, a)++-- the integer argument is the number of the clause, used just for user feedback+checkCases :: Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])+checkCases = checkCases' 1++checkCases' :: Int -> Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])+checkCases' i v tv [] = return $ Kinded NoKind []+checkCases' i v tv (c : cl) = do+    Kinded k1 ce  <- checkCase i v tv c+    Kinded k2 cle <- checkCases' (i + 1) v tv cl+    return $ Kinded (unionKind k1 k2) $ ce : cle++checkCase :: Int -> Val -> TVal -> Clause -> TypeCheck (Kinded EClause)+checkCase i v tv cl@(Clause _ [p] mrhs) = enter ("case " ++ show i) $+  -- traceCheck ("checking case " ++ show i) $+    do+      -- clearDots -- NOT NEEDED+      (flex,ins,cxt,vt,pe,pv,absp) <- checkPattern neutral [] emptySub tv p+      local (\ _ -> cxt) $ do+        mapM (checkGoal ins) flex+        tel <- getContextTele -- TODO!+        case (absp,mrhs) of+           (True,Nothing) -> return $ Kinded NoKind (Clause tel [pe] Nothing)+           (False,Nothing) -> throwErrorMsg ("missing right hand side in case " ++ showCase cl)+           (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in case " ++ showCase cl)+           (False,Just rhs) -> do+              -- pv <- whnf' (patternToExpr p) -- DIFFICULT FOR DOT PATTERNS!+      --        vp <- patternToVal p -- BUG: INTRODUCES FRESH GENS, BUT THEY HAVE ALREADY BEEN INTRODUCED IN checkPattern+              addRewrite (Rewrite v pv) [vt] $ \ [vt'] -> do+                Kinded ki rhse <- checkRHS ins rhs vt'+                return $ Kinded ki (Clause tel [pe] (Just rhse))+                -- [rhs'] <- solveAndModify [rhs] (environ cxt)+                -- return (Clause [p] rhs')++-- type check a function++checkFun :: Type -> [Clause] -> TypeCheck (Kinded [EClause])+checkFun t cl = do+  tv <- whnf' t+  checkClauses tv cl++-- the integer argument is the number of the clause, used just for user feedback+checkClauses :: TVal -> [Clause] -> TypeCheck (Kinded [EClause])+checkClauses = checkClauses' 1++checkClauses' :: Int -> TVal -> [Clause] -> TypeCheck (Kinded [EClause])+checkClauses' i tv [] = return $ Kinded NoKind ([])+checkClauses' i tv (c:cl) = do+    Kinded ki1 ce  <- checkClause i tv c+    Kinded ki2 cle <- checkClauses' (i + 1) tv cl+    return $ Kinded (unionKind ki1 ki2) $ (ce : cle)++-- checkClause i tv cl = (cl', cle)+-- checking one equation cl of a function at type tv+-- solve size constraints+-- substitute solution into clause, resulting in cl'+-- return also extracted clause cle+checkClause :: Int -> TVal -> Clause -> TypeCheck (Kinded EClause)+checkClause i tv cl@(Clause _ pl mrhs) = enter ("clause " ++ show i) $ do+  -- traceCheck ("checking function clause " ++ show i) $+    -- clearDots -- NOT NEEDED+    (flex,ins,cxt,tv0,ple,plv,absp) <- checkPatterns neutral [] emptySub tv pl+    -- 2013-03-30 When checking the rhs, we only allow new size hypotheses+    -- if they do not break any valuation of the existing hypotheses.+    -- See ICFP 2013 paper.+    -- We exclude cofuns here, for experimentation.+    -- Note that cofuns need not be SN, so the strict consistency may be+    -- not necessary.+    local (\ _ -> cxt { consistencyCheck = (mutualCo cxt == Ind) }) $ do+      mapM (checkGoal ins) flex+{-+      dots <- openDots+      unless (null dots) $+        recoverFailDoc $ text "the following dotted constructors could not be confirmed: " <+> prettyTCM dots+-}+      -- TODO: insert meta var solution in dot patterns+      tel <- getContextTele -- WRONG TELE, has VGens for DotPs+      case (absp,mrhs) of+         (True,Nothing) -> return $ Kinded NoKind (Clause tel ple Nothing)+         (False,Nothing) -> throwErrorMsg ("missing right hand side in clause " ++ show cl)+         (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in clause " ++ show cl)+         (False,Just rhs) -> do+            Kinded ki rhse <- checkRHS ins rhs tv0+            env  <- getEnv+            [rhse] <- solveAndModify [rhse] env+            return $ Kinded ki (Clause tel ple (Just rhse))+++-- * Pattern checking ------------------------------------------------++type Substitution = Valuation -- [(Int,Val)]++emptySub    = emptyVal+sgSub       = sgVal+lookupSub i = lookup i . valuation++type DotFlex = (Int,(Expr,Domain))++-- left over goals+data Goal+    = DotFlex Int (Maybe Expr) Domain+      -- ^ @Just@ : Flexible variable from inaccessible pattern.+      -- ^ @Nothing@ : Flexible variable from hidden function type.+    | MaxMatches Int TVal+    | DottedCons Dotted Pattern TVal+  deriving Show++-- checkPatterns is initially called with an empty local context+-- in the type checking monad+checkPatterns :: Dec -> [Goal] -> Substitution -> TVal -> [Pattern] -> TypeCheck ([Goal],Substitution,TCContext,TVal,[EPattern],[Val],Bool)+checkPatterns dec0 flex ins v pl =+  case v of+    VMeasured mu vb -> setMeasure mu $ checkPatterns dec0 flex ins vb pl+    VGuard beta vb -> addBoundHyp beta $ checkPatterns dec0 flex ins vb pl+{-+    VGuard beta vb -> throwErrorMsg $ "checkPattern at type " ++ show v ++ " --- introduction of constraints not supported"+-}+    _ -> case pl of+      [] -> do cxt <- ask+               return (flex,ins,cxt,v,[],[],False)+      (p:pl') -> do (flex',ins',cxt',v',pe,pv,absp) <- checkPattern dec0 flex ins v p+                    local (\ _ -> cxt') $ do+                      (flex'',ins'',cxt'',v'',ple,plv,absps) <- checkPatterns dec0 flex' ins' v' pl'+                      return (flex'',ins'',cxt'',v'', pe:ple, pv:plv, absp || absps) -- if pe==IrrP then ple else pe:ple)++{-+checkPattern dec0 flex subst tv p = (flex', subst', cxt', tv', pe, pv, absp)++Input :+  dec0  : context in which pattern occurs (irrelevant, parametric, recursive)+          are we checking an erased argument? (constr. pat. needs to be forced!)+  flex  : list of pairs (flexible variable, its dot pattern + supposed type)+  subst : list of pairs (flexible variable, its valuation)+  cxt   : in monad, containing+    rho   : binding of variables to values+    delta : binding of generic values to their types+  tv    : type of the expression \ p -> t+  p     : the pattern to check++Output+  tv'   : type of t+  pe    : erased pattern+  pv    : value of pattern (this is in essence whnf' pe,+            but we cannot evaluate because of dot patterns)+  absp  : did we encounter an absurd pattern+-}++checkPattern :: Dec -> [Goal] -> Substitution -> TVal -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,TVal,EPattern,Val,Bool)+checkPattern dec0 flex ins tv p = -- ask >>= \ TCContext { context = delta, environ = rho } -> trace ("checkPattern" ++ ("\n  dot pats: " +?+ show flex) ++ ("\n  substion: " +?+ show ins) ++ ("\n  environ : " +?+ show rho) ++ ("\n  context : " +?+ show delta) ++ "\n  pattern : " ++ show p ++ "\n  at type : " ++ show tv ++ "\t<>") $+ enter ("pattern " ++ show p) $ do+  tv <- force tv+  case tv of+    -- record type can be eliminated+    VApp (VDef (DefId DatK d)) vl ->+      case p of+        ProjP proj -> do+          tv <- projectType tv proj VIrr -- do not have record value here+          cxt <- ask+          return (flex, ins, cxt, tv, p, VProj Post proj, False)+{-+          mfs <- getFieldsAtType d vl+          case mfs of+            Nothing -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with projection pattern" <+> prettyTCM p)+            Just ptvs ->+              case lookup proj ptvs of+                Nothing -> failDoc (text "record type" <+> prettyTCM tv <+> text "does not know projection" <+> text proj)+                Just tv -> do+                  tv <- piApp tv VIrr -- cut of record arg+                  cxt <- ask+                  return (flex, ins, cxt, tv, p, VProj proj, False)+-}+        _ -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with a non-projection pattern")++    -- intersection type+    VQuant Pi x dom@(Domain av ki Hidden) fv -> do+      -- introduce new flexible variable+      newWithGen x dom $ \ i xv -> do+        tv <- fv `app` xv+        checkPattern dec0 (DotFlex i Nothing dom : flex) ins tv p++    -- function type can be eliminated+    VQuant Pi x (Domain av ki dec) fv -> do+{-+       let erased' = er || erased dec+       let decEr   = if erased' then irrelevantDec else dec -- dec {erased = erased'}+-}+       let decEr = dec `compose` dec0+       let domEr   =  (Domain av ki decEr)+       case p of++         -- treat successor pattern here, because of admissibility check+         SuccP p2 -> do+                 when (av /= vSize) $ throwErrorMsg "checkPattern: expected type Size"+                 when (isSuccessorPattern p2) $ cannotMatchDeep p tv++                 co <- asks mutualCo+                 when (co /= CoInd) $+                   throwErrorMsg ("successor pattern only allowed in cofun")++                 enterDoc (text ("checkPattern " ++ show p ++" : matching on size, checking that target") <+> prettyTCM tv <+> text "ends in correct coinductive sized type") $+                   underAbs x domEr fv $ \ i _ bv -> endsInSizedCo i bv++                 cxt <- ask+                 -- 2012-02-05 assume size variable in SuccP to be < #+                 let sucTy = (vFinSize `arrow` vFinSize)+                 (flex',ins',cxt',tv',p2e,p2v,absp) <- checkPattern decEr flex ins sucTy p2+                 -- leqVal Mixed delta' VSet VSize av -- av = VSize+                 let pe = SuccP p2e+                 let pv = VSucc p2v+--                 pv0 <- local (\ _ -> cxt') $ whnf' $ patternToExpr pe+                 -- pv0 <- patternToVal p -- RETIRE patternToVal+                 -- pv  <- up False pv0 av -- STUPID what can be eta-exanded at type Size??+                 vb  <- app fv pv+{-+                 endsInCoind <- endsInSizedCo pv vb+                 when (not endsInCoind) $ throwErrorMsg $ "checkPattern " ++ show p ++" : cannot match on size since target " ++ show tv ++ " does not end in correct coinductive sized type"+-}+                 return (flex',ins',cxt',vb,pe,pv,absp)++         -- other patterns: no need to know about result type+         _ -> do+           (flex',ins',cxt',pe,pv,absp) <- checkPattern' flex ins domEr p+           -- traceM ("checkPattern' returns " ++ show (flex',ins',cxt',pe,pv,absp))+           vb  <- app fv pv+           vb  <- substitute ins' vb  -- from ConP case -- ?? why not first subst and then whnf?+           -- traceCheckM ("Returning type " ++ show vb)+           return (flex',ins',cxt',vb,pe,pv,absp)++    _ -> throwErrorMsg $ "checkPattern: expected function type, found " ++ show tv++-- TODO: refactor with monad transformers+-- put absp into writer monad++turnIntoVarPatAtUnitType :: TVal -> Pattern -> TypeCheck Pattern+turnIntoVarPatAtUnitType (VApp (VDef (DefId DatK n)) _) p@(ConP pi c []) =+  flip (ifM $ isUnitData n) (return p) $ do+    let x = fresh "un!t"+    return $ VarP x+turnIntoVarPatAtUnitType _ p = return p++checkPattern' :: [Goal] -> Substitution -> Domain -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,EPattern,Val,Bool)+checkPattern' flex ins domEr@(Domain av ki decEr) p = do+       p <- turnIntoVarPatAtUnitType av p+       case p of+          SuccP{} -> failDoc (text "successor pattern" <+> prettyTCM p <+> text "not allowed here")++          PairP p1 p2 -> do+            av <- force av+            case av of+             VQuant Sigma y dom1@(Domain av1 ki1 dec1) fv -> do+              (flex, ins, cxt, pe1, pv1, absp1) <-+                 checkPattern' flex ins (Domain av1 ki1 $ dec1 `compose` decEr) p1+              av2 <- app fv pv1+              (flex, ins, cxt, pe2, pv2, absp2) <-+                 local (const cxt) $+                   checkPattern' flex ins (Domain av2 ki decEr) p2+              return (flex, ins, cxt, PairP pe1 pe2, VPair pv1 pv2, absp1 || absp2)+             _ -> failDoc (text "pair pattern" <+> prettyTCM p <+> text "could not be checked against type" <+> prettyTCM av)+{-+   (x : Sigma y:A. B) -> C+     =iso= (y : A) -> (x' : B) -> C[(y,x')/x]++   (x : Sigma y:V. <B;rho1>) -> <C;rho2>+     =iso= (y : V) -> <(x': B) -> C; ?? x=(y,x')>+ -}+{-+            case av of+              VQuant Sigma y dom1@(Domain av1 ki1 dec1) env1 a2 -> do+                let x' = x ++ "#2"+                    ep = Pair (Var y) (Var x')+                    tv = VQuant Pi y dom1 env1 $+                           Quant x' (Domain a2+-}++          ProjP proj -> failDoc (text "cannot eliminate type" <+> prettyTCM av <+> text "with projection pattern" <+> prettyTCM p)++          VarP y -> do+            new y domEr $ \ xv -> do+              cxt' <- ask+              p' <- case av of+                       VBelow Lt v -> flip SizeP y <$> toExpr v+                       _ -> return p+              return (flex, ins, cxt', maybeErase $ p', xv, False)++{- checking bounded size patterns++    ex : [i : Size] -> [j : Below< i] -> ...+    ex i (j < i) = ...++  type of pattern : Below< i needs to cover type of parameter Below< i++    zero : [j : Size] -> Nat $j   -- need to hold a "sized con type"+    zero : [j < i]    -> Nat i++    ex : [i : Size] -> (n : Nat i) -> ...+    ex i (zero (j < i) = ...++  type of size-pat : Below< i++-}+          SizeP e y -> do -- pattern (z > y), y is the bound variable, z the bound of z+            e <- resurrect $ checkSize e -- (Var z)+            newWithGen y domEr $ \ j xv -> do+{-+               VGen k <- whnf' (Var z)+               addSizeRel j 1 k $ do  -- j < k+-}+               ve <- whnf' e+               addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ do+                 subtype av (VBelow Lt ve)+                 cxt' <- ask+                 return (flex, ins, cxt', maybeErase $ SizeP e y, xv, False)++          AbsurdP -> do+                 when (isFunType av) $ throwErrorMsg ("absurd pattern " ++ show p ++ " does not match function types, like " ++ show av)+                 cxt' <- ask+                 return (MaxMatches 0 av : flex, ins, cxt', maybeErase $ AbsurdP, VIrr, True)+{-+                 cenvs <- matchingConstructors av  -- TODO: av might be MVar+                                                   -- need to be postponed+                 case cenvs of+                    [] -> do bv   <- whnf (update env x VIrr) b+                             cxt' <- ask+                             return (flex, ins, cxt', bv, maybeErase $ AbsurdP, True)+                    _ -> throwErrorMsg $ "type " ++ show av ++ " of absurd pattern not empty"+-}++          -- always expand defined patterns!+          p@(ConP pi n ps) | coPat pi == DefPat -> do+            checkPattern' flex ins domEr =<< expandDefPat p++--          ConP pi n pl | not $ dottedPat pi -> do+          ConP pi n pl -> do++                 -- disambiguate constructor first+                 n <- disambigCon n av++                 let co     = coPat pi+                     dotted = dottedPat pi++                 -- First check that we do not match against an irrelevant argument.+                 unless dotted $ nonDottedConstructorChecks n co pl+{- TODO+                 enter ("can only match non parametric arguments") $+                   leqPolM (polarity dec) (pprod defaultPol)+-}+                 (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- checkConstructorPattern co n pl++                 when (isFunType vc') $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " of type " ++ show vc' ++ " not allowed")+                 let flexgen = concat $ map (\ g -> case g of+                        DotFlex i _ _ -> [i]+                        _ -> []) flex'+                     -- fst $ unzip flex'+--                  av1 <- sing (environ cxt') (patternToExpr p) vc'+--                  av2 <- sing (environ cxt') (patternToExpr p) av+--                  subst <- local (\ _ -> cxt') $ inst flexgen VSet av1 av2+++                 -- need to evaluate the erased pattern!+                 let pe = ConP pi n ple -- erased pattern+                 -- dot <- if dottedPat pi then newDotted p else return notDotted+                 dot <- if dottedPat pi then mkDotted True else return notDotted+                 pv0 <- mkConVal dot co n pvs vc+                 -- OLD: let pv0 = VDef (DefId (ConK co) n) `VApp` pvs+{-+                 let epe = patternToExpr pe+                 pv0 <- local (\ _ -> cxt') $ whnf' epe+--                 pv0 <- patternToVal p -- THIS USE should be ok, since the new GENs are not in the global context yet, only in cxt' -- NO LONGER ok with erasure!+                 -- traceM $ "sucessfully computed value " ++ show pv0 ++ " of pattern " ++ show epe+-}++                 subst <- local (\ _ -> cxt') $ do+                   case av of  -- TODO: need subtyping-unify instead of unify??+                     VSing vav av0 -> do+                       vav <- whnfClos vav+                       inst Pos flexgen av0 pv0 vav+                     _ -> unifyIndices flexgen vc' av  -- vc' <= av ?!+                   -- THIS IMPLEMENTATION RELIES HEAVILY ON INJECTIVITY OF DATAS++{- moved to checkRHS+                 -- apply substitution to measures in environment+                 let mmu = (envBound . environ) cxt'+                 mmu' <- Traversable.mapM (substitute subst) mmu+-}+{-+                 ins'' <- compSubst ins' subst+                 vb <- substitute ins'' vb+                 delta' <- substitute ins'' delta'+-}+                 ins''   <- compSubst ins' subst -- 2010-07-27 not ok to switch!+                 delta'' <- substitute ins'' (context cxt')+                 traceCheckM $ "delta'' = " ++ show delta''+                 av  <- substitute ins'' av  -- 2010-09-22: update av+                 pv  <- up False pv0 av++                 -- if the constructor was dotted, make sure it is the only match+                 let flex'' = fwhen dotted (DottedCons dot p av :) flex'+                 return (flex'', ins'', cxt' { context = delta'' },+                         maybeErase pe, pv, absp)+{- DO NOT UPDATE measure here, its done in checkRHS+                 return (flex', ins'', cxt' { context = delta'', environ = (environ cxt') { envBound = mmu' } }, vb',+                         maybeErase pe, absp)+-}+++{- UNUSED+          -- If we encounter a dotted constructor, we simply+          -- compute the pattern variable context+          -- and then treat the pattern as dot pattern.+          p@(ConP pi n ps) | dottedPat pi -> do+            (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <-+              checkConstructorPattern (coPat pi) n ps+            local (const cxt') $+              checkPattern' flex ins domEr $ DotP $ patternToExpr p+-}++          DotP e -> do+            -- create an informative, but irrelevant identifier for dot pattern+            let xp = fresh $ "." ++ case e of Var z -> suggestion z; _ -> Util.parens $ show e+            newWithGen xp domEr $ \ k xv -> do+                       cxt' <- ask+                       -- traceCheck ("Returning type " ++ show vb) $+                       return (DotFlex k (Just e) domEr : flex+                              ,ins+                              ,cxt'+                              ,maybeErase $ DotP e -- $ Var xp -- DotP $ Meta k -- e -- Meta k+                              -- ,maybeErase $ -- AbsurdP -- VarP $ show e+                              ,xv+                              ,False) -- TODO: Erase in e/ Meta subst!+{- original code+                    do let (k, delta') = cxtPush dec av delta+                       vb <- whnf (update env x (VGen k)) b+                       return ((k,(e,Domain av dec)):flex+                              ,ins+                              ,rho+                              ,delta'+                              ,vb)+-}++    where+      maybeErase p = if erased decEr then ErasedP p else p++      checkConstructorPattern co n pl = do+                 when (isFunType av) $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " at type " ++ show av ++ " not allowed")+-- TODO: ensure that matchings against erased arguments are forced+--                 when (erased dec) $ throwErrorMsg $ "checkPattern: cannot match on erased argument " ++ show p ++ " : " ++ show av++                 ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n++                 -- the following is a hack to still support old-style+                 --   add .($ i) (zero i) ...+                 -- fun defs:  if (zero i) is matched against (Nat flexvar$i)+                 -- we use the old constructor type [i : Size] -> Nat $i+                 -- else, the new one [j < i] -> Nat i+                 let flexK k (DotFlex k' _ _) = k == k'+                     flexK k _ = False+                     -- use lhs con type only if sizeindex is not a rigid var+                     isFlex (VGen k) = List.any (flexK k) flex+                     isFlex _ = True+                     isSz = if co == Cons then sz else Nothing+                 vc <- instConLType n conPars vc isSz isFlex dataPars =<< force av+{-+                 vc <- case sz of+                         Nothing -> instConType n nPars vc =<< force av+                         Just vc -> instConType n (nPars+1) vc =<< force av+-}++                 -- (flex',ins',cxt',vc',ple,pvs,absp) <-+                 (vc,) <$> checkPatterns decEr flex ins vc pl+++      -- These checks are only relevant if a constructor is an actual match.+      nonDottedConstructorChecks n co pl = do+        ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n++        -- check that size argument of coconstr is dotted+        when (co == CoCons && isJust sz) $ do+          let sizep = head pl  -- 2012-01-22: WAS (pl !! nPars)+          unless (isDotPattern sizep) $+            throwErrorMsg $ "in pattern " ++ show p  ++ ", coinductive size sub pattern " ++ show sizep ++ " must be dotted"++        when (not $ decEr `elem` map Dec [Const,Rec]) $+          recoverFail $ "cannot match pattern " ++ show p ++ " against non-computational argument"+        -- check not to match non-trivially against erased stuff+        when (decEr == Dec Const) $ do+          let failNotForced = recoverFail $ "checkPattern: constructor " ++ show n ++ " of non-computational argument " ++ show p ++ " : " ++ show av ++ " not forced"+          mcenvs <- matchingConstructors av+          case mcenvs of+             Nothing -> do -- now check whether dataName is a record type+               DataSig { constructors } <- lookupSymb dataName+               unless (length constructors == 1) $ failNotForced+               return ()+             Just [] -> recoverFail $ "checkPattern: no constructor matches type " ++ show av+             Just [(ci, _)] | cName ci == n -> return ()+             _ -> failNotForced+++++{- New treatment of size matching  (see examples/Sized/Cody.ma)++sized data O : Size -> Set+{ Z : [i : Size] -> O ($ i)+; S : [i : Size] -> O i -> O ($ i)+; L : [i : Size] -> (Nat -> O i) -> O ($ i)+; M : [i : Size] -> O i -> O i -> O ($ i)+}++fun deep : [i : Size] -> O i -> Nat -> Nat+{ deep i4 (M i3 (L j2 f) (S i2 (S i1 (S i x)))) n+  = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n)))+; deep i x n = n+}++Explicit form:  Size variables and their constraints are noted explicitely,+to be able to do untyped call extraction in the termination module.++ deep i4+  (M (i4 > i3)+       (L (i3 > j2) f)+       (S (i3 > i2)+            (S (i2 > i1)+                 (S (i1 > i) x)))) n+  = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n)))++i4, i3, ... are all rigid variables with constraints between them.+There is a tree hierarchy, but I do not know whether I can exploit+this.++  i4 > i3 > i2 > i1 > i+          > j3++This could be stored in a union-find-like data structure, or just in+the constraint matrix.++How to pattern match?++  id : [i : Size] -> List i -> List i+  id i (cons (i > j) x xs) = cons j x (id j xs)++Only a size variable matches a size arguments++  match  (cons (i > j) x xs)   against   List i+  get    cons : [j : Size] -> Nat -> List j -> List ($ j)+  yield  x : Nat, xs : List j, cons j x xs : List ($ j)+  check  List ($ j) <= List i+ -}++{- RETIRED+-- checkDot does not need to extract+checkDot :: Substitution -> DotFlex -> TypeCheck ()+checkDot subst (i,(e,it)) = enter ("dot pattern " ++ show e) $+  case (lookup i subst) of+    Nothing -> throwErrorMsg $ "not instantiated"+    Just v -> do+      tv <- substitute subst (typ it)+      ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv)+      applyDec (decor it) $ do+        checkExpr e tv+        v' <-  whnf' e -- TODO: has subst erased terms?+        enter ("inferred value " ++ show v ++ " does not match given dot pattern value " ++ show v') $+          eqVal Pos tv v v'+-}++-- checkDot does not need to extract+-- 2012-01-25 now we do since "extraction" turns also con.terms into records+checkGoal :: Substitution -> Goal -> TypeCheck ()+checkGoal subst (DotFlex i me it) = enter ("dot pattern " ++ show me) $+  case lookupSub i subst of+    Nothing -> recoverFail $ "not instantiated"+    Just v -> whenJust me $ \ e -> do+      tv <- substitute subst (typ it)+      ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv)+--      applyDec (decor it) $ do+      resurrect $ do -- consider a DotP e always as irrelevant!+        e <- valueOf <$> checkExpr e tv+        v' <-  whnf' e -- TODO: has subst erased terms?+        enterDoc (text "inferred value" <+> prettyTCM v <+> text "does not match given dot pattern value" <+> prettyTCM v') $+          leqVal Pos tv v v' -- WAS: eqVal+checkGoal subst (MaxMatches n av) = do+  traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av)+  av' <- substitute subst av+  traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av')+  -- av' <- reval av'+  -- traceCheckM ("checkGoal: reevalutated " ++ show av')+  mcenvs <- matchingConstructors av'+  traceCheckM ("checkGoal matching constructors = " ++ show mcenvs)+  maybe (recoverFail $ "not a data type: " ++ show av')+   (\ cenvs ->+      if length cenvs > n then recoverFail $+        if n==0 then "absurd pattern does not match since type " ++ show av' ++ " is not empty"+         else+           "more than one constructor matches type " ++ show av'+       else return ())+   mcenvs+checkGoal subst (DottedCons dot p av)+  | isDotted dot =+      enterDoc (text "confirming dotted constructor" <+> prettyTCM p) $ do+        checkGoal subst (MaxMatches 1 av)+  | otherwise    = return ()++checkRHS :: Substitution -> Expr -> TVal -> TypeCheck (Kinded Extr)+checkRHS ins rhs v = do+   traceCheckM ("checking rhs " ++ show rhs ++ " : " ++ show v)+   enter "right hand side" $ do+     -- first update measure according to substitution for dot variables+     cxt <- ask+     let rho = environ cxt+     mmu' <- Traversable.mapM (substitute ins) (envBound rho)+     local (\ _ -> cxt { environ = rho { envBound = mmu' }}) $+       activateFuns $+         checkExpr rhs v++++-- TODO type directed unification++-- unifyIndices flex tv1 tv2+-- tv1 = D pars  inds  is the type of the pattern+-- tv2 = D pars' inds' is the type matched against+-- Note that in this case we can unify without using the principle of+-- injective data type constructors,+-- we are only calling unifyIndices from the constructor pattern case+-- in Checkpattern+unifyIndices :: [Int] -> Val -> Val -> TypeCheck Substitution+unifyIndices flex v1 v2 = ask >>= \ cxt -> enterDoc (text ("unifyIndices " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show Pos) <+> prettyTCM v2) $ do+-- {-+  case (v1,v2) of+    (VSing _ v1, VApp (VDef (DefId DatK d2)) vl2) ->+      flip (unifyIndices flex) v2 =<< whnfClos v1+    (VApp (VDef (DefId DatK d1)) vl1, VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 -> do+      (DataSig { numPars = np, symbTyp = tv, positivity = posl}) <- lookupSymbQ d1+      instList posl flex tv vl1 vl2 -- unify also parameters to solve dot patterns+    _ ->+-- -}+         inst Pos flex vTopSort v1 v2+-- throwErrorMsg ("unifyIndices " ++ show v1 ++ " =?= " ++ show v2 ++ " failed, not applied to data types")++-- unify, but first produce whnf+instWh :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution+instWh pos flex tv w1 w2 = do+  v1 <- whnfClos w1+  v2 <- whnfClos w2+  inst pos flex tv v1 v2++-- | Check occurrence and return singleton substitution.+assignFlex :: Int -> Val -> TypeCheck Substitution+assignFlex k v = do+  unlessM (nocc [k] v) $+    failDoc $+      text "variable " <+> prettyTCM (VGen k) <+>+      text " may not occur in " <+> prettyTCM v+  return $ sgSub k v++-- match v1 against v2 by unification , yielding a substition+inst :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution+inst pos flex tv v1 v2 = ask >>= \ cxt -> enterDoc (text ("inst " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show pos) <+> prettyTCM v2 <+> colon <+> prettyTCM tv) $ do+--  case tv of+--    (VPi dec x av env b) ->+  case (v1,v2) of+    (VGen k, VGen j) | k == j -> return emptySub+    (VGen k, _) | elem k flex -> assignFlex k v2+    (_, VGen k) | elem k flex -> assignFlex k v1++    -- injectivity of data type constructors is unsound in general+    (VApp (VDef (DefId DatK d1)) vl1,+     VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 ->  do+         (DataSig { numPars, symbTyp = tv, positivity = posl }) <- lookupSymbQ d1+         instList' numPars posl flex tv vl1 vl2+           -- ignore parameters (first numPars args)+           -- this is sound because we have irrelevance for parameters+           -- we assume injectivity for indices++    -- Constructor applications are represented as VRecord+    (VRecord (NamedRec _ c1 _ dot1) rs1,+     VRecord (NamedRec _ c2 _ dot2) rs2) | c1 == c2 -> do+         alignDotted dot1 dot2+         sige <- lookupSymbQ c1+         instList [] flex (symbTyp sige) (map snd rs1) (map snd rs2)++    (VSucc v1',     VSucc v2')     -> instWh pos flex tv v1' v2'+    (VSucc v,       VInfty)        -> instWh pos flex tv v   VInfty+    (VSing v1' tv1, VSing v2' tv2) -> do+      subst <- inst pos flex tv tv1 tv2+      u1 <- substitute subst v1'+      u2 <- substitute subst v2'+      tv1' <- substitute subst tv1+      inst pos flex tv1' u1 u2 >>= compSubst subst++-- HACK AHEAD+    (VUp v1 _, _) -> inst pos flex tv v1 v2+    (_, VUp v2 _) -> inst pos flex tv v1 v2+--    (VUp v1' a1, VUp v2' a2) -> instList flex [a1,v1'] [a2,v2']+--     (VPi dec x1 av1 env1 b1, VPi dec x2 av2 env2 b2) ->++{- TODO: REPAIR THIS+    _ -> traceCheck ("inst: WARNING! assuming " ++ show (context cxt) ++ " |- " ++ show v1 ++ " == " ++ show v2) $+           return [] -- throwErrorMsg $ "inst: NYI"+ -}+    _ -> do leqVal pos tv v1 v2 `throwTrace` ("inst: leqVal " ++ show v1 ++ " ?<=" ++ show pos ++ " " ++ show v2 ++ " : " ++ show tv ++ " failed")+            return emptySub++instList :: [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution+instList = instList' 0++-- unify lists, ignoring the first np items+instList' :: Int -> [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution+instList' np posl flex tv [] [] = return emptySub+instList' np posl flex tv (v1:vl1) (v2:vl2) = do+  v1 <- whnfClos v1+  v2 <- whnfClos v2+  if (np <= 0 || isMeta flex v1 || isMeta flex v2) then+    case tv of+      (VQuant Pi x dom fv) -> do+        let pol = getPol dom  -- WAS: (headPosl posl)+        subst <- inst pol flex (typ dom) v1 v2+        vl1' <- mapM (substitute subst) vl1+        vl2' <- mapM (substitute subst) vl2+        v    <- substitute subst v1+        fv   <- substitute subst fv+        vb   <- app fv v+        subst' <- instList' (np - 1) (tailPosl posl) flex vb vl1' vl2'+        compSubst subst subst'+   else+    case tv of+      (VQuant Pi x dom fv) -> do+        vb   <- app fv v2+        instList' (np - 1) (tailPosl posl) flex vb vl1 vl2+instList' np pos flex tv vl1 vl2 = throwErrorMsg $ "internal error: instList' " ++ show (np,pos,flex,tv,vl1,vl2) ++ " not handled"++headPosl :: [Pol] -> Pol+headPosl [] = mixed+headPosl (pos:_) = pos++tailPosl :: [Pol] -> [Pol]+tailPosl [] = []+tailPosl (_:posl) = posl+++isMeta :: [Int] -> Val -> Bool+isMeta flex (VGen k) = k `elem` flex+isMeta _ _ = False++----------------------------------------------------------------------+-- * Substitution into values+----------------------------------------------------------------------++-- | Overloaded substitution of values for generic values (free variables).+class Substitute a where+  substitute :: Substitution -> a -> TypeCheck a++instance Substitute v => Substitute (x,v) where+  substitute subst (x,v) = (x,) <$> substitute subst v++instance Substitute v => Substitute [v] where+  substitute = mapM . substitute++instance Substitute v => Substitute (Maybe v) where+  substitute = Traversable.mapM . substitute++instance Substitute v => Substitute (Map k v) where+  substitute = Traversable.mapM . substitute++instance Substitute v => Substitute (OneOrTwo v) where+  substitute = Traversable.mapM . substitute++instance Substitute v => Substitute (Dom v) where+  substitute = Traversable.mapM . substitute++instance Substitute v => Substitute (Measure v) where+  substitute = Traversable.mapM . substitute++instance Substitute v => Substitute (Bound v) where+  substitute = Traversable.mapM . substitute++instance Substitute v => Substitute (Sort v) where+  substitute = Traversable.mapM . substitute++-- substitute generic variable in value+instance Substitute Val where+  substitute subst v = do -- enterDoc (text "substitute" <$> prettyTCM v) $ do+    let sub v = substitute subst v+    case v of+      VGen k                -> return $ valuateGen k subst+      VApp v1 vl            -> foldM app ==<< (sub v1, sub vl)+      VSing v1 vt           -> vSing ==<< (sub v1, sub vt) -- TODO: Check reevaluation necessary?++      VSucc v1              -> succSize  <$> substitute subst v1+      VMax  vs              -> maxSize   <$> mapM (substitute subst) vs+      VPlus vs              -> plusSizes <$> mapM (substitute subst) vs++      VCase v1 tv1 env cl   -> VCase <$> sub v1 <*> sub tv1 <*> sub env <*> return cl+      VMeasured mu bv       -> VMeasured <$> sub mu <*> sub bv+      VGuard beta bv        -> VGuard <$> sub beta <*> sub bv++      VBelow ltle v         -> VBelow ltle <$> substitute subst v++      VQuant pisig x dom fv -> VQuant pisig x <$> sub dom <*> sub fv+      VRecord ri rs         -> VRecord ri <$> sub rs+      VPair v1 v2           -> VPair <$> sub v1 <*> sub v2+      VProj{}               -> return v++      VLam x env b          -> flip (VLam x) b <$> sub env+      VConst v              -> VConst <$> sub v+      VAbs x i v valu       -> VAbs x i v <$> sub valu+      VClos env e           -> flip VClos e <$> sub env+      VUp v1 vt             -> up False ==<< (sub v1, sub vt)+      VSort s               -> VSort <$> sub s+      VZero                 -> return $ v+      VInfty                -> return $ v+      VIrr                  -> return $ v+      VDef id               -> return $ vDef id  -- because empty list of apps will be rem.+      VMeta x env n         -> flip (VMeta x) n <$> sub env+{- REDUNDANT+      _ -> error $ "substitute: internal error: not defined for " ++ show v+-}++instance Substitute SemCxt where+  substitute subst delta = do+    cxt' <- substitute subst (cxt delta)+    return $ delta { cxt = cxt' }++-- | Substitute in environment.+instance Substitute Env where+  substitute subst (Environ rho mmeas) =+    Environ <$> substitute subst rho <*> substitute subst mmeas++instance Substitute Substitution where+  substitute subst2 subst1 = compSubst subst1 subst2++-- | "merge" substitutions by first applying the second to the first, then+--   appending them @t[sigma][tau] = t[sigma . tau]@+compSubst :: Substitution -> Substitution -> TypeCheck Substitution+compSubst (Valuation subst1) subst2@(Valuation subst2') =+    Valuation . (++ subst2') <$> substitute subst2 subst1++----------------------------------------------------------------------+-- * Size checking+----------------------------------------------------------------------++{- TODO: From a sized data declaration++  sized data D pars : Size -> t+  { c : [j : Size] -> args -> D pars $j ts+  }++  with constructor type++   c : .pars -> [j : Size] -> args -> D pars $j ts++  extract new-style constructor type++   c :  .pars -> [i : Size] -> [j < i : Size] -> args -> D pars i ts++  Then replace in ConSig filed isSized :: Sized  by :: Maybe Expr+  which stores the new-style constructor type++-}++mkConLType :: Int -> Expr -> (Name, Expr)+mkConLType npars t =+  let (Telescope (sizetb : tel), t0) = typeToTele t+  in case spineView t0 of+    (d@(Def (DefId DatK _)), args) ->+      let (pars, sizeindex : inds) = splitAt npars args+          i     = fresh "s!ze"+          args' = pars ++ Var i : inds+          core  = foldl App d args'+          tbi   = TBind i $ sizeDomain irrelevantDec+          tbj   = sizetb { boundDom = belowDomain irrelevantDec Lt (Var i) }+          tel'  = Telescope $ tbi : tbj : tel+      in (i, teleToType tel' core)+    _ -> error $ "conLType " ++ show npars ++ " (" ++ show t ++ "): illformed constructor type"++++-- * check wether the data type is sized type+++-- check data declaration type+-- called from typeCheckDeclaration (DataDecl{})+-- parameters : number of params, type+szType :: Co -> Int -> TVal -> TypeCheck ()+szType co p tv = doVParams p tv $ \ tv' -> do+    let polsz = if co==Ind then Pos else Neg+    case tv' of+      VQuant Pi x (Domain av ki dec) fv | isVSize av && not (erased dec) && polarity dec == polsz -> return ()+      _ -> throwErrorMsg $ "not a sized type, target " ++ show tv' ++ " must have non-erased domain " ++ show Size ++ " with polarity " ++ show polsz++-- * constructors of sized type++-- check data constructors+-- called from typeCheckConstructor+szConstructor :: Name -> Co -> Int -> TVal -> TypeCheck ()+szConstructor n co p tv = enterDoc (text ("szConstructor " ++ show n ++ " :") <+> prettyTCM tv) $ do+  doVParams p tv $ \ tv' ->+    case tv' of+       VQuant Pi x dom fv | isVSize (typ dom) ->+          underAbs x dom fv $ \ k xv bv -> do+            szSizeVarUsage n co p k bv+       _ -> throwErrorMsg $ "not a valid sized constructor: expected size quantification"++szSizeVarUsage :: Name -> Co -> Int -> Int -> TVal -> TypeCheck ()+szSizeVarUsage n co p i tv = enterDoc (text "szSizeVarUsage of" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $+    case tv of+       VQuant Pi x dom fv -> do+          let av = typ dom+          szSizeVarDataArgs n p i av  -- recursive calls of for D..i..+          enterDoc (text "checking" <+> prettyTCM av <+> text (" to be " +++              (if co == CoInd then "antitone" else "isotone") ++ " in variable")+              <+> prettyTCM (VGen i)) $+            szMono co i av                -- monotone in i+          underAbs x dom fv $ \ _ xv bv -> do+            szSizeVarUsage n co p i bv++       _ -> szSizeVarTarget p i tv++-- check that Target is of form D ... (Succ i) ...+szSizeVarTarget :: Int -> Int -> TVal -> TypeCheck ()+szSizeVarTarget p i tv = enterDoc (text "szSizeVarTarget, variable" <+> prettyTCM (VGen i) <+> text ("argument no. " ++ show p ++ " in") <+> prettyTCM tv) $ do+    let err = text "expected target" <+> prettyTCM tv <+> text "of size" <+> prettyTCM (VSucc (VGen i))+    case tv of+       VSing _ tv -> szSizeVarTarget p i =<< whnfClos tv+       VApp d vl -> do+               v0 <- whnfClos (vl !! p)+               case v0 of+                 (VSucc (VGen i')) | i == i' -> return ()+                 _ -> failDoc err+       _ -> failDoc err+++-- check that rec. arguments are of form D ... i ....+-- and size used nowhere else ?? -- Andreas, 2009-11-27 TOO STRICT!+{- accepts, for instance++   Nat -> Ord i      as argument of a constructor of  Ord ($ i)+   List (Rose A i)   as argument of a constructor of  Rose A ($i)+ -}+szSizeVarDataArgs :: Name -> Int -> Int -> TVal -> TypeCheck ()+szSizeVarDataArgs n p i tv = enterDoc (text "sizeVarDataArgs" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $ do+   case tv of++     {- case D pars sizeArg args -}+     VApp (VDef (DefId DatK (QName m))) vl | n == m -> do+        let (pars, v0 : idxs) = splitAt p vl+        v0 <- whnfClos v0+        case v0 of+          VGen i' | i' == i -> do+            forM_ (pars ++ idxs) $ \ v -> nocc [i] v >>= do+              boolToErrorDoc $+                text "variable" <+> prettyTCM (VGen i) <+>+                text "may not occur in" <+> prettyTCM v+          _ -> failDoc $+                text "wrong size index" <+> prettyTCM v0 <+>+                text "at recursive occurrence" <+> prettyTCM tv++-- not necessary: check for monotonicity above+--     {- case D' pars sizeArg args -}+--     VApp (VDef m) vl | n /= m -> do++     VApp v1 vl -> mapM_ (\ v -> whnfClos v >>= szSizeVarDataArgs n p i) (v1:vl)++     VQuant Pi x dom fv -> do+       szSizeVarDataArgs n p i (typ dom)+       underAbs x dom fv $ \ _ xv bv -> do+          szSizeVarDataArgs n p i bv++     fv | isFun fv ->+       addName (absName fv) $ \ xv -> szSizeVarDataArgs n p i =<< app fv xv+{-+     VLam x env b ->+       addName x $ \ xv -> do+         bv <- whnf (update env x xv) b+         szSizeVarDataArgs n p i bv+-}+     _ -> return ()++{- REMOVED, 2009-11-28, replaced by monotonicity check+     VGen i' -> return $ i' /= i+     VSucc tv' -> szSizeVarDataArgs n p i tv'+ -}++-- doVParams number_of_params constructor_or_datatype_signature+-- skip over parameters of type signature of a constructor/data type+doVParams :: Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a+doVParams 0 tv k = k tv+doVParams p (VQuant Pi x dom fv) k =+  underAbs x dom fv $ \ _ xv bv -> do+    doVParams (p - 1) bv k++--------------------------------------+-- check for admissible  type++{-++ - admissibility needs to be check clausewise, because of Karl's example++   fun nonAdmissibleType : Unit -> Set++   fun diverge : (u : Unit) -> nonAdmissibleType u+   {+     diverge unit patterns = badRhs+   }++ - the type must be admissible in the current position+   only if the size pattern is a successor.+   If the pattern is a variable, then there is no induction on that size+   argument, so no limit case, so no upper semi-continuity necessary+   for the type.++ - when checking++     ... (s i) ps  admissible  (j : Size) -> A++   we will check++     A  admissible in j++   and continue with++     ... ps  admissible  A[s i / j]++   just to maintain type wellformedness.  The (s i) in A does not+   really matter, since there is no case distinction on ordinals.++ - a size pattern which is not inductive (meaning there is an+    inductive type indexed by that size) nor coinductive (meaning that+    the result type is coinductive and is indexed by that size) must+    be flagged unusable for termination checking.++ - the fun/cofun distinction could be inferred by the termination checker+   or be clausewise as in Agda 2++-}+++admFunDef :: Co -> [Clause] -> TVal -> TypeCheck [Clause]+admFunDef co cls tv = do+  (cls, inco) <- admClauses cls tv+  when (co==CoInd && not (co `elem` inco)) $+    throwErrorMsg $ show tv ++ " is not a type of a cofun" -- ++ if co==Ind then "fun" else "cofun"+  return cls++admClauses :: [Clause] -> TVal -> TypeCheck ([Clause], [Co])+admClauses [] tv = return ([], [])+admClauses (cl:cls) tv = do+  (cl',inco) <- admClause cl tv+  (cls',inco') <- admClauses cls tv+  return (cl' : cls', inco ++ inco')++admClause :: Clause -> TVal -> TypeCheck (Clause, [Co])+admClause (Clause tel ps e) tv = traceAdm ("admClause: admissibility of patterns " ++ show ps) $+   introPatterns ps tv $ \ pvs _ -> do+       (ps', inco) <- admPatterns pvs tv+       return (Clause tel ps' e, inco)++admPatterns :: [(Pattern,Val)] -> TVal -> TypeCheck ([Pattern], [Co])+admPatterns [] tv = do+  isCo <- endsInCo tv+  return ([], if isCo then [CoInd] else [])+admPatterns ((p,v):pvs) tv = do+   (p, inco1)  <- admPattern p tv+   bv <- piApp tv v+   (ps, inco2) <- admPatterns pvs bv+   return (p:ps, inco1 ++ inco2)++{-+-- turn a pattern into a value+-- extend delta by generic values but do not introduce their types+evalPat :: Pattern -> (Val -> TypeCheck a) -> TypeCheck a+evalPat p f =+    case p of+      VarP n -> addName n f+      ConP co n [] -> f (VCon co n)+      ConP co n pl -> evalPats pl $ \ vl -> f (VApp (VCon co n) vl)+      SuccP p -> evalPat p $ \ v -> f (VSucc v)+-- DOES NOT WORK SINCE e has unbound variables+      DotP e -> do+        v <- whnf' e+        f v++evalPats :: [Pattern] -> ([Val] -> TypeCheck a) -> TypeCheck a+evalPats [] f = f []+evalPats (p:ps) f = evalPat p $ \ v -> evalPats ps $ \ vs -> f (v:vs)+-}++{-+evalPat :: Pattern -> TypeCheck (State TCContext Val)+evalPat p =+    case p of+      VarP n -> return $ State $ \ ce ->+        let (k, delta) = cxtPushGen (context ce)+            rho = update n (VGen k) (environ ce)+        in  (VGen k, TCContext { context = delta, environ = rho })+      ConP co n [] -> return (VCon co n)+      ConP co n pl -> do+        vl <- mapM evalPat pl+        return (VApp (VCon co n) vl)+      SuccP p -> do+       v <- evalPat p+       return (VSucc v)+-- TODO: does not work!+--      DotP e -> return $ State $ \ ce ->+-}+++++{- 2013-03-31 On instantiation of quantifiers [i < #] - F i++If F is upper semi-continuous then++  [i < #] -> F i   is a sub"set" of   F #++so we can instantiate i to #.  (Hughes et al., POPL 96; Abel, LMCS 08)++1) Consider the special case++  F i = [j < i] -> G i++Because # is a limit, thus, j < i < #  iff j < #, we reason:++  F # = [j < #] -> G j++  [i < #] -> F i+      = [i < #] -> [j < i] -> G j  (since # is a limit)+      = [j < #] -> G j++2) Consider the special case++  F i = [j <= i] -> G j++We have++  F # = [j <= #] -> G j+      = G # /\ ([j < #] -> G j)++  [i < #] -> F i+      = [i < #] -> [j <= i] -> G j+      = [j < #] -> G j++So if G is upper semi-continuous, so is F.++-}+++-- | Check whether a type is upper semi-continuous.+lowerSemiCont :: Int -> TVal -> TypeCheck Bool+lowerSemiCont i tv = errorToBool $ lowerSemiContinuous i tv++docNotLowerSemi i av = text "type " <+> prettyTCM av <+>+  text " not lower semi continuous in " <+> prettyTCM (VGen i)++lowerSemiContinuous :: Int -> TVal -> TypeCheck ()+lowerSemiContinuous i av = do+  av <- force av+  let fallback = szAntitone i av `newErrorDoc` docNotLowerSemi i av++  case av of++    -- [j < i] & F j  is lower semi-cont in i+    -- because [i < #] & [j < i] & F j is the same as [j < #] & F j+    -- [but what if i in FV(F j)? should not matter!] 2013-04-01+    VQuant Sigma x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return ()++    -- [j <= i] & F j  is lower semi-cont in i if F is+    VQuant Sigma x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' -> do+      underAbs x dom fv $ \ j xv bv -> lowerSemiContinuous j bv++    -- Sigma-type general case+    VQuant Sigma x dom@Domain{ typ = av } fv -> do+      lowerSemiContinuous i av+      underAbs x dom fv $ \ _ xv bv -> lowerSemiContinuous i bv++    VApp (VDef (DefId DatK n)) vl -> do+      sige <- lookupSymbQ n+      case sige of++        -- finite tuple type+        DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do+          -- match target of constructor against tv to instantiate+          --  c : ... -> D ps  -- ps = snd (cPatFam ci)+          mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis+          case mrhoci of+            Nothing -> fallback+            Just (rho,ci) -> if (cRec ci) then fallback else do+              -- infinite tuples (recursive constructor) are not lower semi cont+              enter ("lowerSemiContinuous: detected tuple type, checking components") $+                allComponentTypes (cFields ci) rho (lowerSemiContinuous i)++       -- i-sized inductive types are lower semi-cont in i+        DataSig { numPars, isSized = Sized, isCo = Ind } | length vl > numPars -> do+          s <- whnfClos $ vl !! numPars -- the size argument is the first fgter the parameters+          case s of+            VGen i' | i == i' -> return ()+            _ -> fallback++        -- finite inductive type+        DataSig { symbTyp = dv, constructors = cis, isCo = Ind } ->+          -- if any cRec cis then fallback else do -- we loop on recursive data, so exclude+          -- check that we do not loop on the same data names...+          ifM ((n `elem`) <$> asks callStack) fallback $ do+          local (\ ce -> ce { callStack = n : callStack ce }) $ do+          -- match target of constructor against tv to instantiate+          --  c : ... -> D ps  -- ps = snd (cPatFam ci)+          forM_ cis $ \ ci -> do+            match <- nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv+            Foldable.forM_ match $ \ rho -> do+                enter ("lowerSemiContinuous: detected tuple type, checking components") $+                  allComponentTypes (cFields ci) rho (lowerSemiContinuous i)++        _ -> fallback+    _ -> fallback++-- | Check whether a type is upper semi-continuous.+upperSemiCont :: Int -> TVal -> TypeCheck Bool+upperSemiCont i tv = errorToBool $ endsInSizedCo' False i tv+  -- 2013-03-30+  -- endsInSizedCo needs tv[0/i] = Top+  -- upperSemiCont does not need this, the target can also be constant in i++-- | @endsInSizedCo i tv@ checks that @tv@ is lower semi-continuous in @i@+--   and that @tv[0/i] = Top@.+endsInSizedCo :: Int -> TVal -> TypeCheck ()+endsInSizedCo = endsInSizedCo' True++-- | @endsInSizedCo' False i tv@ checks that @tv@ is lower semi-continuous in @i@.+--   @endsInSizedCo' True i tv@ additionally checks that @tv[0/i] = Top@.+endsInSizedCo' :: Bool -> Int -> TVal -> TypeCheck ()+endsInSizedCo' endInCo i tv  = enterDoc (text "endsInSizedCo:" <+> prettyTCM tv) $ do+   tv <- force tv+   let fallback+         | endInCo = failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a CoSet or codata of size" <+> prettyTCM (VGen i) <+> text "nor a tuple type"+         | otherwise = szMonotone i tv+   case tv of+      VSort (CoSet (VGen i)) -> return ()+      VMeasured mu bv -> endsInSizedCo' endInCo i bv++      -- case forall j <= i. C j coinductive in i+      VQuant Pi x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' ->+        underAbs x dom fv $ \ j xv bv ->+          endsInSizedCo' endInCo j bv+      VGuard (Bound Le (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' ->+        endsInSizedCo' endInCo j bv++      -- same case again, written as j < i+1. C j+      VQuant Pi x dom@Domain{ typ = VBelow Lt (VSucc (VGen i')) } fv | i == i' ->+        underAbs x dom fv $ \ j xv bv ->+          endsInSizedCo' endInCo j bv+      VGuard (Bound Lt (Measure [VGen j]) (Measure [VSucc (VGen i')])) bv | i == i' ->+        endsInSizedCo' endInCo j bv++      -- case forall j < i. C j:  already coinductive in i !!+      -- Trivially, forall j < 0. C j is the top type.+      -- And, forall i < # forall j < i  is equivalent to forall j < #+      -- so we can instantiate i to #.+      VGuard (Bound Lt (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' ->+        return ()+      VQuant Pi x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return ()++      VQuant Pi x dom fv -> do+         lowerSemiContinuous i $ typ dom+         underAbs x dom fv $ \ _ xv bv -> endsInSizedCo' endInCo i bv++      VSing _ tv -> endsInSizedCo' endInCo i =<< whnfClos tv+      VApp (VDef (DefId DatK n)) vl -> do+         sige <- lookupSymbQ n+         case sige of+            DataSig { numPars = np, isSized = Sized, isCo = CoInd }+              | length vl > np -> do+                 v <- whnfClos $ vl !! np+                 if isVGeni v then return () else fallback+                   where isVGeni (VGen i) = True+                         isVGeni (VPlus vs) = and $ map isVGeni vs+                         isVGeni (VMax vs)  = and $ map isVGeni vs+                         isVGeni VZero = True+                         isVGeni _ = False+{- WE DO NOT HAVE SUBST ON VALUES!+                 case vl !! np of+                   VGen j -> if i == j then return () else fail1+                   VZero -> return ()+                   VClos rho e -> do+                     v <- whnf (update rho i VZero) e -- BUGGER+                     if v == VZero then return () else fail1+-}+-- we also allow the target to be a tuple if all of its components+-- fulfill "endsInSizedCo"+            DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do+              allTypesOfTuple tv vl dv cis (endsInSizedCo' endInCo i)+{-+              -- match target of constructor against tv to instantiate+              --  c : ... -> D ps  -- ps = snd (cPatFam ci)+              mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis+              case mrhoci of+                Nothing -> failDoc $ text "endsInSizedCo: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor"+                Just (rho,ci) -> enter ("endsInSizedCo: detected tuple target, checking components") $+                  fieldsEndInSizedCo endInCo i (cFields ci) rho+-}+            _ -> fallback+      _ -> fallback+{- failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a function type nor a codata nor a tuple type"+-}++-- | @allTypesOfTyples args dv cis check@ performs @check@ on all component+--   types of tuple type @tv = d args@ where @dv@ is the type of @d@.+allTypesOfTuple :: TVal -> [Val] -> TVal -> [ConstructorInfo] -> (TVal -> TypeCheck ()) -> TypeCheck ()+allTypesOfTuple tv vl dv cis check = do+  -- match target of constructor against tv to instantiate+  --  c : ... -> D ps  -- ps = snd (cPatFam ci)+  mrhoci <- Util.firstJustM $+    map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis+  -- we know that only one constructor can match, otherwise it would not be a tuple type+  case mrhoci of+    Nothing -> failDoc $ text "allTypesOfTuple: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor"+    Just (rho,ci) -> enter ("allTypesOfTuple: detected tuple target, checking components") $+      allComponentTypes (cFields ci) rho check++{-+fieldsEndInSizedCo :: Bool -> Int -> [FieldInfo] -> Env -> TypeCheck ()+fieldsEndInSizedCo endInCo i fis rho0 = allComponentTypes fis rho0 (endsInSizedCo' endInCo i)+fieldsEndInSizedCo endInCo i fis rho0 = enter ("fieldsEndInSizedCo: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $+  loop fis rho0 where+    loop [] rho = return ()+    -- nothing to check for erased index fields+    loop (f : fs) rho | fClass f == Index && erased (fDec f) =+      loop fs rho+    loop (f : fs) rho | fClass f == Index = do+      tv <- whnf rho (fType f)+      endsInSizedCo' endInCo i tv+      loop fs rho+    loop (f : fs) rho = do+      tv <- whnf rho (fType f)+      when (not $ erased (fDec f)) $ endsInSizedCo' endInCo i tv+      -- for non-index fields, value is not given by matching, so introduce+      -- generic value+      new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do+        let rho' = update rho (fName f) xv+        -- do not need to check erased fields?+        loop fs rho'+-}++-- | @allComponentTypes fis env check@ applies @check@ to all field types+--   in @fis@ (evaluated wrt to environment @env@).+--   Erased fields are skipped.  (Is this correct?)+allComponentTypes :: [FieldInfo] -> Env -> (TVal -> TypeCheck ()) -> TypeCheck ()+allComponentTypes fis rho0 check = enter ("allComponentTypes: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $+  loop fis rho0 where+    loop [] rho = return ()++    -- nothing to check for erased index fields+    loop (f : fs) rho | fClass f == Index && erased (fDec f) =+      loop fs rho++    -- ordinary index field types are checked+    loop (f : fs) rho | fClass f == Index = do+      check =<< whnf rho (fType f)+      loop fs rho++    -- proper fields+    loop (f : fs) rho = do+      tv <- whnf rho (fType f)+      -- do not need to check erased fields?+      when (not $ erased (fDec f)) $ check tv+      -- for non-index fields, value is not given by matching, so introduce+      -- generic value+      new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do+        loop fs $ update rho (fName f) xv++++endsInCo :: TVal -> TypeCheck Bool+endsInCo tv  = -- traceCheck ("endsInCo: " ++ show tv) $+   case tv of+      VQuant Pi x dom fv -> underAbs x dom fv $ \ _ _ bv -> endsInCo bv++      VApp (VDef (DefId DatK n)) vl -> do+         sige <- lookupSymbQ n+         case sige of+            DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $+               return True+            _ -> return False+      _ -> return False++-- precondition: Pattern does not contain "Unusable"+admPattern :: Pattern -> TVal -> TypeCheck (Pattern, [Co])+admPattern p tv = traceAdm ("admPattern " ++ show p ++ " type: " ++ show tv) $+  case tv of+      VGuard beta bv -> addBoundHyp beta $ admPattern p bv+      VApp (VDef (DefId DatK d)) vl -> do+         case p of+           ProjP n -> return (p, [])+           _ -> throwErrorMsg "admPattern: IMPOSSIBLE: non-projection pattern for record type"+      VQuant Pi x dom fv -> underAbs x dom fv $ \ k xv bv -> do+  {-+         if p is successor pattern+         check that bv is admissible in k, returning subset of [Ind, CoInd]+         p is usable if either CoInd or it is a var or dot pattern and Ind+-}+         if isSuccessorPattern p then do+           inco <- admType k bv+           when (CoInd `elem` inco && not (shallowSuccP p)) $ cannotMatchDeep p tv+           if (CoInd `elem` inco)+              || (inco /= [] && completeP p)+            then return (p, inco)+            else return (UnusableP p, inco)+          else return (p, [])++      _ -> throwErrorMsg "admPattern: IMPOSSIBLE: pattern for a non-function type"++cannotMatchDeep p tv = recoverFailDoc $+  text "cannot match against deep successor pattern"+    <+> text (show p) <+> text "at type" <+> prettyTCM tv++admType :: Int -> TVal -> TypeCheck [Co]+admType i tv = enter ("admType: checking " ++ show tv ++ " admissible in v" ++ show i) $+    case tv of+       VQuant Pi x dom@(Domain av _ _) fv -> do+          isInd <- szUsed Ind i av+          when (not isInd) $+            szAntitone i av `newErrorDoc` docNotLowerSemi i av+          underAbs x dom fv $ \ gen _ bv -> do+            inco <- admType i bv+            if isInd then return (Ind : inco) else return inco+       _ -> do+          isCoind <- szUsed CoInd  i tv+          if isCoind then return [CoInd]+           else do+            szMonotone i tv+            return []++szUsed :: Co -> Int -> TVal -> TypeCheck Bool+szUsed co i tv = traceAdm ("szUsed: " ++ show tv ++ " " ++ show co ++ " in v" ++ show i) $+    case tv of+         (VApp (VDef (DefId DatK n)) vl) ->+             do sige <- lookupSymbQ n+                case sige of+                  DataSig { numPars = p+                          , isSized = Sized+                          , isCo = co' } | co == co' && length vl > p ->+                      -- p is the number of parameters+                      -- it is also the index of the size argument+                      do s <- whnfClos $ vl !! p+                         case s of+                           VGen i' | i == i' -> return True+                           _ -> return False+                  _ -> return False+         _ -> return False++++-- for inductive fun, and for every size argument i+-- - every argument needs to be either inductive or antitone in i+-- - the result needs to be monotone in i++{- szCheckIndFun admpos delta tv++ entry point for admissibility check for recursive functions+ - scans for the first size quantification+ - passes on to szCheckIndFunSize+ - currently: also continues to look for the next size quantification...+ -}++szCheckIndFun :: [Int] -> TVal -> TypeCheck ()+szCheckIndFun admpos tv = -- traceCheck ("szCheckIndFun: " ++ show delta ++ " |- " ++ show tv ++ " adm?") $+      case tv of+       VQuant Pi x dom fv -> underAbs x dom fv $ \ k _ bv -> do+         -- bv <- whnf' b+         if isVSize (typ dom) then do+             when (k `elem` admpos) $+               szCheckIndFunSize k bv+             szCheckIndFun admpos bv -- this is for lexicographic induction on sizes, I suppose?  Probably should me more fine grained!  Andreas, 2008-12-01+          else szCheckIndFun admpos bv+       _ -> return ()+++{- szCheckIndFunSize delta i tv++ checks whether type tv is admissible for recursion in index i+ - every argument needs to be either inductive or antitone in i+ - the result needs to be monotone in i+ -}++szCheckIndFunSize :: Int -> TVal -> TypeCheck ()+szCheckIndFunSize i tv = -- traceCheck ("szCheckIndFunSize: " ++ show delta ++ " |- " ++ show tv ++ " adm(v" ++ show i ++ ")?") $+    case tv of+       VQuant Pi x dom fv -> do+            szLowerSemiCont i (typ dom)+--            new x dom $ \ k _  -> szCheckIndFunSize i =<< app fv (VGen k)+            underAbs x dom fv $ \ _ _ bv -> szCheckIndFunSize i bv+{-+            new' x dom $ do+              bv <- whnf' b+              szCheckIndFunSize i bv+-}+       _ -> szMonotone i tv++{- szLowerSemiCont++ - check for lower semi-continuity [Abel, CSL 2006]+ - current approximation: inductive type or antitone+ -}+szLowerSemiCont :: Int -> TVal -> TypeCheck ()+szLowerSemiCont i av = -- traceCheck ("szlowerSemiCont: checking " ++ show av ++ " lower semi continuous in v" ++ show i) $+   (szAntitone i av `catchError`+      (\ msg -> -- traceCheck (show msg) $+                   szInductive i av))+        `newErrorDoc` docNotLowerSemi i av+++{- checking cofun-types for admissibility++conditions:++1. type must end in coinductive type or in sized coinductive type+   indexed by just a variable i which has been quantified in the type++2. in the second case, each argument must be inductive or antitone in i+   optimization:+     arguments types before the quantification over i can be ignored+-}++data CoFunType+  = CoFun             -- yes, but not sized cotermination+  | SizedCoFun Int    -- yes an admissible sized type (the Int specifies the number of the recursive size argument)++{-+design:++admCoFun delta tv : IsCoFunType++   endsInCo delta tv (len delta) id++admEndsInCo delta tv firstVar jobs : IsCoFunType++   traverse tv, gather continutations in jobs, check for CoInd in the end++   if tv = (x:A) -> B+      push A on delta+      add the following task to jobs:+        check A for lower semicontinuity in delta+      continue on B++   if tv = Codata^i+      run (jobs i)+      if they return (), return YesSized Int, otherwise No++   if tv = Codata+      return Yes++   otherwise+      return No+ -}++-- {- TODO: FINISH THIS!!++admCoFun :: TVal -> TypeCheck CoFunType+admCoFun tv = do+  l <- getLen+  admEndsInCo tv l (\ i -> return ())++admEndsInCo :: TVal -> Int -> (Int -> TypeCheck ()) -> TypeCheck CoFunType+admEndsInCo tv firstVar jobs = -- traceCheck ("admEndsInCo: " ++ show tv) $+   case tv of+      VQuant Pi x dom fv -> do+         l <- getLen+         let jobs' = (addJob l (typ dom) jobs)+         underAbs x dom fv $ \ _ _ bv -> admEndsInCo bv firstVar jobs'+{-+         new' x dom $ do+           bv <- whnf' b+           admEndsInCo bv firstVar jobs'+-}++{-+      -- if not applied, it cannot be a sized type+      VDef n -> do+         sig <- gets signature+         case (lookupSig n sig) of+            DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $+               return CoFun+            _ -> throwErrorMsg $ "type of cofun does not end in coinductive type"+-}++      VApp (VDef (DefId DatK n)) vl -> do+         sige <- lookupSymbQ n+         case sige of+            DataSig { isSized = NotSized, isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $+               return CoFun+            DataSig { numPars = p, isSized = Sized, isCo = CoInd } | length vl > p -> -- traceCheck ("found sized coinductive target") $+              do+               -- p is the number of parameters+               -- it is also the index of the size argument+               s <- whnfClos $ vl !! p+               case s of+                  VGen i -> do+                     jobs i+                     return $ SizedCoFun $ i - firstVar+                  _ -> throwErrorMsg $ "size argument in result type must be a variable"+            _ -> throwErrorMsg $ "type of cofun does not end in coinductive type"++addJob :: Int -> TVal -> (Int -> TypeCheck ())+       -> (Int -> TypeCheck ())+addJob l tv jobs recVar = do+  -- is the "recursive" size variable actually in scope?+  jobs recVar+  when (recVar < l) $ szLowerSemiCont recVar tv++-- -}+++{- szCheckCoFun  OBSOLETE!!++ entry point for admissibility check for corecursive functions+ - scans for the first size quantification+ - passes on to szCheckIndFunSize+ - currently: also continues to look for the next size quantification+ - and checks in the end whether the target is a coinductive type+++-- STALE COMMENT: for a cofun : arguments nocc i and result coinductive in i+szCheckCoFun :: SemCxt -> TVal -> TypeCheck ()+szCheckCoFun delta tv =+      case tv of+       VPi dec x av env b -> do+                let (k, delta') = cxtPush dec av delta+                bv <- whnf (update env x (VGen k)) b+                case av of+                  VSize -> do szCheckCoFunSize delta' k bv+                              szCheckCoFun delta' bv+                  _ -> szCheckCoFun delta' bv+       -- result+       (VApp (VDef n) vl) ->+          do sig <- gets signature+             case (lookupSig n sig) of+               (DataSig _ _ _ CoInd _) ->+                   return ()+               _ -> throwErrorMsg $ "cofun doesn't target coinductive type"+       (VDef n)  ->+          do sig <- gets signature+             case (lookupSig n sig) of+               (DataSig _ _ _ CoInd _) ->+                   return ()+               _ -> throwErrorMsg $ "cofun doesn't target coinductive type"+       _ -> throwErrorMsg $ "cofun doesn't target coinductive type"++szCheckCoFunSize :: SemCxt -> Int -> TVal -> TypeCheck ()+szCheckCoFunSize delta i tv = -- traceCheck ("szco " ++ show tv) $+      case tv of+       VPi dec x av env b ->  do+             let (k, delta') = cxtPush dec av delta+             bv <- whnf (update env x (VGen k)) b+             szLowerSemiCont delta i av+             szCheckCoFunSize delta' i bv+       -- result must be coinductive+       _ -> szCoInductive delta i tv++-}++szMono :: Co -> Int -> TVal -> TypeCheck ()+szMono co i tv =+    case co of+         Ind   -> szMonotone i tv+         CoInd -> szAntitone i tv++szMonotone :: Int -> TVal -> TypeCheck ()+szMonotone i tv = traceCheck ("szMonotone: " -- ++ show delta ++ " |- "+                              ++ show tv ++ " mon(v" ++ show i ++ ")?") $+ do+   let si = VSucc (VGen i)+   tv' <- substitute (sgSub i si) tv+   leqVal Pos vTopSort tv tv'++szAntitone :: Int -> TVal -> TypeCheck ()+szAntitone i tv = traceCheck ("szAntitone: " -- ++ show delta ++ " |- "+                              ++ show tv ++ " anti(v" ++ show i ++ ")?") $+ do+   let si = VSucc (VGen i)+   tv' <- substitute (sgSub i si) tv+   leqVal Neg vTopSort tv tv'++-- checks if tv is a sized inductive type of size i+szInductive :: Int -> TVal -> TypeCheck ()+szInductive i tv = szUsed' Ind i tv++-- checks if tv is a sized coinductive type of size i+szCoInductive :: Int -> TVal -> TypeCheck ()+szCoInductive i tv = szUsed' CoInd i tv++szUsed' :: Co -> Int -> TVal -> TypeCheck ()+szUsed' co i tv =+    case tv of+         (VApp (VDef (DefId DatK n)) vl) ->+             do sige <- lookupSymbQ n+                case sige of+                  DataSig { numPars = p, isSized = Sized, isCo =  co' } | co == co' && length vl > p ->+                      -- p is the number of parameters+                      -- it is also the index of the size argument+                      do s <- whnfClos $ vl !! p+                         case s of+                           VGen i' | i == i' -> return ()+                           _ -> throwErrorMsg $ "expected size variable"+                  _ -> throwErrorMsg $ "expected (co)inductive sized type"+         _ -> throwErrorMsg $ "expected (co)inductive sized type"
+ src/Util.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections, NoMonomorphismRestriction,+      FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}++module Util where++import Prelude hiding (showList, null)++import Control.Applicative hiding (empty)+import Control.Monad+import Control.Monad.Writer (Writer, runWriter, All, getAll)++import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Debug.Trace++import Text.PrettyPrint as PP++(+?+) :: String -> String -> String+(+?+) xs "[]" = []+(+?+) xs ys = xs ++ ys++implies :: Bool -> Bool -> Bool+implies a b = if a then b else True++class Pretty a where+    pretty	:: a -> Doc+    prettyPrec	:: Int -> a -> Doc++    pretty	= prettyPrec 0+    prettyPrec	= const pretty++instance Pretty Doc where+    pretty = id++angleBrackets :: Doc -> Doc+angleBrackets d = text "<" <+> d <+> text ">"++-- | Apply when condition is @True@.+fwhen :: Bool -> (a -> a) -> a -> a+fwhen True  f a = f a+fwhen False f a = a++parensIf :: Bool -> Doc -> Doc+parensIf b = fwhen b PP.parens++hsepBy :: Doc -> [Doc] -> Doc+hsepBy sep [] = empty+hsepBy sep [d] = d+hsepBy sep (d:ds) = d <> sep <> hsepBy sep ds++pwords :: String -> [Doc]+pwords = map text . words++fwords :: String -> Doc+fwords = fsep . pwords++fromAllWriter :: Writer All a -> (Bool, a)+fromAllWriter m = let (a, w) = runWriter m+                  in  (getAll w, a)++traceM :: (Monad m) => String -> m ()+traceM msg = trace msg $ return ()++infixr 9 <.>++-- | Composition: pure function after monadic function.+(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c+(f <.> g) a = f <$> g a++whenM :: Monad m => m Bool -> m () -> m ()+whenM mb k = mb >>= (`when` k)++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM mb k = mb >>= (`unless` k)++whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m ()+whenJustM mm k = mm >>= (`whenJust` k)++whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()+whenJust (Just a) k = k a+whenJust Nothing  k = return ()++whenNothing :: (Monad m) => Maybe a -> m () -> m ()+whenNothing Nothing m = m+whenNothing Just{}  m = return ()++ifNothingM :: (Monad m) => m (Maybe a) -> m b -> (a -> m b) -> m b+ifNothingM mma mb f = maybe mb f =<< mma++ifJustM :: (Monad m) => m (Maybe a) -> (a -> m b) -> m b -> m b+ifJustM mma f mb = maybe mb f =<< mma++mapMapM :: (Monad m, Ord k) => (a -> m b) -> Map k a -> m (Map k b)+mapMapM f = Map.foldrWithKey step (return $ Map.empty)+  where step k a m = do a' <- f a+                        m' <- m+                        return $ Map.insert k a' m'++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM c d e = do { b <- c ; if b then d else e }++{- Control.Monad.IfElse+whenM :: Monad m => m Bool -> m () -> m ()+whenM c d = do { b <- c; if b then d else return () }++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM c e = do { b <- c; if b then return () else e }+-}++andLazy :: Monad m => m Bool -> m Bool -> m Bool+andLazy ma mb = ifM ma mb $ return False++andM  :: Monad m => [m Bool] -> m Bool+andM []     = return True+andM (m:ms) = m `andLazy` andM ms++findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+findM p []       = return Nothing+findM p (x : xs) = do b <- p x+                      if b then return (Just x) else findM p xs++-- | Binary version of @=<<@.+(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c+f ==<< (ma, mb) = do { a <- ma; f a =<< mb }++parens :: String -> String+parens s = "(" ++ s ++ ")"++brackets :: String -> String+brackets s = "[" ++ s ++ "]"++bracketsIf :: Bool -> String -> String+bracketsIf False s = s+bracketsIf True  s = "[" ++ s ++ "]"++separate :: String -> String -> String -> String+separate sep "" y = y+separate sep x "" = x+separate sep x y  = x ++ sep ++ y++showList :: String -> (a -> String) -> [a] -> String+showList sep f [] = ""+showList sep f [e] = f e+showList sep f (e:es) = f e ++ sep ++ showList sep f es+-- OR: showList sep f es = foldl separate "" $ map f es++hasDuplicate :: (Eq a) => [a] -> Bool+hasDuplicate [] = False+hasDuplicate (x : xs) = x `elem` xs || hasDuplicate xs++compressMaybes :: [Maybe a] -> [a]+compressMaybes = concat . map (maybe [] (\ a -> [a]))++mapFst :: (a -> c) -> (a,d) -> (c,d)+mapFst f (a,b) = (f a, b)++mapSnd :: (b -> d) -> (a,b) -> (a,d)+mapSnd f (a,b) = (a, f b)++mapPair :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)+mapPair f g (a,b) = (f a, g b)++zipPair :: (a -> b -> c) -> (d -> e -> f) -> (a,d) -> (b,e) -> (c,f)+zipPair f g (a,d) (b,e) = (f a b, g d e)++headMaybe :: [a] -> Maybe a+headMaybe [] = Nothing+headMaybe (a:as) = Just a++firstJust :: [Maybe a] -> Maybe a+firstJust = headMaybe . compressMaybes++firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)+firstJustM [] = return Nothing+firstJustM (mm : mms) = do+  m <- mm+  case m of+    Nothing -> firstJustM mms+    Just{}  -> return m++mapOver :: (Functor f) => f a -> (a -> b) -> f b+mapOver = flip fmap++for = mapOver++mapAssoc :: (a -> b) -> [(n,a)] -> [(n,b)]+mapAssoc f = map (\ (n, a) -> (n, f a))++mapAssocM :: (Applicative m, Monad m) => (a -> m b) -> [(n,a)] -> m [(n,b)]+mapAssocM f = mapM (\ (n, a) -> (n,) <$> f a)++compAssoc :: Eq b => [(a,b)] -> [(b,c)] -> [(a,c)]+compAssoc xs ys = [ (a,c) | (a,b) <- xs, (b',c) <- ys, b == b' ]++-- * Lists and stacks of lists++class Push a b where+  push    :: a -> b -> b++instance Push a [a] where+  push = (:)++instance Push a [[a]] where+  push a (b:bs) = (a : b) : bs++-- TOO HARD for ghc:+-- instance Push a b => Push a [b] where+--   push a (b:bs) = push a b : bs++class Retrieve a b c | b -> c where+  retrieve :: Eq a => a -> b -> Maybe c++instance Retrieve a [(a,b)] b where+  retrieve = lookup++instance Retrieve a [[(a,b)]] b where+  retrieve a = retrieve a . concat++-- instance Retrieve a b c => Retrieve a [b] c where+--   retrieve a = firstJust . map (retrieve a)++{-+class ListLike a where+  length :: a -> Int+  null   :: a -> Bool+  nil    :: a+-}++class Size a where+  size :: a -> Int++instance Size [a] where+  size = length++class Null a where+  null :: a -> Bool++instance Null [a] where+  null = List.null
+ src/Value.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}++module Value where++import Prelude hiding (null)++import Control.Applicative++import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set+import Debug.Trace++import Abstract+import Polarity+import Util+import TraceError -- orM++-- call-by-value+-- cofuns are not forced++data Val+  -- sizes+  = VInfty+  | VZero+  | VSucc Val+  | VMax [Val]+  | VPlus [Val]+  | VMeta MVar Env Int           -- X rho + n  (n-fold successor of X rho)+  -- types+  | VSort (Sort Val)+  | VMeasured (Measure Val) Val  -- mu -> A  (only in checkPattern)+  | VGuard (Bound Val) Val       -- mu<mu' -> A+  | VBelow LtLe Val              -- domain in bounded size quant.+  | VQuant+    { vqPiSig :: PiSigma+    , vqName  :: Name+    , vqDom   :: Domain+    , vqFun   :: FVal+    }+  | VSing Val TVal               -- Singleton type (TVal not Pi)+  -- functions+  | VLam Name Env Expr+  | VAbs Name Int Val Valuation  -- abstract free variable+  | VConst Val                   -- constant function+  | VUp Val TVal                 -- delayed eta expansion; TVal is a Pi+  -- values+  | VRecord RecInfo EnvMap       -- a record value / fully applied constructor+  | VPair Val Val                -- eager pair+  -- neutrals+  | VGen Int                     -- free variable (de Bruijn level)+  | VDef DefId                   -- co(data/constructor/fun)+                                 -- VDef occurs only inside a VApp!+  | VCase Val TVal Env [Clause]+  | VApp Val [Clos]+  -- closures+  | VProj PrePost Name           -- a projection as an argument to a neutral+  | VClos Env Expr               -- closure for cbn evaluation+  -- don't care+  | VIrr                         -- erased hypothetical inhabitant of empty type+    deriving (Eq,Ord)++-- | Makes constant function if name is empty.+vLam :: Name -> Env -> Expr -> FVal+vLam x env e+  | emptyName x = VConst $ VClos env e+  | otherwise   = VLam x env e++-- | Is a value a function?  May become more @True@ after forcing the @VUp@.+isFun :: Val -> Bool+isFun VLam{}                         = True+isFun VAbs{}                         = True+isFun VConst{}                       = True+isFun (VUp _ VQuant{ vqPiSig = Pi }) = True+isFun v                              = False++absName :: FVal -> Name+absName fv =+  case fv of+    VLam x _ _              -> x+    VAbs x _ _ _            -> x+    VUp _ (VQuant Pi x _ _) -> x+    _                       -> noName++type FVal = Val+type TVal = Val -- type value+type Clos = Val+type Domain = Dom TVal++-- | Valuation of free variables.+newtype Valuation = Valuation { valuation :: [(Int,Val)] }+  deriving (Eq,Ord)++emptyVal  = Valuation []+sgVal i v = Valuation [(i,v)]++valuateGen :: Int -> Valuation -> Val+valuateGen i valu = maybe (VGen i) id $ lookup i $ valuation valu++type TeleVal = [TBinding Val]++data Environ a = Environ+  { envMap   :: [(Name,a)]          -- the actual map from names to values+  , envBound :: Maybe (Measure Val) -- optionally the current termination measure+  }+               deriving (Eq,Ord,Show)++type EnvMap = [(Name,Val)]+type Env = Environ Val++{-+data MeasVal = MeasVal [Val]  -- lexicographic termination measure+               deriving (Eq,Ord,Show)+-}++-- smart constructors ------------------------------------------------++-- | The value representing type Size.+vSize :: Val+vSize = VBelow Le VInfty -- 2012-01-28 non-termination bug I have not found+-- vSize = VSort $ SortC Size++vFinSize = VBelow Lt VInfty++-- | Ensure we construct the correct value representing Size.+vSort :: Sort Val -> Val+vSort (SortC Size) = vSize+vSort s            = VSort s++isVSize :: Val -> Bool+isVSize (VSort (SortC Size)) = True+isVSize (VBelow Le VInfty)   = True+isVSize _                    = False++vTSize = VSort $ SortC TSize++vTopSort :: Val+vTopSort = VSort $ Set VInfty++mkClos :: Env -> Expr -> Val+mkClos rho Infty       = VInfty+mkClos rho Zero        = VZero+-- mkClos rho (Succ e)    = VSucc (mkClos rho e)  -- violates an invariant!! succeed/crazys+mkClos rho (Below ltle e) = VBelow ltle (mkClos rho e)+mkClos rho (Proj fx n) = VProj fx n+mkClos rho (Var x) = lookupPure rho x+mkClos rho (Ann e) = mkClos rho $ unTag e+mkClos rho e = VClos rho e+  -- Problem with MetaVars: freeVars of a meta var is unknown in this repr.!+  -- VClos (rho { envMap = filterEnv (freeVars e) (envMap rho)}) e++filterEnv :: Set Name -> EnvMap -> EnvMap+filterEnv ns [] = []+filterEnv ns ((x,v) : rho) =+  if Set.member x ns then (x,v) : filterEnv (Set.delete x ns) rho+   else filterEnv ns rho++vDef id   = VDef id `VApp` []+vCon co n = vDef $ DefId (ConK co) n+-- vCon co n = vDef $ DefId (ConK (coToConK co)) n+vFun n    = vDef $ DefId FunK $ QName n+vDat n    = vDef $ DefId DatK n++{- POSSIBLY BREAKS INVARIANT!+vApp :: Val -> [Val] -> Val+vApp f [] = f+vApp f vs = VApp f vs+-}++vAbs :: Name -> Int -> Val -> FVal+vAbs x i v = VAbs x i v emptyVal++arrow , prod :: TVal -> TVal -> TVal+arrow = quant Pi+prod  = quant Sigma++quant piSig a b = VQuant piSig x (defaultDomain a) (VConst b)+  where x   = fresh ""+-- quant piSig a b = VQuant piSig x (defaultDomain a) (Environ [(bla,b)] Nothing) (Var bla)+--   where x   = fresh ""+--         bla = fresh "#codom"+++-- * Sizes ------------------------------------------------------------++-- Sizes form a commutative semiring with multiplication (Plus) and+-- idempotent addition (Max)+--+-- Wellformed size values are polynomials, i.e., sums (Max) of products (Plus).+-- A monomial m takes one of the forms (k stands for a variable: VGen or VMeta)+-- 0. VSucc^* VZero+-- 1. VSucc^* k+-- 2. VSucc^* (VPlus [k1,...,kn])   where n>=2+-- A polynomial takes one of the forms+-- 0. VInfty+-- 1. m+-- 2. VMax ms  where length ms >= 2 and each mi different+{- OLD+-- * VSucc^* VGen+-- * VMax vs where each v_i = VSucc^* (VGen k_i) and all k_i different+--           and vs has length >= 2+-}+--+-- the smart constructors construct wellformed size values using the laws+-- $ #             = #                Infty+-- max # k         = #+-- $ (max i j)     = max ($ i) ($ j)  $ distributes over max+-- max (max i j) k = max i j k        Assoc-Commut of max+-- max i i         = i                Idempotency of max+succSize :: Val -> Val+succSize v = case v of+            VInfty -> VInfty+            VMax vs -> maxSize $ map succSize vs+            VMeta i rho n -> VMeta i rho (n + 1)  -- TODO: integrate + and mvar+            _ -> VSucc v+vSucc = succSize++-- "multiplication" of sizes+plusSize :: Val -> Val -> Val+plusSize VZero v = v+plusSize v VZero = v+plusSize VInfty v = VInfty+plusSize v VInfty = VInfty+plusSize (VMax vs) v = maxSize $ map (plusSize v) vs+plusSize v (VMax vs) = maxSize $ map (plusSize v) vs+plusSize (VSucc v) v' = succSize $ plusSize v v'+plusSize v' (VSucc v) = succSize $ plusSize v v'+plusSize (VPlus vs) (VPlus vs') = VPlus $ List.sort (vs ++ vs') -- every summand is a var!  -- TODO: more efficient sorting!+plusSize (VPlus vs) v = VPlus $ List.insert v vs+plusSize v (VPlus vs) = VPlus $ List.insert v vs+plusSize v v' = VPlus $ List.sort [v,v']++plusSizes :: [Val] -> Val+plusSizes [] = VZero+plusSizes [v] = v+plusSizes (v:vs) = v `plusSize` (plusSizes vs)++-- maxSize vs = VInfty                 if any v_i=Infty+--            = VMax (sort (nub (flatten vs)) else+-- precondition vs++maxSize :: [Val] -> Val+maxSize vs = case Set.toList . Set.fromList <$> flatten vs of+   Nothing -> VInfty+   Just [] -> VZero+   Just [v] -> v+   Just vs' -> VMax vs'+  where flatten (VZero:vs) = flatten vs+        flatten (VInfty:_) = Nothing+        flatten (VMax vs:vs') = flatten vs' >>= return . (vs++)+        flatten (v:vs) = flatten vs >>= return . (v:)+        flatten [] = return []++{-+maxSize :: [Val] -> Val+maxSize vs = case flatten [] vs of+   [] -> VInfty+   [v] -> v+   vs' -> VMax vs'+  where flatten acc (VInfty:_) = []+        flatten acc (VMax vs:vs') = flatten (vs ++ acc) vs'+        flatten acc (v:vs) = flatten (v:acc) vs+        flatten acc [] = Set.toList $ Set.fromList acc -- sort, nub+-}++-- * destructors -------------------------------------------------------++vSortToSort :: Sort Val -> Sort Expr+vSortToSort (SortC c)    = SortC c+vSortToSort (Set VInfty) = Set Infty++predSize :: Val -> Maybe Val+predSize VInfty = Just VInfty+predSize (VSucc v) = Just v+predSize (VMax vs) = do vs' <- mapM predSize vs+                        return $ maxSize vs'+predSize (VMeta v rho n) | n > 0 = return $ VMeta v rho (n-1)+predSize _ = Nothing -- variable or zero or sum++instance HasPred Val where+  predecessor VInfty = Nothing -- for printing bounds+  predecessor v = predSize v++isFunType :: TVal -> Bool+isFunType VQuant{ vqPiSig = Pi } = True+isFunType _                      = False++isDataType :: TVal -> Bool+isDataType (VApp (VDef (DefId DatK _)) _) = True+isDataType (VSing v tv) = isDataType tv+isDataType _ = False++-- * ugly printing -----------------------------------------------------++instance Show (Sort Val) where+  show (SortC c) = show c+  show (Set VZero) = "Set"+  show (CoSet VInfty) = "Set"+  show (Set v) = parens $ ("Set " ++ show v)+  show (CoSet v) = parens $ ("CoSet " ++ show v)++instance Show Val where+  show v | isVSize v = "Size"+  show (VSort s) = show s+  show VInfty = "#"+  show VZero = "0"+  show (VSucc v) = "($ " ++ show v ++ ")"+  show (VMax vl) = "(max " ++ showVals vl ++ ")"+  show (VPlus (v:vl)) = parens $ foldr (\ v s -> show v ++ " + " ++ s) (show v) vl+  show (VApp v []) = show v+  show (VApp v vl) = "(" ++ show v ++ " " ++ showVals vl ++ ")"+  show (VDef id) = show id+  show (VProj Pre id) = show id+  show (VProj Post id) = "." ++ show id+  show (VPair v1 v2) = "(" ++ show v1 ++ ", " ++ show v2 ++ ")"+  show (VGen k) = "v" ++ show k+  show (VMeta k rho 0) = "?" ++ show k ++ showEnv rho+  show (VMeta k rho 1) = "$?" ++ show k ++ showEnv rho+  show (VMeta k rho n) = "(?" ++ show k ++ showEnv rho ++ " + " ++ show n ++")"+  show (VRecord ri env) = show ri ++ "{" ++ Util.showList "; " (\ (n, v) -> show n ++ " = " ++ show v) env ++ "}"+  show (VCase v vt env cs) = "case " ++ show v ++ " : " ++ show vt ++ " { " ++ showCases cs ++ " } " ++ showEnv env+  show (VClos (Environ [] Nothing) e) = showsPrec precAppR e ""+  show (VClos env e) = "{" ++ show e ++ " " ++ showEnv env ++ "}"+  show (VSing v vt) = "<" ++ show v ++ " : " ++ show vt ++ ">"+  show VIrr  = "."+  show (VMeasured mu tv) = parens $ show mu ++ " -> " ++ show tv+  show (VGuard beta tv) = parens $ show beta ++ " -> " ++ show tv+  show (VBelow ltle v) = show ltle ++ " " ++ show v++  show (VQuant pisig x (Domain (VBelow ltle v) ki dec) bv)+       | (ltle,v) /= (Le,VInfty) =+       parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) +++                (if erased dec then brackets binding else parens binding)+                 ++ " " ++ show pisig ++ " " ++ showSkipLambda bv+            where binding = show x ++ " " ++ show ltle ++ " " ++ show v++  show (VQuant pisig x (Domain av ki dec) bv) =+        parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) +++                (if erased dec then brackets binding+                  else if emptyName x then s1 else parens binding)+                    ++ " " ++ show pisig ++ " " ++ showSkipLambda bv+             where s1 = s2 ++ s0+                   s2 = show av+                   s3 = show ki+                   s0 = if ki == defaultKind || s2 == s3 then "" else "::" ++ s3+                   binding = if emptyName x then  s1 else show x ++ " : " ++ s1++  show (VLam x env e) = "(\\" ++ show x ++ " -> " ++ show e ++ showEnv env ++ ")"+  show (VConst v) = "(\\ _ -> " ++ show v ++ ")"+  show (VAbs x i v valu) = "(\\" ++ show x ++ "@" ++ show i ++ show v ++ showValuation valu ++ ")"+  show (VUp v vt) = "(" ++ show v ++ " Up " ++ show vt ++ ")"++showSkipLambda v =+  case v of+    (VLam x env e)    -> show e ++ showEnv env+    (VConst v)        -> show v+    (VAbs x i v valu) -> show v ++ showValuation valu+    v                 -> show v++showVals :: [Val] -> String+showVals [] = ""+showVals (v:vl) = show v ++ (if null vl then "" else " " ++ showVals vl)++-- environment ---------------------------------------------------++emptyEnv :: Environ a+emptyEnv = Environ [] Nothing++appendEnv :: Environ a -> Environ a -> Environ a+appendEnv (Environ rho mmeas) (Environ rho' mmeas') =+  Environ (rho ++ rho') (orM mmeas mmeas')++-- | enviroment extension / update+update :: Environ a -> Name -> a -> Environ a+update env n v | emptyName n = env+               | otherwise   = env { envMap = (n,v) : envMap env }++lookupPure :: Show a => Environ a -> Name -> a+lookupPure rho x =+    case lookup x (envMap rho) of+      Just v -> v+      Nothing -> error $ "lookupPure: unbound identifier " ++ show x ++ " in environment " ++ show rho++lookupEnv :: Monad m => Environ a -> Name -> m a+lookupEnv rho x =+    case lookup x (envMap rho) of+      Just v -> return $ v+      Nothing -> fail $ "lookupEnv: unbound identifier " ++ show x --  ++ " in environment " ++ show rho+{-+lookupEnv :: Monad m => Environ a -> Name -> m a+lookupEnv [] n = fail $ "lookupEnv: identifier " ++ show n ++ " not bound"+lookupEnv ((x,v):xs) n = if x == n then return v+                          else lookupEnv xs n+-}++showValuation :: Valuation -> String+showValuation (Valuation [])  = ""+showValuation (Valuation tau) = "{" ++ Util.showList ", " (\(i,v) -> show i ++ " = " ++ show v) tau ++ "}"++showEnv :: Environ Val -> String+showEnv (Environ [] Nothing)   = ""+showEnv (Environ rho Nothing)  = "{" ++ showEnv' rho ++ "}"+showEnv (Environ [] (Just mu)) = "{ measure=" ++ show mu ++ " }"+showEnv (Environ rho (Just mu)) = "{" ++ showEnv' rho ++ " | measure=" ++ show mu ++ " }"++showEnv' :: EnvMap -> String+showEnv' = Util.showList ", " (\ (n,v) -> show n ++ " = " ++ show v)
+ src/Value.hs-boot view
@@ -0,0 +1,10 @@+module Value where++import {-# SOURCE #-} Abstract++data Val+instance Eq Val+instance Ord Val+instance Show Val++type TeleVal = [TBinding Val]
+ src/Warshall.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Warshall where++{- construct a graph from constraints++   x + n <= y   becomes   x ---(-n)---> y+   x <= n + y   becomes   x ---(+n)---> y++the default edge (= no edge is) labelled with infinity++building the graph involves keeping track of the node names.+We do this in a finite map, assigning consecutive numbers to nodes.+-}+++import Control.Monad.State+import Data.Maybe -- fromJust+import Data.Array+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.List as List++import Debug.Trace+import Util+++traceSolve msg a = a -- trace msg a +traceSolveM msg = return () -- traceM msg+{-+traceSolve msg a = trace msg a +traceSolveM msg = traceM msg+-}+++-- semi rings ----------------------------------------------------++class SemiRing a where+  oplus  :: a -> a -> a+  otimes :: a -> a -> a+  ozero  :: a -- neutral for oplus, dominant for otimes+  oone   :: a -- neutral for otimes++type Matrix a = Array (Int,Int) a++-- assuming a square matrix+warshall :: SemiRing a => Matrix a -> Matrix a+warshall a0 = loop r a0 where +  b@((r,c),(r',c')) = bounds a0 -- assuming r == c and r' == c'+  loop k a | k <= r' = +    loop (k+1) (array b [ ((i,j), +                           (a!(i,j)) `oplus` ((a!(i,k)) `otimes` (a!(k,j))))+                        | i <- [r..r'], j <- [c..c'] ])+           | otherwise = a++-- edge weight in the graph, forming a semi ring ++data Weight = Finite Int | Infinite +              deriving (Eq)++inc :: Weight -> Int -> Weight+inc Infinite   n = Infinite+inc (Finite k) n = Finite (k + n)++instance Show Weight where+  show (Finite i) = show i+  show Infinite   = "."++instance Ord Weight where+  a <= Infinite = True+  Infinite <= b = False+  Finite a <= Finite b = a <= b++instance SemiRing Weight where+  oplus = min++  otimes Infinite _ = Infinite+  otimes _ Infinite = Infinite+  otimes (Finite a) (Finite b) = Finite (a + b)++  ozero = Infinite+  oone  = Finite 0+ +-- constraints ---------------------------------------------------++-- nodes of the graph are either +-- * flexible variables (with identifiers drawn from Int), +-- * rigid variables (also identified by Ints), or +-- * constants (like 0, infinity, or anything between)++data Node rigid+  = Rigid rigid+  | Flex  FlexId+    deriving (Eq, Ord)++instance Show rigid => Show (Node rigid) where+  show (Flex  i) = "?" ++ show i+  show (Rigid r) = show r++data Rigid = RConst Weight+           | RVar RigidId+             deriving (Eq, Ord)++instance Show Rigid where+  show (RVar i) = "v" ++ show i+  show (RConst Infinite)   = "#"+  show (RConst (Finite n)) = show n++type NodeId  = Int+type RigidId = Int+type FlexId  = Int+type Scope   = RigidId -> Bool  +-- which rigid variables a flex may be instatiated to++infinite (RConst Infinite) = True+infinite _ = False++-- isBelow r w r'  +-- checks, if r and r' are connected by w (meaning w not infinite)+-- wether r + w <= r'+-- precondition: not the same rigid variable+isBelow :: Rigid -> Weight -> Rigid -> Bool+isBelow _ Infinite _ = True+isBelow _ n (RConst Infinite) = True+-- isBelow (RConst Infinite)   n (RConst (Finite _)) = False+isBelow (RConst (Finite i)) (Finite n) (RConst (Finite j)) = i + n <= j+isBelow _ _ _ = False -- rigid variables are not related++-- a constraint is an edge in the graph+data Constrnt edgeLabel rigid flexScope+  = NewFlex FlexId flexScope+  | Arc (Node rigid) edgeLabel (Node rigid)+-- Arc v1 k v2  at least one of v1,v2 is a VMeta (Flex), +--              the other a VMeta or a VGen (Rigid)+-- if k <= 0 this means  $^(-k) v1 <= v2+-- otherwise                    v1 <= $^k v3++type Constraint = Constrnt Weight Rigid Scope++arc :: Node Rigid -> Int -> Node Rigid -> Constraint+arc a k b = Arc a (Finite k) b++instance Show Constraint where+  show (NewFlex i s) = "SizeMeta(?" ++ show i ++ ")"+  show (Arc v1 (Finite k) v2) +    | k == 0 = show v1 ++ "<=" ++ show v2+    | k < 0  = show v1 ++ "+" ++ show (-k) ++ "<=" ++ show v2+    | otherwise  = show v1 ++ "<=" ++ show v2 ++ "+" ++ show k++type Constraints = [Constraint]++emptyConstraints = []++-- graph (matrix) ------------------------------------------------++data Graph edgeLabel rigid flexScope = Graph +  { flexScope :: Map FlexId flexScope       -- scope for each flexible var+  , nodeMap :: Map (Node rigid) NodeId      -- node labels to node numbers+  , intMap  :: Map NodeId (Node rigid)      -- node numbers to node labels+  , nextNode :: NodeId                      -- number of nodes (n)+  , graph :: NodeId -> NodeId -> edgeLabel  -- the edges (restrict to [0..n[)+  }++-- the empty graph: no nodes, edges are all undefined (infinity weight)+initGraph :: SemiRing edgeLabel => Graph edgeLabel rigid flexScope+initGraph = Graph Map.empty Map.empty Map.empty 0 (\ x y -> ozero)++-- the Graph Monad, for constructing a graph iteratively+type GM edgeLabel rigid flexScope = State (Graph edgeLabel rigid flexScope)++addFlex :: FlexId -> flexScope -> GM edgeLabel rigid flexScope ()+addFlex x scope = do+  st <- get+  put $ st { flexScope = Map.insert x scope (flexScope st) }+++-- i <- addNode n  returns number of node n. if not present, it is added first+addNode :: (Eq rigid, Ord rigid) => (Node rigid) -> GM edgeLabel rigid flexScope Int+addNode n = do+  st <- get+  case Map.lookup n (nodeMap st) of+    Just i -> return i+    Nothing -> do let i = nextNode st+                  put $ st { nodeMap = Map.insert n i (nodeMap st)+                           , intMap = Map.insert i n (intMap st)+                           , nextNode = i + 1+                           }+                  return i++-- addEdge n1 k n2  +-- improves the weight of egde n1->n2 to be at most k+-- also adds nodes if not yet present+addEdge :: (Eq rigid, Ord rigid, SemiRing edgeLabel) => (Node rigid) -> edgeLabel -> (Node rigid) -> GM edgeLabel rigid flexScope ()+addEdge n1 k n2 = do+  i1 <- addNode n1+  i2 <- addNode n2+  st <- get+  let graph' x y = if (x,y) == (i1,i2) then k `oplus` (graph st) x y+                   else graph st x y+  put $ st { graph = graph' }++addConstraint :: (Eq rigid, Ord rigid, SemiRing edgeLabel) =>  +  Constrnt edgeLabel rigid flexScope -> GM edgeLabel rigid flexScope ()+addConstraint (NewFlex x scope) = do+  addFlex x scope+  addEdge (Flex x) oone (Flex x) -- add dummy edge to make sure each meta variable+                              -- is in the matrix and gets solved+addConstraint (Arc n1 k n2)     = addEdge n1 k n2++buildGraph :: (Eq rigid, Ord rigid, SemiRing edgeLabel) =>  +  [Constrnt edgeLabel rigid flexScope] -> Graph edgeLabel rigid flexScope+buildGraph cs = execState (mapM_ addConstraint cs) initGraph++mkMatrix :: Int -> (Int -> Int -> a) -> Matrix a+mkMatrix n g = array ((0,0),(n-1,n-1)) +                 [ ((i,j), g i j) | i <- [0..n-1], j <- [0..n-1]]++-- displaying matrices with row and column labels --------------------++-- a matrix with row descriptions in b and column descriptions in c+data LegendMatrix a b c = LegendMatrix +  { matrix   :: Matrix a+  , rowdescr :: Int -> b+  , coldescr :: Int -> c+  }++instance (Show a, Show b, Show c) => Show (LegendMatrix a b c) where+  show (LegendMatrix m rd cd) =+    -- first show column description+    let ((r,c),(r',c')) = bounds m+    in foldr (\ j s -> "\t" ++ show (cd j) ++ s) "" [c .. c'] ++ +    -- then output rows+       foldr (\ i s -> "\n" ++ show (rd i) +++                foldr (\ j t -> "\t" ++ show (m!(i,j)) ++ t) +                      (s) +                      [c .. c'])+             "" [r .. r'] ++-- solving the constraints -------------------------------------------++-- a solution assigns to each flexible variable a size expression+-- which is either a constant or a v + n for a rigid variable v+type Solution = Map Int MaxExpr++emptySolution :: Solution+emptySolution = Map.empty++extendSolution :: Solution -> Int -> SizeExpr -> Solution+extendSolution subst k v = Map.insertWith (++) k [v] subst++type MaxExpr = [SizeExpr]+-- newtype MaxExpr = MaxExpr { sizeExprs :: [SizeExpr] } deriving (Show)++data SizeExpr = SizeVar Int Int   -- e.g. x + 5+              | SizeConst Weight  -- a number or infinity++instance Show SizeExpr where+  show (SizeVar n 0) = show (Rigid (RVar n))+  show (SizeVar n k) = show (Rigid (RVar n)) ++ "+" ++ show k+  show (SizeConst (Finite i)) = show i+  show (SizeConst Infinite)   = "#"++-- sizeRigid r n  returns the size expression corresponding to r + n+sizeRigid :: Rigid -> Int -> SizeExpr+sizeRigid (RConst k) n = SizeConst (inc k n)+sizeRigid (RVar i)   n = SizeVar i n ++{-+apply :: SizeExpr -> Solution -> SizeExpr+apply e@(SizeExpr (Rigid _) _) phi = e+apply e@(SizeExpr (Flex  x) i) phi = case Map.lookup x phi of+  Nothing -> e+  Just (SizeExpr v j) -> SizeExpr v (i + j) + +after :: Solution -> Solution -> Solution+after psi phi = Map.map (\ e -> e `apply` phi) psi+-}++{-+solve :: Constraints -> Maybe Solution+solve cs = if any (\ x -> x < Finite 0) d then Nothing+     else Map.+   where gr = buildGraph cs+         n  = nextNode gr+         m  = mkMatrix n (graph gr)+         m' = warshall m+         d  = [ m!(i,i) | i <- [0 .. (n-1)] ]+         ns = keys (nodeMap gr)+-}++{- compute solution++a solution CANNOT exist if++  v < v  for a rigid variable v++  v <= v' for rigid variables v,v'++  x < v   for a flexible variable x and a rigid variable v++thus, for each flexible x, only one of the following cases is possible++  r+n <= x+m <= infty  for a unique rigid r  (meaning r --(m-n)--> x)+  x <= r+n             for a unique rigid r  (meaning x --(n)--> r)++we are looking for the least values for flexible variables that solve+the constraints.  Algorithm++while flexible variables and rigid rows left+  find a rigid variable row i+    for all flexible columns j+      if i --n--> j with n<=0 (meaning i+n <= j) then j = i + n++while flexible variables j left+  search the row j for entry i+    if j --n--> i with n >= 0 (meaning j <= i + n) then j = i +++-}++solve :: Constraints -> Maybe Solution+solve cs = traceSolve (show lm0) $ traceSolve (show lm) $ traceSolve (show cs) $+     let solution = if solvable then loop1 rigids emptySolution+                    else Nothing+     in traceSolve ("solution = " ++ show solution) $ +          solution+   where -- compute the graph and its transitive closure m+         gr  = buildGraph cs+         n   = nextNode gr            -- number of nodes+         m0  = mkMatrix n (graph gr)+         m   = warshall m0++         -- tracing only: build output version of transitive graph+         legend i = fromJust $ Map.lookup i (intMap gr) -- trace only+         lm0 = LegendMatrix m0 legend legend            -- trace only+         lm  = LegendMatrix m legend legend             -- trace only++         -- compute the sets of flexible and rigid node numbers+         ns  = Map.keys (nodeMap gr)                    +         -- a set of flexible variables+         flexs  = foldl (\ l k -> case k of (Flex i) -> i : l+                                            (Rigid _) -> l) [] ns+         -- a set of rigid variables+         rigids = foldl (\ l k -> case k of (Flex _) -> l+                                            (Rigid i) -> i : l) [] ns++         -- rigid matrix indices+         rInds = foldl (\ l r -> let Just i = Map.lookup (Rigid r) (nodeMap gr)+                                 in i : l) [] rigids++         -- check whether there is a solution+         -- d   = [ m!(i,i) | i <- [0 .. (n-1)] ]  -- diagonal+-- a rigid variable might not be less than it self, so no -.. on the +-- rigid part of the diagonal+         solvable = all (\ x -> x >= oone) [ m!(i,i) | i <- rInds ] &&+-- a rigid variable might not be bounded below by infinity or+-- bounded above by a constant+-- it might not be related to another rigid variable+           all (\ (r,  r') -> r == r' || +                let Just row = (Map.lookup (Rigid r)  (nodeMap gr))+                    Just col = (Map.lookup (Rigid r') (nodeMap gr))+                    edge = m!(row,col)+                in  isBelow r edge r' ) +             [ (r,r') | r <- rigids, r' <- rigids ]+           &&+-- a flexible variable might not be strictly below a rigid variable+           all (\ (x, v) -> +                let Just row = (Map.lookup (Flex x)  (nodeMap gr))+                    Just col = (Map.lookup (Rigid (RVar v)) (nodeMap gr))+                    edge = m!(row,col)+                in  edge >= Finite 0)+             [ (x,v) | x <- flexs, (RVar v) <- rigids ]+++         inScope :: FlexId -> Rigid -> Bool+         inScope x (RConst _) = True+         inScope x (RVar v)   = case Map.lookup x (flexScope gr) of+                     Just scope -> scope v+                     Nothing    -> error $ "Warshall.inScope panic: flexible " ++ show x ++ " does not carry scope info when assigning it rigid variable " ++ show v  ++{- loop1++while flexible variables and rigid rows left+  find a rigid variable row i+    for all flexible columns j+      if i --n--> j with n<=0 (meaning i + n <= j) then +        add i + n to the solution of j++-}++         loop1 :: [Rigid] -> Solution -> Maybe Solution+         loop1 (r:rgds) subst = loop1 rgds subst' where +            row = fromJust $ Map.lookup (Rigid r) (nodeMap gr)+            subst' =+                  foldl (\ sub f -> +                          let col = fromJust $ Map.lookup (Flex f) (nodeMap gr)+                          in  case (True -- inScope f r  -- SEEMS WRONG TO IGNORE THINGS NOT IN SCOPE+                                   , m!(row,col)) of+--                                Finite z | z <= 0 -> +                                (True, Finite z) -> +                                   let trunc z | z >= 0 = 0+                                            | otherwise = -z+                                   in extendSolution sub f (sizeRigid r (trunc z))+                                _ -> sub+                     ) subst flexs       +         loop1 [] subst = case flexs List.\\ (Map.keys subst) of+            [] -> Just subst+            flexs' -> loop2 flexs' subst++{- loop2++while flexible variables j left+  search the row j for entry i+    if j --n--> i with n >= 0 (meaning j <= i + n) then j = i ++-}+         loop2 :: [FlexId] -> Solution -> Maybe Solution+         loop2 [] subst = Just subst +         loop2 (f:flxs) subst = loop3 0 subst+           where row = fromJust $ Map.lookup (Flex f) (nodeMap gr)+                 loop3 col subst | col >= n = +                   -- default to infinity+                    loop2 flxs (extendSolution subst f (SizeConst Infinite)) +                 loop3 col subst =+                   case Map.lookup col (intMap gr) of+                     Just (Rigid r) | not (infinite r) -> +                       case (True -- inScope f r+                            ,m!(row,col)) of+                        (True, Finite z) | z >= 0 -> +                            loop2 flxs (extendSolution subst f (sizeRigid r z))+                        (_, Infinite) -> loop3 (col+1) subst +                        _ -> Nothing +                     _ -> loop3 (col+1) subst
test/fail/Makefile view
@@ -14,7 +14,7 @@ # an error.  Then one has to verify the new error message is actually the # intended one (manually), and remove the .err file. -mugda=../../Main+mugda=../../src/Main  # Enable read -n SHELL=bash@@ -29,7 +29,7 @@ default : all all : $(allstems) -debug : +debug : 	@echo $(allagda)  # No error recorded@@ -91,7 +91,7 @@ # RETARDED!!!!!!!  #		echo rm -f $*.tmp; echo rm -f $*.tmp.2; \-#		false; +#		false;  # Clean
test/succeed/Makefile view
@@ -1,14 +1,14 @@-# MiniAgda +# MiniAgda # Makefile for successful tests # Authors: Andreas Abel, Ulf Norell # Created: 2004-12-03, 2008-09-03 -mugda = ../../Main+mugda = ../../src/Main  # Getting all miniagda files allagda=$(patsubst %.ma,%,$(shell find . -name "*.ma")) -all : $(allagda) +all : $(allagda)  $(allagda) : % : %.ma 	@echo "----------------------------------------------------------------------"