diff --git a/Abstract.hs b/Abstract.hs new file mode 100644 --- /dev/null +++ b/Abstract.hs @@ -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 :: Monad m => (a -> m a) -> Measure a -> m (Measure a) +applyLastM f (Measure mu) = loop mu >>= return . Measure + where loop [] = fail "empty measure" + loop [e] = f e >>= return . (:[]) + loop (e:es) = loop es >>= return . (e:) + +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 -- 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 + + +-} diff --git a/Abstract.hs-boot b/Abstract.hs-boot new file mode 100644 --- /dev/null +++ b/Abstract.hs-boot @@ -0,0 +1,4 @@ +module Abstract where + +data TBinding a + diff --git a/Collection.hs b/Collection.hs new file mode 100644 --- /dev/null +++ b/Collection.hs @@ -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.\\) diff --git a/Concrete.hs b/Concrete.hs new file mode 100644 --- /dev/null +++ b/Concrete.hs @@ -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 -- ^ @@ 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 ++ ")" diff --git a/Eval.hs b/Eval.hs new file mode 100644 --- /dev/null +++ b/Eval.hs @@ -0,0 +1,2358 @@ +{-# LANGUAGE TupleSections, FlexibleInstances, 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.Error hiding (mapM) +import Control.Monad.Reader hiding (mapM) +import Control.Monad.IfElse -- unlessM +-- import Control.Monad.HT -- andLazy -- because liftM2 (&&) is NOT lazy! + +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 + +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 +-} + +-- 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 +-- = Pi x:a +-- B > = Pi x: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) +-- = Pi x:a +-- = Pi x: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 + -- fail $ "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) -> fail $ "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 -> fail $ "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 + +-- = Pi x: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 (fail $ "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 -> fail $ "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,_) -> fail $ "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 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 +-- fail $ "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 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 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 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 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 = fail $ "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 + _ -> fail $ "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) $ + fail ("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{} -> fail $ "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, Error e, MonadError e 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) + _ -> throwError $ strMsg $ "type " ++ show tv1 ++ " has different shape than " ++ show tv2 + +sortView12 :: (Monad 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) + _ -> fail $ "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 typeView12 tv12 of + Right sh -> return $ Just sh + Left err -> (recoverFail 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 fail $ "pattern " ++ show p1 ++ " != " ++ show p2 +-} + +type NameMap = [(Name,Name)] + +alphaPattern :: Pattern -> Pattern -> StateT NameMap TypeCheck () +alphaPattern p1 p2 = do + let failure = fail $ "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 +-- _ -> fail $ "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{}) -> fail err + (VSucc{}, VPlus{}) -> fail 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) -> fail $ "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 diff --git a/Eval.hs-boot b/Eval.hs-boot new file mode 100644 --- /dev/null +++ b/Eval.hs-boot @@ -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 diff --git a/Extract.hs b/Extract.hs new file mode 100644 --- /dev/null +++ b/Extract.hs @@ -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 -> + { 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.Error +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 = runErrorT (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{} -> fail $ "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] + _ -> fail $ "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 $ fail $ "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 +-- _ -> fail $ "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{} -> fail $ "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 + _ -> fail $ "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 }) +-} diff --git a/HsSyntax.hs b/HsSyntax.hs new file mode 100644 --- /dev/null +++ b/HsSyntax.hs @@ -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) 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 '()' +-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2007-2014 Andreas Abel and Karl Mehltretter. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Lexer.x b/Lexer.x new file mode 100644 --- /dev/null +++ b/Lexer.x @@ -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 + +} diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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' diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,111 @@ +# 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 + +# EOF diff --git a/MiniAgda.cabal b/MiniAgda.cabal new file mode 100644 --- /dev/null +++ b/MiniAgda.cabal @@ -0,0 +1,88 @@ +name: MiniAgda +version: 0.2014.1.9 +build-type: Simple +cabal-version: >= 1.8 +license: OtherLicense +license-file: LICENSE +author: Andreas Abel and Karl Mehltretter +maintainer: Andreas Abel +homepage: http://www.tcs.ifi.lmu.de/~abel/miniagda/ +bug-reports: http://hub.darcs.net/abel/miniagda/issues +category: Dependent types +synopsis: A toy dependently typed programming language with type-based termination. +description: + MiniAgda is a tiny dependently-typed programming language in the style + of Agda. It serves as a laboratory to test potential additions to the + language and type system of Agda. MiniAgda's termination checker is a + fusion of sized types and size-change termination and supports + coinduction. Equality incorporates eta-expansion at record and + singleton types. Function arguments can be declared as static; such + arguments are discarded during equality checking and compilation. + + Recent features include bounded size quantification and destructor + patterns for a more general handling of coinduction. + +tested-with: GHC == 7.6.3 + +extra-source-files: Makefile + +data-files: test/succeed/Makefile + test/succeed/*.ma + test/fail/Makefile + test/fail/*.ma + test/fail/*.err + test/fail/adm/*.ma + test/fail/adm/*.err + lib/*.ma +source-repository head + type: darcs + location: http://hub.darcs.net/abel/miniagda + +executable miniagda + hs-source-dirs: . + build-depends: array >= 0.3 && < 0.5, + base >= 4.2 && < 4.7, + containers >= 0.3 && < 0.6, + haskell-src-exts >= 1.14 && < 1.15, + -- mtl-2.1 contains a severe bug + mtl >= 2.0 && < 2.1 || >= 2.1.1 && < 2.2, + pretty >= 1.0 && < 1.2, +-- utility-ht >= 0.0.1 && < 1.0, + IfElse >= 0.85 && < 2.0 + build-tools: happy >= 1.15 && < 2, + alex >= 3.0 && < 4 + extensions: CPP + MultiParamTypeClasses + TypeSynonymInstances + FlexibleInstances + FlexibleContexts + GeneralizedNewtypeDeriving + NoMonomorphismRestriction + PatternGuards + TupleSections + NamedFieldPuns + main-is: Main.hs + other-modules: Abstract + Collection + Concrete + Eval + Extract + HsSyntax + Lexer + Main + Parser + Polarity + PrettyTCM + ScopeChecker + Semiring + SparseMatrix + TCM + Termination + ToHaskell + Tokens + TraceError + TreeShapedOrder + TypeChecker + Util + Value + Warshall diff --git a/Parser.y b/Parser.y new file mode 100644 --- /dev/null +++ b/Parser.y @@ -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) + +} diff --git a/Polarity.hs b/Polarity.hs new file mode 100644 --- /dev/null +++ b/Polarity.hs @@ -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 +-} diff --git a/PrettyTCM.hs b/PrettyTCM.hs new file mode 100644 --- /dev/null +++ b/PrettyTCM.hs @@ -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 diff --git a/ScopeChecker.hs b/ScopeChecker.hs new file mode 100644 --- /dev/null +++ b/ScopeChecker.hs @@ -0,0 +1,1125 @@ +-- 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.IfElse +import Control.Monad.Identity hiding (mapM) +import Control.Monad.Reader hiding (mapM) +import Control.Monad.State hiding (mapM) +import Control.Monad.Error 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 (ErrorT 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 $ runErrorT $ + 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) $ fail $ "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 _) = fail $ "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{}) = fail $ "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) $ fail $ "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 + _ -> fail $ "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 + fail $ "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 -> fail $ + "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 + + _ -> fail $ "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 -> fail $ "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" diff --git a/Semiring.hs b/Semiring.hs new file mode 100644 --- /dev/null +++ b/Semiring.hs @@ -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 + ] +-} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SparseMatrix.hs b/SparseMatrix.hs new file mode 100644 --- /dev/null +++ b/SparseMatrix.hs @@ -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) +-} + diff --git a/TCM.hs b/TCM.hs new file mode 100644 --- /dev/null +++ b/TCM.hs @@ -0,0 +1,1523 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, PatternGuards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, DeriveFoldable, DeriveTraversable, TupleSections #-} + +module TCM where + +import Prelude hiding (null) + +import Control.Monad +import Control.Monad.IfElse +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Error +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 (ErrorT 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 + } + +{- +-- only defined for single bindings +cxtSetType :: Int -> Dec -> TVal -> SemCxt -> SemCxt +cxtSetType k dec tv delta = + delta { cxt = Map.insert k (One tv) (cxt delta) + , decs = Map.insert k (One dec) (decs delta) + -- upperDecs need not be updated + } +-- , decs = Map.insert k dec (decs delta) } +-} +{- +cxtLookupGen :: Monad m => SemCxt -> Int -> m Domain +cxtLookupGen delta k = do + One tv <- lookupM k (cxt delta) + One dec <- lookupM k (decs delta) +-- dec <- lookupM k (decs delta) + return $ Domain { typ = tv, decor = dec } + +cxtLookupGen :: Monad m => SemCxt -> Int -> m CxtEntry +cxtLookupGen delta k = do + tv12 <- lookupM k (cxt delta) + dec12 <- lookupM k (decs delta) + udec <- lookupM k (upperDecs delta) + return $ CxtEntry (zipWith12 Domain tv12 dec12) udec +-} +cxtLookupGen :: Monad m => SemCxt -> Int -> m CxtEntry +cxtLookupGen delta k = do + dom12 <- lookupM k (cxt delta) + udec <- lookupM k (upperDecs delta) + return $ CxtEntry dom12 udec + +cxtLookupName :: Monad m => SemCxt -> Ren -> Name -> m CxtEntry +cxtLookupName delta ren x = do + i <- lookupM x ren + cxtLookupGen delta i + +{- +cxtLookupName :: Monad m => SemCxt -> Ren -> Name -> m Domain +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 -> fail $ "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 + -- fail $ "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 + awhenM (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 + _ -> fail $ "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 + _ -> fail $ "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 + _ -> fail $ "matchPatType: IMPOSSIBLE " ++ show p ++ " : " ++ show dom + + (DotP e, _) -> cont + (AbsurdP, _) -> cont + (ErasedP p,_) -> matchPatType (p,v) dom cont + _ -> fail $ "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 + _ -> fail $ "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) $ fail $ "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') $ fail $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show d' + -- whenJust conPars $ fail $ "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 -> fail $ "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 + fail $ "cannot handle constraint " ++ show v ++ " <= " ++ show (VMax vs) + mkConstraint w@(VMax vs) v = fail $ "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 = fail $ "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 -> fail $ "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'') +-} diff --git a/TCM.hs-boot b/TCM.hs-boot new file mode 100644 --- /dev/null +++ b/TCM.hs-boot @@ -0,0 +1,17 @@ +module TCM where + +-- import CallStack +import TraceError + +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Error +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 (ErrorT TraceError IO)) diff --git a/Termination.hs b/Termination.hs new file mode 100644 --- /dev/null +++ b/Termination.hs @@ -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^*)^* + +-} diff --git a/ToHaskell.hs b/ToHaskell.hs new file mode 100644 --- /dev/null +++ b/ToHaskell.hs @@ -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 -> + { 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.Error +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 (ErrorT 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 = runErrorT (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{} -> fail $ "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: + _ -> fail $ "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) $ + fail $ "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) $ + fail $ "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" diff --git a/Tokens.hs b/Tokens.hs new file mode 100644 --- /dev/null +++ b/Tokens.hs @@ -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) + diff --git a/TraceError.hs b/TraceError.hs new file mode 100644 --- /dev/null +++ b/TraceError.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} + +module TraceError where + +import Control.Monad.Error +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 :: (Monad m) => m Doc -> m a +failDoc d = fail . 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 :: (Monad m) => m Doc -> Bool -> m () +boolToErrorDoc d True = return () +boolToErrorDoc d False = failDoc d + +boolToError :: (Monad m) => String -> Bool -> m () +boolToError msg True = return () +boolToError msg False = fail 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' :: (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 = fail s + +assertDoc' :: (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 +-} diff --git a/TreeShapedOrder.hs b/TreeShapedOrder.hs new file mode 100644 --- /dev/null +++ b/TreeShapedOrder.hs @@ -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 = headM $ 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 diff --git a/TypeChecker.hs b/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/TypeChecker.hs @@ -0,0 +1,3302 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, + PatternGuards, TupleSections, NamedFieldPuns #-} + +module TypeChecker where + +import Prelude hiding (null) + +import Control.Applicative hiding (Const) -- ((<$>)) +import Control.Monad +import Control.Monad.IfElse +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Error +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 = (runErrorT (runStateT tc sig)) +-} + +doNf sig e = runErrorT (runReaderT (runStateT (whnf emptyEnv e >>= reify) (initWithSig sig)) emptyContext) +doWhnf sig e = runErrorT (runReaderT (runStateT (whnf emptyEnv e >>= whnfClos) (initWithSig sig)) emptyContext) + + +-- top-level functions ------------------------------------------- + +runTypeCheck :: TCState -> TypeCheck a -> IO (Either TraceError (a,TCState)) +runTypeCheck st tc = runErrorT (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 fail "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 = fail $ "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 -> fail $ "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 = fail $ + "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 + _ -> fail $ "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 + _ -> fail $ "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 () + _ -> fail $ "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) = <> + 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,_) -> fail $ 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 -> fail $ 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 -> fail $ err ++ "min" ++ show (v1,v2) ++ " does not exist" + | v1 == VInfty -> return $ CoSet $ succSize v2 + | otherwise -> fail $ 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) + _ -> fail $ "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 + fail $ err ++ ", because it is marked as erased" + else if not (leqPol pol SPos) then + fail $ 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) $ + fail $ "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 + _ -> fail $ "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) -> fail ("missing right hand side in case " ++ showCase cl) + (True,Just rhs) -> fail ("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) -> fail ("missing right hand side in clause " ++ show cl) + (True,Just rhs) -> fail ("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 -> fail $ "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) $ + fail ("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. ) -> + =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) $ fail ("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') $ fail ("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) $ fail ("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) $ + fail $ "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 -> fail $ "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 = fail $ "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 + _ -> fail $ "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)) $ + fail $ 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, []) + _ -> fail "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, []) + + _ -> fail "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 () + _ -> fail $ "expected size variable" + _ -> fail $ "expected (co)inductive sized type" + _ -> fail $ "expected (co)inductive sized type" diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -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.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 + +liftMaybe :: (Monad m) => Maybe a -> m a +liftMaybe = maybe (fail "Util.liftMaybe: unexpected Nothing") return + +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 + +lookupM :: (Monad m, Show k, Ord k) => k -> Map k v -> m v +lookupM k m = maybe (fail $ "lookupM: unbound key " ++ show k) return $ Map.lookup k m + +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 + +headM :: Monad m => [a] -> m a +headM [] = fail "headM" +headM (a:as) = return 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 diff --git a/Value.hs b/Value.hs new file mode 100644 --- /dev/null +++ b/Value.hs @@ -0,0 +1,410 @@ +{-# 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 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 +-} + +failValInv :: (Monad m) => Val -> m a +failValInv v = fail $ "internal error: value " ++ show v ++ " violates representation invariant" + +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) diff --git a/Value.hs-boot b/Value.hs-boot new file mode 100644 --- /dev/null +++ b/Value.hs-boot @@ -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] diff --git a/Warshall.hs b/Warshall.hs new file mode 100644 --- /dev/null +++ b/Warshall.hs @@ -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 diff --git a/dist/build/miniagda/miniagda-tmp/Lexer.hs b/dist/build/miniagda/miniagda-tmp/Lexer.hs new file mode 100644 --- /dev/null +++ b/dist/build/miniagda/miniagda-tmp/Lexer.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE CPP,MagicHash #-} +{-# 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.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# 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 22 "templates/wrappers.hs" #-} + +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 89 "templates/wrappers.hs" #-} + +{-# LINE 103 "templates/wrappers.hs" #-} + +{-# LINE 118 "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+7) `div` 8)*8+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 231 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + +{-# LINE 320 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + +{-# LINE 346 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + +{-# LINE 364 "templates/wrappers.hs" #-} + +{-# LINE 377 "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 " ++ (show line) ++ " line, " ++ (show column) ++ " column" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : go inp' + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + +{-# LINE 409 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + +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"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x05\x00\x31\x00\x41\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x49\x00\x00\x00\x33\x00\x34\x00\x17\x00\x47\x00\x48\x00\x3a\x00\x3b\x00\x45\x00\x42\x00\x3f\x00\x43\x00\x40\x00\x44\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x3e\x00\x3d\x00\x4d\x00\x4a\x00\x4e\x00\x02\x00\x00\x00\x7c\x00\x7c\x00\x74\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x64\x00\x6e\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x38\x00\x4b\x00\x39\x00\x46\x00\x4c\x00\x30\x00\x7c\x00\x7c\x00\x6a\x00\x5d\x00\x86\x00\x5a\x00\x7c\x00\x7c\x00\x98\x00\x7c\x00\x7c\x00\x5e\x00\x66\x00\x7c\x00\x7c\x00\x78\x00\x7c\x00\x75\x00\x70\x00\x80\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x36\x00\x3c\x00\x37\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\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\x0d\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0e\x00\x0c\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x07\x00\x0b\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\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\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\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\x0d\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0e\x00\x0c\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x07\x00\x0b\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x01\x00\x0e\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\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\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\x0d\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0e\x00\x0c\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x07\x00\x0b\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x07\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\x0c\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0d\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\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\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\x13\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\x15\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\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\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\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\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\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\x14\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x15\x00\x04\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x13\x00\x06\x00\x10\x00\x10\x00\x10\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0d\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0e\x00\x0c\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x07\x00\x0b\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x1c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x1d\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x1f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x23\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x29\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x2a\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x2b\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x2d\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x32\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x9f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x60\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x72\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x9d\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x9c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x53\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x91\x00\x7c\x00\x7c\x00\x7c\x00\x9a\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x99\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x97\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x96\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x54\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x55\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x95\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x94\x00\x7c\x00\x7c\x00\x7c\x00\x8a\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x93\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x92\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x82\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x90\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x8f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x8d\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x5c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x6b\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x87\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x61\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x8c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x63\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x8b\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x65\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x89\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x68\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x88\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x85\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x6f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x71\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x73\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x83\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x81\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x77\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x79\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7e\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7b\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7a\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x76\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x84\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x6d\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x6c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x69\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x62\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x5f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x67\x00\x7c\x00\x5b\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x8e\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x59\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x58\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x57\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x56\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x9b\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x52\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x9e\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x51\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x50\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x35\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x2f\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x2e\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x2c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x28\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x27\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7d\x00\x26\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x25\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x24\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x22\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x21\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x20\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x1e\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x7c\x00\x7c\x00\x7c\x00\x1b\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\x7c\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\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\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x3e\x00\x2b\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x3d\x00\xff\xff\x23\x00\x24\x00\x20\x00\x26\x00\x3e\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x2d\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x7c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\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\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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"# + +alex_deflt :: AlexAddr +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) [[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[(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 "" #-} +{-# LINE 1 "" #-} +{-# 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 37 "templates/GenericTemplate.hs" #-} + +{-# LINE 47 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + !i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (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#))) + !b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + !off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (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` (I# (s)))) + in + new_acc `seq` + case alexGetByte input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + (base) = alexIndexInt32OffAddr alex_base s + ((I# (ord_c))) = fromIntegral c + (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 [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a predx : rest) + | predx user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred predx : rest) + | predx user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +instance Functor AlexLastAcc where + fmap f AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap f (AlexLastSkip x y) = AlexLastSkip x y + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred 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 (I# (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. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/dist/build/miniagda/miniagda-tmp/Parser.hs b/dist/build/miniagda/miniagda-tmp/Parser.hs new file mode 100644 --- /dev/null +++ b/dist/build/miniagda/miniagda-tmp/Parser.hs @@ -0,0 +1,2685 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# 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 qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.18.9 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn4 :: ([C.Declaration]) -> (HappyAbsSyn ) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> ([C.Declaration]) +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: ([C.Declaration]) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([C.Declaration]) +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: ((C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name])) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> ((C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name])) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ((C.Name, C.Telescope, C.Type, C.Constructor, [C.Name])) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ((C.Name, C.Telescope, C.Type, C.Constructor, [C.Name])) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (C.LetDef) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (C.LetDef) +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: (Bool) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> (Bool) +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (Maybe C.Type) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (Maybe C.Type) +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (C.Declaration) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> (C.Declaration) +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: ([Name]) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> ([Name]) +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: (Name) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> (Name) +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: ([Name]) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> ([Name]) +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: ([Name]) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> ([Name]) +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: (Pol) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> (Pol) +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: (A.Measure C.Expr) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> (A.Measure C.Expr) +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: ([C.Expr]) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> ([C.Expr]) +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: (A.Bound C.Expr) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> (A.Bound C.Expr) +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: ([Name]) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> ([Name]) +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: (C.Telescope) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> (C.Telescope) +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: (C.TBind) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> (C.TBind) +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: (C.TBind) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> (C.TBind) +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: (C.TBind) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> (C.TBind) +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: (C.LBind) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> (C.LBind) +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: ((Dec, C.Name)) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> ((Dec, C.Name)) +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (C.LetDef) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> (C.LetDef) +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: (C.LBind) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> (C.LBind) +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: (C.Telescope) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> (C.Telescope) +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: (C.Expr) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> (C.Expr) +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: ([C.Expr]) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> ([C.Expr]) +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: (C.Expr) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> (C.Expr) +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: (C.Expr) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> (C.Expr) +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: (C.TBind) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> (C.TBind) +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: (C.Expr) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> (C.Expr) +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: ([C.Expr]) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> ([C.Expr]) +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: (C.Expr) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> (C.Expr) +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: (C.QName) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> (C.QName) +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: ([([Name],C.Expr)]) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> ([([Name],C.Expr)]) +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: (([Name],C.Expr)) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> (([Name],C.Expr)) +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: (C.TypeSig) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> (C.TypeSig) +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: (C.Constructor) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> (C.Constructor) +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: ([C.Constructor ]) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> ([C.Constructor ]) +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: ([C.Clause]) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> ([C.Clause]) +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyIn55 :: (C.Clause) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> (C.Clause) +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +happyIn56 :: ([C.Pattern]) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> ([C.Pattern]) +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +happyIn57 :: ([C.Pattern]) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> ([C.Pattern]) +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +happyIn58 :: (C.Pattern) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> (C.Pattern) +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyIn59 :: (C.Pattern) -> (HappyAbsSyn ) +happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> (C.Pattern) +happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut59 #-} +happyIn60 :: (C.Pattern) -> (HappyAbsSyn ) +happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn ) -> (C.Pattern) +happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut60 #-} +happyIn61 :: (C.Pattern) -> (HappyAbsSyn ) +happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn ) -> (C.Pattern) +happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut61 #-} +happyIn62 :: (C.Pattern) -> (HappyAbsSyn ) +happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn ) -> (C.Pattern) +happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut62 #-} +happyIn63 :: ([C.Clause]) -> (HappyAbsSyn ) +happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn ) -> ([C.Clause]) +happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut63 #-} +happyIn64 :: ([C.Clause ]) -> (HappyAbsSyn ) +happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn ) -> ([C.Clause ]) +happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut64 #-} +happyIn65 :: (C.TBind) -> (HappyAbsSyn ) +happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn ) -> (C.TBind) +happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut65 #-} +happyIn66 :: (C.Telescope) -> (HappyAbsSyn ) +happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn ) -> (C.Telescope) +happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut66 #-} +happyInTok :: (T.Token) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (T.Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x00\x00\x00\x00\xfe\x01\x55\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x03\x00\x00\x7f\x03\x7f\x03\x7f\x03\xfa\x01\x5e\x03\x7d\x03\x7d\x03\x7d\x03\x00\x00\x3c\x03\x2a\x03\x18\x03\x06\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x03\x49\x03\x00\x00\x4a\x03\x52\x03\x46\x03\x00\x00\x65\x03\x65\x03\x00\x00\xfe\x08\x00\x00\xfe\x08\x00\x00\xbe\x01\x00\x00\x00\x00\x65\x03\xf7\x08\x65\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x03\xfe\x08\x20\x01\x58\x03\x03\x00\x55\x00\x00\x00\x00\x00\xf4\x02\x58\x03\x58\x03\xc1\x00\xc1\x01\x00\x00\xe2\x02\xd0\x02\xbe\x02\xac\x02\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x44\x03\x00\x00\x00\x00\x00\x00\x32\x03\x2d\x00\x30\x00\x00\x00\x00\x00\x33\x03\x00\x00\x00\x00\xc1\x01\x00\x00\xc1\x00\x8a\x00\xb4\x01\x00\x00\x00\x00\x0f\x01\xcf\x08\x21\x03\x00\x00\xe3\x08\x00\x00\x00\x00\x2b\x03\x00\x00\x29\x03\x1e\x03\xee\x01\x87\x01\x00\x00\x1f\x03\xc1\x00\x6b\x00\xe1\x01\xe1\x01\xe1\x01\x4b\x03\xc1\x00\xc1\x00\xc1\x00\x4b\x03\x00\x00\x00\x00\x28\x03\x20\x03\x22\x03\x00\x00\x39\x03\xc1\x00\x10\x03\x0d\x03\x31\x03\xfe\x02\x25\x03\xc1\x00\x00\x00\x25\x03\x01\x03\xfb\x02\xf7\x08\xeb\x02\xf7\x08\x13\x03\xc1\x00\x00\x00\xa7\x00\xe9\x02\x00\x00\xe6\x02\x99\x01\xd9\x02\x00\x00\xd4\x02\xc1\x00\x00\x00\xc1\x00\x00\x00\xd7\x02\xdb\x02\xf7\x08\x00\x00\x52\x01\xc1\x00\xc7\x02\xc1\x00\xef\x02\xce\x02\xc8\x02\x00\x00\xde\x02\x00\x00\xb0\x02\x24\x00\xb1\x02\x00\x00\xce\x01\xb2\x02\xa3\x02\x7d\x02\xa8\x02\x5b\x00\xa1\x02\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x50\x00\xb6\x02\xbb\x02\x91\x02\x00\x00\x66\x01\x00\x00\x00\x00\xb9\x02\xc1\x00\xc1\x00\xc1\x00\xe8\x00\xc1\x00\x92\x02\x92\x02\x57\x01\x59\x00\x00\x00\x00\x00\x00\x00\x7f\x02\xc1\x00\xc1\x00\x01\x00\x00\x00\x00\x00\x8c\x02\x83\x02\x8a\x00\x00\x00\xb4\x01\x7e\x02\x5c\x00\x00\x00\x00\x00\xa5\x02\x00\x00\x00\x00\x30\x00\x36\x01\x00\x00\x8e\x01\x8e\x01\xa5\x02\xe1\x01\x00\x00\x00\x00\x00\x00\x00\x00\x76\x02\x80\x02\x61\x02\xc1\x00\x00\x02\x00\x00\x45\x00\x79\x02\x6b\x02\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x02\xe5\xff\xc1\x00\x7a\x02\xc1\x00\xc1\x00\xc1\x00\x51\x02\xc1\x00\xc1\x00\x00\x00\x00\x00\xc1\x00\xc1\x00\x00\x00\x8e\x01\xc1\x00\x00\x00\x72\x02\x78\x02\x00\x00\x4f\x02\xc1\x00\x44\x02\x6c\x02\x66\x02\x3c\x02\x64\x02\xc1\x00\xf2\xff\x31\x02\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x3a\x02\x34\x02\x29\x02\x00\x00\x2a\x02\x00\x00\xc1\x00\xc1\x00\xc1\x00\x27\x02\x42\x01\xc1\x00\x00\x00\x00\x00\x3e\x02\x00\x00\x1a\x02\x00\x00\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x02\x0c\x02\x11\x02\x10\x02\x08\x02\x02\x02\x00\x00\xc1\x00\x30\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x09\x02\x1f\x02\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xc2\x01\xfc\x01\xf3\x01\xf1\x01\xf4\x01\x74\x00\xf0\x01\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x00\x00\x00\x00\x00\x00\x06\x02\x00\x00\xe7\x01\xd3\x01\xd1\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x9a\x01\x30\x00\xc1\x00\x00\x00\xbb\x01\xb0\x01\x6a\x01\x93\x01\x00\x00\xc1\x00\x92\x01\xc1\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x65\x01\xb3\x01\x81\x09\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\x62\x01\x1c\x01\x0f\x00\x00\x00\x00\x00\xa0\x00\x99\x00\xe0\x01\x00\x00\x71\x09\x61\x09\x51\x09\x41\x09\x00\x00\xaf\x01\x00\x00\xaa\x01\x00\x00\x97\x01\x00\x00\x86\x01\xcb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x01\x12\x01\x0e\x01\x00\x00\x79\x00\x00\x00\x6a\x00\x00\x00\x07\x02\x00\x00\x00\x00\x34\x01\x86\x09\x2a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\xa8\x01\x82\x01\x00\x00\x00\x00\x00\x00\x31\x09\x97\x00\x41\x00\x8d\x08\x60\x02\x00\x00\x31\x09\x31\x09\x31\x09\x31\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\xff\x00\x00\x97\x04\x46\x02\x83\x01\x00\x00\x00\x00\xc1\x08\x7d\x09\x00\x00\x00\x00\xc5\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x01\x00\x00\x00\x00\x7d\x04\x0e\x02\x67\x01\x4d\x01\x28\x01\x71\x01\x19\x05\x79\x03\xff\x04\x43\x01\x9d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x73\x08\x00\x00\x00\x00\x1e\x01\x00\x00\xcb\x00\x59\x08\x00\x00\x0d\x01\x00\x00\x00\x00\xab\x08\x13\x01\x77\x02\xcc\x00\x63\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x08\x00\x00\x49\x04\x00\x00\x00\x00\x00\x00\x35\x02\x00\x00\x00\x00\x25\x08\x00\x00\x0b\x08\xb6\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x04\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\xda\x00\xd7\x00\x00\x00\x70\x01\x00\x00\x00\x00\x9f\x00\xf1\x07\xd7\x07\xbd\x07\xa7\x08\xa3\x07\xae\x00\xa8\x00\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x04\x5f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x35\x01\x00\x00\x00\x00\xb9\x00\x4b\x02\x00\x00\x75\x02\x9e\x01\x85\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x04\x80\x00\x6f\x07\x55\x07\x3b\x07\x00\x00\x21\x07\x07\x07\x00\x00\x00\x00\xcb\x04\xfb\x03\x00\x00\x65\x02\xe1\x03\x00\x00\x77\x00\x04\x00\x00\x00\x00\x00\xed\x06\x00\x00\x69\x00\xfb\xff\x00\x00\xf0\xff\xd3\x06\x00\x00\x00\x00\x00\x00\xc7\x03\xb9\x06\xb1\x04\x9f\x06\x85\x06\x6b\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x06\x37\x06\x1d\x06\x00\x00\x00\x00\x03\x06\x00\x00\x00\x00\x08\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\xe9\x05\xc4\x00\x00\x00\xcf\x05\xb5\x05\x9b\x05\x81\x05\x00\x00\x31\x01\x00\x00\xad\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x35\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\x9b\x00\x93\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x05\x00\x00\x33\x05\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfd\xff\x00\x00\xdb\xff\x00\x00\xfc\xff\xfb\xff\xf9\xff\xfa\xff\xf8\xff\xf7\xff\xf6\xff\xf5\xff\xf4\xff\xf3\xff\x00\x00\xf2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\xdb\xff\xdb\xff\xdb\xff\xdb\xff\xf1\xff\xfd\xff\xeb\xff\xfd\xff\xed\xff\xfd\xff\xef\xff\xfd\xff\xd3\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\xfd\xff\x00\x00\x00\x00\xe5\xff\x44\xff\xe7\xff\x44\xff\xe9\xff\x00\x00\xdd\xff\xae\xff\x00\x00\xc3\xff\x00\x00\xcc\xff\xcf\xff\xce\xff\xcd\xff\xca\xff\xcb\xff\x00\x00\x44\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xe8\xff\xdb\xff\x49\xff\x49\xff\xc3\xff\x00\x00\xd2\xff\xdb\xff\xdb\xff\xdb\xff\xdb\xff\xf0\xff\xea\xff\xec\xff\xee\xff\x75\xff\x00\x00\x7d\xff\x53\xff\xd7\xff\x57\xff\x56\xff\x5c\xff\x76\xff\x78\xff\x00\x00\x80\xff\x7e\xff\x00\x00\x7f\xff\xc3\xff\xc3\xff\x00\x00\x7a\xff\x75\xff\x00\x00\x8b\xff\x9e\xff\x9d\xff\x8c\xff\xba\xff\xb9\xff\x00\x00\x70\xff\x95\xff\x00\x00\x91\xff\x89\xff\x84\xff\x78\xff\xc3\xff\x00\x00\x87\xff\x00\x00\x00\x00\x00\x00\xc3\xff\xc3\xff\xc3\xff\x00\x00\x61\xff\x4a\xff\x00\x00\x4d\xff\x00\x00\xde\xff\x00\x00\xc3\xff\xd1\xff\x00\x00\x00\x00\x00\x00\x6a\xff\xc3\xff\x43\xff\x00\x00\x00\x00\x00\x00\xc3\xff\xd9\xff\xc3\xff\x00\x00\xc3\xff\xac\xff\x75\xff\x00\x00\xc4\xff\x9b\xff\xd1\xff\x00\x00\xc2\xff\x00\x00\xc3\xff\xc1\xff\xc3\xff\xad\xff\x00\x00\x00\x00\xc3\xff\x6b\xff\x00\x00\xc3\xff\x00\x00\xc3\xff\x00\x00\x00\x00\x00\x00\xe0\xff\x4b\xff\xdf\xff\x63\xff\x62\xff\x00\x00\xc9\xff\x00\x00\x00\x00\x9c\xff\x75\xff\x00\x00\xd1\xff\x00\x00\x79\xff\xc3\xff\x88\xff\x86\xff\xab\xff\x00\x00\x00\x00\x00\x00\xd9\xff\x9c\xff\x00\x00\x83\xff\x81\xff\x00\x00\xc3\xff\xc3\xff\xc3\xff\x00\x00\xc3\xff\x00\x00\x00\x00\x00\x00\x8b\xff\x8a\xff\x8c\xff\xa1\xff\x91\xff\xc3\xff\xc3\xff\x4e\xff\x59\xff\x5a\xff\x84\xff\x00\x00\xc3\xff\x5e\xff\xcc\xff\x00\x00\x75\xff\x5b\xff\x5c\xff\x72\xff\x4f\xff\x51\xff\x00\x00\x00\x00\x50\xff\x00\x00\x00\x00\x00\x00\x00\x00\x54\xff\x55\xff\x58\xff\x52\xff\x00\x00\x00\x00\x73\xff\xc3\xff\x75\xff\x5d\xff\x75\xff\x00\x00\x00\x00\x8d\xff\xc3\xff\xc5\xff\xc6\xff\x99\xff\x90\xff\x91\xff\x94\xff\x92\xff\x93\xff\x82\xff\x85\xff\x00\x00\x00\x00\xc3\xff\x00\x00\xc3\xff\xc3\xff\xc3\xff\xa2\xff\xc3\xff\xc3\xff\x7b\xff\xc8\xff\xc3\xff\xc3\xff\x60\xff\x00\x00\xc3\xff\x4c\xff\xd6\xff\x00\x00\xd0\xff\x00\x00\xc3\xff\x00\x00\xd6\xff\x6c\xff\x6e\xff\x6a\xff\xc3\xff\x75\xff\x00\x00\xd8\xff\xc3\xff\xc3\xff\xc3\xff\xc3\xff\xc3\xff\xc3\xff\x00\x00\x00\x00\x00\x00\x9a\xff\x00\x00\xdc\xff\xc3\xff\xc3\xff\xc3\xff\x00\x00\x00\x00\xc3\xff\x6d\xff\xe3\xff\x00\x00\x47\xff\x00\x00\x48\xff\x00\x00\xe1\xff\x64\xff\x5f\xff\x98\xff\xc7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\xff\xc3\xff\x65\xff\x8e\xff\xc3\xff\xc3\xff\xc3\xff\xc3\xff\x00\x00\x72\xff\x77\xff\xc3\xff\x71\xff\x74\xff\x7c\xff\x84\xff\x00\x00\x00\x00\x00\x00\x00\x00\x66\xff\x00\x00\xc3\xff\xb5\xff\xb4\xff\xb3\xff\xb7\xff\xb6\xff\xd6\xff\x45\xff\xd5\xff\x6f\xff\xd6\xff\x46\xff\x00\x00\x00\x00\x00\x00\xb8\xff\xc0\xff\xbf\xff\xbe\xff\xbd\xff\xbc\xff\xbb\xff\xe4\xff\xe2\xff\x00\x00\x00\x00\x65\xff\xc3\xff\x96\xff\xbd\xff\xbc\xff\xbb\xff\x68\xff\x67\xff\xc3\xff\x00\x00\xc3\xff\xaa\xff\x65\xff\x69\xff\xa9\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x13\x00\x01\x00\x13\x00\x01\x00\x04\x00\x05\x00\x06\x00\x07\x00\x24\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x13\x00\x2a\x00\x0f\x00\x1f\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x13\x00\x09\x00\x2b\x00\x2c\x00\x13\x00\x1b\x00\x15\x00\x1d\x00\x2d\x00\x30\x00\x31\x00\x13\x00\x22\x00\x36\x00\x01\x00\x25\x00\x26\x00\x3a\x00\x28\x00\x29\x00\x30\x00\x2b\x00\x2c\x00\x01\x00\x2e\x00\x13\x00\x01\x00\x01\x00\x30\x00\x30\x00\x04\x00\x05\x00\x06\x00\x07\x00\x38\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x13\x00\x1b\x00\x0f\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x12\x00\x1b\x00\x25\x00\x1d\x00\x1b\x00\x1b\x00\x30\x00\x1d\x00\x2b\x00\x1f\x00\x01\x00\x25\x00\x22\x00\x13\x00\x25\x00\x25\x00\x26\x00\x2b\x00\x28\x00\x29\x00\x2b\x00\x2b\x00\x01\x00\x33\x00\x2e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x1f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x38\x00\x16\x00\x0f\x00\x01\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x2d\x00\x12\x00\x33\x00\x25\x00\x21\x00\x1b\x00\x1f\x00\x1d\x00\x1f\x00\x12\x00\x3b\x00\x3c\x00\x22\x00\x2a\x00\x16\x00\x25\x00\x26\x00\x28\x00\x28\x00\x29\x00\x2d\x00\x2b\x00\x2d\x00\x12\x00\x2e\x00\x01\x00\x02\x00\x03\x00\x23\x00\x16\x00\x06\x00\x3d\x00\x3e\x00\x13\x00\x38\x00\x13\x00\x2b\x00\x0d\x00\x13\x00\x0f\x00\x2f\x00\x30\x00\x31\x00\x29\x00\x33\x00\x34\x00\x2c\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x3d\x00\x3e\x00\x1f\x00\x13\x00\x21\x00\x13\x00\x23\x00\x13\x00\x25\x00\x26\x00\x27\x00\x13\x00\x13\x00\x32\x00\x2b\x00\x3d\x00\x3e\x00\x36\x00\x2f\x00\x30\x00\x31\x00\x3a\x00\x33\x00\x34\x00\x17\x00\x36\x00\x37\x00\x01\x00\x02\x00\x03\x00\x17\x00\x1f\x00\x06\x00\x2f\x00\x13\x00\x33\x00\x15\x00\x13\x00\x32\x00\x0d\x00\x2f\x00\x0f\x00\x36\x00\x3b\x00\x3c\x00\x2d\x00\x3a\x00\x13\x00\x13\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x13\x00\x1f\x00\x15\x00\x21\x00\x13\x00\x23\x00\x13\x00\x25\x00\x10\x00\x27\x00\x01\x00\x02\x00\x03\x00\x2b\x00\x13\x00\x06\x00\x36\x00\x2f\x00\x30\x00\x31\x00\x3a\x00\x33\x00\x34\x00\x32\x00\x36\x00\x37\x00\x36\x00\x36\x00\x30\x00\x31\x00\x3a\x00\x3a\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x36\x00\x1f\x00\x36\x00\x21\x00\x3a\x00\x23\x00\x3a\x00\x25\x00\x13\x00\x27\x00\x01\x00\x02\x00\x03\x00\x2b\x00\x13\x00\x06\x00\x08\x00\x2f\x00\x30\x00\x31\x00\x08\x00\x33\x00\x34\x00\x2b\x00\x2c\x00\x37\x00\x13\x00\x13\x00\x15\x00\x10\x00\x08\x00\x13\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x2b\x00\x2c\x00\x1f\x00\x13\x00\x21\x00\x13\x00\x23\x00\x15\x00\x25\x00\x13\x00\x27\x00\x01\x00\x02\x00\x03\x00\x2b\x00\x13\x00\x06\x00\x13\x00\x2f\x00\x30\x00\x31\x00\x21\x00\x33\x00\x34\x00\x13\x00\x14\x00\x37\x00\x13\x00\x13\x00\x14\x00\x2a\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x2b\x00\x2c\x00\x1f\x00\x13\x00\x14\x00\x01\x00\x02\x00\x03\x00\x25\x00\x26\x00\x06\x00\x2d\x00\x2e\x00\x13\x00\x2b\x00\x2d\x00\x2e\x00\x22\x00\x00\x00\x01\x00\x01\x00\x02\x00\x03\x00\x08\x00\x29\x00\x06\x00\x37\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x22\x00\x13\x00\x1f\x00\x01\x00\x2b\x00\x2c\x00\x13\x00\x29\x00\x25\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x13\x00\x1f\x00\x15\x00\x01\x00\x01\x00\x02\x00\x03\x00\x25\x00\x13\x00\x06\x00\x37\x00\x01\x00\x02\x00\x03\x00\x2b\x00\x2c\x00\x06\x00\x13\x00\x13\x00\x15\x00\x01\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x37\x00\x17\x00\x35\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x2b\x00\x2c\x00\x1f\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x01\x00\x25\x00\x1f\x00\x2b\x00\x2c\x00\x01\x00\x13\x00\x2b\x00\x25\x00\x01\x00\x01\x00\x02\x00\x03\x00\x1f\x00\x2b\x00\x06\x00\x13\x00\x29\x00\x15\x00\x37\x00\x01\x00\x2e\x00\x28\x00\x01\x00\x02\x00\x03\x00\x37\x00\x2d\x00\x06\x00\x2e\x00\x2b\x00\x2c\x00\x17\x00\x26\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x34\x00\x35\x00\x1f\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x25\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x13\x00\x14\x00\x1f\x00\x23\x00\x01\x00\x02\x00\x03\x00\x35\x00\x25\x00\x06\x00\x26\x00\x2b\x00\x28\x00\x37\x00\x2b\x00\x2f\x00\x30\x00\x31\x00\x35\x00\x33\x00\x34\x00\x13\x00\x14\x00\x27\x00\x28\x00\x26\x00\x37\x00\x26\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x04\x00\x05\x00\x1f\x00\x01\x00\x04\x00\x05\x00\x06\x00\x07\x00\x25\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x1d\x00\x1e\x00\x26\x00\x08\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x24\x00\x0e\x00\x22\x00\x26\x00\x37\x00\x26\x00\x13\x00\x1b\x00\x0e\x00\x16\x00\x30\x00\x1f\x00\x01\x00\x13\x00\x26\x00\x35\x00\x16\x00\x25\x00\x26\x00\x20\x00\x28\x00\x20\x00\x22\x00\x2b\x00\x2a\x00\x2d\x00\x20\x00\x21\x00\x24\x00\x13\x00\x22\x00\x22\x00\x16\x00\x17\x00\x38\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x24\x00\x22\x00\x01\x00\x26\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x16\x00\x17\x00\x26\x00\x24\x00\x26\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x13\x00\x26\x00\x2a\x00\x16\x00\x17\x00\x13\x00\x19\x00\x26\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x01\x00\x2a\x00\x01\x00\x24\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\x08\x00\x26\x00\x2b\x00\x2c\x00\x13\x00\x01\x00\x08\x00\x01\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x35\x00\x35\x00\x13\x00\x21\x00\x29\x00\x2b\x00\x2c\x00\x16\x00\x17\x00\x24\x00\x2b\x00\x2c\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x36\x00\x1f\x00\x38\x00\x39\x00\x3a\x00\x2b\x00\x2c\x00\x22\x00\x2a\x00\x2e\x00\x28\x00\x01\x00\x2a\x00\x2a\x00\x26\x00\x2d\x00\x36\x00\x20\x00\x38\x00\x39\x00\x3a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x35\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x27\x00\x01\x00\x2a\x00\x01\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x10\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x2a\x00\x24\x00\x2a\x00\x22\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x26\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x2c\x00\x2e\x00\x01\x00\x22\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x22\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x21\x00\x01\x00\x2a\x00\x22\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x21\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x2a\x00\x2e\x00\x2a\x00\x22\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x28\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x2a\x00\x01\x00\x2a\x00\x22\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x25\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x24\x00\x01\x00\x21\x00\x2a\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x01\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x2a\x00\x28\x00\x21\x00\x01\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x06\x00\x07\x00\x22\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x29\x00\x22\x00\x21\x00\x01\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x33\x00\x35\x00\x21\x00\x2c\x00\x35\x00\x2c\x00\x13\x00\x01\x00\x28\x00\x16\x00\x17\x00\x21\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x20\x00\x25\x00\x01\x00\x21\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\x21\x00\x2a\x00\x16\x00\x17\x00\x2e\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x01\x00\x21\x00\x01\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\x38\x00\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\x16\x00\x17\x00\x1c\x00\x1d\x00\x1e\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x13\x00\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\x19\x00\x16\x00\x17\x00\x1c\x00\x1d\x00\x1e\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x1f\x00\xff\xff\x21\x00\xff\xff\x23\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\xff\xff\x33\x00\x34\x00\x21\x00\xff\xff\x23\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\xff\xff\x33\x00\x34\x00\x21\x00\xff\xff\x23\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\xff\xff\x23\x00\x2b\x00\x25\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x2b\x00\x33\x00\x34\x00\xff\xff\x2f\x00\x30\x00\x31\x00\xff\xff\x33\x00\x34\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0f\x00\xff\xff\x11\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0f\x00\xff\xff\x11\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0f\x00\xff\xff\x11\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0f\x00\xff\xff\x11\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0f\x00\xff\xff\x11\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0f\x00\xff\xff\x11\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\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"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\xe5\x00\x4e\xff\xa8\x00\x28\x00\x4e\xff\x4e\xff\x4e\xff\x4e\xff\xa6\x00\x4e\xff\x4e\xff\x4e\xff\x4e\xff\xa8\x00\x51\x01\x4e\xff\x39\x01\x4e\xff\x4e\xff\x4e\xff\x4e\xff\x4e\xff\xa8\x00\x2e\x00\xbf\x00\x57\x00\x8a\x00\x4e\xff\x6d\x01\x4e\xff\x3a\x01\xa9\x00\x3b\x01\x2f\x00\x4e\xff\xe6\x00\x28\x00\x4e\xff\x4e\xff\xe7\x00\x4e\xff\x4e\xff\x3d\x01\x4e\xff\x4e\xff\x28\x00\x4e\xff\xa8\x00\x28\x00\x4f\xff\x8d\x00\x43\x01\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x4e\xff\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x82\x00\xec\x00\x4f\xff\x1b\x01\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x7b\x01\xec\x00\xed\x00\xef\x00\xec\x00\x4f\xff\xb0\x00\x4f\xff\x67\x00\xf2\x00\x28\x00\xed\x00\x4f\xff\x82\x00\xed\x00\x4f\xff\x4f\xff\x67\x00\x4f\xff\x4f\xff\x67\x00\x4f\xff\x4f\xff\x1c\x01\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x55\x01\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x3f\x00\x4f\xff\x28\x00\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x4f\xff\x56\x01\x7c\x01\x83\x00\x0f\x01\x89\x00\x4f\xff\xd3\x00\x4f\xff\x11\x01\x3e\x01\x84\x00\x85\x00\x4f\xff\x8a\x00\x3f\x00\x4f\xff\x4f\xff\xaf\x00\x4f\xff\x4f\xff\xd4\x00\x4f\xff\x12\x01\x44\x01\x4f\xff\x28\x00\x5e\x00\x78\x00\xc7\x00\x3f\x00\x60\x00\x40\x00\x90\x00\x4e\x01\x4f\xff\xe9\x00\x3a\x00\x79\x00\xf3\x00\x7a\x00\x3b\x00\x3c\x00\x3d\x00\x80\x01\x3e\x00\x3f\x00\x81\x01\x7b\x00\x7c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x40\x00\x41\x00\x65\x00\x82\x00\x7e\x00\x28\x00\x7f\x00\xe9\x00\xe2\x00\xe3\x00\x81\x00\x09\x01\x28\x00\x8c\x01\xe4\x00\x40\x00\x44\x00\x63\x01\x3b\x00\x3c\x00\x3d\x00\xe7\x00\x3e\x00\x3f\x00\x01\x01\x82\x00\x68\x00\x28\x00\x5e\x00\x78\x00\x02\x01\x30\x01\x60\x00\x29\x00\x8a\x00\x83\x00\x1f\x01\xe9\x00\x86\x01\x79\x00\x2a\x00\x7a\x00\x63\x01\x86\x00\x85\x00\x31\x01\xe7\x00\xe9\x00\xe9\x00\x7b\x00\x7c\x00\x61\x00\x62\x00\x7d\x00\x64\x00\xa8\x00\x9e\x00\x65\x00\x9f\x00\x7e\x00\xe9\x00\x7f\x00\xe9\x00\x80\x00\x0b\x01\x81\x00\x28\x00\x5e\x00\x78\x00\x3a\x00\x0c\x01\x60\x00\xe6\x00\x3b\x00\x3c\x00\x3d\x00\xe7\x00\x3e\x00\x3f\x00\x62\x01\x82\x00\x68\x00\x19\x01\x63\x01\xa9\x00\xaa\x00\xe7\x00\xe7\x00\x7b\x00\x7c\x00\x61\x00\x62\x00\x7d\x00\x64\x00\x68\x00\xea\x00\x65\x00\xed\x00\x7e\x00\xe7\x00\xdb\x00\xe7\x00\x80\x00\x99\x00\x81\x00\x28\x00\x5e\x00\x78\x00\x3a\x00\xdc\x00\x60\x00\x45\x00\x3b\x00\x3c\x00\x3d\x00\x46\x00\x3e\x00\x3f\x00\xf2\x00\x57\x00\x68\x00\x8a\x00\x31\x00\xa6\x00\xa1\x00\x30\x00\x31\x00\x7b\x00\x7c\x00\x61\x00\x62\x00\x7d\x00\x64\x00\xdd\x00\x57\x00\x65\x00\x31\x00\x7e\x00\x8a\x00\xdb\x00\xac\x00\xdc\x00\x68\x00\x81\x00\x28\x00\x5e\x00\x5f\x00\x3a\x00\x68\x00\x60\x00\x92\x00\x3b\x00\x3c\x00\x3d\x00\x8f\x00\x3e\x00\x3f\x00\x25\x00\xf6\x00\x68\x00\x99\x00\x25\x00\xf6\x00\x90\x00\xff\x00\x75\x00\x76\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\xbf\x00\x57\x00\x65\x00\x25\x00\xb6\x00\x28\x00\x5e\x00\x78\x00\x66\x00\xe3\x00\x60\x00\x5c\x01\xf8\x00\x68\x00\x67\x00\xf7\x00\xf8\x00\x70\x01\x03\x00\x02\x00\x28\x00\x5e\x00\x78\x00\x32\x00\x25\x01\x60\x00\x68\x00\x7b\x00\x7c\x00\x61\x00\x62\x00\x7d\x00\x64\x00\x24\x01\x31\x00\x65\x00\x47\x00\xc1\x00\x57\x00\x68\x00\x25\x01\x01\x01\x7b\x00\x7c\x00\x61\x00\x62\x00\x7d\x00\x64\x00\x68\x00\xbd\x00\x65\x00\xbe\x00\x4d\x00\x28\x00\x5e\x00\x5f\x00\xc1\x00\x68\x00\x60\x00\x68\x00\x28\x00\x5e\x00\x5f\x00\xc2\x00\x57\x00\x60\x00\x8a\x00\xdc\x00\x8b\x00\x4e\x00\x0a\x01\x75\x00\x76\x00\x57\x00\x68\x00\xcc\x00\xbb\xff\x61\x00\x62\x00\x7d\x00\x64\x00\xca\x00\x57\x00\x65\x00\x61\x00\x62\x00\x63\x00\x64\x00\x4f\x00\xc1\x00\x65\x00\xdd\x00\x57\x00\x50\x00\x55\x00\xcd\x00\x66\x00\x02\x00\x28\x00\x5e\x00\x5f\x00\x14\x01\x67\x00\x60\x00\x8a\x00\x8c\x01\x8d\x00\x68\x00\x28\x00\x8a\x01\xaf\x00\x28\x00\x5e\x00\x5f\x00\x68\x00\x15\x01\x60\x00\x88\x01\x56\x00\x57\x00\xdf\x00\x89\x01\x61\x00\x62\x00\x7d\x00\x64\x00\xb4\x00\xb5\x00\x65\x00\x58\x00\xf4\x00\x5a\x00\x5b\x00\x5c\x00\xc1\x00\x61\x00\x62\x00\x63\x00\x64\x00\x25\x00\x4c\x00\x65\x00\x39\x00\x28\x00\x5e\x00\x5f\x00\xbc\xff\x66\x00\x60\x00\x54\xff\x3a\x00\x54\xff\x68\x00\x67\x00\x3b\x00\x3c\x00\x3d\x00\xbd\xff\x3e\x00\x3f\x00\x25\x00\x26\x00\x17\x01\x18\x01\x79\x01\x68\x00\x7a\x01\x61\x00\x62\x00\x7d\x00\x64\x00\x2d\x00\x2e\x00\x65\x00\x4f\xff\x11\x00\x12\x00\x13\x00\x14\x00\xc1\x00\x15\x00\x16\x00\x17\x00\x18\x00\xce\x00\xcf\x00\x7b\x01\x40\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x7f\x01\x34\x00\x82\x01\x83\x01\x68\x00\x84\x01\x35\x00\x4f\xff\xc3\x00\x36\x00\xd0\x00\x57\x01\x28\x00\x35\x00\x85\x01\x8f\xff\xc4\x00\x4f\xff\x4f\xff\x37\x00\x4f\xff\x5e\x01\x67\x01\x4f\xff\x66\x01\x31\x01\x37\x00\xc5\x00\x6a\x01\xfa\x00\x68\x01\x69\x01\x69\x00\x6a\x00\xfe\xff\x6b\x00\x9b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x6b\x01\x6c\x01\x28\x00\x6d\x01\x70\x00\xb9\x00\xba\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\xdf\x00\x57\x00\x93\x00\x94\x00\x71\x01\x75\x01\x76\x01\x25\x01\x96\x00\x6e\x00\x6f\x00\x58\x00\xe0\x00\x5a\x00\x5b\x00\x5c\x00\x55\x00\x77\x01\x38\x01\x69\x00\x6a\x00\x55\x00\x6b\x00\x78\x01\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x28\x00\x3d\x01\x28\x00\x41\x01\x70\x00\xb9\x00\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\xdf\x00\x57\x00\x55\x00\x40\x01\x43\x01\x56\x00\x57\x00\x55\x00\x28\x00\x40\x01\x28\x00\x58\x00\xe0\x00\x5a\x00\x5b\x00\x5c\x00\x58\x00\xe0\x00\x5a\x00\x5b\x00\x5c\x00\x8e\xff\x8f\xff\x55\x00\x52\x01\x59\x01\x56\x00\x57\x00\x93\x00\x94\x00\x53\x01\x56\x00\x57\x00\xa0\x00\x96\x00\x6e\x00\x6f\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x58\x00\x14\x01\x46\x01\x5b\x00\x5c\x00\x56\x00\x57\x00\x5a\x01\x54\x01\x5b\x01\xaf\x00\x28\x00\xd1\xff\xfa\x00\xfc\x00\x15\x01\x58\x00\xf1\x00\xf5\x00\x5b\x00\x5c\x00\x11\x00\x12\x00\x13\x00\x14\x00\x8d\xff\x15\x00\x16\x00\x17\x00\x18\x00\x81\x00\x28\x00\xa3\x00\x28\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0e\x01\x15\x00\x16\x00\x17\x00\x18\x00\x10\x01\x13\x01\xc4\xff\x52\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x16\x01\x15\x00\x16\x00\x17\x00\x18\x00\x19\x01\x1c\x01\x28\x00\x53\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x1e\x01\x15\x00\x16\x00\x17\x00\x18\x00\x1f\x01\x28\x00\x22\x01\x54\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x27\x01\x15\x00\x16\x00\x17\x00\x18\x00\x28\x01\x2c\x01\x2d\x01\x55\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x2e\x01\x15\x00\x16\x00\x17\x00\x18\x00\x2f\x01\x28\x00\xa3\x00\x88\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\xa5\x00\x15\x00\x16\x00\x17\x00\x18\x00\xa6\x00\x28\x00\x1f\x00\xac\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x28\x00\x15\x00\x16\x00\x17\x00\x18\x00\xae\x00\xaf\x00\x21\x00\x28\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x11\x00\x12\x00\x13\x00\x14\x00\xb2\x00\x15\x00\x16\x00\x17\x00\x18\x00\xb3\x00\xb4\x00\x23\x00\x28\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xca\x00\xd1\x00\xe9\x00\xa3\xff\x8a\xff\xd2\x00\x28\x01\x28\x00\xf0\x00\x69\x00\x6a\x00\x25\x00\x6b\x00\x29\x01\x6c\x00\x6d\x00\x6e\x00\x6f\x00\xf1\x00\x92\x00\x28\x00\x49\x00\x70\x00\xb9\x00\xba\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\xfc\x00\x4a\x00\x4b\x00\x69\x00\x6a\x00\x4c\x00\x6b\x00\xfd\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x28\x00\x2c\x00\x28\x00\x34\x00\x70\x00\xb9\x00\xba\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x9a\x00\xff\xff\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x9b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\xb9\x00\xba\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x85\x01\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x5b\x01\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x36\x01\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x45\x01\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x47\x01\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x4f\x01\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\xb9\x00\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x28\x01\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x29\x01\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x9c\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x9a\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x9b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x9c\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\xc7\x00\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\xe4\x00\xc8\x00\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x34\x01\x9d\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x48\x01\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xb8\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\xbb\x00\x00\x00\x9f\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xfe\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\xb7\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xb8\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\xbb\x00\x00\x00\x9f\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xbc\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x8d\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x8a\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x7d\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x32\x01\x72\x00\x73\x00\x74\x00\x75\x00\x5e\x01\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x5f\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x60\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x61\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x64\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x6e\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x71\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x72\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x73\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x31\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x32\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x33\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x35\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x3a\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x41\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x49\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x4a\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x4b\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x4c\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x4d\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x57\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x03\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x06\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x07\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x08\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x20\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x22\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x2a\x01\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xa7\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xaf\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\x00\x00\xd6\x00\x93\x00\x94\x00\xd7\x00\x6e\x00\x6f\x00\xa3\x00\x96\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x73\x00\x05\x01\x75\x00\x76\x00\x57\x00\x68\x00\x00\x00\x00\x00\xd4\x00\xd5\x00\x00\x00\xd6\x00\x93\x00\x94\x00\xd7\x00\x6e\x00\x6f\x00\xa0\x00\x96\x00\x6e\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x73\x00\xd9\x00\x75\x00\x76\x00\x57\x00\xd3\x00\x00\x00\x7e\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x9f\xff\xd4\x00\x00\x00\x3b\x00\x3c\x00\x3d\x00\x00\x00\x3e\x00\x3f\x00\x7e\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x3a\x00\xa0\xff\x00\x00\x00\x00\x3b\x00\x3c\x00\x3d\x00\x00\x00\x3e\x00\x3f\x00\x7e\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x81\x00\x00\x00\x00\x00\x43\x00\x3a\x00\x44\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x3d\x00\x3a\x00\x3e\x00\x3f\x00\x00\x00\x3b\x00\x3c\x00\x3d\x00\x00\x00\x3e\x00\x3f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x1d\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x1f\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x21\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x23\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x93\x00\x94\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x96\x00\x6e\x00\x6f\x00\x93\x00\x94\x00\x00\x00\x00\x00\x00\x00\x95\x00\x96\x00\x6e\x00\x6f\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\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"# + +happyReduceArr = Happy_Data_Array.array (1, 188) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188) + ] + +happy_n_terms = 57 :: Int +happy_n_nonterms = 63 :: Int + +happyReduce_1 = happySpecReduce_1 0# happyReduction_1 +happyReduction_1 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn4 + (reverse happy_var_1 + )} + +happyReduce_2 = happySpecReduce_0 1# happyReduction_2 +happyReduction_2 = happyIn5 + ([] + ) + +happyReduce_3 = happySpecReduce_2 1# happyReduction_3 +happyReduction_3 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_4 = happySpecReduce_1 2# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_1 2# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_6 = happySpecReduce_1 2# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_7 = happySpecReduce_1 2# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_8 = happySpecReduce_1 2# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_9 = happySpecReduce_1 2# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_10 = happySpecReduce_1 2# happyReduction_10 +happyReduction_10 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_11 = happySpecReduce_1 2# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_12 = happySpecReduce_1 2# happyReduction_12 +happyReduction_12 happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_13 = happySpecReduce_1 2# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_14 = happySpecReduce_2 2# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn6 + (C.OverrideDecl Impredicative [happy_var_2] + )} + +happyReduce_15 = happyReduce 4# 2# happyReduction_15 +happyReduction_15 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn6 + (C.OverrideDecl Impredicative happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_16 = happySpecReduce_2 2# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn6 + (C.OverrideDecl Fail [happy_var_2] + )} + +happyReduce_17 = happyReduce 4# 2# happyReduction_17 +happyReduction_17 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn6 + (C.OverrideDecl Fail happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_18 = happySpecReduce_2 2# happyReduction_18 +happyReduction_18 happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn6 + (C.OverrideDecl Check [happy_var_2] + )} + +happyReduce_19 = happyReduce 4# 2# happyReduction_19 +happyReduction_19 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn6 + (C.OverrideDecl Check happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_20 = happySpecReduce_2 2# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn6 + (C.OverrideDecl TrustMe [happy_var_2] + )} + +happyReduce_21 = happyReduce 4# 2# happyReduction_21 +happyReduction_21 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn6 + (C.OverrideDecl TrustMe happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_22 = happySpecReduce_2 3# happyReduction_22 +happyReduction_22 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn7 + (let (n,tel,t,cs,fs) = happy_var_2 in C.DataDecl n A.NotSized A.Ind tel t cs fs + )} + +happyReduce_23 = happySpecReduce_3 4# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn8 + (let (n,tel,t,cs,fs) = happy_var_3 in C.DataDecl n A.Sized A.Ind tel t cs fs + )} + +happyReduce_24 = happySpecReduce_2 5# happyReduction_24 +happyReduction_24 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn9 + (let (n,tel,t,cs,fs) = happy_var_2 in C.DataDecl n A.NotSized A.CoInd tel t cs fs + )} + +happyReduce_25 = happySpecReduce_3 6# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn10 + (let (n,tel,t,cs,fs) = happy_var_3 in C.DataDecl n A.Sized A.CoInd tel t cs fs + )} + +happyReduce_26 = happySpecReduce_2 7# happyReduction_26 +happyReduction_26 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn11 + (let (n,tel,t,c,fs) = happy_var_2 in C.RecordDecl n tel t c fs + )} + +happyReduce_27 = happyReduce 8# 8# happyReduction_27 +happyReduction_27 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + case happyOut53 happy_x_6 of { happy_var_6 -> + case happyOut22 happy_x_8 of { happy_var_8 -> + happyIn12 + ((happy_var_1, happy_var_2, happy_var_4, reverse happy_var_6, happy_var_8) + ) `HappyStk` happyRest}}}}} + +happyReduce_28 = happyReduce 6# 8# happyReduction_28 +happyReduction_28 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_2 of { happy_var_2 -> + case happyOut53 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_6 of { happy_var_6 -> + happyIn12 + ((happy_var_1, happy_var_2, C.set0, reverse happy_var_4, happy_var_6) + ) `HappyStk` happyRest}}}} + +happyReduce_29 = happyReduce 8# 9# happyReduction_29 +happyReduction_29 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + case happyOut52 happy_x_6 of { happy_var_6 -> + case happyOut22 happy_x_8 of { happy_var_8 -> + happyIn13 + ((happy_var_1, happy_var_2, happy_var_4, happy_var_6, happy_var_8) + ) `HappyStk` happyRest}}}}} + +happyReduce_30 = happyReduce 6# 9# happyReduction_30 +happyReduction_30 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_2 of { happy_var_2 -> + case happyOut52 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_6 of { happy_var_6 -> + happyIn13 + ((happy_var_1, happy_var_2, C.set0, happy_var_4, happy_var_6) + ) `HappyStk` happyRest}}}} + +happyReduce_31 = happyReduce 5# 10# happyReduction_31 +happyReduction_31 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut51 happy_x_2 of { happy_var_2 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + happyIn14 + (C.FunDecl A.Ind happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_32 = happyReduce 5# 11# happyReduction_32 +happyReduction_32 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut51 happy_x_2 of { happy_var_2 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + happyIn15 + (C.FunDecl A.CoInd happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_33 = happyReduce 4# 12# happyReduction_33 +happyReduction_33 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn16 + (C.MutualDecl (reverse happy_var_3) + ) `HappyStk` happyRest} + +happyReduce_34 = happySpecReduce_3 13# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut18 happy_x_3 of { happy_var_3 -> + happyIn17 + (C.LetDecl happy_var_1 happy_var_3 + )}} + +happyReduce_35 = happyReduce 5# 14# happyReduction_35 +happyReduction_35 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_2 of { happy_var_2 -> + case happyOut20 happy_x_3 of { happy_var_3 -> + case happyOut40 happy_x_5 of { happy_var_5 -> + happyIn18 + (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 15# happyReduction_36 +happyReduction_36 = happyIn19 + (False + ) + +happyReduce_37 = happySpecReduce_1 15# happyReduction_37 +happyReduction_37 happy_x_1 + = happyIn19 + (True + ) + +happyReduce_38 = happySpecReduce_0 16# happyReduction_38 +happyReduction_38 = happyIn20 + (Nothing + ) + +happyReduce_39 = happySpecReduce_2 16# happyReduction_39 +happyReduction_39 happy_x_2 + happy_x_1 + = case happyOut42 happy_x_2 of { happy_var_2 -> + happyIn20 + (Just happy_var_2 + )} + +happyReduce_40 = happyReduce 4# 17# happyReduction_40 +happyReduction_40 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut24 happy_x_2 of { happy_var_2 -> + case happyOut59 happy_x_4 of { happy_var_4 -> + happyIn21 + (C.PatternDecl (head happy_var_2) (tail happy_var_2) happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_41 = happySpecReduce_0 18# happyReduction_41 +happyReduction_41 = happyIn22 + ([] + ) + +happyReduce_42 = happySpecReduce_2 18# happyReduction_42 +happyReduction_42 happy_x_2 + happy_x_1 + = case happyOut25 happy_x_2 of { happy_var_2 -> + happyIn22 + (happy_var_2 + )} + +happyReduce_43 = happySpecReduce_1 19# happyReduction_43 +happyReduction_43 happy_x_1 + = case happyOutTok happy_x_1 of { (T.Id happy_var_1 _) -> + happyIn23 + (C.Name happy_var_1 + )} + +happyReduce_44 = happySpecReduce_1 20# happyReduction_44 +happyReduction_44 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn24 + ([happy_var_1] + )} + +happyReduce_45 = happySpecReduce_2 20# happyReduction_45 +happyReduction_45 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn24 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_46 = happySpecReduce_1 21# happyReduction_46 +happyReduction_46 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn25 + ([happy_var_1] + )} + +happyReduce_47 = happySpecReduce_3 21# happyReduction_47 +happyReduction_47 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_3 of { happy_var_3 -> + happyIn25 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_48 = happySpecReduce_1 22# happyReduction_48 +happyReduction_48 happy_x_1 + = happyIn26 + (SPos + ) + +happyReduce_49 = happySpecReduce_1 22# happyReduction_49 +happyReduction_49 happy_x_1 + = happyIn26 + (Pos + ) + +happyReduce_50 = happySpecReduce_1 22# happyReduction_50 +happyReduction_50 happy_x_1 + = happyIn26 + (Neg + ) + +happyReduce_51 = happySpecReduce_1 22# happyReduction_51 +happyReduction_51 happy_x_1 + = happyIn26 + (Const + ) + +happyReduce_52 = happySpecReduce_1 22# happyReduction_52 +happyReduction_52 happy_x_1 + = happyIn26 + (Param + ) + +happyReduce_53 = happySpecReduce_1 22# happyReduction_53 +happyReduction_53 happy_x_1 + = happyIn26 + (Rec + ) + +happyReduce_54 = happySpecReduce_2 23# happyReduction_54 +happyReduction_54 happy_x_2 + happy_x_1 + = case happyOut28 happy_x_2 of { happy_var_2 -> + happyIn27 + (A.Measure happy_var_2 + )} + +happyReduce_55 = happySpecReduce_2 24# happyReduction_55 +happyReduction_55 happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn28 + ([happy_var_1] + )} + +happyReduce_56 = happySpecReduce_3 24# happyReduction_56 +happyReduction_56 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut28 happy_x_3 of { happy_var_3 -> + happyIn28 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_57 = happySpecReduce_3 25# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn29 + (A.Bound A.Lt happy_var_1 happy_var_3 + )}} + +happyReduce_58 = happySpecReduce_3 25# happyReduction_58 +happyReduction_58 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn29 + (A.Bound A.Le happy_var_1 happy_var_3 + )}} + +happyReduce_59 = happySpecReduce_1 26# happyReduction_59 +happyReduction_59 happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn30 + (let { f (C.Ident (C.QName x)) = x + ; f e = error ("not an identifier: " ++ C.prettyExpr e) + } in map f happy_var_1 + )} + +happyReduce_60 = happySpecReduce_0 27# happyReduction_60 +happyReduction_60 = happyIn31 + ([] + ) + +happyReduce_61 = happySpecReduce_2 27# happyReduction_61 +happyReduction_61 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_2 of { happy_var_2 -> + happyIn31 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_62 = happySpecReduce_2 27# happyReduction_62 +happyReduction_62 happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_2 of { happy_var_2 -> + happyIn31 + (C.TMeasure happy_var_1 : happy_var_2 + )}} + +happyReduce_63 = happyReduce 5# 28# happyReduction_63 +happyReduction_63 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut30 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn32 + (C.TBind (Dec Default) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_64 = happyReduce 5# 28# happyReduction_64 +happyReduction_64 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn32 + (C.TBounded A.defaultDec happy_var_2 A.Lt happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_65 = happyReduce 5# 28# happyReduction_65 +happyReduction_65 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn32 + (C.TBounded A.defaultDec happy_var_2 A.Le happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_66 = happyReduce 6# 28# happyReduction_66 +happyReduction_66 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + happyIn32 + (C.TBind (Dec happy_var_1) happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_67 = happyReduce 6# 28# happyReduction_67 +happyReduction_67 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + happyIn32 + (C.TBounded (Dec happy_var_1) happy_var_3 A.Lt happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_68 = happyReduce 6# 28# happyReduction_68 +happyReduction_68 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + happyIn32 + (C.TBounded (Dec happy_var_1) happy_var_3 A.Le happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_69 = happySpecReduce_1 28# happyReduction_69 +happyReduction_69 happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + happyIn32 + (happy_var_1 + )} + +happyReduce_70 = happySpecReduce_1 28# happyReduction_70 +happyReduction_70 happy_x_1 + = case happyOut34 happy_x_1 of { happy_var_1 -> + happyIn32 + (happy_var_1 + )} + +happyReduce_71 = happyReduce 5# 29# happyReduction_71 +happyReduction_71 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn33 + (C.TBind A.irrelevantDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_72 = happyReduce 5# 29# happyReduction_72 +happyReduction_72 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn33 + (C.TBounded A.irrelevantDec happy_var_2 A.Lt happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_73 = happyReduce 5# 29# happyReduction_73 +happyReduction_73 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn33 + (C.TBounded A.irrelevantDec happy_var_2 A.Le happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_74 = happyReduce 5# 30# happyReduction_74 +happyReduction_74 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn34 + (C.TBind A.Hidden happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_75 = happyReduce 5# 30# happyReduction_75 +happyReduction_75 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn34 + (C.TBounded A.Hidden happy_var_2 A.Lt happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_76 = happyReduce 5# 30# happyReduction_76 +happyReduction_76 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn34 + (C.TBounded A.Hidden happy_var_2 A.Le happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_77 = happySpecReduce_1 31# happyReduction_77 +happyReduction_77 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn35 + (C.TBind A.defaultDec [happy_var_1] Nothing + )} + +happyReduce_78 = happySpecReduce_3 31# happyReduction_78 +happyReduction_78 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn35 + (C.TBind A.irrelevantDec [happy_var_2] Nothing + )} + +happyReduce_79 = happySpecReduce_2 31# happyReduction_79 +happyReduction_79 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn35 + (C.TBind (Dec happy_var_1) [happy_var_2] Nothing + )}} + +happyReduce_80 = happyReduce 4# 31# happyReduction_80 +happyReduction_80 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn35 + (C.TBind (Dec happy_var_1) [happy_var_3] Nothing + ) `HappyStk` happyRest}} + +happyReduce_81 = happySpecReduce_1 32# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn36 + ((A.defaultDec , happy_var_1) + )} + +happyReduce_82 = happySpecReduce_3 32# happyReduction_82 +happyReduction_82 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn36 + ((A.irrelevantDec, happy_var_2) + )} + +happyReduce_83 = happySpecReduce_2 32# happyReduction_83 +happyReduction_83 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn36 + ((Dec happy_var_1 , happy_var_2) + )}} + +happyReduce_84 = happySpecReduce_1 33# happyReduction_84 +happyReduction_84 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn37 + (happy_var_1 + )} + +happyReduce_85 = happyReduce 7# 33# happyReduction_85 +happyReduction_85 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + case happyOut42 happy_x_7 of { happy_var_7 -> + happyIn37 + (C.LetDef A.irrelevantDec happy_var_2 [] (Just happy_var_4) happy_var_7 + ) `HappyStk` happyRest}}} + +happyReduce_86 = happyReduce 8# 33# happyReduction_86 +happyReduction_86 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + case happyOut42 happy_x_8 of { happy_var_8 -> + happyIn37 + (C.LetDef (Dec happy_var_1) happy_var_3 [] (Just happy_var_5) happy_var_8 + ) `HappyStk` happyRest}}}} + +happyReduce_87 = happySpecReduce_1 34# happyReduction_87 +happyReduction_87 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn38 + (happy_var_1 + )} + +happyReduce_88 = happySpecReduce_3 34# happyReduction_88 +happyReduction_88 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn38 + (C.TBind A.defaultDec [happy_var_1] (Just happy_var_3) + )}} + +happyReduce_89 = happyReduce 5# 34# happyReduction_89 +happyReduction_89 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn38 + (C.TBind A.defaultDec [happy_var_2] (Just happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_90 = happyReduce 5# 34# happyReduction_90 +happyReduction_90 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn38 + (C.TBind A.irrelevantDec [happy_var_2] (Just happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_91 = happyReduce 6# 34# happyReduction_91 +happyReduction_91 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + happyIn38 + (C.TBind (Dec happy_var_1) [happy_var_3] (Just happy_var_5) + ) `HappyStk` happyRest}}} + +happyReduce_92 = happySpecReduce_1 35# happyReduction_92 +happyReduction_92 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn39 + ([C.TBind (Dec Default) {- A.defaultDec -} [] happy_var_1] + )} + +happyReduce_93 = happySpecReduce_3 35# happyReduction_93 +happyReduction_93 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_2 of { happy_var_2 -> + happyIn39 + ([C.TBind A.irrelevantDec [] happy_var_2] + )} + +happyReduce_94 = happySpecReduce_2 35# happyReduction_94 +happyReduction_94 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_2 of { happy_var_2 -> + happyIn39 + ([C.TBind (Dec happy_var_1) [] happy_var_2] + )}} + +happyReduce_95 = happySpecReduce_1 35# happyReduction_95 +happyReduction_95 happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn39 + ([happy_var_1] + )} + +happyReduce_96 = happySpecReduce_1 35# happyReduction_96 +happyReduction_96 happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn39 + ([C.TMeasure happy_var_1] + )} + +happyReduce_97 = happySpecReduce_1 35# happyReduction_97 +happyReduction_97 happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn39 + ([C.TBound happy_var_1] + )} + +happyReduce_98 = happySpecReduce_1 35# happyReduction_98 +happyReduction_98 happy_x_1 + = case happyOut31 happy_x_1 of { happy_var_1 -> + happyIn39 + (happy_var_1 + )} + +happyReduce_99 = happySpecReduce_1 36# happyReduction_99 +happyReduction_99 happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn40 + (foldr1 C.Pair happy_var_1 + )} + +happyReduce_100 = happySpecReduce_1 37# happyReduction_100 +happyReduction_100 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn41 + ([happy_var_1] + )} + +happyReduce_101 = happySpecReduce_3 37# happyReduction_101 +happyReduction_101 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut41 happy_x_3 of { happy_var_3 -> + happyIn41 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_102 = happySpecReduce_3 38# happyReduction_102 +happyReduction_102 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn42 + (C.Quant A.Pi happy_var_1 happy_var_3 + )}} + +happyReduce_103 = happyReduce 4# 38# happyReduction_103 +happyReduction_103 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut24 happy_x_2 of { happy_var_2 -> + case happyOut40 happy_x_4 of { happy_var_4 -> + happyIn42 + (foldr C.Lam happy_var_4 happy_var_2 + ) `HappyStk` happyRest}} + +happyReduce_104 = happyReduce 4# 38# happyReduction_104 +happyReduction_104 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut40 happy_x_4 of { happy_var_4 -> + happyIn42 + (C.LLet happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_105 = happyReduce 6# 38# happyReduction_105 +happyReduction_105 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut40 happy_x_2 of { happy_var_2 -> + case happyOut20 happy_x_3 of { happy_var_3 -> + case happyOut54 happy_x_5 of { happy_var_5 -> + happyIn42 + (C.Case happy_var_2 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_106 = happySpecReduce_1 38# happyReduction_106 +happyReduction_106 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn42 + (happy_var_1 + )} + +happyReduce_107 = happySpecReduce_3 38# happyReduction_107 +happyReduction_107 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn42 + (C.Plus happy_var_1 happy_var_3 + )}} + +happyReduce_108 = happySpecReduce_3 38# happyReduction_108 +happyReduction_108 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn42 + (C.App happy_var_1 [happy_var_3] + )}} + +happyReduce_109 = happySpecReduce_3 38# happyReduction_109 +happyReduction_109 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn42 + (C.App happy_var_3 [happy_var_1] + )}} + +happyReduce_110 = happySpecReduce_1 39# happyReduction_110 +happyReduction_110 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn43 + (happy_var_1 + )} + +happyReduce_111 = happySpecReduce_3 39# happyReduction_111 +happyReduction_111 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_3 of { happy_var_3 -> + happyIn43 + (C.Quant A.Sigma [happy_var_1] happy_var_3 + )}} + +happyReduce_112 = happySpecReduce_1 40# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn44 + (C.TBind (Dec Default) {- A.defaultDec -} [] happy_var_1 + )} + +happyReduce_113 = happySpecReduce_3 40# happyReduction_113 +happyReduction_113 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_2 of { happy_var_2 -> + happyIn44 + (C.TBind A.irrelevantDec [] happy_var_2 + )} + +happyReduce_114 = happySpecReduce_2 40# happyReduction_114 +happyReduction_114 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut45 happy_x_2 of { happy_var_2 -> + happyIn44 + (C.TBind (Dec happy_var_1) [] happy_var_2 + )}} + +happyReduce_115 = happySpecReduce_1 40# happyReduction_115 +happyReduction_115 happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn44 + (happy_var_1 + )} + +happyReduce_116 = happySpecReduce_1 40# happyReduction_116 +happyReduction_116 happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn44 + (C.TMeasure happy_var_1 + )} + +happyReduce_117 = happySpecReduce_1 40# happyReduction_117 +happyReduction_117 happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn44 + (C.TBound happy_var_1 + )} + +happyReduce_118 = happySpecReduce_1 41# happyReduction_118 +happyReduction_118 happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn45 + (let (f : args) = reverse happy_var_1 in + if null args then f else C.App f args + )} + +happyReduce_119 = happySpecReduce_2 41# happyReduction_119 +happyReduction_119 happy_x_2 + happy_x_1 + = case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn45 + (C.CoSet happy_var_2 + )} + +happyReduce_120 = happySpecReduce_1 41# happyReduction_120 +happyReduction_120 happy_x_1 + = happyIn45 + (C.Set C.Zero + ) + +happyReduce_121 = happySpecReduce_2 41# happyReduction_121 +happyReduction_121 happy_x_2 + happy_x_1 + = case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn45 + (C.Set happy_var_2 + )} + +happyReduce_122 = happySpecReduce_3 41# happyReduction_122 +happyReduction_122 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (T.Number happy_var_1 _) -> + case happyOut45 happy_x_3 of { happy_var_3 -> + happyIn45 + (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) + )}} + +happyReduce_123 = happySpecReduce_1 42# happyReduction_123 +happyReduction_123 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn46 + ([happy_var_1] + )} + +happyReduce_124 = happySpecReduce_2 42# happyReduction_124 +happyReduction_124 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn46 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_125 = happySpecReduce_3 42# happyReduction_125 +happyReduction_125 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn46 + (C.Proj happy_var_3 : happy_var_1 + )}} + +happyReduce_126 = happySpecReduce_2 42# happyReduction_126 +happyReduction_126 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn46 + (C.Set C.Zero : happy_var_1 + )} + +happyReduce_127 = happySpecReduce_1 43# happyReduction_127 +happyReduction_127 happy_x_1 + = happyIn47 + (C.Size + ) + +happyReduce_128 = happySpecReduce_1 43# happyReduction_128 +happyReduction_128 happy_x_1 + = happyIn47 + (C.Max + ) + +happyReduce_129 = happySpecReduce_1 43# happyReduction_129 +happyReduction_129 happy_x_1 + = happyIn47 + (C.Infty + ) + +happyReduce_130 = happySpecReduce_1 43# happyReduction_130 +happyReduction_130 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn47 + (C.Ident happy_var_1 + )} + +happyReduce_131 = happyReduce 5# 43# happyReduction_131 +happyReduction_131 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut40 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn47 + (C.Sing happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_132 = happySpecReduce_3 43# happyReduction_132 +happyReduction_132 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_2 of { happy_var_2 -> + happyIn47 + (happy_var_2 + )} + +happyReduce_133 = happySpecReduce_1 43# happyReduction_133 +happyReduction_133 happy_x_1 + = happyIn47 + (C.Unknown + ) + +happyReduce_134 = happySpecReduce_2 43# happyReduction_134 +happyReduction_134 happy_x_2 + happy_x_1 + = case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn47 + (C.Succ happy_var_2 + )} + +happyReduce_135 = happySpecReduce_1 43# happyReduction_135 +happyReduction_135 happy_x_1 + = case happyOutTok happy_x_1 of { (T.Number happy_var_1 _) -> + happyIn47 + (iterate C.Succ C.Zero !! (read happy_var_1) + )} + +happyReduce_136 = happyReduce 4# 43# happyReduction_136 +happyReduction_136 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut49 happy_x_3 of { happy_var_3 -> + happyIn47 + (C.Record happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_137 = happySpecReduce_1 44# happyReduction_137 +happyReduction_137 happy_x_1 + = case happyOutTok happy_x_1 of { (T.QualId happy_var_1 _) -> + happyIn48 + (let (m,n) = happy_var_1 in C.Qual (C.Name m) (C.Name n) + )} + +happyReduce_138 = happySpecReduce_1 44# happyReduction_138 +happyReduction_138 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn48 + (C.QName happy_var_1 + )} + +happyReduce_139 = happySpecReduce_3 45# happyReduction_139 +happyReduction_139 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + happyIn49 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_140 = happySpecReduce_1 45# happyReduction_140 +happyReduction_140 happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn49 + ([happy_var_1] + )} + +happyReduce_141 = happySpecReduce_0 45# happyReduction_141 +happyReduction_141 = happyIn49 + ([] + ) + +happyReduce_142 = happySpecReduce_3 46# happyReduction_142 +happyReduction_142 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn50 + ((happy_var_1,happy_var_3) + )}} + +happyReduce_143 = happySpecReduce_3 47# happyReduction_143 +happyReduction_143 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn51 + (C.TypeSig happy_var_1 happy_var_3 + )}} + +happyReduce_144 = happyReduce 4# 48# happyReduction_144 +happyReduction_144 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn52 + (C.Constructor happy_var_1 happy_var_2 (Just happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_145 = happySpecReduce_2 48# happyReduction_145 +happyReduction_145 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_2 of { happy_var_2 -> + happyIn52 + (C.Constructor happy_var_1 happy_var_2 Nothing + )}} + +happyReduce_146 = happySpecReduce_3 49# happyReduction_146 +happyReduction_146 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut52 happy_x_3 of { happy_var_3 -> + happyIn53 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_147 = happySpecReduce_2 49# happyReduction_147 +happyReduction_147 happy_x_2 + happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn53 + (happy_var_1 + )} + +happyReduce_148 = happySpecReduce_1 49# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn53 + ([happy_var_1] + )} + +happyReduce_149 = happySpecReduce_0 49# happyReduction_149 +happyReduction_149 = happyIn53 + ([] + ) + +happyReduce_150 = happyReduce 5# 50# happyReduction_150 +happyReduction_150 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + case happyOut54 happy_x_5 of { happy_var_5 -> + happyIn54 + ((C.Clause Nothing [happy_var_1] (Just happy_var_3)) : happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_151 = happySpecReduce_3 50# happyReduction_151 +happyReduction_151 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn54 + ((C.Clause Nothing [happy_var_1] (Just happy_var_3)) : [] + )}} + +happyReduce_152 = happySpecReduce_3 50# happyReduction_152 +happyReduction_152 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn54 + ((C.Clause Nothing [happy_var_1] Nothing) : happy_var_3 + )}} + +happyReduce_153 = happySpecReduce_1 50# happyReduction_153 +happyReduction_153 happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + happyIn54 + ((C.Clause Nothing [happy_var_1] Nothing) : [] + )} + +happyReduce_154 = happySpecReduce_0 50# happyReduction_154 +happyReduction_154 = happyIn54 + ([] + ) + +happyReduce_155 = happyReduce 4# 51# happyReduction_155 +happyReduction_155 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + case happyOut40 happy_x_4 of { happy_var_4 -> + happyIn55 + (C.Clause (Just happy_var_1) happy_var_2 (Just happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_156 = happySpecReduce_2 51# happyReduction_156 +happyReduction_156 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn55 + (C.Clause (Just happy_var_1) happy_var_2 Nothing + )}} + +happyReduce_157 = happySpecReduce_1 52# happyReduction_157 +happyReduction_157 happy_x_1 + = case happyOut57 happy_x_1 of { happy_var_1 -> + happyIn56 + (reverse happy_var_1 + )} + +happyReduce_158 = happySpecReduce_0 53# happyReduction_158 +happyReduction_158 = happyIn57 + ([] + ) + +happyReduce_159 = happySpecReduce_2 53# happyReduction_159 +happyReduction_159 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + happyIn57 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_160 = happySpecReduce_3 53# happyReduction_160 +happyReduction_160 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_3 of { happy_var_3 -> + happyIn57 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_161 = happySpecReduce_2 54# happyReduction_161 +happyReduction_161 happy_x_2 + happy_x_1 + = happyIn58 + (C.AbsurdP + ) + +happyReduce_162 = happySpecReduce_3 54# happyReduction_162 +happyReduction_162 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut59 happy_x_2 of { happy_var_2 -> + happyIn58 + (happy_var_2 + )} + +happyReduce_163 = happySpecReduce_1 54# happyReduction_163 +happyReduction_163 happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn58 + (happy_var_1 + )} + +happyReduce_164 = happySpecReduce_2 54# happyReduction_164 +happyReduction_164 happy_x_2 + happy_x_1 + = case happyOut58 happy_x_2 of { happy_var_2 -> + happyIn58 + (C.SuccP happy_var_2 + )} + +happyReduce_165 = happySpecReduce_2 54# happyReduction_165 +happyReduction_165 happy_x_2 + happy_x_1 + = happyIn58 + (C.DotP (C.Set C.Zero) + ) + +happyReduce_166 = happySpecReduce_2 54# happyReduction_166 +happyReduction_166 happy_x_2 + happy_x_1 + = case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn58 + (C.DotP happy_var_2 + )} + +happyReduce_167 = happySpecReduce_3 55# happyReduction_167 +happyReduction_167 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut60 happy_x_1 of { happy_var_1 -> + case happyOut59 happy_x_3 of { happy_var_3 -> + happyIn59 + (C.PairP happy_var_1 happy_var_3 + )}} + +happyReduce_168 = happySpecReduce_1 55# happyReduction_168 +happyReduction_168 happy_x_1 + = case happyOut60 happy_x_1 of { happy_var_1 -> + happyIn59 + (happy_var_1 + )} + +happyReduce_169 = happySpecReduce_1 56# happyReduction_169 +happyReduction_169 happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + happyIn60 + (happy_var_1 + )} + +happyReduce_170 = happySpecReduce_3 56# happyReduction_170 +happyReduction_170 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn60 + (C.SizeP happy_var_1 happy_var_3 + )}} + +happyReduce_171 = happySpecReduce_3 56# happyReduction_171 +happyReduction_171 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn60 + (C.SizeP happy_var_3 happy_var_1 + )}} + +happyReduce_172 = happySpecReduce_1 56# happyReduction_172 +happyReduction_172 happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + happyIn60 + (happy_var_1 + )} + +happyReduce_173 = happySpecReduce_3 56# happyReduction_173 +happyReduction_173 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_3 of { happy_var_3 -> + happyIn60 + (patApp happy_var_1 [happy_var_3] + )}} + +happyReduce_174 = happySpecReduce_2 57# happyReduction_174 +happyReduction_174 happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + happyIn61 + (patApp happy_var_1 [happy_var_2] + )}} + +happyReduce_175 = happySpecReduce_2 57# happyReduction_175 +happyReduction_175 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + happyIn61 + (patApp happy_var_1 [happy_var_2] + )}} + +happyReduce_176 = happySpecReduce_1 58# happyReduction_176 +happyReduction_176 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn62 + (C.IdentP (C.QName happy_var_1) + )} + +happyReduce_177 = happySpecReduce_2 58# happyReduction_177 +happyReduction_177 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn62 + (C.ConP True (C.QName happy_var_2) [] + )} + +happyReduce_178 = happySpecReduce_1 59# happyReduction_178 +happyReduction_178 happy_x_1 + = case happyOut64 happy_x_1 of { happy_var_1 -> + happyIn63 + (reverse happy_var_1 + )} + +happyReduce_179 = happySpecReduce_3 60# happyReduction_179 +happyReduction_179 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut64 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn64 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_180 = happySpecReduce_2 60# happyReduction_180 +happyReduction_180 happy_x_2 + happy_x_1 + = case happyOut64 happy_x_1 of { happy_var_1 -> + happyIn64 + (happy_var_1 + )} + +happyReduce_181 = happySpecReduce_1 60# happyReduction_181 +happyReduction_181 happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn64 + ([happy_var_1] + )} + +happyReduce_182 = happySpecReduce_0 60# happyReduction_182 +happyReduction_182 = happyIn64 + ([] + ) + +happyReduce_183 = happyReduce 5# 61# happyReduction_183 +happyReduction_183 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn65 + (C.TBind (Dec Default) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_184 = happyReduce 5# 61# happyReduction_184 +happyReduction_184 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + happyIn65 + (C.TBind A.irrelevantDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_185 = happyReduce 6# 61# happyReduction_185 +happyReduction_185 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + happyIn65 + (C.TBind (Dec happy_var_1) happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_186 = happyReduce 6# 61# happyReduction_186 +happyReduction_186 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_5 of { happy_var_5 -> + happyIn65 + (C.TBind (Dec SPos) happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_187 = happySpecReduce_0 62# happyReduction_187 +happyReduction_187 = happyIn66 + ([] + ) + +happyReduce_188 = happySpecReduce_2 62# happyReduction_188 +happyReduction_188 happy_x_2 + happy_x_1 + = case happyOut65 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_2 of { happy_var_2 -> + happyIn66 + (happy_var_1 : happy_var_2 + )}} + +happyNewToken action sts stk [] = + happyDoAction 56# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + T.Id happy_dollar_dollar _ -> cont 1#; + T.QualId happy_dollar_dollar _ -> cont 2#; + T.Number happy_dollar_dollar _ -> cont 3#; + T.Data _ -> cont 4#; + T.CoData _ -> cont 5#; + T.Record _ -> cont 6#; + T.Sized _ -> cont 7#; + T.Fields _ -> cont 8#; + T.Mutual _ -> cont 9#; + T.Fun _ -> cont 10#; + T.CoFun _ -> cont 11#; + T.Pattern _ -> cont 12#; + T.Case _ -> cont 13#; + T.Def _ -> cont 14#; + T.Let _ -> cont 15#; + T.In _ -> cont 16#; + T.Eval _ -> cont 17#; + T.Fail _ -> cont 18#; + T.Check _ -> cont 19#; + T.TrustMe _ -> cont 20#; + T.Impredicative _ -> cont 21#; + T.Type _ -> cont 22#; + T.Set _ -> cont 23#; + T.CoSet _ -> cont 24#; + T.Size _ -> cont 25#; + T.Infty _ -> cont 26#; + T.Succ _ -> cont 27#; + T.Max _ -> cont 28#; + T.LTri _ -> cont 29#; + T.RTri _ -> cont 30#; + T.AngleOpen _ -> cont 31#; + T.AngleClose _ -> cont 32#; + T.BrOpen _ -> cont 33#; + T.BrClose _ -> cont 34#; + T.BracketOpen _ -> cont 35#; + T.BracketClose _ -> cont 36#; + T.PrOpen _ -> cont 37#; + T.PrClose _ -> cont 38#; + T.Bar _ -> cont 39#; + T.Comma _ -> cont 40#; + T.Sem _ -> cont 41#; + T.Col _ -> cont 42#; + T.Dot _ -> cont 43#; + T.Arrow _ -> cont 44#; + T.Leq _ -> cont 45#; + T.Eq _ -> cont 46#; + T.PlusPlus _ -> cont 47#; + T.Plus _ -> cont 48#; + T.Minus _ -> cont 49#; + T.Slash _ -> cont 50#; + T.Times _ -> cont 51#; + T.Hat _ -> cont 52#; + T.Amp _ -> cont 53#; + T.Lam _ -> cont 54#; + T.Underscore _ -> cont 55#; + _ -> happyError' (tk:tks) + } + +happyError_ 56# tk tks = happyError' tks +happyError_ _ tk tks = happyError' (tk:tks) + +newtype HappyIdentity a = HappyIdentity a +happyIdentity = HappyIdentity +happyRunIdentity (HappyIdentity a) = a + +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 0# tks) (\x -> happyReturn (happyOut4 x)) + +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 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 30 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 51 "templates/GenericTemplate.hs" #-} + +{-# LINE 61 "templates/GenericTemplate.hs" #-} + +{-# LINE 70 "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 0#, 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 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where (off) = indexShortOffAddr happyActOffsets st + (off_i) = (off Happy_GHC_Exts.+# i) + check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) + then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) + else False + (action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 130 "templates/GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 163 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + (off) = indexShortOffAddr happyGotoOffsets st1 + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where (off) = indexShortOffAddr happyGotoOffsets st + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (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 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- 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. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# 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. diff --git a/lib/base.ma b/lib/base.ma new file mode 100644 --- /dev/null +++ b/lib/base.ma @@ -0,0 +1,94 @@ +-- 2012-02-01 MiniAgda Library (not universe polymorphic) + +-- Leibniz equality (the only family) + +data Id [A : Set](a : A) : A -> Set +{ refl : Id A a a +} + +fun subst : [A : Set] -> [P : A -> Set] -> [a, b : A] -> Id A a b -> P a -> P b +{ subst A P a .a refl h = h +} + +fun cong : [A : Set] -> [B : A -> Set] -> [f : (x : A) -> B x] -> + [a, b : A] -> (p : Id A a b) -> + Id (B b) (subst A B a b p (f a)) (f b) +{ cong A B f a .a refl = refl +} + +-- Enumerations and sums + +data Empty {} +data Unit { unit } + +-- * Booleans + +data Bool { true; false } + +fun if : [A : Set] -> (b : Bool) -> (t, e : A) -> A +{ if A true t e = t +; if A false t e = e +} + +fun If : (b : Bool) -> ++(A, B : Set) -> Set +{ If true A B = A +; If false A B = B +} + +-- * Either: disjoint sum type + +let Either ++(A, B : Set) = (b : Bool) & If b B A +pattern left a = (false, a) +pattern right b = (true, b) + +fun either : [A, B : Set] -> [C : Either A B -> Set] -> + ((a : A) -> C (left a)) -> + ((b : B) -> C (right b)) -> + (x : Either A B) -> C x +{ either A B C l r (left a) = l a +; either A B C l r (right b) = r b +} + +fun EitherT : [A, B : Set] -> (A -> Set) -> (B -> Set) -> Either A B -> Set +{ EitherT A B l r (left a) = l a +; EitherT A B l r (right b) = r b +} + +let mapEither [A, B, A', B' : Set] (f : A -> A') (g : B -> B') + : Either A B -> Either A' B' + = either A B (\ x -> Either A' B') (\ a -> left (f a)) (\ b -> right (g b)) + +-- * Maybe: option type + +let Maybe ++(A : Set) = Either Unit A +pattern nothing = left unit +pattern just a = right a + +let maybe [A, B : Set] (n : B) (j : A -> B) : Maybe A -> B + = either Unit A (\ x -> B) (\ u -> n) j + +let mapMaybe [A, B : Set] (f : A -> B) : Maybe A -> Maybe B + = mapEither Unit A Unit B (\ u -> u) f + +-- * Trichonomy + +data Three { one; two; three } + +fun ThreeT : (t : Three) -> ++(A, B, C : Set) -> Set +{ ThreeT one A B C = A +; ThreeT two A B C = B +; ThreeT three A B C = C +} + +let Tri ++(A, B, C : Set) = (t : Three) & ThreeT t A B C +pattern first a = (one, a) +pattern second b = (two, b) +pattern third c = (three, c) + +-- * Recursion principle + +fun fix : [A : Size -> Set] -> + ([i : Size] -> ([j < i] -> A j) -> A i) -> + [i : Size] -> |i| -> A i +{ fix A f i = f i (fix A f) +} diff --git a/lib/bintree.ma b/lib/bintree.ma new file mode 100644 --- /dev/null +++ b/lib/bintree.ma @@ -0,0 +1,11 @@ +-- bintree.ma Binary trees + +cofun BinTree : ++(A : Set) -> +(i : Size) -> Set +{ BinTree A i = let ++T = [j < i] & BinTree A j + in Maybe (T & A & T) +} +pattern leaf = nothing +pattern node l a r = just (l, a, r) + + + diff --git a/lib/colist.ma b/lib/colist.ma new file mode 100644 --- /dev/null +++ b/lib/colist.ma @@ -0,0 +1,59 @@ +-- colist.ma -- MiniAgda colist library + +cofun CoList : ++(A : Set) -> -(i : Size) -> Set +{ CoList A i = Maybe (A & ([i' < i] -> CoList A i')) +} + +fun colist : [A : Set] -> [i : Size] -> |i| -> List A i -> CoList A i +{ colist A i nil = nil +; colist A i (cons a (i', as)) = cons a (\ i'' -> colist A (max i' i'') as) +} + +fun cotake : [A : Set] -> [i : Size] -> Nat i -> CoList A i -> List A i +{ cotake A i zero as = nil +; cotake A i n nil = nil +; cotake A i (suc (i', n)) (cons a l) = cons a (i', cotake A i' n (l i')) +} + +fun codrop : [A : Set ] -> + [i : Size] -> Nat i -> + [j : Size] -> CoList A (j+i) -> CoList A j +{ codrop A i zero j l = l +; codrop A i n j nil = nil +; codrop A i (suc (i', n)) j (cons a l) = codrop A i' n j (l (j+i')) +} + +-- direct encoding of tail +check +fun cotail : [A : Set] [i : Size] (l : CoList A $i) -> CoList A i +{ cotail A i nil = nil +; cotail A i (cons a l) = l i +} + +-- tail as instance of drop +let cotail [A : Set] : [i : Size] (l : CoList A $i) -> CoList A i + = codrop A $0 (suc (0, zero)) + +fun coappend : [A : Set] -> [i : Size] -> |i| -> + CoList A i -> CoList A i -> CoList A i +{ coappend A i nil bs = bs +; coappend A i (cons a l) bs = cons a (\ i' -> coappend A i' (l i') bs) +} + +-- list take + +let take [A : Set] [i : Size] (n : Nat i) (as : List A i) : List A i + = cotake A i n (colist A i as) + +{- + +fun cotail : [A : Set] -> [i : Size] -> CoList A $i -> CoList A i +{ cotail A i l = case l + { nil -> nil + ; (cons a as) -> cons a (\ j -> as $j + +mapMaybe (A & ([i' < $i] -> CoList A i')) + (A & ([i' < i] -> CoList A i')) + +} +-} diff --git a/lib/list.ma b/lib/list.ma new file mode 100644 --- /dev/null +++ b/lib/list.ma @@ -0,0 +1,94 @@ +-- list.ma -- MiniAgda list library + +cofun List : ++(A : Set) -> +(i : Size) -> Set +{ List A i = Maybe (A & [i' < i] & List A i') +} +pattern nil = nothing +pattern cons a l = just (a, l) + +let consL [A : Set] [i : Size] (a : A) (as : List A i) : List A $i + = cons a (i, as) + +-- foldr + +fun foldr : [A : Set] -> [B : Size -> Set] -> + ([i : Size] -> A -> [j < i] -> B j -> B i) -> + ([i : Size] -> B i) -> + [i : Size] -> List A i -> B i +{ foldr A B f b i nil = b i +; foldr A B f b i (cons a (j (A -> B) -> [i : Size] -> List A i -> List B i + = \ A B f -> foldr A (List B) + (\ i a j bs -> cons (f a) (j, bs)) + (\ i -> nil) + +fun mapList : [A, B : Set] -> (A -> B) -> [i : Size] -> List A i -> List B i +{ mapList A B f i nil = nil +; mapList A B f i (cons a (j, as)) = cons (f a) (j, mapList A B f j as) +} + +-- append + +check +let append : [A : Set] -> + [i : Size] -> List A i -> + [j : Size] -> List A j -> List A (i+j) + = \ A i as j bs -> + foldr A (\ i -> List A (i+j)) + (\ i b i' bs -> cons b (i'+j, bs)) + (\ i -> bs) + i + as + +fun append : [A : Set] -> + [i : Size] -> |i| -> List A i -> + [j : Size] -> List A j -> List A (i+j) +{ append A i nil j bs = bs +; append A i (cons a (i' Nat # -> + [j : Size] -> List A j -> List A j +{ drop A zero j l = l +; drop A n j nil = nil +; drop A n j (cons a (j' < j, as)) = drop A (pred # n) j' as +} + +-- take for lists is take for colists after embedding + +-- fold left + +check +fun foldl : [A, B : Set] -> (B -> A -> B) -> B -> + [i : Size] -> List A i -> B +{ foldl A B f acc i nil = acc +; foldl A B f acc i (cons a (j, as)) = foldl A B f (f acc a) j as +} + +-- fold left from fold right + +let foldl' : [A : Set] -> [B : Set] -> (B -> A -> B) -> + [i : Size] -> List A i -> B -> B + = \ A B f -> foldr A (\ i -> B -> B) + (\ i a j r acc -> r (f acc a)) + (\ i acc -> acc) + +let foldl : [A : Set] -> [B : Set] -> (B -> A -> B) -> B -> + [i : Size] -> List A i -> B + = \ A B f b i l -> foldl' A B f i l b + +-- reverse + +let revApp [A : Set] (as : List A #) (bs : List A #) : List A # + = foldl A (List A #) (\ as a -> consL A # a as) bs # as + +let reverse [A : Set] (as : List A #) : List A # + = revApp A as nil + diff --git a/lib/nat.ma b/lib/nat.ma new file mode 100644 --- /dev/null +++ b/lib/nat.ma @@ -0,0 +1,115 @@ +-- nat.ma + +-- Natural numbers + +cofun Nat : +Size -> Set +{ Nat i = Maybe ([j < i] & Nat j) +} +pattern zero = nothing +pattern suc n = just n + +let succ [i : Size] (n : Nat i) : Nat $i = suc (i, n) + +let oneN : Nat 1 = suc (0, zero) +let twoN : Nat 2 = suc (1, oneN) +let threeN : Nat 3 = suc (2, twoN) +let fourN : Nat 4 = suc (3, threeN) + +fun caseNat : [i : Size] -> |i| -> (n : Nat $i) -> + [C : Set] -> C -> ([i : Size] -> (m : Nat i) -> C) -> C +{ caseNat i zero C z s = z +; caseNat i (suc (i', n)) C z s = s i' n +} + +{- ERROR in TypeChecker! +fun caseNat : [i : Size] -> |i| -> (n : Nat $i) -> + [C : [j : Size] -> Nat j -> Set] -> + C 0 zero -> + ([i : Size] -> (m : Nat i) -> C i m) -> + C $i n +{ caseNat i zero C z s = z +; caseNat i (suc (i', n)) C z s = s i' n +} +-} + +fun iterNat : [A : Set](f : A -> A)(a : A)[i : Size](n : Nat i) -> A +{ iterNat A f a i zero = a +; iterNat A f a i (suc (i', n)) = iterNat A f (f a) i' n +} + +fun pred : [i : Size] -> (n : Nat $i) -> Nat i +{ pred i zero = zero +; pred i (suc (j, n)) = n +} + +fun plus : [i : Size] -> |i| -> (n : Nat i) -> + [j : Size] -> (m : Nat j) -> Nat (i+j) +{ plus i zero j m = m +; plus i (suc (i', n)) j m = suc (i'+j, plus i' n j m) +} + +fun times : [i : Size] -> |i| -> (n : Nat i) -> (m : Nat #) -> Nat # +{ times i zero m = zero +; times i (suc (i', n)) m = plus # m # (times i' n m) +} + +fun minus : [i : Size] -> (n : Nat i) -> + [j : Size] -> |j| -> (m : Nat j) -> Nat i +{ minus i zero j m = zero +; minus i n j zero = n +; minus i (suc (i', n)) j (suc (j', m)) = minus i' n j' m +} + +-- computes ceil(n/(m+1)) +fun div' : [i : Size] -> |i| -> (n : Nat i) -> (m : Nat #) -> Nat i +{ div' i zero m = zero +; div' i (suc (i', n)) m = suc (i', div' i' (minus i' n # m) m) +} + +-- computes floor(n/m) if m>0, and 0 otherwise +check -- Alternative definition + let div [i : Size] (n : Nat i) (m : Nat #) : Nat i + = caseNat # m (Nat i) + zero + (\ oo pred_m -> div' i (minus i n # pred_m) pred_m) + +check -- Alternative definition + fun div : [i : Size] -> (n : Nat i) -> (m : Nat #) -> Nat i + { div i n zero = zero + ; div i n m = div' i (minus i n # (pred # m)) (pred # m) + } + +-- computes floor(n/m) if m>0, and 0 otherwise +fun div : [i : Size] -> (n : Nat i) -> (m : Nat #) -> Nat i +{ div i n zero = zero +; div i n (suc (j, m')) = div' i (minus i n # m') m' +} + +-- Comparing natural numbers + +let Compare +(i, j : Size) = Tri (Nat i) Unit (Nat j) +pattern greater n = first n +pattern equal = second unit +pattern less m = third m + +-- compares two numbers and returns the difference +fun compare : [i : Size] -> |i| -> (n : Nat i) -> + [j : Size] -> (m : Nat j) -> Compare i j +{ compare i zero j zero = equal +; compare i n j zero = greater n +; compare i zero j m = less m +; compare i (suc (i', n)) j (suc (j', m)) = compare i' n j' m +} + +-- greatest common divisor +fun gcd : [i : Size] -> (n : Nat i) -> + [j : Size] -> (m : Nat j) -> |i,j| -> Nat (max i j) +{ gcd i zero j m = m +; gcd i n j zero = n +; gcd i (suc (i', n)) j (suc (j', m)) = case compare i' n j' m + { (equal) -> suc (i', n) + ; (greater n') -> gcd i' n' j (suc (j', m)) + ; (less m') -> gcd i (suc (i', n)) j' m' + } +} + diff --git a/lib/stl.ma b/lib/stl.ma new file mode 100644 --- /dev/null +++ b/lib/stl.ma @@ -0,0 +1,131 @@ +-- stl.ma Simply Typed Lambda calculus, implemented with de Bruijn indices + +-- Types are unlabeled binary trees + +let Ty = BinTree Unit +pattern base = leaf +pattern arrow a b = node a unit b + +let arr [i : Size] (a, b : Ty i) : Ty $i + = arrow (i, a) (i, b) + +-- Contexts are lists of types +let Context = List (Ty #) + +let extend [i : Size] (a : Ty #) (cxt : Context i) : Context $i + = consL (Ty #) i a cxt + +-- Well-typed variables + +fun Var : [i : Size] -> |i| -> (cxt : Context i) -> ^(c : Ty #) -> Set +{ Var i nil c = Empty +; Var i (cons a (j, cxt)) c = Either (Id (Ty #) a c) (Var j cxt c) +} + +-- Variables are a variant of natural numbers +pattern vzero = left refl +pattern vsucc x = right x + +let vzer (cxt : Context #) (a : Ty #) : Var # (extend # a cxt) a + = vzero + +let vsuc (cxt : Context #) (a, b : Ty #) (x : Var # cxt a) + : Var # (extend # b cxt) a + = vsucc x + +-- Well-typed terms + +cofun Term : +(i : Size) -> (cxt : Context #) -> (c : Ty #) -> Set +{ Term i cxt c = + let ++T (cxt : Context #) (c : Ty #) = [j < i] & Term j cxt c + in Tri (Var # cxt c) -- var + ((a : Ty #) & T cxt (arr # a c) & T cxt a) -- app + (case c -- abs + { (base) -> Empty + ; (arrow (j, a) (k, b)) -> T (extend # a cxt) b + }) +} +pattern var x = first x +pattern app a t u = second (a, t, u) +pattern abs t = third t + +-- Example terms + +pattern v0 = vzero +pattern v1 = vsucc v0 +pattern v2 = vsucc v1 +pattern v3 = vsucc v2 + +pattern var0 = var v0 +pattern var1 = var v1 +pattern var2 = var v2 +pattern var3 = var v3 + +let tyId : Ty # = arr # base base +let tmId : Term # nil tyId = abs (0, var0) + +let tyK : Ty # = arr # base tyId +let tmK : Term # nil tyK = abs (1, abs (0, var1)) + +let tyS : Ty # = arr # tyK (arr # tyId tyId) +let tmS : Term # nil tyS = abs (4, abs (3, abs (2, app base + (1, app base (0, var2) (0, var0)) + (1, app base (0, var1) (0, var0))))) + +-- Renamings + +let Renaming (gamma, delta : Context #) + = (a : Ty #) -> Var # delta a -> Var # gamma a + +check +fun liftRen : (gamma, delta : Context #) -> (c : Ty #) -> + (rho : Renaming gamma delta) -> Renaming (extend # c gamma) (extend # c delta) +{ liftRen gamma delta c rho .c vzero = vzero +; liftRen gamma delta c rho a (vsucc x) = vsucc (rho a x) +} + +let liftRen (gamma, delta : Context #) (c : Ty #) (rho : Renaming gamma delta) + : Renaming (extend # c gamma) (extend # c delta) + = \ a y -> case y + { (left p) -> left p + ; (right x) -> right (rho a x) + } + +fun rename : (gamma, delta : Context #) -> (c : Ty #) -> + [i : Size] -> Term i delta c -> Renaming gamma delta -> Term i gamma c +{ rename gamma delta c i (var x) rho = var (rho c x) +; rename gamma delta c i (app a (j,t) (k,u)) rho = + app a (j, rename gamma delta (arr # a c) j t rho) + (k, rename gamma delta a k u rho) +; rename gamma delta base i (abs ()) rho +; rename gamma delta (arrow (k1,a) (k2,b)) i (abs (j,t)) rho = + abs (j, rename (extend # a gamma) (extend # a delta) b j t + (liftRen gamma delta a rho)) +} + +-- Substitutions + +let Substitution +(i : Size) (gamma, delta : Context #) + = (a : Ty #) -> Var # delta a -> Term i gamma a + +let liftSubst (gamma, delta : Context #) (c : Ty #) + [i : Size] (sigma : Substitution i gamma delta) + : Substitution i (extend # c gamma) (extend # c delta) + = \ a y -> case y + { (left p) -> var (left p) + ; (right x) -> rename (extend # c gamma) gamma a i + (sigma a x) (\ b x -> vsucc x) + } + +fun substitute : (gamma, delta : Context #) -> (c : Ty #) -> + [i : Size] -> |i| -> Term i delta c -> + [j : Size] -> Substitution j gamma delta -> Term (i+j) gamma c +{ substitute gamma delta c i (var x) j sigma = sigma c x +; substitute gamma delta c i (app a (i1, t) (i2, u)) j sigma = + app a (i1+j, substitute gamma delta (arr # a c) i1 t j sigma) + (i2+j, substitute gamma delta a i2 u j sigma) +; substitute gamma delta base i (abs ()) j sigma +; substitute gamma delta (arrow (k1, a) (k2, b)) i (abs (i', t)) j sigma = + abs (i' + j, substitute (extend # a gamma) (extend # a delta) b i' t j + (liftSubst gamma delta a j sigma)) +} diff --git a/test/fail/AccCoqTermination.err b/test/fail/AccCoqTermination.err new file mode 100644 --- /dev/null +++ b/test/fail/AccCoqTermination.err @@ -0,0 +1,49 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "AccCoqTermination.ma" --- +--- scope checking --- +--- type checking --- +type Acc : ^(A : Set) -> ^(Lt : A -> A -> Set) -> ^ A -> Set +term Acc.acc : .[A : Set] -> .[Lt : A -> A -> Set] -> .[b : A] -> ^(y1 : (a : A) -> Lt a b -> Acc A Lt a) -> < Acc.acc b y1 : Acc A Lt b > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type R : ^ Nat -> ^ Nat -> Set +term R.r1 : .[x : Nat] -> < R.r1 x : R (Nat.succ (Nat.succ x)) (Nat.succ Nat.zero) > +term R.r2 : < R.r2 : R (Nat.succ Nat.zero) Nat.zero > +term acc2 : (n : Nat) -> Acc Nat R (Nat.succ (Nat.succ n)) +term acc2 = \ n -> Acc.acc [Nat.succ (Nat.succ n)] (\ a -> \ p -> case p : R a (Nat.succ (Nat.succ n)) + {}) +term aux1 : (a : Nat) -> (p : R a (Nat.succ Nat.zero)) -> Acc Nat R a +{ aux1 (Nat.succ (Nat.succ x)) (R.r1 [.x]) = acc2 x +} +term acc1 : Acc Nat R (Nat.succ Nat.zero) +term acc1 = Acc.acc [Nat.succ Nat.zero] aux1 +term aux0 : (a : Nat) -> (p : R a Nat.zero) -> Acc Nat R a +{ aux0 .(succ zero) R.r2 = acc1 +} +term acc0 : Acc Nat R Nat.zero +term acc0 = Acc.acc [Nat.zero] aux0 +term accR : (n : Nat) -> Acc Nat R n +{ accR Nat.zero = acc0 +; accR (Nat.succ Nat.zero) = acc1 +; accR (Nat.succ (Nat.succ n)) = acc2 n +} +term acc_dest : (n : Nat) -> (p : Acc Nat R n) -> (m : Nat) -> R m n -> Acc Nat R m +{ acc_dest .n (Acc.acc [n] p) = p +} +term f : (x : Nat) -> Acc Nat R x -> Nat +{ f x (Acc.acc [.x] p) = case x : Nat + { Nat.zero -> f (Nat.succ x) (p (Nat.succ x) R.r2) + ; Nat.succ Nat.zero -> f (Nat.succ x) (p (Nat.succ x) (R.r1 [Nat.zero])) + ; Nat.succ (Nat.succ y) -> Nat.zero + } +} +term g : (x : Nat) -> .[Acc Nat R x] -> Nat +{ g x [p] = case x : Nat + { Nat.zero -> g (Nat.succ x) [acc_dest Nat.zero p (Nat.succ x) R.r2] + ; Nat.succ Nat.zero -> g (Nat.succ x) [acc_dest (Nat.succ Nat.zero) p (Nat.succ x) (R.r1 [Nat.zero])] + ; Nat.succ (Nat.succ y) -> Nat.zero + } +} +error during typechecking: +Termination check for function g fails diff --git a/test/fail/AccCoqTermination.ma b/test/fail/AccCoqTermination.ma new file mode 100644 --- /dev/null +++ b/test/fail/AccCoqTermination.ma @@ -0,0 +1,90 @@ +{- +-- to debug make test/fail +fun f : (A : Set) -> A +{ f A = f A +} +-} + +data Acc ( A : Set) ( Lt : A -> A -> Set) : A -> Set +{ + acc : (b : A) -> + ((a : A) -> Lt a b -> Acc A Lt a) + -> Acc A Lt b +} + +data Nat : Set +{ + zero : Nat ; + succ : Nat -> Nat +} + +{- R (S x) x if x < 2 + -} +data R : Nat -> Nat -> Set +{ r1 : (x : Nat) -> R (succ (succ x)) (succ zero) +; r2 : R (succ zero) zero +} + +{- +fun succR : (n : Nat) -> R (succ n) n +{ succR zero = r2 +; succR (succ n) = +-} + +let acc2 : (n : Nat) -> Acc Nat R (succ (succ n)) + = \ n -> acc (succ (succ n)) (\ a -> \ p -> case p {}) + +fun aux1 : (a : Nat) -> (p : R a (succ zero)) -> Acc Nat R a +{ aux1 (succ (succ x)) (r1 .x) = acc2 x +} +-- 2010-09-20 here I would like to have internally +-- externally, there should be no dot patterns! +-- aux1 (.succ (.succ x)) (r1 .x) = acc2 x + +let acc1 : Acc Nat R (succ zero) + = acc (succ zero) aux1 + +fun aux0 : (a : Nat) -> (p : R a zero) -> Acc Nat R a +{ aux0 .(succ zero) r2 = acc1 +} + +let acc0 : Acc Nat R zero + = acc zero aux0 + +fun accR : (n : Nat) -> Acc Nat R n +{ accR zero = acc0 +; accR (succ zero) = acc1 +; accR (succ (succ n)) = acc2 n +} + +fun acc_dest : (n : Nat) -> (p : Acc Nat R n) -> + (m : Nat) -> R m n -> Acc Nat R m +{ acc_dest .n (acc n p) = p +} + +fun f : (x : Nat) -> Acc Nat R x -> Nat +{ f x (acc .x p) = case x + { zero -> f (succ x) (p (succ x) r2) + ; (succ zero) -> f (succ x) (p (succ x) (r1 zero)) + ; (succ (succ y)) -> zero + } +} + +-- In Coq, g and h are accepted by the termination checker +fun g : (x : Nat) -> [Acc Nat R x] -> Nat +{ g x p = case x + { zero -> g (succ x) (acc_dest zero p (succ x) r2) + ; (succ zero) -> g (succ x) (acc_dest (succ zero) p (succ x) (r1 zero)) + ; (succ (succ y)) -> zero + } +} +-- MiniAgda refuses g and h + +fun h : (x : Nat) -> [Acc Nat R x] -> Nat +{ h zero p = h (succ zero) (acc_dest zero p (succ zero) r2) +; h (succ zero) p = h (succ (succ zero)) (acc_dest (succ zero) p (succ (succ zero)) (r1 zero)) +; h (succ (succ y)) p = zero +} + +eval let bla : Nat + = f zero acc0 diff --git a/test/fail/AccImplicit.err b/test/fail/AccImplicit.err new file mode 100644 --- /dev/null +++ b/test/fail/AccImplicit.err @@ -0,0 +1,63 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "AccImplicit.ma" --- +--- scope checking --- +--- type checking --- +type Acc : ^(A : Set) -> ^(Lt : A -> A -> Set) -> (b : A) -> Set +term Acc.acc : .[A : Set] -> .[Lt : A -> A -> Set] -> .[b : A] -> ^(accOut : (a : A) -> Lt a b -> Acc A Lt a) -> < Acc.acc accOut : Acc A Lt b > +term accOut : .[A : Set] -> .[Lt : A -> A -> Set] -> (b : A) -> (acc : Acc A Lt b) -> (a : A) -> Lt a b -> Acc A Lt a +{ accOut [A] [Lt] b (Acc.acc #accOut) = #accOut +} +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type R : ^ Nat -> ^ Nat -> Set +term R.r1 : .[x : Nat] -> < R.r1 x : R (Nat.succ (Nat.succ x)) (Nat.succ Nat.zero) > +term R.r2 : < R.r2 : R (Nat.succ Nat.zero) Nat.zero > +term acc2 : (n : Nat) -> Acc Nat R (Nat.succ (Nat.succ n)) +term acc2 = \ n -> Acc.acc (\ a -> \ p -> case p : R a (Nat.succ (Nat.succ n)) + {}) +term aux1 : (a : Nat) -> (p : R a (Nat.succ Nat.zero)) -> Acc Nat R a +{ aux1 (Nat.succ (Nat.succ x)) (R.r1 [.x]) = acc2 x +} +term acc1 : Acc Nat R (Nat.succ Nat.zero) +term acc1 = Acc.acc aux1 +term aux0 : (a : Nat) -> (p : R a Nat.zero) -> Acc Nat R a +{ aux0 .(succ zero) R.r2 = acc1 +} +term acc0 : Acc Nat R Nat.zero +term acc0 = Acc.acc aux0 +term accR : (n : Nat) -> Acc Nat R n +{ accR Nat.zero = acc0 +; accR (Nat.succ Nat.zero) = acc1 +; accR (Nat.succ (Nat.succ n)) = acc2 n +} +term acc_dest : .[n : Nat] -> (p : Acc Nat R n) -> (m : Nat) -> R m n -> Acc Nat R m +{ acc_dest [n] (Acc.acc p) = p +} +term f : (x : Nat) -> Acc Nat R x -> Nat +{ f x (Acc.acc p) = case x : Nat + { Nat.zero -> f (Nat.succ x) (p (Nat.succ x) R.r2) + ; Nat.succ Nat.zero -> f (Nat.succ x) (p (Nat.succ x) (R.r1 [Nat.zero])) + ; Nat.succ (Nat.succ y) -> Nat.zero + } +} +term h : (x : Nat) -> .[Acc Nat R x] -> Nat +{ h Nat.zero [Acc.acc [p]] = h (Nat.succ Nat.zero) [p (Nat.succ Nat.zero) R.r2] +; h (Nat.succ Nat.zero) [Acc.acc [p]] = h (Nat.succ (Nat.succ Nat.zero)) [p (Nat.succ (Nat.succ Nat.zero)) (R.r1 [Nat.zero])] +; h (Nat.succ (Nat.succ y)) [p] = Nat.zero +} +term bla : Nat +term bla = f Nat.zero acc0 +type Id : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a a > +error during typechecking: +p1 +/// checkExpr 0 |- \ p -> refl : (p : Acc Nat R Nat.zero) -> Id Nat (h Nat.zero [p]) (h Nat.zero [acc0]) +/// checkForced fromList [] |- \ p -> refl : (p : Acc Nat R Nat.zero) -> Id Nat (h Nat.zero [p]) (h Nat.zero [acc0]) +/// new p : (Acc Nat R Nat.zero) +/// checkExpr 1 |- refl : Id Nat (h Nat.zero [p]) (h Nat.zero [acc0]) +/// checkForced fromList [(p,0)] |- refl : Id Nat (h Nat.zero [p]) (h Nat.zero [acc0]) +/// leqVal' (subtyping) < Id.refl : Id Nat (h Nat.zero [p]) (h Nat.zero [p]) > <=+ Id Nat (h Nat.zero [p]) (h Nat.zero [acc0]) +/// leqVal' (subtyping) Id Nat (h Nat.zero [p]) (h Nat.zero [p]) <=+ Id Nat (h Nat.zero [p]) (h Nat.zero [acc0]) +/// leqVal' h Nat.zero p <=^ Nat.zero : Nat +/// leqApp: head mismatch h != Nat.zero diff --git a/test/fail/AccImplicit.ma b/test/fail/AccImplicit.ma new file mode 100644 --- /dev/null +++ b/test/fail/AccImplicit.ma @@ -0,0 +1,98 @@ +data Acc ( A : Set) (Lt : A -> A -> Set) *(b : A) : Set +{ acc : (accOut : (a : A) -> Lt a b -> Acc A Lt a) -> Acc A Lt b +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +{- R (S x) x if x < 2 + -} +data R : Nat -> Nat -> Set +{ r1 : (x : Nat) -> R (succ (succ x)) (succ zero) +; r2 : R (succ zero) zero +} + +{- +fun succR : (n : Nat) -> R (succ n) n +{ succR zero = r2 +; succR (succ n) = +-} + +let acc2 : (n : Nat) -> Acc Nat R (succ (succ n)) + = \ n -> acc (\ a -> \ p -> case p {}) + +fun aux1 : (a : Nat) -> (p : R a (succ zero)) -> Acc Nat R a +{ aux1 (succ (succ x)) (r1 .x) = acc2 x +} + +let acc1 : Acc Nat R (succ zero) + = acc aux1 + +fun aux0 : (a : Nat) -> (p : R a zero) -> Acc Nat R a +{ aux0 .(succ zero) r2 = acc1 +} + +let acc0 : Acc Nat R zero + = acc aux0 + +fun accR : (n : Nat) -> Acc Nat R n +{ accR zero = acc0 +; accR (succ zero) = acc1 +; accR (succ (succ n)) = acc2 n +} + +fun acc_dest : [n : Nat] -> (p : Acc Nat R n) -> + (m : Nat) -> R m n -> Acc Nat R m +{ acc_dest n (acc p) = p +} + +fun f : (x : Nat) -> Acc Nat R x -> Nat +{ f x (acc p) = case x + { zero -> f (succ x) (p (succ x) r2) + ; (succ zero) -> f (succ x) (p (succ x) (r1 zero)) + ; (succ (succ y)) -> zero + } +} + +{- +-- In Coq, g and h are accepted by the termination checker +fun g : (x : Nat) -> [Acc Nat R x] -> Nat +{ g x p = case x + { zero -> g (succ x) (acc_dest zero p (succ x) r2) + ; (succ zero) -> g (succ x) (acc_dest (succ zero) p (succ x) (r1 zero)) + ; (succ (succ y)) -> zero + } +} + +fun h : (x : Nat) -> [Acc Nat R x] -> Nat +{ h zero p = h (succ zero) (acc_dest zero p (succ zero) r2) +; h (succ zero) p = h (succ (succ zero)) (acc_dest (succ zero) p (succ (succ zero)) (r1 zero)) +; h (succ (succ y)) p = zero +} +-} + +fun h : (x : Nat) -> [Acc Nat R x] -> Nat +{ h zero (acc p) = h (succ zero) (p (succ zero) r2) +; h (succ zero) (acc p) = h (succ (succ zero)) (p (succ (succ zero)) (r1 zero)) +; h (succ (succ y)) p = zero +} +{- The definition of h should be fine since + + q : Acc Nat R zero iff q = acc .Nat .R zero p + +so the forced match does not refine the type [Acc Nat R x] further. +This means that h can be translated to case trees without any case on q, +it just uses the destructor. -} + +eval let bla : Nat + = f zero acc0 + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +let p1 : (p : Acc Nat R zero) -> Id Nat (h zero p) (h zero acc0) + = \ p -> refl +{- In a case tree representation of h this would type check! -} diff --git a/test/fail/BadConstraint.err b/test/fail/BadConstraint.err new file mode 100644 --- /dev/null +++ b/test/fail/BadConstraint.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BadConstraint.ma" --- +--- scope checking --- +scope check error: f +/// |i| < |i|: constraints must follow a quantifier diff --git a/test/fail/BadConstraint.ma b/test/fail/BadConstraint.ma new file mode 100644 --- /dev/null +++ b/test/fail/BadConstraint.ma @@ -0,0 +1,2 @@ +-- 2013-03-30 constraints must follow quantifier +fun f : [A : Set] -> [i : Size] -> (|i| < |i| -> A) -> A {} diff --git a/test/fail/BadConstraint1.err b/test/fail/BadConstraint1.err new file mode 100644 --- /dev/null +++ b/test/fail/BadConstraint1.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BadConstraint1.ma" --- +--- scope checking --- +scope check error: f +/// |i| < |i|: constraints must follow a quantifier diff --git a/test/fail/BadConstraint1.ma b/test/fail/BadConstraint1.ma new file mode 100644 --- /dev/null +++ b/test/fail/BadConstraint1.ma @@ -0,0 +1,2 @@ +-- 2013-03-30 constraints must follow quantifier +fun f : [A : Set] -> [i : Size] -> (A -> |i| < |i| -> A) -> A {} diff --git a/test/fail/BadSizeLambda.err b/test/fail/BadSizeLambda.err new file mode 100644 --- /dev/null +++ b/test/fail/BadSizeLambda.err @@ -0,0 +1,22 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BadSizeLambda.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +term sabotage : .[i : Size] -> (.[j < i] -> Unit) -> Unit +{ sabotage [i] f = Unit.unit +} +term wtf : .[i : Size] -> Unit +error during typechecking: +wtf +/// clause 1 +/// right hand side +/// checkExpr 1 |- sabotage i (\ j -> wtf j) : Unit +/// inferExpr' sabotage i (\ j -> wtf j) +/// checkApp ((.[j < v0] -> Unit{i = v0})::Tm -> {Unit {i = v0}}) eliminated by \ j -> wtf j +/// checkExpr 1 |- \ j -> wtf j : .[j < i] -> Unit +/// checkForced fromList [(i,0)] |- \ j -> wtf j : .[j < i] -> Unit +/// new j < v0 +/// adding size rel. v1 + 1 <= v0 +/// cannot add hypothesis v1 + 1 <= v0 because it is not satisfyable under all possible valuations of the current hypotheses diff --git a/test/fail/BadSizeLambda.ma b/test/fail/BadSizeLambda.ma new file mode 100644 --- /dev/null +++ b/test/fail/BadSizeLambda.ma @@ -0,0 +1,14 @@ +-- 2013-03-30 ICFP 2013 paper + +data Unit { unit } + +-- primitive counterexample + +fun sabotage : [i : Size] -> ([j < i] -> Unit) -> Unit +{ sabotage i f = unit +} + +-- not strongly normalizing +fun wtf : [i : Size] -> |i| -> Unit +{ wtf i = sabotage i (\ j -> wtf j) +} diff --git a/test/fail/BadSizeLambdaCoinductive.err b/test/fail/BadSizeLambdaCoinductive.err new file mode 100644 --- /dev/null +++ b/test/fail/BadSizeLambdaCoinductive.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BadSizeLambdaCoinductive.ma" --- +--- scope checking --- +--- type checking --- +type S : -(i : Size) -> Set +term S.inn : .[i : Size] -> ^(out : .[j < i] -> S j) -> < S.inn out : S i > +term out : .[i : Size] -> (inn : S i) -> .[j < i] -> S j +{ out [i] (S.inn #out) = #out +} +term eta : .[i : Size] -> (.[j < i] -> S $j) -> S i +{ eta [i] f .out [j < i] = f [j] .out [j] +} +term cons : .[i : Size] -> (s : S i) -> S $i +term cons = [\ i ->] \ s -> S.inn ([\ j ->] s) +term inf : .[i : Size] -> S i +error during typechecking: +inf +/// clause 1 +/// right hand side +/// checkExpr 1 |- eta i (\ j -> cons j (inf j)) : S i +/// inferExpr' eta i (\ j -> cons j (inf j)) +/// checkApp ((.[j < v0] -> S $j{i = v0})::Tm -> {S i {i = v0}}) eliminated by \ j -> cons j (inf j) +/// checkExpr 1 |- \ j -> cons j (inf j) : .[j < i] -> S $j +/// checkForced fromList [(i,0)] |- \ j -> cons j (inf j) : .[j < i] -> S $j +/// new j < v0 +/// adding size rel. v1 + 1 <= v0 +/// cannot add hypothesis v1 + 1 <= v0 because it is not satisfyable under all possible valuations of the current hypotheses diff --git a/test/fail/BadSizeLambdaCoinductive.ma b/test/fail/BadSizeLambdaCoinductive.ma new file mode 100644 --- /dev/null +++ b/test/fail/BadSizeLambdaCoinductive.ma @@ -0,0 +1,18 @@ +-- 2013-03-30 illegal size lambda \ j < i in rhs + +-- coinductive counterexample + +data S -(i : Size) { inn (out : [j < i] -> S j) } +fields out + +fun eta : [i : Size] -> ([j < i] -> S $j) -> S i +{ eta i f .out j = f j .out j +} + +let cons [i : Size] (s : S i) : S $i + = inn (\ j -> s) + +-- not strongly normalizing: +fun inf : [i : Size] -> |i| -> S i +{ inf i = eta i (\ j -> cons j (inf j)) +} diff --git a/test/fail/BadSizeLambdaInductive.err b/test/fail/BadSizeLambdaInductive.err new file mode 100644 --- /dev/null +++ b/test/fail/BadSizeLambdaInductive.err @@ -0,0 +1,30 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BadSizeLambdaInductive.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Nat : +(i : Size) -> Set +term Nat.zero : .[i : Size] -> .[j < i] -> < Nat.zero j : Nat i > +term Nat.suc : .[i : Size] -> .[j < i] -> ^(n : Nat j) -> < Nat.suc j n : Nat i > +term apply : .[i : Size] -> (.[j < i] -> Nat $j -> Unit) -> Nat i -> Unit +{ apply [i] f (Nat.zero [j < i]) = f [j] (Nat.zero [j]) +; apply [i] f (Nat.suc [j < i] x) = f [j] (Nat.suc [j] x) +} +term caseN : .[i : Size] -> Unit -> (Nat i -> Unit) -> Nat $i -> Unit +{ caseN [i] z s (Nat.zero [j < $i]) = z +; caseN [i] z s (Nat.suc [j < $i] x) = s x +} +term run : .[i : Size] -> Nat i -> Unit +error during typechecking: +run +/// clause 1 +/// right hand side +/// checkExpr 1 |- apply i (\ j -> caseN j unit (run j)) : Nat i -> Unit +/// inferExpr' apply i (\ j -> caseN j unit (run j)) +/// checkApp ((.[j < v0] -> Nat $j -> Unit{i = v0})::Tm -> {Nat i -> Unit {i = v0}}) eliminated by \ j -> caseN j unit (run j) +/// checkExpr 1 |- \ j -> caseN j unit (run j) : .[j < i] -> Nat $j -> Unit +/// checkForced fromList [(i,0)] |- \ j -> caseN j unit (run j) : .[j < i] -> Nat $j -> Unit +/// new j < v0 +/// adding size rel. v1 + 1 <= v0 +/// cannot add hypothesis v1 + 1 <= v0 because it is not satisfyable under all possible valuations of the current hypotheses diff --git a/test/fail/BadSizeLambdaInductive.ma b/test/fail/BadSizeLambdaInductive.ma new file mode 100644 --- /dev/null +++ b/test/fail/BadSizeLambdaInductive.ma @@ -0,0 +1,24 @@ +-- 2013-03-30 + +-- inductive counterexample + +data Unit { unit } + +data Nat +(i : Size) +{ zero [j < i] +; suc [j < i] (n : Nat j) } + +fun apply : [i : Size] -> ([j < i] -> Nat $j -> Unit) -> Nat i -> Unit +{ apply i f (zero j) = f j (zero j) +; apply i f (suc j x) = f j (suc j x) +} + +fun caseN : [i : Size] -> Unit -> (Nat i -> Unit) -> Nat $i -> Unit +{ caseN i z s (zero j) = z +; caseN i z s (suc j x) = s x +} + +-- not strongly normalizing: +fun run : [i : Size] -> |i| -> Nat i -> Unit +{ run i = apply i (\ j -> caseN j unit (run j)) +} diff --git a/test/fail/BigDataInSet0.err b/test/fail/BigDataInSet0.err new file mode 100644 --- /dev/null +++ b/test/fail/BigDataInSet0.err @@ -0,0 +1,18 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BigDataInSet0.ma" --- +--- scope checking --- +--- type checking --- +ty-u BigOk : Set 1 +term BigOk.bigOk : ^(y0 : Set) -> < BigOk.bigOk y0 : BigOk > +type BigIrr : Set +term BigIrr.bigIrr : .[y0 : Set] -> < BigIrr.bigIrr y0 : BigIrr > +type Big : Set +error during typechecking: +Big +/// constructor Big.big +/// new Big : Set +/// inferExpr' ^ Set -> Big +/// new : Set +/// leSize 1 <=+ 0 +/// leSize' 1 <= 0 +/// leSize': 1 <= 0 failed diff --git a/test/fail/BigDataInSet0.ma b/test/fail/BigDataInSet0.ma new file mode 100644 --- /dev/null +++ b/test/fail/BigDataInSet0.ma @@ -0,0 +1,15 @@ +-- 2010-09-20 + +data BigOk : Set 1 +{ bigOk : Set 0 -> BigOk +} + +-- 2012-10-10 suceeds, because of irrelevance +data BigIrr : Set +{ bigIrr : .Set -> BigIrr +} + +data Big : Set 0 +{ big : Set 0 -> Big +} +-- needs to fail, constructor lives in Set 1 diff --git a/test/fail/BoundedFake.err b/test/fail/BoundedFake.err new file mode 100644 --- /dev/null +++ b/test/fail/BoundedFake.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BoundedFake.ma" --- +--- scope checking --- +--- type checking --- +term bad : .[i : Size] -> .[j : Size] -> .[A : Set] -> A +error during typechecking: +bad +/// clause 1 +/// pattern j < i +/// new j <= # +/// adding size rel. v1 + 1 <= v0 +/// leqVal' (subtyping) Size <=+ < i +/// leSize # <+ i +/// leSize' # < i +/// leSize: # + 0 < i failed diff --git a/test/fail/BoundedFake.ma b/test/fail/BoundedFake.ma new file mode 100644 --- /dev/null +++ b/test/fail/BoundedFake.ma @@ -0,0 +1,9 @@ +-- 2012-01-22 + +-- need to check that bounds are forced! +fun bad : [i, j : Size] -> [A : Set] -> A +{ bad i (j < i) A = bad j j A +} + +let bot : [A : Set] -> A + = bad # # diff --git a/test/fail/BoundedQStrict.err b/test/fail/BoundedQStrict.err new file mode 100644 --- /dev/null +++ b/test/fail/BoundedQStrict.err @@ -0,0 +1,29 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BoundedQStrict.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +term mySucc : .[i : Size] -> .[j : Size] -> |j| < |i| -> Nat j -> Nat i +{ mySucc [i] [j] n = Nat.succ [j] n +} +error during typechecking: +bla +/// checkExpr 0 |- \ i -> \ j -> \ n -> mySucc i j n : .[i : Size] -> .[j : Size] -> |j| <= |i| -> Nat j -> Nat i +/// checkForced fromList [] |- \ i -> \ j -> \ n -> mySucc i j n : .[i : Size] -> .[j : Size] -> |j| <= |i| -> Nat j -> Nat i +/// new i <= # +/// checkExpr 1 |- \ j -> \ n -> mySucc i j n : .[j : Size] -> |j| <= |i| -> Nat j -> Nat i +/// checkForced fromList [(i,0)] |- \ j -> \ n -> mySucc i j n : .[j : Size] -> |j| <= |i| -> Nat j -> Nat i +/// new j <= # +/// checkExpr 2 |- \ n -> mySucc i j n : |j| <= |i| -> Nat j -> Nat i +/// adding size rel. v1 + 0 <= v0 +/// checkExpr 2 |- \ n -> mySucc i j n : Nat j -> Nat i +/// checkForced fromList [(j,1),(i,0)] |- \ n -> mySucc i j n : Nat j -> Nat i +/// new n : (Nat v1) +/// checkExpr 3 |- mySucc i j n : Nat i +/// inferExpr' mySucc i j n +/// checkGuard |j| < |i| +/// lexSizes: no descent detected diff --git a/test/fail/BoundedQStrict.ma b/test/fail/BoundedQStrict.ma new file mode 100644 --- /dev/null +++ b/test/fail/BoundedQStrict.ma @@ -0,0 +1,21 @@ +-- 2010-11-12 + +{- another way to look at sized types: + +sized data Nat (i : Size) : Set +{ zero : Nat i +; succ : [j : Size] -> |j| < |i| -> Nat j -> Nat i +} + +-} +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat $i +; succ : [i : Size] -> Nat i -> Nat $i +} + +fun mySucc : [i : Size] -> [j : Size] -> |j| < |i| -> Nat j -> Nat i +{ mySucc i j n = succ j n } + +let bla : [i : Size] -> [j : Size] -> |j| <= |i| -> Nat j -> Nat i + = \ i j n -> mySucc i j n +-- needs to fail diff --git a/test/fail/BoundedQWrong.err b/test/fail/BoundedQWrong.err new file mode 100644 --- /dev/null +++ b/test/fail/BoundedQWrong.err @@ -0,0 +1,42 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BoundedQWrong.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +term mySucc : .[i : Size] -> .[j < i] -> Nat i -> Nat j +block fails as expected, error message: +mySucc +/// clause 1 +/// right hand side +/// checkExpr 3 |- succ j n : Nat j +/// checkForced fromList [(j,1),(i,0),(n,2)] |- succ j n : Nat j +/// checkApp (^(y1 : (Nat v1)::()) -> < Nat.succ i y1 : Nat $i >{i = v1}) eliminated by n +/// leqVal' (subtyping) < n : Nat i > <=+ Nat j +/// leqVal' (subtyping) Nat i <=+ Nat j +/// leqVal' i <=+ j : Size +/// leSize i <=+ j +/// leSize' i <= j +/// bound not entailed +error during typechecking: +explicitCast +/// checkExpr 0 |- \ i -> \ j -> \ n -> n : .[i : Size] -> .[j <= i] -> Nat i -> Nat j +/// checkForced fromList [] |- \ i -> \ j -> \ n -> n : .[i : Size] -> .[j <= i] -> Nat i -> Nat j +/// new i <= # +/// checkExpr 1 |- \ j -> \ n -> n : .[j <= i] -> Nat i -> Nat j +/// checkForced fromList [(i,0)] |- \ j -> \ n -> n : .[j <= i] -> Nat i -> Nat j +/// new j <= v0 +/// adding size rel. v1 + 0 <= v0 +/// checkExpr 2 |- \ n -> n : Nat i -> Nat j +/// checkForced fromList [(j,1),(i,0)] |- \ n -> n : Nat i -> Nat j +/// new n : (Nat v0) +/// checkExpr 3 |- n : Nat j +/// leqVal' (subtyping) < n : Nat i > <=+ Nat j +/// leqVal' (subtyping) Nat i <=+ Nat j +/// leqVal' i <=+ j : Size +/// leSize i <=+ j +/// leSize' i <= j +/// bound not entailed diff --git a/test/fail/BoundedQWrong.ma b/test/fail/BoundedQWrong.ma new file mode 100644 --- /dev/null +++ b/test/fail/BoundedQWrong.ma @@ -0,0 +1,21 @@ +-- 2010-11-12 + +{- another way to look at sized types: + +sized data Nat (i : Size) : Set +{ zero : Nat i +; succ : [j : Size] -> |j| < |i| -> Nat j -> Nat i +} + +-} +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat $i +; succ : [i : Size] -> Nat i -> Nat $i +} + +fail +fun mySucc : [i : Size] -> [j < i] -> Nat i -> Nat j +{ mySucc i j n = succ j n } + +let explicitCast : [i : Size] -> [j <= i] -> Nat i -> Nat j + = \ i j n -> n diff --git a/test/fail/BoxNeg.err b/test/fail/BoxNeg.err new file mode 100644 --- /dev/null +++ b/test/fail/BoxNeg.err @@ -0,0 +1,11 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "BoxNeg.ma" --- +--- scope checking --- +--- type checking --- +type Box : ^(A : Set) -> Set +term Box.box : .[A : Set] -> ^(y0 : A) -> < Box.box y0 : Box A > +type Neg : Set +term Neg.neg : ^(y0 : Box Neg -> Neg) -> < Neg.neg y0 : Neg > +error during typechecking: +checking positivity +/// polarity check ++ <= ^ failed diff --git a/test/fail/BoxNeg.ma b/test/fail/BoxNeg.ma new file mode 100644 --- /dev/null +++ b/test/fail/BoxNeg.ma @@ -0,0 +1,9 @@ +-- 2010-06-11, Nisse + +data Box (A : Set) : Set +{ box : A -> Box A +} + +data Neg : Set +{ neg : (Box Neg -> Neg) -> Neg +} diff --git a/test/fail/CheatSubtypingPos.err b/test/fail/CheatSubtypingPos.err new file mode 100644 --- /dev/null +++ b/test/fail/CheatSubtypingPos.err @@ -0,0 +1,12 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "CheatSubtypingPos.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +MakePos +/// checkExpr 0 |- \ F -> F : (- Set -> Set) -> + Set -> Set +/// checkForced fromList [] |- \ F -> F : (- Set -> Set) -> + Set -> Set +/// new F : (-Set -> Set) +/// checkExpr 1 |- F : + Set -> Set +/// leqVal' (subtyping) -(xSing# : Set) -> < F xSing# : Set > <=+ + Set -> Set +/// subtyping -(xSing# : Set) -> < F xSing# : Set > <=+ + Set -> Set failed diff --git a/test/fail/CheatSubtypingPos.ma b/test/fail/CheatSubtypingPos.ma new file mode 100644 --- /dev/null +++ b/test/fail/CheatSubtypingPos.ma @@ -0,0 +1,3 @@ +-- 2010-07-11 + +let MakePos : (-Set -> Set) -> (+Set -> Set) = \ F -> F diff --git a/test/fail/CoNotLowerSemi.err b/test/fail/CoNotLowerSemi.err new file mode 100644 --- /dev/null +++ b/test/fail/CoNotLowerSemi.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "CoNotLowerSemi.ma" --- +--- scope checking --- +--- type checking --- +type Nat : +(i : Size) -> Set +term Nat.zero : .[i : Size] -> < Nat.zero : Nat i > +term Nat.suc : .[i : Size] -> ^(jn : .[j < i] & Nat j) -> < Nat.suc jn : Nat i > +type Stream : ++(A : Set) -> -(i : Size) -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : .[j < i] -> Stream A j) -> < Stream.cons head tail : Stream A i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A i) -> A +{ head [A] [i] (Stream.cons #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A i) -> .[j < i] -> Stream A j +{ tail [A] [i] (Stream.cons #head #tail) = #tail +} +term repeat : .[A : Set] -> (a : A) -> .[i : Size] -> Stream A i +{ repeat [A] a [i] = Stream.cons a ([\ j ->] repeat [A] a [j]) +} +error during typechecking: +lsc +/// new s : (Stream (Nat #) #) +/// checkExpr 1 |- (# , s) : .[j < #] & Stream (Nat j) # +/// checkForced fromList [(s,0)] |- (# , s) : .[j < #] & Stream (Nat j) # +/// checkExpr 1 |- # : < # +/// leqVal' (subtyping) < # : Size > <=+ < # +/// leSize # <+ # +/// leSize: # < # failed diff --git a/test/fail/CoNotLowerSemi.ma b/test/fail/CoNotLowerSemi.ma new file mode 100644 --- /dev/null +++ b/test/fail/CoNotLowerSemi.ma @@ -0,0 +1,17 @@ +data Nat +(i : Size) +{ zero +; suc (jn : [j < i] & Nat j) +} + +data Stream ++(A : Set) -(i : Size) +{ cons (head : A) (tail : [j < i] -> Stream A j) +} + +cofun repeat : [A : Set] (a : A) [i : Size] |i| -> Stream A i +{ repeat A a i = cons a (\ j -> repeat A a j) +} + +-- infinite tuples not lsc + +let lsc (s : Stream (Nat #) #) : [j < #] & Stream (Nat j) # + = (#, s) diff --git a/test/fail/CoNotLowerSemi1.err b/test/fail/CoNotLowerSemi1.err new file mode 100644 --- /dev/null +++ b/test/fail/CoNotLowerSemi1.err @@ -0,0 +1,24 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "CoNotLowerSemi1.ma" --- +--- scope checking --- +--- type checking --- +type Nat : +(i : Size) -> Set +term Nat.zero : .[i : Size] -> < Nat.zero : Nat i > +term Nat.suc : .[i : Size] -> ^(jn : .[j < i] & Nat j) -> < Nat.suc jn : Nat i > +type Stream : ++(A : Set) -> Set +term Stream.cons : .[A : Set] -> ^(head : A) -> ^(tail : Stream A) -> < Stream.cons head tail : Stream A > +term head : .[A : Set] -> (cons : Stream A) -> A +{ head [A] (Stream.cons #head #tail) = #head +} +term tail : .[A : Set] -> (cons : Stream A) -> Stream A +{ tail [A] (Stream.cons #head #tail) = #tail +} +error during typechecking: +lsc +/// new s : (Stream (Nat #)) +/// checkExpr 1 |- (# , s) : .[j < #] & Stream (Nat j) +/// checkForced fromList [(s,0)] |- (# , s) : .[j < #] & Stream (Nat j) +/// checkExpr 1 |- # : < # +/// leqVal' (subtyping) < # : Size > <=+ < # +/// leSize # <+ # +/// leSize: # < # failed diff --git a/test/fail/CoNotLowerSemi1.ma b/test/fail/CoNotLowerSemi1.ma new file mode 100644 --- /dev/null +++ b/test/fail/CoNotLowerSemi1.ma @@ -0,0 +1,19 @@ +data Nat +(i : Size) +{ zero +; suc (jn : [j < i] & Nat j) +} + +codata Stream ++(A : Set) +{ cons (head : A) (tail : Stream A) +} + +-- infinite tuples not lsc + +let lsc (s : Stream (Nat #)) : [j < #] & Stream (Nat j) + = (#, s) + +{- +cofun repeat : [A : Set] (a : A) [i : Size] |i| -> Stream A i +{ repeat A a i = cons a (\ j -> repeat A a j) +} +-} diff --git a/test/fail/ConorMcBrideCalco09inflationary.err b/test/fail/ConorMcBrideCalco09inflationary.err new file mode 100644 --- /dev/null +++ b/test/fail/ConorMcBrideCalco09inflationary.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "ConorMcBrideCalco09inflationary.ma" --- +--- scope checking --- +--- type checking --- +type Map : (F : Set -> Set) -> Set (max 1) +type Map = \ F -> .[A : Set] -> .[B : Set] -> (A -> B) -> F A -> F B +type Nu : (F : + Set -> Set) -> -(i : Size) -> Set +{ Nu F i = .[j < i] -> F (Nu F j) +} +error during typechecking: +out +/// new F : (+Set -> Set) +/// new i <= # +/// new r : (Nu (v0 Up (+Set -> Set)) {$i {i = v1, F = (v0 Up (+Set -> Set))}}) +/// checkExpr 3 |- r i : F (Nu F i) +/// inferExpr' r i +/// leqVal' (subtyping) [(i,1),(F,0),(r,2)] |- < i : <= # > <=+ < $i +/// leSize v1 <+ ($ v1) +/// leSize' v1 < ($ v1) +/// leSize'': i + -1 < i failed diff --git a/test/fail/D.err b/test/fail/D.err new file mode 100644 --- /dev/null +++ b/test/fail/D.err @@ -0,0 +1,29 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "D.ma" --- +--- scope checking --- +--- type checking --- +type D : Set +term D.abs : ^(y0 : ^ D -> D) -> < D.abs y0 : D > +warning: ignoring error: polarity check ++ <= - failed +warning: ignoring error: polarity check ++ <= + failed +term app : D -> ^ D -> D +{ app (D.abs f) d = f d +} +term sapp : D -> D +{ sapp x = app x x +} +error during typechecking: +delta +/// checkExpr 0 |- abs (\ x -> sapp x) : D +/// checkForced fromList [] |- abs (\ x -> sapp x) : D +/// checkApp (^(y0 : (^D::() -> D)::()) -> < D.abs y0 : D >) eliminated by \ x -> sapp x +/// checkExpr 0 |- \ x -> sapp x : ^ D -> D +/// checkForced fromList [] |- \ x -> sapp x : ^ D -> D +/// new x : D +/// checkExpr 1 |- sapp x : D +/// inferExpr' sapp x +/// checkApp (D::Tm -> D) eliminated by x +/// inferExpr' x +/// inferExpr: variable x : D may not occur +/// , because of polarity +/// polarity check ^ <= * failed diff --git a/test/fail/D.ma b/test/fail/D.ma new file mode 100644 --- /dev/null +++ b/test/fail/D.ma @@ -0,0 +1,19 @@ +-- 2010-11-06 + +-- this might be accepted without trustme in future versions?! +trustme +data D : Set +{ abs : ^(^D -> D) -> D +} + +fun app : D -> ^D -> D +{ app (abs f) d = f d +} + +fun sapp : D -> D +{ sapp x = app x x +} + +-- this needs to fail, since x is not parametric in application! +let delta : D + = abs (\ x -> sapp x) diff --git a/test/fail/D1.err b/test/fail/D1.err new file mode 100644 --- /dev/null +++ b/test/fail/D1.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "D1.ma" --- +--- scope checking --- +--- type checking --- +type D : Set +term D.abs : ^(y0 : ^ D -> D) -> < D.abs y0 : D > +warning: ignoring error: polarity check ++ <= - failed +warning: ignoring error: polarity check ++ <= + failed +term app : ^ D -> ^ D -> D +error during typechecking: +app +/// clause 1 +/// pattern abs f +/// cannot match pattern abs f against non-computational argument diff --git a/test/fail/D1.ma b/test/fail/D1.ma new file mode 100644 --- /dev/null +++ b/test/fail/D1.ma @@ -0,0 +1,15 @@ +-- 2010-11-06 + +-- this might be accepted without trustme in future versions?! +trustme +data D : Set +{ abs : (^D -> D) -> D +} + +-- this must fail! +fun app : ^D -> ^D -> D +{ app (abs f) d = f d +} +{- abs must not be characterized as a forced match! +only terminating eta-expansions are forced matches +-} diff --git a/test/fail/DataAtSetInfty.err b/test/fail/DataAtSetInfty.err new file mode 100644 --- /dev/null +++ b/test/fail/DataAtSetInfty.err @@ -0,0 +1,7 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "DataAtSetInfty.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +U +/// # is not a valid universe level diff --git a/test/fail/DataAtSetInfty.ma b/test/fail/DataAtSetInfty.ma new file mode 100644 --- /dev/null +++ b/test/fail/DataAtSetInfty.ma @@ -0,0 +1,10 @@ +-- 2010-09-14 + +-- this needs to be rejected + +data U : Set # +{ inn : [i : Size] -> (out : Set i) -> U +} + +let U' : U = inn # U + diff --git a/test/fail/DeepForcedConstructors.err b/test/fail/DeepForcedConstructors.err new file mode 100644 --- /dev/null +++ b/test/fail/DeepForcedConstructors.err @@ -0,0 +1,21 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "DeepForcedConstructors.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +term not : Bool -> Bool +{ not Bool.true = Bool.false +; not Bool.false = Bool.true +} +type Nat : ^ Bool -> Set +term Nat.zero : < Nat.zero : Nat Bool.true > +term Nat.succ : ^(b : Bool) -> ^(y1 : Nat b) -> < Nat.succ b y1 : Nat Bool.false > +term f : (b : Bool) -> .[Nat b] -> Bool +error during typechecking: +f +/// clause 2 +/// pattern succ .true zero +/// pattern zero +/// checkPattern: constructor Nat.zero of non-computational argument zero : (Nat .Bool.true{}) not forced diff --git a/test/fail/DeepForcedConstructors.ma b/test/fail/DeepForcedConstructors.ma new file mode 100644 --- /dev/null +++ b/test/fail/DeepForcedConstructors.ma @@ -0,0 +1,23 @@ +-- 2010-01-25 +-- 2010-07-08 + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun not : Bool -> Bool +{ not true = false +; not false = true +} + +data Nat : Bool -> Set +{ zero : Nat true +; succ : (b : Bool) -> Nat b -> Nat false +} + +fun f : (b : Bool) -> [Nat b] -> Bool +{ f true zero = true +; f false (succ .true zero) = false +} +-- should not type check, since match "zero" inside (succ ...) is not forced diff --git a/test/fail/DescendAscend.err b/test/fail/DescendAscend.err new file mode 100644 --- /dev/null +++ b/test/fail/DescendAscend.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "DescendAscend.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term plus : Nat -> Nat -> Nat +{} +term f : Nat -> Nat +term g : Nat -> Nat -> Nat +{ f (Nat.succ (Nat.succ (Nat.succ n))) = g n n +} +{ g (Nat.succ n) m = plus (g n (Nat.succ m)) (f m) +} +error during typechecking: +Termination check for mutual block [f,g] fails for [f,g] diff --git a/test/fail/DescendAscend.ma b/test/fail/DescendAscend.ma new file mode 100644 --- /dev/null +++ b/test/fail/DescendAscend.ma @@ -0,0 +1,17 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun plus : Nat -> Nat -> Nat {} + +mutual { + + fun f : Nat -> Nat + { f (succ (succ (succ n))) = g n n + } + + fun g : Nat -> Nat -> Nat + { g (succ n) m = plus (g n (succ m)) (f m) + } +} diff --git a/test/fail/DescendAscend2.err b/test/fail/DescendAscend2.err new file mode 100644 --- /dev/null +++ b/test/fail/DescendAscend2.err @@ -0,0 +1,18 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "DescendAscend2.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term plus : Nat -> Nat -> Nat +{} +term f : Nat -> Nat -> Nat +term g : Nat -> Nat -> Nat +{ f (Nat.succ n) m = f n (Nat.succ m) +; f (Nat.succ (Nat.succ (Nat.succ n))) m = plus m (g n n) +} +{ g (Nat.succ n) m = plus (g n (Nat.succ m)) (f m n) +} +error during typechecking: +Termination check for mutual block [f,g] fails for [g] diff --git a/test/fail/DescendAscend2.ma b/test/fail/DescendAscend2.ma new file mode 100644 --- /dev/null +++ b/test/fail/DescendAscend2.ma @@ -0,0 +1,19 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun plus : Nat -> Nat -> Nat {} + +mutual { + + fun f : Nat -> Nat -> Nat + { + f (succ n) m = f n (succ m) ; -- ADDING THIS LINE leads to success?? + f (succ (succ (succ n))) m = plus (m) (g n n) + } + + fun g : Nat -> Nat -> Nat + { g (succ n) m = plus (g n (succ m)) (f m n) + } +} diff --git a/test/fail/DoNotEraseDataTeleForConTypes.err b/test/fail/DoNotEraseDataTeleForConTypes.err new file mode 100644 --- /dev/null +++ b/test/fail/DoNotEraseDataTeleForConTypes.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "DoNotEraseDataTeleForConTypes.ma" --- +--- scope checking --- +--- type checking --- +type Wrap : .[A : Set] -> Set +error during typechecking: +Wrap +/// constructor Wrap.inn +/// new Wrap : (.[A : Set] -> Set) +/// new A : Set +/// inferExpr' ^(out : A) -> Wrap A +/// inferExpr' A +/// inferExpr: variable A : Set may not occur +/// , because it is marked as erased diff --git a/test/fail/DoNotEraseDataTeleForConTypes.ma b/test/fail/DoNotEraseDataTeleForConTypes.ma new file mode 100644 --- /dev/null +++ b/test/fail/DoNotEraseDataTeleForConTypes.ma @@ -0,0 +1,11 @@ +-- 2010-06-18 + +-- the following definition needs to be rejected! +data Wrap [A : Set] : Set +{ inn : (out : A) -> Wrap A +} +fields out + +fun cast : [A : Set] -> [B : Set] -> A -> B +{ cast A B a = out {- B -} (inn {- A -} a) +} diff --git a/test/fail/DottedConstructorsWrong.err b/test/fail/DottedConstructorsWrong.err new file mode 100644 --- /dev/null +++ b/test/fail/DottedConstructorsWrong.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "DottedConstructorsWrong.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +term top : Unit -> Unit +{ top un!t = Unit.unit +} +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +term not : Bool -> Bool +block fails as expected, error message: +not +/// clause 1 +/// confirming dotted constructor .true +/// more than one constructor matches type Bool +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.suc : ^(n : Nat) -> < Nat.suc n : Nat > +term pred : Nat -> Nat +error during typechecking: +pred +/// clause 2 +/// confirming dotted constructor .suc x +/// more than one constructor matches type Nat diff --git a/test/fail/DottedConstructorsWrong.ma b/test/fail/DottedConstructorsWrong.ma new file mode 100644 --- /dev/null +++ b/test/fail/DottedConstructorsWrong.ma @@ -0,0 +1,21 @@ +-- 2013-04-08 + +data Unit { unit } + +fun top : Unit -> Unit +{ top .unit = unit } + +data Bool { true ; false } + +fail +fun not : Bool -> Bool +{ not .true = false +; not false = true +} + +data Nat { zero ; suc (n : Nat) } + +fun pred : Nat -> Nat +{ pred zero = zero +; pred (.suc x) = x +} diff --git a/test/fail/EndsCoInEmpty.err b/test/fail/EndsCoInEmpty.err new file mode 100644 --- /dev/null +++ b/test/fail/EndsCoInEmpty.err @@ -0,0 +1,32 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "EndsCoInEmpty.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type EmptyOr : ++(A : Set) -> ^ Bool -> Set +term EmptyOr.inn : .[A : Set] -> ^(out : A) -> < EmptyOr.inn out : EmptyOr A Bool.true > +term out : .[A : Set] -> (inn : EmptyOr A Bool.true) -> A +{ out [A] (EmptyOr.inn #out) = #out +} +term exFalso : .[A : Set] -> .[B : Set] -> EmptyOr A Bool.false -> B +{ exFalso [A] [B] () +} +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term bla : .[A : Set] -> .[i : Size] -> EmptyOr (Stream A i) Bool.false +error during typechecking: +bla +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> EmptyOr (Stream A i) Bool.false ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: EmptyOr (Stream A i) Bool.false +/// allTypesOfTuple: panic: target type EmptyOr (Stream A i) Bool.false is not an instance of any constructor diff --git a/test/fail/EndsCoInEmpty.ma b/test/fail/EndsCoInEmpty.ma new file mode 100644 --- /dev/null +++ b/test/fail/EndsCoInEmpty.ma @@ -0,0 +1,29 @@ +-- 2010-09-05 +-- Tried to trick MiniAgda into believing that an empty type is a tuple type +-- but it did not follow me. Good! + +data Bool : Set +{ true : Bool +; false : Bool +} + +-- a fake tuple type +data EmptyOr ++(A : Set) : Bool -> Set +{ inn : (out : A) -> EmptyOr A true +} + +fun exFalso : [A, B : Set] -> EmptyOr A false -> B +{ exFalso A B () +} + +sized codata Stream ++(A : Set) : Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A $i +} + +cofun bla : [A : Set] -> [i : Size] -> EmptyOr (Stream A i) false +{ bla A ($ i) = exFalso (Stream A i) (EmptyOr (Stream A $i) false) (bla A i) +} + +fun anything : [A : Set] -> A +{ anything A = exFalso (EmptyOr (Stream Bool #) false) A (bla Bool #) +} diff --git a/test/fail/ExistsSPos.err b/test/fail/ExistsSPos.err new file mode 100644 --- /dev/null +++ b/test/fail/ExistsSPos.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "ExistsSPos.ma" --- +--- scope checking --- +--- type checking --- +type Exists : ^(A : Set) -> ++(B : A -> Set) -> Set +term Exists.exI : .[A : Set] -> .[B : A -> Set] -> ^(witness : A) -> ^(proof : B witness) -> < Exists.exI witness proof : Exists A B > +term witness : .[A : Set] -> .[B : A -> Set] -> (exI : Exists A B) -> A +{ witness [A] [B] (Exists.exI #witness #proof) = #witness +} +term proof : .[A : Set] -> .[B : A -> Set] -> (exI : Exists A B) -> B (witness [A] [B] exI) +{ proof [A] [B] (Exists.exI #witness #proof) = #proof +} +type Foo : Set +term Foo.foo : ^(y0 : Exists Foo (\ x -> Foo)) -> < Foo.foo y0 : Foo > +error during typechecking: +checking positivity +/// polarity check ++ <= ^ failed diff --git a/test/fail/ExistsSPos.ma b/test/fail/ExistsSPos.ma new file mode 100644 --- /dev/null +++ b/test/fail/ExistsSPos.ma @@ -0,0 +1,9 @@ +-- 2010-06-11, Nisse + +data Exists (A : Set) (+ B : A -> Set) : Set +{ exI : (witness : A) -> (proof : B witness) -> Exists A B +} + +data Foo : Set +{ foo : Exists Foo (\ x -> Foo) -> Foo +} diff --git a/test/fail/Fib2.err b/test/fail/Fib2.err new file mode 100644 --- /dev/null +++ b/test/fail/Fib2.err @@ -0,0 +1,47 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "Fib2.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Nat : Set +type Nat = SNat # +term add : Nat -> Nat -> Nat +{ add (SNat.zero [.#]) = \ y -> y +; add (SNat.succ [.#] x) = \ y -> SNat.succ [#] (add x y) +} +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term zipWith : .[A : Set] -> .[B : Set] -> .[C : Set] -> (A -> B -> C) -> .[i : Size] -> Stream A i -> Stream B i -> Stream C i +{ zipWith [A] [B] [C] f $[i < #] (Stream.cons [.i] a as) (Stream.cons [.i] b bs) = Stream.cons [i] (f a b) (zipWith [A] [B] [C] f [i] as bs) +} +term n0 : Nat +term n0 = SNat.zero [#] +term n1 : Nat +term n1 = SNat.succ [#] n0 +term fib : .[i : Size] -> Stream Nat i +{ fib $[i < #] = Stream.cons [i] n0 (zipWith [Nat] [Nat] [Nat] add [i] (Stream.cons [i] n1 (fib [i])) (fib [i])) +} +term fib2 : .[i : Size] -> Stream Nat (i + i) +error during typechecking: +fib2 +/// clause 1 +/// right hand side +/// checkExpr 1 |- cons (i + i) n0 (zipWith Nat Nat Nat add (i + i) (cons (i + i) n1 (fib2 i)) (fib2 i)) : Stream Nat ($i + $i) +/// checkForced fromList [(i,0)] |- cons (i + i) n0 (zipWith Nat Nat Nat add (i + i) (cons (i + i) n1 (fib2 i)) (fib2 i)) : Stream Nat ($i + $i) +/// leqVal' (subtyping) < Stream.cons (i + i) (SNat.zero #) (zipWith Nat Nat Nat add (i + i) (Stream.cons [i + i] n1 (fib2 [i])) (fib2 [i])) : Stream Nat $(i + i) > <=+ Stream Nat ($i + $i) +/// leqVal' (subtyping) Stream Nat $(i + i) <=+ Stream Nat ($i + $i) +/// leqVal' $(i + i) <=- $$(i + i) : Size +/// leSize $(i + i) <=- $$(i + i) +/// leSize i + i <=- $(i + i) +/// leSize' $(i + i) <= i + i +/// leSize: 0 + 1 <= 0 failed diff --git a/test/fail/Fib2.ma b/test/fail/Fib2.ma new file mode 100644 --- /dev/null +++ b/test/fail/Fib2.ma @@ -0,0 +1,52 @@ +-- 2010-11-01 + +-- Nat --------------------------------------------------------------- + +sized data SNat : Size -> Set +{ zero : [i : Size] -> SNat ($ i) +; succ : [i : Size] -> SNat i -> SNat ($ i) +} + +let Nat : Set = SNat # + +fun add : Nat -> Nat -> Nat +{ add (zero .#) = \ y -> y +; add (succ .# x) = \ y -> succ # (add x y) +} + +-- Stream ------------------------------------------------------------ + +sized codata Stream ++(A : Set) : -Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A ($ i) +} +fields head, tail + +cofun zipWith : [A : Set] -> [B : Set] -> [C : Set] -> + (A -> B -> C) -> [i : Size] -> + Stream A i -> Stream B i -> Stream C i +{ + zipWith A B C f ($ i) (cons .i a as) (cons .i b bs) = + cons i (f a b) (zipWith A B C f i as bs) +} + + +-- Fibonacci stream -------------------------------------------------- + +let n0 : Nat = zero # +let n1 : Nat = succ # n0 + +cofun fib : [i : Size] -> Stream Nat i +{ + fib ($ i) = cons i n0 (zipWith Nat Nat Nat add i + (cons i n1 (fib i)) (fib i)) +} + +cofun fib2 : [i : Size] -> Stream Nat (i + i) +{ + fib2 ($ i) = -- RHS illtyped, produces only Stream Nat $(i + i) + cons (i + i) n0 + (zipWith Nat Nat Nat add (i + i) + (cons (i + i) n1 (fib2 i)) + (fib2 i)) +} + diff --git a/test/fail/FinBranchMutualWrong.err b/test/fail/FinBranchMutualWrong.err new file mode 100644 --- /dev/null +++ b/test/fail/FinBranchMutualWrong.err @@ -0,0 +1,19 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "FinBranchMutualWrong.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.suc : ^(y0 : Nat) -> < Nat.suc y0 : Nat > +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Prod : -(A : Set) -> ++(B : Set) -> Set +term Prod.pair : .[A : Set] -> .[B : Set] -> ^(y0 : A -> B) -> < Prod.pair y0 : Prod A B > +type Tree : Set +term Tree.node : ^(numBranches : Nat) -> ^(y1 : VecTree numBranches) -> < Tree.node numBranches y1 : Tree > +{ VecTree Nat.zero = Unit +; VecTree (Nat.suc n) = Prod Tree (VecTree n) +} +error during typechecking: +checking positivity +/// polarity check ++ <= - failed diff --git a/test/fail/FinBranchMutualWrong.ma b/test/fail/FinBranchMutualWrong.ma new file mode 100644 --- /dev/null +++ b/test/fail/FinBranchMutualWrong.ma @@ -0,0 +1,26 @@ +-- 2010-08-30 + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data Unit : Set { unit : Unit } + +-- fake product, is fun space +data Prod -(A : Set) ++(B : Set) : Set +{ pair : (A -> B) -> Prod A B +} + +mutual { + + data Tree : Set + { node : (numBranches : Nat) -> VecTree numBranches -> Tree + } + + fun VecTree : Nat -> Set + { VecTree zero = Unit + ; VecTree (suc n) = Prod Tree (VecTree n) + } + +} diff --git a/test/fail/FunctionExtensionality.err b/test/fail/FunctionExtensionality.err new file mode 100644 --- /dev/null +++ b/test/fail/FunctionExtensionality.err @@ -0,0 +1,28 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "FunctionExtensionality.ma" --- +--- scope checking --- +--- type checking --- +type Id : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a a > +term subst : .[A : Set] -> .[a : A] -> .[b : A] -> .[q : Id A a b] -> .[P : A -> Set] -> P a -> P b +{ subst [A] [a] [.a] [Id.refl] [P] h = h +} +term J : .[A : Set] -> .[P : (a : A) -> (b : A) -> Id A a b -> Set] -> (h : (a : A) -> P a a Id.refl) -> (a : A) -> (b : A) -> .[q : Id A a b] -> P a b q +{ J [A] [P] h a .a [Id.refl] = h a +} +term subst : .[A : Set] -> (a : A) -> (b : A) -> (q : Id A a b) -> .[P : A -> Set] -> P a -> P b +term subst = [\ A ->] \ a -> \ b -> \ q -> [\ P ->] J [A] [\ x -> \ y -> \ p -> P x -> P y] (\ y -> \ p -> p) a b [q] +term ext : .[A : Set] -> .[B : A -> Set] -> .[f : (x : A) -> B x] -> .[g : (x : A) -> B x] -> (h : .[x : A] -> Id (B x) (f x) (g x)) -> Id ((x : A) -> B x) f g +{} +error during typechecking: +extReducesNot +/// new A : Set +/// new a : v0 +/// new f : (v0::Tm -> {A {a = v1, A = v0}}) +/// new p : (.[x : v0::Tm] -> Id A x (f x){f = (v2 Up (v0::Tm -> {A {a = v1, A = v0}})), a = v1, A = v0}) +/// checkExpr 4 |- refl : Id A a (subst [A -> A] (\ x -> x) (f ) (ext [A] [\ x -> A] [\ x -> x] [f ] (p x)) [\ x -> A] a) +/// checkForced fromList [(A,0),(a,1),(f,2),(p,3)] |- refl : Id A a (subst [A -> A] (\ x -> x) (f ) (ext [A] [\ x -> A] [\ x -> x] [f ] (p x)) [\ x -> A] a) +/// leqVal' (subtyping) < Id.refl : Id A a a > <=+ Id A a (subst [A -> A] (\ x -> x) (f ) (ext [A] [\ x -> A] [\ x -> x] [f ] (p x)) [\ x -> A] a) +/// leqVal' (subtyping) Id A a a <=+ Id A a (subst [A -> A] (\ x -> x) (f ) (ext [A] [\ x -> A] [\ x -> x] [f ] (p x)) [\ x -> A] a) +/// leqVal' a <=^ J (A -> A) (\ x -> \ y -> \ p -> A x -> A y) (\ y -> \ p -> p) (\ x -> x) (f ) (ext [A] [\ x -> A] [\ x -> x] [f ] (p x)) a : A +/// leqApp: head mismatch a != J diff --git a/test/fail/FunctionExtensionality.ma b/test/fail/FunctionExtensionality.ma new file mode 100644 --- /dev/null +++ b/test/fail/FunctionExtensionality.ma @@ -0,0 +1,32 @@ +-- 2012-03-07 chat with Nicolai Kraus + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} +check +fun subst : [A : Set] [a, b : A] [q : Id A a b] + [P : A -> Set] -> P a -> P b +{ subst A a .a refl P h = h +} + +fun J : [A : Set] [P : (a,b : A) -> Id A a b -> Set] + (h : (a : A) -> P a a refl) (a,b : A) [q : Id A a b] -> P a b q +{ J A P h a .a refl = h a +} + +-- defining subst from J +let subst [A : Set] (a, b : A) (q : Id A a b) + [P : A -> Set] : P a -> P b + = J A (\ x y p -> P x -> P y) (\ y p -> p) a b q + +-- extensionality axiom +fun ext : [A : Set] [B : A -> Set] [f, g : (x : A) -> B x] + (h : [x : A] -> Id (B x) (f x) (g x)) -> + Id ((x : A) -> B x) f g {} + +let extReducesNot [A : Set] [a : A] [f : A -> A] [p : [x : A] -> Id A x (f x)] : + Id A a (subst (A -> A) (\ x -> x) f + (ext A (\ x -> A) (\ x -> x) f p) + (\ x -> A) + a) + = refl diff --git a/test/fail/HOMatching.err b/test/fail/HOMatching.err new file mode 100644 --- /dev/null +++ b/test/fail/HOMatching.err @@ -0,0 +1,12 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "HOMatching.ma" --- +--- scope checking --- +--- type checking --- +type Succ : Set +term Succ.succ : ^(y0 : Succ) -> < Succ.succ y0 : Succ > +type homatch : (Succ -> Succ) -> Set +error during typechecking: +homatch +/// clause 1 +/// pattern succ +/// cannot resolve constructor succ diff --git a/test/fail/HOMatching.ma b/test/fail/HOMatching.ma new file mode 100644 --- /dev/null +++ b/test/fail/HOMatching.ma @@ -0,0 +1,15 @@ +data Succ : Set +{ succ : Succ -> Succ +} + +fun homatch : (Succ -> Succ) -> Set +{ homatch succ = Succ +} + +{- +data Lim (A : Set) : Set +{ lim : (A -> Lim A) -> Lim A +} + +fun bla : (A : Set) -> Lim A -> +-} diff --git a/test/fail/HetIdFoolingEta.err b/test/fail/HetIdFoolingEta.err new file mode 100644 --- /dev/null +++ b/test/fail/HetIdFoolingEta.err @@ -0,0 +1,31 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "HetIdFoolingEta.ma" --- +--- scope checking --- +--- type checking --- +ty-u Id : ^(A : Set) -> ^(a : A) -> ^(B : Set) -> ^ B -> Set 1 +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a A a > +error during typechecking: +offDia +/// not a type: (f : (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> Id A a B b) -> (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// inferExpr' (f : (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> Id A a B b) -> (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// new f : (.[A : Set] -> .[B : Set] -> (a : A) -> (b : B) -> Id A a B b) +/// inferExpr' (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// new A : Set +/// inferExpr' (B : Set) -> (a : A) -> (b : B) -> Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// new B : Set +/// inferExpr' (a : A) -> (b : B) -> Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// new a : v1 +/// inferExpr' (b : B) -> Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// new b : v2 +/// inferExpr' Id (Id A B a b) (f A B a b) (Id A a A a) (refl A a) +/// inferExpr' Id (Id A B a b) (f A B a b) (Id A a A a) +/// inferExpr' Id (Id A B a b) (f A B a b) +/// inferExpr' Id (Id A B a b) +/// checkApp (^(A : Set) -> ^(a : A) -> ^(B : Set) -> ^ B -> Set 1) eliminated by Id A B a b +/// inferExpr' Id A B a b +/// inferExpr' Id A B a +/// inferExpr' Id A B +/// checkApp (^(a : v1::Tm) -> ^(B : Set) -> ^ B -> Set 1{A = v1}) eliminated by B +/// leqVal' (subtyping) < B : Set > <=+ A +/// leqVal' (subtyping) Set <=+ A +/// leqApp: head mismatch Set != A diff --git a/test/fail/HetIdFoolingEta.ma b/test/fail/HetIdFoolingEta.ma new file mode 100644 --- /dev/null +++ b/test/fail/HetIdFoolingEta.ma @@ -0,0 +1,10 @@ +data Id (A : Set) (a : A) : (B : Set) -> B -> Set 1 +{ refl : Id A a A a +} + +-- this does not typecheck since f A a B b expands to *, not to refl +let offDia : (f : (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> Id A a B b) -> + (A : Set) -> (B : Set) -> (a : A) -> (b : B) -> + Id (Id A B a b) (f A B a b) + (Id A a A a) (refl A a) + = \ f -> \ A -> \ B -> \ a -> \ b -> refl (Id A a A a) (refl A a) diff --git a/test/fail/HungryEtaRecord.err b/test/fail/HungryEtaRecord.err new file mode 100644 --- /dev/null +++ b/test/fail/HungryEtaRecord.err @@ -0,0 +1,23 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "HungryEtaRecord.ma" --- +--- scope checking --- +--- type checking --- +type Hungry : -(i : Size) -> Set +term Hungry.inn : .[i : Size] -> ^(out : .[j < i] -> Hungry j) -> < Hungry.inn out : Hungry i > +term out : .[i : Size] -> (inn : Hungry i) -> .[j < i] -> Hungry j +{ out [i] (Hungry.inn #out) = #out +} +type D : .[i : Size] -> Hungry i -> Set +{} +error during typechecking: +unique +/// new i <= # +/// new x : (Hungry v0) +/// new y : (Hungry v0) +/// new d : (D v0 (v1 Up (Hungry v0))) +/// checkExpr 4 |- d : D i y +/// leqVal' (subtyping) < d : D i x > <=+ D i y +/// leqVal' (subtyping) D i x <=+ D i y +/// leqVal' x : Hungry i <=* y : Hungry i +/// leqVal' x : Hungry i <=* y : Hungry i +/// leqApp: head mismatch x != y diff --git a/test/fail/HungryEtaRecord.ma b/test/fail/HungryEtaRecord.ma new file mode 100644 --- /dev/null +++ b/test/fail/HungryEtaRecord.ma @@ -0,0 +1,13 @@ +-- 2012-02-07 + +-- a recursive unit type +record Hungry -(i : Size) : Set +{ inn (out : [j < i] -> Hungry j) +} fields out + +fun D : [i : Size] -> Hungry i -> Set {} + +let unique [i : Size] (x, y : Hungry i) (d : D i x) : D i y + = d +-- loops! because of infinite eta-expansion performed in equality testing +-- similar to recursive record problem diff --git a/test/fail/IdFoolingEta.err b/test/fail/IdFoolingEta.err new file mode 100644 --- /dev/null +++ b/test/fail/IdFoolingEta.err @@ -0,0 +1,29 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "IdFoolingEta.ma" --- +--- scope checking --- +--- type checking --- +type Id : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a a > +term subst : .[A : Set] -> (a : A) -> (b : A) -> Id A a b -> .[P : A -> Set] -> P a -> P b +{ subst [A] a .a Id.refl [P] x = x +} +error during typechecking: +offDia +/// checkExpr 0 |- \ f -> \ A -> \ a -> \ b -> refl : (f : .[A : Set] -> (a : A) -> (b : A) -> Id A a b) -> .[A : Set] -> (a : A) -> (b : A) -> Id (Id A a b) (f [A] a b) (subst [A] a b (f [A] a b) [Id A a] Id.refl) +/// checkForced fromList [] |- \ f -> \ A -> \ a -> \ b -> refl : (f : .[A : Set] -> (a : A) -> (b : A) -> Id A a b) -> .[A : Set] -> (a : A) -> (b : A) -> Id (Id A a b) (f [A] a b) (subst [A] a b (f [A] a b) [Id A a] Id.refl) +/// new f : (.[A : Set] -> (a : A) -> (b : A) -> Id A a b) +/// checkExpr 1 |- \ A -> \ a -> \ b -> refl : .[A : Set] -> (a : A) -> (b : A) -> Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// checkForced fromList [(f,0)] |- \ A -> \ a -> \ b -> refl : .[A : Set] -> (a : A) -> (b : A) -> Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// new A : Set +/// checkExpr 2 |- \ a -> \ b -> refl : (a : A) -> (b : A) -> Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// checkForced fromList [(A,1),(f,0)] |- \ a -> \ b -> refl : (a : A) -> (b : A) -> Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// new a : v1 +/// checkExpr 3 |- \ b -> refl : (b : A) -> Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// checkForced fromList [(A,1),(f,0),(a,2)] |- \ b -> refl : (b : A) -> Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// new b : v1 +/// checkExpr 4 |- refl : Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// checkForced fromList [(A,1),(f,0),(a,2),(b,3)] |- refl : Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// leqVal' (subtyping) < Id.refl : Id (Id A a b) (f A a b [A] a b) (f A a b [A] a b) > <=+ Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// leqVal' (subtyping) Id (Id A a b) (f A a b [A] a b) (f A a b [A] a b) <=+ Id (Id A a b) (f A a b [A] a b) (subst [A] a b (f A a b [A] a b) [Id A a] Id.refl) +/// leqVal' f A a b <=^ subst A a b (f A a b [A] a b) (Id A a) Id.refl : Id A a b +/// leqApp: head mismatch f != subst diff --git a/test/fail/IdFoolingEta.ma b/test/fail/IdFoolingEta.ma new file mode 100644 --- /dev/null +++ b/test/fail/IdFoolingEta.ma @@ -0,0 +1,16 @@ +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +fun subst : (A : Set) -> (a : A) -> (b : A) -> Id A a b -> + (P : A -> Set) -> P a -> P b +{ subst A a .a (refl) P x = x +} + +-- this does not typecheck since f A a b expands to * but subst blocks +let offDia : (f : (A : Set) -> (a : A) -> (b : A) -> Id A a b) -> + (A : Set) -> (a : A) -> (b : A) -> + Id (Id A a b) + (f A a b) + (subst A a b (f A a b) (Id A a) (refl)) + = \ f -> \ A -> \ a -> \ b -> refl {- (Id A a b) (subst A a b (f A a b) (Id A a) (refl A a)) -} diff --git a/test/fail/IllegalParameter.err b/test/fail/IllegalParameter.err new file mode 100644 --- /dev/null +++ b/test/fail/IllegalParameter.err @@ -0,0 +1,6 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "IllegalParameter.ma" --- +--- scope checking --- +scope check error: D +/// c +/// expression (\A -> A) is not valid in a parameter diff --git a/test/fail/IllegalParameter.ma b/test/fail/IllegalParameter.ma new file mode 100644 --- /dev/null +++ b/test/fail/IllegalParameter.ma @@ -0,0 +1,4 @@ +-- 2013-04-05 + +data D (F : Set -> Set) +{ c : D (\ A -> A) } diff --git a/test/fail/InconsistentHypotheses.err b/test/fail/InconsistentHypotheses.err new file mode 100644 --- /dev/null +++ b/test/fail/InconsistentHypotheses.err @@ -0,0 +1,10 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "InconsistentHypotheses.ma" --- +--- scope checking --- +--- type checking --- +type f : .[i : Size] -> .[j < i] -> |i| < |j| -> Set +error during typechecking: +f +/// clause 1 +/// adding size rel. v0 + 1 <= v1 +/// cannot add hypothesis v0 + 1 <= v1 because it makes the set of hyptheses unsatisfiable diff --git a/test/fail/InconsistentHypotheses.ma b/test/fail/InconsistentHypotheses.ma new file mode 100644 --- /dev/null +++ b/test/fail/InconsistentHypotheses.ma @@ -0,0 +1,3 @@ +-- 2013-04-04 This should not termination check: +fun f : [i : Size] |i| [j < i] -> |i| < |j| -> Set +{ f i j = f j i } diff --git a/test/fail/InjDataLoop.err b/test/fail/InjDataLoop.err new file mode 100644 --- /dev/null +++ b/test/fail/InjDataLoop.err @@ -0,0 +1,28 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "InjDataLoop.ma" --- +--- scope checking --- +--- type checking --- +type Empty : Set +type Eq : .[i : Size] -> ^(A : Set i) -> ^(a : A) -> ^ A -> Set +term Eq.refl : .[i : Size] -> .[A : Set i] -> .[a : A] -> < Eq.refl : Eq [i] A a a > +type I : ^(F : Set -> Set) -> Set +ty-u InvI : ^(A : Set) -> Set 1 +term InvI.inv : .[A : Set] -> ^(Inverse : Set -> Set) -> ^(y1 : Eq [1] Set (I Inverse) A) -> < InvI.inv Inverse y1 : InvI A > +tmty invertible : (A : Set) -> InvI A +{} +type cantor : Set -> Set +type cantor = \ A -> case invertible A : InvI A + { InvI.inv X p -> X A -> Empty + } +type cIc : Set +type cIc = cantor (I cantor) +error during typechecking: +delta +/// checkExpr 0 |- case invertible (I cantor) + { inv .cantor refl -> \ f -> f f + } : case invertible (I cantor) : InvI (I cantor) + { InvI.inv X p -> X (I cantor) -> Empty + } +/// case 1 +/// dot pattern Just cantor +/// not instantiated diff --git a/test/fail/InjDataLoop.ma b/test/fail/InjDataLoop.ma new file mode 100644 --- /dev/null +++ b/test/fail/InjDataLoop.ma @@ -0,0 +1,47 @@ +{- 2010-01-15 + +Non-termination from inconsistency and injectivity of data type constructors +by the use of smart case. + +2010-06-25 Switching to predicative polymorphism +-} + +data Empty : Set {} + +data Eq [i : Size](A : Set i)(a : A) : A -> Set +{ refl : Eq i A a a +} + +data I (F : Set -> Set) : Set {} + +data InvI (A : Set) : Set 1 +{ inv : (Inverse : Set -> Set) -> Eq 1 Set (I Inverse) A -> InvI A +} + +fun invertible : (A : Set) -> InvI A {} -- postulate + +-- self-application on the type level +let cantor : Set -> Set += \ A -> case (invertible A) + { (inv X p) -> X A -> Empty + } + +let cIc : Set + = cantor (I cantor) + +-- type checker loops! +let delta : cIc += case (invertible (I cantor)) + { (inv {-.(I cantor)-} .cantor (refl {-.1 .Set .(I cantor)-})) -> + -- in the branch, cIc --> cIc -> Empty --> (cIc -> Empty) -> Empty -->... + \ f -> f f + } + +let delta' : cIc -> Empty += case (invertible (I cantor)) + { (inv {-.(I cantor)-} .cantor (refl {-.Set .(I cantor)-})) -> + \ f -> f f + } + +let omega : Empty + = delta' delta diff --git a/test/fail/InjDataLoop2.err b/test/fail/InjDataLoop2.err new file mode 100644 --- /dev/null +++ b/test/fail/InjDataLoop2.err @@ -0,0 +1,30 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "InjDataLoop2.ma" --- +--- scope checking --- +--- type checking --- +type Empty : Set +type Eq : .[i : Size] -> ^(A : Set i) -> ^(a : A) -> ^ A -> Set +term Eq.refl : .[i : Size] -> .[A : Set i] -> .[a : A] -> < Eq.refl : Eq [i] A a a > +type I : ^(F : Set -> Set) -> Set +ty-u InvI : ^(A : Set) -> Set 1 +term InvI.inv : .[A : Set] -> ^(Inverse : Set -> Set) -> ^(isInverse : Eq [1] Set (I Inverse) A) -> < InvI.inv Inverse isInverse : InvI A > +type Inverse : .[A : Set] -> (inv : InvI A) -> Set -> Set +{ Inverse [A] (InvI.inv #Inverse #isInverse) = #Inverse +} +term isInverse : .[A : Set] -> (inv : InvI A) -> Eq [1] Set (I (Inverse [A] inv)) A +{ isInverse [A] (InvI.inv #Inverse #isInverse) = #isInverse +} +tmty invertible : (A : Set) -> InvI A +{} +type cantor : Set -> Set +type cantor = \ A -> Inverse (invertible A) A -> Empty +type cIc : Set +type cIc = cantor (I cantor) +error during typechecking: +delta +/// checkExpr 0 |- case invertible (I cantor) : InvI (I cantor) + { inv .cantor refl -> \ f -> f f + } : invertible (I cantor) .Inverse (I cantor) -> Empty +/// case 1 +/// dot pattern Just cantor +/// not instantiated diff --git a/test/fail/InjDataLoop2.ma b/test/fail/InjDataLoop2.ma new file mode 100644 --- /dev/null +++ b/test/fail/InjDataLoop2.ma @@ -0,0 +1,50 @@ +{- 2010-01-15 + +Non-termination from inconsistency and injectivity of data type constructors +by the use of smart case. + +2010-06-25 Switching to predicative polymorphism +-} + +data Empty : Set {} + +data Eq [i : Size](A : Set i)(a : A) : A -> Set +{ refl : Eq i A a a +} + +data I (F : Set -> Set) : Set {} + +data InvI (A : Set) : Set 1 +{ inv : (Inverse : Set -> Set) -> + (isInverse : Eq 1 Set (I Inverse) A) -> + InvI A +} +fields Inverse, isInverse + +fun invertible : (A : Set) -> InvI A {} -- postulate + +-- self-application on the type level +let cantor : Set -> Set += \ A -> Inverse (invertible A) A -> Empty + -- not using smart case here, gives a different message + +let cIc : Set + = cantor (I cantor) + +-- type checker loops! +let delta : cIc += case (invertible (I cantor)) : InvI (I cantor) + { (inv .cantor refl) -> + -- in the branch, cIc --> cIc -> Empty --> (cIc -> Empty) -> Empty -->... + \ f -> f f + } +-- HERE, one gets error "dot pattern cantor not instantiated" + +let delta' : cIc -> Empty += case (invertible (I cantor)) + { (inv .cantor refl) -> + \ f -> f f + } + +let omega : Empty + = delta' delta diff --git a/test/fail/InvalidField.err b/test/fail/InvalidField.err new file mode 100644 --- /dev/null +++ b/test/fail/InvalidField.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "InvalidField.ma" --- +--- scope checking --- +scope check error: D +/// record field f unknown diff --git a/test/fail/InvalidField.ma b/test/fail/InvalidField.ma new file mode 100644 --- /dev/null +++ b/test/fail/InvalidField.ma @@ -0,0 +1,1 @@ +data D : Set { c : D } fields f diff --git a/test/fail/InvalidSizeP.err b/test/fail/InvalidSizeP.err new file mode 100644 --- /dev/null +++ b/test/fail/InvalidSizeP.err @@ -0,0 +1,22 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "InvalidSizeP.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term test : .[i : Size] -> SNat i -> SNat i -> SNat i +error during typechecking: +test +/// clause 1 +/// pattern succ (l < k) y +/// pattern l < k +/// new l < v0 +/// adding size rel. v3 + 1 <= v0 +/// adding size rel. v3 + 1 <= v1 +/// leqVal' (subtyping) < i <=+ < k +/// leSize i <=+ k +/// leSize' i <= k +/// bound not entailed diff --git a/test/fail/InvalidSizeP.ma b/test/fail/InvalidSizeP.ma new file mode 100644 --- /dev/null +++ b/test/fail/InvalidSizeP.ma @@ -0,0 +1,14 @@ +-- bug reported by David Thibodeau, Nov 2011 +-- fixed 2012-01-24 + +sized data SNat : Size -> Set +{ zero : (i : Size) -> SNat ($ i) +; succ : (i : Size) -> SNat i -> SNat ($ i) +} + +-- the following should fail: + +fun test : [i : Size] -> SNat i -> SNat i -> SNat i +{ test i (succ (i > k) x) (succ (k > l) y) = test i (succ l y) (succ k x) +} +-- the second successor pattern has not the correct upper bound (k instead i) diff --git a/test/fail/IrrHeterogeneousEta.err b/test/fail/IrrHeterogeneousEta.err new file mode 100644 --- /dev/null +++ b/test/fail/IrrHeterogeneousEta.err @@ -0,0 +1,97 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "IrrHeterogeneousEta.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type T : Bool -> Set +{ T Bool.true = Bool -> Bool +; T Bool.false = Bool +} +block fails as expected, error message: +etaFun' +/// checkExpr 0 |- \ F -> \ g -> \ h -> g (h true) : .[F : .[b : Bool] -> (T b -> T b) -> Bool -> Set] -> (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> \ y -> x y) a) -> Bool +/// checkForced fromList [] |- \ F -> \ g -> \ h -> g (h true) : .[F : .[b : Bool] -> (T b -> T b) -> Bool -> Set] -> (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> \ y -> x y) a) -> Bool +/// new F : (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set) +/// checkExpr 1 |- \ g -> \ h -> g (h true) : (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> \ y -> x y) a) -> Bool +/// checkForced fromList [(F,0)] |- \ g -> \ h -> g (h true) : (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> \ y -> x y) a) -> Bool +/// new g : ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}} {Bool.true {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}}) +/// checkExpr 2 |- \ h -> g (h true) : (h : (a : Bool) -> F Bool.true (\ x -> \ y -> x y) a) -> Bool +/// checkForced fromList [(g,1),(F,0)] |- \ h -> g (h true) : (h : (a : Bool) -> F Bool.true (\ x -> \ y -> x y) a) -> Bool +/// new h : ((a : Bool::Tm) -> F [Bool.true] (\ x -> \ y -> x y) a{g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}} {Bool.true {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}) +/// checkExpr 3 |- g (h true) : Bool +/// inferExpr' g (h true) +/// checkApp ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}} {Bool.true {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Bool -> Set))}}) eliminated by h true +/// leqVal' (subtyping) < h a Bool.true : F Bool.true (\ x -> \ y -> x y) Bool.true > <=+ F Bool.false (\ x -> x) Bool.true +/// leqVal' (subtyping) F Bool.true (\ x -> \ y -> x y) Bool.true <=+ F Bool.false (\ x -> x) Bool.true +/// leqVal' x y : (Bool -> Bool) -> Bool -> Bool <=* x : Bool -> Bool +/// new x : (Bool::Tm -> Bool)||Bool +/// leqVal' x y : Bool -> Bool <=* x : Bool +/// type (Bool::Tm -> Bool) has different shape than Bool +block fails as expected, error message: +etaFun +/// checkExpr 0 |- \ F -> \ g -> \ a -> g a : .[F : .[b : Bool] -> (T b -> T b) -> Set] -> (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> \ y -> x y)) -> Bool +/// checkForced fromList [] |- \ F -> \ g -> \ a -> g a : .[F : .[b : Bool] -> (T b -> T b) -> Set] -> (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> \ y -> x y)) -> Bool +/// new F : (.[b : Bool::Tm] -> (T b -> T b) -> Set) +/// checkExpr 1 |- \ g -> \ a -> g a : (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> \ y -> x y)) -> Bool +/// checkForced fromList [(F,0)] |- \ g -> \ a -> g a : (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> \ y -> x y)) -> Bool +/// new g : ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}}) +/// checkExpr 2 |- \ a -> g a : (a : F Bool.true (\ x -> \ y -> x y)) -> Bool +/// checkForced fromList [(g,1),(F,0)] |- \ a -> g a : (a : F Bool.true (\ x -> \ y -> x y)) -> Bool +/// new a : (v0 {Bool.true {g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}} {\ x -> \ y -> x y {g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}}) +/// checkExpr 3 |- g a : Bool +/// inferExpr' g a +/// checkApp ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Set))}}) eliminated by a +/// leqVal' (subtyping) < a : F Bool.true (\ x -> \ y -> x y) > <=+ F Bool.false (\ x -> x) +/// leqVal' (subtyping) F Bool.true (\ x -> \ y -> x y) <=+ F Bool.false (\ x -> x) +/// leqVal' x y : (Bool -> Bool) -> Bool -> Bool <=* x : Bool -> Bool +/// new x : (Bool::Tm -> Bool)||Bool +/// leqVal' x y : Bool -> Bool <=* x : Bool +/// type (Bool::Tm -> Bool) has different shape than Bool +type U : Bool -> Set +{ U Bool.true = Unit +; U Bool.false = Bool +} +block fails as expected, error message: +etaUnit' +/// checkExpr 0 |- \ F -> \ g -> \ h -> g (h true) : .[F : .[b : Bool] -> (U b -> U b) -> Bool -> Set] -> (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> Unit.unit) a) -> Bool +/// checkForced fromList [] |- \ F -> \ g -> \ h -> g (h true) : .[F : .[b : Bool] -> (U b -> U b) -> Bool -> Set] -> (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> Unit.unit) a) -> Bool +/// new F : (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set) +/// checkExpr 1 |- \ g -> \ h -> g (h true) : (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> Unit.unit) a) -> Bool +/// checkForced fromList [(F,0)] |- \ g -> \ h -> g (h true) : (g : F Bool.false (\ x -> x) Bool.true -> Bool) -> (h : (a : Bool) -> F Bool.true (\ x -> Unit.unit) a) -> Bool +/// new g : ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}} {Bool.true {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}}) +/// checkExpr 2 |- \ h -> g (h true) : (h : (a : Bool) -> F Bool.true (\ x -> Unit.unit) a) -> Bool +/// checkForced fromList [(g,1),(F,0)] |- \ h -> g (h true) : (h : (a : Bool) -> F Bool.true (\ x -> Unit.unit) a) -> Bool +/// new h : ((a : Bool::Tm) -> F [Bool.true] (\ x -> Unit.unit) a{g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}} {Bool.true {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}) +/// checkExpr 3 |- g (h true) : Bool +/// inferExpr' g (h true) +/// checkApp ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}} {Bool.true {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Bool -> Set))}}) eliminated by h true +/// leqVal' (subtyping) < h a Bool.true : F Bool.true (\ x -> Unit.unit) Bool.true > <=+ F Bool.false (\ x -> x) Bool.true +/// leqVal' (subtyping) F Bool.true (\ x -> Unit.unit) Bool.true <=+ F Bool.false (\ x -> x) Bool.true +/// leqVal' Unit.unit : Unit -> Unit <=* x : Bool -> Bool +/// new x : Unit||Bool +/// leqVal' Unit.unit : Unit <=* x : Bool +/// type Unit has different shape than Bool +error during typechecking: +etaUnit +/// checkExpr 0 |- \ F -> \ g -> \ a -> g a : .[F : .[b : Bool] -> (U b -> U b) -> Set] -> (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> Unit.unit)) -> Bool +/// checkForced fromList [] |- \ F -> \ g -> \ a -> g a : .[F : .[b : Bool] -> (U b -> U b) -> Set] -> (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> Unit.unit)) -> Bool +/// new F : (.[b : Bool::Tm] -> (U b -> U b) -> Set) +/// checkExpr 1 |- \ g -> \ a -> g a : (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> Unit.unit)) -> Bool +/// checkForced fromList [(F,0)] |- \ g -> \ a -> g a : (g : F Bool.false (\ x -> x) -> Bool) -> (a : F Bool.true (\ x -> Unit.unit)) -> Bool +/// new g : ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}}) +/// checkExpr 2 |- \ a -> g a : (a : F Bool.true (\ x -> Unit.unit)) -> Bool +/// checkForced fromList [(g,1),(F,0)] |- \ a -> g a : (a : F Bool.true (\ x -> Unit.unit)) -> Bool +/// new a : (v0 {Bool.true {g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}} {\ x -> Unit.unit {g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}}) +/// checkExpr 3 |- g a : Bool +/// inferExpr' g a +/// checkApp ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}} {\ x -> x {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (U b -> U b) -> Set))}}) eliminated by a +/// leqVal' (subtyping) < a : F Bool.true (\ x -> Unit.unit) > <=+ F Bool.false (\ x -> x) +/// leqVal' (subtyping) F Bool.true (\ x -> Unit.unit) <=+ F Bool.false (\ x -> x) +/// leqVal' Unit.unit : Unit -> Unit <=* x : Bool -> Bool +/// new x : Unit||Bool +/// leqVal' Unit.unit : Unit <=* x : Bool +/// type Unit has different shape than Bool diff --git a/test/fail/IrrHeterogeneousEta.ma b/test/fail/IrrHeterogeneousEta.ma new file mode 100644 --- /dev/null +++ b/test/fail/IrrHeterogeneousEta.ma @@ -0,0 +1,82 @@ +-- 2010-10-09 + +-- an example with different types in context during eq. checking +-- derived from Ulf's counterexample + +data Unit : Set +{ unit : Unit +} + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun T : Bool -> Set +{ T true = Bool -> Bool +; T false = Bool +} + +-- fails with "Bool -> Bool has different shape than Bool" +fail +let etaFun' : + [F : [b : Bool] -> (T b -> T b) -> Bool -> Set] -> + (g : F false (\ x -> x) true -> Bool) -> + (h : (a : Bool) -> F true (\ x y -> x y) a) -> + Bool + = \ F g h -> g (h true) +-- but succeeds in ICC + +{- compares (cannot eta-expand lhs!) + + F false (\ x -> x) true ?= F true (\ x y -> x y) true + x : Bool |- x : Bool ?= x : Bool -> Bool |- \ y -> x y : Bool -> Bool + +-} + +fail +let etaFun : + [F : [b : Bool] -> (T b -> T b) -> Set] -> + (g : F false (\ x -> x) -> Bool) -> + (a : F true (\ x y -> x y)) -> + Bool + = \ F g a -> g a + +{- compares (cannot eta-expand lhs!) + + F false (\ x -> x) true ?= F true (\ x y -> x y) true + x : Bool |- x : Bool ?= x : Bool -> Bool |- \ y -> x y : Bool -> Bool + + works with eta-contraction, but... +-} + +fun U : Bool -> Set +{ U true = Unit +; U false = Bool +} + +fail +let etaUnit' : + [F : [b : Bool] -> (U b -> U b) -> Bool -> Set] -> + (g : F false (\ x -> x) true -> Bool) -> + (h : (a : Bool) -> F true (\ x -> unit) a) -> + Bool + = \ F g h -> g (h true) + +{- + F false (\ x -> x) true ?= F true (\ x -> unit) true + x : Bool |- x : Bool ?= x : Unit |- unit : Unit +-} + +let etaUnit : + [F : [b : Bool] -> (U b -> U b) -> Set] -> + (g : F false (\ x -> x) -> Bool) -> + (a : F true (\ x -> unit)) -> + Bool + = \ F g a -> g a + +{- + F false (\ x -> x) true ?= F true (\ x -> unit) true + x : Bool |- x : Bool ?= x : Unit |- unit : Unit +-} + diff --git a/test/fail/IrrHeterogeneousFun.err b/test/fail/IrrHeterogeneousFun.err new file mode 100644 --- /dev/null +++ b/test/fail/IrrHeterogeneousFun.err @@ -0,0 +1,47 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "IrrHeterogeneousFun.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type T : Bool -> Set +{ T Bool.true = Nat +; T Bool.false = Bool +} +term good : .[F : Nat -> Set] -> .[f : .[b : Bool] -> (.[T b] -> Nat) -> Nat] -> (g : (n : Nat) -> F (f [Bool.true] ([\ x ->] n))) -> (h : F (f [Bool.false] ([\ x ->] Nat.zero)) -> Bool) -> Bool +{ good [F] [f] g h = h (g Nat.zero) +} +term good' : .[F : .[b : Bool] -> (.[T b] -> Nat) -> Set] -> (g : F [Bool.false] ([\ x ->] Nat.zero) -> Bool) -> (h : (n : Nat) -> F [Bool.true] ([\ x ->] n)) -> Bool +term good' = [\ F ->] \ g -> \ h -> g (h Nat.zero) +warning: ignoring error: type Nat has different shape than Bool +term bad1 : .[F : .[b : Bool] -> (T b -> T b) -> Nat -> Set] -> (g : F [Bool.false] (\ x -> x) Nat.zero -> Bool) -> (h : (n : Nat) -> F [Bool.true] (\ x -> x) n) -> Bool +term bad1 = [\ F ->] \ g -> \ h -> g (h Nat.zero) +term f : (b : Bool) -> T b -> T b +{ f Bool.true x = x +; f Bool.false Bool.true = Bool.false +; f Bool.false Bool.false = Bool.true +} +error during typechecking: +bad2 +/// checkExpr 0 |- \ F -> \ g -> \ h -> g (h zero) : .[F : .[b : Bool] -> (T b -> T b) -> Nat -> Set] -> (g : F Bool.false (\ x -> f Bool.false x) Nat.zero -> Bool) -> (h : (n : Nat) -> F Bool.true (\ x -> f Bool.true x) n) -> Bool +/// checkForced fromList [] |- \ F -> \ g -> \ h -> g (h zero) : .[F : .[b : Bool] -> (T b -> T b) -> Nat -> Set] -> (g : F Bool.false (\ x -> f Bool.false x) Nat.zero -> Bool) -> (h : (n : Nat) -> F Bool.true (\ x -> f Bool.true x) n) -> Bool +/// new F : (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set) +/// checkExpr 1 |- \ g -> \ h -> g (h zero) : (g : F Bool.false (\ x -> f Bool.false x) Nat.zero -> Bool) -> (h : (n : Nat) -> F Bool.true (\ x -> f Bool.true x) n) -> Bool +/// checkForced fromList [(F,0)] |- \ g -> \ h -> g (h zero) : (g : F Bool.false (\ x -> f Bool.false x) Nat.zero -> Bool) -> (h : (n : Nat) -> F Bool.true (\ x -> f Bool.true x) n) -> Bool +/// new g : ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}} {\ x -> f Bool.false x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}} {Nat.zero {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}}) +/// checkExpr 2 |- \ h -> g (h zero) : (h : (n : Nat) -> F Bool.true (\ x -> f Bool.true x) n) -> Bool +/// checkForced fromList [(g,1),(F,0)] |- \ h -> g (h zero) : (h : (n : Nat) -> F Bool.true (\ x -> f Bool.true x) n) -> Bool +/// new h : ((n : Nat::Tm) -> F [Bool.true] (\ x -> f Bool.true x) n{g = (v1 Up ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}} {\ x -> f Bool.false x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}} {Nat.zero {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}})), F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}) +/// checkExpr 3 |- g (h zero) : Bool +/// inferExpr' g (h zero) +/// checkApp ((v0 {Bool.false {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}} {\ x -> f Bool.false x {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}} {Nat.zero {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}})::Tm -> {Bool {F = (v0 Up (.[b : Bool::Tm] -> (T b -> T b) -> Nat -> Set))}}) eliminated by h zero +/// leqVal' (subtyping) < h n Nat.zero : F Bool.true (\ x -> f Bool.true x) Nat.zero > <=+ F Bool.false (\ x -> f Bool.false x) Nat.zero +/// leqVal' (subtyping) F Bool.true (\ x -> f Bool.true x) Nat.zero <=+ F Bool.false (\ x -> f Bool.false x) Nat.zero +/// leqVal' x : Nat -> Nat <=* f Bool.false x : Bool -> Bool +/// new x : Nat||Bool +/// leqVal' x : Nat <=* f Bool.false x : Bool +/// type Nat has different shape than Bool diff --git a/test/fail/IrrHeterogeneousFun.ma b/test/fail/IrrHeterogeneousFun.ma new file mode 100644 --- /dev/null +++ b/test/fail/IrrHeterogeneousFun.ma @@ -0,0 +1,65 @@ +-- 2010-10-01 + +-- an example with different types in context during eq. checking +-- derived from Ulf's counterexample + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun T : Bool -> Set +{ T true = Nat +; T false = Bool +} + +fun good : + [F : Nat -> Set] -> + [f : [b : Bool] -> ([T b] -> Nat) -> Nat] -> + (g : (n : Nat) -> F (f true (\ x -> n))) -> + (h : F (f false (\ x -> zero)) -> Bool) -> + Bool +{ good F f g h = h (g zero) +} + +let good' : + [F : [b : Bool] -> ([T b] -> Nat) -> Set] -> + (g : F false (\ x -> zero) -> Bool) -> + (h : (n : Nat) -> F true (\ x -> n)) -> + Bool + = \ F g h -> g (h zero) + +-- fails with "Nat has different shape than Bool" +trustme +let bad1 : + [F : [b : Bool] -> (T b -> T b) -> Nat -> Set] -> + (g : F false (\ x -> x) zero -> Bool) -> + (h : (n : Nat) -> F true (\ x -> x) n) -> + Bool + = \ F g h -> g (h zero) + +{- compare + F false (\ x -> x) zero ?= F true (\ x -> x) zero + x : Bool |- x : Bool ?= x : Nat |- x : Nat +-} + +fun f : (b : Bool) -> T b -> T b +{ f true x = x +; f false true = false +; f false false = true +} + +-- this should of course fail +let bad2 : + [F : [b : Bool] -> (T b -> T b) -> Nat -> Set] -> + (g : F false (\ x -> f false x) zero -> Bool) -> + (h : (n : Nat) -> F true (\ x -> f true x) n) -> + Bool + = \ F g h -> g (h zero) + + diff --git a/test/fail/Makefile b/test/fail/Makefile new file mode 100644 --- /dev/null +++ b/test/fail/Makefile @@ -0,0 +1,101 @@ +# MiniAgda +# Makefile for failing tests +# Author: Andreas Abel +# Created: 2004-12-06, 2008-09-03 + +# How this file works +# =================== +# +# Whenever a .ma file is modified, +# a corresponding .err file is generated to save the model error message +# for this file. When the test suite is processed the next time, e.g., +# after some hacking on the MiniAgda implementation, the new error message +# is compared to the saved one. If they do not match, this is considered +# an error. Then one has to verify the new error message is actually the +# intended one (manually), and remove the .err file. + +mugda=../../Main + +# Enable read -n +SHELL=bash + +# Getting all agda files +allagda=$(shell find . -name '*.ma') +allstems=$(patsubst %.ma,%,$(allagda)) +allout=$(patsubst %.ma,%.err,$(allagda)) + +.PHONY : $(allstems) + +default : all +all : $(allstems) + +debug : + @echo $(allagda) + +# No error recorded + +$(allout) : %.err : %.ma + @echo "----------------------------------------------------------------------" + @echo "$*.ma" + @echo "----------------------------------------------------------------------" + @if $(mugda) $(shell if [ -e $*.flags ]; then cat $*.flags; fi) $< > $*.tmp; \ + then echo "Unexpected success"; rm -f $*.tmp; false; \ + else if [ -s $*.tmp ]; \ + then sed -e "s/[^ ]*test.fail.//g" $*.tmp > $@; cat $@; rm -f $*.tmp; true; \ + else rm -f $@ $*.tmp; false; \ + fi; \ + fi + +# Existing error + + +# echo `cat $*.err` > $*.tmp.2; \ +# echo `cat $*.tmp` > $*.tmp.3; \ + +# NO WITH SPACES AFTER \ AT END OF LINE + +$(allstems) : % : %.err + @echo "----------------------------------------------------------------------" + @echo "$*.ma" + @echo "----------------------------------------------------------------------" + @if $(mugda) $(shell if [ -e $*.flags ]; then cat $*.flags; fi) $*.ma \ + > $*.tmp.2; \ + then echo "Unexpected success"; rm -f $*.tmp.2; false; \ + else sed -e "s/[^ ]*test.fail.//g" $*.tmp.2 > $*.tmp; \ + echo `tail -1 $*.err` > $*.tmp.2; \ + echo `tail -1 $*.tmp` > $*.tmp.3; \ + true; \ + fi; + @if cmp $*.tmp.2 $*.tmp.3; \ + then if cmp $*.tmp $*.err; \ + then rm -f $*.tmp $*.tmp.2 $*.tmp.3; true; \ + else mv $*.tmp $*.err; \ + rm -f $*.tmp.2 $*.tmp.3; true; \ + fi; \ + else echo "== Old error ==="; \ + cat $*.err; \ + echo "== New error ==="; \ + cat $*.tmp; \ + /bin/echo -n "Accept new error [y/N]? "; \ + read -n 1; \ + echo ""; \ + if [ "fckShPrg$$REPLY" != "fckShPrgy" ]; \ + then echo "Keeping old error"; false; \ + else echo "Replacing error, continuing..."; \ + mv $*.tmp $*.err; \ + rm -f $*.tmp.2 $*.tmp.3; true; \ + fi; \ + fi + +# CAUTION: NO SPACE AFTER \ +# RETARDED!!!!!!! + +# echo rm -f $*.tmp; echo rm -f $*.tmp.2; \ +# false; + +# Clean + +clean : + -rm -f *.err *.tmp *.tmp.* *~ adm/*.err adm/*.tmp* + +# EOF diff --git a/test/fail/MeasureInTelescope.err b/test/fail/MeasureInTelescope.err new file mode 100644 --- /dev/null +++ b/test/fail/MeasureInTelescope.err @@ -0,0 +1,3 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MeasureInTelescope.ma" --- +--- scope checking --- diff --git a/test/fail/MeasureInTelescope.ma b/test/fail/MeasureInTelescope.ma new file mode 100644 --- /dev/null +++ b/test/fail/MeasureInTelescope.ma @@ -0,0 +1,4 @@ +-- 2012-01-12 + +let [i : Size] |i| = i +-- should give a parse or scope checking error diff --git a/test/fail/MeasureInValue.err b/test/fail/MeasureInValue.err new file mode 100644 --- /dev/null +++ b/test/fail/MeasureInValue.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MeasureInValue.ma" --- +--- scope checking --- +scope check error: f +/// measure not allowed in expression (|i| -> CoSet 0) diff --git a/test/fail/MeasureInValue.ma b/test/fail/MeasureInValue.ma new file mode 100644 --- /dev/null +++ b/test/fail/MeasureInValue.ma @@ -0,0 +1,10 @@ +-- 2010-07-17 + +-- measures can only appear in fun-decls +-- caught by the scope-checker + +fun f : (i,j : Size) -> |i| -> Set 1 +{ f i j = |i| -> Set +} + + diff --git a/test/fail/MeasuresTypo.err b/test/fail/MeasuresTypo.err new file mode 100644 --- /dev/null +++ b/test/fail/MeasuresTypo.err @@ -0,0 +1,26 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MeasuresTypo.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type N : Set +term N.zz : < N.zz : N > +term N.ss : ^(y0 : N) -> < N.ss y0 : N > +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +term even : .[i : Size] -> Nat i -> Bool +term even' : .[i : Size] -> Nat i -> Bool +term odd' : .[i : Size] -> Nat i -> Bool +error during typechecking: +even' +/// clause 2 +/// right hand side +/// checkExpr 3 |- odd' i n : Bool +/// inferExpr' odd' i n +/// checkGuard |i,0| < |i,0| +/// lexSizes: no descent detected diff --git a/test/fail/MeasuresTypo.ma b/test/fail/MeasuresTypo.ma new file mode 100644 --- /dev/null +++ b/test/fail/MeasuresTypo.ma @@ -0,0 +1,33 @@ +-- 2010-07-26 explicit measures + +data Bool : Set +{ true : Bool +; false : Bool +} + +data N : Set +{ zz : N +; ss : N -> N +} + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +mutual { + + fun even : [i : Size] -> |i,$0| -> Nat i -> Bool + { even i n = even' i n + } + + fun even' : [i : Size] -> |i,0| -> Nat i -> Bool + { even' i (zero (i > j)) = true + ; even' i (succ (i > j) n) = odd' i n -- typo here, should be j + } + + fun odd' : [i : Size] -> |i,0| -> Nat i -> Bool + { odd' i (zero (i > j)) = false + ; odd' i (succ (i > j) n) = even j n + } +} diff --git a/test/fail/MixedMeasureLength.err b/test/fail/MixedMeasureLength.err new file mode 100644 --- /dev/null +++ b/test/fail/MixedMeasureLength.err @@ -0,0 +1,4 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MixedMeasureLength.ma" --- +--- scope checking --- +scope check error: in a mutual function block, either all functions must be without measure or have a measure of the same length diff --git a/test/fail/MixedMeasureLength.ma b/test/fail/MixedMeasureLength.ma new file mode 100644 --- /dev/null +++ b/test/fail/MixedMeasureLength.ma @@ -0,0 +1,10 @@ +-- 2010-07-17 + +-- measured functions need to have the same length measure +-- caught by the scope-checker + +mutual { + fun f : (i,j : Size) -> |i| -> Set {} + fun g : (i,j : Size) -> |i,j| -> Set {} +} + diff --git a/test/fail/MixedMeasuredUnmeasured.err b/test/fail/MixedMeasuredUnmeasured.err new file mode 100644 --- /dev/null +++ b/test/fail/MixedMeasuredUnmeasured.err @@ -0,0 +1,4 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MixedMeasuredUnmeasured.ma" --- +--- scope checking --- +scope check error: in a mutual function block, either all functions must be without measure or have a measure of the same length diff --git a/test/fail/MixedMeasuredUnmeasured.ma b/test/fail/MixedMeasuredUnmeasured.ma new file mode 100644 --- /dev/null +++ b/test/fail/MixedMeasuredUnmeasured.ma @@ -0,0 +1,10 @@ +-- 2010-07-17 + +-- mixing measured functions with unmeasured is illegal, +-- caught by the scope-checker + +mutual { + fun f : (i : Size) -> |i| -> Set {} + fun g : (i : Size) -> Set {} +} + diff --git a/test/fail/MuOnlyPosNotSPos.err b/test/fail/MuOnlyPosNotSPos.err new file mode 100644 --- /dev/null +++ b/test/fail/MuOnlyPosNotSPos.err @@ -0,0 +1,19 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MuOnlyPosNotSPos.ma" --- +--- scope checking --- +--- type checking --- +type Mu : ++(F : + Set -> Set) -> Set +error during typechecking: +Mu +/// constructor Mu.inn +/// new Mu : (++(F : (+Set -> Set)::Set) -> Set) +/// new F : (+Set -> {Set {Mu = (v0 Up (++(F : (+Set -> Set)::Set) -> Set))}}) +/// inferExpr' ^ F (Mu F) -> Mu F +/// inferExpr' F (Mu F) +/// checkApp (+Set -> {Set {Mu = (v0 Up (++(F : (+Set -> Set)::Set) -> Set))}}) eliminated by Mu F +/// inferExpr' Mu F +/// checkApp (++(F : (+Set -> Set)::Set) -> Set) eliminated by F +/// inferExpr' F +/// inferExpr: variable F : + Set -> Set may not occur +/// , because of polarity +/// polarity check ++ <= + failed diff --git a/test/fail/MuOnlyPosNotSPos.ma b/test/fail/MuOnlyPosNotSPos.ma new file mode 100644 --- /dev/null +++ b/test/fail/MuOnlyPosNotSPos.ma @@ -0,0 +1,6 @@ +-- 2010-06-20 + +-- F needs to be ++ (spos) not just pos +data Mu ++(F : +Set -> Set) : Set +{ inn : F (Mu F) -> Mu F +} diff --git a/test/fail/MustBeCofun.err b/test/fail/MustBeCofun.err new file mode 100644 --- /dev/null +++ b/test/fail/MustBeCofun.err @@ -0,0 +1,13 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MustBeCofun.ma" --- +--- scope checking --- +--- type checking --- +type CoList : ^(A : Set) -> - Size -> Set +term CoList.conil : .[A : Set] -> .[i : Size] -> < CoList.conil i : CoList A $i > +term CoList.cocons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : CoList A i) -> < CoList.cocons i y1 y2 : CoList A $i > +term repeat : .[A : Set] -> (a : A) -> .[i : Size] -> CoList A i +error during typechecking: +repeat +/// clause 1 +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/MustBeCofun.ma b/test/fail/MustBeCofun.ma new file mode 100644 --- /dev/null +++ b/test/fail/MustBeCofun.ma @@ -0,0 +1,14 @@ +-- 2010-08-18 + +sized codata CoList (A : Set) : Size -> Set +{ conil : [i : Size] -> CoList A $i +; cocons : [i : Size] -> A -> CoList A i -> CoList A $i +} + +-- the following declaration must be cofun otherwise non-termination +fun repeat : [A : Set] -> (a : A) -> [i : Size] -> CoList A i +{ repeat A a ($ i) = cocons A i a (repeat A a i) +} + +data Unit : Set { unit : Unit } +eval let units : CoList Unit # = repeat Unit unit # diff --git a/test/fail/MutualDataNotMon.err b/test/fail/MutualDataNotMon.err new file mode 100644 --- /dev/null +++ b/test/fail/MutualDataNotMon.err @@ -0,0 +1,22 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MutualDataNotMon.ma" --- +--- scope checking --- +--- type checking --- +type L : +(A : Set) -> Set +term L.l1 : .[A : Set] -> ^(y0 : A) -> ^(y1 : L A) -> < L.l1 y0 y1 : L A > +term L.l2 : .[A : Set] -> ^(y0 : T A) -> < L.l2 y0 : L A > +type T : +(A : Set) -> Set +term T.t1 : .[A : Set] -> ^(y0 : L A) -> < T.t1 y0 : T A > +error during typechecking: +new L : (+(A : Set) -> Set) +/// new T : (+(A : Set) -> Set{L = (v0 Up (+(A : Set) -> Set))}) +/// T +/// constructor T.t2 +/// new T : (+(A : Set) -> Set{T = (v1 Up (+(A : Set) -> Set{L = (v0 Up (+(A : Set) -> Set))})), L = (v0 Up (+(A : Set) -> Set))}) +/// new A : Set +/// inferExpr' ^ (A -> T A) -> T A +/// inferExpr' A -> T A +/// inferExpr' A +/// inferExpr: variable A : Set may not occur +/// , because of polarity +/// polarity check + <= - failed diff --git a/test/fail/MutualDataNotMon.ma b/test/fail/MutualDataNotMon.ma new file mode 100644 --- /dev/null +++ b/test/fail/MutualDataNotMon.ma @@ -0,0 +1,15 @@ +-- 2010-08-31 + +mutual { + + data L +(A : Set) : Set + { l1 : A -> L A -> L A + ; l2 : T A -> L A + } + + data T +(A : Set) : Set + { t1 : L A -> T A + ; t2 : (A -> T A) -> T A + } + +} diff --git a/test/fail/MutualNeg.err b/test/fail/MutualNeg.err new file mode 100644 --- /dev/null +++ b/test/fail/MutualNeg.err @@ -0,0 +1,11 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MutualNeg.ma" --- +--- scope checking --- +--- type checking --- +type D : Set +term D.absD : ^(y0 : E -> D) -> < D.absD y0 : D > +type E : Set +term E.absE : ^(y0 : D -> E) -> < E.absE y0 : E > +error during typechecking: +checking positivity +/// polarity check ++ <= + failed diff --git a/test/fail/MutualNeg.ma b/test/fail/MutualNeg.ma new file mode 100644 --- /dev/null +++ b/test/fail/MutualNeg.ma @@ -0,0 +1,10 @@ +-- 2010-08-30 + +-- this is positive, but not strictly positive + +mutual { + + data D : Set { absD : (E -> D) -> D } + data E : Set { absE : (D -> E) -> E } + +} diff --git a/test/fail/MutualNeg2.err b/test/fail/MutualNeg2.err new file mode 100644 --- /dev/null +++ b/test/fail/MutualNeg2.err @@ -0,0 +1,11 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "MutualNeg2.ma" --- +--- scope checking --- +--- type checking --- +type D : Set +term D.absD : ^(y0 : E -> D) -> < D.absD y0 : D > +type E : Set +term E.inE : ^(y0 : D) -> < E.inE y0 : E > +error during typechecking: +checking positivity +/// polarity check ++ <= - failed diff --git a/test/fail/MutualNeg2.ma b/test/fail/MutualNeg2.ma new file mode 100644 --- /dev/null +++ b/test/fail/MutualNeg2.ma @@ -0,0 +1,10 @@ +-- 2010-08-30 + +-- this is negative + +mutual { + + data D : Set { absD : (E -> D) -> D } + data E : Set { inE : D -> E } + +} diff --git a/test/fail/NatToSize.err b/test/fail/NatToSize.err new file mode 100644 --- /dev/null +++ b/test/fail/NatToSize.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NatToSize.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.suc : ^(y0 : Nat) -> < Nat.suc y0 : Nat > +size toSize : Nat -> Size +{ toSize Nat.zero = 0 +; toSize (Nat.suc n) = $(toSize n) +} +size toSizeNT : Nat -> Size +{ toSizeNT Nat.zero = 0 +; toSizeNT (Nat.suc n) = $(toSizeNT (Nat.suc n)) +} +error during typechecking: +Termination check for function toSizeNT fails diff --git a/test/fail/NatToSize.ma b/test/fail/NatToSize.ma new file mode 100644 --- /dev/null +++ b/test/fail/NatToSize.ma @@ -0,0 +1,16 @@ +-- 2010-11-01 + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +fun toSize : Nat -> Size +{ toSize zero = 0 +; toSize (suc n) = $(toSize n) +} + +fun toSizeNT : Nat -> Size +{ toSizeNT zero = 0 +; toSizeNT (suc n) = $(toSizeNT (suc n)) +} diff --git a/test/fail/NegPol.err b/test/fail/NegPol.err new file mode 100644 --- /dev/null +++ b/test/fail/NegPol.err @@ -0,0 +1,16 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NegPol.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +U +/// checkExpr 0 |- \ X -> X -> X : + Set -> Set +/// checkForced fromList [] |- \ X -> X -> X : + Set -> Set +/// new X : Set +/// checkExpr 1 |- X -> X : Set +/// checkForced fromList [(X,0)] |- X -> X : Set +/// inferExpr' X -> X +/// inferExpr' X +/// inferExpr: variable X : Set may not occur +/// , because of polarity +/// polarity check + <= - failed diff --git a/test/fail/NegPol.ma b/test/fail/NegPol.ma new file mode 100644 --- /dev/null +++ b/test/fail/NegPol.ma @@ -0,0 +1,4 @@ +-- 2010-08-19 +let U : +Set -> Set + = \ X -> X -> X + diff --git a/test/fail/NonLinearParameter.err b/test/fail/NonLinearParameter.err new file mode 100644 --- /dev/null +++ b/test/fail/NonLinearParameter.err @@ -0,0 +1,16 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NonLinearParameter.ma" --- +--- scope checking --- +--- type checking --- +type Prod : ^(A : Set) -> ^(B : Set) -> Set +term Prod.pair : .[A : Set] -> .[B : Set] -> ^(a : A) -> ^(b : B) -> < Prod.pair a b : Prod A B > +term a : .[A : Set] -> .[B : Set] -> (pair : Prod A B) -> A +{ a [A] [B] (Prod.pair #a #b) = #a +} +term b : .[A : Set] -> .[B : Set] -> (pair : Prod A B) -> B +{ b [A] [B] (Prod.pair #a #b) = #b +} +type D : ^(A : Set 1) -> Set +error during typechecking: +D +/// expected parameter to be a pattern, but I found [Prod A A] diff --git a/test/fail/NonLinearParameter.ma b/test/fail/NonLinearParameter.ma new file mode 100644 --- /dev/null +++ b/test/fail/NonLinearParameter.ma @@ -0,0 +1,6 @@ +-- 2013-04-05 + +data Prod (A, B : Set) { pair (a : A) (b : B) } + +data D (A : Set 1) +{ c : D (Prod A A) } -- not a pattern, currenlty not accepted diff --git a/test/fail/NonLinearParameterPattern.err b/test/fail/NonLinearParameterPattern.err new file mode 100644 --- /dev/null +++ b/test/fail/NonLinearParameterPattern.err @@ -0,0 +1,33 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NonLinearParameterPattern.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.false : < Bool.false : Bool > +term Bool.true : < Bool.true : Bool > +type D : ^(x : Bool) -> ^(y : Bool) -> Set +term D.c : .[x : Bool] -> .[x : Bool] -> < D.c : D x x > +type g : D Bool.true Bool.true -> Set +{ g D.c = Bool +} +type f : D Bool.true Bool.false -> Set +block fails as expected, error message: +f +/// clause 1 +/// pattern c +/// instConLType' +/// instConType: +cannot match parameters [Bool.true, Bool.false] +against patterns [x, x] +when instantiating type .[x : Bool] -> .[x : Bool] -> < D.c : D x x > +of constructor D.c +error during typechecking: +v +/// checkExpr 0 |- c : D Bool.true Bool.false +/// checkForced fromList [] |- c : D Bool.true Bool.false +/// instConLType' +/// instConType: +cannot match parameters [Bool.true, Bool.false] +against patterns [x, x] +when instantiating type .[x : Bool] -> .[x : Bool] -> < D.c : D x x > +of constructor D.c diff --git a/test/fail/NonLinearParameterPattern.ma b/test/fail/NonLinearParameterPattern.ma new file mode 100644 --- /dev/null +++ b/test/fail/NonLinearParameterPattern.ma @@ -0,0 +1,15 @@ +data Bool { false ; true } + +data D (x, y : Bool) +{ c : D x x } + +fun g : D true true -> Set +{ g c = Bool } + +fail +fun f : D true false -> Set +{ f c = Bool } +-- should not match! + +let v : D true false = c +-- should also fail diff --git a/test/fail/NonLinearPatterns.err b/test/fail/NonLinearPatterns.err new file mode 100644 --- /dev/null +++ b/test/fail/NonLinearPatterns.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NonLinearPatterns.ma" --- +--- scope checking --- +scope check error: nonlin +/// pattern not linear: X diff --git a/test/fail/NonLinearPatterns.ma b/test/fail/NonLinearPatterns.ma new file mode 100644 --- /dev/null +++ b/test/fail/NonLinearPatterns.ma @@ -0,0 +1,3 @@ +fun nonlin : Set -> Set -> Set +{ nonlin X X = X +} diff --git a/test/fail/NonPosBoundedData.err b/test/fail/NonPosBoundedData.err new file mode 100644 --- /dev/null +++ b/test/fail/NonPosBoundedData.err @@ -0,0 +1,21 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NonPosBoundedData.ma" --- +--- scope checking --- +--- type checking --- +type D : +(i : Size) -> Set +{ D i = .[j < i] & D j -> D j +} +type D : +(i : Size) -> Set +error during typechecking: +D +/// clause 1 +/// right hand side +/// checkExpr 1 |- (.[j < i] & D j) -> .[j < i] & D j : Set +/// checkForced fromList [(i,0)] |- (.[j < i] & D j) -> .[j < i] & D j : Set +/// inferExpr' (.[j < i] & D j) -> .[j < i] & D j +/// inferExpr' .[j < i] & D j +/// inferExpr' < i +/// inferExpr' i +/// inferExpr: variable i : Size may not occur +/// , because of polarity +/// polarity check + <= - failed diff --git a/test/fail/NonPosBoundedData.ma b/test/fail/NonPosBoundedData.ma new file mode 100644 --- /dev/null +++ b/test/fail/NonPosBoundedData.ma @@ -0,0 +1,15 @@ +-- 2012-02-04 + +-- Putting the bound on the outside ensures positivity +check +cofun D : +(i : Size) -> Set +{ D i = [j < i] & (D j -> D j) +} + +-- If we place the bound directly before the recursive occurrence +-- we need strictly positive functionals + +cofun D : +(i : Size) -> Set +{ D i = [j < i] & D j -> [j < i] & D j +} +-- fails diff --git a/test/fail/NotEnoughParameters.err b/test/fail/NotEnoughParameters.err new file mode 100644 --- /dev/null +++ b/test/fail/NotEnoughParameters.err @@ -0,0 +1,6 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NotEnoughParameters.ma" --- +--- scope checking --- +scope check error: D +/// c +/// constructor c: target (D A) is missing parameters diff --git a/test/fail/NotEnoughParameters.ma b/test/fail/NotEnoughParameters.ma new file mode 100644 --- /dev/null +++ b/test/fail/NotEnoughParameters.ma @@ -0,0 +1,3 @@ +-- 2013-04-05 + +data D (A, B : Set) { c : D A } diff --git a/test/fail/NotForcedConstructors.err b/test/fail/NotForcedConstructors.err new file mode 100644 --- /dev/null +++ b/test/fail/NotForcedConstructors.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NotForcedConstructors.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +term not : Bool -> Bool +{ not Bool.true = Bool.false +; not Bool.false = Bool.true +} +type Nat : ^ Bool -> Set +term Nat.zero : < Nat.zero : Nat Bool.true > +term Nat.succ : ^(b : Bool) -> ^(y1 : Nat b) -> < Nat.succ b y1 : Nat (not b) > +term f : (b : Bool) -> .[Nat b] -> Bool +error during typechecking: +f +/// clause 1 +/// pattern zero +/// checkPattern: constructor Nat.zero of non-computational argument zero : (Nat Bool.true{}) not forced diff --git a/test/fail/NotForcedConstructors.ma b/test/fail/NotForcedConstructors.ma new file mode 100644 --- /dev/null +++ b/test/fail/NotForcedConstructors.ma @@ -0,0 +1,19 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +fun not : Bool -> Bool +{ not true = false +; not false = true +} + +data Nat : Bool -> Set +{ zero : Nat true +; succ : (b : Bool) -> Nat b -> Nat (not b) +} + +fun f : (b : Bool) -> [Nat b] -> Bool +{ f true zero = true +; f false (succ n) = false +} diff --git a/test/fail/NumbersAsIds.err b/test/fail/NumbersAsIds.err new file mode 100644 --- /dev/null +++ b/test/fail/NumbersAsIds.err @@ -0,0 +1,3 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "NumbersAsIds.ma" --- +--- scope checking --- diff --git a/test/fail/NumbersAsIds.ma b/test/fail/NumbersAsIds.ma new file mode 100644 --- /dev/null +++ b/test/fail/NumbersAsIds.ma @@ -0,0 +1,7 @@ +--2010-06-25 feature "numbers as ids" removed, numbers are now sizes +data 3 : Set +{ 0 : 3 +; 1 : 3 +; 2 : 3 +} + diff --git a/test/fail/OverlappingPatternIndFam-sound.err b/test/fail/OverlappingPatternIndFam-sound.err new file mode 100644 --- /dev/null +++ b/test/fail/OverlappingPatternIndFam-sound.err @@ -0,0 +1,32 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "OverlappingPatternIndFam-sound.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Id : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a a > +term subst : .[A : Set] -> (a : A) -> (b : A) -> Id A a b -> .[P : A -> Set] -> P a -> P b +{ subst [A] a .a Id.refl [P] x = x +} +type DecEq : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term DecEq.eq : .[A : Set] -> .[a : A] -> < DecEq.eq : DecEq A a a > +term DecEq.notEq : .[A : Set] -> .[a : A] -> .[b : A] -> < DecEq.notEq b : DecEq A a b > +error during typechecking: +fDiag +/// checkExpr 0 |- \ f -> \ A -> \ a -> refl : (f : .[A : Set] -> (a : A) -> (b : A) -> DecEq A a b) -> .[A : Set] -> (a : A) -> Id (DecEq A a a) (f [A] a a) DecEq.eq +/// checkForced fromList [] |- \ f -> \ A -> \ a -> refl : (f : .[A : Set] -> (a : A) -> (b : A) -> DecEq A a b) -> .[A : Set] -> (a : A) -> Id (DecEq A a a) (f [A] a a) DecEq.eq +/// new f : (.[A : Set] -> (a : A) -> (b : A) -> DecEq A a b) +/// checkExpr 1 |- \ A -> \ a -> refl : .[A : Set] -> (a : A) -> Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// checkForced fromList [(f,0)] |- \ A -> \ a -> refl : .[A : Set] -> (a : A) -> Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// new A : Set +/// checkExpr 2 |- \ a -> refl : (a : A) -> Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// checkForced fromList [(A,1),(f,0)] |- \ a -> refl : (a : A) -> Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// new a : v1 +/// checkExpr 3 |- refl : Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// checkForced fromList [(A,1),(f,0),(a,2)] |- refl : Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// leqVal' (subtyping) < Id.refl : Id (DecEq A a a) (f A a b [A] a a) (f A a b [A] a a) > <=+ Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// leqVal' (subtyping) Id (DecEq A a a) (f A a b [A] a a) (f A a b [A] a a) <=+ Id (DecEq A a a) (f A a b [A] a a) DecEq.eq +/// leqVal' f A a a <=^ DecEq.eq : DecEq A a a +/// leqApp: head mismatch f != DecEq.eq diff --git a/test/fail/OverlappingPatternIndFam-sound.ma b/test/fail/OverlappingPatternIndFam-sound.ma new file mode 100644 --- /dev/null +++ b/test/fail/OverlappingPatternIndFam-sound.ma @@ -0,0 +1,28 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +fun subst : (A : Set) -> (a : A) -> (b : A) -> Id A a b -> + (P : A -> Set) -> P a -> P b +{ subst A a .a refl P x = x +} + +-- an overlapping ind. fam. +data DecEq (A : Set)(a : A) : A -> Set +{ eq : DecEq A a a +; notEq : (b : A) -> DecEq A a b +} + +-- this rightfully does not type check, since f A a a does not expand to eq +-- (both patterns match) +let fDiag : (f : (A : Set) -> (a : A) -> (b : A) -> DecEq A a b) -> + (A : Set) -> (a : A) -> Id (DecEq A a a) (f A a a) eq + = \ f -> \ A -> \ a -> refl + +let incons : (A : Set) -> (a : A) -> Id (DecEq A a a) (notEq a) eq + = fDiag notEq diff --git a/test/fail/OverlappingPatternIndFam.err b/test/fail/OverlappingPatternIndFam.err new file mode 100644 --- /dev/null +++ b/test/fail/OverlappingPatternIndFam.err @@ -0,0 +1,34 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "OverlappingPatternIndFam.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Id : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a a > +term subst : .[A : Set] -> (a : A) -> (b : A) -> Id A a b -> .[P : A -> Set] -> P a -> P b +{ subst [A] a .a Id.refl [P] x = x +} +type DecEq : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term DecEq.eq : .[A : Set] -> .[a : A] -> < DecEq.eq : DecEq A a a > +term DecEq.notEq : .[A : Set] -> .[a : A] -> .[b : A] -> < DecEq.notEq b : DecEq A a b > +error during typechecking: +offDiag +/// not a type: (A : Set) -> (f : (a : A) -> (b : A) -> DecEq A a b) -> (a : A) -> (b : A) -> Id (DecEq A a b) (f a b) (notEq A a b) +/// inferExpr' (A : Set) -> (f : (a : A) -> (b : A) -> DecEq A a b) -> (a : A) -> (b : A) -> Id (DecEq A a b) (f a b) (notEq A a b) +/// new A : Set +/// inferExpr' (f : (a : A) -> (b : A) -> DecEq A a b) -> (a : A) -> (b : A) -> Id (DecEq A a b) (f a b) (notEq A a b) +/// new f : ((a : v0::Tm) -> (b : A) -> DecEq A a b{A = v0}) +/// inferExpr' (a : A) -> (b : A) -> Id (DecEq A a b) (f a b) (notEq A a b) +/// new a : v0 +/// inferExpr' (b : A) -> Id (DecEq A a b) (f a b) (notEq A a b) +/// new b : v0 +/// inferExpr' Id (DecEq A a b) (f a b) (notEq A a b) +/// checkApp (^(DecEq v0 v2 v3)::Tm -> {Set {a = (v1 v2 v3), A = (DecEq v0 v2 v3)}}) eliminated by notEq A a b +/// checkExpr 4 |- notEq A a b : DecEq A a b +/// checkForced fromList [(A,0),(f,1),(a,2),(b,3)] |- notEq A a b : DecEq A a b +/// checkApp (.[b : v0::Tm] -> < DecEq.notEq b : DecEq A a b >{a = v2, A = v0}) eliminated by A +/// leqVal' (subtyping) < A : Set > <=+ A +/// leqVal' (subtyping) Set <=+ A +/// leqApp: head mismatch Set != A diff --git a/test/fail/OverlappingPatternIndFam.ma b/test/fail/OverlappingPatternIndFam.ma new file mode 100644 --- /dev/null +++ b/test/fail/OverlappingPatternIndFam.ma @@ -0,0 +1,43 @@ +-- 2009-09-19 +-- unsound eta-expansion as noted by Anton Setzer + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +fun subst : (A : Set) -> (a : A) -> (b : A) -> Id A a b -> + (P : A -> Set) -> P a -> P b +{ subst A a .a (refl) P x = x +} + +-- an overlapping ind. fam. +data DecEq (A : Set)(a : A) : A -> Set +{ eq : DecEq A a a +; notEq : (b : A) -> DecEq A a b +} + +-- every function into DecEq is the constant notEq one +-- that is provable in the current implementation of eta, but is unsound +let offDiag : (A : Set) -> (f : (a : A) -> (b : A) -> DecEq A a b) -> + (a : A) -> (b : A) -> + Id (DecEq A a b) (f a b) (notEq A a b) + = \ A -> \ f -> \ a -> \ b -> refl -- (DecEq A a b) (notEq A a b) + +-- let incons : (A : Set) -> (a : A) -> Id (DecEq A a a) (eq A a) (notEq A a a) +-- = \ A -> \ a -> offDiag (\ A' -> \ a' -> \ b -> eq A' a') A a a + +fun f : (x : Bool) -> (y : Bool) -> DecEq Bool x y +{ f true true = eq Bool true +; f true false = notEq Bool true false +; f false true = notEq Bool false true +; f false false = eq Bool false +} + +-- now we can show that two constructors are equal +let incons : Id (DecEq Bool true true) (eq Bool true) (notEq Bool true true) + = offDiag Bool f true true diff --git a/test/fail/PolarityWrongCast.err b/test/fail/PolarityWrongCast.err new file mode 100644 --- /dev/null +++ b/test/fail/PolarityWrongCast.err @@ -0,0 +1,35 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "PolarityWrongCast.ma" --- +--- scope checking --- +--- type checking --- +type DNeg : Set -> + Set -> Set +type DNeg = \ B -> \ A -> (A -> B) -> B +type Empty : Set +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +type Id : Nat # -> ++ Set -> Set +{ Id (Nat.zero [.#]) A = A +; Id (Nat.succ [.#] n) A = A +} +error during typechecking: +kast +/// checkExpr 0 |- \ i -> \ n -> \ x -> x : .[i : Size] -> .[n : Nat i] -> Id n (Nat #) -> Id n (Nat i) +/// checkForced fromList [] |- \ i -> \ n -> \ x -> x : .[i : Size] -> .[n : Nat i] -> Id n (Nat #) -> Id n (Nat i) +/// new i <= # +/// checkExpr 1 |- \ n -> \ x -> x : .[n : Nat i] -> Id n (Nat #) -> Id n (Nat i) +/// checkForced fromList [(i,0)] |- \ n -> \ x -> x : .[n : Nat i] -> Id n (Nat #) -> Id n (Nat i) +/// new n : (Nat v0) +/// checkExpr 2 |- \ x -> x : Id n (Nat #) -> Id n (Nat i) +/// checkForced fromList [(n,1),(i,0)] |- \ x -> x : Id n (Nat #) -> Id n (Nat i) +/// new x : (Id v1 {Nat # {n = v1, i = v0}}) +/// checkExpr 3 |- x : Id n (Nat i) +/// leqVal' (subtyping) < x : Id n (Nat #) > <=+ Id n (Nat i) +/// leqVal' (subtyping) Id n (Nat #) <=+ Id n (Nat i) +/// leqVal' Nat # <=+ Nat i : Set +/// leqVal' # <=+ i : Size +/// leSize # <=+ i +/// leSize' # <= i +/// leSize: # + 0 <= i failed diff --git a/test/fail/PolarityWrongCast.ma b/test/fail/PolarityWrongCast.ma new file mode 100644 --- /dev/null +++ b/test/fail/PolarityWrongCast.ma @@ -0,0 +1,22 @@ +-- 2010-06-19 + +let DNeg : Set -> +Set -> Set + = \ B -> \ A -> (A -> B) -> B + +data Empty : Set {} + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +-- hide positivity behind recursion +fun Id : Nat # -> ++Set -> Set +{ Id (zero .#) A = A +; Id (succ .# n) A = A +} + +-- SUBTYPING the wrong way round +let kast : [i : Size] -> [n : Nat i] -> Id n (Nat #) -> Id n (Nat i) + = \ i -> \ n -> \ x -> x + diff --git a/test/fail/RecurseOnErased.err b/test/fail/RecurseOnErased.err new file mode 100644 --- /dev/null +++ b/test/fail/RecurseOnErased.err @@ -0,0 +1,13 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "RecurseOnErased.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term f : .[Nat] -> Nat -> Nat +error during typechecking: +f +/// clause 1 +/// pattern zero +/// checkPattern: constructor Nat.zero of non-computational argument zero : Nat not forced diff --git a/test/fail/RecurseOnErased.ma b/test/fail/RecurseOnErased.ma new file mode 100644 --- /dev/null +++ b/test/fail/RecurseOnErased.ma @@ -0,0 +1,21 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +-- matching on irrelevant arguments needs to be forbidden +fun f : [Nat] -> Nat -> Nat +{ f zero n = n -- this should not be allowed! +; f m zero = zero +; f m (succ n) = n +} + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +-- because of irrelevance of first argument of f +-- this should hold: +let p1 : (n : Nat) -> Id Nat (f zero n) (f (succ zero) n) + = \ n -> refl Nat (f zero n) + diff --git a/test/fail/ResurrectFromErasedPattern.err b/test/fail/ResurrectFromErasedPattern.err new file mode 100644 --- /dev/null +++ b/test/fail/ResurrectFromErasedPattern.err @@ -0,0 +1,24 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "ResurrectFromErasedPattern.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Nat : ^ Bool -> Set +term Nat.zero : < Nat.zero : Nat Bool.true > +term Nat.succ : .[b : Bool] -> ^(y1 : Nat b) -> < Nat.succ b y1 : Nat Bool.false > +term f : (b : Bool) -> .[Nat b] -> Nat Bool.false +error during typechecking: +f +/// clause 2 +/// right hand side +/// checkExpr 2 |- succ false (succ b n) : Nat Bool.false +/// checkForced fromList [(n,1),(b,0)] |- succ false (succ b n) : Nat Bool.false +/// checkApp (^(y1 : (Nat Bool.false{})::()) -> < Nat.succ b y1 : Nat Bool.false >{b = Bool.false{}}) eliminated by succ b n +/// checkExpr 2 |- succ b n : Nat Bool.false +/// checkForced fromList [(n,1),(b,0)] |- succ b n : Nat Bool.false +/// checkApp (^(y1 : (Nat v0)::()) -> < Nat.succ b y1 : Nat Bool.false >{b = v0}) eliminated by n +/// inferExpr' n +/// inferExpr: variable n : Nat b may not occur +/// , because it is marked as erased diff --git a/test/fail/ResurrectFromErasedPattern.ma b/test/fail/ResurrectFromErasedPattern.ma new file mode 100644 --- /dev/null +++ b/test/fail/ResurrectFromErasedPattern.ma @@ -0,0 +1,14 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Bool -> Set +{ zero : Nat true +; succ : [b : Bool] -> Nat b -> Nat false +} + +fun f : (b : Bool) -> [Nat b] -> Nat false +{ f true zero = succ true zero +; f false (succ b n) = succ false (succ b n) +} diff --git a/test/fail/SPosNotPos.err b/test/fail/SPosNotPos.err new file mode 100644 --- /dev/null +++ b/test/fail/SPosNotPos.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "SPosNotPos.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +DNeg +/// checkExpr 0 |- \ B -> \ A -> (A -> B) -> B : Set -> ++ Set -> Set +/// checkForced fromList [] |- \ B -> \ A -> (A -> B) -> B : Set -> ++ Set -> Set +/// new B : Set +/// checkExpr 1 |- \ A -> (A -> B) -> B : ++ Set -> Set +/// checkForced fromList [(B,0)] |- \ A -> (A -> B) -> B : ++ Set -> Set +/// new A : Set +/// checkExpr 2 |- (A -> B) -> B : Set +/// checkForced fromList [(A,1),(B,0)] |- (A -> B) -> B : Set +/// inferExpr' (A -> B) -> B +/// inferExpr' A -> B +/// inferExpr' A +/// inferExpr: variable A : Set may not occur +/// , because of polarity +/// polarity check ++ <= + failed diff --git a/test/fail/SPosNotPos.ma b/test/fail/SPosNotPos.ma new file mode 100644 --- /dev/null +++ b/test/fail/SPosNotPos.ma @@ -0,0 +1,6 @@ +-- 2010-06-19 + +-- A only pos, not strictly pos. + +let DNeg : Set -> ++Set -> Set + = \ B -> \ A -> (A -> B) -> B diff --git a/test/fail/ShadowBinding.err b/test/fail/ShadowBinding.err new file mode 100644 --- /dev/null +++ b/test/fail/ShadowBinding.err @@ -0,0 +1,4 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "ShadowBinding.ma" --- +--- scope checking --- +scope check error: (let A = A in A): Identifier A already in context diff --git a/test/fail/ShadowBinding.ma b/test/fail/ShadowBinding.ma new file mode 100644 --- /dev/null +++ b/test/fail/ShadowBinding.ma @@ -0,0 +1,42 @@ +-- 2013-04-06 + +fail +fun Bla1 : (A, A : Set) -> Set +{ Bla1 A B = A +} + +fail +fun Bla2 : (A, B : Set) -> Set +{ Bla2 = \ A A -> A +} + +fail +fun Bla1' : (A : Set) -> (A : Set) -> Set +{ Bla1' A B = A +} + +check +let Bla3 (A : Set) : (A : Set) -> Set = \ B -> A + +fail +let Bla3 (A : Set) (A : Set) : Set = A + +check +let Bla4 (A : Set) : Set -> Set = \ A -> A + +fail +let Bla5 : Set -> Set -> Set = \ A A -> A + +fail +let Bla6 : Set -> Set -> Set1 = \ A A -> Set + +fail +let Hurz : Set = \ M i s s i s s i p p i -> i + +check +let Bla7 (A : Set) : Set = + let A = A in A + +let Bla7 (A : Set) : Set = + let A = A in + let A = A in A diff --git a/test/fail/ShadowParameter.err b/test/fail/ShadowParameter.err new file mode 100644 --- /dev/null +++ b/test/fail/ShadowParameter.err @@ -0,0 +1,6 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "ShadowParameter.ma" --- +--- scope checking --- +scope check error: Sg +/// sg +/// TBind {boundDec = Dec {thePolarity = ^}, boundNames = [n], boundType = Nat}: Identifier n already in context diff --git a/test/fail/ShadowParameter.ma b/test/fail/ShadowParameter.ma new file mode 100644 --- /dev/null +++ b/test/fail/ShadowParameter.ma @@ -0,0 +1,8 @@ +-- 2013-04-06 +data Nat { zero ; suc (n : Nat) } + +data Sg (n : Nat) +{ sg (n : Nat) : Sg n +} +-- this should be illegal shadowing, because it is confusing +-- (even the type checker gets confused) diff --git a/test/fail/ShadowPatternParameter.err b/test/fail/ShadowPatternParameter.err new file mode 100644 --- /dev/null +++ b/test/fail/ShadowPatternParameter.err @@ -0,0 +1,6 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "ShadowPatternParameter.ma" --- +--- scope checking --- +scope check error: D +/// c +/// TBind {boundDec = Dec {thePolarity = ^}, boundNames = [n], boundType = Nat}: Identifier n already in context diff --git a/test/fail/ShadowPatternParameter.ma b/test/fail/ShadowPatternParameter.ma new file mode 100644 --- /dev/null +++ b/test/fail/ShadowPatternParameter.ma @@ -0,0 +1,7 @@ +-- 2013-04-06 + +data Nat { zero ; suc (n : Nat) } + +data D (n : Nat) +{ c (n : Nat) : D (suc n) +} diff --git a/test/fail/SizedDataWrongPol.err b/test/fail/SizedDataWrongPol.err new file mode 100644 --- /dev/null +++ b/test/fail/SizedDataWrongPol.err @@ -0,0 +1,7 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "SizedDataWrongPol.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +Nat +/// sized type Nat has wrong polarity annotation - at Size argument, it should be + diff --git a/test/fail/SizedDataWrongPol.ma b/test/fail/SizedDataWrongPol.ma new file mode 100644 --- /dev/null +++ b/test/fail/SizedDataWrongPol.ma @@ -0,0 +1,1 @@ +sized data Nat : -Size -> Set {} diff --git a/test/fail/StoreSize.err b/test/fail/StoreSize.err new file mode 100644 --- /dev/null +++ b/test/fail/StoreSize.err @@ -0,0 +1,16 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "StoreSize.ma" --- +--- scope checking --- +--- type checking --- +ty-u WrapSize : Set 1 +term WrapSize.inn : .[out : Size] -> < WrapSize.inn out : WrapSize > +size out : (inn : WrapSize) -> Size +error during typechecking: +WrapSize +/// out +/// clause 1 +/// right hand side +/// checkExpr 1 |- #out : Size +/// inferExpr' #out +/// inferExpr: variable #out : Size may not occur +/// , because it is marked as erased diff --git a/test/fail/StoreSize.ma b/test/fail/StoreSize.ma new file mode 100644 --- /dev/null +++ b/test/fail/StoreSize.ma @@ -0,0 +1,7 @@ +-- 2010-09-20 + +data WrapSize : Set 1 +{ inn : (out : Size) -> WrapSize +} +-- bug: MiniAgda tries to generate a destructor, even though out +-- is not a proper field (it is erased internally) diff --git a/test/fail/StreamDupl.err b/test/fail/StreamDupl.err new file mode 100644 --- /dev/null +++ b/test/fail/StreamDupl.err @@ -0,0 +1,26 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "StreamDupl.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term evens : .[A : Set] -> .[i : Size] -> .[j : Size] -> Stream A (i + j) -> Stream A i +error during typechecking: +evens +/// clause 1 +/// pattern cons .(i + j + 1) a (cons .(i + j) b as) +/// unifyIndices [(Dec {thePolarity = .}Set::Set,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = *}(Stream v0 v5)::(),Dec {thePolarity = ++})] |- < Stream.cons $.(i + j) a (Stream.cons .(i + j) b as) : Stream A $$.(i + j) > ?<=+ Stream A ($i + j) +/// unifyIndices [(Dec {thePolarity = .}Set::Set,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = *}(Stream v0 v5)::(),Dec {thePolarity = ++})] |- Stream A $$.(i + j) ?<=+ Stream A ($i + j) +/// inst [(Dec {thePolarity = .}Set::Set,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = *}(Stream v0 v5)::(),Dec {thePolarity = ++})] |- $$.(i + j) ?<=- $(i + j) : Size +/// inst [(Dec {thePolarity = .}Set::Set,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = .}Size::Size,Dec {thePolarity = ++}),(Dec {thePolarity = *}v0::Tm,Dec {thePolarity = ++}),(Dec {thePolarity = *}(Stream v0 v5)::(),Dec {thePolarity = ++})] |- $.(i + j) ?<=- i + j : Size +/// inst: leqVal ($ v5) ?<=- (v2 + v1) : Size failed +/// leqVal' $.(i + j) <=- i + j : Size +/// leSize $.(i + j) <=- i + j +/// leSize' i + j <= $.(i + j) +/// leSize: i + j <= .(i + j) + 1 failed diff --git a/test/fail/StreamDupl.ma b/test/fail/StreamDupl.ma new file mode 100644 --- /dev/null +++ b/test/fail/StreamDupl.ma @@ -0,0 +1,12 @@ +-- 2010-11-01 + +sized codata Stream ++(A : Set) : -Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A $i +} + +cofun evens : [A : Set] -> [i, j : Size] -> Stream A (i + j) -> Stream A i +{ evens A ($i) j (cons .(i + j + 1) a (cons .(i + j) b as)) = + cons i a (evens A i as) +} +-- this should fail because we cannot match the input stream to depth 2 +-- since only i is replaced by $i diff --git a/test/fail/StreamNotSemiCont.err b/test/fail/StreamNotSemiCont.err new file mode 100644 --- /dev/null +++ b/test/fail/StreamNotSemiCont.err @@ -0,0 +1,25 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "StreamNotSemiCont.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Stream : +(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term bad : .[i : Size] -> .[A : Set] -> (Stream A i -> Stream A i) -> Stream A i +error during typechecking: +bad +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> .[A : Set] -> (Stream A i -> Stream A i) -> Stream A i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: .[A : Set] -> (Stream A i -> Stream A i) -> Stream A i +/// new A : Set +/// endsInSizedCo: (Stream A i -> Stream A i) -> Stream A i +/// type Stream A i -> Stream A i not lower semi continuous in i diff --git a/test/fail/StreamNotSemiCont.ma b/test/fail/StreamNotSemiCont.ma new file mode 100644 --- /dev/null +++ b/test/fail/StreamNotSemiCont.ma @@ -0,0 +1,20 @@ +-- 2010-07-01 Following a question of Nisse, this example explains +-- the need for continuity check. + +data Unit : Set +{ unit : Unit +} + +sized codata Stream +(A : Set) : Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A $i +} +fields head, tail + +cofun bad : [i : Size] -> [A : Set] -> (Stream A i -> Stream A i) -> Stream A i +{ bad ($ i) A f = f (cons A i (bad i A f)) +} + +let undef : Stream Unit # = bad # Unit (tail #) + +eval let diverge : Unit = head # undef + diff --git a/test/fail/Tm.err b/test/fail/Tm.err new file mode 100644 --- /dev/null +++ b/test/fail/Tm.err @@ -0,0 +1,47 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "Tm.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term iterate : .[A : Set] -> (step : A -> A) -> (start : A) -> .[i : Size] -> Stream A i +{ iterate [A] step start $[i < #] = Stream.cons [i] start (iterate [A] step (step start) [i]) +} +type Tm : Set +term Tm.abs : ^(y0 : ^ Tm -> Tm) -> < Tm.abs y0 : Tm > +term Tm.app : ^(y0 : Tm) -> ^(y1 : Tm) -> < Tm.app y0 y1 : Tm > +warning: ignoring error: polarity check ++ <= - failed +warning: ignoring error: polarity check ++ <= + failed +term sapp : ^ Tm -> Tm +{ sapp x = Tm.app x x +} +term delta : Tm +term delta = Tm.abs (\ x -> sapp x) +term omega : Tm +term omega = Tm.app delta delta +term step : Tm -> Tm +error during typechecking: +step +/// clause 3 +/// right hand side +/// checkExpr 1 |- abs (\ x -> step (f x)) : Tm +/// checkForced fromList [(f,0)] |- abs (\ x -> step (f x)) : Tm +/// checkApp (^(y0 : (^Tm::() -> Tm)::()) -> < Tm.abs y0 : Tm >) eliminated by \ x -> step (f x) +/// checkExpr 1 |- \ x -> step (f x) : ^ Tm -> Tm +/// checkForced fromList [(f,0)] |- \ x -> step (f x) : ^ Tm -> Tm +/// new x : Tm +/// checkExpr 2 |- step (f x) : Tm +/// inferExpr' step (f x) +/// checkApp (Tm -> Tm) eliminated by f x +/// inferExpr' f x +/// checkApp (^Tm::() -> Tm) eliminated by x +/// inferExpr' x +/// inferExpr: variable x : Tm may not occur +/// , because of polarity +/// polarity check ^ <= * failed diff --git a/test/fail/Tm.ma b/test/fail/Tm.ma new file mode 100644 --- /dev/null +++ b/test/fail/Tm.ma @@ -0,0 +1,41 @@ +-- 2010-11-06 + +sized codata Stream ++ (A : Set) : -Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A $i +} fields head, tail + +cofun iterate + : [A : Set ] -> (step : A -> A) -> (start : A) -> + [i : Size] -> Stream A i +{ iterate A step start ($ i) = cons i start (iterate A step (step start) i) +} + +-- this might be accepted without trustme in future versions?! +trustme +data Tm : Set +{ abs : ^(^Tm -> Tm) -> Tm +; app : ^Tm -> ^Tm -> Tm +} + +fun sapp : ^Tm -> Tm +{ sapp x = app x x +} + +let delta : Tm + = abs (\ x -> sapp x) + +let omega : Tm + = app delta delta + +fun step : Tm -> Tm +{ step (app (abs f) t) = f t +; step (app t u) = app (step t) u +; step (abs f) = abs (\ x -> step (f x)) + -- rejected, since x not parametric + -- think of f=id, then step would analyze x ! +} + +let steps : Tm -> Stream Tm # + = \ start -> iterate Tm step start # + +eval let omegas : Stream Tm # = steps omega diff --git a/test/fail/TypeInTypeViaSetInfty.err b/test/fail/TypeInTypeViaSetInfty.err new file mode 100644 --- /dev/null +++ b/test/fail/TypeInTypeViaSetInfty.err @@ -0,0 +1,9 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "TypeInTypeViaSetInfty.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +star +/// not a type: Set # +/// inferExpr' Set # +/// # is not a valid universe level diff --git a/test/fail/TypeInTypeViaSetInfty.ma b/test/fail/TypeInTypeViaSetInfty.ma new file mode 100644 --- /dev/null +++ b/test/fail/TypeInTypeViaSetInfty.ma @@ -0,0 +1,3 @@ +-- 2010-09-03 + +let star : Set # = Set # diff --git a/test/fail/UlfsCounterexample.err b/test/fail/UlfsCounterexample.err new file mode 100644 --- /dev/null +++ b/test/fail/UlfsCounterexample.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "UlfsCounterexample.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type T : Bool -> Set +{ T Bool.true = Nat +; T Bool.false = Bool +} +term bad : .[F : Nat -> Set] -> .[f : .[x : Bool] -> T x -> Nat] -> (g : (n : Nat) -> F (f [Bool.true] n)) -> (h : F (f [Bool.false] Bool.false) -> Bool) -> Bool +error during typechecking: +bad +/// clause 1 +/// right hand side +/// checkExpr 4 |- h (g zero) : Bool +/// inferExpr' h (g zero) +/// checkApp ((v0 {f [Bool.false] Bool.false {g = (v2 Up ((n : Nat::Tm) -> F (f [Bool.true] n){f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))})), f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))}})::Tm -> {Bool {g = (v2 Up ((n : Nat::Tm) -> F (f [Bool.true] n){f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))})), f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))}}) eliminated by g zero +/// leqVal' (subtyping) < g n Nat.zero : F (f x [Bool.true] Nat.zero) > <=+ F (f x [Bool.false] Bool.false) +/// leqVal' (subtyping) F (f x [Bool.true] Nat.zero) <=+ F (f x [Bool.false] Bool.false) +/// leqVal' f Bool.true Nat.zero <=* f Bool.false Bool.false : Nat +/// leqVal' Nat.zero : Nat <=* Bool.false : Bool +/// type Nat has different shape than Bool diff --git a/test/fail/UlfsCounterexample.ma b/test/fail/UlfsCounterexample.ma new file mode 100644 --- /dev/null +++ b/test/fail/UlfsCounterexample.ma @@ -0,0 +1,36 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun T : Bool -> Set +{ T true = Nat +; T false = Bool +} + +-- type checking fails with message "zero != false" +-- can be harmful if constructors can be reused in different types +fun bad : + [F : Nat -> Set] -> + [f : [x : Bool] -> T x -> Nat] -> + (g : (n : Nat) -> F (f true n)) -> + (h : F (f false false) -> Bool) -> + Bool +{ bad F f g h = h (g zero) +} + +{- h expects _ : F (f false false) + but g zero : F (f true zero) + +? F (f true zero) <= F (f false false) +? f true zero : Nat = f false false : Nat +? zero : (T x)[true/x] = false : (T x)[false/x] +? zero : Nat = false : Bool + +should abort with message Nat != Bool +-} diff --git a/test/fail/UlfsCounterexample2.err b/test/fail/UlfsCounterexample2.err new file mode 100644 --- /dev/null +++ b/test/fail/UlfsCounterexample2.err @@ -0,0 +1,26 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "UlfsCounterexample2.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type T : ^ Bool -> Set +term T.nat : ^(y0 : Nat) -> < T.nat y0 : T Bool.true > +term T.bool : ^(y0 : Bool) -> < T.bool y0 : T Bool.false > +term bad : .[F : Nat -> Set] -> ^(f : .[x : Bool] -> T x -> Nat) -> (g : (n : Nat) -> F (f [Bool.true] (T.nat n))) -> (h : F (f [Bool.false] (T.bool Bool.false)) -> Bool) -> Bool +error during typechecking: +bad +/// clause 1 +/// right hand side +/// checkExpr 4 |- h (g zero) : Bool +/// inferExpr' h (g zero) +/// checkApp ((v0 {f [Bool.false] (T.bool Bool.false) {g = (v2 Up ((n : Nat::Tm) -> F (f [Bool.true] (T.nat n)){f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))})), f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))}})::Tm -> {Bool {g = (v2 Up ((n : Nat::Tm) -> F (f [Bool.true] (T.nat n)){f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))})), f = (v1 Up (.[x : Bool::Tm] -> T x -> Nat{F = (v0 Up (Nat::Tm -> Set))})), F = (v0 Up (Nat::Tm -> Set))}}) eliminated by g zero +/// leqVal' (subtyping) < g n Nat.zero : F (f x [Bool.true] (T.nat Nat.zero)) > <=+ F (f x [Bool.false] (T.bool Bool.false)) +/// leqVal' (subtyping) F (f x [Bool.true] (T.nat Nat.zero)) <=+ F (f x [Bool.false] (T.bool Bool.false)) +/// leqVal' f Bool.true (T.nat Nat.zero) <=* f Bool.false (T.bool Bool.false) : Nat +/// leqVal' T.nat Nat.zero : T Bool.true <=* T.bool Bool.false : T Bool.false +/// leqVal': head mismatch T.nat{y0 = Nat.zero{}} != T.bool{y0 = Bool.false{}} diff --git a/test/fail/UlfsCounterexample2.ma b/test/fail/UlfsCounterexample2.ma new file mode 100644 --- /dev/null +++ b/test/fail/UlfsCounterexample2.ma @@ -0,0 +1,27 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +data T : Bool -> Set +{ nat : Nat -> T true +; bool : Bool -> T false +} + +-- type checking fails with message "nat != bool" +-- can be harmful if constructors can be reused in different types +fun bad : + [F : Nat -> Set] -> + ^(f : [x : Bool] -> T x -> Nat) -> + (g : (n : Nat) -> F (f true (nat n))) -> + (h : F (f false (bool false)) -> Bool) -> + Bool +{ bad F f g h = h (g zero) +} +-- 2010-10-01 now it is checked before that +-- nat and bool are in the same family T diff --git a/test/fail/VectorPatternNotForced.err b/test/fail/VectorPatternNotForced.err new file mode 100644 --- /dev/null +++ b/test/fail/VectorPatternNotForced.err @@ -0,0 +1,42 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "VectorPatternNotForced.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term add : Nat -> Nat -> Nat +{ add Nat.zero y = y +; add (Nat.succ x) y = Nat.succ (add x y) +} +type Vec : ^(A : Set) -> ^ Nat -> Set +term Vec.nil : .[A : Set] -> < Vec.nil : Vec A Nat.zero > +term Vec.cons : .[A : Set] -> .[n : Nat] -> ^(y1 : A) -> ^(y2 : Vec A n) -> < Vec.cons n y1 y2 : Vec A (Nat.succ n) > +term length : .[A : Set] -> .[n : Nat] -> Vec A n -> < n : Nat > +{ length [A] [.Nat.zero] Vec.nil = Nat.zero +; length [A] [.(succ n)] (Vec.cons [n] a v) = Nat.succ (length [A] [n] v) +} +term head : .[A : Set] -> .[n : Nat] -> Vec A (Nat.succ n) -> A +{ head [A] [.n] (Vec.cons [n] a v) = a +} +term tail : .[A : Set] -> .[n : Nat] -> Vec A (Nat.succ n) -> Vec A n +{ tail [A] [.n] (Vec.cons [n] a v) = v +} +term zeroes : (n : Nat) -> Vec Nat n +{ zeroes Nat.zero = Vec.nil +; zeroes (Nat.succ x) = Vec.cons [x] Nat.zero (zeroes x) +} +type Fin : ^ Nat -> Set +term Fin.fzero : .[n : Nat] -> < Fin.fzero n : Fin (Nat.succ n) > +term Fin.fsucc : .[n : Nat] -> ^(y1 : Fin n) -> < Fin.fsucc n y1 : Fin (Nat.succ n) > +term lookup : .[A : Set] -> .[n : Nat] -> Vec A n -> Fin n -> A +{ lookup [A] [.(succ n)] (Vec.cons [n] a v) (Fin.fzero [.n]) = a +; lookup [A] [.(succ n)] (Vec.cons [n] a v) (Fin.fsucc [.n] i) = lookup [A] [n] v i +; lookup [A] [.Nat.zero] Vec.nil () +} +term downFrom : .[n : Nat] -> Vec Nat n +error during typechecking: +downFrom +/// clause 1 +/// pattern zero +/// checkPattern: constructor Nat.zero of non-computational argument zero : Nat not forced diff --git a/test/fail/VectorPatternNotForced.ma b/test/fail/VectorPatternNotForced.ma new file mode 100644 --- /dev/null +++ b/test/fail/VectorPatternNotForced.ma @@ -0,0 +1,48 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ add zero y = y +; add (succ x) y = succ (add x y) +} + +data Vec (A : Set) : Nat -> Set +{ nil : Vec A zero +; cons : [n : Nat] -> A -> Vec A n -> Vec A (succ n) +} + +fun length : [A : Set] -> [n : Nat] -> Vec A n -> < n : Nat > +{ length A .zero nil = zero +; length A .(succ n) (cons n a v) = succ (length A n v) +} + +fun head : [A : Set] -> [n : Nat] -> Vec A (succ n) -> A +{ head A .n (cons n a v) = a +} +fun tail : [A : Set] -> [n : Nat] -> Vec A (succ n) -> Vec A n +{ tail A .n (cons n a v) = v +} + +fun zeroes : (n : Nat) -> Vec Nat n +{ zeroes zero = nil +; zeroes (succ x) = cons x zero (zeroes x) +} + +data Fin : Nat -> Set +{ fzero : [n : Nat] -> Fin (succ n) +; fsucc : [n : Nat] -> Fin n -> Fin (succ n) +} + +fun lookup : [A : Set] -> [n : Nat] -> Vec A n -> Fin n -> A +{ lookup A .(succ n) (cons n a v) (fzero .n) = a +; lookup A .(succ n) (cons n a v) (fsucc .n i) = lookup A n v i +; lookup A .zero nil () -- IMPOSSIBLE +} + +-- the following should give an error, since we cannot match on [n : Nat] +fun downFrom : [n : Nat] -> Vec Nat n +{ downFrom zero = nil +; downFrom (succ n) = cons n n (downFrom n) +} diff --git a/test/fail/VeiledParameter.err b/test/fail/VeiledParameter.err new file mode 100644 --- /dev/null +++ b/test/fail/VeiledParameter.err @@ -0,0 +1,6 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "VeiledParameter.ma" --- +--- scope checking --- +scope check error: D +/// c +/// expression (If true A B) is not valid in a parameter diff --git a/test/fail/VeiledParameter.ma b/test/fail/VeiledParameter.ma new file mode 100644 --- /dev/null +++ b/test/fail/VeiledParameter.ma @@ -0,0 +1,11 @@ +-- 2013-04-05 + +data Bool { false ; true } + +fun If : Bool -> ++(A, B : Set) -> Set +{ If true A B = A +; If false A B = B +} + +data D (A, B : Set) +{ c : D (If true A B) (If false A B) } diff --git a/test/fail/absurdPatUnit.err b/test/fail/absurdPatUnit.err new file mode 100644 --- /dev/null +++ b/test/fail/absurdPatUnit.err @@ -0,0 +1,11 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "absurdPatUnit.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type bla : Unit -> Set +error during typechecking: +bla +/// clause 1 +/// absurd pattern does not match since type Unit is not empty diff --git a/test/fail/absurdPatUnit.ma b/test/fail/absurdPatUnit.ma new file mode 100644 --- /dev/null +++ b/test/fail/absurdPatUnit.ma @@ -0,0 +1,8 @@ +-- Absurd pattern used on non-empty type + +data Unit : Set +{ unit : Unit } + +fun bla : Unit -> Set +{ bla () +} diff --git a/test/fail/adm/adm1.err b/test/fail/adm/adm1.err new file mode 100644 --- /dev/null +++ b/test/fail/adm/adm1.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "adm/adm1.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +term foo : .[i : Size] -> Nat i +{} +type foo2 : (i : Size) -> Nat $i -> Set +{ foo2 i (Nat.zero [.i]) = foo2 i (Nat.zero [i]) +; foo2 i (Nat.succ [.i] x) = Nat # +} +error during typechecking: +Termination check for function foo2 fails diff --git a/test/fail/adm/adm1.ma b/test/fail/adm/adm1.ma new file mode 100644 --- /dev/null +++ b/test/fail/adm/adm1.ma @@ -0,0 +1,22 @@ +sized data Nat : Size -> Set +{ +zero : ( i : Size ) -> Nat ($ i); +succ : ( i : Size ) -> Nat i -> Nat ($ i); +} + + +-- size not used +fun foo : (i : Size ) -> Nat i +{ +--foo ($ i) = foo i -- subtyping +} + + +-- 2010-03-10, this is admissible, but not terminating! +fun foo2 : ( i : Size ) -> Nat ($ i) -> Set +{ +foo2 i (zero .i) = foo2 i (zero i); +foo2 i (succ .i x) = Nat # +} + + diff --git a/test/fail/adm/adm2.err b/test/fail/adm/adm2.err new file mode 100644 --- /dev/null +++ b/test/fail/adm/adm2.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "adm/adm2.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +term foo : .[i : Size] -> Nat i +error during typechecking: +foo +/// clause 1 +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/adm/adm2.ma b/test/fail/adm/adm2.ma new file mode 100644 --- /dev/null +++ b/test/fail/adm/adm2.ma @@ -0,0 +1,15 @@ +sized data Nat : Size -> Set +{ +zero : ( i : Size ) -> Nat ($ i); +succ : ( i : Size ) -> Nat i -> Nat ($ i) +} + +-- 2010-03-10 +-- termination checking fails because this pattern is declared unusable +-- it would be clearer if the pattern ($ i) was rejected because +-- Nat i is not coinductive +-- 2010-08-18 now clearer +fun foo : (i : Size ) -> Nat i +{ +foo ($ i) = foo i +} diff --git a/test/fail/adm/adm3.err b/test/fail/adm/adm3.err new file mode 100644 --- /dev/null +++ b/test/fail/adm/adm3.err @@ -0,0 +1,19 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "adm/adm3.ma" --- +--- scope checking --- +--- type checking --- +type Maybe : ^(A : Set) -> Set +term Maybe.nothing : .[A : Set] -> < Maybe.nothing : Maybe A > +term Maybe.just : .[A : Set] -> ^(y0 : A) -> < Maybe.just y0 : Maybe A > +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term bla : .[i : Size] -> SNat $i -> SNat i +error during typechecking: +bla +/// clause 1 +/// pattern zero $i +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/adm/adm3.ma b/test/fail/adm/adm3.ma new file mode 100644 --- /dev/null +++ b/test/fail/adm/adm3.ma @@ -0,0 +1,33 @@ +data Maybe (A : Set) : Set +{ nothing : Maybe A +; just : A -> Maybe A +} + +sized data SNat : Size -> Set +{ +zero : (i : Size ) -> SNat ($ i); +succ : (i : Size ) -> SNat i -> SNat ($ i) +} + +-- no complete pattern matching +fun bla : (i : Size ) -> SNat ($ i) -> SNat i +{ +bla .($ i) (zero ($ i)) = zero i; -- no complete pattern matching +bla .i (succ i x) = x +} +-- 2010-08-18 new error: successor pattern only allowed in cofun + +-- termination check fails because ($ i) is unusable +fun loop : (i : Size ) -> (SNat i) -> Set +{ +loop ($ i) x = loop i (bla i x) +} + +eval let diverge : Set = loop # (zero #) + +fun deconstruct_nat : (i : Size) -> SNat ($ i) -> Maybe (SNat i) +{ + deconstruct_nat i (zero .i) = nothing (SNat i); + deconstruct_nat i (succ .i n) = just (SNat i) n +} + diff --git a/test/fail/bfSizePatternIncomplete.err b/test/fail/bfSizePatternIncomplete.err new file mode 100644 --- /dev/null +++ b/test/fail/bfSizePatternIncomplete.err @@ -0,0 +1,31 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "bfSizePatternIncomplete.ma" --- +--- scope checking --- +--- type checking --- +type Prod : ++(A : Set) -> ++(B : Set) -> Set +term Prod.pair : .[A : Set] -> .[B : Set] -> ^(y0 : A) -> ^(y1 : B) -> < Prod.pair y0 y1 : Prod A B > +term split : .[A : Set] -> .[B : Set] -> Prod A B -> .[C : Set] -> (A -> B -> C) -> C +{ split [A] [B] (Prod.pair a b) [C] f = f a b +} +type List : ++(A : Set) -> + Size -> Set +term List.nil : .[A : Set] -> .[s!ze : Size] -> .[i < s!ze] -> List A s!ze +term List.nil : .[A : Set] -> .[i : Size] -> < List.nil i : List A $i > +term List.cons : .[A : Set] -> .[s!ze : Size] -> .[i < s!ze] -> ^ A -> ^ List A i -> List A s!ze +term List.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : List A i) -> < List.cons i y1 y2 : List A $i > +term append : .[A : Set] -> List A # -> List A # -> List A # +{ append [A] (List.nil [.#]) l = l +; append [A] (List.cons [.#] a as) l = List.cons [#] a (append [A] as l) +} +type Rose : ++(A : Set) -> + Size -> Set +term Rose.rose : .[A : Set] -> .[s!ze : Size] -> .[i < s!ze] -> ^ A -> ^ List (Rose A i) # -> Rose A s!ze +term Rose.rose : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : List (Rose A i) #) -> < Rose.rose i y1 y2 : Rose A $i > +term step : .[j : Size] -> .[A : Set] -> .[i : Size] -> List (Rose A $i) j -> Prod (List A j) (List (Rose A i) #) +{ step [.$j] [A] [i] (List.nil [j]) = Prod.pair (List.nil [j]) (List.nil [#]) +; step [.$j] [A] [.i] (List.cons [j] (Rose.rose [i] a rs') rs) = split [List A j] [List (Rose A i) #] (step [j] [A] [i] rs) [Prod (List A $j) (List (Rose A i) #)] (\ as -> \ rs'' -> Prod.pair (List.cons [j] a as) (append [Rose A i] rs' rs'')) +} +term bf' : .[A : Set] -> .[i : Size] -> List A # -> List (Rose A i) # -> List A # +error during typechecking: +bf' +/// clause 1 +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/bfSizePatternIncomplete.ma b/test/fail/bfSizePatternIncomplete.ma new file mode 100644 --- /dev/null +++ b/test/fail/bfSizePatternIncomplete.ma @@ -0,0 +1,71 @@ +data Prod (+A : Set) (+B : Set) : Set +{ + pair : A -> B -> Prod A B +} + +fun split : (A : Set) -> (B : Set) -> Prod A B -> + (C : Set) -> (A -> B -> C) -> C +{ + split A B (pair a b) C f = f a b +} + +sized data List (+ A : Set) : Size -> Set +{ + nil : (i : Size) -> List A ($ i) ; + cons : (i : Size) -> A -> List A i -> List A ($ i) +} + +fun append : (A : Set) -> List A # -> List A # -> List A # +{ + append A (nil .#) l = l; + append A (cons .# a as) l = cons # a (append A as l) +} + +sized data Rose (+A : Set) : Size -> Set +{ + rose : (i : Size) -> A -> List (Rose A i) # -> Rose A ($ i) +} + + + +fun step : (j : Size) -> (A : Set) -> (i : Size) -> + List (Rose A ($ i)) j -> + Prod (List A j) (List (Rose A i) #) + +{ + step .($ j) A i (nil {- .(Rose A ($ i)) -} j) = + pair {- (List A _) (List (Rose A _) _) -} + (nil _) + (nil {- (Rose A i) -} _); + + step .($ j) A .i (cons {- .(Rose A ($ i)) -} j (rose i a rs') rs) = + split (List A j) (List (Rose A i) #) + (step j A i rs) + (Prod (List A ($ j)) (List (Rose A i) #)) + (\ as -> \ rs'' -> pair {- (List A _) (List (Rose A _) #) -} + (cons _ a as) + (append (Rose A i) rs' rs'')) + +} + +-- 2010-08-18 new error: successor pattern only allowed in cofun +fun bf' : (A : Set) -> (i : Size) -> List A # -> List (Rose A i) # -> List A # +{ + bf' A ($ i) as (nil {-.(Rose A ($ i))-} .#) = as; + bf' A ($ i) as (cons {-.(Rose A ($ i))-} .# r rs) = append A as + (split + (List A #) (List (Rose A i) #) + (step # A i (cons {-(Rose A ($ i))-} _ r rs)) + (List A #) + (bf' A i) + ) +} + +{- +fun bf : (i : Size) -> (A : Set) -> Rose A i -> List (Rose A i) # -> List A # +{ + + bf i A r rs + +} +-} diff --git a/test/fail/bfTypeNotAdmissible.err b/test/fail/bfTypeNotAdmissible.err new file mode 100644 --- /dev/null +++ b/test/fail/bfTypeNotAdmissible.err @@ -0,0 +1,39 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "bfTypeNotAdmissible.ma" --- +--- scope checking --- +--- type checking --- +type Prod : ++(A : Set) -> ++(B : Set) -> Set +term Prod.pair : .[A : Set] -> .[B : Set] -> ^(y0 : A) -> ^(y1 : B) -> < Prod.pair y0 y1 : Prod A B > +term split : .[A : Set] -> .[B : Set] -> Prod A B -> .[C : Set] -> (A -> B -> C) -> C +{ split [A] [B] (Prod.pair a b) [C] f = f a b +} +type List : ++(A : Set) -> + Size -> Set +term List.nil : .[A : Set] -> .[s!ze : Size] -> .[i < s!ze] -> List A s!ze +term List.nil : .[A : Set] -> .[i : Size] -> < List.nil i : List A $i > +term List.cons : .[A : Set] -> .[s!ze : Size] -> .[i < s!ze] -> ^ A -> ^ List A i -> List A s!ze +term List.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : List A i) -> < List.cons i y1 y2 : List A $i > +term append : .[A : Set] -> List A # -> List A # -> List A # +{ append [A] (List.nil [.#]) l = l +; append [A] (List.cons [.#] a as) l = List.cons [#] a (append [A] as l) +} +type Rose : ++(A : Set) -> + Size -> Set +term Rose.rose : .[A : Set] -> .[s!ze : Size] -> .[i < s!ze] -> ^ A -> ^ List (Rose A i) # -> Rose A s!ze +term Rose.rose : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : List (Rose A i) #) -> < Rose.rose i y1 y2 : Rose A $i > +term step : .[j : Size] -> .[A : Set] -> .[i : Size] -> List (Rose A $i) j -> Prod (List A j) (List (Rose A i) #) +{ step [.$j] [A] [i] (List.nil [j]) = Prod.pair (List.nil [j]) (List.nil [#]) +; step [.$j] [A] [.i] (List.cons [j] (Rose.rose [i] a rs') rs) = split [List A j] [List (Rose A i) #] (step [j] [A] [i] rs) [Prod (List A $j) (List (Rose A i) #)] (\ as -> \ rs'' -> Prod.pair (List.cons [j] a as) (append [Rose A i] rs' rs'')) +} +term bf' : .[A : Set] -> .[i : Size] -> List A # -> List (Rose A i) # -> List A # +error during typechecking: +checking type of bf' for admissibility +/// new A : _ +/// new as : _ +/// new i : _ +/// new a : _ +/// new r : _ +/// new rs : _ +/// new i <= # +/// admType: checking ((List v0 #)::Tm -> {List (Rose A i) # -> List A # {i = v6, A = v0}}) admissible in v6 +/// new : (List v0 #) +/// admType: checking ((List {Rose A i {i = v6, A = v0}} #)::Tm -> {List A # {i = v6, A = v0}}) admissible in v6 +/// type List (Rose A i) # not lower semi continuous in i diff --git a/test/fail/bfTypeNotAdmissible.ma b/test/fail/bfTypeNotAdmissible.ma new file mode 100644 --- /dev/null +++ b/test/fail/bfTypeNotAdmissible.ma @@ -0,0 +1,84 @@ +data Prod (+A : Set) (+B : Set) : Set +{ + pair : A -> B -> Prod A B +} + +fun split : (A : Set) -> (B : Set) -> Prod A B -> + (C : Set) -> (A -> B -> C) -> C +{ + split A B (pair a b) C f = f a b +} + +sized data List (+ A : Set) : Size -> Set +{ + nil : (i : Size) -> List A ($ i) ; + cons : (i : Size) -> A -> List A i -> List A ($ i) +} + +fun append : (A : Set) -> List A # -> List A # -> List A # +{ + append A (nil .#) l = l; + append A (cons .# a as) l = cons # a (append A as l) +} + +sized data Rose (+A : Set) : Size -> Set +{ + rose : (i : Size) -> A -> List (Rose A i) # -> Rose A ($ i) +} + + + +fun step : (j : Size) -> (A : Set) -> (i : Size) -> + List (Rose A ($ i)) j -> + Prod (List A j) (List (Rose A i) #) + +{ + step .($ j) A i (nil j) = pair (nil _) (nil _); + + step .($ j) A .i (cons j (rose i a rs') rs) = + split (List A j) (List (Rose A i) #) + (step j A i rs) + (Prod (List A ($ j)) (List (Rose A i) #)) + (\ as -> \ rs'' -> pair + (cons _ a as) + (append (Rose A i) rs' rs'')) + +} + +fun bf' : (A : Set) -> (i : Size) -> List A # -> List (Rose A i) # -> List A # +{ + bf' A i as (nil .#) = as; + bf' A .($ i) as (cons .# (rose i a r) rs) = append A as + (split + (List A #) (List (Rose A i) #) + (step # A i (cons _ (rose _ a r) rs)) + (List A #) + (bf' A i) + ) +} + +{- +mutual { + + fun bf' : (A : Set) -> (i : Size) -> List A # -> List (Rose A i) # -> List A # + { + bf' A ($ i) as (nil .(Rose A ($ i)) .#) = as; + bf' A ($ i) as (cons .(Rose A ($ i)) .# r rs) = + append A as (bf A i r rs) + } + + fun bf : (A : Set) -> (i : Size) -> Rose A i -> List (Rose A i) # -> List A # + { + + bf A i r rs = + (split + (List A #) (List (Rose A i) #) + (step # A i (cons (Rose A ($ i)) _ r rs)) + (List A #) + (bf' A i) + ) + } + +} + +-} diff --git a/test/fail/bigData.err b/test/fail/bigData.err new file mode 100644 --- /dev/null +++ b/test/fail/bigData.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "bigData.ma" --- +--- scope checking --- +--- type checking --- +type Any : Set +error during typechecking: +Any +/// constructor Any.inn +/// new Any : Set +/// inferExpr' ^(Out : Set) -> Any +/// new Out : Set +/// leSize 1 <=+ 0 +/// leSize' 1 <= 0 +/// leSize': 1 <= 0 failed diff --git a/test/fail/bigData.ma b/test/fail/bigData.ma new file mode 100644 --- /dev/null +++ b/test/fail/bigData.ma @@ -0,0 +1,15 @@ +-- 2010-06-25 removed Set:Set, so this should not pass + +data Any : Set +{ inn : (Out : Set) -> Any } + +data Big : Set -> Set +{ + big : (A : Set) -> (B : Set) -> Big (A -> B) +} + +fun bla : (A : Set) -> Big A -> Big A +{ + bla .(A -> B) (big A B) = big A B +-- bla (.(A) -> .(B)) (big A B) = big A B +} diff --git a/test/fail/coSetOmega.err b/test/fail/coSetOmega.err new file mode 100644 --- /dev/null +++ b/test/fail/coSetOmega.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "coSetOmega.ma" --- +--- scope checking --- +--- type checking --- +type D : (i : Size) -> CoSet i +error during typechecking: +D +/// clause 1 +/// right hand side +/// checkExpr 1 |- D i -> D i : CoSet $i +/// checkForced fromList [(i,0)] |- D i -> D i : CoSet $i +/// inferExpr' D i -> D i +/// new : (D v0) +/// ptsRule ((CoSet v0),(CoSet v0)) : domain cannot be sized diff --git a/test/fail/coSetOmega.ma b/test/fail/coSetOmega.ma new file mode 100644 --- /dev/null +++ b/test/fail/coSetOmega.ma @@ -0,0 +1,10 @@ +cofun D : (i : Size) -> CoSet i +{ D ($ i) = D i -> D i +} + +let sapp : D # -> D # + = \ x -> x x + +eval let omega : D # -> D # + = sapp sapp + diff --git a/test/fail/coSizeInFun.err b/test/fail/coSizeInFun.err new file mode 100644 --- /dev/null +++ b/test/fail/coSizeInFun.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "coSizeInFun.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Stream : - Size -> Set +term Stream.cons : .[i : Size] -> ^(y1 : SNat #) -> ^(y2 : Stream i) -> < Stream.cons i y1 y2 : Stream $i > +term bla : .[i : Size] -> SNat i -> .[j : Size] -> Stream j -> .[A : Set] -> A +error during typechecking: +bla +/// clause 1 +/// pattern $j +/// successor pattern only allowed in cofun diff --git a/test/fail/coSizeInFun.ma b/test/fail/coSizeInFun.ma new file mode 100644 --- /dev/null +++ b/test/fail/coSizeInFun.ma @@ -0,0 +1,31 @@ + +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +sized codata Stream : Size -> Set { + cons : (i : Size) -> SNat # -> Stream i -> Stream ($ i) +} + +-- This is a fake lexicographic induction on (j,i) + +-- 2010-03-10: size pattern in co constructors must be dotted +-- but the pattern ($ j) fails since target is not Stream j +fun bla : (i : Size) -> SNat i -> (j : Size) -> Stream j -> (A : Set) -> A +{ + bla .($ i) (zero i) ($ j) (cons .j x xs) = bla # x j xs ; + bla .($ i) (succ i y) j xs = bla i y j xs +} +-- 2010-08-18: ($ j) only in cofun + +-- OLD: +-- Analysis declares j unusable for termination, so termination check fails +fun blo : (i : Size) -> SNat i -> (j : Size) -> Stream j -> (A : Set) -> A +{ + blo .($ i) (zero i) .($ j) (cons j x xs) = blo # x j xs ; + blo .($ i) (succ i y) j xs = blo i y j xs +} +-- NEW: +-- size patterns in coconstructors must be dotted! diff --git a/test/fail/codataNotMonotone.err b/test/fail/codataNotMonotone.err new file mode 100644 --- /dev/null +++ b/test/fail/codataNotMonotone.err @@ -0,0 +1,23 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "codataNotMonotone.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type NatEq : -(i : Size) -> ^ SNat i -> ^ SNat i -> Set +term NatEq.eqz : .[i : Size] -> < NatEq.eqz i : NatEq $i (SNat.zero [i]) (SNat.zero [i]) > +error during typechecking: +NatEq +/// constructor NatEq.eqs +/// szConstructor NatEq : .[i : Size] -> .[n : SNat i] -> .[m : SNat i] -> ^(y3 : NatEq i n m) -> < NatEq.eqs i n m y3 : NatEq $i (SNat.succ [i] n) (SNat.succ [i] m) > +/// new i <= # +/// szSizeVarUsage of i in .[n : SNat i] -> .[m : SNat i] -> ^(y3 : NatEq i n m) -> < NatEq.eqs i n m y3 : NatEq $i (SNat.succ [i] n) (SNat.succ [i] m) > +/// checking SNat i to be antitone in variable i +/// leqVal' SNat i <=- SNat $i : Set # +/// leqVal' i <=- $i : Size +/// leSize i <=- $i +/// leSize' $i <= i +/// leSize: 0 + 1 <= 0 failed diff --git a/test/fail/codataNotMonotone.ma b/test/fail/codataNotMonotone.ma new file mode 100644 --- /dev/null +++ b/test/fail/codataNotMonotone.ma @@ -0,0 +1,12 @@ +-- 2010-05-06 + +sized data SNat : Size -> Set +{ zero : [i : Size] -> SNat ($ i) +; succ : [i : Size] -> SNat i -> SNat ($ i) +} + +sized codata NatEq : (i : Size) -> SNat i -> SNat i -> Set +{ eqz : [i : Size] -> NatEq ($ i) (zero i) (zero i) +; eqs : [i : Size] -> (n : SNat i) -> (m : SNat i) -> + NatEq i n m -> NatEq ($ i) (succ i n) (succ i m) +} diff --git a/test/fail/codyPatternConditionExplicit.err b/test/fail/codyPatternConditionExplicit.err new file mode 100644 --- /dev/null +++ b/test/fail/codyPatternConditionExplicit.err @@ -0,0 +1,60 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "codyPatternConditionExplicit.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type O : + Size -> Set +term O.Z : .[s!ze : Size] -> .[i < s!ze] -> O s!ze +term O.Z : .[i : Size] -> < O.Z i : O $i > +term O.S : .[s!ze : Size] -> .[i < s!ze] -> ^ O i -> O s!ze +term O.S : .[i : Size] -> ^(y1 : O i) -> < O.S i y1 : O $i > +term O.L : .[s!ze : Size] -> .[i < s!ze] -> ^ (Nat -> O i) -> O s!ze +term O.L : .[i : Size] -> ^(y1 : Nat -> O i) -> < O.L i y1 : O $i > +term O.M : .[s!ze : Size] -> .[i < s!ze] -> ^ O i -> ^ O i -> O s!ze +term O.M : .[i : Size] -> ^(y1 : O i) -> ^(y2 : O i) -> < O.M i y1 y2 : O $i > +term f01 : .[i : Size] -> Nat -> O $$$i +{ f01 [i] Nat.zero = O.Z [i] +; f01 [i] (Nat.succ Nat.zero) = O.S [$i] (O.Z [i]) +; f01 [i] (Nat.succ (Nat.succ n)) = O.S [$$i] (O.S [$i] (O.Z [i])) +} +term v5 : .[i : Size] -> O $$$$$i +term v5 = [\ i ->] O.M [$$$$i] (O.L [$$$i] (f01 [i])) (O.S [$$$i] (O.S [$$i] (O.S [$i] (O.Z [i])))) +term emb : Nat -> O # +{ emb Nat.zero = O.Z [#] +; emb (Nat.succ n) = O.S [#] (emb n) +} +term pre : .[i : Size] -> (Nat -> O $$i) -> Nat -> O $i +term pre = [\ i ->] \ f -> \ n -> case f (Nat.succ n) : O $$i + { O.Z [.$i] -> O.Z [i] + ; O.S [.$i] x -> x + ; O.L [.$i] g -> g n + ; O.M [.$i] a b -> a + } +term deep : .[i : Size] -> O i -> Nat -> Nat +error during typechecking: +deep +/// clause 1 +/// right hand side +/// checkExpr 9 |- deep $$$i (M $$i (L $i (pre i f)) (S j2 (f n))) (succ (succ (succ n))) : Nat +/// inferExpr' deep $$$i (M $$i (L $i (pre i f)) (S j2 (f n))) (succ (succ (succ n))) +/// inferExpr' deep $$$i (M $$i (L $i (pre i f)) (S j2 (f n))) +/// checkApp ((O ($ ($ ($ v6))))::Tm -> {Nat -> Nat {i = ($ ($ ($ v6)))}}) eliminated by M $$i (L $i (pre i f)) (S j2 (f n)) +/// checkExpr 9 |- M $$i (L $i (pre i f)) (S j2 (f n)) : O $$$i +/// checkForced fromList [(i4,0),(i3,1),(j2,2),(f,3),(i2,4),(i1,5),(i,6),(x,7),(n,8)] |- M $$i (L $i (pre i f)) (S j2 (f n)) : O $$$i +/// checkApp (^(y1 : (O ($ ($ v6)))::()) -> ^(y2 : O i) -> < O.M i y1 y2 : O $i >{i = ($ ($ v6))}) eliminated by L $i (pre i f) +/// checkExpr 9 |- L $i (pre i f) : O $$i +/// checkForced fromList [(i4,0),(i3,1),(j2,2),(f,3),(i2,4),(i1,5),(i,6),(x,7),(n,8)] |- L $i (pre i f) : O $$i +/// checkApp (^(y1 : (Nat::Tm -> {O i {i = ($ v6)}})::()) -> < O.L i y1 : O $i >{i = ($ v6)}) eliminated by pre i f +/// inferExpr' pre i f +/// checkApp ((Nat::Tm -> {O $$i {i = v6}})::Tm -> {Nat -> O $i {i = v6}}) eliminated by f +/// leqVal' (subtyping) (xSing# : Nat) -> < f xSing# : O j2 > <=+ Nat -> O $$i +/// new xSing# : Nat +/// comparing codomain < f xSing# : O j2 > with O $$i +/// leqVal' (subtyping) < f xSing# : O j2 > <=+ O $$i +/// leqVal' (subtyping) O j2 <=+ O $$i +/// leqVal' j2 <=+ $$i : Size +/// leSize j2 <=+ $$i +/// leSize' j2 <= $$i +/// bound not entailed diff --git a/test/fail/codyPatternConditionExplicit.ma b/test/fail/codyPatternConditionExplicit.ma new file mode 100644 --- /dev/null +++ b/test/fail/codyPatternConditionExplicit.ma @@ -0,0 +1,62 @@ +{- 2010-02-02 Cody Roux communicated and observation of Frederic + Blanqui that the "non-linear" size-assignment for constructors (see + M below) does not allow to express the precise sizes in a deep + match involving a limit ordinal (see L below). From this I could + construct a non-looping term in MiniAgda. + + 2010-03-09 + This file tests whether the loop is still accepted after the fix. + -} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +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) +} + +{- 2010-03-08 construct a value of size 5 -} + +fun f01 : [i : Size] -> Nat -> O ($$$ i) +{ f01 i zero = Z i +; f01 i (succ zero) = S _ (Z i) +; f01 i (succ (succ n)) = S _ (S _ (Z i)) +} + +let v5 : [i : Size] -> O ($$$$$ i) + = \ i -> M $$$$i (L $$$i (f01 i)) (S $$$i (S $$i (S $i (Z i)))) + +fun emb : Nat -> O # +{ emb zero = Z # +; emb (succ n) = S # (emb n) +} + +let pre : [i : Size] -> (Nat -> O ($ ($ i))) -> Nat -> O ($ i) + = \ i -> \ f -> \ n -> case (f (succ n)) + { (Z .($ i)) -> Z i + ; (S .($ i) x) -> x + ; (L .($ i) g) -> g n + ; (M .($ i) a b) -> a + } + +fun deep : [i : Size] -> O i -> Nat -> Nat +{ deep i4 + (M (i4 > i3) + (L (i3 > j2) f) + (S (i3 > i2) + (S (i2 > i1) + (S (i1 > i) x)))) n + = deep ($$$ i) (M ($$ i) (L ($ i) (pre i f)) (S j2 (f n))) (succ (succ (succ n))) +; deep i x n = n +} + + +let four : Nat + = succ (succ (succ (succ zero))) + +eval let loop : Nat = deep # (M # (L # emb) (emb four)) four diff --git a/test/fail/codyPatternConditionExplicit2.err b/test/fail/codyPatternConditionExplicit2.err new file mode 100644 --- /dev/null +++ b/test/fail/codyPatternConditionExplicit2.err @@ -0,0 +1,60 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "codyPatternConditionExplicit2.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type O : + Size -> Set +term O.Z : .[s!ze : Size] -> .[i < s!ze] -> O s!ze +term O.Z : .[i : Size] -> < O.Z i : O $i > +term O.S : .[s!ze : Size] -> .[i < s!ze] -> ^ O i -> O s!ze +term O.S : .[i : Size] -> ^(y1 : O i) -> < O.S i y1 : O $i > +term O.L : .[s!ze : Size] -> .[i < s!ze] -> ^ (Nat -> O i) -> O s!ze +term O.L : .[i : Size] -> ^(y1 : Nat -> O i) -> < O.L i y1 : O $i > +term O.M : .[s!ze : Size] -> .[i < s!ze] -> ^ O i -> ^ O i -> O s!ze +term O.M : .[i : Size] -> ^(y1 : O i) -> ^(y2 : O i) -> < O.M i y1 y2 : O $i > +term f01 : .[i : Size] -> Nat -> O $$$i +{ f01 [i] Nat.zero = O.Z [i] +; f01 [i] (Nat.succ Nat.zero) = O.S [$i] (O.Z [i]) +; f01 [i] (Nat.succ (Nat.succ n)) = O.S [$$i] (O.S [$i] (O.Z [i])) +} +term v5 : .[i : Size] -> O $$$$$i +term v5 = [\ i ->] O.M [$$$$i] (O.L [$$$i] (f01 [i])) (O.S [$$$i] (O.S [$$i] (O.S [$i] (O.Z [i])))) +term emb : Nat -> O # +{ emb Nat.zero = O.Z [#] +; emb (Nat.succ n) = O.S [#] (emb n) +} +term pre : .[i : Size] -> (Nat -> O $$i) -> Nat -> O $i +term pre = [\ i ->] \ f -> \ n -> case f (Nat.succ n) : O $$i + { O.Z [.$i] -> O.Z [i] + ; O.S [.$i] x -> x + ; O.L [.$i] g -> g n + ; O.M [.$i] a b -> a + } +term deep : .[i : Size] -> O i -> Nat -> Nat +error during typechecking: +deep +/// clause 1 +/// right hand side +/// checkExpr 9 |- deep (max $$$i $$j2) (M (max $$i $j2) (L $i (pre $$i f)) (S j2 (f n))) (succ (succ (succ n))) : Nat +/// inferExpr' deep (max $$$i $$j2) (M (max $$i $j2) (L $i (pre $$i f)) (S j2 (f n))) (succ (succ (succ n))) +/// inferExpr' deep (max $$$i $$j2) (M (max $$i $j2) (L $i (pre $$i f)) (S j2 (f n))) +/// checkApp ((O (max ($ ($ ($ v6))) ($ ($ v2))))::Tm -> {Nat -> Nat {i = (max ($ ($ ($ v6))) ($ ($ v2)))}}) eliminated by M (max $$i $j2) (L $i (pre $$i f)) (S j2 (f n)) +/// checkExpr 9 |- M (max $$i $j2) (L $i (pre $$i f)) (S j2 (f n)) : O (max $$$i $$j2) +/// checkForced fromList [(i4,0),(i3,1),(j2,2),(f,3),(i2,4),(i1,5),(i,6),(x,7),(n,8)] |- M (max $$i $j2) (L $i (pre $$i f)) (S j2 (f n)) : O (max $$$i $$j2) +/// checkApp (^(y1 : (O (max ($ ($ v6)) ($ v2)))::()) -> ^(y2 : O i) -> < O.M i y1 y2 : O $i >{i = (max ($ ($ v6)) ($ v2))}) eliminated by L $i (pre $$i f) +/// checkExpr 9 |- L $i (pre $$i f) : O (max $$i $j2) +/// checkForced fromList [(i4,0),(i3,1),(j2,2),(f,3),(i2,4),(i1,5),(i,6),(x,7),(n,8)] |- L $i (pre $$i f) : O (max $$i $j2) +/// checkApp (^(y1 : (Nat::Tm -> {O i {i = ($ v6)}})::()) -> < O.L i y1 : O $i >{i = ($ v6)}) eliminated by pre $$i f +/// inferExpr' pre $$i f +/// checkApp ((Nat::Tm -> {O $$i {i = ($ ($ v6))}})::Tm -> {Nat -> O $i {i = ($ ($ v6))}}) eliminated by f +/// leqVal' (subtyping) (xSing# : Nat) -> < f xSing# : O j2 > <=+ Nat -> O $$$$i +/// new xSing# : Nat +/// comparing codomain < f xSing# : O j2 > with O $$$$i +/// leqVal' (subtyping) < f xSing# : O j2 > <=+ O $$$$i +/// leqVal' (subtyping) O j2 <=+ O $$$$i +/// leqVal' j2 <=+ $$$$i : Size +/// leSize j2 <=+ $$$$i +/// leSize' j2 <= $$$$i +/// bound not entailed diff --git a/test/fail/codyPatternConditionExplicit2.ma b/test/fail/codyPatternConditionExplicit2.ma new file mode 100644 --- /dev/null +++ b/test/fail/codyPatternConditionExplicit2.ma @@ -0,0 +1,63 @@ +{- 2010-02-02 Cody Roux communicated and observation of Frederic + Blanqui that the "non-linear" size-assignment for constructors (see + M below) does not allow to express the precise sizes in a deep + match involving a limit ordinal (see L below). From this I could + construct a non-looping term in MiniAgda. + + 2010-03-09 + This file tests whether the loop is still accepted after the fix. + -} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +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) +} + +{- 2010-03-08 construct a value of size 5 -} + +fun f01 : [i : Size] -> Nat -> O ($$$ i) +{ f01 i zero = Z i +; f01 i (succ zero) = S _ (Z i) +; f01 i (succ (succ n)) = S _ (S _ (Z i)) +} + +let v5 : [i : Size] -> O ($$$$$ i) + = \ i -> M $$$$i (L $$$i (f01 i)) (S $$$i (S $$i (S $i (Z i)))) + +fun emb : Nat -> O # +{ emb zero = Z # +; emb (succ n) = S # (emb n) +} + +let pre : [i : Size] -> (Nat -> O ($ ($ i))) -> Nat -> O ($ i) + = \ i -> \ f -> \ n -> case (f (succ n)) + { (Z .($ i)) -> Z i + ; (S .($ i) x) -> x + ; (L .($ i) g) -> g n + ; (M .($ i) a b) -> a + } + +fun deep : [i : Size] -> O i -> Nat -> Nat +{ deep i4 + (M (i4 > i3) + (L (i3 > j2) f) + (S (i3 > i2) + (S (i2 > i1) + (S (i1 > i) x)))) n -- illtyped! vv + = deep (max ($$$ i) ($$ j2)) (M (max ($$ i) ($ j2)) (L ($ i) (pre ($$ i) f)) (S j2 (f n))) (succ (succ (succ n))) + -- 8 9 10 11 12 +; deep i x n = n +} + + +let four : Nat + = succ (succ (succ (succ zero))) + +eval let loop : Nat = deep # (M # (L # emb) (emb four)) four diff --git a/test/fail/cofunIntoBoolTimesStream.err b/test/fail/cofunIntoBoolTimesStream.err new file mode 100644 --- /dev/null +++ b/test/fail/cofunIntoBoolTimesStream.err @@ -0,0 +1,37 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "cofunIntoBoolTimesStream.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Prod : ++(A : Set) -> ++(B : Set) -> Set +term Prod.pair : .[A : Set] -> .[B : Set] -> ^(fst : A) -> ^(snd : B) -> < Prod.pair fst snd : Prod A B > +term fst : .[A : Set] -> .[B : Set] -> (pair : Prod A B) -> A +{ fst [A] [B] (Prod.pair #fst #snd) = #fst +} +term snd : .[A : Set] -> .[B : Set] -> (pair : Prod A B) -> B +{ snd [A] [B] (Prod.pair #fst #snd) = #snd +} +type BStr : - Size -> Set +term BStr.cons : .[i : Size] -> ^(head : Bool) -> ^(tail : BStr i) -> < BStr.cons i head tail : BStr $i > +term head : .[i : Size] -> (cons : BStr $i) -> Bool +{ head [i] (BStr.cons [.i] #head #tail) = #head +} +term tail : .[i : Size] -> (cons : BStr $i) -> BStr i +{ tail [i] (BStr.cons [.i] #head #tail) = #tail +} +term idAndLast : .[i : Size] -> BStr i -> Prod Bool (BStr i) +error during typechecking: +idAndLast +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> BStr i -> Prod Bool (BStr i) ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: BStr i -> Prod Bool (BStr i) +/// new : (BStr v0) +/// endsInSizedCo: Prod Bool (BStr i) +/// allTypesOfTuple: detected tuple target, checking components +/// allComponentTypes: checking fields of tuple type [field fst : A,field snd : B] in environment Environ {envMap = [(B,(BStr v0)),(A,Bool)], envBound = Nothing} +/// endsInSizedCo: Bool +/// endsInSizedCo: target Bool of corecursive function is neither a CoSet or codata of size i nor a tuple type diff --git a/test/fail/cofunIntoBoolTimesStream.ma b/test/fail/cofunIntoBoolTimesStream.ma new file mode 100644 --- /dev/null +++ b/test/fail/cofunIntoBoolTimesStream.ma @@ -0,0 +1,32 @@ +-- 2010-05-19 + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Prod (+ A : Set) (+ B : Set) : Set +{ pair : (fst : A) -> (snd : B) -> Prod A B +} +fields fst, snd + +sized codata BStr : Size -> Set +{ cons : [i : Size] -> (head : Bool) -> (tail : BStr i) -> BStr ($ i) +} +fields head, tail + +-- this code needs to be rejected by the type checker! : +-- a "function" returning the input stream plus its "last" bit +cofun idAndLast : [i : Size] -> BStr i -> Prod Bool (BStr i) +{ idAndLast ($ i) (cons .i b bs) = pair {- Bool (BStr ($ i)) -} + (fst {- Bool (BStr i) -} (idAndLast i bs)) + (cons i b (idAndLast i bs)) +} + +cofun trues : [i : Size] -> BStr i +{ trues ($ i) = cons i true (trues i) +} + +-- this will loop: +eval let last : Bool = snd {- Bool (BStr #) -} (idAndLast # (trues #)) + diff --git a/test/fail/cofunIntoStreamPlusStream.err b/test/fail/cofunIntoStreamPlusStream.err new file mode 100644 --- /dev/null +++ b/test/fail/cofunIntoStreamPlusStream.err @@ -0,0 +1,35 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "cofunIntoStreamPlusStream.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Twice : ++(A : Set) -> Set +term Twice.inl : .[A : Set] -> ^(y0 : A) -> < Twice.inl y0 : Twice A > +term Twice.inr : .[A : Set] -> ^(y0 : A) -> < Twice.inr y0 : Twice A > +term fmap : .[A : Set] -> .[B : Set] -> (A -> B) -> Twice A -> Twice B +{ fmap [A] [B] f (Twice.inl a) = Twice.inl (f a) +; fmap [A] [B] f (Twice.inr a) = Twice.inr (f a) +} +type BStr : - Size -> Set +term BStr.cons : .[i : Size] -> ^(head : Bool) -> ^(tail : BStr i) -> < BStr.cons i head tail : BStr $i > +term head : .[i : Size] -> (cons : BStr $i) -> Bool +{ head [i] (BStr.cons [.i] #head #tail) = #head +} +term tail : .[i : Size] -> (cons : BStr $i) -> BStr i +{ tail [i] (BStr.cons [.i] #head #tail) = #tail +} +term idAndLast : .[i : Size] -> BStr i -> Twice (BStr i) +error during typechecking: +idAndLast +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> BStr i -> Twice (BStr i) ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: BStr i -> Twice (BStr i) +/// new : (BStr v0) +/// endsInSizedCo: Twice (BStr i) +/// endsInSizedCo: target Twice (BStr i) of corecursive function is neither a CoSet or codata of size i nor a tuple type diff --git a/test/fail/cofunIntoStreamPlusStream.ma b/test/fail/cofunIntoStreamPlusStream.ma new file mode 100644 --- /dev/null +++ b/test/fail/cofunIntoStreamPlusStream.ma @@ -0,0 +1,40 @@ +-- 2010-05-19 + +data Unit : Set +{ unit : Unit +} + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Twice (+ A : Set) : Set +{ inl : A -> Twice A +; inr : A -> Twice A +} + +fun fmap : [A : Set] -> [B : Set] -> (A -> B) -> Twice A -> Twice B +{ fmap A B f (inl a) = inl (f a) +; fmap A B f (inr a) = inr (f a) +} + +sized codata BStr : Size -> Set +{ cons : [i : Size] -> (head : Bool) -> (tail : BStr i) -> BStr ($ i) +} + +-- this code needs to be rejected by the type checker! : +-- a "function" returning the input stream plus its "last" bit +cofun idAndLast : [i : Size] -> BStr i -> Twice (BStr i) +{ idAndLast ($ i) (cons .i b bs) = fmap (BStr i) (BStr ($ i)) + (cons i b) (idAndLast i bs) +} + +cofun trues : [i : Size] -> BStr i +{ trues ($ i) = cons i true (trues i) +} + +-- this will loop: +eval let last : Twice Unit = + fmap (BStr #) Unit (\ x -> unit) (idAndLast # (trues #)) + diff --git a/test/fail/countingBT.err b/test/fail/countingBT.err new file mode 100644 --- /dev/null +++ b/test/fail/countingBT.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "countingBT.ma" --- +--- scope checking --- +--- type checking --- +type BT : Set +term BT.lf : < BT.lf : BT > +term BT.node : ^(y0 : BT) -> ^(y1 : BT) -> < BT.node y0 y1 : BT > +term f : BT -> BT +term g : BT -> BT -> BT +{ f (BT.node l (BT.node rl rr)) = g l rr +} +{ g t u = f (BT.node t u) +} +error during typechecking: +Termination check for mutual block [f,g] fails for [f,g] diff --git a/test/fail/countingBT.ma b/test/fail/countingBT.ma new file mode 100644 --- /dev/null +++ b/test/fail/countingBT.ma @@ -0,0 +1,13 @@ +data BT : Set +{ lf : BT +; node : BT -> BT -> BT +} + +mutual { + fun f : BT -> BT + { f (node l (node rl rr)) = g l rr + } + fun g : BT -> BT -> BT + { g t u = f (node t u) + } +} diff --git a/test/fail/countingMerge.err b/test/fail/countingMerge.err new file mode 100644 --- /dev/null +++ b/test/fail/countingMerge.err @@ -0,0 +1,26 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "countingMerge.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.true : < Bool.true : Bool > +term Bool.false : < Bool.false : Bool > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.suc : ^(y0 : Nat) -> < Nat.suc y0 : Nat > +type List : Set +term List.nil : < List.nil : List > +term List.cons : ^(y0 : Nat) -> ^(y1 : List) -> < List.cons y0 y1 : List > +term leq : Nat -> Nat -> Bool +{} +term merge : List -> List -> List +term merge_aux : Nat -> List -> Nat -> List -> Bool -> List +{ merge List.nil l = l +; merge l List.nil = l +; merge (List.cons x xs) (List.cons y ys) = merge_aux x xs y ys (leq x y) +} +{ merge_aux x xs y ys Bool.true = List.cons x (merge xs (List.cons y ys)) +; merge_aux x xs y ys Bool.false = List.cons y (merge (List.cons x xs) ys) +} +error during typechecking: +Termination check for mutual block [merge,merge_aux] fails for [merge,merge_aux] diff --git a/test/fail/countingMerge.ma b/test/fail/countingMerge.ma new file mode 100644 --- /dev/null +++ b/test/fail/countingMerge.ma @@ -0,0 +1,36 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data List : Set +{ nil : List +; cons : Nat -> List -> List +} + +fun leq : Nat -> Nat -> Bool {} + +-- merge as would be represented with "with" in Agda +mutual { + fun merge : List -> List -> List + { merge nil l = l + ; merge l nil = l + ; merge (cons x xs) (cons y ys) = merge_aux x xs y ys (leq x y) + } + fun merge_aux : Nat -> List -> Nat -> List -> Bool -> List + { merge_aux x xs y ys true = cons x (merge xs (cons y ys)) + ; merge_aux x xs y ys false = cons y (merge (cons x xs) ys) + } +} + +{- this is not recognized terminating since + + cons y ys is in no relation with y or ys + +its size is max(y,ys) + 1, but we do not honor max in termination checking +-} diff --git a/test/fail/dataNotMonotone.err b/test/fail/dataNotMonotone.err new file mode 100644 --- /dev/null +++ b/test/fail/dataNotMonotone.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "dataNotMonotone.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ^(A : Set) -> - Size -> Set +term Stream.consStream : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.consStream i y1 y2 : Stream A $i > +type NotMon : ^(A : Set) -> + Size -> Set +error during typechecking: +NotMon +/// constructor NotMon.consBla +/// szConstructor NotMon : .[A : Set] -> .[i : Size] -> ^(y1 : Stream A i) -> ^(y2 : NotMon A i) -> < NotMon.consBla i y1 y2 : NotMon A $i > +/// new A : Set +/// new i <= # +/// szSizeVarUsage of i in ^(y1 : Stream A i) -> ^(y2 : NotMon A i) -> < NotMon.consBla i y1 y2 : NotMon A $i > +/// checking Stream A i to be isotone in variable i +/// leqVal' Stream A i <=+ Stream A $i : Set # +/// leqVal' i <=- $i : Size +/// leSize i <=- $i +/// leSize' $i <= i +/// leSize: 0 + 1 <= 0 failed diff --git a/test/fail/dataNotMonotone.ma b/test/fail/dataNotMonotone.ma new file mode 100644 --- /dev/null +++ b/test/fail/dataNotMonotone.ma @@ -0,0 +1,10 @@ +-- 2009-11-28 +-- illegal use of size index (destroys monotonicity) + +sized codata Stream (A : Set) : Size -> Set +{ consStream : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +sized data NotMon (A : Set) : Size -> Set +{ consBla : (i : Size) -> Stream A i -> NotMon A i -> NotMon A ($ i) +} diff --git a/test/fail/drop.err b/test/fail/drop.err new file mode 100644 --- /dev/null +++ b/test/fail/drop.err @@ -0,0 +1,23 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "drop.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Stream : - Size -> Set +term Stream.cons : .[i : Size] -> ^(y1 : SNat #) -> ^(y2 : Stream i) -> < Stream.cons i y1 y2 : Stream $i > +term drop : .[i : Size] -> SNat i -> .[j : Size] -> Stream j -> Stream j +error during typechecking: +drop +/// clause 2 +/// right hand side +/// checkExpr 7 |- drop i y j xs : Stream $j +/// leqVal' (subtyping) < drop [i] y [j] xs : Stream j > <=+ Stream $j +/// leqVal' (subtyping) Stream j <=+ Stream $j +/// leqVal' j <=- $j : Size +/// leSize j <=- $j +/// leSize' $j <= j +/// leSize: 0 + 1 <= 0 failed diff --git a/test/fail/drop.ma b/test/fail/drop.ma new file mode 100644 --- /dev/null +++ b/test/fail/drop.ma @@ -0,0 +1,18 @@ + +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +sized codata Stream : Size -> Set { + cons : (i : Size) -> SNat # -> Stream i -> Stream ($ i) +} + +-- drop the first elements of a stream + +cofun drop : (i : Size) -> SNat i -> (j : Size) -> Stream j -> Stream j +{ + drop .($ i) (zero i) j xs = xs ; + drop .($ i) (succ i y) ($ j) (cons .j x xs) = drop i y j xs +} diff --git a/test/fail/erased1.err b/test/fail/erased1.err new file mode 100644 --- /dev/null +++ b/test/fail/erased1.err @@ -0,0 +1,16 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "erased1.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +id +/// checkExpr 0 |- \ A -> \ x -> x : .[A : Set] -> .[A] -> A +/// checkForced fromList [] |- \ A -> \ x -> x : .[A : Set] -> .[A] -> A +/// new A : Set +/// checkExpr 1 |- \ x -> x : .[A] -> A +/// checkForced fromList [(A,0)] |- \ x -> x : .[A] -> A +/// new x : v0 +/// checkExpr 2 |- x : A +/// inferExpr' x +/// inferExpr: variable x : A may not occur +/// , because it is marked as erased diff --git a/test/fail/erased1.ma b/test/fail/erased1.ma new file mode 100644 --- /dev/null +++ b/test/fail/erased1.ma @@ -0,0 +1,5 @@ +-- invalid use of erased data + +let id : (A : Set) -> [A] -> A + = \ A -> \ x -> x + diff --git a/test/fail/f_x_is_f_0.err b/test/fail/f_x_is_f_0.err new file mode 100644 --- /dev/null +++ b/test/fail/f_x_is_f_0.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "f_x_is_f_0.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term f : .[i : Size] -> SNat i -> SNat # +error during typechecking: +f +/// clause 1 +/// pattern $$i +/// cannot match against deep successor pattern $$i at type .[i : Size] -> SNat i -> SNat # diff --git a/test/fail/f_x_is_f_0.ma b/test/fail/f_x_is_f_0.ma new file mode 100644 --- /dev/null +++ b/test/fail/f_x_is_f_0.ma @@ -0,0 +1,11 @@ + +sized data SNat : Size -> Set +{ +zero : (i : Size) -> SNat ($ i); +succ : (i : Size) -> SNat i -> SNat ($ i) +} + +fun f : (i : Size) -> SNat i -> SNat # +{ +f ($ ($ i)) x = f ($ i) (zero i) +} diff --git a/test/fail/fail1.err b/test/fail/fail1.err new file mode 100644 --- /dev/null +++ b/test/fail/fail1.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "fail1.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term inc : .[i : Size] -> .[j : Size] -> SNat i -> SNat j +error during typechecking: +inc +/// clause 1 +/// size constraints [?0+1<=v1,v0<=?0,SizeMeta(?0)] unsolvable diff --git a/test/fail/fail1.ma b/test/fail/fail1.ma new file mode 100644 --- /dev/null +++ b/test/fail/fail1.ma @@ -0,0 +1,12 @@ +-- rigid variable clash + +sized data SNat : Size -> Set +{ +zero : (i : Size) -> SNat ($ i); +succ : (i : Size) -> SNat i -> SNat ($ i) +} + +fun inc : (i : Size) -> (j : Size) -> SNat i -> SNat j +{ +inc i j x = succ _ x; +} diff --git a/test/fail/fibStream.err b/test/fail/fibStream.err new file mode 100644 --- /dev/null +++ b/test/fail/fibStream.err @@ -0,0 +1,29 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "fibStream.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term add : Nat -> Nat -> Nat +{ add Nat.zero = \ y -> y +; add (Nat.succ x) = \ y -> Nat.succ (add x y) +} +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +term tail : .[A : Set] -> .[i : Size] -> Stream A $i -> Stream A i +{ tail [A] [i] (Stream.cons [.i] x xs) = xs +} +term zipWith : .[A : Set] -> .[B : Set] -> .[C : Set] -> (A -> B -> C) -> .[i : Size] -> Stream A i -> Stream B i -> Stream C i +{ zipWith [A] [B] [C] f $[i < #] (Stream.cons [.i] a as) (Stream.cons [.i] b bs) = Stream.cons [i] (f a b) (zipWith [A] [B] [C] f [i] as bs) +} +term n0 : Nat +term n0 = Nat.zero +term n1 : Nat +term n1 = Nat.succ n0 +term fib : .[i : Size] -> Stream Nat i +error during typechecking: +fib +/// clause 1 +/// pattern $$i +/// cannot match against deep successor pattern $$i at type .[i : Size] -> Stream Nat i diff --git a/test/fail/fibStream.ma b/test/fail/fibStream.ma new file mode 100644 --- /dev/null +++ b/test/fail/fibStream.ma @@ -0,0 +1,37 @@ + +data Nat : Set { + zero : Nat; + succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat { + add zero = \y -> y; + add (succ x) = \y -> succ (add x y) +} + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +fun tail : (A : Set) -> (i : Size) -> Stream A ($ i) -> Stream A i +{ + tail A i (cons .i x xs) = xs +} + +cofun zipWith : (A : Set) -> (B : Set) -> (C : Set) -> + (A -> B -> C) -> (i : Size) -> + Stream A i -> Stream B i -> Stream C i +{ + zipWith A B C f ($ i) (cons .i a as) (cons .i b bs) = + cons i (f a b) (zipWith A B C f i as bs) +} + +let n0 : Nat = zero +let n1 : Nat = succ n0 + +-- although this is productive, matching ($ ($ i)) is disallowed for cofun +cofun fib : (i : Size) -> Stream Nat i +{ + fib ($ ($ i)) = cons _ n0 (cons _ n1 (zipWith Nat Nat Nat add + i (fib i) (tail Nat i (fib ($ i))))) +} diff --git a/test/fail/hang.err b/test/fail/hang.err new file mode 100644 --- /dev/null +++ b/test/fail/hang.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "hang.ma" --- +--- scope checking --- +scope check error: f +/// Identifier F undefined diff --git a/test/fail/hang.ma b/test/fail/hang.ma new file mode 100644 --- /dev/null +++ b/test/fail/hang.ma @@ -0,0 +1,19 @@ +data Empty : Set +{ +} + +mutual +{ + + +fun F : Set -> Set +{ +F x = F x +} + +fun f : Empty -> F Empty +{ +f x = x +} + +} diff --git a/test/fail/hang2.err b/test/fail/hang2.err new file mode 100644 --- /dev/null +++ b/test/fail/hang2.err @@ -0,0 +1,13 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "hang2.ma" --- +--- scope checking --- +--- type checking --- +type Empty : Set +term F : Empty -> Empty +term f : Empty -> Empty +{ F x = F x +} +{ f x = f (F x) +} +error during typechecking: +Termination check for mutual block [F,f] fails for [F,f] diff --git a/test/fail/hang2.ma b/test/fail/hang2.ma new file mode 100644 --- /dev/null +++ b/test/fail/hang2.ma @@ -0,0 +1,19 @@ +data Empty : Set +{ +} + +mutual +{ + +fun F : Empty -> Empty +{ +F x = F x +} + +-- should this scope check ? +fun f : Empty -> Empty +{ +f x = f (F x) +} + +} diff --git a/test/fail/huetHullotReverse.err b/test/fail/huetHullotReverse.err new file mode 100644 --- /dev/null +++ b/test/fail/huetHullotReverse.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "huetHullotReverse.ma" --- +--- scope checking --- +--- type checking --- +type Enum : Set +term Enum.aa : < Enum.aa : Enum > +term Enum.bb : < Enum.bb : Enum > +term Enum.cc : < Enum.cc : Enum > +type List : ^(A : Set) -> Set +term List.nil : .[A : Set] -> < List.nil : List A > +term List.cons : .[A : Set] -> ^(y0 : A) -> ^(y1 : List A) -> < List.cons y0 y1 : List A > +term list : List Enum +term list = List.cons Enum.aa (List.cons Enum.bb (List.cons Enum.cc List.nil)) +term rev : .[A : Set] -> List A -> List A +term rev1 : .[A : Set] -> A -> List A -> A +term rev2 : .[A : Set] -> A -> List A -> List A +{ rev [A] List.nil = List.nil +; rev [A] (List.cons x xs) = List.cons (rev1 [A] x xs) (rev2 [A] x xs) +} +{ rev1 [A] a List.nil = a +; rev1 [A] a (List.cons x xs) = rev1 [A] x xs +} +{ rev2 [A] a List.nil = List.nil +; rev2 [A] a (List.cons x xs) = rev [A] (List.cons a (rev [A] (rev2 [A] x xs))) +} +error during typechecking: +Termination check for mutual block [rev,rev1,rev2] fails for [rev,rev2] diff --git a/test/fail/huetHullotReverse.ma b/test/fail/huetHullotReverse.ma new file mode 100644 --- /dev/null +++ b/test/fail/huetHullotReverse.ma @@ -0,0 +1,51 @@ +data Enum : Set +{ + aa : Enum ; + bb : Enum ; + cc : Enum +} + +data List ( A : Set ) : Set +{ + +nil : List A; +cons : A -> List A -> List A +} + +let list : List Enum = cons aa (cons bb (cons cc (nil ))) +mutual +{ + + fun rev : ( A : Set ) -> List A -> List A + { + + rev A (nil ) = nil ; + rev A (cons x xs) = cons (rev1 A x xs) (rev2 A x xs) + + } + + fun rev1 : ( A : Set ) -> A -> List A -> A + { + + rev1 A a (nil ) = a; + rev1 A a (cons x xs) = rev1 A x xs + + } + + fun rev2 : (A : Set ) -> A -> List A -> List A + { + + rev2 A a (nil ) = nil ; + rev2 A a (cons x xs) = rev A (cons a (rev A (rev2 A x xs))) + } +} + +let revlist : List Enum = rev Enum list + +fun flat : (A : Set ) -> List (List A) -> List A +{ +flat A (nil .(List A)) = nil; +flat A (cons .(List A) (nil) yl) = flat A yl; +flat A (cons .(List A) (cons x xl) yl) = cons x (flat A (cons xl yl)) +} + diff --git a/test/fail/incompleteSizePattern1.err b/test/fail/incompleteSizePattern1.err new file mode 100644 --- /dev/null +++ b/test/fail/incompleteSizePattern1.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "incompleteSizePattern1.ma" --- +--- scope checking --- +--- type checking --- +type Empty : Set +term bad' : .[Size] -> Empty +error during typechecking: +bad' +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[Size] -> Empty ends in correct coinductive sized type +/// new <= # +/// endsInSizedCo: Empty +/// endsInSizedCo: target Empty of corecursive function is neither a CoSet or codata of size nor a tuple type diff --git a/test/fail/incompleteSizePattern1.ma b/test/fail/incompleteSizePattern1.ma new file mode 100644 --- /dev/null +++ b/test/fail/incompleteSizePattern1.ma @@ -0,0 +1,11 @@ + +data Empty : Set +{ +} + +-- recursion on Size fails since ($ i) is not a complete pattern match +cofun bad' : Size -> Empty +{ + bad' ($ i) = bad' _ +} + diff --git a/test/fail/incompleteSizePattern2.err b/test/fail/incompleteSizePattern2.err new file mode 100644 --- /dev/null +++ b/test/fail/incompleteSizePattern2.err @@ -0,0 +1,13 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "incompleteSizePattern2.ma" --- +--- scope checking --- +--- type checking --- +type Bool : Set +term Bool.tt : < Bool.tt : Bool > +term Bool.ff : < Bool.ff : Bool > +term bad'' : .[Size] -> Bool +error during typechecking: +bad'' +/// clause 1 +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/incompleteSizePattern2.ma b/test/fail/incompleteSizePattern2.ma new file mode 100644 --- /dev/null +++ b/test/fail/incompleteSizePattern2.ma @@ -0,0 +1,13 @@ + +data Bool : Set +{ + tt : Bool; + ff : Bool +} + +fun bad'' : Size -> Bool +{ + bad'' ($ i) = bad'' _; + bad'' i = tt +} +-- 2010-08-18 ($ i) only allowed in cofun diff --git a/test/fail/inconsistentAssumption.err b/test/fail/inconsistentAssumption.err new file mode 100644 --- /dev/null +++ b/test/fail/inconsistentAssumption.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "inconsistentAssumption.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Eq : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Eq.refl : .[A : Set] -> .[a : A] -> < Eq.refl : Eq A a a > +term subst : .[A : Set] -> .[P : A -> Set] -> (i : A) -> (j : A) -> Eq A i j -> P i -> P j +{ subst [A] [P] i .i Eq.refl p = p +} +error during typechecking: +type of h +/// not a type: (ass : (i : Size) -> Eq Size $i i) -> (i : Size) -> SNat i -> SNat # +/// inferExpr' (ass : (i : Size) -> Eq Size $i i) -> (i : Size) -> SNat i -> SNat # +/// inferExpr' (i : Size) -> Eq Size $i i +/// new i <= # +/// inferExpr' Eq Size $i i +/// inferExpr' Eq Size $i +/// inferExpr' Eq Size +/// checkApp (^(A : Set) -> ^(a : A) -> ^ A -> Set) eliminated by Size +/// leqVal' (subtyping) < Size : TSize > <=+ Set +/// leqVal' (subtyping) TSize <=+ Set +/// universe test TSize <= Set failed diff --git a/test/fail/inconsistentAssumption.ma b/test/fail/inconsistentAssumption.ma new file mode 100644 --- /dev/null +++ b/test/fail/inconsistentAssumption.ma @@ -0,0 +1,38 @@ +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +data Eq (A : Set) (a : A) : A -> Set +{ + refl : Eq A a a +} + +fun subst : (A : Set) -> (P : A -> Set) -> (i : A) -> (j : A) -> + Eq A i j -> P i -> P j +{ + subst A P i .i (refl) p = p +} + +fun h : (ass : (i : Size) -> Eq Size ($ i) i) -> (i : Size) -> SNat i -> SNat # +{ + h ass .($ i) (zero i) = h ass i (subst Size SNat ($ i) i (ass i) (zero i)); + h ass .($ i) (succ i n) = h ass i n +} + + +let loop : (ass : (i : Size) -> Eq Size ($ i) i) -> SNat # + = \ ass -> h ass # (zero #) + + +-- the following program has to be rejected +-- because of incomplete pattern matching +fun g : (ass : (i : Size) -> Eq Size ($ i) i) -> (i : Size) -> SNat i -> SNat # +{ + g ass ($ i) x = g ass i (subst Size SNat ($ i) i (ass i) x) +} + +-- let yy : (ass : (i : Size) -> Eq Size ($ i) i) -> +-- Eq (SNat #) (zero #) (g ass # (zero #)) +-- = \ ass -> refl (SNat #) (zero #) diff --git a/test/fail/inconsistentAssumption2.err b/test/fail/inconsistentAssumption2.err new file mode 100644 --- /dev/null +++ b/test/fail/inconsistentAssumption2.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "inconsistentAssumption2.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Eq : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Eq.refl : .[A : Set] -> .[a : A] -> < Eq.refl : Eq A a a > +term subst : .[A : Set] -> .[P : A -> Set] -> (i : A) -> (j : A) -> Eq A i j -> P i -> P j +{ subst [A] [P] i .i Eq.refl p = p +} +error during typechecking: +type of h +/// not a type: (ass : (i : Size) -> Eq Size $i i) -> (i : Size) -> SNat i -> SNat # +/// inferExpr' (ass : (i : Size) -> Eq Size $i i) -> (i : Size) -> SNat i -> SNat # +/// inferExpr' (i : Size) -> Eq Size $i i +/// new i <= # +/// inferExpr' Eq Size $i i +/// inferExpr' Eq Size $i +/// inferExpr' Eq Size +/// checkApp (^(A : Set) -> ^(a : A) -> ^ A -> Set) eliminated by Size +/// leqVal' (subtyping) < Size : TSize > <=+ Set +/// leqVal' (subtyping) TSize <=+ Set +/// universe test TSize <= Set failed diff --git a/test/fail/inconsistentAssumption2.ma b/test/fail/inconsistentAssumption2.ma new file mode 100644 --- /dev/null +++ b/test/fail/inconsistentAssumption2.ma @@ -0,0 +1,32 @@ +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +data Eq (A : Set) (a : A) : A -> Set +{ + refl : Eq A a a +} + +fun subst : (A : Set) -> (P : A -> Set) -> (i : A) -> (j : A) -> + Eq A i j -> P i -> P j +{ + subst A P i .i (refl) p = p +} + +-- h is not a problem since the right hand side of the first clause +-- does not reduce if ass i is not refl +fun h : (ass : (i : Size) -> Eq Size ($ i) i) -> (i : Size) -> SNat i -> SNat # +{ + h ass .($ i) (zero i) = h ass i (subst Size SNat ($ i) i (ass i) (zero i)); + h ass .($ i) (succ i n) = h ass i n +} + + +let loop : (ass : (i : Size) -> Eq Size ($ i) i) -> SNat # + = \ ass -> h ass # (zero #) + +let yy : (ass : (i : Size) -> Eq Size ($ i) i) -> + Eq (SNat #) (zero #) (h ass # (zero #)) + = \ ass -> refl diff --git a/test/fail/inductiveNotDotPattern.err b/test/fail/inductiveNotDotPattern.err new file mode 100644 --- /dev/null +++ b/test/fail/inductiveNotDotPattern.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "inductiveNotDotPattern.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term bla : .[i : Size] -> SNat $i -> SNat i +error during typechecking: +bla +/// clause 1 +/// pattern zero $i +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> < SNat.zero i : SNat $i > ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: < SNat.zero i : SNat $i > +/// endsInSizedCo: SNat $i +/// endsInSizedCo: target SNat $i of corecursive function is neither a CoSet or codata of size i nor a tuple type diff --git a/test/fail/inductiveNotDotPattern.ma b/test/fail/inductiveNotDotPattern.ma new file mode 100644 --- /dev/null +++ b/test/fail/inductiveNotDotPattern.ma @@ -0,0 +1,20 @@ +sized data SNat : Size -> Set +{ +zero : (i : Size ) -> SNat ($ i); +succ : (i : Size ) -> SNat i -> SNat ($ i) +} + +-- no complete pattern matching +cofun bla : (i : Size ) -> SNat ($ i) -> SNat i +{ +bla .($ i) (zero ($ i)) = zero _; -- no complete pattern matching +bla .i (succ i x) = x +} + +fun loop : (i : Size ) -> (SNat i) -> Set +{ +loop ($ i) x = loop _ (bla _ x) +} + +-- eval let diverge : Set = loop # (zero #) + diff --git a/test/fail/lengthCoList.err b/test/fail/lengthCoList.err new file mode 100644 --- /dev/null +++ b/test/fail/lengthCoList.err @@ -0,0 +1,21 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "lengthCoList.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +type Colist : ^(A : Set) -> - Size -> Set +term Colist.nil : .[A : Set] -> .[i : Size] -> < Colist.nil i : Colist A $i > +term Colist.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Colist A i) -> < Colist.cons i y1 y2 : Colist A $i > +term olist' : .[i : Size] -> Colist (Nat #) i +{ olist' $[i < #] = Colist.cons [i] (Nat.zero [#]) (olist' [i]) +} +term length : .[i : Size] -> .[A : Set] -> Colist A i -> Nat i +error during typechecking: +length +/// clause 1 +/// pattern nil i +/// in pattern nil i, coinductive size sub pattern i must be dotted diff --git a/test/fail/lengthCoList.ma b/test/fail/lengthCoList.ma new file mode 100644 --- /dev/null +++ b/test/fail/lengthCoList.ma @@ -0,0 +1,86 @@ +sized data Nat : Size -> Set +{ + zero : [i : Size] -> Nat ($ i); + succ : [i : Size] -> Nat i -> Nat ($ i); +} + + +sized codata Colist (A : Set) : Size -> Set +{ + nil : [i : Size] -> Colist A ($ i); + cons : [i : Size] -> A -> Colist A i -> Colist A ($ i) +} + +cofun olist' : [i : Size] -> Colist (Nat #) i +{ +olist' ($ i) = cons i (zero #) (olist' i) +} + +-- not allowed because no inductive argument with i +fun length : [i : Size] -> [A : Set] -> Colist A i -> Nat i +{ +length .($ i) A (nil i) = zero i ; +length .($ i) A (cons i a as) = succ i (length i A as) +} + +eval let diverge : Nat # = length # (Nat #) (olist' #) + + +-- the rest is fine -------------------------------------------------- + +sized codata CoNat : Size -> Set +{ + cozero : [i : Size] -> CoNat ($ i); + cosucc : [i : Size] -> CoNat i -> CoNat ($ i) +} + +let z : CoNat # = cozero # + +-- allowed because i used in coinductive result +cofun length2 : [i : Size] -> [A : Set] -> Colist A i -> CoNat i +{ +length2 ($ i) A (nil .i) = cozero i; +length2 ($ i) A (cons .i a as) = cosucc i (length2 i A as) +} + +cofun omega' : [i : Size] -> CoNat i +{ +omega' ($ i) = cosucc i (omega' i) +} + +let omega : CoNat # = omega' # + +-- not ok because size not used in inductive argument +-- fun convert1 : [i : Size] -> CoNat i -> Nat i +-- { +-- convert1 ($ i) (cozero .i) = zero i; +-- convert1 ($ i) (cosucc i x) = succ i (convert1 i x) +-- } + +-- ok +fun convert2 : [i : Size] -> Nat i -> CoNat i +{ +convert2 ($ i) (zero .i) = cozero i; +convert2 ($ i) (succ .i x) = cosucc i (convert2 i x) +} + +-- also ok +fun convert2' : [i : Size] -> Nat i -> CoNat i +{ convert2' i (zero (i > j)) = cozero j +; convert2' i (succ (i > j) x) = cosucc j (convert2' j x) +} + +-- also ok +fun convert3 : [i : Size] -> Nat i -> CoNat # +{ +convert3 i (zero (i > j)) = cozero #; +convert3 i (succ (i > j) x) = omega' # +} + +-- also ok +cofun convert4 : [i : Size] -> Nat i -> CoNat i +{ +convert4 ($ i) (zero .i) = cozero ($ i) ; +convert4 ($ i) (succ .i x) = cosucc i (convert4 i x) +} + diff --git a/test/fail/lengthCoList2.err b/test/fail/lengthCoList2.err new file mode 100644 --- /dev/null +++ b/test/fail/lengthCoList2.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "lengthCoList2.ma" --- +--- scope checking --- +scope check error: convert3 +/// Identifier omega' undefined diff --git a/test/fail/lengthCoList2.ma b/test/fail/lengthCoList2.ma new file mode 100644 --- /dev/null +++ b/test/fail/lengthCoList2.ma @@ -0,0 +1,42 @@ +sized data Nat : Size -> Set +{ + zero : [i : Size] -> Nat ($ i); + succ : [i : Size] -> Nat i -> Nat ($ i); +} + +sized codata CoNat : Size -> Set +{ + cozero : [i : Size] -> CoNat ($ i); + cosucc : [i : Size] -> CoNat i -> CoNat ($ i) +} + +let z : CoNat # = cozero # + +-- ok +fun convert2 : [i : Size] -> Nat i -> CoNat i +{ +convert2 ($ i) (zero .i) = cozero i; +convert2 ($ i) (succ .i x) = cosucc i (convert2 i x) +} + +-- NOT ok +fun convert2' : [i : Size] -> Nat i -> CoNat i +{ convert2' i (zero (i > j)) = cozero j +; convert2' i (succ (i > j) x) = cosucc j (convert2' j x) +} +-- since $j <= i but noth otherwise! + +-- ok +fun convert3 : [i : Size] -> Nat i -> CoNat # +{ +convert3 i (zero (i > j)) = cozero #; +convert3 i (succ (i > j) x) = omega' # +} + +-- also ok +cofun convert4 : [i : Size] -> Nat i -> CoNat i +{ +convert4 ($ i) (zero .i) = cozero ($ i) ; +convert4 ($ i) (succ .i x) = cosucc i (convert4 i x) +} + diff --git a/test/fail/loop.err b/test/fail/loop.err new file mode 100644 --- /dev/null +++ b/test/fail/loop.err @@ -0,0 +1,44 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loop.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Nat : Set +type Nat = SNat # +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Maybe : ++(A : Set) -> Set +term Maybe.nothing : .[A : Set] -> < Maybe.nothing : Maybe A > +term Maybe.just : .[A : Set] -> ^(y0 : A) -> < Maybe.just y0 : Maybe A > +term shift_case : .[i : Size] -> Maybe (SNat $i) -> Maybe (SNat i) +{ shift_case [i] Maybe.nothing = Maybe.nothing +; shift_case [.i] (Maybe.just (SNat.zero [i])) = Maybe.nothing +; shift_case [.i] (Maybe.just (SNat.succ [i] x)) = Maybe.just x +} +term shift : .[i : Size] -> (Nat -> Maybe (SNat $i)) -> Nat -> Maybe (SNat i) +term shift = [\ i ->] \ f -> \ n -> shift_case [i] (f (SNat.succ [#] n)) +term loop : .[i : Size] -> SNat i -> (Nat -> Maybe (SNat i)) -> Unit +term loop_case : .[i : Size] -> (Nat -> Maybe (SNat i)) -> Maybe (SNat i) -> Unit +error during typechecking: +loop +/// clause 2 +/// right hand side +/// checkExpr 4 |- loop j n (shift j f) : Unit +/// inferExpr' loop j n (shift j f) +/// checkApp (((SNat #)::Tm -> {Maybe (SNat i) {i = v1}})::Tm -> {Unit {i = v1}}) eliminated by shift j f +/// inferExpr' shift j f +/// checkApp (((SNat #)::Tm -> {Maybe (SNat $i) {i = v1}})::Tm -> {Nat -> Maybe (SNat i) {i = v1}}) eliminated by f +/// leqVal' (subtyping) (xSing# : SNat #) -> < f xSing# : Maybe (SNat i) > <=+ SNat # -> Maybe (SNat $j) +/// new xSing# : (SNat #) +/// comparing codomain < f xSing# : Maybe (SNat i) > with Maybe (SNat $j) +/// leqVal' (subtyping) < f xSing# : Maybe (SNat i) > <=+ Maybe (SNat $j) +/// leqVal' (subtyping) Maybe (SNat i) <=+ Maybe (SNat $j) +/// leqVal' SNat i <=+ SNat $j : Set +/// leqVal' i <=+ $j : Size +/// leSize i <=+ $j +/// leSize' i <= $j +/// bound not entailed diff --git a/test/fail/loop.ma b/test/fail/loop.ma new file mode 100644 --- /dev/null +++ b/test/fail/loop.ma @@ -0,0 +1,52 @@ +sized data SNat : Size -> Set +{ zero : [i : Size] -> SNat ($ i) +; succ : [i : Size] -> SNat i -> SNat ($ i) +} + +let Nat : Set = SNat # + +data Unit : Set +{ unit : Unit +} + +data Maybe (+ A : Set) : Set +{ nothing : Maybe A +; just : A -> Maybe A +} + +fun shift_case : [i : Size] -> Maybe (SNat ($ i)) -> Maybe (SNat i) +{ shift_case i (nothing {-.(SNat ($ i))-}) = nothing -- (SNat i) +; shift_case .i (just {-.(SNat ($ i))-} (zero i)) = nothing -- (SNat i) +; shift_case .i (just {-.(SNat ($ i))-} (succ i x)) = just x -- (SNat i) x +} + +let shift : [i : Size] -> (Nat -> Maybe (SNat ($ i))) -> + Nat -> Maybe (SNat i) = + \i -> \f -> \n -> shift_case i (f (succ # n)) + +mutual +{ + + fun loop : [i : Size] -> SNat i -> (Nat -> Maybe (SNat i)) -> Unit + { loop i (zero (i > j) ) f = loop_case i f (f (zero j)) + ; loop i (succ (i > j) n) f = loop j n (shift j f) + } + -- loop j n : (Nat -> Maybe (SNat j)) -> Unit + -- f : Nat -> Maybe (SNat i) + -- no way to go (with j < i) + -- from Nat -> Maybe (SNat i) + -- to Nat -> Maybe (SNat j) + + fun loop_case : [i : Size] -> (Nat -> Maybe (SNat i)) -> + Maybe (SNat i) -> Unit + { loop_case i f (nothing) = unit + ; loop_case i f (just (zero (i > j) )) = unit + ; loop_case i f (just (succ (i > j) y)) = loop j y (shift j f) + -- f : Nat -> Maybe (SNat i) should have type Nat -> Maybe (SNat ($ j)) + -- but we only know $ j <= i and not equality + } +} + +let inc : Nat -> Maybe Nat = \n -> just (succ # n) + +eval let diverge : Unit = loop # (zero #) inc diff --git a/test/fail/loopAdmStream-Nat.err b/test/fail/loopAdmStream-Nat.err new file mode 100644 --- /dev/null +++ b/test/fail/loopAdmStream-Nat.err @@ -0,0 +1,27 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopAdmStream-Nat.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term guard : .[j : Size] -> (Stream Nat $j -> Stream Nat #) -> Stream Nat j -> Stream Nat # +{ guard [j] g xs = g (Stream.cons [j] Nat.zero xs) +} +term f : .[i : Size] -> (Stream Nat i -> Stream Nat #) -> Stream Nat i +error during typechecking: +f +/// clause 1 +/// pattern $j +/// checkPattern $j : matching on size, checking that target .[i : Size] -> (Stream Nat i -> Stream Nat #) -> Stream Nat i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: (Stream Nat i -> Stream Nat #) -> Stream Nat i +/// type Stream Nat i -> Stream Nat # not lower semi continuous in i diff --git a/test/fail/loopAdmStream-Nat.ma b/test/fail/loopAdmStream-Nat.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopAdmStream-Nat.ma @@ -0,0 +1,36 @@ +-- 2010-05-11 + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +sized codata Stream (+ A : Set) : Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A ($ i) +} +fields head, tail + +fun guard : [j : Size] -> (Stream Nat ($ j) -> Stream Nat #) + -> (Stream Nat j -> Stream Nat #) +{ guard j g xs = g (cons j zero xs) +} + +-- the type of f is not admissible +cofun f : [i : Size] -> (Stream Nat i -> Stream Nat #) -> Stream Nat i +{ f ($ j) g = guard j g (f j (guard j g)) +} + +-- LOOP! +eval let loop : Nat = head # (f # (tail #)) + +{- +-- the type of f is not admissible +cofun f : (Stream Nat # -> Stream Nat #) -> + [i : Size] -> (Stream Nat i -> Stream Nat #) -> Stream Nat i +{ f h ($ j) g = h (g (cons j zero + (f (\ x -> h (h x)) + j + (\ x -> g (cons j zero x))))) +} + +-} diff --git a/test/fail/loopAdmStream-simplified.err b/test/fail/loopAdmStream-simplified.err new file mode 100644 --- /dev/null +++ b/test/fail/loopAdmStream-simplified.err @@ -0,0 +1,18 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopAdmStream-simplified.ma" --- +--- scope checking --- +--- type checking --- +type StreamUnit : - Size -> Set +term StreamUnit.cons : .[i : Size] -> ^(tail : StreamUnit i) -> < StreamUnit.cons i tail : StreamUnit $i > +term tail : .[i : Size] -> (cons : StreamUnit $i) -> StreamUnit i +{ tail [i] (StreamUnit.cons [.i] #tail) = #tail +} +term f : (StreamUnit # -> StreamUnit #) -> .[i : Size] -> (StreamUnit i -> StreamUnit #) -> StreamUnit i +error during typechecking: +f +/// clause 1 +/// pattern $j +/// checkPattern $j : matching on size, checking that target .[i : Size] -> (StreamUnit i -> StreamUnit #) -> StreamUnit i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: (StreamUnit i -> StreamUnit #) -> StreamUnit i +/// type StreamUnit i -> StreamUnit # not lower semi continuous in i diff --git a/test/fail/loopAdmStream-simplified.ma b/test/fail/loopAdmStream-simplified.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopAdmStream-simplified.ma @@ -0,0 +1,17 @@ +-- 2010-05-11 + +sized codata StreamUnit : Size -> Set +{ cons : [i : Size] -> (tail : StreamUnit i) -> StreamUnit ($ i) +} +fields tail + +-- the type of f is not admissible +cofun f : (StreamUnit # -> StreamUnit #) -> + (i : Size) -> (StreamUnit i -> StreamUnit #) -> StreamUnit i +{ f h ($ j) g = h (g (cons j (f (\ x -> h (h x)) j (\ x -> g (cons j x))))) +} + +let bla : StreamUnit # = f (tail #) # (\ x -> x) + +-- LOOP! +eval let us : StreamUnit # = tail # bla diff --git a/test/fail/loopAdmStream.err b/test/fail/loopAdmStream.err new file mode 100644 --- /dev/null +++ b/test/fail/loopAdmStream.err @@ -0,0 +1,23 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopAdmStream.ma" --- +--- scope checking --- +--- type checking --- +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(head : A) -> ^(tail : Stream A i) -> < Stream.cons i head tail : Stream A $i > +term head : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> A +{ head [A] [i] (Stream.cons [.i] #head #tail) = #head +} +term tail : .[A : Set] -> .[i : Size] -> (cons : Stream A $i) -> Stream A i +{ tail [A] [i] (Stream.cons [.i] #head #tail) = #tail +} +term f : (Stream Unit # -> Stream Unit #) -> .[i : Size] -> (Stream Unit i -> Stream Unit #) -> Stream Unit i +error during typechecking: +f +/// clause 1 +/// pattern $j +/// checkPattern $j : matching on size, checking that target .[i : Size] -> (Stream Unit i -> Stream Unit #) -> Stream Unit i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: (Stream Unit i -> Stream Unit #) -> Stream Unit i +/// type Stream Unit i -> Stream Unit # not lower semi continuous in i diff --git a/test/fail/loopAdmStream.ma b/test/fail/loopAdmStream.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopAdmStream.ma @@ -0,0 +1,23 @@ +-- 2010-05-11 + +data Unit : Set +{ unit : Unit +} + +sized codata Stream (+ A : Set) : Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A ($ i) +} +fields head, tail + +-- the type of f is not admissible +cofun f : (Stream Unit # -> Stream Unit #) -> + (i : Size) -> (Stream Unit i -> Stream Unit #) -> Stream Unit i +{ f h ($ j) g = + h (g (cons j unit (f (\ x -> h (h x)) j (\ x -> g (cons j unit x))))) +} + +let bla : Stream Unit # = f (tail #) # (\ x -> x) + +-- LOOP! +eval let u : Unit = head # bla +eval let us : Stream Unit # = tail # bla diff --git a/test/fail/loopBadTypesHidden.err b/test/fail/loopBadTypesHidden.err new file mode 100644 --- /dev/null +++ b/test/fail/loopBadTypesHidden.err @@ -0,0 +1,43 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopBadTypesHidden.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Maybe : ++(A : Set) -> Set +term Maybe.nothing : .[A : Set] -> < Maybe.nothing : Maybe A > +term Maybe.just : .[A : Set] -> ^(y0 : A) -> < Maybe.just y0 : Maybe A > +type Nat : Set +type Nat = SNat # +term shift_case : .[i : Size] -> Maybe (SNat $i) -> Maybe (SNat i) +{ shift_case [i] Maybe.nothing = Maybe.nothing +; shift_case [.i] (Maybe.just (SNat.zero [i])) = Maybe.nothing +; shift_case [.i] (Maybe.just (SNat.succ [i] x)) = Maybe.just x +} +term shift : .[i : Size] -> (Nat -> Maybe (SNat $i)) -> Nat -> Maybe (SNat i) +term shift = [\ i ->] \ f -> \ n -> shift_case [i] (f (SNat.succ [#] n)) +term inc : Nat -> Maybe Nat +term inc = \ n -> Maybe.just (SNat.succ [#] n) +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type loopType : Unit -> Set +{ loopType un!t = .[i : Size] -> SNat i -> (Nat -> Maybe (SNat i)) -> Unit +} +type loopCaseType : Unit -> Set +{ loopCaseType un!t = .[i : Size] -> (Nat -> Maybe (SNat i)) -> Maybe (SNat i) -> Unit +} +term loop : (u : Unit) -> loopType u +term loop_case : (u : Unit) -> loopCaseType u +error during typechecking: +checking type of loop for admissibility +/// new un!t : _ +/// new i : _ +/// new f : _ +/// new i <= # +/// admType: checking ((SNat v3)::Tm -> {(Nat -> Maybe (SNat i)) -> Unit {i = v3, un!t = v0}}) admissible in v3 +/// new : (SNat v3) +/// admType: checking (((SNat #)::Tm -> {Maybe (SNat i) {i = v3, un!t = v0}})::Tm -> {Unit {i = v3, un!t = v0}}) admissible in v3 +/// type SNat # -> Maybe (SNat i) not lower semi continuous in i diff --git a/test/fail/loopBadTypesHidden.ma b/test/fail/loopBadTypesHidden.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopBadTypesHidden.ma @@ -0,0 +1,63 @@ +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +data Maybe (+ A : Set) : Set +{ + nothing : Maybe A; + just : A -> Maybe A +} + +let Nat : Set = SNat # + +fun shift_case : (i : Size) -> Maybe (SNat ($ i)) -> Maybe (SNat i) +{ + +shift_case i nothing = nothing; +shift_case .i (just (zero i)) = nothing; +shift_case .i (just (succ i x)) = just x + +} + +let shift : (i : Size) -> (Nat -> Maybe (SNat ($ i))) -> Nat -> Maybe (SNat i) = +\i -> \f -> \n -> shift_case i (f (succ # n)) + +let inc : Nat -> Maybe Nat = \n -> just (succ # n) + +data Unit : Set +{ + unit : Unit +} + +fun loopType : Unit -> Set +{ +loopType unit = (i : Size) -> SNat i -> (Nat -> Maybe (SNat i)) -> Unit +} + +fun loopCaseType : Unit -> Set +{ +loopCaseType unit = (i : Size) -> (Nat -> Maybe (SNat i)) -> Maybe (SNat i) -> Unit +} + + +-- hide bad types .... +mutual +{ + +fun loop : (u : Unit) -> loopType u +{ +loop unit .($ i) (zero i) f = loop_case unit ($ i) f (f (zero i)); +loop unit .($ i) (succ i n) f = loop unit i n (shift i f) +} + +fun loop_case : (u : Unit) -> loopCaseType u +{ +loop_case unit i f (nothing) = unit; +loop_case unit .($ i) f (just (zero i)) = unit; +loop_case unit .($ i) f (just (succ i y)) = loop unit i y (shift i f) +} +} + +eval let diverge : Unit = loop unit # (zero #) inc diff --git a/test/fail/loopBounded.err b/test/fail/loopBounded.err new file mode 100644 --- /dev/null +++ b/test/fail/loopBounded.err @@ -0,0 +1,44 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopBounded.ma" --- +--- scope checking --- +--- type checking --- +type Empty : Set +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Maybe : ++(A : Set) -> Set +term Maybe.nothing : .[A : Set] -> < Maybe.nothing : Maybe A > +term Maybe.just : .[A : Set] -> ^(a : A) -> < Maybe.just a : Maybe A > +type Nat : + Size -> Set +{ Nat i = Maybe (.[j < i] & Nat j) +} +pattern zero = nothing +pattern suc i n = just (i, n) +term pred : .[i : Size] -> Nat $i -> Nat i +{ pred [i] Maybe.nothing = Maybe.nothing +; pred [i] (Maybe.just ([j < $i], n)) = n +} +term wfix : .[A : Size -> Set] -> (f : .[i : Size] -> (.[j < i] -> A j) -> A i) -> .[i : Size] -> A i +{ wfix [A] f [i] = f [i] (wfix [A] f) +} +term fix : .[A : Size -> Set] -> (f : .[i : Size] -> A i -> A $i) -> .[i : Size] -> A i +block fails as expected, error message: +fix +/// clause 1 +/// right hand side +/// checkExpr 3 |- f i (fix A f) : A i +/// inferExpr' f i (fix A f) +/// checkApp ((v0 v2)::Tm -> {A $i {i = v2, A = (v0 Up (Size -> Set))}}) eliminated by fix A f +/// leqVal' (subtyping) .[i : Size] -> < fix [A ] (f i ) i : A i > <=+ A i +/// leqApp: head mismatch .[i : Size] -> < fix [A ] (f i ) i : A i > != A +type A : -(i : Size) -> Set +type A = \ i -> (Nat # -> Nat i) -> Nat # +term fix : (f : .[i : Size] -> A i -> A $i) -> .[i : Size] -> A i +error during typechecking: +fix +/// clause 1 +/// right hand side +/// checkExpr 2 |- f i (fix f i) : (Nat # -> Nat i) -> Nat # +/// inferExpr' f i (fix f i) +/// checkApp ((((Nat #)::Tm -> {Nat i {i = v1}})::Tm -> {Nat # {i = v1}})::Tm -> {A $i {i = v1}}) eliminated by fix f i +/// checkGuard |i| < |i| +/// lexSizes: no descent detected diff --git a/test/fail/loopBounded.ma b/test/fail/loopBounded.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopBounded.ma @@ -0,0 +1,39 @@ +-- 2012-02-04 + +data Empty {} +data Unit { unit } +data Maybe ++(A : Set) { nothing ; just (a : A) } + +cofun Nat : +Size -> Set +{ Nat i = Maybe ([j < i] & Nat j) +} +pattern zero = nothing +pattern suc i n = just (i, n) + +fun pred : [i : Size] -> Nat $i -> Nat i +{ pred i zero = zero +; pred i (suc j n) = n +} + +{- +fun loop : [i : Size] -> Nat i -> Unit +{ loop i zero = unit +; loop i (suc j n) = loop j (pred j (suc j n)) +} +-} + +fun wfix : [A : Size -> Set] (f : [i : Size] -> ([j < i] -> A j) -> A i) + [i : Size] -> |i| -> A i +{ wfix A f i = f i (wfix A f) +} + +fail +fun fix : [A : Size -> Set] (f : [i : Size] -> A i -> A $i) [i : Size] -> A i +{ fix A f i = f i (fix A f) +} + +let A -(i : Size) = (Nat # -> Nat i) -> Nat # + +fun fix : (f : [i : Size] -> A i -> A $i) [i : Size] -> |i| -> A i +{ fix f i = f i (fix f i) +} diff --git a/test/fail/loopOldNoSizePattern.err b/test/fail/loopOldNoSizePattern.err new file mode 100644 --- /dev/null +++ b/test/fail/loopOldNoSizePattern.err @@ -0,0 +1,36 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopOldNoSizePattern.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Maybe : ++(A : Set) -> Set +term Maybe.nothing : .[A : Set] -> < Maybe.nothing : Maybe A > +term Maybe.just : .[A : Set] -> ^(y0 : A) -> < Maybe.just y0 : Maybe A > +type Nat : Set +type Nat = SNat # +term shift_case : .[i : Size] -> Maybe (SNat $i) -> Maybe (SNat i) +{ shift_case [i] Maybe.nothing = Maybe.nothing +; shift_case [.i] (Maybe.just (SNat.zero [i])) = Maybe.nothing +; shift_case [.i] (Maybe.just (SNat.succ [i] x)) = Maybe.just x +} +term shift : .[i : Size] -> (Nat -> Maybe (SNat $i)) -> Nat -> Maybe (SNat i) +term shift = [\ i ->] \ f -> \ n -> shift_case [i] (f (SNat.succ [#] n)) +term inc : Nat -> Maybe Nat +term inc = \ n -> Maybe.just (SNat.succ [#] n) +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +term loop : .[i : Size] -> SNat i -> (Nat -> Maybe (SNat i)) -> Unit +term loop_case : .[i : Size] -> (Nat -> Maybe (SNat i)) -> Maybe (SNat i) -> Unit +error during typechecking: +checking type of loop for admissibility +/// new i : _ +/// new f : _ +/// new i <= # +/// admType: checking ((SNat v2)::Tm -> {(Nat -> Maybe (SNat i)) -> Unit {i = v2}}) admissible in v2 +/// new : (SNat v2) +/// admType: checking (((SNat #)::Tm -> {Maybe (SNat i) {i = v2}})::Tm -> {Unit {i = v2}}) admissible in v2 +/// type SNat # -> Maybe (SNat i) not lower semi continuous in i diff --git a/test/fail/loopOldNoSizePattern.ma b/test/fail/loopOldNoSizePattern.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopOldNoSizePattern.ma @@ -0,0 +1,52 @@ +sized data SNat : Size -> Set +{ + zero : (i : Size ) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +data Maybe (+ A : Set) : Set +{ + nothing : Maybe A; + just : A -> Maybe A +} + +let Nat : Set = SNat # + +fun shift_case : (i : Size) -> Maybe (SNat ($ i)) -> + Maybe (SNat i) +{ + shift_case i nothing = nothing; + shift_case .i (just (zero i)) = nothing; + shift_case .i (just (succ i x)) = just x +} + +let shift : (i : Size) -> (Nat -> Maybe (SNat ($ i))) -> + Nat -> Maybe (SNat i) = +\i -> \f -> \n -> shift_case i (f (succ # n)) + +let inc : Nat -> Maybe Nat = \n -> just (succ # n) + +data Unit : Set +{ + unit : Unit +} + +mutual +{ + + fun loop : (i : Size) -> SNat i -> (Nat -> Maybe (SNat i)) -> Unit + { + loop .($ i) (zero i) f = loop_case ($ i) f (f (zero i)); + loop .($ i) (succ i n) f = loop i n (shift i f) + } + + fun loop_case : (i : Size) -> (Nat -> Maybe (SNat i)) -> + Maybe (SNat i) -> Unit + { + loop_case i f (nothing) = unit; + loop_case .($ i) f (just (zero i)) = unit; + loop_case .($ i) f (just (succ i y)) = loop i y (shift i f) + } +} + +eval let diverge : Unit = loop # (zero #) inc diff --git a/test/fail/loopTypesHiddenInData.err b/test/fail/loopTypesHiddenInData.err new file mode 100644 --- /dev/null +++ b/test/fail/loopTypesHiddenInData.err @@ -0,0 +1,3 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "loopTypesHiddenInData.ma" --- +--- scope checking --- diff --git a/test/fail/loopTypesHiddenInData.ma b/test/fail/loopTypesHiddenInData.ma new file mode 100644 --- /dev/null +++ b/test/fail/loopTypesHiddenInData.ma @@ -0,0 +1,63 @@ +sized data SNat : Size -> Set +{ + zero : [i : Size] -> SNat ($ i); + succ : [i : Size] -> SNat i -> SNat ($ i) +} + +data Maybe ( + A : Set ) : Set +{ + nothing : Maybe A; + just : A -> Maybe A +} + +let Nat : Set = SNat # + +fun shift_case : (i : Size) -> Maybe (SNat ($ i)) -> Maybe (SNat i) +{ + +shift_case i (nothing ) = nothing; +shift_case .i (just (zero i)) = nothing; +shift_case .i (just (succ i x)) = just x + +} + +let shift : (i : Size) -> (Nat -> Maybe (SNat ($ i))) -> Nat -> Maybe (SNat i) = +\i -> \f -> \n -> shift_case i (f (succ # n)) + +let inc : Nat -> Maybe Nat = \n -> just (succ # n) + +data Unit : Set +{ + unit : Unit +} + +data loopType : Set +{ +lt : [i : Size] -> SNat i -> (Nat -> Maybe (SNat i)) -> loopType +} + +data loopCaseType : Set +{ +lct : [i : Size] -> (Nat -> Maybe (SNat i)) -> Maybe (SNat i) -> loopCaseType +} + + +-- hide bad types .... +mutual +{ + +fun loop : loopType -> Unit +{ +loop (lt .($ i) (zero i) f) = loop_case (lct ($ i) f (f (zero i))); +loop (lt .($ i) (succ i n) f) = loop (lt i n (shift i f)) +} + +fun loop_case : loopCaseType -> Unit +{ +loop_case (lct i f (nothing) = unit; +loop_case (lct .($ i) f (just (zero i))) = unit; +loop_case (lct .($ i) f (just (succ i y))) = loop (lt i y (shift i f)) +} +} + +eval let diverge : Unit = loop (lt # (zero #) inc) diff --git a/test/fail/mapStream2.err b/test/fail/mapStream2.err new file mode 100644 --- /dev/null +++ b/test/fail/mapStream2.err @@ -0,0 +1,16 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "mapStream2.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term map2 : .[i : Size] -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +error during typechecking: +map2 +/// clause 1 +/// pattern cons .$i u (cons i x xl) +/// pattern cons i x xl +/// in pattern cons i x xl, coinductive size sub pattern i must be dotted diff --git a/test/fail/mapStream2.ma b/test/fail/mapStream2.ma new file mode 100644 --- /dev/null +++ b/test/fail/mapStream2.ma @@ -0,0 +1,33 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +data Nat : Set { + zero : Nat; + succ : Nat -> Nat +} + +-- THIS SHOULD NOT TYPECHECK!! +cofun map2 : (i : Size) -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +{ +map2 .($ ($ i)) f (cons .($ i) u (cons i x xl)) = + cons _ (f u) (cons _ (f x) (map2 _ f xl)) +} + +{- a better explanation why this does not work: + +- the quantification (i : Size) -> ... Stream Nat i is a CoSize quant. +- disallow dot patterns for CoSize + +cofun map2 : (i : Size) -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +{ +map2 ($ ($ i)) f (cons .Nat .($ i) u (cons .Nat .i x xl)) = + cons Nat _ (f u) (cons Nat _ (f x) (map2 _ f xl)) +} + +- this then fails since deep matching is not allowed +- for the CoSizes inside the cons we would still have to allow dot patterns +- how to separate these two uses? +- maybe: the size pattern inside cocons can only be a dot pattern?! +-} diff --git a/test/fail/mapStream2sizeMatchDepth2.err b/test/fail/mapStream2sizeMatchDepth2.err new file mode 100644 --- /dev/null +++ b/test/fail/mapStream2sizeMatchDepth2.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "mapStream2sizeMatchDepth2.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term map2 : .[i : Size] -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +error during typechecking: +map2 +/// clause 1 +/// pattern $$i +/// cannot match against deep successor pattern $$i at type .[i : Size] -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i diff --git a/test/fail/mapStream2sizeMatchDepth2.ma b/test/fail/mapStream2sizeMatchDepth2.ma new file mode 100644 --- /dev/null +++ b/test/fail/mapStream2sizeMatchDepth2.ma @@ -0,0 +1,37 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +data Nat : Set { + zero : Nat; + succ : Nat -> Nat +} + +{- +-- This is now illegal since cosize patterns must be dotted in coconstructors. +cofun map2 : (i : Size) -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +{ +map2 .($ ($ i)) f (cons .Nat .($ i) u (cons .Nat i x xl)) = + cons Nat _ (f u) (cons Nat _ (f x) (map2 _ f xl)) +} +-} + +{- a better explanation why this does not work: + +- the quantification (i : Size) -> ... Stream Nat i is a CoSize quant. +- disallow dot patterns for CoSize +-} + +cofun map2 : (i : Size) -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +{ +map2 ($ ($ i)) f (cons .Nat .($ i) u (cons .Nat .i x xl)) = + cons Nat _ (f u) (cons Nat _ (f x) (map2 _ f xl)) +} + +{- +- this then fails since deep matching is not allowed +- for the CoSizes inside the cons we would still have to allow dot patterns +- how to separate these two uses? +- maybe: the size pattern inside cocons can only be a dot pattern?! +-} diff --git a/test/fail/matchOnNatSuccI.err b/test/fail/matchOnNatSuccI.err new file mode 100644 --- /dev/null +++ b/test/fail/matchOnNatSuccI.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "matchOnNatSuccI.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +term foo : .[i : Size] -> Nat i +{} +type foo2 : (i : Size) -> Nat $i -> Set +{ foo2 i (Nat.zero [.i]) = foo2 # (Nat.zero [#]) +; foo2 i (Nat.succ [.i] x) = Nat # +} +error during typechecking: +Termination check for function foo2 fails diff --git a/test/fail/matchOnNatSuccI.ma b/test/fail/matchOnNatSuccI.ma new file mode 100644 --- /dev/null +++ b/test/fail/matchOnNatSuccI.ma @@ -0,0 +1,22 @@ +sized data Nat : Size -> Set +{ +zero : ( i : Size ) -> Nat ($ i); +succ : ( i : Size ) -> Nat i -> Nat ($ i); +} + + +-- size not used +fun foo : (i : Size ) -> Nat i +{ +--foo ($ i) = foo i -- subtyping +} + + +-- not inductive in i +fun foo2 : (i : Size ) -> Nat ($ i) -> Set +{ +foo2 i (zero .i) = foo2 _ (zero _); +foo2 i (succ .i x) = Nat _ +} + +-- I think the analysis declares i unusable for termination, and then the check fails diff --git a/test/fail/match_erased.err b/test/fail/match_erased.err new file mode 100644 --- /dev/null +++ b/test/fail/match_erased.err @@ -0,0 +1,13 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "match_erased.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term illegal_match : Nat -> .[Nat] -> Nat +error during typechecking: +illegal_match +/// clause 1 +/// pattern zero +/// checkPattern: constructor Nat.zero of non-computational argument zero : Nat not forced diff --git a/test/fail/match_erased.ma b/test/fail/match_erased.ma new file mode 100644 --- /dev/null +++ b/test/fail/match_erased.ma @@ -0,0 +1,12 @@ +data Nat : Set +{ + zero : Nat; + succ : Nat -> Nat +} + +-- The following should not type check. +fun illegal_match : Nat -> [Nat] -> Nat +{ + illegal_match x zero = x; + illegal_match x (succ y) = x +} diff --git a/test/fail/match_on_set.err b/test/fail/match_on_set.err new file mode 100644 --- /dev/null +++ b/test/fail/match_on_set.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "match_on_set.ma" --- +--- scope checking --- +scope check error: bla +/// pattern A is not a constructor diff --git a/test/fail/match_on_set.ma b/test/fail/match_on_set.ma new file mode 100644 --- /dev/null +++ b/test/fail/match_on_set.ma @@ -0,0 +1,8 @@ +data A : Set {} +data B : Set {} + +fun bla : Set -> Set +{ + bla A = B; + bla B = A +} diff --git a/test/fail/negativeFam.err b/test/fail/negativeFam.err new file mode 100644 --- /dev/null +++ b/test/fail/negativeFam.err @@ -0,0 +1,13 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "negativeFam.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.suc : ^(y0 : Nat) -> < Nat.suc y0 : Nat > +type D : ^ Nat -> Set +term D.abs : ^(y0 : D Nat.zero -> D Nat.zero) -> < D.abs y0 : D Nat.zero > +term D.app : .[n : Nat] -> ^(y1 : D n) -> ^(y2 : D n) -> < D.app n y1 y2 : D n > +error during typechecking: +checking positivity +/// polarity check ++ <= - failed diff --git a/test/fail/negativeFam.ma b/test/fail/negativeFam.ma new file mode 100644 --- /dev/null +++ b/test/fail/negativeFam.ma @@ -0,0 +1,11 @@ +data Nat : Set +{ + zero : Nat; + suc : Nat -> Nat +} + +data D : Nat -> Set +{ + abs : (D zero -> D zero) -> D zero; + app : (n : Nat) -> D n -> D n -> D n +} diff --git a/test/fail/notAdmMonotoneArg.err b/test/fail/notAdmMonotoneArg.err new file mode 100644 --- /dev/null +++ b/test/fail/notAdmMonotoneArg.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "notAdmMonotoneArg.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +type Unit : Set +term Unit.triv : < Unit.triv : Unit > +term bla : .[i : Size] -> (Stream Unit i -> Stream Unit i) -> Stream Unit i +error during typechecking: +bla +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> (Stream Unit i -> Stream Unit i) -> Stream Unit i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: (Stream Unit i -> Stream Unit i) -> Stream Unit i +/// type Stream Unit i -> Stream Unit i not lower semi continuous in i diff --git a/test/fail/notAdmMonotoneArg.ma b/test/fail/notAdmMonotoneArg.ma new file mode 100644 --- /dev/null +++ b/test/fail/notAdmMonotoneArg.ma @@ -0,0 +1,13 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +data Unit : Set { + triv : Unit +} + +cofun bla : (i : Size) -> (Stream Unit i -> Stream Unit i) -> Stream Unit i +{ + bla ($ i) f = f (cons Unit i triv (bla i f)) +} diff --git a/test/fail/omegaInst.err b/test/fail/omegaInst.err new file mode 100644 --- /dev/null +++ b/test/fail/omegaInst.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "omegaInst.ma" --- +--- scope checking --- +--- type checking --- +term ok : .[F : Size -> Set] -> .[i < #] -> (f : .[j < $i] -> F j) -> F i +term ok = [\ F ->] [\ i ->] \ f -> f [i] +term bad : .[F : Size -> Set] -> .[i <= #] -> (f : .[j < $i] -> F j) -> F i +term bad = [\ F ->] [\ i ->] \ f -> f [i] +term inst : .[F : Size -> Set] -> (f : .[j < #] -> F j) -> F # +term inst = [\ F ->] \ f -> bad [F] [#] f +error during typechecking: +bot +/// new F : (Size -> Set) +/// new f : (.[j < #] -> F j{F = (v0 Up (Size -> Set))}) +/// checkExpr 2 |- f # : F # +/// inferExpr' f # +/// checkApp (.[j < #] -> F j{F = (v0 Up (Size -> Set))}) eliminated by # +/// leqVal' (subtyping) < # : Size > <=+ < # +/// leSize # <+ # +/// leSize: # < # failed diff --git a/test/fail/omegaInst.ma b/test/fail/omegaInst.ma new file mode 100644 --- /dev/null +++ b/test/fail/omegaInst.ma @@ -0,0 +1,17 @@ +-- 2012-02-06 Make sure not to violate < - Constraints by going through infty + +let ok [F : Size -> Set] [i < #] (f : [j < $i] -> F j) : F i + = f i + +-- this needs to fail, because i can be instantiated to # +let bad [F : Size -> Set] [i <= #] (f : [j < $i] -> F j) : F i + = f i + +let inst [F : Size -> Set] (f : [j < #] -> F j) : F # + = bad F # f + +let bot [F : Size -> Set] (f : [j < #] -> F j) : F # + = f # +-- DOUBTS: is this so bad after all? +-- each descending chain f has a limit. +-- If # is that closure ordinal, this should be ok. diff --git a/test/fail/omegaInst1.err b/test/fail/omegaInst1.err new file mode 100644 --- /dev/null +++ b/test/fail/omegaInst1.err @@ -0,0 +1,22 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "omegaInst1.ma" --- +--- scope checking --- +--- type checking --- +term fix : .[F : Size -> Set] -> (phi : .[i <= #] -> (f : .[j < i] -> F j) -> F i) -> .[i <= #] -> F i +{ fix [F] phi [i] = phi [i] (fix [F] phi) +} +type Bot : +(i : Size) -> Set +{ Bot i = .[j < i] & Bot j +} +type Top : -(i : Size) -> Set +{ Top i = .[j < i] -> Top j +} +error during typechecking: +out +/// new i <= # +/// new r : (Top {$i {i = v0}}) +/// checkExpr 2 |- \ j -> r $j j : Top i +/// checkForced fromList [(i,0),(r,1)] |- \ j -> r $j j : .[j < i] -> Top j +/// new j < v0 +/// adding size rel. v2 + 1 <= v0 +/// cannot add hypothesis v2 + 1 <= v0 because it is not satisfyable under all possible valuations of the current hypotheses diff --git a/test/fail/omegaInst1.ma b/test/fail/omegaInst1.ma new file mode 100644 --- /dev/null +++ b/test/fail/omegaInst1.ma @@ -0,0 +1,27 @@ +-- 2012-02-06 Make sure not to violate < - Constraints by going through infty +-- (not finished) + +fun fix : [F : Size -> Set] + (phi : [i <= #] (f : [j < i] -> F j) -> F i) + [i <= #] -> |i| -> F i +{ fix F phi i = phi i (fix F phi) +} + +cofun Bot : +(i : Size) -> Set +{ Bot i = [j < i] & Bot j +} + +cofun Top : -(i : Size) -> Set +{ Top i = [j < i] -> Top j +} + +let out [i : Size] (r : Top $i) : Top i + = \ j -> r $j j + +let inn [i : Size] (t : Top i) : Top $i + = \ j -> t + +let bad [F : Size -> Set] [i <= #] (f : [j < $i] -> F j) : F i + = f i + +let test [F : Size -> Set] = fix F (bad F) diff --git a/test/fail/onesStreamUnguarded.err b/test/fail/onesStreamUnguarded.err new file mode 100644 --- /dev/null +++ b/test/fail/onesStreamUnguarded.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "onesStreamUnguarded.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term copyFirst : .[i : Size] -> Stream Nat i -> Stream Nat $i +error during typechecking: +copyFirst +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> Stream Nat i -> Stream Nat $i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: Stream Nat i -> Stream Nat $i +/// new : (Stream {Nat {i = v0}} v0) +/// endsInSizedCo: Stream Nat $i +/// endsInSizedCo: target Stream Nat $i of corecursive function is neither a CoSet or codata of size i nor a tuple type diff --git a/test/fail/onesStreamUnguarded.ma b/test/fail/onesStreamUnguarded.ma new file mode 100644 --- /dev/null +++ b/test/fail/onesStreamUnguarded.ma @@ -0,0 +1,19 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : [i : Size] -> A -> Stream A i -> Stream A ($ i) +} + +data Nat : Set { + zero : Nat; + succ : Nat -> Nat +} + +-- the following needs to be rejected +-- the matching on size is illegal since the target is not Stream Nat i +cofun copyFirst : (i : Size) -> Stream Nat i -> Stream Nat ($ i) +{ copyFirst ($ i) (cons .Nat .i x xs) = cons Nat ($ i) x (cons Nat i x xs) +} + +cofun ones : (i : Size) -> Stream Nat i +{ ones ($ i) = copyFirst i (ones i) +} diff --git a/test/fail/partialFunction.err b/test/fail/partialFunction.err new file mode 100644 --- /dev/null +++ b/test/fail/partialFunction.err @@ -0,0 +1,18 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "partialFunction.ma" --- +--- scope checking --- +--- type checking --- +type Subset : ^(A : Set) -> ^(P : A -> Set) -> Set +term Subset.put : .[A : Set] -> .[P : A -> Set] -> ^(a : A) -> .[y1 : P a] -> < Subset.put a y1 : Subset A P > +type PFun : ^(A : Set) -> ^(B : Set) -> Set +error during typechecking: +PFun +/// constructor PFun.mkPFun +/// new PFun : (^(A : Set) -> ^(B : Set) -> Set) +/// new A : Set +/// new B : Set +/// inferExpr' ^(dom : A -> Set) -> ^(app : Subset A dom -> B) -> PFun A B +/// new dom : (v1::Tm -> {Set {B = v2, A = v1, PFun = (v0 Up (^(A : Set) -> ^(B : Set) -> Set))}}) +/// leSize 1 <=+ 0 +/// leSize' 1 <= 0 +/// leSize': 1 <= 0 failed diff --git a/test/fail/partialFunction.ma b/test/fail/partialFunction.ma new file mode 100644 --- /dev/null +++ b/test/fail/partialFunction.ma @@ -0,0 +1,9 @@ +data Subset (A : Set) (P : A -> Set) : Set +{ + put : (a : A) -> [P a] -> Subset A P +} + +data PFun (A : Set)(B : Set) : Set +{ mkPFun : (dom : A -> Set) -> (app : Subset A dom -> B) -> PFun A B +} +-- should fail unless Set : Set diff --git a/test/fail/relevantArgErasedMagicVec.err b/test/fail/relevantArgErasedMagicVec.err new file mode 100644 --- /dev/null +++ b/test/fail/relevantArgErasedMagicVec.err @@ -0,0 +1,32 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "relevantArgErasedMagicVec.ma" --- +--- scope checking --- +--- type checking --- +type Sigma : ^(A : Set) -> ^(B : A -> Set) -> Set +term Sigma.pair : .[A : Set] -> .[B : A -> Set] -> ^(fst : A) -> ^(snd : B fst) -> < Sigma.pair fst snd : Sigma A B > +term fst : .[A : Set] -> .[B : A -> Set] -> (pair : Sigma A B) -> A +{ fst [A] [B] (Sigma.pair #fst #snd) = #fst +} +term snd : .[A : Set] -> .[B : A -> Set] -> (pair : Sigma A B) -> B (fst [A] [B] pair) +{ snd [A] [B] (Sigma.pair #fst #snd) = #snd +} +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +type Empty : Set +term magic : .[A : Set] -> .[p : Empty] -> A +{} +type Unit : Set +term Unit.unit : < Unit.unit : Unit > +type Vec : .[A : Set] -> (n : Nat) -> Set +error during typechecking: +Vec +/// clause 2 +/// right hand side +/// checkExpr 2 |- Sigma A (\ z -> Vec A n) : Set +/// inferExpr' Sigma A (\ z -> Vec A n) +/// inferExpr' Sigma A +/// checkApp (^(A : Set) -> ^(B : A -> Set) -> Set) eliminated by A +/// inferExpr' A +/// inferExpr: variable A : Set may not occur +/// , because it is marked as erased diff --git a/test/fail/relevantArgErasedMagicVec.ma b/test/fail/relevantArgErasedMagicVec.ma new file mode 100644 --- /dev/null +++ b/test/fail/relevantArgErasedMagicVec.ma @@ -0,0 +1,44 @@ +-- proof irrelevance via polymorphism + +data Sigma (A : Set) (B : A -> Set) : Set +{ pair : (fst : A) -> (snd : B fst) -> Sigma A B +} +fields fst, snd + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +data Empty : Set +{ +} + +-- magic = abort does not need the inhabitant p : Empty +fun magic : [A : Set] -> [p : Empty] -> A +{ +} + +data Unit : Set +{ unit : Unit +} + +fun Vec : [A : Set] -> (n : Nat) -> Set +{ Vec A zero = Empty +; Vec A (succ n) = Sigma A (\ z -> Vec A n) +} + +fun Leq : (n : Nat) -> (m : Nat) -> Set +{ Leq zero m = Unit +; Leq (succ n) zero = Empty +; Leq (succ n) (succ m) = Leq n m +} +let Lt : (n : Nat) -> (m : Nat) -> Set + = \ n -> \ m -> Leq (succ n) m + +fun lookup : [A : Set] -> (n : Nat) -> (m : Nat) -> [Lt m n] -> Vec A n -> A +{ lookup A zero m p v = magic A p +; lookup A (succ n) zero p v = fst v -- fst A (\ z -> Vec A n) v +; lookup A (succ n) (succ m) p v = lookup A n m p <| snd v -- (snd A (\ z -> Vec A n) v) +} + diff --git a/test/fail/scolist_not_lsc1.err b/test/fail/scolist_not_lsc1.err new file mode 100644 --- /dev/null +++ b/test/fail/scolist_not_lsc1.err @@ -0,0 +1,20 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "scolist_not_lsc1.ma" --- +--- scope checking --- +--- type checking --- +type Nat : ^ Size -> Set +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +type Colist : ^(A : Set) -> ^ Size -> Set +term Colist.nil : .[A : Set] -> .[i : Size] -> < Colist.nil i : Colist A $i > +term Colist.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Colist A i) -> < Colist.cons i y1 y2 : Colist A $i > +term length : .[i : Size] -> .[A : Set] -> Colist A i -> Nat i +error during typechecking: +checking type of length for admissibility +/// new A : _ +/// new i : _ +/// new i <= # +/// admType: checking (.[A : Set] -> Colist A i -> Nat i{i = v2}) admissible in v2 +/// new A : Set +/// admType: checking ((Colist v3 v2)::Tm -> {Nat i {A = v3, i = v2}}) admissible in v2 +/// type Colist A i not lower semi continuous in i diff --git a/test/fail/scolist_not_lsc1.ma b/test/fail/scolist_not_lsc1.ma new file mode 100644 --- /dev/null +++ b/test/fail/scolist_not_lsc1.ma @@ -0,0 +1,79 @@ +-- keyword "sized" forgotten + +data Nat : Size -> Set +{ + zero : (i : Size ) -> Nat ($ i); + succ : (i : Size ) -> Nat i -> Nat ($ i); +} + + +codata Colist (A : Set) : Size -> Set +{ + nil : (i : Size ) -> Colist A ($ i); + cons : (i : Size ) -> A -> Colist A i -> Colist A ($ i) +} + +-- not allowed because no inductive argument with i +fun length : (i : Size ) -> (A : Set) -> Colist A i -> Nat i +{ +length .($ i) A (nil i) = zero i ; +length .($ i) A (cons i a as) = succ i (length i A as) +} + +codata CoNat : Size -> Set +{ + cozero : (i : Size ) -> CoNat ($ i); + cosucc : (i : Size ) -> CoNat i -> CoNat ($ i) +} + +let z : CoNat # = cozero # + +-- allowed because i used in coinductive result +cofun length2 : (i : Size ) -> ( A : Set ) -> Colist A i -> CoNat i +{ +length2 .($ i) A (nil i) = cozero i; +length2 .($ i) A (cons i a as) = cosucc i (length2 i A as) +} + +cofun omega' : ( i : Size ) -> CoNat i +{ +omega' ($ i) = cosucc i (omega' i) +} + +let omega : CoNat # = omega' # + +cofun olist' : ( i : Size ) -> Colist (Nat #) i +{ +olist' ($ i) = cons i (zero #) (olist' i) +} + +eval let diverge : Nat # = length # (Nat #) (olist' #) + +-- not ok because size not used in inductive argument +-- fun convert1 : (i : Size ) -> CoNat i -> Nat i +-- { +-- convert1 .($ i) (cozero i) = zero i; +-- convert1 .($ i) (cosucc i x) = succ i (convert1 i x) +-- } + +-- ok +fun convert2 : ( i : Size ) -> Nat i -> CoNat i +{ +convert2 .($ i) (zero i) = cozero i; +convert2 .($ i) (succ i x) = cosucc i (convert2 i x) +} + +-- also ok +fun convert3 : ( i : Size ) -> Nat i -> CoNat # +{ +convert3 .($ i) (zero i) = cozero #; +convert3 .($ i) (succ i x) = omega' # +} + +-- also ok +cofun convert4 : ( i : Size ) -> Nat i -> CoNat i +{ +convert4 .($ i) (zero i) = cozero ($ i) ; +convert4 .($ i) (succ i x) = cosucc i (convert4 i x) +} + diff --git a/test/fail/scolist_not_lsc2.err b/test/fail/scolist_not_lsc2.err new file mode 100644 --- /dev/null +++ b/test/fail/scolist_not_lsc2.err @@ -0,0 +1,30 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "scolist_not_lsc2.ma" --- +--- scope checking --- +--- type checking --- +type Nat : + Size -> Set +term Nat.zero : .[s!ze : Size] -> .[i < s!ze] -> Nat s!ze +term Nat.zero : .[i : Size] -> < Nat.zero i : Nat $i > +term Nat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ Nat i -> Nat s!ze +term Nat.succ : .[i : Size] -> ^(y1 : Nat i) -> < Nat.succ i y1 : Nat $i > +type Colist : ^(A : Set) -> ^ Size -> Set +term Colist.nil : .[A : Set] -> .[i : Size] -> < Colist.nil i : Colist A $i > +term Colist.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Colist A i) -> < Colist.cons i y1 y2 : Colist A $i > +type CoNat : ^ Size -> Set +term CoNat.cozero : .[i : Size] -> < CoNat.cozero i : CoNat $i > +term CoNat.cosucc : .[i : Size] -> ^(y1 : CoNat i) -> < CoNat.cosucc i y1 : CoNat $i > +term z : CoNat # +term z = CoNat.cozero [#] +term length2 : .[i : Size] -> .[A : Set] -> Colist A i -> CoNat i +{ length2 [.$i] [A] (Colist.nil [i]) = CoNat.cozero [i] +; length2 [.$i] [A] (Colist.cons [i] a as) = CoNat.cosucc [i] (length2 [i] [A] as) +} +term omega' : .[i : Size] -> CoNat i +error during typechecking: +omega' +/// clause 1 +/// pattern $i +/// checkPattern $i : matching on size, checking that target .[i : Size] -> CoNat i ends in correct coinductive sized type +/// new i <= # +/// endsInSizedCo: CoNat i +/// endsInSizedCo: target CoNat i of corecursive function is neither a CoSet or codata of size i nor a tuple type diff --git a/test/fail/scolist_not_lsc2.ma b/test/fail/scolist_not_lsc2.ma new file mode 100644 --- /dev/null +++ b/test/fail/scolist_not_lsc2.ma @@ -0,0 +1,79 @@ +sized data Nat : Size -> Set +{ + zero : (i : Size ) -> Nat ($ i); + succ : (i : Size ) -> Nat i -> Nat ($ i); +} + + +codata Colist (A : Set) : Size -> Set +{ + nil : (i : Size ) -> Colist A ($ i); + cons : (i : Size ) -> A -> Colist A i -> Colist A ($ i) +} + +-- -- not allowed because no inductive argument with i +-- fun length : (i : Size ) -> (A : Set) -> Colist A i -> Nat i +-- { +-- length .($ i) .A (nil A i) = zero i ; +-- length .($ i) .A (cons A i a as) = succ i (length i A as) +-- } + +-- not a sized codata !! +codata CoNat : Size -> Set +{ + cozero : (i : Size ) -> CoNat ($ i); + cosucc : (i : Size ) -> CoNat i -> CoNat ($ i) +} + +let z : CoNat # = cozero # + +-- allowed because i used in coinductive result +cofun length2 : (i : Size ) -> ( A : Set ) -> Colist A i -> CoNat i +{ +length2 .($ i) A (nil i) = cozero i; +length2 .($ i) A (cons i a as) = cosucc i (length2 i A as) +} + +cofun omega' : ( i : Size ) -> CoNat i +{ +omega' ($ i) = cosucc i (omega' i) +} + +let omega : CoNat # = omega' # + +cofun olist' : ( i : Size ) -> Colist (Nat #) i +{ +olist' ($ i) = cons i (zero #) (olist' i) +} + +-- Diverges: +-- eval let diverge : Nat # = length # (Nat #) (olist' #) + +-- not ok because size not used in inductive argument +-- fun convert1 : (i : Size ) -> CoNat i -> Nat i +-- { +-- convert1 .($ i) (cozero i) = zero i; +-- convert1 .($ i) (cosucc i x) = succ i (convert1 i x) +-- } + +-- ok +fun convert2 : ( i : Size ) -> Nat i -> CoNat i +{ +convert2 .($ i) (zero i) = cozero i; +convert2 .($ i) (succ i x) = cosucc i (convert2 i x) +} + +-- also ok +fun convert3 : ( i : Size ) -> Nat i -> CoNat # +{ +convert3 .($ i) (zero i) = cozero #; +convert3 .($ i) (succ i x) = omega' # +} + +-- also ok +cofun convert4 : ( i : Size ) -> Nat i -> CoNat i +{ +convert4 .($ i) (zero i) = cozero ($ i) ; +convert4 .($ i) (succ i x) = cosucc i (convert4 i x) +} + diff --git a/test/fail/shadowGlobal.err b/test/fail/shadowGlobal.err new file mode 100644 --- /dev/null +++ b/test/fail/shadowGlobal.err @@ -0,0 +1,4 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "shadowGlobal.ma" --- +--- scope checking --- +scope check error: "shadowing of global definitions forbidden": Identifier bla already in signature diff --git a/test/fail/shadowGlobal.ma b/test/fail/shadowGlobal.ma new file mode 100644 --- /dev/null +++ b/test/fail/shadowGlobal.ma @@ -0,0 +1,3 @@ +-- 2012-01-27 shadowing of globals not allowed +let bla : Size = 0 +let bla : Size = 0 diff --git a/test/fail/shouldBeDotPattern_snat.err b/test/fail/shouldBeDotPattern_snat.err new file mode 100644 --- /dev/null +++ b/test/fail/shouldBeDotPattern_snat.err @@ -0,0 +1,23 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "shouldBeDotPattern_snat.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term z : SNat # +term z = SNat.zero [#] +term one : SNat # +term one = SNat.succ [#] z +term two : SNat # +term two = SNat.succ [#] one +term three : SNat # +term three = SNat.succ [#] two +term add : .[i : Size] -> .[j : Size] -> SNat i -> SNat j -> SNat # +error during typechecking: +add +/// clause 1 +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/shouldBeDotPattern_snat.ma b/test/fail/shouldBeDotPattern_snat.ma new file mode 100644 --- /dev/null +++ b/test/fail/shouldBeDotPattern_snat.ma @@ -0,0 +1,82 @@ +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +let z : SNat # = zero # +let one : SNat # = succ # z +let two : SNat # = succ # one +let three : SNat # = succ # two + + +-- 2010-08-18 all these functions fail because ($ i) is restricted to cofun + +fun add : (i : Size) -> (j : Size) -> SNat i -> SNat j -> SNat # +{ + +add ($ i) j (zero .i) y = y; +add ($ i) j (succ .i x) y = succ # (add i j x y) + +} + +let four : SNat # = add # # two two +let six : SNat # = add # # four two + +fun minus : (i : Size) -> (j : Size) -> SNat i -> SNat j -> SNat i +{ + +minus ($ i) ($ j) (zero .i) y = zero i; +minus ($ i) ($ j) x (zero .j) = x ; +minus ($ i) ($ j) (succ .i x) (succ .j y) = minus i j x y + +} + +let min4_2 : SNat # = minus # # four two + +-- not structurally recursive without sizes ... +fun div : (i : Size) -> (j : Size) -> SNat i -> SNat j -> SNat i +{ + +div ($ i) ($ j) (zero .i) y = (zero i) ; +div ($ i) ($ j) x (zero .j) = (zero i); +div ($ i) ($ j) (succ .i x) (succ .j y) = succ i (div i ($ j) (minus i j x y) (succ j y)) + +} + +let div4_4 : SNat # = div # # four four + + +fun compare : (i : Size) -> (j : Size) -> (SNat i) -> (SNat j) + -> (A : Set) -> A -> A -> A +{ +compare ($ i) ($ j) x (zero .j) A a a' = a ; +compare ($ i) ($ j) (zero .i) (succ .j y') A a a' = a'; +compare ($ i) ($ j) (succ .i x) (succ .j y) A a a' = compare i j x y A a a' +} + +fun gcd : (i : Size) -> (j : Size) -> (SNat i) -> (SNat j) -> (SNat #) +{ +gcd ($ i) j (zero .i) y = y ; +gcd i ($ j) x (zero .j) = x ; +gcd ($ i) ($ j) (succ .i x) (succ .j y) = + compare i j x y (SNat #) + (gcd i ($ j) (minus i j x y) (succ j y)) + (gcd ($ i) j (succ i x) (minus j i y x)) +} + +let gcd6_4 : SNat # = gcd # # six four + +data SEmpty : Size -> Set +{ +} + +fun bad : (i : Size) -> SNat i -> SEmpty i +{ +bad i x = x +} + +fun bad2 : (A : Set) -> (B : Set) -> A -> B +{ +bad2 A B x = x +} diff --git a/test/fail/singleton.err b/test/fail/singleton.err new file mode 100644 --- /dev/null +++ b/test/fail/singleton.err @@ -0,0 +1,19 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "singleton.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +K +/// checkExpr 0 |- \ A -> \ x -> \ y -> y : .[A : Set] -> (x : A) -> (y : A) -> < x : A > +/// checkForced fromList [] |- \ A -> \ x -> \ y -> y : .[A : Set] -> (x : A) -> (y : A) -> < x : A > +/// new A : Set +/// checkExpr 1 |- \ x -> \ y -> y : (x : A) -> (y : A) -> < x : A > +/// checkForced fromList [(A,0)] |- \ x -> \ y -> y : (x : A) -> (y : A) -> < x : A > +/// new x : v0 +/// checkExpr 2 |- \ y -> y : (y : A) -> < x : A > +/// checkForced fromList [(x,1),(A,0)] |- \ y -> y : (y : A) -> < x : A > +/// new y : v0 +/// checkExpr 3 |- y : < x : A > +/// leqVal' (subtyping) < y : A > <=+ < x : A > +/// leqVal' y : A <=* x : A +/// leqApp: head mismatch y != x diff --git a/test/fail/singleton.ma b/test/fail/singleton.ma new file mode 100644 --- /dev/null +++ b/test/fail/singleton.ma @@ -0,0 +1,6 @@ +-- 2009-11-29 + +let K : (A : Set) -> (x : A) -> (y : A) -> + = \ A -> \ x -> \ y -> y + + diff --git a/test/fail/sizePatternSucc.err b/test/fail/sizePatternSucc.err new file mode 100644 --- /dev/null +++ b/test/fail/sizePatternSucc.err @@ -0,0 +1,17 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "sizePatternSucc.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +type Empty : Set +term bad : .[i : Size] -> SNat i -> Empty +error during typechecking: +bad +/// clause 2 +/// pattern zero $i +/// pattern $i +/// successor pattern only allowed in cofun diff --git a/test/fail/sizePatternSucc.ma b/test/fail/sizePatternSucc.ma new file mode 100644 --- /dev/null +++ b/test/fail/sizePatternSucc.ma @@ -0,0 +1,18 @@ + +sized data SNat : Size -> Set +{ +zero : (i : Size) -> SNat ($ i); +succ : (i : Size) -> SNat i -> SNat ($ i) +} + +data Empty : Set +{ +} + +-- ($ i) appearing as a size pattern + +fun bad : (i : Size) -> SNat i -> Empty +{ +bad .($ i) (succ i x) = bad _ x; +bad .($ ($ i)) (zero ($ i)) = bad _ (zero _); +} diff --git a/test/fail/stream.err b/test/fail/stream.err new file mode 100644 --- /dev/null +++ b/test/fail/stream.err @@ -0,0 +1,6 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "stream.ma" --- +--- scope checking --- +scope check error: Stream +/// cons +/// Identifier Nat undefined diff --git a/test/fail/stream.ma b/test/fail/stream.ma new file mode 100644 --- /dev/null +++ b/test/fail/stream.ma @@ -0,0 +1,29 @@ + +sized codata Stream : Size -> Set { + cons : (i : Size) -> Nat -> Stream i -> Stream ($ i) +} + +fun tail : Stream # -> Stream # { + tail (cons .# x xs) = xs +} + +fun head : Stream # -> Nat { + head (cons .# x xs) = x +} + + + +cofun lookbad : (i : Size ) -> Stream i +{ +lookbad ($ i) = + first (Stream _) (Stream _) + (cons _ zero (lookbad _)) + (lookbad _) +} + +--let proof2 : Eq (Stream #) (cons # zero (lookbad #)) (lookbad #) = refl (Stream #) (lookbad #) +--let proof3 : Eq (Stream #) (cons # zero (lookbad #)) (tail (lookbad #)) = refl (Stream #) (tail (lookbad #) + +let proof2 : Eq (Stream #) (cons # zero (lookbad #)) (lookbad #) = refl (Stream #) (lookbad #) +let proof3 : Eq (Stream #) (cons # zero (lookbad #)) (tail (lookbad #)) = refl (Stream #) (tail (lookbad #)) + diff --git a/test/fail/streamMisc.err b/test/fail/streamMisc.err new file mode 100644 --- /dev/null +++ b/test/fail/streamMisc.err @@ -0,0 +1,5 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "streamMisc.ma" --- +--- scope checking --- +scope check error: wkStream2 +/// pattern not linear: A diff --git a/test/fail/streamMisc.ma b/test/fail/streamMisc.ma new file mode 100644 --- /dev/null +++ b/test/fail/streamMisc.ma @@ -0,0 +1,188 @@ +data Nat : Set +{ + zero : Nat ; + succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ +add x zero = x; +add x (succ y) = succ (add x y); +} + +eval let one : Nat = succ zero + +sized codata Stream (A : Set) : Size -> Set +{ + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +cofun zeroes : (i : Size ) -> Stream Nat i +{ +zeroes ($ i) = cons Nat i zero (zeroes i) +} + +cofun ones : (i : Size) -> Stream Nat i +{ +ones ($ i) = cons Nat i one (ones i) +} + +eval let ones' : Stream Nat # = ones # + +cofun map : (A : Set) -> (B : Set) -> (i : Size) -> + (A -> B) -> Stream A # -> Stream B i +{ +map A B ($ i) f (cons .A .# a as) = cons B i (f a) (map A B i f as) +} + +eval let twos : Stream Nat # = map Nat Nat # ( \ x -> succ x) ones' + + + +-- tail is a fun +fun tail : (A : Set) -> Stream A # -> Stream A # +{ +tail A (cons .A .# a as) = as +} + + +eval let twos' : Stream Nat # = tail Nat twos + +fun head : (A : Set) -> Stream A # -> A +{ +head A (cons .A .# a as) = a +} + +eval let two : Nat = head Nat twos +eval let two' : Nat = head Nat twos' + +eval let twos2 : Stream Nat # = map Nat Nat # ( \ x -> succ x) ones' +eval let twos2' : Stream Nat # = tail Nat twos2 + +cofun zipWith : ( A : Set ) -> ( B : Set ) -> (C : Set) -> ( i : Size ) -> + (A -> B -> C) -> Stream A # -> Stream B # -> Stream C i +{ +zipWith A B C ($ i) f (cons .A .# a as) (cons .B .# b bs) = + cons C i (f a b) (zipWith A B C i f as bs) +} + + + +fun nth : Nat -> Stream Nat # -> Nat +{ +nth zero ns = head Nat ns; +nth (succ x) ns = nth x (tail Nat ns) +} + +eval let fours : Stream Nat # = zipWith Nat Nat Nat # add twos twos +eval let four : Nat = head Nat fours + + + +cofun fib : (x : Nat ) -> (y : Nat ) -> (i : Size ) -> Stream Nat i +{ +fib x y ($ i) = (cons Nat ($ i) x (cons Nat i y (fib y (add x y) i))) +} + +eval let fib' : Stream Nat # = tail Nat (fib zero zero #) + + +eval let fib8 : Nat = nth (add four four) (fib zero zero #) + +eval let fib2 : Nat = head Nat (tail Nat (fib zero zero #)) + +cofun nats : (i : Size ) -> Nat -> Stream Nat i +{ +nats ($ i) x = (cons Nat i x (nats i (succ x))) +} + +eval let nats' : Stream Nat # = tail Nat (nats # zero) + + +--- weakening +eval let wkStream : ( A : Set ) -> ( i : Size ) -> Stream A ($ i) -> Stream A i = \ A -> \ i -> \ s -> s + +-- should be ok but does not pass admissibility check +cofun wkStream_ok : ( A : Set ) -> (i : Size ) -> Stream A ($ i) -> Stream A i +{ +wkStream_ok A ($ i) (cons .A .($ i) x xs) = cons A i x (wkStream A i xs) +} + + + +--bad +--not admissble +cofun wkStream2 : ( A : Set ) -> ( i : Size ) -> Stream A i -> Stream A ($ i) +{ +wkStream2 A ($ i) (cons A .i x xs) = cons A ($ i) x (wkStream2 A i xs) +} + + +-- an unproductive stream +cofun unp : (i : Size ) -> Stream Nat i +{ +unp i = unp i +} + +-- another one, not type correect +{- +cofun unp2 : (i : Size ) -> Stream Nat i +{ +unp2 ($ i) = cons Nat i zero (tail Nat (unp2 ($ i))) +} +-} + + +--eval let bla2 : Nat = nth four (unp #) + +mutual +{ + +cofun alt1 : ( i : Size ) -> Stream Nat i +{ +alt1 ($ i) = cons Nat i zero (alt2 i) +} + +cofun alt2 : ( i : Size ) -> Stream Nat i +{ +alt2 ($ i) = cons Nat i one (alt1 i) +} + +} + +data Bool : Set +{ +tt : Bool; +ff : Bool +} + +-- tt if a stream starts with 2 zeroes +fun twozeroes : Stream Nat # -> Bool +{ +twozeroes (cons .Nat .# zero (cons .Nat .# zero str)) = tt; +twozeroes (cons .Nat .# zero (cons .Nat .# (succ x) str)) = ff; +twozeroes (cons .Nat .# (succ x) str) = ff +} + +eval let twozeroes'zeroes : Bool = twozeroes (zeroes #) + +data Eq ( A : Set ) : A -> A -> Set +{ +refl : (a : A) -> Eq A a a +} + +-- hangs on unproductive stream +-- let zz : Eq (Stream Nat #) (unp #) (cons Nat # zero (unp #)) = refl (Stream Nat #) (unp #) + +sized data Unit : Size -> Set +{ +unit : (i : Size ) -> Unit ($ i) +} + +-- bad. 2010-03-10 WHY? I think it is ok! +fun head2 : (i : Size ) -> Unit i -> Stream Nat i -> Nat +{ +head2 .($ i) (unit i) (cons .Nat .i x xl) = x +} + + diff --git a/test/fail/stream_x_is_cons_x_tail_x.err b/test/fail/stream_x_is_cons_x_tail_x.err new file mode 100644 --- /dev/null +++ b/test/fail/stream_x_is_cons_x_tail_x.err @@ -0,0 +1,28 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "stream_x_is_cons_x_tail_x.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term n0 : Nat +term n0 = Nat.zero +term n1 : Nat +term n1 = Nat.succ n0 +term n2 : Nat +term n2 = Nat.succ n1 +term n3 : Nat +term n3 = Nat.succ n2 +term n4 : Nat +term n4 = Nat.succ n3 +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +term tail : .[A : Set] -> .[i : Size] -> Stream A $i -> Stream A i +{ tail [A] [i] (Stream.cons [.i] x xs) = xs +} +term bad : .[i : Size] -> Stream Nat i +error during typechecking: +bad +/// clause 1 +/// pattern $$i +/// cannot match against deep successor pattern $$i at type .[i : Size] -> Stream Nat i diff --git a/test/fail/stream_x_is_cons_x_tail_x.ma b/test/fail/stream_x_is_cons_x_tail_x.ma new file mode 100644 --- /dev/null +++ b/test/fail/stream_x_is_cons_x_tail_x.ma @@ -0,0 +1,26 @@ + +data Nat : Set { + zero : Nat; + succ : Nat -> Nat +} + +let n0 : Nat = zero +let n1 : Nat = succ n0 +let n2 : Nat = succ n1 +let n3 : Nat = succ n2 +let n4 : Nat = succ n3 + + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +fun tail : (A : Set) -> (i : Size) -> Stream A ($ i) -> Stream A i +{ + tail A i (cons .i x xs) = xs +} + +cofun bad : (i : Size) -> Stream Nat i +{ + bad ($ ($ i)) = cons _ n0 (tail Nat _ (bad ($ i))) +} diff --git a/test/fail/subtyping_erased.err b/test/fail/subtyping_erased.err new file mode 100644 --- /dev/null +++ b/test/fail/subtyping_erased.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "subtyping_erased.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +id +/// checkExpr 0 |- \ A -> \ x -> x : .[A : Set] -> (.[A] -> A) -> A -> A +/// checkForced fromList [] |- \ A -> \ x -> x : .[A : Set] -> (.[A] -> A) -> A -> A +/// new A : Set +/// checkExpr 1 |- \ x -> x : (.[A] -> A) -> A -> A +/// checkForced fromList [(A,0)] |- \ x -> x : (.[A] -> A) -> A -> A +/// new x : (.[v0::Tm] -> {A {A = v0}}) +/// checkExpr 2 |- x : A -> A +/// leqVal' (subtyping) .[xSing# : A] -> < x xSing# : A > <=+ A -> A +/// subtyping .[xSing# : A] -> < x xSing# : A > <=+ A -> A failed diff --git a/test/fail/subtyping_erased.ma b/test/fail/subtyping_erased.ma new file mode 100644 --- /dev/null +++ b/test/fail/subtyping_erased.ma @@ -0,0 +1,6 @@ +-- every function which does not use its argument is a function +-- this is UNSOUND under erasure! + +let id : [A : Set] -> ([A] -> A) -> (A -> A) + = \ A -> \ x -> x + diff --git a/test/fail/subtyping_erased_wrongdir.err b/test/fail/subtyping_erased_wrongdir.err new file mode 100644 --- /dev/null +++ b/test/fail/subtyping_erased_wrongdir.err @@ -0,0 +1,15 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "subtyping_erased_wrongdir.ma" --- +--- scope checking --- +--- type checking --- +error during typechecking: +id +/// checkExpr 0 |- \ A -> \ x -> x : .[A : Set] -> (A -> A) -> .[A] -> A +/// checkForced fromList [] |- \ A -> \ x -> x : .[A : Set] -> (A -> A) -> .[A] -> A +/// new A : Set +/// checkExpr 1 |- \ x -> x : (A -> A) -> .[A] -> A +/// checkForced fromList [(A,0)] |- \ x -> x : (A -> A) -> .[A] -> A +/// new x : (v0::Tm -> {A {A = v0}}) +/// checkExpr 2 |- x : .[A] -> A +/// leqVal' (subtyping) (xSing# : A) -> < x xSing# : A > <=+ .[A] -> A +/// subtyping (xSing# : A) -> < x xSing# : A > <=+ .[A] -> A failed diff --git a/test/fail/subtyping_erased_wrongdir.ma b/test/fail/subtyping_erased_wrongdir.ma new file mode 100644 --- /dev/null +++ b/test/fail/subtyping_erased_wrongdir.ma @@ -0,0 +1,6 @@ +-- wrong direction of subtyping +-- not every function is a function which does not use its argument + +let id : [A : Set] -> (A -> A) -> ([A] -> A) + = \ A -> \ x -> x + diff --git a/test/fail/swapVariablesWithoutDecrease.err b/test/fail/swapVariablesWithoutDecrease.err new file mode 100644 --- /dev/null +++ b/test/fail/swapVariablesWithoutDecrease.err @@ -0,0 +1,14 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "swapVariablesWithoutDecrease.ma" --- +--- scope checking --- +--- type checking --- +type SNat : + Size -> Set +term SNat.zero : .[s!ze : Size] -> .[i < s!ze] -> SNat s!ze +term SNat.zero : .[i : Size] -> < SNat.zero i : SNat $i > +term SNat.succ : .[s!ze : Size] -> .[i < s!ze] -> ^ SNat i -> SNat s!ze +term SNat.succ : .[i : Size] -> ^(y1 : SNat i) -> < SNat.succ i y1 : SNat $i > +term bla : .[i : Size] -> .[j : Size] -> SNat i -> SNat j -> SNat # +{ bla [.$i] [j] (SNat.succ [i] x) y = bla [$j] [i] (SNat.succ [j] y) x +} +error during typechecking: +Termination check for function bla fails diff --git a/test/fail/swapVariablesWithoutDecrease.ma b/test/fail/swapVariablesWithoutDecrease.ma new file mode 100644 --- /dev/null +++ b/test/fail/swapVariablesWithoutDecrease.ma @@ -0,0 +1,12 @@ +-- termination fails with variable swapping + +sized data SNat : Size -> Set +{ +zero : (i : Size) -> SNat ($ i); +succ : (i : Size) -> SNat i -> SNat ($ i) +} + +fun bla : (i : Size) -> (j : Size) -> SNat i -> SNat j -> SNat # +{ +bla .($ i) j (succ i x) y = bla _ _ (succ _ y) x; +} diff --git a/test/fail/tailBad.err b/test/fail/tailBad.err new file mode 100644 --- /dev/null +++ b/test/fail/tailBad.err @@ -0,0 +1,11 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "tailBad.ma" --- +--- scope checking --- +--- type checking --- +type Stream : ++(A : Set) -> - Size -> Set +term Stream.cons : .[A : Set] -> .[i : Size] -> ^(y1 : A) -> ^(y2 : Stream A i) -> < Stream.cons i y1 y2 : Stream A $i > +term sid : .[A : Set] -> .[i : Size] -> Stream A $i -> Stream A i +error during typechecking: +sid +/// clause 1 +/// size constraints [v1<=?0+1,?0<=?1,?1+1<=v1,SizeMeta(?1),SizeMeta(?0)] unsolvable diff --git a/test/fail/tailBad.ma b/test/fail/tailBad.ma new file mode 100644 --- /dev/null +++ b/test/fail/tailBad.ma @@ -0,0 +1,11 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +-- the type of this identity is not the type of a fun +fun sid : (A : Set) -> (i : Size) -> Stream A ($ i) -> Stream A i +{ + sid A i (cons .i x xs) = cons _ x (sid A _ xs) +} +-- size constraints unsolvable diff --git a/test/fail/vec_eta.err b/test/fail/vec_eta.err new file mode 100644 --- /dev/null +++ b/test/fail/vec_eta.err @@ -0,0 +1,42 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "vec_eta.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(pred : Nat) -> < Nat.succ pred : Nat > +term add : Nat -> Nat -> Nat +{ add Nat.zero y = y +; add (Nat.succ x) y = Nat.succ (add x y) +} +type Vec : ++(A : Set) -> ^ Nat -> Set +term Vec.vnil : .[A : Set] -> < Vec.vnil : Vec A Nat.zero > +term Vec.vcons : .[A : Set] -> ^(head : A) -> .[n : Nat] -> ^(tail : Vec A n) -> < Vec.vcons head n tail : Vec A (Nat.succ n) > +term head : .[A : Set] -> .[n : Nat] -> (vcons : Vec A (Nat.succ n)) -> A +{ head [A] [n] (Vec.vcons #head [.n] #tail) = #head +} +term tail : .[A : Set] -> .[n : Nat] -> (vcons : Vec A (Nat.succ n)) -> Vec A n +{ tail [A] [n] (Vec.vcons #head [.n] #tail) = #tail +} +type Id : ^(A : Set) -> ^(a : A) -> ^ A -> Set +term Id.refl : .[A : Set] -> .[a : A] -> < Id.refl : Id A a a > +error during typechecking: +vec0vnil +/// checkExpr 0 |- \ A -> \ n -> \ v -> \ v' -> refl : .[A : Set] -> (n : Nat) -> (v : Vec A n) -> (v' : Vec A n) -> Id (Vec A n) v v' +/// checkForced fromList [] |- \ A -> \ n -> \ v -> \ v' -> refl : .[A : Set] -> (n : Nat) -> (v : Vec A n) -> (v' : Vec A n) -> Id (Vec A n) v v' +/// new A : Set +/// checkExpr 1 |- \ n -> \ v -> \ v' -> refl : (n : Nat) -> (v : Vec A n) -> (v' : Vec A n) -> Id (Vec A n) v v' +/// checkForced fromList [(A,0)] |- \ n -> \ v -> \ v' -> refl : (n : Nat) -> (v : Vec A n) -> (v' : Vec A n) -> Id (Vec A n) v v' +/// new n : Nat +/// checkExpr 2 |- \ v -> \ v' -> refl : (v : Vec A n) -> (v' : Vec A n) -> Id (Vec A n) v v' +/// checkForced fromList [(n,1),(A,0)] |- \ v -> \ v' -> refl : (v : Vec A n) -> (v' : Vec A n) -> Id (Vec A n) v v' +/// new v : (Vec v0 v1) +/// checkExpr 3 |- \ v' -> refl : (v' : Vec A n) -> Id (Vec A n) v v' +/// checkForced fromList [(n,1),(A,0),(v,2)] |- \ v' -> refl : (v' : Vec A n) -> Id (Vec A n) v v' +/// new v' : (Vec v0 v1) +/// checkExpr 4 |- refl : Id (Vec A n) v v' +/// checkForced fromList [(n,1),(A,0),(v,2),(v',3)] |- refl : Id (Vec A n) v v' +/// leqVal' (subtyping) < Id.refl : Id (Vec A n) v v > <=+ Id (Vec A n) v v' +/// leqVal' (subtyping) Id (Vec A n) v v <=+ Id (Vec A n) v v' +/// leqVal' v <=^ v' : Vec A n +/// leqApp: head mismatch v != v' diff --git a/test/fail/vec_eta.ma b/test/fail/vec_eta.ma new file mode 100644 --- /dev/null +++ b/test/fail/vec_eta.ma @@ -0,0 +1,27 @@ +data Nat : Set +{ + zero : Nat; + succ : (pred : Nat) -> Nat +} + +fun add : Nat -> Nat -> Nat +{ + add zero y = y; + add (succ x) y = succ (add x y) +} + +data Vec (+A : Set) : Nat -> Set +{ + vnil : Vec A zero; + vcons : (head : A) -> [n : Nat] -> (tail : Vec A n) -> Vec A (succ n) +} + +data Id (A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +let vec0vnil : (A : Set) -> (n : Nat) -> (v : Vec A n) -> (v' : Vec A n) -> + Id (Vec A n) v v' + = \ A -> \ n -> \ v -> \ v' -> refl -- (Vec A n) v + + diff --git a/test/fail/vec_length.err b/test/fail/vec_length.err new file mode 100644 --- /dev/null +++ b/test/fail/vec_length.err @@ -0,0 +1,25 @@ +MiniAgda by Andreas Abel and Karl Mehltretter +--- opening "vec_length.ma" --- +--- scope checking --- +--- type checking --- +type Nat : Set +term Nat.zero : < Nat.zero : Nat > +term Nat.succ : ^(y0 : Nat) -> < Nat.succ y0 : Nat > +term add : Nat -> Nat -> Nat +{ add Nat.zero y = y +; add (Nat.succ x) y = Nat.succ (add x y) +} +type Vec : ++(A : Set) -> ^ Nat -> Set +term Vec.vnil : .[A : Set] -> < Vec.vnil : Vec A Nat.zero > +term Vec.vcons : .[A : Set] -> ^(y0 : A) -> .[n : Nat] -> ^(y2 : Vec A n) -> < Vec.vcons y0 n y2 : Vec A (Nat.succ n) > +term length : .[A : Set] -> .[n : Nat] -> Vec A n -> Nat +error during typechecking: +length +/// clause 2 +/// right hand side +/// checkExpr 5 |- succ n : Nat +/// checkForced fromList [(.(succ n),1),(A,0),(x,2),(n,3),(xs,4)] |- succ n : Nat +/// checkApp (^(y0 : Nat::()) -> < Nat.succ y0 : Nat >) eliminated by n +/// inferExpr' n +/// inferExpr: variable n : Nat may not occur +/// , because it is marked as erased diff --git a/test/fail/vec_length.ma b/test/fail/vec_length.ma new file mode 100644 --- /dev/null +++ b/test/fail/vec_length.ma @@ -0,0 +1,23 @@ +data Nat : Set +{ + zero : Nat; + succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ + add zero y = y; + add (succ x) y = succ (add x y) +} + +data Vec (+A : Set) : Nat -> Set +{ + vnil : Vec A zero; + vcons : A -> [n : Nat] -> Vec A n -> Vec A (succ n) +} + +fun length : [A : Set] -> [n : Nat] -> Vec A n -> Nat +{ + length A .zero (vnil) = zero; + length A .(succ n) (vcons x n xs) = succ n -- error: erased n may not occ. +} diff --git a/test/succeed/AbsurdMatchNonLin.ma b/test/succeed/AbsurdMatchNonLin.ma new file mode 100644 --- /dev/null +++ b/test/succeed/AbsurdMatchNonLin.ma @@ -0,0 +1,32 @@ +-- 2010-07-08 + +data Bool : Set +{ true : Bool +; false : Bool +} + +data BB : Bool -> Set +{ tt : BB true +; ff : BB false +} + +data Empty : Set {} +data Unit : Set { unit : Unit } + +fun True : Bool -> Set +{ True true = Unit +; True false = Empty +} + +fun not : Bool -> Bool +{ not true = false +; not false = true +} + +-- the information that True b is empty is not available early enough +-- if we process left to right +-- works if test for emptiness is postponed till after checking patterns +fun bla : (b : Bool) -> True b -> True (not b) -> BB b -> Empty +{ bla .false () x ff +; bla .true x () tt +} diff --git a/test/succeed/AccDestructorErasedIndex.ma b/test/succeed/AccDestructorErasedIndex.ma new file mode 100644 --- /dev/null +++ b/test/succeed/AccDestructorErasedIndex.ma @@ -0,0 +1,111 @@ +-- 2010-01-22 bug noted +-- 2010-07-08 bug fixed +-- 2012-01-22 parameters gone from constructors + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +{- R (S x) x if x < 2 + -} +data R : Nat -> Nat -> Set +{ r1 : (x : Nat) -> R (succ (succ x)) (succ zero) +; r2 : R (succ zero) zero +} + +-- ERROR: data AccPar [A : Set](Lt : A -> A -> Set)(b : A) : Set +data Acc (A : Set) (Lt : A -> A -> Set) *(b : A) : Set +{ acc : (accParOut : (a : A) -> Lt a b -> Acc A Lt a) -> Acc A Lt b +} + +{- 2011-04-23 does not work due to new polarities +data AccOk (A : Set)(Lt : A -> A -> Set) : A -> Set +{ accOk : [b : A] -> (accOkOut : (a : A) -> Lt a b -> AccOk A Lt a) -> AccOk A Lt b +} +-- WAS: BUG +-- destructor generation does not work if indices are not erased +data Acc (A : Set) (Lt : A -> A -> Set) : A -> Set +{ acc : (b : A) -> (accOut : (a : A) -> Lt a b -> Acc A Lt a) -> Acc A Lt b +} +-} + +fun acc_dest : (n : Nat) -> (p : Acc Nat R n) -> + (m : Nat) -> R m n -> Acc Nat R m +{ acc_dest n (acc p) = p +} + +{- +fun succR : (n : Nat) -> R (succ n) n +{ succR zero = r2 +; succR (succ n) = +-} + +let acc2 : (n : Nat) -> Acc Nat R (succ (succ n)) + = \ n -> acc -- Nat R (succ (succ n)) + (\ a -> \ p -> case p {}) + +fun aux1 : (a : Nat) -> (p : R a (succ zero)) -> Acc Nat R a +{ aux1 (succ (succ x)) (r1 .x) = acc2 x +} + +let acc1 : Acc Nat R (succ zero) + = acc -- Nat R (succ zero) + aux1 + +fun aux0 : (a : Nat) -> (p : R a zero) -> Acc Nat R a +{ aux0 .(succ zero) r2 = acc1 +} + +eval let acc0 : Acc Nat R zero + = acc -- Nat R zero + aux0 + +fun accR : (n : Nat) -> Acc Nat R n +{ accR zero = acc0 +; accR (succ zero) = acc1 +; accR (succ (succ n)) = acc2 n +} + +fun f : (x : Nat) -> Acc Nat R x -> Nat +{ f x (acc {-.Nat .R .x-} p) = case x + { zero -> f (succ x) (p (succ x) r2) + ; (succ zero) -> f (succ x) (p (succ x) (r1 zero)) + ; (succ (succ y)) -> zero + } +} + +{- +-- In Coq, g and h are accepted by the termination checker +fun g : (x : Nat) -> [Acc Nat R x] -> Nat +{ g x p = case x + { zero -> g (succ x) (acc_dest zero p (succ x) r2) + ; (succ zero) -> g (succ x) (acc_dest (succ zero) p (succ x) (r1 zero)) + ; (succ (succ y)) -> zero + } +} + +fun h : (x : Nat) -> [Acc Nat R x] -> Nat +{ h zero p = h (succ zero) (acc_dest zero p (succ zero) r2) +; h (succ zero) p = h (succ (succ zero)) (acc_dest (succ zero) p (succ (succ zero)) (r1 zero)) +; h (succ (succ y)) p = zero +} +-} + +-- h needs to be rejected, Acc cannot be erased at compile-time! +fun h : (x : Nat) -> [Acc Nat R x] -> Nat +{ h zero (acc {-.Nat .R .zero-} p) = h (succ zero) (p (succ zero) r2) +; h (succ zero) (acc {-.Nat .R .(succ zero)-} p) = h (succ (succ zero)) (p (succ (succ zero)) (r1 zero)) +; h (succ (succ y)) p = zero +} + +eval let bla : Nat + = h zero acc0 + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +-- fails, since (h zero p) does not reduce, but (h zero acc0) --> zero +fail let p1 : (p : Acc Nat R zero) -> Id Nat (h zero p) (h zero acc0) + = \ p -> refl -- Nat (h zero acc0) diff --git a/test/succeed/AppendAddSize.ma b/test/succeed/AppendAddSize.ma new file mode 100644 --- /dev/null +++ b/test/succeed/AppendAddSize.ma @@ -0,0 +1,12 @@ +-- 2010-11-01 +-- 2012-01-22 parameters gone from constructors + +sized data List (A : Set) : +Size -> Set +{ nil : [i : Size] -> List A $i +; cons : [i : Size] -> A -> List A i -> List A $i +} + +fun append : [A : Set] -> [i, j : Size] -> List A i -> List A $j -> List A (i + j) +{ append A i j (nil (i > i')) l = l +; append A i j (cons (i > i') a as) l = cons (i' + j) a (append A i' j as l) +} diff --git a/test/succeed/BelowLeInfty.ma b/test/succeed/BelowLeInfty.ma new file mode 100644 --- /dev/null +++ b/test/succeed/BelowLeInfty.ma @@ -0,0 +1,27 @@ +sized data Nat : +(i <= #) -> Set +{ zero [i <= #] : Nat $i +; succ [i <= #] (n : Nat i) : Nat $i +} + +let sib00 : ([i : Size] -> Nat i) -> ([i : Size] -> Nat i) = \ x -> x +let sib01 : ([i : Size] -> Nat i) -> ([i < #] -> Nat i) = \ x -> x +let sib11 : ([i < #] -> Nat i) -> ([i < #] -> Nat i) = \ x -> x + +fail let sib10 : ([i < #] -> Nat i) -> ([i : Size] -> Nat i) = \ x -> x + +let sub00 : ([i <= #] -> Nat i) -> ([i <= #] -> Nat i) = \ x -> x +let sub01 : ([i <= #] -> Nat i) -> ([i < #] -> Nat i) = \ x -> x +let sub11 : ([i < #] -> Nat i) -> ([i < #] -> Nat i) = \ x -> x + +fail let sub10 : ([i < #] -> Nat i) -> ([i <= #] -> Nat i) = \ x -> x + +let sub1 : ([i : Size] -> Nat i) -> ([i <= #] -> Nat i) + = \ x -> x + +let sub2 : ([i <= #] -> Nat i) -> ([i : Size] -> Nat i) + = \ x -> x + +sized data MNat : +(i <= #) -> Set +{ mzero [i : Size] : MNat $i +; msucc [i <= #] (n : MNat i) : MNat $i +} diff --git a/test/succeed/BigWrap.ma b/test/succeed/BigWrap.ma new file mode 100644 --- /dev/null +++ b/test/succeed/BigWrap.ma @@ -0,0 +1,37 @@ +-- 2010-09-20 big data type + +data BigWrap : Set 1 +{ inn : (out : Set) -> BigWrap +} + +-- 2012-10-10: automatic irrelevance analysis (forcing) +-- turns this into [A : Set] -> NotBig A +data NotBig : Set -> Set +{ notBig : (A : Set) -> NotBig A +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +data NAT : Set 1 +{ ZERO : NAT +; SUCC : NAT -> NAT +} + +fun NATnat : NAT -> Nat +{ NATnat ZERO = zero +; NATnat (SUCC n) = succ (NATnat n) +} + +-- small kind +data Exists : Set +{ inEx : [A : Set] -> (outEx : A) -> Exists +} + +-- big kind +data EXISTS : Set 1 +{ inEX : (OutType : Set) -> (outValue : OutType) -> EXISTS +} + diff --git a/test/succeed/BoundedQ.ma b/test/succeed/BoundedQ.ma new file mode 100644 --- /dev/null +++ b/test/succeed/BoundedQ.ma @@ -0,0 +1,26 @@ +-- 2010-11-12 + +{- another way to look at sized types: + +sized data Nat (i : Size) : Set +{ zero : Nat i +; succ : [j : Size] -> |j| < |i| -> Nat j -> Nat i +} + +-} +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat $i +; succ : [i : Size] -> Nat i -> Nat $i +} + +fun mySucc : [i : Size] -> [j < i] -> Nat j -> Nat i +{ mySucc i j n = succ j n } + +let boundedId [i : Size] [j <= i] (n : Nat j) : Nat j = n + +let explicitCast : [i : Size] -> [j <= i] -> Nat j -> Nat i + = \ i j n -> n + +fun explicitCast' : [i : Size] -> [j : Size] -> |j| <= |i| -> Nat j -> Nat i +{ explicitCast' i j n = n +} diff --git a/test/succeed/BuiltinSigma.ma b/test/succeed/BuiltinSigma.ma new file mode 100644 --- /dev/null +++ b/test/succeed/BuiltinSigma.ma @@ -0,0 +1,46 @@ +-- 2011-12-17 +-- non-dependent pairs + +fun fst' : (A, B : Set) -> (A & B) -> A +{ fst' A B (a, b) = a +} + +fun snd' : (A, B : Set) -> A & B -> B +{ snd' A B (a, b) = b +} + +let swap : (A, B : Set) -> A & B -> B & A + = \ A B p -> (snd' A B p, fst' A B p) + +fun reassoc' : (A, B, C : Set) -> (A & B) & C -> A & B & C +{ reassoc' A B C ((a , b) , c) = let bc : B & C = b , c in a , bc +} + +fun reassoc'' : (A, B, C : Set) -> (A & B) & C -> A & B & C +{ reassoc'' A B C ((a , b) , c) = a , b , c +} + +fun reassoc3 : (A, B, C, D : Set) -> ((A & B) & C) & D -> A & B & C & D +{ reassoc3 A B C D (((a , b) , c) , d) = a , b , c , d +} + +-- dependent pairs + +fun fst : (A : Set) -> (B : A -> Set) -> (x : A) & B x -> A +{ fst A B (a, b) = a +} + +fun snd : (A : Set) -> (B : A -> Set) -> (p : (x : A) & B x) -> B (fst A B p) +{ snd A B (a, b) = b +} + +let curry : (A : Set) -> (B : A -> Set) -> (C : (x : A) -> B x -> Set) -> + ((p : (x : A) & B x) -> C (fst A B p) (snd A B p)) -> + ((x : A) -> (y : B x) -> C x y) + = \ A B C f x y -> f (x , y) + +fun uncurry : (A : Set) -> (B : A -> Set) -> (C : (x : A) -> B x -> Set) -> + ((x : A) -> (y : B x) -> C x y) -> + (p : (x : A) & B x) -> C (fst A B p) (snd A B p) +{ uncurry A B C f (x , y) = f x y +} diff --git a/test/succeed/CoFunReturnsProduct.ma b/test/succeed/CoFunReturnsProduct.ma new file mode 100644 --- /dev/null +++ b/test/succeed/CoFunReturnsProduct.ma @@ -0,0 +1,88 @@ +-- 2010-05-20, -06-08 Andreas Abel +-- breadth-first relabeling of possibly infinite trees (Jones and Gibbons, 1993) +-- see Nils Anders Danielsson, Beating the Productivity Checker (PAR 2010, FLoC) +-- 2012-01-22 parameters gone from constructors + +data Prod (+ A : Set)(+ B : Set) : Set +{ pair : (fst : A) -> (snd : B) -> Prod A B +} fields fst, snd + +sized codata Stream (+ A : Set) : Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A ($ i) +} fields head, tail + +sized codata Tree (+ A : Set) : Size -> Set +{ leaf : [i : Size] -> Tree A ($ i) +; node : [i : Size] -> A -> Tree A i -> Tree A i -> Tree A ($ i) +} + +-- this definition is fine since the result type is a product +-- where each of its components is coinductive in i (TLCA, 2003) +cofun lab : [i : Size] -> [A : Set] -> [B : Set] -> + Tree A i -> Stream (Stream B #) i -> + Prod (Tree B i) (Stream (Stream B #) i) +{ + lab ($ i) A B (leaf {-.A-} .i) bss = + pair {- (Tree B ($ i)) (Stream (Stream B #) ($ i)) -} (leaf {-B-} i) bss + +; lab ($ i) A B (node {-.A-} .i x l r) + (cons {- .(Stream B #) -} .i (cons {-.B-} .# b bs) bss) = + + -- recursive call on left subtree + let pl : Prod (Tree B i) (Stream (Stream B #) i) + = lab i A B l bss + + -- recursive call on right subtree, threading the label stream-stream + in let pr : Prod (Tree B i) (Stream (Stream B #) i) + = lab i A B r (snd {- (Tree B i) (Stream (Stream B #) i) -} pl) + + in pair {- (Tree B ($ i)) (Stream (Stream B #) ($ i)) -} + (node {-B-} i b (fst {- (Tree B i) (Stream (Stream B #) i) -} pl) + (fst {- (Tree B i) (Stream (Stream B #) i) -} pr)) + (cons {- (Stream B #) -} i bs + (snd {- (Tree B i) (Stream (Stream B #) i) -} pr)) +} + + +-- this auxiliary function replaces the original circular program +cofun label2 : [i : Size] -> [A : Set] -> [B : Set] -> + Tree A i -> Stream B # -> Stream (Stream B #) i +{ label2 ($ i) A B t bs = snd {- (Tree B ($ i)) (Stream (Stream B #) ($ i)) -} + (lab ($ i) A B t (cons {- (Stream B #)-} i bs (label2 i A B t bs))) +} + +-- main program +fun label : [i : Size] -> [A : Set] -> [B : Set] -> + Tree A i -> Stream B # -> Tree B i +{ label i A B t bs = fst {- (Tree B i) (Stream (Stream B #) i) -} + (lab i A B t (cons {-(Stream B #)-} i bs (label2 i A B t bs))) +} + +-- testing... + +data Unit : Set +{ unit : Unit +} + +data Nat : Set +{ Z : Nat +; S : Nat -> Nat +} + +cofun nats : [i : Size] -> Nat -> Stream Nat i +{ nats ($ i) n = cons {-Nat-} i n (nats i (S n)) +} + +fun finTree : Nat -> Tree Unit # +{ finTree Z = leaf {- Unit -} # +; finTree (S n) = node {- Unit -} # unit (finTree n) (finTree n) +} + +eval let t0 : Tree Nat # = label # Unit Nat (finTree Z) (nats # Z) +eval let t1 : Tree Nat # = label # Unit Nat (finTree (S Z)) (nats # Z) +eval let t2 : Tree Nat # = label # Unit Nat (finTree (S (S Z))) (nats # Z) +eval let t3 : Tree Nat # = label # Unit Nat (finTree (S (S (S Z)))) (nats # Z) + + + + diff --git a/test/succeed/ConorMcBrideCalco09inflationary.ma b/test/succeed/ConorMcBrideCalco09inflationary.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ConorMcBrideCalco09inflationary.ma @@ -0,0 +1,88 @@ +-- 2012-02-05 Check whether we can define dependent case in MiniAgda +-- 2013-04-02 Musings on fixed-point + +let Map (F : Set -> Set) + = [A, B : Set] -> (A -> B) -> F A -> F B + +cofun Nu : (F : Set -> Set) -(i : Size) -> Set +{ Nu F i = [j < i] -> F (Nu F j) +} + +-- * we have Nu F # <==> [i < #] -> Nu F i + +cofun Inf : (G : Size -> Set) -(i : Size) -> Set +{ Inf G i = [j < i] -> G j } + +let usc [F : Set -> Set] (r : Inf (Nu F) #) : Nu F # + = r # -- uses upper semi cont + +cofun toInf : (F : Set -> Set) (r : Nu F #) -> Inf (Nu F) # +{ toInf F r i j = r j } + +-- * we also have Nu F # <==> [i <= #] -> Nu F i + +let All (G : Size -> Set) = [i : Size] -> G i + +let fromAll [F : Set -> Set] (r : All (Nu F)) : Nu F # + = r # -- trivial + +cofun toAll : (F : Set -> Set) (r : Nu F #) -> All (Nu F) +{ toAll F r i j = r j } + +-- post-fixed point +-- the reasoning usually is +-- Nu F # = Nu F $# = [j < $#] -> F (Nu F j) ==> F (Nu F #) +fail -- 2013-04-05 should work, but needs implementation +fun postfp : [F : Set -> Set] (r : Nu F #) -> F (Nu F #) +{ postfp F r = r # } + +-- destructor + +let out [F : Set -> Set] [i : Size] (r : Nu F $i) : F (Nu F i) + = r i +-- fails to typecheck #ifdef STRICTINFTY (would succeed if i<#) +-- r : [j < $i] -> F (Nu F j) +-- r i : |i| < |$i| -> F (Nu F i) + +-- constructor (needs monotonicity of F) + +check +fun inn : [F : +Set -> Set] [i : Size] -> F (Nu F i) -> Nu F $i +{ inn F i t j = t +} + +let inn [F : +Set -> Set] [i : Size] (t : F (Nu F i)) : Nu F $i + = \ j -> t + +-- coiteration +-- 2013-03-30 this must be a cofun, since not SN. +cofun coit : [F : +Set -> Set] (map : Map F) + [S : Set] (step : S -> F S) + [i : Size] -> |i| -> (start : S) -> Nu F i +{ coit F map S step i + = \ start j -> map S (Nu F j) (coit F map S step j) (step start) +} + +{- not needed (eta is built-in) +-- eta + +let eta [F : +Set -> Set] [i : Size] (r : Nu F $i) : Nu F $i + = \ j -> r j + +fun caseNu : [F : +Set -> Set] + [P : (i : Size) -> Nu F i -> Set] + (f : [i : Size] -> (t : F (Nu F i)) -> P $i (inn F i t)) + [i : Size] (x : Nu F $i) -> P $i (eta F i x) +{ caseNu F P f i x = f i (x i) +} +-} + +-- case + +let caseNu + [F : +Set -> Set] + [P : (i : Size) -> Nu F i -> Set] + (f : [i : Size] -> (t : F (Nu F i)) -> P $i (inn F i t)) + [i : Size] + (x : Nu F $i) : P $i x + = f i (x i) diff --git a/test/succeed/ConstructorTelescopes.ma b/test/succeed/ConstructorTelescopes.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ConstructorTelescopes.ma @@ -0,0 +1,19 @@ +-- 2012-01-25 parsing telescopes in constructor declarations + +data List ++(A : Set) ++(i : Size) : Set +{ nil [j < i] : List A i +; cons [j < i] (x : A) (xs : List A j) : List A i +} + +sized data SList ++(A : Set) : +Size -> Set +{ snil [i : Size] : SList A $i +; scons [i : Size] (x : A) (xs : SList A i) : SList A $i +} + +{- +sized data IList ++(A : Set) : +Size -> Set +{ inil [i <= #] : IList A $i +; icons [i <= #] (x : A) (xs : IList A i) : IList A $i +} +-} + diff --git a/test/succeed/ConstructorVeiledTarget.ma b/test/succeed/ConstructorVeiledTarget.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ConstructorVeiledTarget.ma @@ -0,0 +1,9 @@ +-- 2010-09-14 +-- 2013-04-05 This should maybe no longer enjoy support, merely obfuscating anyway + +let Id ++(A : Set) = A + +data Bool : Set +{ true : Bool +; false : Id Bool +} diff --git a/test/succeed/DataTypesNotFamilies.ma b/test/succeed/DataTypesNotFamilies.ma new file mode 100644 --- /dev/null +++ b/test/succeed/DataTypesNotFamilies.ma @@ -0,0 +1,13 @@ +-- 2012-01-26 omitting types in data type (not family) definitions + +data Bool : Set { true ; false } + +data List ++(A : Set) : Set +{ nil ; cons (head : A) (tail : List A) +} + +record Prod ++(A, B : Set) : Set +{ pair (fst : A) (snd : B) +} fields fst, snd + +fail data Id (a : Bool) : Bool -> Set { refl } diff --git a/test/succeed/DeepMatch.ma b/test/succeed/DeepMatch.ma new file mode 100644 --- /dev/null +++ b/test/succeed/DeepMatch.ma @@ -0,0 +1,16 @@ + +data Nat : Set +{ Z : Nat +; S : Nat -> Nat +} + +fun plus : Nat -> Nat -> Nat +{ plus Z m = m +; plus (S n) m = S (plus n m) +} + +fun fib : Nat -> Nat +{ fib Z = S Z +; fib (S Z) = S Z +; fib (S (S n)) = plus (fib n) (fib (S n)) +} diff --git a/test/succeed/DescendAscendTerm.ma b/test/succeed/DescendAscendTerm.ma new file mode 100644 --- /dev/null +++ b/test/succeed/DescendAscendTerm.ma @@ -0,0 +1,17 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun plus : Nat -> Nat -> Nat {} + +mutual { + + fun f : Nat -> Nat + { f (succ (succ (succ n))) = g n n + } + + fun g : Nat -> Nat -> Nat + { g (succ n) m = plus (g n (succ m)) (f n) + } +} diff --git a/test/succeed/DotPatternNotLeftToRightBinding.ma b/test/succeed/DotPatternNotLeftToRightBinding.ma new file mode 100644 --- /dev/null +++ b/test/succeed/DotPatternNotLeftToRightBinding.ma @@ -0,0 +1,55 @@ +-- 2010-09-22 +-- 2012-01-22 parameters gone from constructors + +fun A : Set {} +fun B : Set {} +fun f : A -> A {} + +data Fix *(a : A) : A -> Set +{ fix : Fix a (f a) +} + +-- eta not definable unconditionally (like for Id) +fun eta : (a, b : A) -> Fix a b -> Fix a b +{ eta a .(f a) (fix) = fix +} + +-- variable a used in dot pattern left of its binding +fun bla : (b, a : A) -> Fix a b -> A +{ bla .(f a) a (fix) = a +} + +-- Function inverse + +data Inv (g : A -> B) : B -> Set +{ mkInv : (getInv : A) -> Inv g (g getInv) +} +-- MiniAgda does not generate destructor getInv + +fun getInv : (g : A -> B) -> (b : B) -> Inv g b -> A + { getInv g .(g a) (mkInv a) = a + } + +{- Analysis: + + mkInv : (getInv : A) -> Inv g b where b = (g getInv) + +bind b in destructor type after parameters + + getInv : (g : A -> B) -> (b : B) -> Inv g b -> A + +put its value (g a) down as dot-pattern instead of b + + getInv g .(g a) (mkInv .g a) = a + +-} + +{- +data Id (A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +fun f : (A : Set) -> (c : A -> A) -> (a : A) -> (b : A) -> Id A (c b) b -> A +{ f A c .(c b) b (refl .A .b) = b +} +-} diff --git a/test/succeed/DottedConstructors.ma b/test/succeed/DottedConstructors.ma new file mode 100644 --- /dev/null +++ b/test/succeed/DottedConstructors.ma @@ -0,0 +1,127 @@ +-- 2013-04-08 Dotted constructors + +data Unit { unit } + +data Nat { zero ; suc (n : Nat) } + +fun plus : Nat -> Nat -> Nat +{ plus zero m = m +; plus (suc n) m = suc (plus n m) +} + +data List ++(A : Set) { nil ; cons (x : A) (xs : List A) } + +data Vec ++(A : Set) (n : Nat) +{ vnil : Vec A zero +; vcons (vhead : A) (vtail : Vec A n) : Vec A (suc n) +} fields vhead, vtail + +fun append : [A : Set] [n : Nat] [m : Nat] -> Vec A n -> Vec A m -> Vec A (plus n m) +{ append A .zero m vnil ys = ys +; append A (.suc n) m (vcons x xs) ys = vcons x (append A n m xs ys) +} + +data Fin (n : Nat) +{ fzero : Fin (suc n) +; fsuc (i : Fin n) : Fin (suc n) +} + +fun lookup : [A : Set] [n : Nat] (i : Fin n) (xs : Vec A n) -> A +{ lookup A .zero () vnil +; lookup A (.suc n) fzero (.vcons x xs) = x +; lookup A (.suc n) (fsuc i) (.vcons x xs) = lookup A n i xs +} + +{- untyped terms + +data Tm (n : Nat) +{ var (x : Fin n) +; app (r, s : Tm n) +; abs (t : Tm (suc n)) +} + +let Subst (n, m : Nat) = Vec (Tm m) n + +fun liftSubst : (n : Nat) [m : Nat] -> Subst n m -> Subst (suc n) (suc m) +{} + +fun subst : (n : Nat) [m : Nat] -> Tm n -> Subst n m -> Tm m +{ subst n m (var i) rho = lookup (Tm m) n i rho +; subst n m (app r s) rho = app (subst n m r rho) (subst n m s rho) +; subst n m (abs t) rho = abs (subst (suc n) (suc m) t (liftSubst n m rho)) +} +-} + +data Ty { nat ; arr (a, b : Ty) } + +let Cxt = List Ty + +data Var (cxt : Cxt) (a : Ty) +{ vzero : Var (cons a cxt) a +; vsuc (x : Var cxt b) : Var (cons a cxt) b +} + +data Tm (cxt : Cxt) (a : Ty) + +{ var (x : Var cxt a) : Tm cxt a + +; app [a : Ty] + (r : Tm cxt (arr a b)) + (s : Tm cxt a) : Tm cxt b + +; abs (t : Tm (cons a cxt) b) : Tm cxt (arr a b) +} + +fun Sem : Ty -> Set +{ Sem nat = Nat +; Sem (arr a b) = Sem a -> Sem b +} + +fun Env : Cxt -> Set +{ Env nil = Unit +; Env (cons a as) = Sem a & Env as +} + +fun val : [cxt : Cxt] [a : Ty] -> Var cxt a -> Env cxt -> Sem a +{ val (.cons a cxt) .a vzero (v, vs) = v +; val (.cons a cxt) b (vsuc x) (v, vs) = val cxt b x vs +} + +fun sem : [cxt : Cxt] [a : Ty] -> Tm cxt a -> Env cxt -> Sem a +{ sem cxt a (var x) rho = val cxt a x rho +; sem cxt b (app a r s) rho = (sem cxt (arr a b) r rho) (sem cxt a s rho) +; sem cxt (.arr a b) (abs t) rho v = sem (cons a cxt) b t (v, rho) +} + + + +{- How to check a data constructor + +Case 1: no target given, e.g. + + cons (x : A) (xs : List A) + + Bring the parameters of the data telescope into scope, then + check constructor telescope + +Case 2: target given, e.g. + + vcons (vhead : A) (vtail : Vec A n) : Vec A (suc n) + + Take the parameters off the target, treat them like patterns, + and check them against the data telecope (or type of data name). + We get out a context + + A : Set + n : Nat + + use this context to check full type of constructor. + Also, check that no binding in constructor type shadows the + pattern variables of the target (would be confusing). + In the end, prepend the context to the constructor type. + +Case 3: target is function type. + + Extract final target and proceed as in 2. + +-} diff --git a/test/succeed/DottedPatSyn.ma b/test/succeed/DottedPatSyn.ma new file mode 100644 --- /dev/null +++ b/test/succeed/DottedPatSyn.ma @@ -0,0 +1,15 @@ +-- 2013-04-08 + +data Bool { false ; true } +data Maybe (A : Set) { nothing ; just (fromJust : A) } + +let Three = Maybe Bool +pattern one = nothing +pattern two = just false +pattern three = just true + +data D (b : Three) +{ c : D three } + +fun f : [b : Three] -> D b -> Set 1 +{ f .three c = Set } diff --git a/test/succeed/Empty.ma b/test/succeed/Empty.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Empty.ma @@ -0,0 +1,34 @@ +-- 2012-01-28 the empty type as least type + +data Empty {} + +let abort [A : Set] (x : Empty) : A = x + +let abort1 [A : Set] (x : Empty) : A -> A = x +let abort2 [F : +Set -> Set] [A : Set] (x : F Empty) : F A = x + +let toEmp [A, B : Set] (x : A -> B) : Empty -> B = x + +data Unit { unit } + +let abort3 (x : Empty) : Unit = x +-- let abort4 (x : Empty) : |0| < |0| -> Unit = x -- constraint disallowed here +let abort5 (x : Empty) : [i < 0] -> Unit = x + +-- unit type as the biggest type + +data Bool { true; false } + +fun f : Bool -> Unit +{ f x = x +} + +let noReturnNeeded [M : +Set -> Set] [A : Set] (x : M A) : M Unit + = x + +fun g : Unit -> Bool +{ g unit = true -- this should translate into a variable pattern +} + +let test [T : Bool -> Set] (x : T (g unit)) : T true + = x diff --git a/test/succeed/EvalBoveCaprettaNotSized.ma b/test/succeed/EvalBoveCaprettaNotSized.ma new file mode 100644 --- /dev/null +++ b/test/succeed/EvalBoveCaprettaNotSized.ma @@ -0,0 +1,93 @@ +-- 2009-11-29 A partial normalizer for untyped lambda calculus in MiniAgda +-- 2012-01-22 parameters gone from constructors + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +data List (+A : Set) : Set +{ nil : List A +; cons : A -> List A -> List A +} + +-- de Bruijn terms + +data Exp : Set +{ var : Nat -> Exp +; abs : Exp -> Exp +; app : Exp -> Exp -> Exp +} + +-- set of values + +data D : Set +{ clos : Exp -> (List D) -> D +} + +-- environment operations + +let Env : Set + = List D + +let empty : Env + = nil + +let update : Env -> D -> Env + = \ rho -> \ d -> cons d rho + +let dummy : D + = clos (var zero) empty + +fun lookup : Env -> Nat -> D +{ lookup (nil) n = dummy +; lookup (cons d rho) zero = d +; lookup (cons d rho) (succ n) = lookup rho n +} + +-- inductive graph of the evaluation function + +data Eval : Exp -> Env -> D -> Set +{ evVar : [k : Nat] -> [rho : Env] -> + + ------------------------------- + Eval (var k) rho (lookup rho k) + +; evAbs : [e : Exp] -> [rho : Env] -> + + ----------------------------- + Eval (abs e) rho (clos e rho) + +; evApp : [f : Exp] -> [e : Exp] -> [rho : Env] -> + (evldFun : Exp) -> (evldEnv : Env) -> (evldArg : D) -> [d' : D] -> + + (theFun : Eval f rho (clos evldFun evldEnv)) -> + (theArg : Eval e rho evldArg) -> + (theApp : Eval evldFun (update evldEnv evldArg) d') -> + ----------------------------- + Eval (app f e) rho d' +} + +-- evaluation as a partial function +{- after erasure, the function takes the form + + evaluate : Exp -> Env -> D +-} + +mutual { + + fun evaluate : (e : Exp) -> (rho : Env) -> + [d : D] -> [Eval e rho d] -> + { evaluate (var k) rho .(lookup rho k) (evVar .k .rho) = lookup rho k + ; evaluate (abs e) rho .(clos e rho) (evAbs .e .rho) = clos e rho + ; evaluate (app f e) rho .d' (evApp .f .e .rho f' rho' d d' evF evE evF') + = apply f' rho' (evaluate f rho (clos f' rho') evF) + (evaluate e rho d evE) d' evF' + } + + fun apply : [f' : Exp] -> [rho' : Env] -> -> + (d : D) -> [d' : D] -> [Eval f' (update rho' d) d'] -> + { apply .f' .rho' (clos f' rho') d d' p = evaluate f' (update rho' d) d' p + } +} + diff --git a/test/succeed/EvenOdd.ma b/test/succeed/EvenOdd.ma new file mode 100644 --- /dev/null +++ b/test/succeed/EvenOdd.ma @@ -0,0 +1,31 @@ +-- 2010-08-28 mutual data types + +mutual { + + data Even : Set + { ev0 : Even + ; evS : Odd -> Even + } + + data Odd : Set + { oddS : Even -> Odd + } + +} + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +mutual { + + fun evenToNat : Even -> Nat + { evenToNat ev0 = zero + ; evenToNat (evS o) = suc (oddToNat o) + } + + fun oddToNat : Odd -> Nat + { oddToNat (oddS e) = suc (evenToNat e) + } +} diff --git a/test/succeed/Evens.ma b/test/succeed/Evens.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Evens.ma @@ -0,0 +1,18 @@ +-- 2010-11-01 +-- 2012-01-22 parameters gone from constructors + +sized codata Stream ++(A : Set) : -Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A $i +} + +-- suggested by Florent Balestrini +cofun evens : [A : Set] -> [i : Size] -> Stream A (i + i) -> Stream A i +{ evens A ($i) (cons .(i + i + 1) a (cons .(i + i) b as)) = + cons i a (evens A i as) +} + +cofun map2 : [A, B : Set] -> (A -> B) -> + [i : Size] -> Stream A (2 * i) -> Stream B (2 * i) +{ map2 A B f ($ i) (cons .$(2 * i) a1 (cons .(2 * i) a2 as)) = + cons $(2 * i) (f a1) (cons (2 * i) (f a2) (map2 A B f i as)) +} diff --git a/test/succeed/ExtractLets.ma b/test/succeed/ExtractLets.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ExtractLets.ma @@ -0,0 +1,15 @@ +-- 2010-10-04 extract let definitions + +-- the polymorphic identity + +let id : [A : Set] -> A -> A + = \ A x -> x + +let s : [A, B, C : Set] -> (A -> B -> C) -> (A -> B) -> A -> C + = \ A B C x y z -> x z (y z) + +let k : [A, B : Set] -> A -> B -> A + = \ A B x y -> x + +let skk : [A : Set] -> A -> A + = \ A -> s A (A -> A) A (k A (A -> A)) (k A A) diff --git a/test/succeed/FakeMutual.ma b/test/succeed/FakeMutual.ma new file mode 100644 --- /dev/null +++ b/test/succeed/FakeMutual.ma @@ -0,0 +1,47 @@ +-- 2010-08-28 fake mutuals, to test positivity checker + +-- real mutuals + +mutual { + data E : Set { e0 : E + ; eS : O -> E } + data O : Set { oS : E -> O } +} + +mutual { + data D1 : Set { d1 : D2 -> D1 } -- D1 / D2 ++ D3 / + data D2 : Set { d2 : D3 -> D2 } -- D1 / D2 / D3 ++ + data D3 : Set { d3 : D1 -> D3 } -- D1 ++ D2 / D3 / + {- to see that D1 is spos, we have to traverse the calls through D2 and D3 -} +} + +-- fake mutuals + +mutual { + + -- A is spos in its def. + data A : Set + { a1 : A + ; a2 : A -> A + } + + -- but not in B + data B : Set + { b1 : B + ; b2 : (A -> B) -> B + } +} + +mutual { + + -- D is spos in its definition + data D : Set + { c : D + ; d : D -> D + } + -- D is not spos in T + fun T : Set -> Set + { T X = D -> X + } + +} diff --git a/test/succeed/Fields.ma b/test/succeed/Fields.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Fields.ma @@ -0,0 +1,19 @@ +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +fun f : Nat -> Nat +{} + +-- 2010-09-03 currently, MiniAgda parses "index" as an index +-- but it is not computable from D A (f index) +data D ++(A : Nat -> Set) : Nat -> Set +{ mkD : (index : Nat) -> (content : A index) -> D A (f index) +} + +{- generates +fun content : [A : Nat -> Set] -> (index : Nat) -> (d : D A (_f index)) -> A index +{ content A index (mkD .A .index c) = c +} +-} diff --git a/test/succeed/FinBranchMutual.ma b/test/succeed/FinBranchMutual.ma new file mode 100644 --- /dev/null +++ b/test/succeed/FinBranchMutual.ma @@ -0,0 +1,25 @@ +-- 2010-08-28 + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data Unit : Set { unit : Unit } + +data Prod ++(A, B : Set) : Set +{ pair : (fst : A) -> (snd : B) -> Prod A B +} + +mutual { + + data Tree : Set + { node : (numBranches : Nat) -> VecTree numBranches -> Tree + } + + fun VecTree : Nat -> Set + { VecTree zero = Unit + ; VecTree (suc n) = Prod Tree (VecTree n) + } + +} diff --git a/test/succeed/Fix.ma b/test/succeed/Fix.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Fix.ma @@ -0,0 +1,7 @@ +-- 2012-01-27 fix-point principle + +fun fix : [A : Size -> Set] -> + (f : [i : Size] -> ([j < i] -> A j) -> A i) -> + [i : Size] -> |i| -> A i +{ fix A f i = f i (fix A f) +} diff --git a/test/succeed/ForceInConType.ma b/test/succeed/ForceInConType.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ForceInConType.ma @@ -0,0 +1,28 @@ +-- 2012-02-24, reported by Nisse + +data Id ++(A : Set) (x : A) : A -> Set +{ refl : Id A x x +} + +data Either ++(A, B : Set) : Set +{ left : A -> Either A B +; right : B -> Either A B +} + +cofun P : ++(A : Set) -> Set +{ P A = Either A A +} + +fun Foo : ++(A : Set) -> P A -> Set +{ Foo A x = (z : A) & Id (P A) x (left z) +} + +fun foo : ++(A : Set) -> (x : P A) -> Foo A x +{ foo A (left x) = (x, refl) +} + +-- leqVal' [(x,1),(A,0)] |- left x <=^ left x : P A +-- conType left: expected P A to be a data type + +-- P is a cofun (and in my original code it is actually corecursive). Is +-- MiniAgda too lazy here? diff --git a/test/succeed/ForcedMatch.ma b/test/succeed/ForcedMatch.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ForcedMatch.ma @@ -0,0 +1,15 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data D : Bool -> Bool -> Set +{ d00 : D false false +; d01 : D false true +; d11 : D true true +} + +fun f : (b : Bool) -> [D b b] -> Bool +{ f false d00 = false +; f true d11 = true +} diff --git a/test/succeed/ForcedMatchIdType.ma b/test/succeed/ForcedMatchIdType.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ForcedMatchIdType.ma @@ -0,0 +1,35 @@ +-- 2012-01-22 parameters gone from constructors + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +fun subst : [A : Set] -> [a : A] -> [b : A] -> [Id A a b] -> + [P : A -> Set] -> P a -> P b +{ subst A a .a refl P h = h +} + + +{- This is ok, due to the eta-expansion at identity type + + since p -->eta refl A a + both sides reduce and, hence, equality can be shown. + + However, at compile time, the matching against refl cannot be removed, + because of the non-linearity of subst! +-} + +let p1 : [A : Set] -> [a : A] -> [p : Id A a a] -> + [P : A -> Set] -> (h : P a) -> + Id (P a) (subst A a a p P h) (subst A a a refl P h) + = \ A a p P h -> refl + +let p2 [A : Set] [a : A] [p : Id A a a] [P : A -> Set] (h : P a) : + Id (P a) (subst A a a p P h) h + = refl + +-- this one is uncontroversial: +let p3 : [A : Set] -> [a, b : A] -> [p, q : Id A a b] -> + [P : A -> Set] -> (h : P a) -> + Id (P b) (subst A a b p P h) (subst A a b q P h) + = \ A -> \ a b -> \ p q -> \ P -> \ h -> refl -- (P b) (subst A a b p P h) diff --git a/test/succeed/ForestRose.ma b/test/succeed/ForestRose.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ForestRose.ma @@ -0,0 +1,19 @@ +-- 2010-09-01 + +data List ++(A : Set) : Set +{ nil : List A +; cons : A -> List A -> List A +} + +mutual { + + data Rose ++ (A : Set) : Set + { rose : (label : A) -> (subtrees : Forest A) -> Rose A + } + + fun Forest : ++ Set -> Set + { Forest A = List (Rose A) + } + +} + diff --git a/test/succeed/GADT.ma b/test/succeed/GADT.ma new file mode 100644 --- /dev/null +++ b/test/succeed/GADT.ma @@ -0,0 +1,21 @@ +-- 2010-10-03 + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data Pair (A, B : Set) : Set +{ pair : A -> B -> Pair A B +} + +data Exp : Set -> Set 1 +{ nat : Nat -> Exp Nat +; bool : Bool -> Exp Bool +; tup : (A, B : Set) -> Pair A B -> Exp (Pair A B) +} diff --git a/test/succeed/GoodConstraint.ma b/test/succeed/GoodConstraint.ma new file mode 100644 --- /dev/null +++ b/test/succeed/GoodConstraint.ma @@ -0,0 +1,6 @@ +-- 2013-03-30 constraints must follow quantifier +check +fun f : [A : Set] -> ([i : Size] -> |i| < |i| -> A) -> A {} + +check +fun f : [A : Set] -> ([i : Size] -> |i| < |i| -> |i| < |i| -> A) -> A {} diff --git a/test/succeed/HEq.ma b/test/succeed/HEq.ma new file mode 100644 --- /dev/null +++ b/test/succeed/HEq.ma @@ -0,0 +1,8 @@ +data HEq [A : Set](a : A) : [B : Set] -> B -> Set +{ refl : HEq A a A a +} + +data HEq' [i : Size][A : Set i](a : A) : [B : Set i] -> B -> Set +{ refl' : HEq' i A a A a +} + diff --git a/test/succeed/HVec.ma b/test/succeed/HVec.ma new file mode 100644 --- /dev/null +++ b/test/succeed/HVec.ma @@ -0,0 +1,31 @@ +-- 2010-06-30 heterogeneous vectors +-- 2012-01-22 parameters gone from constructors + +data Unit : Set { unit : Unit } + +data Prod [i : Size] (A : Set i) (B : Set i) : Set i +--{ pair : A -> B -> Prod i A B +{ pair : (fst : A) -> (snd : B) -> Prod i A B +} + +fun fst' : [i : Size] -> [A : Set i] -> [B : Set i] -> Prod i A B -> A +{ fst' i A B (pair a b) = a +} + +data List [i : Size] (A : Set i) : Set i +{ nil : List i A +; cons : A -> List i A -> List i A +} + +-- recursive heterogeneous vectors +fun HVecR : List 1 Set -> Set +{ HVecR (nil) = Unit +; HVecR (cons A As) = Prod 0 A (HVecR As) +} + +-- inductive heterogeneous vectors +data HVec : List 1 Set -> Set 1 +{ vnil : HVec (nil) +; vcons : [A : Set] -> [As : List 1 Set] -> + A -> HVec As -> HVec (cons A As) +} diff --git a/test/succeed/HungryEtaRecord.ma b/test/succeed/HungryEtaRecord.ma new file mode 100644 --- /dev/null +++ b/test/succeed/HungryEtaRecord.ma @@ -0,0 +1,14 @@ +-- 2012-02-07 + +-- a recursive unit type +-- 2013-03-30 must be a cofun since not SN +cofun Hungry : -(i : Size) -> Set +{ Hungry i = [j < i] -> Hungry j +} + +fun D : [i : Size] -> Hungry i -> Set {} + +-- Don't try this at home! +-- let unique [i : Size] (x, y : Hungry i) (d : D i x) : D i y = d +-- loops! because of infinite eta-expansion performed in equality testing +-- similar to recursive record problem diff --git a/test/succeed/IdTypePos.ma b/test/succeed/IdTypePos.ma new file mode 100644 --- /dev/null +++ b/test/succeed/IdTypePos.ma @@ -0,0 +1,9 @@ +-- 2010-06-20 + +data Id ++(A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +data Exists (A : Set) ++(P : A -> Set) : Set +{ exI : (witness : A) -> (proof : P witness) -> Exists A P +} diff --git a/test/succeed/IrrHeterogeneousFun.ma b/test/succeed/IrrHeterogeneousFun.ma new file mode 100644 --- /dev/null +++ b/test/succeed/IrrHeterogeneousFun.ma @@ -0,0 +1,37 @@ +-- 2010-10-01 + +-- an example with different types in context during eq. checking +-- derived from Ulf's counterexample + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun T : Bool -> Set +{ T true = Nat +; T false = Bool +} + +fun good : + [F : Nat -> Set] -> + [f : [b : Bool] -> ([T b] -> Nat) -> Nat] -> + (g : (n : Nat) -> F (f true (\ x -> n))) -> + (h : F (f false (\ x -> zero)) -> Bool) -> + Bool +{ good F f g h = h (g zero) +} + +let good' : + [F : [b : Bool] -> ([T b] -> Nat) -> Set] -> + (g : F false (\ x -> zero) -> Bool) -> + (h : (n : Nat) -> F true (\ x -> n)) -> + Bool + = \ F g h -> g (h zero) + + diff --git a/test/succeed/IrrHeterogeneousSingleton.ma b/test/succeed/IrrHeterogeneousSingleton.ma new file mode 100644 --- /dev/null +++ b/test/succeed/IrrHeterogeneousSingleton.ma @@ -0,0 +1,33 @@ +-- 2010-10-01 +-- Should heterogeneous equality x : ?= a : A +-- succeed? I'd say yes! + +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun T : Bool -> Set +{ T true = Nat +; T false = +} + +fun good : + [F : Nat -> Set] -> + [f : [x : Bool] -> T x -> Nat] -> + (z : T false) -> + (g : (n : Nat) -> F (f true n)) -> + (h : F (f false z) -> Bool) -> + Bool +{ good F f z g h = h (g zero) +} + +{- f true zero ?= f false z : Nat + zero : Nat ?= z : +-} + diff --git a/test/succeed/IrrHeterogeneousSize.ma b/test/succeed/IrrHeterogeneousSize.ma new file mode 100644 --- /dev/null +++ b/test/succeed/IrrHeterogeneousSize.ma @@ -0,0 +1,22 @@ +-- 2010-10-01 +-- zero # : Nat # ?= zero i : Nat $i succeeds +-- even though Nat # /= Nat $i + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat $i +; succ : [i : Size] -> Nat i -> Nat $i +} + +fun good : + [Size] -> + [f : [i : Size] -> Nat i -> Set] -> + (g : [i : Size] -> (n : Nat i) -> f i n) -> + (h : f # (zero #) -> Set) -> + Set +{ good i f g h = h (g $i (zero i)) +} + +{- f # (zero #) : Set >= f $i (zero i) : Set + zero # : Nat # ?= zero i : Nat $i +-} + diff --git a/test/succeed/LargeElim.ma b/test/succeed/LargeElim.ma new file mode 100644 --- /dev/null +++ b/test/succeed/LargeElim.ma @@ -0,0 +1,28 @@ +-- 2010-10-16 + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ add zero n = n +; add (succ m) n = succ (add m n) +} + +fun Sum : Nat -> Set +{ Sum zero = Nat +; Sum (succ n) = Nat -> Sum n +} + +fun sum : (n : Nat) -> Nat -> Sum n +{ sum zero x = x +; sum (succ n) x = \ y -> sum n (add x y) +} + +let one : Nat = succ zero +let two : Nat = succ one +let three : Nat = succ two +let four : Nat = succ three + +eval let six : Nat = sum four three two one zero zero diff --git a/test/succeed/LetTele.ma b/test/succeed/LetTele.ma new file mode 100644 --- /dev/null +++ b/test/succeed/LetTele.ma @@ -0,0 +1,19 @@ +-- 2012-01-24 telescopes for let + +let id0 : [i : Size] -> [A : Set i] -> (a : A) -> A + = \ i A a -> a + +let id [i : Size][A : Set i](a : A) : A = a + +-- 2012-01-26 let and local let without type + +let id' [i : Size][A : Set i](a : A) = a + +let two [A : Set] (f : A -> A) (x : A) : A = + let y = f x + in f y + +let two' : [A : Set] -> (f : A -> A) -> (x : A) -> A = + \ A f x -> + let y = f x + in f y diff --git a/test/succeed/LowerSemiCont.ma b/test/succeed/LowerSemiCont.ma new file mode 100644 --- /dev/null +++ b/test/succeed/LowerSemiCont.ma @@ -0,0 +1,61 @@ +-- If F is anitone, then it is lower semi-continuous + +cofun sup : (F : Size -> Set) +(i : Size) -> Set +{ sup F i = [j < i] & F j } + +let pairF [F : -Size -> Set] (a : F #) : sup F # + = (#, a) + +-- [j < i] & F j is lower semi in i +let supsup [F : Size -> Set] (a : sup F #) : sup (sup F) # + = (#, a) + +cofun bsup : (F : Size -> Set) +(i : Size) -> Set +{ bsup F i = [j <= i] & F j } + +-- [j <= i] & F j is lower semi in i if F i +let bsupsup [F : Size -> Set] (a : sup F #) : bsup (sup F) # + = (#, a) + +sized data SNat : +Size -> Set +{ szero : [i : Size] -> SNat $i +; ssuc : [i : Size] -> SNat i -> SNat $i +} + +let pairSNat (a : SNat #) : [j < #] & SNat j + = (#, a) + +let pairSNat2 (a : SNat #) : [j < #] & SNat j & SNat j + = (#, a, a) + +data Fork ++(A : Set) +{ fork (fst : A) (snd : A) +} fields fst, snd + +-- tuples of lsc things are lsc +let forkSNat (a : SNat #) : [j < #] & Fork (SNat j) + = (#, fork a a) + +data Maybe ++(A : Set) +{ nothing +; just (fromJust : A) +} fields fromJust + +let maybeSNat (a : SNat #) : [j < #] & Maybe (SNat j) + = (#, just a) + +data List ++(A : Set) +{ nil +; cons (x : A)(xs : List A) +} + +fail -- inductive types preserve lcs, but not supported yet +let listSNat (a : SNat #) : [j < #] & List (SNat j) + = (#, cons a nil) + +data Nat +(i : Size) : Set +{ zero : Nat i +; suc : (jn : [j < i] & Nat j) -> Nat i +} + +let one : Nat # = suc (#,zero) diff --git a/test/succeed/Makefile b/test/succeed/Makefile new file mode 100644 --- /dev/null +++ b/test/succeed/Makefile @@ -0,0 +1,22 @@ +# MiniAgda +# Makefile for successful tests +# Authors: Andreas Abel, Ulf Norell +# Created: 2004-12-03, 2008-09-03 + +mugda = ../../Main + +# Getting all miniagda files +allagda=$(patsubst %.ma,%,$(shell find . -name "*.ma")) + +all : $(allagda) + +$(allagda) : % : %.ma + @echo "----------------------------------------------------------------------" + @echo $< + @echo "----------------------------------------------------------------------" + @$(mugda) $< + +clean : + -rm *~ + +#EOF diff --git a/test/succeed/MeasureInFunTele.ma b/test/succeed/MeasureInFunTele.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MeasureInFunTele.ma @@ -0,0 +1,10 @@ +-- 2012-02-22 + +cofun T : -(i : Size)|i| -> Set +{ T i = [j < i] -> T j +} + +fun bla : [i : Size] |i| -> T i +{ bla i = bla +} +-- should succeed diff --git a/test/succeed/MeasuredHerSubst1.ma b/test/succeed/MeasuredHerSubst1.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MeasuredHerSubst1.ma @@ -0,0 +1,108 @@ +-- 2010-07-27 Implementation of JFP-paper +-- Implementing a Normalizer Using Heterogeneous Sized Types +-- Version with subst/simsubst/normApp mutual + +-- 2012-01-22 parameters gone from constructors + +data Maybe (A : Set) : Set +{ nothing : Maybe A +; just : A -> Maybe A +} + +let just_ : [A : Set] -> A -> Maybe A = \ A a -> just a + +fun mapMaybe : [A, B : Set] -> (A -> B) -> Maybe A -> Maybe B +{ mapMaybe A B f (nothing) = nothing +; mapMaybe A B f (just a) = just (f a) +} + +sized data Ty : Size -> Set +{ base : [i : Size] -> Ty $i +; arr : [i : Size] -> Ty i -> Ty i -> Ty $i +} + +sized data Tm (A : Set) : Size -> Set +{ var : [i : Size] -> A -> Tm A $i +; app : [i : Size] -> Tm A i -> Tm A i -> Tm A $i +; abs : [i : Size] -> Ty # -> Tm (Maybe A) i -> Tm A $i +} + +fun mapTm : [A, B : Set] -> [i : Size] -> |i| -> (A -> B) -> Tm A i -> Tm B i +{ mapTm A B i f (var (i > j) x) = var j (f x) +; mapTm A B i f (app (i > j) r s) = app j (mapTm A B j f r) (mapTm A B j f s) +; mapTm A B i f (abs (i > j) a r) = + abs j a (mapTm (Maybe A) (Maybe B) j (mapMaybe A B f) r) +} + +let shiftTm : [A : Set] -> [i : Size] -> Tm A i -> Tm (Maybe A) i + = \ A i t -> mapTm A (Maybe A) i (just_ A) t + +-- result of substitution is carrying a type or not +data Res (A : Set) +(i : Size) : Set +{ ne : Tm A # -> Res A i +; nf : Tm A # -> Ty i -> Res A i +} + +fun tm : [A : Set] -> [i : Size] -> Res A i -> Tm A # +{ tm A i (ne t) = t +; tm A i (nf t a) = t +} + +fun shiftRes : [A : Set] -> [i : Size] -> Res A i -> Res (Maybe A) i +{ shiftRes A i (ne t) = ne (shiftTm A # t) +; shiftRes A i (nf t a) = nf (shiftTm A # t) a +} + +-- construct results without type information +let varRes : [A : Set] -> [i : Size] -> A -> Res A i + = \ A i x -> ne (var # x) + +let absRes : [A : Set] -> [i : Size] -> Ty # -> Res (Maybe A) # -> Res A i + = \ A i a r -> ne (abs # a (tm (Maybe A) # r)) + +let appRes : [A : Set] -> [i : Size] -> Res A # -> Res A # -> Res A i + = \ A i t u -> ne (app # (tm A # t) (tm A # u)) + +-- environments (in paper: Val) + +let Env : Set -> Set -> Size -> Set + = \ A B i -> A -> Res B i + +fun sg : [A : Set] -> [i : Size] -> Tm A # -> Ty i -> Env (Maybe A) A i +{ sg A i s a (nothing) = nf s a +; sg A i s a (just y) = varRes A i y +} + +fun lift : [A, B : Set] -> [i : Size] -> Env A B i -> Env (Maybe A) (Maybe B) i +{ lift A B i rho (nothing) = varRes (Maybe B) i (nothing) +; lift A B i rho (just x) = shiftRes B i (rho x) +} + +-- hereditary substitution + +mutual { + +fun subst : [i : Size] -> |i,$$0,#| -> Ty i -> + [A : Set] -> Tm A # -> Tm (Maybe A) # -> Tm A # +{ subst i a A s t = tm A i (simsubst i # (Maybe A) A t (sg A i s a)) +} + +fun simsubst : [i, j : Size] -> |i,$0,j| -> + [A, B : Set] -> Tm A j -> Env A B i -> Res B i +{ simsubst i j A B (var (j > j') x) rho = rho x +; simsubst i j A B (abs (j > j') b t) rho = + absRes B i b (simsubst i j' (Maybe A) (Maybe B) t (lift A B i rho)) +; simsubst i j A B (app (j > j') t u) rho = + let t' : Res B i = simsubst i j' A B t rho in + let u' : Res B i = simsubst i j' A B u rho in + normApp i B t' u' +} + +fun normApp : [i : Size] -> |i,0,#| -> + [B : Set] -> Res B i -> Res B i -> Res B i +{ normApp i B (nf (abs .# b' r') (arr (i > i') b c)) u' = + nf (subst i' b B (tm B i u') r') c +; normApp i B t' u' = appRes B i t' u' +} + +} diff --git a/test/succeed/MeasuredRose.ma b/test/succeed/MeasuredRose.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MeasuredRose.ma @@ -0,0 +1,31 @@ +-- 2010-07-27 +-- 2012-01-22 parameters gone from constructors + +data List (+ A : Set) : Set +{ nil : List A +; cons : A -> List A -> List A +} + +fun mapList : [A : Set] -> [B : Set] -> (A -> B) -> List A -> List B +{ mapList A B f (nil) = nil +; mapList A B f (cons a as) = cons (f a) (mapList A B f as) +} + +-- sized Roses + +sized data Rose (+ A : Set) : Size -> Set +{ rose : [i : Size] -> A -> List (Rose A i) -> Rose A ($ i) +} + +fun mapRose : [A : Set] -> [B : Set] -> (A -> B) -> + [i : Size] -> |i| -> Rose A i -> Rose B i +{ mapRose A B f i (rose (i > j) a rs) = + rose j (f a) (mapList (Rose A j) (Rose B j) (mapRose A B f j) rs) +} + +-- 2012-01-27 it is also possible to place the measure after the rec.arg. +fun mapRose' : [A : Set] -> [B : Set] -> (A -> B) -> + [i : Size] -> Rose A i -> |i| -> Rose B i +{ mapRose' A B f i (rose (i > j) a rs) = + rose j (f a) (mapList (Rose A j) (Rose B j) (mapRose' A B f j) rs) +} diff --git a/test/succeed/MergeWith.ma b/test/succeed/MergeWith.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MergeWith.ma @@ -0,0 +1,29 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data List : Set +{ nil : List +; cons : Nat -> List -> List +} + +fun leq : Nat -> Nat -> Bool {} + +-- merge as would be represented with "with" in Agda +mutual { + fun merge : List -> List -> List + { merge nil l = l + ; merge l nil = l + ; merge (cons x xs) (cons y ys) = merge_aux x xs (cons x xs) y ys (cons y ys) (leq x y) + } + fun merge_aux : Nat -> List -> List -> Nat -> List -> List -> Bool -> List + { merge_aux x xs xxs y ys yys true = cons x (merge xs yys) + ; merge_aux x xs xxs y ys yys false = cons y (merge xxs ys) + } +} diff --git a/test/succeed/MockSig.ma b/test/succeed/MockSig.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MockSig.ma @@ -0,0 +1,5 @@ +-- 2010-06-19 + +data MockSig ++(A : Set) ++(B : .A -> Set) : Set +{ pair : (fst : A) -> (snd : B fst) -> MockSig A B +} diff --git a/test/succeed/Mu.ma b/test/succeed/Mu.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Mu.ma @@ -0,0 +1,46 @@ +-- 2010-06-20 +-- sized inductive types +-- 2012-01-22 parameters gone from constructors + +data Empty : Set {} +data Unit : Set { unit : Unit } +data Sum ++(A : Set) ++(B : Set) : Set +{ inl : A -> Sum A B +; inr : B -> Sum A B +} +data Prod ++(A : Set) ++(B : Set) : Set +{ pair : (fst : A) -> (snd : B) -> Prod A B +} + +sized data Mu ++(F : ++Set -> Set) : +Size -> Set +{ inn : [i : Size] -> (out : F (Mu F i)) -> Mu F ($ i) +} + +fun myout : [F : ++Set -> Set] -> [i : Size] -> Mu F ($ i) -> F (Mu F i) +{ myout F i (inn .i t) = t +} + +-- iteration (universal property of Mu) +fun iter : [F : ++Set -> Set] -> + (mapF : [A : Set] -> [B : Set] -> (A -> B) -> F A -> F B) -> + [G : Set] -> (step : F G -> G) -> + [i : Size] -> Mu F i -> G +{- iter F mapF G step .($ j) (inn .F j t) = + step (mapF (Mu F j) G (iter F mapF G step j) t) +-} +{ iter F mapF G step i (inn (i > j) t) = + step (mapF (Mu F j) G (iter F mapF G step j) t) +} + +let NatF : ++Set -> Set = \ X -> Sum Unit X +let Nat : +Size -> Set = Mu NatF + +let zero : [i : Size] -> Nat ($ i) + = \ i -> inn i (inl unit) + +let succ : [i : Size] -> Nat i -> Nat ($ i) + = \ i -> \ n -> inn i (inr n) + + +let ListF : ++Set -> ++Set -> Set = \ A -> \ X -> Sum Unit (Prod A X) +let List : ++Set -> +Size -> Set = \ A -> Mu (ListF A) diff --git a/test/succeed/MultiSigma.ma b/test/succeed/MultiSigma.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MultiSigma.ma @@ -0,0 +1,3 @@ +-- 2012-02-24 + +let test = (A, B : Set) & Set diff --git a/test/succeed/MutualBigDataKindInf.ma b/test/succeed/MutualBigDataKindInf.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MutualBigDataKindInf.ma @@ -0,0 +1,20 @@ +-- 2010-09-20 + +data Unit : Set { unit : Unit } +mutual { + + data MaybeBig : Set 1 + { Nothing : MaybeBig + ; Just : Unit -> Big -> MaybeBig + } + + data Big : Set 1 + { BigIn : (BigOut : Set) -> Big + } fields BigOut + +} + +fun Maybe : MaybeBig -> Set -> (Set -> Set) -> Set +{ Maybe Nothing A F = A +; Maybe (Just u B) A F = F (BigOut B) +} diff --git a/test/succeed/MutualRecordsNoEta.ma b/test/succeed/MutualRecordsNoEta.ma new file mode 100644 --- /dev/null +++ b/test/succeed/MutualRecordsNoEta.ma @@ -0,0 +1,24 @@ +-- 2014-01-09 + +mutual { + data D -(i : Size) + { inn (out : R i) } + + data R -(i : Size) + { delay (force : [j < i] -> D j) + } fields force +} + +fun inh : [i : Size] -> R i +{ inh i .force j = inn (inh j) +} + +data Empty : Set {} + +fun elim : D # -> (D # -> Empty) -> Empty +{ elim (inn r) f = f (r .force #) +} + +-- Stack overflow because MiniAgda thinks D and R are not recursive +-- and does eta-expansion into all eternity + diff --git a/test/succeed/Nested.ma b/test/succeed/Nested.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Nested.ma @@ -0,0 +1,11 @@ +-- 2010-07-01 Ana asked whether nesting is possible + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat $i +; succ : [i : Size] -> Nat i -> Nat $i +} + +fun nested : [i : Size] -> Nat i -> Nat i +{ nested i (zero (i > j)) = zero j +; nested i (succ (i > j) n) = nested j (nested j n) +} diff --git a/test/succeed/NewSyntaxTour.ma b/test/succeed/NewSyntaxTour.ma new file mode 100644 --- /dev/null +++ b/test/succeed/NewSyntaxTour.ma @@ -0,0 +1,50 @@ +-- 2012-01-27 + +-- Telescopes in let-declarations +---------------------------------------------------------------------- + +-- instead of + +let two : [A : Set] -> (f : A -> A) -> (a : A) -> A + = \ A f a -> f (f a) + +-- one can now write + +let two1 [A : Set] (f : A -> A) (a : A) : A + = f (f a) + +-- since the type A of the let-body f (f a) is inferable +-- we can omit it + +let two2 [A : Set] (f : A -> A) (a : A) + = f (f a) + +-- telescopes can also contain bounded size variables +-- 2013-04-01 however, these may violate the context consistency check. +fail let boundedSize (j <= #) (i < j) = i + +-- Untyped local let +---------------------------------------------------------------------- + +-- inferable types of local let declarations can also be omitted + +let twice [F : Set -> Set] (f : [A : Set] -> A -> F A) + [A : Set] (a : A) : F (F A) + = let [FA] = F A in + let fa = f A a in f FA fa + +-- local lets can also use telescopes +let localLetTel : Size = + let two1 [A : Set] (f : A -> A) (a : A) + = f (f a) + in 0 + +-- and can still be made irrelevant +let localLetIrr [A : Set] (f : [A -> A] -> Size) [a : A] : Size = + let [g] (x : A) = a + in f g + +-- alternative with . instead of brackets +let localLetIrr1 [A : Set] (f : .(A -> A) -> Size) .(a : A) : Size = + let .g (x : A) = a + in f g diff --git a/test/succeed/Nisse2012-02-17.ma b/test/succeed/Nisse2012-02-17.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Nisse2012-02-17.ma @@ -0,0 +1,32 @@ +-- bug reported 2012-02-17 + +data Id ++(A : Set) (x : A) : A -> Set +{ refl : Id A x x +} + +data Either ++(A, B : Set) : Set +{ left : A -> Either A B +; right : B -> Either A B +} + +cofun P : ++(A : Set) -> Set +{ P A = Either A A +} + +fun Foo : ++(A : Set) -> P A -> Set +{ Foo A x = (z : A) & Id (P A) x (left z) +} + +fun foo : ++(A : Set) -> (x : P A) -> Foo A x +{ foo A (left x) = (x, refl) +} + +{- +/// leqVal' [(x,1),(A,0)] |- left x <=^ left x : P A +/// conType left: expected P A to be a data type + +P is a cofun (and in my original code it is actually corecursive). Is +MiniAgda too lazy here? + +A: do not know, it works (2012-03-06) +-} diff --git a/test/succeed/Nisse2012-03-06.ma b/test/succeed/Nisse2012-03-06.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Nisse2012-03-06.ma @@ -0,0 +1,43 @@ +-- 2012-03-06 +-- more complicated case of comparing case clauses + +data Id ++(A : Set) (x : A) : A -> Set +{ refl : Id A x x +} + +data Unit : Set +{ unit : Unit +} + +data Either ++(A, B : Set) : Set +{ left : A -> Either A B +; right : B -> Either A B +} + +let Maybe ++(A : Set) : Set = + Either Unit A + +pattern nothing = left unit +pattern just x = right x + +data Monad (F : +Set -> Set) : Set $0 +{ monad : + (return : (A : Set) -> A -> F A) -> + (bind : (A, B : Set) -> F A -> (A -> F B) -> F B) -> + (leftIdentity : (A, B : Set) (x : A) (f : A -> F B) -> + Id (F B) (bind A B (return A x) f) (f x)) -> + Monad F +} +fields return, bind, leftIdentity + +let maybeT (F : +Set -> Set) (M : Monad F) : Monad (\A -> F (Maybe A)) + = monad (\A x -> return M (Maybe A) (just x)) + (\A B m f -> bind M (Maybe A) (Maybe B) m (\x -> case x + { nothing -> return M (Maybe B) nothing + ; (just x) -> f x + })) + (\A B x f -> leftIdentity M (Maybe A) (Maybe B) (just x) + (\x -> case x + { nothing -> return M (Maybe B) nothing + ; (just x) -> f x + })) diff --git a/test/succeed/OverloadedConstructors.ma b/test/succeed/OverloadedConstructors.ma new file mode 100644 --- /dev/null +++ b/test/succeed/OverloadedConstructors.ma @@ -0,0 +1,55 @@ +-- 2013-04-26 + +data Nat { zero ; suc (n : Nat) } + +let one : Nat = suc zero +let two : Nat = suc one + +fun add : Nat -> Nat -> Nat +{ add zero n = n +; add (suc m) n = suc (add m n) +} + +data Fin (n : Nat) +-- refines Nat +{ zero : Fin (suc n) +; suc (i : Fin n) : Fin (suc n) +} + +fun weakF1 : [m : Nat] -> Fin m -> Fin (suc m) +-- refines \ i -> i +{ weakF1 (.suc m) zero = zero +; weakF1 (.suc m) (suc i) = suc (weakF1 m i) +} + +fun weakF : (n : Nat) [m : Nat] -> Fin m -> Fin (add n m) +-- refines \ i -> i +{ weakF zero m i = i +; weakF (suc n) m i = weakF1 (add n m) (weakF n m i) +} + +fun addF : (n : Nat) [m : Nat] -> Fin n -> Fin m -> Fin (add n m) +-- refines add +{ addF (.suc n) m zero j = weakF (suc n) m j +; addF (.suc n) m (suc i) j = suc (addF n m i j) +} + + +data List ++(A : Set) { nil ; cons (x : A) (xs : List A) } + +fun lookupL : [A : Set] (i : Nat) (xs : List A) -> A +{ lookupL A zero (cons x xs) = x +; lookupL A (suc i) (cons x xs) = lookupL A i xs +} + +data Vec ++(A : Set) (n : Nat) +-- refines List +{ nil : Vec A zero +; cons (head : A) (tail : Vec A n) : Vec A (suc n) +} + +fun lookup : [A : Set] [n : Nat] (i : Fin n) (xs : Vec A n) -> A +-- refines LookupL +{ lookup A (.suc n) zero (.cons x xs) = x +; lookup A (.suc n) (suc i) (.cons x xs) = lookup A n i xs +} diff --git a/test/succeed/PTSRule.ma b/test/succeed/PTSRule.ma new file mode 100644 --- /dev/null +++ b/test/succeed/PTSRule.ma @@ -0,0 +1,11 @@ +-- 2010-09-22 + +-- a buggy PTS rule might check whether the sort of the domain +-- is leq than the sort of the codomain + +let T : (i : Size) -> Set ($$ i) + = \ i -> Set ($ i) -> Set i + +let U : (i : Size) -> Set _ + = \ i -> Set ($ _) -> Set _ + diff --git a/test/succeed/ParseMultBind.ma b/test/succeed/ParseMultBind.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ParseMultBind.ma @@ -0,0 +1,15 @@ +let K : (A, B : Set) -> Set + = \ A B -> A + +data Prod ++(A, B : Set) : Set +{ pair : A -> B -> Prod A B +} + +fun fst : [A, B : Set] -> Prod A B -> A +{ fst A B (pair a b) = a +} + +-- 2012-02-04 telescopes in pi types +fun snd : [A, B : Set] (p : Prod A B) -> B +{ snd A B (pair a b) = b +} diff --git a/test/succeed/ParsePipeOperators.ma b/test/succeed/ParsePipeOperators.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ParsePipeOperators.ma @@ -0,0 +1,80 @@ +-- 2012-01-26 F# forward |> and backward pipe operators (<| is Haskell's $) + +-- Backward pipe <| + +-- backward pipe is a synonym for application, but associates to the right +-- and binds weaker than almost everything, exept ',' +-- currently, it has same binding strength as -> and + + +let three [A : Set] (f : A -> A) (x : A) : A + = f <| f <| f x + +let sbla (f : Size -> Size) (x, y : Size) -- : Size + = f <| x + y + +let threeId (f : [A : Set] -> A -> A) [A : Set] (x : A) -- : A + = f A <| f A <| f A x + +-- since <| and -> both associate to the right +-- first-come-first-serve + +fail +let failure [F : Size -> Set] [i : Size] [B : Set] (x : F <| i -> B) : Size + = 0 + -- parsed as F (i -> B) + +let success [F : Size -> Set] [i : Size] [B : Set] (x : B -> F <| i) : Size + = 0 + -- parsed as B -> F i + +let one [A : Set] (f : A -> A) : A -> A + = \ x -> f <| x + -- parsed as \ x -> f x + +-- Forward pipe |> + +let binApp [A,B,C : Set] (f : A -> B -> C) (x : A) (y : B) : C + = y |> f x + -- parsed as f x y + +let redex [A : Set] : A -> A + = \ x -> x |> \ y -> y + -- parsed as \ x -> (\ y -> y) x + +data List (A : Set) : Set +{ nil : List A +; cons (head : A) (tail : List A) : List A +} + +-- pipe back can be used in patterns +fun evens : [A : Set] -> List A -> List A +{ evens A nil = nil +; evens A <| cons x <| nil = nil +; evens A <| cons x <| cons y <| xs = cons x <| evens A xs +} + +-- ever tried parens? +{- fails +fun K : [A, B : Set] -> A -> B -> A +{ ((K A) B a) b = a +} +-} + +record Prod ++(A, B : Set) : Set +{ pair (fst : A) (snd : B) : Prod A B +} fields fst, snd + +-- pointless but parses +fun fork : [A : Set] -> (a : A) -> Prod A A +{ fork A a <| .fst = a +; fork A a <| .snd = a +} + +{- fails rightly, parsed as (a. fst) +fun fork' : [A : Set] -> (a : A) -> Prod A A +{ fork' A <| a .fst = a +; fork' A <| a .snd = a +} +-} + + diff --git a/test/succeed/Pattern.ma b/test/succeed/Pattern.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Pattern.ma @@ -0,0 +1,72 @@ +-- 2012-01-23 pattern declarations + +data Unit : Set { unit : Unit } + +-- * Booleans + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun if : [i : Size] -> (A : Set i) -> Bool -> ++(a, b : A) -> A +{ if i A true a b = a +; if i A false a b = b +} + +fun If : Bool -> ++(A, B : Set) -> Set +{ If true A B = A +; If false A B = B +} + +-- * disjoint sum + +let Plus : ++(A, B : Set) -> Set + = \ A B -> (b : Bool) & If b A B + +pattern inl a = true , a +pattern inr b = false , b + +fun casePlus : [A, B, C : Set] -> (A -> C) -> (B -> C) -> Plus A B -> C +{ casePlus A B C f g (inl a) = f a +; casePlus A B C f g (inr b) = g b +} + +-- * Maybe + +let Maybe : ++(A : Set) -> Set + = Plus Unit + +pattern nothing = inl unit +pattern just a = inr a + +fun maybe : [A, B : Set] -> B -> (A -> B) -> Maybe A -> B +{ maybe A B b f nothing = b +; maybe A B b f (just a) = f a +} + +let mapMaybe : [A, B : Set] -> (A -> B) -> Maybe A -> Maybe B + = \ A B f -> maybe A (Maybe B) nothing (\ a -> just (f a)) + +-- * Lists + +let ListF : ++(A, X : Set) -> Set + = \ A X -> Maybe (A & X) + +cofun List : ++(A : Set) -> ++(i : Size) -> Set +{ List A i = (j < i) & ListF A (List A j) +} + +pattern nil j = j , nothing +pattern cons j a as = j , just (a , as) + + + +{- +data Bit : Set { b0 : Bit; b1 : Bit } + +fun BitCase : Bit -> ++(A, B : Set) -> Set +{ BitCase b0 A B = A +; BitCase b1 A B = B +} +-} diff --git a/test/succeed/PatternParameters.ma b/test/succeed/PatternParameters.ma new file mode 100644 --- /dev/null +++ b/test/succeed/PatternParameters.ma @@ -0,0 +1,137 @@ +data Unit { unit } +data Bool { false ; true } + +data Nat { zero ; suc (n : Nat) } + +fun plus : Nat -> Nat -> Nat +{ plus zero m = m +; plus (suc n) m = suc (plus n m) +} + +data List ++(A : Set) { nil ; cons (x : A) (xs : List A) } + +-- * Vectors + +data OldVec ++(A : Set) : (n : Nat) -> Set +{ oldvnil : OldVec A zero +; oldvcons (n : Nat) (oldvhead : A) (oldvtail : OldVec A n) : OldVec A (suc n) +} fields oldvhead, oldvtail + +data Vec ++(A : Set) (n : Nat) +{ vnil : Vec A zero +; vcons (vhead : A) (vtail : Vec A n) : Vec A (suc n) +} fields vhead, vtail + +fun append : [A : Set] (n : Nat) [m : Nat] -> Vec A n -> Vec A m -> Vec A (plus n m) +{ append A zero m vnil ys = ys +; append A (suc n) m (vcons x xs) ys = vcons x (append A n m xs ys) +} + +data Fin (n : Nat) +{ fzero : Fin (suc n) +; fsuc (i : Fin n) : Fin (suc n) +} + +fun lookup : [A : Set] (n : Nat) (i : Fin n) (xs : Vec A n) -> A +{ lookup A zero () vnil +; lookup A (suc n) fzero (vcons x xs) = x +; lookup A (suc n) (fsuc i) (vcons x xs) = lookup A n i xs +} + +{- untyped terms + +data Tm (n : Nat) +{ var (x : Fin n) +; app (r, s : Tm n) +; abs (t : Tm (suc n)) +} + +let Subst (n, m : Nat) = Vec (Tm m) n + +fun liftSubst : (n : Nat) [m : Nat] -> Subst n m -> Subst (suc n) (suc m) +{} + +fun subst : (n : Nat) [m : Nat] -> Tm n -> Subst n m -> Tm m +{ subst n m (var i) rho = lookup (Tm m) n i rho +; subst n m (app r s) rho = app (subst n m r rho) (subst n m s rho) +; subst n m (abs t) rho = abs (subst (suc n) (suc m) t (liftSubst n m rho)) +} +-} + +-- * Simply typed lambda terms. + +data Ty { nat ; arr (a, b : Ty) } + +let Cxt = List Ty + +data Var (cxt : Cxt) (a : Ty) +{ vzero : Var (cons a cxt) a -- non-linearity ok! +; vsuc (x : Var cxt b) : Var (cons a cxt) b +} + +data Tm (cxt : Cxt) (a : Ty) +{ var (x : Var cxt a) : Tm cxt a +; app (a : Ty) (r : Tm cxt (arr a b)) (s : Tm cxt a) : Tm cxt b +; abs (t : Tm (cons a cxt) b) : Tm cxt (arr a b) +} + +fun Sem : Ty -> Set +{ Sem nat = Nat +; Sem (arr a b) = Sem a -> Sem b +} + +fun Env : Cxt -> Set +{ Env nil = Unit +; Env (cons a as) = Sem a & Env as +} + +fun val : (cxt : Cxt) [a : Ty] -> Var cxt a -> Env cxt -> Sem a +{ val (cons a cxt) .a vzero (v, vs) = v +; val (cons a cxt) b (vsuc x) (v, vs) = val cxt b x vs +} + +fun sem : (cxt : Cxt) (a : Ty) -> Tm cxt a -> Env cxt -> Sem a +{ sem cxt a (var x) rho = val cxt a x rho +; sem cxt b (app a r s) rho = sem cxt (arr a b) r rho (sem cxt a s rho) +; sem cxt (arr a b) (abs t) rho v = sem (cons a cxt) b t (v, rho) +} + +-- * Identity type. + +data Id (A : Set) (x, y : A) { refl : Id A x x } + +fun subst : [A : Set] [P : A -> Set] [x, y : A] -> Id A x y -> P x -> P y +{ subst A P x .x refl h = h } + +fail let trueIsFalse : Id Bool true false = refl + +{- How to check a data constructor + +Case 1: no target given, e.g. + + cons (x : A) (xs : List A) + + Bring the parameters of the data telescope into scope, then + check constructor telescope + +Case 2: target given, e.g. + + vcons (vhead : A) (vtail : Vec A n) : Vec A (suc n) + + Take the parameters off the target, treat them like patterns, + and check them against the data telecope (or type of data name). + We get out a context + + A : Set + n : Nat + + use this context to check full type of constructor. + Also, check that no binding in constructor type shadows the + pattern variables of the target (would be confusing). + In the end, prepend the context to the constructor type. + +Case 3: target is function type. + + Extract final target and proceed as in 2. + +-} diff --git a/test/succeed/Polarities.ma b/test/succeed/Polarities.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Polarities.ma @@ -0,0 +1,89 @@ +-- 2010-06-19, 2010-11-09 + +let Const : ++ Set -> . Set -> Set + = \ A -> \ X -> A + +let DNeg : ^ Set -> + Set -> Set + = \ B -> \ A -> * (* A -> B) -> B + +data Empty : Set {} + +sized data Nat : + Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> ^ Nat i -> Nat ($ i) +} + +let Cont' : + Set -> Set + = DNeg Empty + +-- the following holds already because of whnf computation +let cast' : [i : Size] -> ^ Cont' (Nat i) -> Cont' (Nat #) + = \ i -> \ x -> x + +data Cont +(A : Set) : Set +{ cont : (uncont : DNeg Empty A) -> Cont A +} + +-- the following holds because Cont is a datatype (pol. already impl.) +let cast : [i : Size] -> ^ Cont (Nat i) -> Cont (Nat #) + = \ i -> \ x -> x + +-- hide positivity behind recursion +fun Id : * Nat # -> ++Set -> Set +{ Id (zero .#) A = A +; Id (succ .# n) A = A +} + +let kast : [i : Size] -> [n : Nat i] -> Id n (Nat i) -> Id n (Nat #) + = \ i -> \ n -> \ x -> x + +data Tree -(B : Set) ++(A : Set) : Set +{ leaf : Tree B A +; node : A -> (B -> Tree B A) -> Tree B A +} + +sized data STree -(B : Set) ++(A : Set) : +Size -> Set +{ sleaf : [i : Size] -> STree B A ($ i) +; snode : [i : Size] -> A -> (B -> STree B A i) -> STree B A ($ i) +} + +data Mu ++(F : ++Set -> Set) : Set +{ inn : F (Mu F) -> Mu F +} + +{- + .(p) = o + ++(p) = p + +(++) = + + +(p) = p + -(++) = - + -(+) = - + -(-) = + + -(p) = p + o(o) = o + o(++) = . + o(+) = . + o(-) = . + o(.) = . + + -(Gamma) |- A : s Gamma |- B : s + --------------------------------- + Gamma |- A -> B : s + + -(Gamma) |- A : s Gamma, x : A |- B : s + ---------------------------------------- + Gamma |- p(x : A) -> B : s + + -------------------------------- p in {++,+,o} + Gamma, p(x : A), Gamma' |- x : A + + Gamma, p(x : A) |- t : B + ---------------------------- + Gamma |- \xt : p(x : A) -> B + + Gamma |- r : p(x : A) -> B p(Gamma) |- s : A + ---------------------------------------------- + Gamma |- r s: B[s/x] + + +-} diff --git a/test/succeed/PredDepType.ma b/test/succeed/PredDepType.ma new file mode 100644 --- /dev/null +++ b/test/succeed/PredDepType.ma @@ -0,0 +1,21 @@ +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +fun Pred : (i : Size) -> (x : Nat ($ i)) -> Set +{ Pred i (succ .i n) = Nat i +; Pred i (zero .i) = Nat ($ i) +} + +fun pred : [i : Size] -> (x : Nat ($ i)) -> Pred i x +{ pred i (succ .i n) = n +; pred i (zero .i) = zero i +} + +{- DOES NOT WORK +fun minus : [i : Size] -> Nat i -> Nat # -> Nat i +{ minus i n (zero .#) = n +; minus i n (succ .# m) = minus i (pred i n) m +} +-} diff --git a/test/succeed/Prelude.ma b/test/succeed/Prelude.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Prelude.ma @@ -0,0 +1,38 @@ +-- 2012-01-28 MiniAgda Prelude, PiSigma style + +data Empty {} +data Unit { unit } +data Bool { true; false } + +fun If : (b : Bool) -> ++(A, B : Set) -> Set +{ If true A B = A +; If false A B = B +} + +let Either ++(A, B : Set) = (b : Bool) & If b B A +pattern left a = (false, a) +pattern right b = (true, b) + +let Maybe ++(A : Set) = Either Unit A +pattern nothing = left unit +pattern just a = right a + +cofun Nat : +Size -> Set +{ Nat i = [j < i] & Maybe (Nat j) +} +pattern zero j = (j, nothing) +pattern succ j n = (j, just n) + + let zer [i : Size] : Nat $i = zero 0 +check let suc [i < #] (n : Nat i) : Nat $i = succ i n + +fun suc : [i : Size] (n : Nat i) -> Nat $i +{ suc i (i', m) = succ $i' (i', m) +} + +fun plus : [i : Size] -> (n : Nat i) -> + [j : Size] -> (m : Nat j) -> Nat (i+j) +{ plus i (zero i') j m = m +; plus i (succ i' n) j m = suc (i'+j) <| plus i' n j m +} +-- 2012-02-01 type checker turns var pattern i' into size pattern (i' < i) diff --git a/test/succeed/Prod.ma b/test/succeed/Prod.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Prod.ma @@ -0,0 +1,3 @@ +data Prod (A : Set)(B : Set) : Set +{ pair : (fst : A) -> (snd : B) -> Prod A B +} diff --git a/test/succeed/Projections.ma b/test/succeed/Projections.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Projections.ma @@ -0,0 +1,14 @@ +-- 2012-01-25 + +-- record +data Sigma ++(A : Set) ++(B : A -> Set) : Set +{ pair (fst : A) (snd : B fst) : Sigma A B +} fields fst, snd + +fun eta : [A, B : Set] -> Sigma A (\ x -> B) -> Sigma A (\ x -> B) +{ eta A B p = pair (fst p) (snd p) +} + +let builtinEta [A, B : Set] (p : Sigma A (\ x -> B)) + : < pair (fst p) (snd p) : Sigma A (\ x -> B) > + = p diff --git a/test/succeed/Rose.ma b/test/succeed/Rose.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Rose.ma @@ -0,0 +1,19 @@ +data List (+ A : Set) : Set +{ nil : List A +; cons : A -> List A -> List A +} + +fun mapList : [A : Set] -> [B : Set] -> (A -> B) -> List A -> List B +{ mapList A B f (nil) = nil +; mapList A B f (cons a as) = cons (f a) (mapList A B f as) +} + +sized data Rose (+ A : Set) : Size -> Set +{ rose : [i : Size] -> A -> List (Rose A i) -> Rose A ($ i) +} + +fun mapRose : [A : Set] -> [B : Set] -> (A -> B) -> + [i : Size] -> Rose A i -> Rose B i +{ mapRose A B f .($ i) (rose i a rs) = + rose i (f a) (mapList (Rose A i) (Rose B i) (mapRose A B f i) rs) +} diff --git a/test/succeed/SP.ma b/test/succeed/SP.ma new file mode 100644 --- /dev/null +++ b/test/succeed/SP.ma @@ -0,0 +1,33 @@ +{- 2010-03-24 Awaji Island + +Mixed coinduction/induction. Allow data with coinductive occurrences. +Interpreted as greatest fixpoint of a least fixpoint. +-} + +sized codata Str (+ A : Set) : Size -> Set +{ cons : [i : Size] -> A -> Str A i -> Str A ($ i) +} + +fun A : Set {} +fun B : Set {} + +sized data SP' (+ X : Set) : Size -> Set +{ get : [j : Size] -> (A -> SP' X j) -> SP' X ($ j) +; out : [j : Size] -> X -> SP' X ($ j) +} + +sized codata SP : Size -> Set +{ put : [i : Size] -> B -> SP' (SP i) # -> SP ($ i) +} + +fun run' : [i : Size] -> (SP i -> Str A # -> Str B i) -> + [j : Size] -> SP' (SP i) j -> Str A # -> Str B i +{ run' i r j (get {- .(SP i)-} (j > k) f) (cons .# a as) = run' i r k (f a) as +; run' i r j (out {- .(SP i)-} (j > k) sp) as = r sp as +} + +cofun run : [i : Size] -> SP i -> Str A # -> Str B i +{ run ($ i) (put .i b sp) as = cons i b (run' i (run i) # sp as) +} + + diff --git a/test/succeed/ScopeCheckFunDef.ma b/test/succeed/ScopeCheckFunDef.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ScopeCheckFunDef.ma @@ -0,0 +1,21 @@ +data Bool : Set { true : Bool; false : Bool } + +fun not : Bool -> Bool +{ not true = false +; not false = true +} + +fun notnot : Bool -> Bool +{ notnot x = not (not x) +} + +fun T : Bool -> Set +{ T true = Bool +; T false = Bool +} + +fun f : (b : Bool) -> T b -> T b +{ f true x = x +; f false x = x +} + diff --git a/test/succeed/SgPredWrongMon.ma b/test/succeed/SgPredWrongMon.ma new file mode 100644 --- /dev/null +++ b/test/succeed/SgPredWrongMon.ma @@ -0,0 +1,16 @@ +-- 2010-06-20 + +let Pred : -Set -> Set 1 + = \ A -> A -> Set + +data Sg ++(A : Set) : A -> Set +{ sg : (elem : A) -> Sg A elem +} + +sized data Nat : +Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +let Sg' : +(A : Set) -> A -> Set + = Sg diff --git a/test/succeed/SolverBugStreamFixed.ma b/test/succeed/SolverBugStreamFixed.ma new file mode 100644 --- /dev/null +++ b/test/succeed/SolverBugStreamFixed.ma @@ -0,0 +1,227 @@ +-- Booleans ---------------------------------------------------------- + +data Bool : Set +{ tt : Bool +; ff : Bool +} + +fun ifthenelse : Bool -> [A : Set] -> A -> A -> A +{ ifthenelse tt A a1 a2 = a1 +; ifthenelse ff A a1 a2 = a2 +} + +-- Nat --------------------------------------------------------------- + +sized data SNat : Size -> Set +{ zero : [i : Size] -> SNat ($ i) +; succ : [i : Size] -> SNat i -> SNat ($ i) +} + +let Nat : Set = SNat # + +fun add : Nat -> Nat -> Nat +{ add (zero .#) = \ y -> y +; add (succ .# x) = \ y -> succ # (add x y) +} + +fun leq : Nat -> Nat -> Bool +{ leq (zero .#) y = tt +; leq (succ .# x) (zero .#) = ff +; leq (succ .# x) (succ .# y) = leq x y +} + +-- Stream ------------------------------------------------------------ + +sized codata Stream (+ A : Set) : Size -> Set +{ cons : [i : Size] -> A -> Stream A i -> Stream A ($ i) +} + +fun tail : [A : Set] -> [i : Size] -> Stream A ($ i) -> Stream A i +{ tail A i (cons .i x xs) = xs +} + +fun head : [A : Set] -> [i : Size] -> Stream A ($ i) -> A +{ head A i (cons .i x xs) = x +} + +fun nth : [A : Set] -> [i : Size] -> SNat i -> Stream A i -> A +{ nth A i (zero (i > j)) xs = head A j xs +; nth A i (succ (i > j) n) xs = nth A j n (tail A j xs) +} + +-- map, zip, merge --------------------------------------------------- + +cofun map : [A : Set] -> [B : Set] -> [i : Size] -> + (A -> B) -> Stream A i -> Stream B i +{ +map A B ($ i) f (cons .i x xl) = cons _ (f x) (map A B _ f xl) +} + +cofun zipWith : [A : Set] -> [B : Set] -> [C : Set] -> + (A -> B -> C) -> [i : Size] -> + Stream A i -> Stream B i -> Stream C i +{ + zipWith A B C f ($ i) (cons .i a as) (cons .i b bs) = + cons i (f a b) (zipWith A B C f i as bs) +} + +cofun merge : [i : Size] -> (Nat -> Nat -> Bool) -> + Stream Nat i -> Stream Nat i -> Stream Nat i +{ +merge ($ i) le (cons .i x xs) (cons .i y ys) = + ifthenelse (le x y) (Stream Nat _) + (cons _ x (merge _ le xs (cons _ y ys))) + (cons _ y (merge _ le (cons _ x xs) ys)) +} + +{- +cofun merge : [i : Size] -> (Nat -> Nat -> Bool) -> + Stream Nat i -> Stream Nat i -> Stream Nat i +{ +merge .($ i) le (cons .i x xs) (cons i y ys) = + ifthenelse (le x y) (Stream Nat _) + (cons _ x (merge _ le xs (cons _ y ys))) + (cons _ y (merge _ le (cons _ x xs) ys)) +} +-} + +-- Hamming function -------------------------------------------------- + +let n0 : Nat = zero # +let n1 : Nat = succ # n0 +let n2 : Nat = succ # n1 +let n3 : Nat = succ # n2 +let n4 : Nat = succ # n3 +let n5 : Nat = succ # n4 + +let double : Nat -> Nat + = \ n -> add n n +let triple : Nat -> Nat + = \ n -> add n (double n) + +cofun ham : [i : Size] -> Stream Nat i +{ + ham ($ i) = cons _ n1 (merge i leq (map Nat Nat i double (ham i)) + (map Nat Nat i triple (ham i))) +} + + +{- +-- THIS SHOULD NOT TYPECHECK!! +cofun map2 : [i : Size] -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +{ +map2 .($ ($ i)) f (cons .($ i) u (cons i x xl)) = + cons _ (f u) (cons _ (f x) (map2 _ f xl)) +} + +cofun ham2 : [i : Size] -> Stream Nat i +{ + ham2 ($ i) = cons _ n1 (merge i leq (map2 i double (ham2 i)) + (map2 i triple (ham2 i))) +} + +-- THIS LOOPS!!! +eval let bla : Nat = nth n1 (ham2 #) +-} + +-- Fibonacci stream -------------------------------------------------- + +{- NOT YET IMPLEMENTED: rational sizes + WILL NOT IMPLEMENT -- see fibDeep.ma + +cofun fib : [i : Size] -> Stream Nat (i + i) +{ + fib (i + 1) = cons _ n0 (cons _ n1 (zipWith Nat Nat Nat add + i (fib i) (tail Nat i (fib (i + 1/2))))) +} + +-} + +{- distinguish fib from the following + +cofun bad : [i : Size] -> Stream Nat i +{ + bad ($ ($ i)) = cons _ n0 (tail Nat _ (bad ($ i))) +} + +-} + +cofun fib : [i : Size] -> Stream Nat i +{ + fib ($ i) = cons _ n0 (zipWith Nat Nat Nat add i + (cons _ n1 (fib i)) (fib i)) +} + + + +cofun fibIter' : (x : Nat) -> (y : Nat) -> [i : Size] -> Stream Nat i +{ + fibIter' x y ($ i) = cons _ x (fibIter' y (add x y) _) +} +let fibIter : Stream Nat # = (fibIter' n1 n1 _) + + +-------------------------------------------- + +-- fibIter(4) = 5 +eval let fibIter4 : Nat = nth Nat # n4 fibIter + +eval let fib1 : Nat = nth Nat # n1 (fib #) +eval let fib2 : Nat = nth Nat # n2 (fib #) +eval let fib3 : Nat = nth Nat # n3 (fib #) +eval let fib4 : Nat = nth Nat # n4 (fib #) +eval let fib5 : Nat = nth Nat # n5 (fib #) + + +-------------------------------------------- + +data Leq : Nat -> Nat -> Set +{ lqz : (x : Nat) -> Leq (zero #) x +; lqs : (x : Nat) -> (y : Nat) -> Leq x y -> Leq (succ # x) (succ # y) +} + +sized codata Increasing : Size -> Stream Nat # -> Set +{ +inc : [i : Size] -> (x : Nat) -> (y : Nat) -> Leq x y -> (tl : Stream Nat #) -> + Increasing i (cons # y tl) -> + Increasing ($ i) (cons # x (cons # y tl)) +} + + +data Eq (+ A : Set) : A -> A -> Set +{ +refl : [a : A] -> Eq A a a +} + +let proof : Eq (Stream Nat #) (tail Nat # fibIter) (tail Nat # fibIter) = + refl (tail Nat # fibIter) + + +-- 2010-07-07 this is just "nats" it should termination check +-- not so evil + +let succ_ : [i : Size] -> SNat i -> SNat $i = \ i x -> succ i x + +cofun evil : [i : Size] -> Stream Nat i +{ +evil ($ i) = map Nat Nat _ (succ_ _) (cons _ (zero _) (evil _)) +} + +-- eval const zzz : Nat = head # (z #) + + + +-- convolution (Shin-Cheng Mu) + +let cons_ : [A : Set] -> [i : Size] -> A -> Stream A i -> Stream A $i + = \ A i a as -> cons i a as + +cofun dmerge : [A : Set] -> [i : Size] -> Stream (Stream A i) i -> Stream A i +{ +dmerge A ($ i) (cons .i ys yss) = + cons i (head A _ ys) (dmerge A i + (zipWith A (Stream A _) (Stream A _) (cons_ A _) i + (tail A _ ys) yss)) +} + + diff --git a/test/succeed/Squash.ma b/test/succeed/Squash.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Squash.ma @@ -0,0 +1,127 @@ +-- 2010-07-09 Workshop on Dependently Typed Programming DTP-10 +-- 2010-09-21 Email discussion on Agda list with Dan Doel +-- 2012-01-22 parameters gone from constructors + +data Id [A : Set](a : A) : A -> Set +{ refl : Id A a a +} + +fun elimId : [A : Set] -> [P : A -> Set] -> [a, b : A] -> [Id A a b] -> + P a -> P b +{ elimId A P a .a refl h = h +} + +-- Existentials ------------------------------------------------------ + +data Ex (A : Set)(P : A -> Set) : Set +{ exIntro : [a : A] -> P a -> Ex A P +} + +-- Large existentials +impredicative data Exists [i : Size](A : Set i)(P : A -> Set) : Set +{ ExIntro : [a : A] -> P a -> Exists i A P +} + +-- projections not definable (weak Sigma) +fail fun proj1 : [i : Size] -> [A : Set i] -> [P : A -> Set] -> + Exists i A P -> A +{ proj1 i A P (ExIntro a p) = a -- a cannot appear here! +} + +-- Exists elimination +fun ExElim : [i : Size] -> [A : Set i] -> [P : A -> Set] -> + Exists i A P -> [C : Set] -> ([a : A] -> P a -> C) -> C +{ ExElim i A P (ExIntro a p) C k = k a p +} + +-- Subsets ----------------------------------------------------------- + +data Subset (A : Set) (P : A -> Set) : Set +{ inSub : (outSub : A) -> [P outSub] -> Subset A P +} + +fun outSub' : [A : Set] -> [P : A -> Set] -> Subset A P -> A +{ outSub' A P (inSub a p) = a +} + +-- Proof-irrelevant propositions (Proof types / bracket types) ------- + +data Prf ++(A : Set) : Set +{ prf : [A] -> Prf A +} + +fun proofIrr : [A : Set] -> [a, b : Prf A] -> Id (Prf A) a b +{ proofIrr A (prf a) (prf b) = refl +} + +fail fun proofIrr' : [A : Set] -> [a, b : Prf A] -> Id (Prf A) a b +{ proofIrr' A a b = refl +} + +-- Monad Laws for Prf + +fun mapPrf : [A, B : Set] -> (A -> B) -> Prf A -> Prf B +{ mapPrf A B f (prf a) = prf (f a) +} + +fun joinPrf : [A : Set] -> Prf (Prf A) -> Prf A +{ joinPrf A (prf (prf a)) = prf a +} + +fail fun bindPrf : [A, B : Set] -> Prf A -> (A -> Prf B) -> Prf B +{ bindPrf A B (prf a) f = f a -- a cannot be used here +} + +let bindPrf : [A, B : Set] -> Prf A -> (A -> Prf B) -> Prf B + = \ A B pa f -> joinPrf B (mapPrf A (Prf B) f pa) + +{- Dan Doel, eliminator for "Squash" = Prf + +I believe this is equivalent to what the thesis refers to as token +type target erasure. It would make the Squash eliminator: + + elimSq : (A : Set) => (P : Squash A -> Set) => + (f : (x : A) => P (squash x)) -> + (s : Squash A) => P s + elimSq A P f (squash x) = f x + +and in general, it would improve the eliminator of any singleton type +in the same way. However, the problem is that equality types are in +this class, and if you make those erasable, you get bad meta-theoretic +properties. -} + +fun elimPrf : [A : Set] -> [P : Prf A -> Set] -> + (f : [a : A] -> P (prf a)) -> + [x : Prf A] -> P x +{ elimPrf A P f (prf a) = f a +} + +-- More laws for bracket types + +-- does not go this way +fail fun isoForall1 : [A : Set] -> [B : A -> Set] -> + ((x : A) -> Prf (B x)) -> Prf ((x : A) -> B x) +{ isoForall1 A B f = prf {-((x : A) -> B x)-} (\ x -> f x) +} + +fun isoForall2 : [A : Set] -> [B : A -> Set] -> + Prf ((x : A) -> B x) -> (x : A) -> Prf (B x) +{ isoForall2 A B (prf {-.((x' : A) -> B x')-} f) x = prf {-(B x)-} (f x) +} + + +data Prod ++(A, B : Set) : Set +{ pair : (fst : A) -> (snd : B) -> Prod A B +} + +fun isoAnd1 : [A, B : Set] -> Prod (Prf A) (Prf B) -> Prf (Prod A B) +{ isoAnd1 A B (pair (prf a) (prf b)) = + prf (pair a b) +} + +fun isoAnd2 : [A, B : Set] -> Prf (Prod A B) -> Prod (Prf A) (Prf B) +{ isoAnd2 A B (prf (pair a b)) = + pair (prf a) (prf b) +} + + diff --git a/test/succeed/Stack.ma b/test/succeed/Stack.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Stack.ma @@ -0,0 +1,66 @@ +-- 2010-07-13,-27 state-less stack object + +data Maybe (A : Set) : Set +{ nothing : Maybe A +; just : A -> Maybe A +} + +-- stack object +sized codata Stack (A : Set) : Size -> Set +{ stack : [i : Size] -> + (top : Maybe A) -> + (pop : Stack A i) -> + (push : A -> Stack A i) -> Stack A $i +} + +-- functional to construct push action +cofun pushFunc : [A : Set] -> [i : Size] -> |i| -> + ([j : Size] -> |j| < |i| -> Stack A j -> A -> Stack A j) -> + Stack A i -> A -> Stack A i +{ pushFunc A ($ i) f s a = stack i (just a) s (f i (pushFunc A i f s a)) +} +-- f : [j : Size] -> |j| < |$i| -> Stack A j -> A -> Stack A j +-- s : Stack A $i +-- by subtyping +-- f : [j : Size] -> |j| < |i| -> Stack A j -> A -> Stack A j +-- s : Stack A i +-- hence pushFunc A i f s a : Stack A i +-- f i (...) : A -> Stack A i +-- rhs : Stack A $i + +-- tying the knot +cofun pushFix : [A : Set] -> [i : Size] -> |i| -> Stack A i -> A -> Stack A i +{ pushFix A ($ i) = pushFunc A ($ i) (pushFix A) +} +-- on the rhs, we have the typing of the recursive call +-- pushFix A : [j : Size] -> |j| < |$i| -> Stack A j -> A -> Stack A j + +-- constructing the empty stack +cofun empty : [A : Set] -> [i : Size] -> |i| -> Stack A i +{ empty A ($ i) = stack i nothing (empty A i) (pushFix A i (empty A i)) +} + +{- original circular program + +data Stack a = Stack + { top :: Maybe a + , pop :: Stack a + , push :: a -> Stack a + } + +-- circular auxiliary program to construct stacks +push' :: Stack a -> a -> Stack a +push' s a = s' + where s' = Stack (Just a) s (push' s') + +-- the empty stack +empty :: Stack a +empty = Stack Nothing empty (push' empty) + +-} + +{- + + push' s a = fix (\ s' -> Stack (Just a) s (push' s')) + +-} diff --git a/test/succeed/StreamDupl.ma b/test/succeed/StreamDupl.ma new file mode 100644 --- /dev/null +++ b/test/succeed/StreamDupl.ma @@ -0,0 +1,12 @@ +-- 2010-11-01 + +sized codata Stream ++(A : Set) : -Size -> Set +{ cons : [i : Size] -> (head : A) -> (tail : Stream A i) -> Stream A $i +} + +cofun evens : [A : Set] -> [i : Size] -> Stream A (i + i) -> Stream A i +{ evens A ($i) (cons .(i + i + 1) a (cons .(i + i) b as)) = + cons i a (evens A i as) +} +-- this should fail because we cannot match the input stream to depth 2 +-- since only i is replaced by $i diff --git a/test/succeed/StrictBoundedQCoinductive.ma b/test/succeed/StrictBoundedQCoinductive.ma new file mode 100644 --- /dev/null +++ b/test/succeed/StrictBoundedQCoinductive.ma @@ -0,0 +1,19 @@ +-- 2010-11-26 + +data Bool : Set +{ true : Bool +; false : Bool +} + +let C : Size -> Set + = \ i -> [j : Size] -> |j| < |i| -> Bool + +cofun foo : [i : Size] -> C i +{ foo ($i) j = true +} + +{- does not type check +cofun loop : [i : Size] -> C i +{ loop ($i) j = loop i j +} +-} diff --git a/test/succeed/UPolyList.ma b/test/succeed/UPolyList.ma new file mode 100644 --- /dev/null +++ b/test/succeed/UPolyList.ma @@ -0,0 +1,5 @@ +data List [i : Size](A : Set i) : Set i +{ nil : List i A +; cons : A -> List i A -> List i A +} + diff --git a/test/succeed/Universe.ma b/test/succeed/Universe.ma new file mode 100644 --- /dev/null +++ b/test/succeed/Universe.ma @@ -0,0 +1,19 @@ +-- 2010-08-28 + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +mutual { + + data U : Set + { nat : U + ; pi : (a : U) -> (El a -> U) -> U + } + + fun El : U -> Set + { El nat = Nat + ; El (pi a f) = (x : El a) -> El (f x) + } +} diff --git a/test/succeed/VecNotErased.ma b/test/succeed/VecNotErased.ma new file mode 100644 --- /dev/null +++ b/test/succeed/VecNotErased.ma @@ -0,0 +1,48 @@ +data Nat : Set +{ + zero : Nat; + succ : (pred : Nat) -> Nat +} + +fun add : Nat -> Nat -> Nat +{ + add zero y = y; + add (succ x) y = succ (add x y) +} + +data Vec' (+A : Set) : Nat -> Set +{ + vnil' : Vec' A zero; + vcons' : (n : Nat) -> (head' : A) -> (tail' : Vec' A n) -> Vec' A (succ n) +} + +{- +data Vec (+A : Set) : Nat -> Set +{ + vnil : Vec A zero; + vcons : (head : A) -> [n : Nat] -> (tail : Vec A n) -> Vec A (succ n) +} + +fun length : [A : Set] -> [n : Nat] -> Vec A n -> Nat +{ + length .A .zero (vnil A) = zero; + length .A .(succ n) (vcons A x n xs) = succ (length A n xs); +} + +fun append : [A : Set] -> [n : Nat] -> Vec A n -> + [m : Nat] -> Vec A m -> Vec A (add n m) +{ + append .A .zero (vnil A) m ys = ys; + append .A .(succ n) (vcons A x n xs) m ys = + vcons A x (add n m) (append A n xs m ys) +} + +data Id (A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +let vec0vnil : (A : Set) -> (v : Vec A zero) -> Id (Vec A zero) v (vnil A) + = \ A -> \ v -> refl (Vec A zero) v + + +-} diff --git a/test/succeed/WrapAbsurd.ma b/test/succeed/WrapAbsurd.ma new file mode 100644 --- /dev/null +++ b/test/succeed/WrapAbsurd.ma @@ -0,0 +1,35 @@ +-- 2010-07-08 + +data Wrap ++(A : Set) : Set +{ wrap : (unwrap : A) -> Wrap A +} + +data Empty : Set {} + +-- should succeed +fun wrap0Elim : Wrap Empty -> Empty +{ wrap0Elim (wrap ()) +} + +data Unit : Set { unit : Unit } + +-- should fail +fail fun wrap1Elim : Wrap Unit -> Empty +{ wrap1Elim (wrap ()) +} + +{- BEFORE BUG FIX: + +checkPattern + dot pats: [(0,(Unit,[(Set 0)]))] + environ : [(".Unit",v0)] + context : [[(Set 0)]] + pattern : () + at type : ((unwrap : v0) -> Wrap A{A = v0}) <> + +the test whether there are matchingConstructors is too optimistic +since v0 is not solved yet to be Unit, it finds no matching constructors +--> it should solve first + +BUG FIX: postpone emptyness check till after pattern checking +-} diff --git a/test/succeed/absurdPattern.ma b/test/succeed/absurdPattern.ma new file mode 100644 --- /dev/null +++ b/test/succeed/absurdPattern.ma @@ -0,0 +1,5 @@ +data Empty : Set {} + +fun magic : [A : Set] -> [x : Empty] -> A +{ magic A () +} diff --git a/test/succeed/addWith.ma b/test/succeed/addWith.ma new file mode 100644 --- /dev/null +++ b/test/succeed/addWith.ma @@ -0,0 +1,28 @@ +sized data SNat : Size -> Set +{ +zero : (i : Size) -> SNat ($ i); +succ : (i : Size) -> SNat i -> SNat ($ i) +} + +-- deep predecessor +-- a size preserving function +fun ote : (i : Size) -> SNat i -> SNat i +{ +ote .($ i) (zero i) = zero i; +ote .($ $ i) (succ .($ i) (zero i)) = zero i; +ote .($ $ i) (succ .($ i) (succ i x)) = succ ($ i) (succ i (ote i x )) +} + +-- add, applying f to both arguments in each step, permuting the arguments +-- "permutating size arguments" +fun addWith : ((k : Size ) -> SNat k -> SNat k ) -> (i : Size ) -> (j : Size ) -> SNat i -> SNat j -> SNat # +{ +addWith f .($ i) j (zero i) y = y; +addWith f .($ i) j (succ i x) y = succ # (addWith f j i (f j y) (f i x)) +} + +let three : SNat # = succ # (succ # (succ # (zero #))) +let four : SNat # = succ # three + +eval let bla : SNat # = addWith ote # # four three + diff --git a/test/succeed/casePair.ma b/test/succeed/casePair.ma new file mode 100644 --- /dev/null +++ b/test/succeed/casePair.ma @@ -0,0 +1,23 @@ +-- 2012-01-26 infer type of pair + +data Bool : Set { true; false } + +{- 2012-02-03 pair inference disabled because of irrelevance + would need polarity annotation in first component in general + +let xor (a, b : Bool) : Bool + = case a, b -- infers type of (a,b) + { (true, true) -> false + ; (false, true) -> true + ; (true, false) -> true + ; (false, false) -> false + } +-} + +let xor' (a, b : Bool) : Bool + = case (a,b) : Bool & Bool + { (true, true) -> false + ; (false, true) -> true + ; (true, false) -> true + ; (false, false) -> false + } diff --git a/test/succeed/caseSList.ma b/test/succeed/caseSList.ma new file mode 100644 --- /dev/null +++ b/test/succeed/caseSList.ma @@ -0,0 +1,73 @@ +-- 2012-01-22 parameters gone from constructors + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun leq : Nat -> Nat -> Bool +{ leq zero n = true +; leq (suc m) zero = false +; leq (suc m) (suc n) = leq m n +} + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +fun True : ^Bool -> Set +{ True b = Id Bool b true +} +let triv : True true + = refl + +fun False : Bool -> Set +{ False b = Id Bool b false +} +let triv' : False false + = refl + +fun leFalse : (n : Nat) -> (m : Nat) -> False (leq n m) -> True (leq m n) +{ leFalse n zero p = triv +; leFalse (suc n) (suc m) p = leFalse n m p +; leFalse zero (suc m) () -- IMPOSSIBLE +} + +data SList : Nat -> Set +{ snil : SList zero +; scons : (shead : Nat) -> -- I can erase this at compile-time, but + -- it should be present at run-time ?? + (stailindex : Nat) -> -- this should be erased at run-time ?? + [True (leq stailindex shead)] -> + (stail : SList stailindex) -> + SList shead +} + +fun maxN : Nat -> Nat -> Nat +{ maxN n m = case leq n m + { true -> m + ; false -> n + } +} + +fun maxLemma : (n : Nat) -> (m : Nat) -> (k : Nat) -> + True (leq n k) -> True (leq m k) -> True (leq (maxN n m) k) +{ maxLemma n m k p q = case leq n m + { true -> q + ; false -> p + } +} + +fun insert : (m : Nat) -> (n : Nat) -> SList n -> SList (maxN n m) +{ insert m .zero snil = scons m zero triv snil +; insert m n (scons .n k p l) = case leq n m + { true -> scons m n triv (scons n k p l) + ; false -> scons n (maxN k m) (maxLemma k m n p (leFalse n m triv')) + (insert m k l) + } +} diff --git a/test/succeed/conat.ma b/test/succeed/conat.ma new file mode 100644 --- /dev/null +++ b/test/succeed/conat.ma @@ -0,0 +1,59 @@ +sized codata CoNat : Size -> Set +{ zero : [i : Size] -> CoNat ($ i) +; succ : [i : Size] -> CoNat i -> CoNat ($ i) +} + +sized codata CoNatEq : (i : Size) -> CoNat i -> CoNat i -> Set +{ eqz : [i : Size] -> CoNatEq ($ i) (zero i) (zero i) +; eqs : [i : Size] -> (n : CoNat i) -> (m : CoNat i) -> + CoNatEq i n m -> CoNatEq ($ i) (succ i n) (succ i m) +} + +cofun add : [i : Size] -> CoNat i -> CoNat i -> CoNat i +{ add ($ i) (zero .i) n = n +; add ($ i) (succ .i m) n = succ i (add i m n) +} + +cofun mult : [i : Size] -> CoNat i -> CoNat i -> CoNat i +{ mult ($ i) (zero .i) n = zero i +; mult ($ i) (succ .i m) (zero .i ) = zero i +; mult ($ i) (succ .i m) (succ .i n) = succ i (add i n (mult i m (succ i n))) +} + +{- +-- addmult n m = n*m + m +cofun addmult : [i : Size] -> CoNat # -> CoNat i -> CoNat i +{ addmult i (zero .#) n = n +; addmult i (succ .# m) n = add i n (addmult i m n) +} +-} + +-- (n + 1)^(m + 1) = (n+1) * (n+1) ^ m = (n+1) ^ m + n * (n+1) ^ m +-- expinc m n = (n+1) ^ m +-- expinc 0 n = 1 +-- expinc (m+1) n = (n+1) * expinc m n = addmult n (expinc m n) + +-- cofun expinc : [i : Size] -> CoNat # -> CoNat i -> CoNat i + +-- pexp m n = (n+1)^m - 1 +-- pexp 0 n = 0 +-- pexp (m+1) 0 = 0 +-- pexp (m+1) 1 = 2^(m+1) - 1 -- ??? +-- pexp (m+1) (n+2) = 1 + n + (n+2) * pexp m (n+2) +-- (n + 2)^(m + 1) = (n+2) * (n+2) ^ m = (n+2) ^ m + n * (n+1) ^ m +{- +cofun exp : [i : Size] -> CoNat i -> CoNat i -> CoNat i +{ exp ($ i) (zero .i ) n = succ i (zero i) +; exp ($ i) (succ .i m) (zero .i) = zero i +; exp ($ i) (succ .i m) (succ .i n) = succ i (case i + { ($ j) -> case n of + { (zero .j) -> + ; (succ .j n) -> + } + }) +} + +(zero .i)) = succ i (zero i) +; exp ($ i) (succ .i m) (succ .i (zero .i)) = succ i (zero i) + +-} diff --git a/test/succeed/countConstructors.ma b/test/succeed/countConstructors.ma new file mode 100644 --- /dev/null +++ b/test/succeed/countConstructors.ma @@ -0,0 +1,35 @@ +-- 2010-01-13 + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun plus : Nat -> Nat -> Nat {} + +mutual { + fun f1 : Nat -> Nat + { f1 zero = zero + ; f1 (succ zero) = zero + ; f1 (succ (succ n)) = g1 n + } + + fun g1 : Nat -> Nat + { g1 zero = zero + ; g1 (succ n) = f1 (succ (succ n)) + } +} + +mutual { + fun f : Nat -> Nat + { f zero = zero + ; f (succ zero) = zero + ; f (succ (succ n)) = g n + } + + fun g : Nat -> Nat + { g zero = zero + ; g (succ n) = plus (f n) (plus (f (succ n)) (f (succ (succ n)))) + } +} + diff --git a/test/succeed/crazys.ma b/test/succeed/crazys.ma new file mode 100644 --- /dev/null +++ b/test/succeed/crazys.ma @@ -0,0 +1,19 @@ +sized data SNat : Size -> Set +{ +zero : (i : Size ) -> SNat ($ i); +succ : (i : Size ) -> SNat i -> SNat ($ i) +} + +fun o2e : (i : Size ) -> SNat i -> SNat i +{ +o2e .($ i) (zero i) = zero _; +o2e .($ $ i) (succ .($ i) (zero i)) = zero _; +o2e .($ $ i) (succ .($ i) (succ i x)) = succ _ (succ _ (o2e _ x )) +} + +-- "permutating size arguments" +fun crazy : (i : Size ) -> (j : Size ) -> SNat i -> SNat j -> SNat # +{ +crazy .($ i) j (zero i) y = y; +crazy .($ i) j (succ i x) y = succ _ (crazy _ _ y (o2e _ x)) +} diff --git a/test/succeed/drop.ma b/test/succeed/drop.ma new file mode 100644 --- /dev/null +++ b/test/succeed/drop.ma @@ -0,0 +1,18 @@ + +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +sized codata Stream : Size -> Set { + cons : (i : Size) -> SNat # -> Stream i -> Stream ($ i) +} + +-- drop the first elements of a stream + +fun drop : (i : Size) -> SNat i -> Stream # -> Stream # +{ + drop .($ i) (zero i) xs = xs ; + drop .($ i) (succ i y) (cons .# x xs) = drop i y xs +} diff --git a/test/succeed/eta.ma b/test/succeed/eta.ma new file mode 100644 --- /dev/null +++ b/test/succeed/eta.ma @@ -0,0 +1,10 @@ +data P (A : Set) : (A -> A) -> Set +{ + inn : (out : A -> A) -> P A out +} + +fun bla : (A : Set) -> (f : (A -> A) -> (A -> A)) -> + P (A -> A) f -> P (A -> A) (\ x -> f x) +{ + bla A f p = p -- (c .(A -> A) f) = c (A -> A) (\ x -> f x) +} diff --git a/test/succeed/eta_unit.ma b/test/succeed/eta_unit.ma new file mode 100644 --- /dev/null +++ b/test/succeed/eta_unit.ma @@ -0,0 +1,47 @@ +-- 2009-06-25 eta expansion for the unit type + +data Unit : Set +{ + unit : Unit +} + +fun P : Unit -> Set +{ + P unit = Unit +} + +fun p : (u : Unit) -> P u +{ + p x = unit +} + +fun q : (u : Unit) -> P u +{ + q unit = unit +} + +-- what also should work is +-- q .unit = unit + +-- 2009-09-19 + +data Bool : Set +{ true : Bool +; false : Bool +} + +let r' : Bool -> Unit + = \ b -> unit + +let pr' : (b : Bool) -> P (r' b) + = \ b -> unit + +fun r : Bool -> Unit +{ r true = unit +; r false = unit +} + +-- definitions need also to be eta-expanded +-- otherwise the following does not typecheck +let pr : (b : Bool) -> P (r b) + = \ b -> unit diff --git a/test/succeed/exists.ma b/test/succeed/exists.ma new file mode 100644 --- /dev/null +++ b/test/succeed/exists.ma @@ -0,0 +1,28 @@ +-- 2010-03-28 Exists and Bracket via parametric function types +-- 2012-01-22 parameters gone from constructors + +data Sigma (A : Set)(B : A -> Set) : Set +{ pair : (fst : A) -> (snd : B fst) -> Sigma A B +} + +data Subset (A : Set)(B : A -> Set) : Set +{ put : (get : A) -> [prf : B get] -> Subset A B +} + +data Exists (A : Set)(B : A -> Set) : Set +{ exI : [a : A] -> (prop : B a) -> Exists A B +} + +fun exE : [A : Set] -> [B : A -> Set] -> [C : Set] -> + Exists A B -> ([a : A] -> B a -> C) -> C +{ exE A B C (exI a b) k = k a b +} + +data Bracket (A : Set) : Set +{ bI : [a : A] -> Bracket A +} + +fun bE : [A : Set] -> [C : Set] -> Bracket A -> ([A] -> C) -> C +{ bE A C (bI a) k = k a +} + diff --git a/test/succeed/fib.ma b/test/succeed/fib.ma new file mode 100644 --- /dev/null +++ b/test/succeed/fib.ma @@ -0,0 +1,137 @@ +-- 2012-01-22 parameters gone from constructors + +data Nat : Set { + zero : Nat; + succ : (n : Nat) -> Nat +} + +fun add : Nat -> Nat -> Nat { + add zero = \y -> y; + add (succ x) = \y -> succ (add x y) +} + +sized codata Stream : Size -> Set { + cons : (i : Size) -> Nat -> Stream i -> Stream ($ i) +} + +fun tail : Stream # -> Stream # { + tail (cons .# x xs) = xs +} + +fun head : Stream # -> Nat { + head (cons .# x xs) = x +} + +{- +norec head : (i : Size) -> Stream ($ i) -> Nat { + head .($ i) (cons i n ns) = n +} + +cofun zipWith : (Nat -> Nat -> Nat ) -> ( i : Size ) + -> Stream i -> Stream i -> Stream i { + zipWith f ($ i) as bs = + cons i (f (head i as) (head i bs)) (zipWith f i (tail i as) (tail i bs)) +} +-} + +fun nth : Nat -> Stream # -> Nat { + nth zero xs = head xs; + nth (succ x) xs = nth x (tail xs) +} + +let one : Nat = (succ zero) + +cofun fib' : (x : Nat ) -> (y : Nat ) -> (i : Size ) -> Stream i +{ + fib' x y ($ i) = cons _ x (fib' y (add x y) _) +} +let fib : Stream # = (fib' one one _) + + +let four : Nat = (succ (succ (succ one))) + +-- fib(four) = 5 +eval let fibfour : Nat = nth four fib + + +-------------------------------------------- +-------------------------------------------- + +data Leq : Nat -> Nat -> Set +{ +lqz : (x : Nat ) -> Leq zero x ; +lqs : (x : Nat ) -> (y : Nat ) -> Leq x y -> Leq (succ x) (succ y) +} + +sized codata Increasing : Size -> Stream # -> Set +{ +inc : (i : Size ) -> (x : Nat ) -> (y : Nat ) -> Leq x y -> (tl : Stream # ) -> + Increasing i (cons # y tl) -> + Increasing ($ i) (cons # x (cons # y tl)) +} + + +data Eq (+ A : Set)(a : A) : A -> Set +{ refl : Eq A a a +} + +let proof : Eq (Stream #) (tail fib) (tail fib) = refl + + + +let double : Stream # -> Stream # = \s -> cons _ (head s) s + +data Bool : Set +{ +tt : Bool; +ff : Bool +} + +fun leq : Nat -> Nat -> Bool +{ +leq zero y = tt; +leq (succ x) zero = ff ; +leq (succ x) (succ y) = leq x y +} + +fun ite : Bool -> (A : Set ) -> A -> A -> A +{ +ite tt A a1 a2 = a1; +ite ff A a1 a2 = a2 +} + +cofun merge : (i : Size ) -> (Nat -> Nat -> Bool) -> Stream # -> Stream # -> Stream i +{ +merge ($ i) le (cons .# x xs) (cons .# y ys) = + ite (le x y) (Stream _) + (cons _ x (merge _ le xs (cons _ y ys))) + (cons _ y (merge _ le (cons _ x xs) ys)) +} + +fun first : (A : Set ) -> (B : Set ) -> A -> B -> A +{ +first A B a b = a +} + +-------------------- + +cofun map : (i : Size) -> (Nat -> Nat) -> Stream i -> Stream i +{ +map ($ i) f (cons .i x xl) = cons _ (f x) (map _ f xl) +} + +{- +-- 2012-01-22 constructor are no longer inferable! +let suc : Nat -> Nat = \ x -> succ x +-- 2012-01-25 constructor recognition also for function types +-} + +cofun evil : (i : Size) -> Stream i +{ +evil ($ i) = map _ succ (cons _ zero (evil _)) +} + +-- eval const zzz : Nat = head # (z #) + + + diff --git a/test/succeed/fibDeep.ma b/test/succeed/fibDeep.ma new file mode 100644 --- /dev/null +++ b/test/succeed/fibDeep.ma @@ -0,0 +1,87 @@ +-- 2012-01-22 parameters gone from constructors + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ add zero = \ y -> y +; add (succ x) = \ y -> succ (add x y) +} + +sized codata Stream (+ A : Set) : Size -> Set { + cons : [i : Size] -> A -> Stream A i -> Stream A ($ i) +} + +fun head : [A : Set] -> [i : Size] -> Stream A ($ i) -> A +{ head A i (cons .i a as) = a +} + +fun tail : [A : Set] -> [i : Size] -> Stream A ($ i) -> Stream A i +{ tail A i (cons .i a as) = as +} + +cofun zipWith : [A : Set] -> [B : Set] -> [C : Set] -> (A -> B -> C) -> + [i : Size] -> Stream A i -> Stream B i -> Stream C i +{ zipWith A B C f ($ i) (cons .i a as) (cons .i b bs) = + cons i (f a b) (zipWith A B C f i as bs) +} + +cofun adds : [i : Size] -> Stream Nat i -> Stream Nat i -> Stream Nat i +{ adds ($ i) (cons .i a as) (cons .i b bs) = + cons i (add a b) (adds i as bs) +} + +let one : Nat = succ zero + +{- Size matching + +at type [i : Size] -> Co i one can match i against ($ j) +since for i = 0, Co i is the set of all terms + +type checking rule + + i:Size, j < i, i --> $ j |- e : Gamma -> Co ($ j) + ------------------------------------------------- + case i { ($ j) -> e } : Gamma -> Co i + +basically, there is an analysis whether the type of the case is +"everything" (opposite of empty). + + -} + +cofun fib' : [i : Size] -> Stream Nat i +{ + fib' i = case i + { ($ j) -> cons j zero (case j + { ($ k) -> cons k one (zipWith Nat Nat Nat add k + (fib' k) + (tail Nat k (fib' ($ k))))})} +} + +{- we can pull one case into the pattern match, but not both -} + +cofun fib : [i : Size] -> Stream Nat i +{ fib ($ i) = cons i zero (case i + { ($ j) -> cons j one (adds j (fib j) (tail Nat j (fib i)))}) +} + +{- blueprint +cofun fib : [i : Size] -> Stream Nat i +{ fib ? = cons ? zero + (cons ? one (adds ? (fib ?) (tail Nat ? (fib ?)))) +} +-- UNSOUND +cofun fib : [i : Size] -> Stream Nat i +{ fib ($$ i) = cons ($ i) zero + (cons i one (adds i (fib i) (tail Nat ($ i) (fib ($ i))))) +} +-} + +{- the question is how to facilitate inference for this? + We need to insert case splits at the appropriate positions. + Why not, this is a form of type reconstruction. + Relies on bidirectional type checking. + Currently, MiniAgda does not check constructors, but infers them, which is bad. + -} diff --git a/test/succeed/gcd-either.ma b/test/succeed/gcd-either.ma new file mode 100644 --- /dev/null +++ b/test/succeed/gcd-either.ma @@ -0,0 +1,44 @@ +-- 2011-12-16 Andreas, gcd example + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; suc : [i : Size] -> Nat i -> Nat ($ i) +} + +-- subtracting two numbers with minus yields the difference +-- plus a bit indicating the bigger number of the two + +data Either : +Size -> +Size -> Set +{ left : [i,j : Size] -> Nat i -> Either i j +; right : [i,j : Size] -> Nat j -> Either i j +} + +fun minus : [i,j : Size] -> Nat i -> Nat j -> Either i j +{ minus i j (zero (i > i')) m = right i j m +; minus i j (suc (i > i') n) (zero (j > j')) = left i j (suc i' n) +; minus i j (suc (i > i') n) (suc (j > j') m) = minus i' j' n m +} + +{- UNUSED +fun esuc : [i,j : Size] -> Either i j -> Either $i $j +{ esuc i j (left .i .j n) = left $i $j (suc i n) +; esuc i j (right .i .j n) = right $i $j (suc j n) +} +-} + +mutual { + + fun gcd : [i,j : Size] -> Nat i -> Nat j -> Nat # + { gcd i j (zero (i > i')) m = m + ; gcd i j (suc (i > i') n) (zero (j > j')) = suc i' n + ; gcd i j (suc (i > i') n) (suc (j > j') m) = + gcd_aux i j i' j' n m (minus i' j' n m) + } + + fun gcd_aux : [i,j : Size] -> [i' < i] -> [j' < j] -> Nat i' -> Nat j' -> + Either i' j' -> Nat # + { gcd_aux i j i' j' n m (left .i' .j' n') = gcd i' j n' (suc j' m) + ; gcd_aux i j i' j' n m (right .i' .j' m') = gcd i j' (suc i' n) m' + } + +} diff --git a/test/succeed/hamming.ma b/test/succeed/hamming.ma new file mode 100644 --- /dev/null +++ b/test/succeed/hamming.ma @@ -0,0 +1,55 @@ +-- 2012-01-22 parameters gone from constructors + +-- Nat --------------------------------------------------------------- + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ add zero = \y -> y +; add (succ x) = \y -> succ (add x y) +} + +let double : Nat -> Nat + = \ n -> add n n +let triple : Nat -> Nat + = \ n -> add n (double n) + +fun leq : Nat -> Nat -> [C : Set] -> C -> C -> C +{ leq zero y C tt ff = tt +; leq (succ x) zero C tt ff = ff +; leq (succ x) (succ y) C tt ff = leq x y C tt ff +} + +-- Stream ------------------------------------------------------------ + +sized codata Stream (+ A : Set) : Size -> Set +{ + cons : [i : Size] -> A -> Stream A i -> Stream A ($ i) +} + +cofun map : [A : Set] -> [B : Set] -> [i : Size] -> + (A -> B) -> Stream A i -> Stream B i +{ + map A B ($ i) f (cons .i x xl) = cons _ (f x) (map A B _ f xl) +} + +cofun merge : [i : Size] -> Stream Nat i -> Stream Nat i -> Stream Nat i +{ + merge ($ i) (cons .i x xs) (cons .i y ys) = + leq x y (Stream Nat _) + (cons _ x (merge _ xs (cons _ y ys))) + (cons _ y (merge _ (cons _ x xs) ys)) +} + + +-- Hamming function -------------------------------------------------- + +cofun ham : [i : Size] -> Stream Nat i +{ + ham ($ i) = cons _ (succ zero) + (merge i (map Nat Nat i double (ham i)) + (map Nat Nat i triple (ham i))) +} diff --git a/test/succeed/ho.ma b/test/succeed/ho.ma new file mode 100644 --- /dev/null +++ b/test/succeed/ho.ma @@ -0,0 +1,21 @@ +data Bool : Set +{ + tt : Bool; + ff : Bool +} + +fun apply : (Bool -> Bool) -> Bool -> Bool +{ +apply f b = f b +} + +fun neg : Bool -> Bool +{ +neg tt = ff; +neg ff = tt +} + +let f : Bool = apply neg tt + +let t : Bool = apply (\ x -> tt) ff + diff --git a/test/succeed/implicitSizeVarUsedExplicitely.ma b/test/succeed/implicitSizeVarUsedExplicitely.ma new file mode 100644 --- /dev/null +++ b/test/succeed/implicitSizeVarUsedExplicitely.ma @@ -0,0 +1,37 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun leq : Nat -> Nat -> Bool {} + +fun plus : [A : Set] -> A -> A -> A {} + +sized data List : Size -> Set +{ nil : (i : Size) -> List ($ i) +; cons : [i : Size] -> Nat -> List i -> List ($ i) +} + +fun filter : [i : Size] -> List i -> List i +{ filter .($ i) (nil i) = nil i -- Size variables are resurrected +; filter .($ i) (cons i n l) = plus (List ($ i)) (filter _ l) (cons _ n (filter _ l)) +} + +fun quicksort : [i : Size] -> List i -> List # +{ quicksort .($ i) (nil i) = nil _ +; quicksort .($ i) (cons i n l) = + plus (List #) (quicksort _ (filter i l)) (cons _ n (quicksort _ (filter i l))) +} + +data Id (A : Set)(a : A) : A -> Set +{ refl : Id A a a +} +{- +let p1 : (i : Size) -> Id (List #) (nil i) (nil #) + = \ i -> refl (List #) (nil i) +-} diff --git a/test/succeed/lengthCoList.ma b/test/succeed/lengthCoList.ma new file mode 100644 --- /dev/null +++ b/test/succeed/lengthCoList.ma @@ -0,0 +1,89 @@ +-- 2012-01-22 parameters gone from constructors + +sized data Nat : Size -> Set +{ + zero : [i : Size] -> Nat ($ i); + succ : [i : Size] -> Nat i -> Nat ($ i); +} + + +sized codata Colist (A : Set) : Size -> Set +{ + nil : [i : Size] -> Colist A ($ i); + cons : [i : Size] -> A -> Colist A i -> Colist A ($ i) +} + +cofun olist' : [i : Size] -> Colist (Nat #) i +{ +olist' ($ i) = cons i (zero #) (olist' i) +} + +{- +-- not allowed because no inductive argument with i +fun length : [i : Size] -> [A : Set] -> Colist A i -> Nat i +{ +length ($ i) .A (nil A .i) = zero i ; +length ($ i) .A (cons A .i a as) = succ i (length i A as) +} + +eval let diverge : Nat # = length # (Nat #) (olist' #) +-} + +sized codata CoNat : Size -> Set +{ + cozero : [i : Size] -> CoNat ($ i); + cosucc : [i : Size] -> CoNat i -> CoNat ($ i) +} + +let z : CoNat # = cozero # + +-- allowed because i used in coinductive result +cofun length2 : [i : Size] -> [A : Set] -> Colist A i -> CoNat i +{ +length2 ($ i) A (nil .i) = cozero i; +length2 ($ i) A (cons .i a as) = cosucc i (length2 i A as) +} + +cofun omega' : [i : Size] -> CoNat i +{ +omega' ($ i) = cosucc i (omega' i) +} + +let omega : CoNat # = omega' # + +-- not ok because size not used in inductive argument +-- fun convert1 : [i : Size] -> CoNat i -> Nat i +-- { +-- convert1 ($ i) (cozero .i) = zero i; +-- convert1 ($ i) (cosucc i x) = succ i (convert1 i x) +-- } + +-- the following must be cofun +cofun convert2 : [i : Size] -> Nat i -> CoNat i +{ +convert2 ($ i) (zero .i) = cozero i; +convert2 ($ i) (succ .i x) = cosucc i (convert2 i x) +} + +-- NOT ok +{- +fun convert2' : [i : Size] -> Nat i -> CoNat i +{ convert2' i (zero (i > j)) = cozero j +; convert2' i (succ (i > j) x) = cosucc j (convert2' j x) +} +-} + +-- also ok +fun convert3 : [i : Size] -> Nat i -> CoNat # +{ +convert3 i (zero (i > j)) = cozero #; +convert3 i (succ (i > j) x) = omega' # +} + +-- also ok +cofun convert4 : [i : Size] -> Nat i -> CoNat i +{ +convert4 ($ i) (zero .i) = cozero ($ i) ; +convert4 ($ i) (succ .i x) = cosucc i (convert4 i x) +} + diff --git a/test/succeed/list.ma b/test/succeed/list.ma new file mode 100644 --- /dev/null +++ b/test/succeed/list.ma @@ -0,0 +1,5 @@ +data List (A : Set) : Set +{ + nil : List A ; + cons : A -> List A -> List A +} diff --git a/test/succeed/logic.ma b/test/succeed/logic.ma new file mode 100644 --- /dev/null +++ b/test/succeed/logic.ma @@ -0,0 +1,72 @@ +-- 2012-01-22 parameters gone from constructors + +data Id (A : Set) (a : A) : A -> Set +{ refl : Id A a a +} + +fun subst : (A : Set) -> (a : A) -> (b : A) -> Id A a b -> + (P : A -> Set) -> P a -> P b +{ subst A a .a (refl {-.A .a-}) P x = x +} + +-- this demonstrates eta expansion at the identity type +let bla : (A : Set) -> (a : A) -> (p : Id A a a) -> + (P : A -> Set) -> (x : P a) -> + Id (P a) x (subst A a a p P x) + = \ A -> \ a -> \ p -> \ P -> \ x -> refl -- (P a) x + +fun resp : (A : Set) -> (a : A) -> (b : A) -> Id A a b -> + (C : Set) -> (f : A -> C) -> Id C (f a) (f b) +{ resp A a .a (refl {-.A .a-}) C f = refl -- C (f a) +} + +-- Needs heterogeneous equality +-- fun resp : (A : Set) -> (a : A) -> (b : A) -> Id A a b -> (P : A -> Set) -> (f : (x : A) -> P x) -> Id (P a) (f a) (f b) +-- { resp A a .a (refl .A .a) P f = refl (P a) (f a) +-- } + +data True : Set +{ trueI : True +} + +data False : Set +{ } + +let falseIrr : (p : False) -> (q : False) -> Id False p q + = \ p -> \ q -> refl -- False p + +fun falseE : False -> (A : Set) -> A +{ } + +data And (A : Set) (B : Set) : Set +{ andI : (andE1 : A) -> (andE2 : B) -> And A B +} + +data Forall (A : Set) (B : A -> Set) : Set +{ forallI : (forallE : (a : A) -> B a) -> Forall A B +} + +fun shapeForallTrue : (A : Set) -> (p : Forall A (\ a -> True)) -> + Id (Forall A (\ a -> True)) p (forallI {- A (\ a -> True)-} (\ a -> trueI)) +{ shapeForallTrue A p = refl -- (Forall A (\ a -> True)) p +} + +data Prop (A : Set) : Set +{ true : Prop A +; false : Prop A +; and : Prop A -> Prop A -> Prop A +; forall : (A -> Prop A) -> Prop A +} + +fun Proof : (A : Set) -> Prop A -> Set +{ Proof A (true) = True +; Proof A (false) = False +; Proof A (and p q) = And (Proof A p) (Proof A q) +; Proof A (forall h) = Forall A (\ a -> Proof A (h a)) +} + +fun proofIrr : (A : Set) -> (P : Prop A) -> (p : Proof A P) -> (q : Proof A P) -> Id (Proof A P) p q +{ proofIrr A (true) p q = refl -- True p +; proofIrr A (false) p q = refl -- False p +-- ; proofIrr A (and .A P Q) (andI .(Proof A P) .(Proof A Q) p1 p2) (andI .(Proof A P) .(Proof A Q) q1 q2) = (proofIrr A P p1 p2) (proofIrr A Q q1 q2) -- etc pp +} diff --git a/test/succeed/lossyIdentityOnStreams.ma b/test/succeed/lossyIdentityOnStreams.ma new file mode 100644 --- /dev/null +++ b/test/succeed/lossyIdentityOnStreams.ma @@ -0,0 +1,10 @@ +-- 2012-01-22 parameters gone from constructors + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +cofun sid : (A : Set) -> (i : Size) -> Stream A ($ i) -> Stream A i +{ + sid A ($ i) (cons .($ i) x xs) = cons _ x (sid A i xs) +} diff --git a/test/succeed/magicVecLookupProofIrr.ma b/test/succeed/magicVecLookupProofIrr.ma new file mode 100644 --- /dev/null +++ b/test/succeed/magicVecLookupProofIrr.ma @@ -0,0 +1,43 @@ +-- proof irrelevance via polymorphism + +data Sigma (A : Set) (B : A -> Set) : Set +{ pair : (fst : A) -> (snd : B fst) -> Sigma A B +} fields fst, snd + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +data Empty : Set +{ +} + +-- magic = abort does not need the inhabitant p : Empty +fun magic : [A : Set] -> [p : Empty] -> A +{ +} + +data Unit : Set +{ unit : Unit +} + +fun Vec : (A : Set) -> (n : Nat) -> Set +{ Vec A zero = Empty +; Vec A (succ n) = Sigma A (\ z -> Vec A n) +} + +fun Leq : (n : Nat) -> (m : Nat) -> Set +{ Leq zero m = Unit +; Leq (succ n) zero = Empty +; Leq (succ n) (succ m) = Leq n m +} +let Lt : (n : Nat) -> (m : Nat) -> Set + = \ n -> \ m -> Leq (succ n) m + +fun lookup : [A : Set] -> (n : Nat) -> (m : Nat) -> [Lt m n] -> Vec A n -> A +{ lookup A zero m p v = magic A p +; lookup A (succ n) zero p v = fst v -- fst A (\ z -> Vec A n) v +; lookup A (succ n) (succ m) p v = lookup A n m p <| snd v -- (snd A (\ z -> Vec A n) v) +} + diff --git a/test/succeed/mapStream.ma b/test/succeed/mapStream.ma new file mode 100644 --- /dev/null +++ b/test/succeed/mapStream.ma @@ -0,0 +1,11 @@ +-- 2012-01-22 parameters gone from constructors + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +cofun map : (A : Set) -> (B : Set) -> (i : Size) -> + (A -> B) -> Stream A i -> Stream B i +{ + map A B ($ i) f (cons .i x xl) = cons _ (f x) (map A B _ f xl) +} diff --git a/test/succeed/max.ma b/test/succeed/max.ma new file mode 100644 --- /dev/null +++ b/test/succeed/max.ma @@ -0,0 +1,27 @@ +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun leq : Nat -> Nat -> Bool +{ leq zero n = true +; leq (suc m) zero = false +; leq (suc m) (suc n) = leq m n +} + +fun maxN : Nat -> Nat -> Nat +{ maxN n m = case leq n m + { true -> m + ; false -> n + } +} + +let one : Nat = suc zero +let two : Nat = suc one +eval let cmp : Bool = leq one two +eval let bla : Nat = maxN one two diff --git a/test/succeed/measures.ma b/test/succeed/measures.ma new file mode 100644 --- /dev/null +++ b/test/succeed/measures.ma @@ -0,0 +1,172 @@ +-- 2010-03-11 explicit measures +-- inspired by Hongwei Xi, LICS 2001 + +data Bool : Set +{ true : Bool +; false : Bool +} + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +{- rules + +2010-07-16 + +When checking the patterns ps qs of f + + f : As -> mu -> Bs -> C + f ps qs = ... g as ... + +as we reach measure mu in the type, insert it into the context +(reader monad) as the current measure. + +When we reach a mutually defined identifier g of type + + g : Delta -> mu' -> D + +we use it at type + + g : Delta -> mu' < mu -> D + +The constraint mu' < mu guarantees that g is only called at smaller instances. + +How to implement this? + +When checking a mutual block where all identifiers carry a measure +(either all should be measured, or none (then use old termination +check)), we keep the signature of the mutual block around + + g1 : TV1 + ... + gn : TVn + +The types are evaluated. We want a function + + bound :: MeasVal -> TVal -> TVal + bound mu tv = tv' + +such that + + bound mu (Delta -> mu' -> A) = Delta -> mu' < mu -> A + +this can done lazyly, pushing the mu past the pi's until it meets the +measure. If there is no measure, then it just gets propagated to the +end and vanishes. This way, we can handle call to rec. fun.s outside +of the mutual block which can be used unrestrictedly. + +If we have a mu-decoration to values, then we need a view function +which does the pushing in behind the curtains. This could be +integrated in the whnf and closures. + +We do not need to keep "bound-closures" at unevaluated applications, +since we do not treat measures as first-class, the cannot appear +everywhere in a term, only in the types of a mutual fun sig, so they +are just appearing after a telescope. + +-- old rules --------------------------------------------------------- + +When checking the patterns ps qs of f + + f : As -> mu -> Bs -> C + f ps qs = ... g as ... + +as we reach measure mu in the type, insert it into the context +(reader monad) as the current measure. + +When checking the application g as on the rhs, if g is in the set of +mutual functions with f, then during infering the type of g as we will +have its type as + + mu' -> D + +at some point. Then, we simply check whether + + mu' < mu + +Yeah! + +Typing rules for measures + + |-{mu} t : A |-{mu} t : mu' -> A mu' < mu + -------------- mu-Intro -------------------------------- mu-Elim + |- t : mu -> A |-{mu} t : A + +After finishing checking the mutual block, purge the measures from the +types of the mutual functions! + +For nested functions, generalize the rule to: + + |-{mu} t : A + ------------------- mu-Intro + |-{mu'} t : mu -> A + +With this system, one cannot do lexicographic induction by nested induction. + + +Explicit rules for measures ? + mu subtype mu' + x : mu |- t : A x : mu |- t : mu' -> A mu' < mu + -------------- mu-Intro ---------------------------------- mu-Elim + |- \xt : mu -> A x : mu |- t x : A + + -} + +mutual { + + fun even : [i : Size] -> |i,$0| -> Nat i -> Bool + { even i n = even' i n + } + + fun even' : [i : Size] -> |i,0| -> Nat i -> Bool + { even' i (zero (i > j)) = true + ; even' i (succ (i > j) n) = odd' j n + } + + fun odd' : [i : Size] -> |i,0| -> Nat i -> Bool + { odd' i (zero (i > j)) = false + ; odd' i (succ (i > j) n) = even j n + } +} + +{- +mutual { + + fun even : [i : Size] -> |i,$0| -> Nat i -> Bool + { even i n = even' i n + } + + fun even' : [i : Size] -> |i,0| -> Nat i -> Bool + { even' .($ i) (zero i) = true + ; even' .($ i) (succ i n) = odd' i n + } + + fun odd' : [i : Size] -> |i,0| -> Nat i -> Bool + { odd' .($ i) (zero i) = false + ; odd' .($ i) (succ i n) = even i n + } +} +-} + + +{- +let infty : Size = # +let ssuc : Size -> Size = \ i -> $ i + +fun maybeSuc : (b : Bool) -> Size -> Size +{ maybeSuc true i = $ i +; maybeSuc false i = i +} + +fun addSize : N -> Size -> Size +{ addSize zz i = i +; addSize (ss n) i = $ (addSize n i) +} + +fun addSNat : (n : N) -> (i : Size) -> Nat i -> Nat (addSize n i) +{ addSNat zz i m = m +; addSNat (ss n) i m = succ (addSize n i) (addSNat n i m) +} +-} diff --git a/test/succeed/msort-implicit.ma b/test/succeed/msort-implicit.ma new file mode 100644 --- /dev/null +++ b/test/succeed/msort-implicit.ma @@ -0,0 +1,105 @@ +-- erased arguments +-- in the spirit of the implicit CC +-- we only specify the erasure in the types +-- 2012-01-22 parameters gone from constructors + +-- booleans + +data Bool : Set +{ + tt : Bool; + ff : Bool +} + +fun ifthenelse : [A : Set] -> Bool -> A -> A -> A +{ + ifthenelse A tt x y = x; + ifthenelse A ff x y = y +} + +-- homogeneous pairs + +data Pair (+ A : Set) : Set +{ + pair : A -> A -> Pair A +} +-- this yields +-- +-- pair : [A : Set] -> A -> A -> Pair A +-- +-- parameter arguments to constructors are always implicit + +fun pr1 : [A : Set] -> Pair A -> A +{ + pr1 A (pair a b) = a +} + +fun pr2 : [A : Set] -> Pair A -> A +{ + pr2 A (pair a b) = b +} + +-- sized Lists + +sized data SList (+ A : Set) : Size -> Set +{ + nil : [i : Size] -> SList A ($ i) ; + cons : [i : Size] -> A -> SList A i -> SList A ($ i) +} + +-- merge sort + +fun split : [A : Set] -> + [i : Size] -> SList A i -> Pair (SList A i) +{ +split A .($ i) (nil i) + = pair (nil _) (nil _); + +split A .($ ($ i)) (cons .($ i) a (nil i)) + = pair (cons _ a (nil _)) (nil _); + +split A .($ ($ i)) (cons .($ i) a (cons i b as)) + = let rec : Pair (SList A i) = split A _ as + in let l1 : SList A _ = pr1 (SList A _) rec + in let l2 : SList A _ = pr2 (SList A _) rec + in pair (cons _ a l1) (cons _ b l2) +} + +fun merge : [A : Set] -> (leq : A -> A -> Bool) + -> SList A # -> SList A # -> SList A # +{ +merge A leq (nil .#) ys = ys; +merge A leq (cons .# x xs) (nil .#) = cons _ x xs; +merge A leq (cons .# x xs) (cons .# y ys) = ifthenelse (SList A _) + (leq x y) (cons _ x (cons _ y (merge A leq xs ys))) + (cons _ y (cons _ x (merge A leq xs ys))) +} + +fun msort : [A : Set] -> (leq : A -> A -> Bool) -> + [i : Size] -> SList A i -> SList A # +{ + msort A leq .($ j) (nil j) = nil _ ; + msort A leq .($ ($ i)) (cons .($ i) a (nil i)) = + cons _ a (nil _) ; + msort A leq .($ ($ i)) (cons .($ i) a (cons i b l)) = + let sl : Pair (SList A _) = split A _ l + in let l1 : SList A # = msort A leq _ (cons _ a (pr1 (SList A _) sl)) + in let l2 : SList A # = msort A leq _ (cons _ b (pr2 (SList A _) sl)) + in merge A leq l1 l2 +} + + +fun msort' : [A : Set] -> (leq : A -> A -> Bool) -> + ([i : Size] -> SList A i -> Pair (SList A i)) -> + [i : Size] -> SList A i -> SList A # +{ + msort' A leq splt .($ j) (nil j) = nil _ ; + msort' A leq splt .($ ($ i)) (cons .($ i) a (nil i)) = + cons _ a (nil _) ; + msort' A leq splt .($ ($ i)) (cons .($ i) a (cons i b l)) = + let sl : Pair (SList A _) = splt _ l + in let l1 : SList A # = msort' A leq splt _ (cons _ a (pr1 (SList A _) sl)) + in let l2 : SList A # = msort' A leq splt _ (cons _ b (pr2 (SList A _) sl)) + in merge A leq l1 l2 +} + diff --git a/test/succeed/msort.ma b/test/succeed/msort.ma new file mode 100644 --- /dev/null +++ b/test/succeed/msort.ma @@ -0,0 +1,97 @@ +-- 2012-01-22 parameters gone from constructors + +-- booleans + +data Bool : Set +{ + tt : Bool; + ff : Bool +} + +fun ifthenelse : (A : Set) -> Bool -> A -> A -> A +{ + ifthenelse A tt x y = x; + ifthenelse A ff x y = y +} + +-- homogeneous pairs + +data Pair (+ A : Set) : Set +{ + pair : A -> A -> Pair A +} + +fun pr1 : (A : Set) -> Pair A -> A +{ + pr1 A (pair a b) = a +} + +fun pr2 : (A : Set) -> Pair A -> A +{ + pr2 A (pair a b) = b +} + +-- sized Lists + +sized data SList (+ A : Set) : Size -> Set +{ + nil : (i : Size) -> SList A ($ i) ; + cons : (i : Size) -> A -> SList A i -> SList A ($ i) +} + +-- merge sort + +fun split : (A : Set) -> + (i : Size) -> SList A i -> Pair (SList A i) +{ +split A .($ i) (nil i) + = pair (nil _) (nil _); + +split A .($ ($ i)) (cons .($ i) a (nil i)) + = pair (cons _ a (nil _)) (nil _); + +split A .($ ($ i)) (cons .($ i) a (cons i b as)) + = let rec : Pair (SList A i) = split A _ as + in let l1 : SList A _ = pr1 (SList A _) rec + in let l2 : SList A _ = pr2 (SList A _) rec + in pair (cons _ a l1) (cons _ b l2) +} + +fun merge : (A : Set) -> (leq : A -> A -> Bool) + -> SList A # -> SList A # -> SList A # +{ +merge A leq (nil .#) ys = ys; +merge A leq (cons .# x xs) (nil .#) = cons _ x xs; +merge A leq (cons .# x xs) (cons .# y ys) = ifthenelse (SList A _) + (leq x y) (cons _ x (cons _ y (merge A leq xs ys))) + (cons _ y (cons _ x (merge A leq xs ys))) +} + +fun msort : (A : Set) -> (leq : A -> A -> Bool) -> + (i : Size) -> SList A i -> SList A # +{ + msort A leq .($ j) (nil j) = nil _ ; + msort A leq .($ ($ i)) (cons .($ i) a (nil i)) = + cons _ a (nil _) ; + msort A leq .($ ($ i)) (cons .($ i) a (cons i b l)) = + let sl : Pair (SList A _) = split A _ l + in let l1 : SList A # = msort A leq _ (cons _ a (pr1 (SList A _) sl)) + in let l2 : SList A # = msort A leq _ (cons _ b (pr2 (SList A _) sl)) + in merge A leq l1 l2 +} + + +fun msort' : (A : Set) -> (leq : A -> A -> Bool) -> + ((i : Size) -> SList A i -> Pair (SList A i)) -> + (i : Size) -> SList A i -> SList A # +{ + msort' A leq splt .($ j) (nil j) = nil _ ; + msort' A leq splt .($ ($ i)) (cons .($ i) a (nil i)) = + cons _ a (nil _) ; + msort' A leq splt .($ ($ i)) (cons .($ i) a (cons i b l)) = + let sl : Pair (SList A _) = splt _ l + in let l1 : SList A # = msort' A leq splt _ (cons _ a (pr1 (SList A _) sl)) + in let l2 : SList A # = msort' A leq splt _ (cons _ b (pr2 (SList A _) sl)) + in merge A leq l1 l2 +} + diff --git a/test/succeed/nat.ma b/test/succeed/nat.ma new file mode 100644 --- /dev/null +++ b/test/succeed/nat.ma @@ -0,0 +1,53 @@ +-- Mugda (Karl Mehltretter's master thesis) +-- sized natural numbers + +sized data SNat : Size -> Set +{ +zero : [i : Size] -> SNat ($ i); +succ : [i : Size] -> SNat i -> SNat ($ i) +} + +fun add : SNat # -> SNat # -> SNat # +{ +add (zero .#) y = y; +add (succ .# x) y = succ # (add x y) +} + +fun inc : (i : Size) -> (j : Size) -> SNat i -> SNat ($ i) +{ +inc i j x = succ _ x; +} + +fun minus : [i : Size] -> SNat i -> SNat # -> SNat i +{ minus i (zero (i > j)) y = zero j +; minus i x (zero .#) = x +; minus i (succ (i > j) x) (succ .# y) = minus j x y -- subtyping j < i +} + +eval let test : SNat # = + minus # (succ # (succ # (zero #))) (succ # (zero #)) + +-- div n m = floor(n/(m+1)) +fun div : [i : Size] -> SNat i -> SNat # -> SNat i +{ div i (zero (i > j)) y = zero j +; div i (succ (i > j) x) y = succ j (div j (minus j x y) y) +} + +data Bool : Set +{ + tt : Bool; + ff : Bool +} + +fun true : [i : Size] -> SNat i -> Bool +{ +true .($ i) (zero i) = tt; +true .($ i) (succ i x) = true _ x +} + +-- ok size variable is a valid pattern + +fun ok : Size -> Bool +{ + ok i = tt +} diff --git a/test/succeed/non-record.ma b/test/succeed/non-record.ma new file mode 100644 --- /dev/null +++ b/test/succeed/non-record.ma @@ -0,0 +1,4 @@ +data NotARecord (A : Set) (B : Set) : Set +{ + pair : (fst : A) -> B -> NotARecord A B +} diff --git a/test/succeed/old_stream.ma b/test/succeed/old_stream.ma new file mode 100644 --- /dev/null +++ b/test/succeed/old_stream.ma @@ -0,0 +1,223 @@ +-- 2012-01-22 parameters gone from constructors + +-- Booleans ---------------------------------------------------------- + +data Bool : Set +{ tt : Bool +; ff : Bool +} + +fun ifthenelse : Bool -> (A : Set) -> A -> A -> A +{ ifthenelse tt A a1 a2 = a1 +; ifthenelse ff A a1 a2 = a2 +} + +-- Nat --------------------------------------------------------------- + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ add zero = \ y -> y +; add (succ x) = \ y -> succ (add x y) +} + +fun leq : Nat -> Nat -> Bool +{ leq zero y = tt +; leq (succ x) zero = ff +; leq (succ x) (succ y) = leq x y +} + +-- Stream ------------------------------------------------------------ + +sized codata Stream (+ A : Set) : Size -> Set +{ cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +fun tail : (A : Set) -> (i : Size) -> Stream A ($ i) -> Stream A i +{ tail A i (cons .i x xs) = xs +} + +fun head : (A : Set) -> (i : Size) -> Stream A ($ i) -> A +{ head A i (cons .i x xs) = x +} + +fun nth : Nat -> Stream Nat # -> Nat +{ nth zero xs = head Nat # xs +; nth (succ x) xs = nth x (tail Nat # xs) +} + +-- map, zip, merge --------------------------------------------------- + +cofun map : (A : Set) -> (B : Set) -> (i : Size) -> + (A -> B) -> Stream A i -> Stream B i +{ +map A B ($ i) f (cons .i x xl) = cons _ (f x) (map A B _ f xl) +} + +cofun zipWith : (A : Set) -> (B : Set) -> (C : Set) -> + (A -> B -> C) -> (i : Size) -> + Stream A i -> Stream B i -> Stream C i +{ + zipWith A B C f ($ i) (cons .i a as) (cons .i b bs) = + cons i (f a b) (zipWith A B C f i as bs) +} + +cofun merge : (i : Size) -> (Nat -> Nat -> Bool) -> + Stream Nat i -> Stream Nat i -> Stream Nat i +{ +merge ($ i) le (cons .i x xs) (cons .i y ys) = + ifthenelse (le x y) (Stream Nat _) + (cons _ x (merge _ le xs (cons _ y ys))) + (cons _ y (merge _ le (cons _ x xs) ys)) +} + +{- +cofun merge : (i : Size) -> (Nat -> Nat -> Bool) -> + Stream Nat i -> Stream Nat i -> Stream Nat i +{ +merge .($ i) le (cons .i x xs) (cons i y ys) = + ifthenelse (le x y) (Stream Nat _) + (cons _ x (merge _ le xs (cons _ y ys))) + (cons _ y (merge _ le (cons _ x xs) ys)) +} +-} + +-- Hamming function -------------------------------------------------- + +let one : Nat = succ zero +let two : Nat = succ one +let three : Nat = succ two +let four : Nat = succ three +let five : Nat = succ four + +let double : Nat -> Nat + = \ n -> add n n +let triple : Nat -> Nat + = \ n -> add n (double n) + +cofun ham : (i : Size) -> Stream Nat i +{ + ham ($ i) = cons _ one (merge i leq (map Nat Nat i double (ham i)) + (map Nat Nat i triple (ham i))) +} + + +{- +-- THIS SHOULD NOT TYPECHECK!! +cofun map2 : (i : Size) -> (Nat -> Nat) -> Stream Nat i -> Stream Nat i +{ +map2 .($ ($ i)) f (cons .Nat .($ i) u (cons .Nat i x xl)) = + cons _ (f u) (cons _ (f x) (map2 _ f xl)) +} + +cofun ham2 : (i : Size) -> Stream Nat i +{ + ham2 ($ i) = cons _ one (merge i leq (map2 i double (ham2 i)) + (map2 i triple (ham2 i))) +} + +-- THIS LOOPS!!! +eval let bla : Nat = nth one (ham2 #) +-} + +-- Fibonacci stream -------------------------------------------------- + +{- NOT YET IMPLEMENTED: rational sizes + WILL NOT IMPLEMENT -- see fibDeep.ma + +cofun fib : (i : Size) -> Stream Nat (i + i) +{ + fib (i + 1) = cons _ zero (cons _ one (zipWith Nat Nat Nat add + i (fib i) (tail Nat i (fib (i + 1/2))))) +} + +-} + +{- distinguish fib from the following + +cofun bad : [i : Size] -> Stream Nat i +{ + bad ($ ($ i)) = cons _ zero (tail Nat _ (bad ($ i))) +} + +-} + +cofun fib : (i : Size) -> Stream Nat i +{ + fib ($ i) = cons _ zero (zipWith Nat Nat Nat add i + (cons _ one (fib i)) (fib i)) +} + + + +cofun fibIter' : (x : Nat ) -> (y : Nat ) -> (i : Size) -> Stream Nat i +{ + fibIter' x y ($ i) = cons _ x (fibIter' y (add x y) _) +} +let fibIter : Stream Nat # = (fibIter' one one _) + + +-------------------------------------------- + +-- fibIter(4) = 5 +eval let fibIter4 : Nat = nth four fibIter + +eval let fib1 : Nat = nth one (fib #) +eval let fib2 : Nat = nth two (fib #) +eval let fib3 : Nat = nth three (fib #) +eval let fib4 : Nat = nth four (fib #) +eval let fib5 : Nat = nth five (fib #) + + +-------------------------------------------- + +data Leq : Nat -> Nat -> Set +{ +lqz : (x : Nat ) -> Leq zero x ; +lqs : (x : Nat ) -> (y : Nat ) -> Leq x y -> Leq (succ x) (succ y) +} + +sized codata Increasing : Size -> Stream Nat # -> Set +{ +inc : (i : Size) -> (x : Nat) -> (y : Nat) -> Leq x y -> (tl : Stream Nat #) -> + Increasing i (cons # y tl) -> + Increasing ($ i) (cons # x (cons # y tl)) +} + + +data Eq (+ A : Set ) : A -> A -> Set +{ +refl : (a : A) -> Eq A a a +} + +let proof : Eq (Stream Nat #) (tail Nat # fibIter) (tail Nat # fibIter) = refl (tail Nat # fibIter) + + +let succ_ : Nat -> Nat = \ x -> succ x + +cofun evil : (i : Size ) -> Stream Nat i +{ +evil ($ i) = map Nat Nat _ succ_ (cons _ zero (evil _)) +} + +-- eval const zzz : Nat = head # (z #) + + + +-- convolution (Shin-Cheng Mu) + +let cons_ : [A : Set] -> [i : Size] -> A -> Stream A i -> Stream A $i + = \ A i a as -> cons i a as + +cofun dmerge : (A : Set) -> (i : Size) -> Stream (Stream A i) i -> Stream A i +{ +dmerge A ($ i) (cons .i ys yss) = + cons i (head A _ ys) (dmerge A i + (zipWith A (Stream A _) (Stream A _) (cons_ A _) i + (tail A _ ys) yss)) +} + + diff --git a/test/succeed/oldnat.ma b/test/succeed/oldnat.ma new file mode 100644 --- /dev/null +++ b/test/succeed/oldnat.ma @@ -0,0 +1,55 @@ +-- Mugda (Karl Mehltretter's master thesis) +-- sized natural numbers + +sized data SNat : Size -> Set +{ +zero : [i : Size] -> SNat ($ i); +succ : [i : Size] -> SNat i -> SNat ($ i) +} + +fun add : SNat # -> SNat # -> SNat # +{ +add (zero .#) y = y; +add (succ .# x) y = succ # (add x y) +} + +fun inc : (i : Size) -> (j : Size) -> SNat i -> SNat ($ i) +{ +inc i j x = succ _ x; +} + +fun minus : [i : Size] -> SNat i -> SNat # -> SNat i +{ +minus .($ i) (zero i) y = zero _; +minus i x (zero .#) = x; +minus .($ i) (succ i x) (succ .# y) = minus _ x y -- subtyping i < ($ i) +} + +eval let test : SNat # = + minus # (succ # (succ # (zero #))) (succ # (zero #)) + +-- div n m = floor(n/(m+1)) +fun div : [i : Size] -> SNat i -> SNat # -> SNat i +{ +div .($ i) (zero i) y = zero _ ; +div .($ i) (succ i x) y = succ _ (div _ (minus _ x y) y) +} + +data Bool : Set +{ + tt : Bool; + ff : Bool +} + +fun true : [i : Size] -> SNat i -> Bool +{ +true .($ i) (zero i) = tt; +true .($ i) (succ i x) = true _ x +} + +-- ok size variable is a valid pattern + +fun ok : Size -> Bool +{ + ok i = tt +} diff --git a/test/succeed/omegaInst1.ma b/test/succeed/omegaInst1.ma new file mode 100644 --- /dev/null +++ b/test/succeed/omegaInst1.ma @@ -0,0 +1,28 @@ +-- 2012-02-06 Make sure not to violate < - Constraints by going through infty +-- (not finished) + +fun fix : [F : Size -> Set] + (phi : [i <= #] (f : [j < i] -> F j) -> F i) + [i <= #] -> |i| -> F i +{ fix F phi i = phi i (fix F phi) +} + +cofun Bot : +(i : Size) -> Set +{ Bot i = [j < i] & Bot j +} + +cofun Top : -(i : Size) -> Set +{ Top i = [j < i] -> Top j +} + +fun out : [i : Size] (r : Top $i) -> Top i +{ out i r j = r $j j } + +let inn [i : Size] (t : Top i) : Top $i + = \ j -> t + +let bad [F : Size -> Set] [i <= #] (f : [j < $i] -> F j) : F i + = f i + +fail +let test [F : Size -> Set] = fix F (bad F) diff --git a/test/succeed/omegaInstTailInfty.ma b/test/succeed/omegaInstTailInfty.ma new file mode 100644 --- /dev/null +++ b/test/succeed/omegaInstTailInfty.ma @@ -0,0 +1,106 @@ +{- 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 + +If G is antitone we have a decreasing chain + + G 0 >= G 1 >= ... + +Since all chains are shorter than #, we have a "fixpoint" G gamma +for some gamma < #. + + F # = [j < #] -> G j = G gamma + + [i < #] -> F i + = [i < #] -> [j < i] -> G j (since # is a limit) + = [j < #] -> G j = G gamma + +Anyway, G does not have to have special properties, it is sufficient +that # is a limit, because + + i < # iff i + 1 < # + +so + + j < i < # iff 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. + +-} + +cofun Inf : (F : Size -> Set) -(i : Size) -> Set +{ Inf F i = [j < i] -> F j } + +-- uses that [j < i] -> F j is upper semi-continuous in i +fun uppersemi : [F : Size -> Set] (f : Inf (Inf F) #) -> Inf F # +{ uppersemi F f j = f # j } +{- + have f : [i < #] -> [j < i] -> F j + show f # : [j < #] -> F j + +-} + +data Stream +(A : Set) -(i : Size) +{ scons (shead : [j < i] -> A) (stail : [j < i] -> Stream A j) +} fields shead, stail + +check +cofun repeat : [A : Set] (a : A) [i : Size] |i| -> Stream A i +{ repeat A a ($ i) = scons (\ j -> a) (\ j -> repeat A a j) +} + +check +let tailInf [A : Set] (s : Stream A #) : Stream A # + = s .stail # + + +-- front streams + +data Front +(A : Set) -(i : Size) +{ cons (head : A) (tail : [j < i] -> Front A j) +} fields head, tail + +fun eta : [F : Size -> Set] [i : Size] (f : [j < i] -> F j) [j < i] -> F j +{ eta F i f j = f j } + +fun repeat : [A : Set] (a : A) [i : Size] |i| -> Front A i +{ repeat A a i = cons a (repeat A a) + -- Or: +; repeat A a i = cons a (eta (Front A) i (repeat A a)) +} + +let tailInf [A : Set] (s : Front A #) : Front A # + = s .tail # + + +-- semicontinuity can be used to instantiate quantifiers +-- related to bound normalization + +trustme -- only if F upper semi-continuous +let uppersemicont [F : Size -> Set] (f : [i < #] -> F i) : F # + = f # + +trustme --only if F lower semi-continuous +let lowersemicont [F : Size -> Set] (a : F #) : [i < #] & F i + = (#, a) diff --git a/test/succeed/pred.ma b/test/succeed/pred.ma new file mode 100644 --- /dev/null +++ b/test/succeed/pred.ma @@ -0,0 +1,19 @@ +sized data SNat : Size -> Set +{ zero : [i : Size] -> SNat ($ i) +; succ : [i : Size] -> SNat i -> SNat ($ i) +} + +data MaybeNat (i : Size) : Set +{ nothing : MaybeNat i +; just : SNat i -> MaybeNat i +} + +fun pred' : [i : Size] -> SNat ($ i) -> MaybeNat i +{ pred' i (succ .i n) = just n +; pred' i (zero .i) = nothing +} + +fun pred : (i : Size) -> SNat ($$ i) -> SNat ($ i) +{ pred i (succ .($ i) n) = n +; pred i (zero .($ i)) = zero i +} diff --git a/test/succeed/qsapp.ma b/test/succeed/qsapp.ma new file mode 100644 --- /dev/null +++ b/test/succeed/qsapp.ma @@ -0,0 +1,80 @@ +-- 2010-06-21 Andreas Abel +-- Quicksort (implementation using partition) in MiniAgda + +-- Booleans + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun if : [A : Set] -> Bool -> A -> A -> A +{ if A true t e = t +; if A false t e = e +} + +-- Natural numbers + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun leq : Nat -> Nat -> Bool +{ leq zero n = true +; leq (succ m) zero = false +; leq (succ m) (succ n) = leq m n +} + +-- Lists over natural numbers as a sized inductive type + +sized data List : Size -> Set +{ nil : [i : Size] -> List ($ i) +; cons : [i : Size] -> Nat -> List i -> List ($ i) +} + +-- Partition a list, continuation-style +-- the lists passed to the continuation k are at most as big as the input list + +fun partition : (Nat -> Bool) -> [i : Size] -> List i -> + [A : Set] -> (List i -> List i -> A) -> A +{ partition p i (nil (i > j)) A k = k (nil j) (nil j) +; partition p i (cons (i > j) n l) A k = if A (p n) + (partition p j l A (\ l1 -> \ l2 -> k (cons j n l1) l2)) -- then + (partition p j l A (\ l1 -> \ l2 -> k l1 (cons j n l2))) -- else +} + +-- Quicksort-append +-- qsapp i l1 l2 = append (sort l1) l2 + +fun qsapp : [i : Size] -> List i -> List # -> List # +{ qsapp i (nil (i > j)) acc = acc +; qsapp i (cons (i > j) n l) acc = partition (\ m -> leq m n) j l (List #) + (\ l1 -> \ l2 -> qsapp j l1 (cons # n (qsapp j l2 acc))) +} + +-- Quicksort + +let quicksort : List # -> List # = \ l -> qsapp # l (nil #) + +-- Testing + +let n0 : Nat = zero +let n1 : Nat = succ n0 +let n2 : Nat = succ n1 +let n3 : Nat = succ n2 +let n4 : Nat = succ n3 +let n5 : Nat = succ n4 +let n6 : Nat = succ n5 +let n7 : Nat = succ n6 +let n8 : Nat = succ n7 +let n9 : Nat = succ n8 + +-- qsapp is fast enough even with MiniAgda CBN +let l : List # = + (cons # n4 (cons # n9 (cons # n1 (cons # n7 (cons # n6 + (cons # n4 (cons # n0 (cons # n0 + (cons # n3 (cons # n3 (cons # n3 (cons # n2 (cons # n3 (nil #)))))))))))))) +-- eval -- 2012-02-25 NO LONGER +let l' : List # = quicksort l + diff --git a/test/succeed/quicksort-filter-fragment.ma b/test/succeed/quicksort-filter-fragment.ma new file mode 100644 --- /dev/null +++ b/test/succeed/quicksort-filter-fragment.ma @@ -0,0 +1,36 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun leq : Nat -> Nat -> Bool {} + +fun plus : [A : Set] -> A -> A -> A {} + +sized data List : Size -> Set +{ nil : [i : Size] -> List ($ i) +; cons : [i : Size] -> Nat -> List i -> List ($ i) +} + +fun filter : [i : Size] -> List i -> List i +{ filter .($ i) (nil i) = nil i +; filter .($ i) (cons i n l) = plus (List ($ i)) (filter _ l) (cons _ n (filter _ l)) +} + +fun quicksort : [i : Size] -> List i -> List # +{ quicksort .($ i) (nil i) = nil _ +; quicksort .($ i) (cons i n l) = + plus (List #) (quicksort _ (filter i l)) (cons _ n (quicksort _ (filter i l))) +} + +data Id (A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +let p1 : (i : Size) -> Id (List #) (nil i) (nil #) + = \ i -> refl -- (List #) (nil i) diff --git a/test/succeed/quicksort-filter.ma b/test/succeed/quicksort-filter.ma new file mode 100644 --- /dev/null +++ b/test/succeed/quicksort-filter.ma @@ -0,0 +1,82 @@ +-- 2010-06-21 Andreas Abel +-- Quicksort (naive implementation using filter) in MiniAgda + +-- Booleans + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun if : [A : Set] -> Bool -> A -> A -> A +{ if A true t e = t +; if A false t e = e +} + +-- Natural numbers + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun leq : Nat -> Nat -> Bool +{ leq zero n = true +; leq (succ m) zero = false +; leq (succ m) (succ n) = leq m n +} + +-- Lists over natural numbers as a sized inductive type + +sized data List : Size -> Set +{ nil : [i : Size] -> List ($ i) +; cons : [i : Size] -> Nat -> List i -> List ($ i) +} + +-- Append lists (yields no size information) + +fun append : List # -> List # -> List # +{ append (nil .#) l = l +; append (cons .# x xs) l = cons # x (append xs l) +} + +-- Filter a list (the output list is as most as long as the input list) + +fun filter : (Nat -> Bool) -> [i : Size] -> List i -> List i +{ filter p i (nil (i > j)) = nil j +; filter p i (cons (i > j) n l) = if (List ($ j)) (p n) + (cons j n (filter p j l)) -- then + (filter p j l) -- else +} + +-- Quicksort + +fun quicksort : [i : Size] -> List i -> List # +{ quicksort i (nil (i > j)) = nil j +; quicksort i (cons (i > j) n l) = + append (quicksort j (filter (\ m -> leq m n) j l)) + (cons # n (quicksort j (filter (leq (succ n)) j l))) +} + +-- Testing + +let n0 : Nat = zero +let n1 : Nat = succ n0 +let n2 : Nat = succ n1 +let n3 : Nat = succ n2 +let n4 : Nat = succ n3 +let n5 : Nat = succ n4 +let n6 : Nat = succ n5 +let n7 : Nat = succ n6 +let n8 : Nat = succ n7 +let n9 : Nat = succ n8 + +{- MiniAgda CBN is too inefficient to do this in reasonable time +let l : List # = + (cons # 4 (cons # 9 (cons # 1 (cons # 7 (cons # 6 + (cons # 4 (cons # 0 (cons # 0 + (cons # 3 (cons # 3 (cons # 3 (cons # 2 (cons # 3 (nil #)))))))))))))) +-} +let l : List # = cons # n1 (cons # n3 (cons # n0 (cons # n2 (nil #)))) +eval let l' : List # = quicksort # l + diff --git a/test/succeed/quicksort.ma b/test/succeed/quicksort.ma new file mode 100644 --- /dev/null +++ b/test/succeed/quicksort.ma @@ -0,0 +1,82 @@ +-- 2010-06-21 Andreas Abel +-- Quicksort (implementation using partition) in MiniAgda +-- more efficient implementation see qsapp.ma + +-- Booleans + +data Bool : Set +{ true : Bool +; false : Bool +} + +fun if : [A : Set] -> Bool -> A -> A -> A +{ if A true t e = t +; if A false t e = e +} + +-- Natural numbers + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +fun leq : Nat -> Nat -> Bool +{ leq zero n = true +; leq (succ m) zero = false +; leq (succ m) (succ n) = leq m n +} + +-- Lists over natural numbers as a sized inductive type + +sized data List : Size -> Set +{ nil : [i : Size] -> List ($ i) +; cons : [i : Size] -> Nat -> List i -> List ($ i) +} + +-- Append lists (yields no size information) + +fun append : List # -> List # -> List # +{ append (nil .#) l = l +; append (cons .# x xs) l = cons # x (append xs l) +} + +-- Partition a list, continuation-style + +fun partition : (Nat -> Bool) -> [i : Size] -> List i -> + [A : Set] -> (List i -> List i -> A) -> A +{ partition p i (nil (i > j)) A k = k (nil j) (nil j) +; partition p i (cons (i > j) n l) A k = if A (p n) + (partition p j l A (\ l1 -> \ l2 -> k (cons j n l1) l2)) -- then + (partition p j l A (\ l1 -> \ l2 -> k l1 (cons j n l2))) -- else +} + +-- Quicksort + +fun quicksort : [i : Size] -> List i -> List # +{ quicksort i (nil (i > j)) = nil j +; quicksort i (cons (i > j) n l) = partition (\ m -> leq m n) j l (List #) + (\ l1 -> \ l2 -> append (quicksort j l1) (cons # n (quicksort j l2))) +} + +-- Testing + +let n0 : Nat = zero +let n1 : Nat = succ n0 +let n2 : Nat = succ n1 +let n3 : Nat = succ n2 +let n4 : Nat = succ n3 +let n5 : Nat = succ n4 +let n6 : Nat = succ n5 +let n7 : Nat = succ n6 +let n8 : Nat = succ n7 +let n9 : Nat = succ n8 + +{- MiniAgda CBN is too inefficient to do this in reasonable time +let l : List # = + (cons # 4 (cons # 9 (cons # 1 (cons # 7 (cons # 6 + (cons # 4 (cons # 0 (cons # 0 + (cons # 3 (cons # 3 (cons # 3 (cons # 2 (cons # 3 (nil #)))))))))))))) +-} +let l : List # = cons # n1 (cons # n3 (cons # n0 (cons # n2 (nil #)))) +eval let l' : List # = quicksort # l diff --git a/test/succeed/rank2SizeQuantStream.ma b/test/succeed/rank2SizeQuantStream.ma new file mode 100644 --- /dev/null +++ b/test/succeed/rank2SizeQuantStream.ma @@ -0,0 +1,13 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +data Unit : Set { + triv : Unit +} + +cofun bla : (i : Size) -> ((j : Size) -> Stream Unit j -> Stream Unit j) -> Stream Unit i +{ + bla ($ i) f = f ($ i) (cons i triv (bla i f)) +} diff --git a/test/succeed/record.ma b/test/succeed/record.ma new file mode 100644 --- /dev/null +++ b/test/succeed/record.ma @@ -0,0 +1,33 @@ +-- a non-dependent record + +data Pair (A : Set) (B : Set) : Set +{ + pair : (fst : A) -> (snd : B) -> Pair A B +} +fields fst, snd + +fun swap : (A : Set) -> Pair A A -> Pair A A +{ + swap A p = pair (snd p) (fst p) +} + +-- eta law +-- p = pair (fst p) (snd p) : Pair A B + +-- a record with dependent destructors + +data Sigma (A : Set) (B : A -> Set) : Set +{ + pair' : (fst' : A) -> (snd' : B fst') -> Sigma A B +} +fields fst', snd' + +{- destructors + +fst' : (A : Set) -> (B : A -> Set) -> (p : Sigma A B) -> A +snd' : (A : Set) -> (B : A -> Set) -> (p : Sigma A B) -> B (fst p) + +-- eta law +-- p = pair' (fst' p) (snd' p) : Sigma A B + +-} diff --git a/test/succeed/shadowDataParam.ma b/test/succeed/shadowDataParam.ma new file mode 100644 --- /dev/null +++ b/test/succeed/shadowDataParam.ma @@ -0,0 +1,19 @@ +-- 2010-08-31 shadowing test + +-- no complaint here, because constructor name introduced after checking its sig +data D (name : Set) : Set +{ name : D name +} + +-- usage fine +fun id : [A : Set] -> D A -> D A +{ id A (name) = name +} + +-- but complaint here, because constructor name in scope +-- 2010-10-01 this is now fine! +data E (name : Set) : Set +{ e : E name +} + +-- a bit weird, still... diff --git a/test/succeed/sigma.ma b/test/succeed/sigma.ma new file mode 100644 --- /dev/null +++ b/test/succeed/sigma.ma @@ -0,0 +1,49 @@ +data Sigma ++(A : Set) ++(B : A -> Set) : Set +{ pair : (fst : A) -> (snd : B fst) -> Sigma A B +} +fields fst, snd + +-- Destructors generated: +-- +-- fun fst : [A : Set] -> [B : A -> Set] -> (p : Sigma A B) -> A +-- { fst A B (pair .A .B a b) = a } +-- fun snd : [A : Set] -> [B : A -> Set] -> (p : Sigma A B) -> B (fst A B p) +-- { snd A B (pair .A .B a b) = b } + +-- infinite trees +codata IT : Set +{ it : Sigma IT (\ x -> IT) -> IT +} + + +data Id ++(A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +-- eta equality for neutral terms +let etaSigma : (A : Set) -> (B : A -> Set) -> (p : Sigma A B) -> + Id (Sigma A B) p (pair (fst p) (snd p)) + = \ A -> \ B -> \ p -> refl -- (Sigma A B) p +data Bool : Set +{ true : Bool +; false : Bool +} + +let Bool2 : Set + = Sigma Bool (\ b -> Bool) +let pair2 : Bool -> Bool -> Bool2 + = \ b1 b2 -> pair {- Bool (\ b -> Bool)-} b1 b2 +let fst2 : Bool2 -> Bool + = fst -- Bool (\ b -> Bool) +let snd2 : Bool2 -> Bool + = snd -- Bool (\ b -> Bool) + +fun bla : Bool -> Bool2 +{ bla true = pair2 true false +; bla false = pair2 false false +} + + +-- eta equality for arbitrary terms +let etaBool2 : (b : Bool) -> Id Bool2 (bla b) (pair2 (fst2 (bla b)) (snd2 (bla b))) + = \ b -> refl -- Bool2 (bla b) diff --git a/test/succeed/simple_nat.ma b/test/succeed/simple_nat.ma new file mode 100644 --- /dev/null +++ b/test/succeed/simple_nat.ma @@ -0,0 +1,10 @@ +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +fun add : Nat -> Nat -> Nat +{ add zero x = x +; add (suc y) x = suc (add y x) +} + diff --git a/test/succeed/singleton.ma b/test/succeed/singleton.ma new file mode 100644 --- /dev/null +++ b/test/succeed/singleton.ma @@ -0,0 +1,89 @@ +-- 2009-11-29 A few examples about singleton types + +let id : (A : Set) -> (x : A) -> + = \ A -> \ x -> x + +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +let zero' + : + = zero + +let succ' + : (x : Nat) -> + = \ x -> succ x + +fun pred : [x : Nat] -> -> +{ pred .x (succ x) = x +} + +-- the recursive constant zero function +fun kzero : (x : Nat) -> +{ kzero zero = zero +; kzero (succ x) = kzero x +} +-- eta-expansion turns this into the non-recursive +-- kzero x = zero + +data IsZero : Nat -> Set +{ isZero : IsZero zero +} + +let p : (x : Nat) -> IsZero (kzero x) + = \ x -> isZero +{- Checking works as follows: + ? x : Nat |- isZero : IsZero (kzero x) + ? IsZero zero <= IsZero (kzero x) + ? zero = kzero x : Nat + . zero = zero : Nat +-} + + +fun pzero : ( -> Nat) -> Nat -> +{ pzero f zero = zero +; pzero f (succ x) = kzero (f (pzero f x)) +} +{- type checking the second clause succees with bidirectional t.c. + Gamma = f : -> Nat + pzero f : Nat -> + x : Nat + + ? Gamma |- f (pzero f x) : Nat + ? Gamma |- pzero f x : + -} + +fun qzero : ((n : Nat) -> IsZero n -> Nat) -> Nat -> +{ qzero f zero = zero +; qzero f (succ x) = kzero (f (qzero f x) isZero) +} +{- type checking the second clause FAILS with bidirectional t.c. + Gamma = f : (n : Nat) -> IsZero n -> Nat + qzero f : Nat -> + x : Nat + + ? Gamma |- f (qzero f x) isZero : Nat + ?1 Gamma |- qzero f x : Nat + ?2 Gamma |- isZero : IsZero (qzero f x) + + Here we fail, since we just substituted the value (qzero f x) for n. + The information qzero f x = 0 is lost. + +One solution here world be to use the eta-expanded form of qzero also +when checking the body of qzero. -} + +-- simplified example + +data Unit : Set { unit : Unit } +data Empty : Set {} + +fun Zero : (n : Nat) -> Set +{ Zero zero = Unit +; Zero (succ x) = Empty +} + +let bla : ((n : Nat) -> Zero n -> Nat) -> (Nat -> ) -> Nat -> Nat + = \ f -> \ g -> \ x -> f (g x) unit +-- THIS DOES NOT DO the job, since g x is eta-expanded to zero. diff --git a/test/succeed/sizeFunctions.ma b/test/succeed/sizeFunctions.ma new file mode 100644 --- /dev/null +++ b/test/succeed/sizeFunctions.ma @@ -0,0 +1,35 @@ +-- 2010-03-11 size functions + +data Bool : Set +{ true : Bool +; false : Bool +} + +data N : Set +{ zz : N +; ss : N -> N +} + +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +let infty : Size = # +let ssuc : Size -> Size = \ i -> $ i + +fun maybeSuc : (b : Bool) -> Size -> Size +{ maybeSuc true i = $ i +; maybeSuc false i = i +} + +fun addSize : N -> Size -> Size +{ addSize zz i = i +; addSize (ss n) i = $ (addSize n i) +} + +fun addSNat : (n : N) -> (i : Size) -> Nat i -> Nat (addSize n i) +{ addSNat zz i m = m +; addSNat (ss n) i m = succ (addSize n i) (addSNat n i m) +} + diff --git a/test/succeed/sizedFinitelyBranchingTrees.ma b/test/succeed/sizedFinitelyBranchingTrees.ma new file mode 100644 --- /dev/null +++ b/test/succeed/sizedFinitelyBranchingTrees.ma @@ -0,0 +1,20 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +data Fin : Nat -> Set +{ fzero : [n : Nat] -> Fin (succ n) +; fsucc : [n : Nat] -> Fin n -> Fin (succ n) +} + +sized data Tree (A : Set) : Size -> Set +{ leaf : [i : Size] -> A -> Tree A ($ i) +; node : [i : Size] -> (n : Nat) -> (Fin n -> Tree A i) -> Tree A ($ i) +} + +fun map : [A : Set] -> [B : Set] -> (A -> B) -> + [i : Size] -> Tree A i -> Tree B i +{ map A B f i (leaf (i > j) a) = leaf j (f a) +; map A B f i (node (i > j) n s) = node j n (\ k -> map A B f j (s k)) +} diff --git a/test/succeed/sizedMax.ma b/test/succeed/sizedMax.ma new file mode 100644 --- /dev/null +++ b/test/succeed/sizedMax.ma @@ -0,0 +1,36 @@ +sized data Nat : Size -> Set +{ zero : [i : Size] -> Nat ($ i) +; succ : [i : Size] -> Nat i -> Nat ($ i) +} + +check fun maxN : [i : Size] -> Nat i -> Nat i -> Nat i +{ maxN .($ i) (zero .i) (zero i) = zero i +; maxN .($ i) (zero .i) (succ i n) = succ i n +; maxN .($ i) (succ .i n) (zero i) = succ i n +; maxN .($ i) (succ .i n) (succ i m) = succ i (maxN i n m) +} + +fun maxN : [i : Size] -> Nat i -> Nat i -> Nat i +{ maxN i (zero (i > j) ) (zero (i > k) ) = zero j +; maxN i (zero (i > j) ) (succ (i > k) m) = succ k m +; maxN i (succ (i > j) n) (zero (i > k) ) = succ j n +; maxN i (succ (i > j) n) (succ (i > k) m) = succ (max j k) + (maxN (max j k) n m) +} + +{- +-- termination checker + + max j k ? j) n) (succ (i > k) m) = succ _X (maxN _Y n m) + + _X + 1 <= i + j <= _Y + k <= _Y + _Y <= _X + +Needs to be solved as _X = _Y = max j k +-} diff --git a/test/succeed/sizedMergeWith.ma b/test/succeed/sizedMergeWith.ma new file mode 100644 --- /dev/null +++ b/test/succeed/sizedMergeWith.ma @@ -0,0 +1,29 @@ +data Bool : Set +{ true : Bool +; false : Bool +} + +data Nat : Set +{ zero : Nat +; suc : Nat -> Nat +} + +sized data List : Size -> Set +{ nil : (i : Size) -> List ($ i) +; cons : (i : Size) -> Nat -> List i -> List ($ i) +} + +fun leq : Nat -> Nat -> Bool {} + +-- merge as would be represented with "with" in Agda +mutual { + fun merge : (i : Size) -> List i -> (j : Size) -> List j -> List # + { merge .($ i) (nil i) j l = l + ; merge i l .($ j) (nil j) = l + ; merge .($ i) (cons i x xs) .($ j) (cons j y ys) = merge_aux i x xs j y ys (leq x y) + } + fun merge_aux : (i : Size) -> Nat -> List i -> (j : Size) -> Nat -> List j -> Bool -> List # + { merge_aux i x xs j y ys true = cons # x (merge i xs ($ j) (cons j y ys)) + ; merge_aux i x xs j y ys false = cons # y (merge ($ i) (cons i x xs) j ys) + } +} diff --git a/test/succeed/sizedOrd.ma b/test/succeed/sizedOrd.ma new file mode 100644 --- /dev/null +++ b/test/succeed/sizedOrd.ma @@ -0,0 +1,26 @@ +data Nat : Set +{ zero : Nat +; succ : Nat -> Nat +} + +sized data Ord : Size -> Set +{ ozero : [i : Size] -> Ord ($ i) +; osucc : [i : Size] -> Ord i -> Ord ($ i) +; olim : [i : Size] -> (Nat -> Ord i) -> Ord ($ i) +} + +fun maxO : [i : Size] -> Ord i -> Ord i -> Ord i +{ maxO i (ozero (i > j)) q = q +; maxO i p (ozero (i > k)) = p +; maxO i (olim (i > j) f) (olim (i > k) g) = + olim (max j k) (\ n -> maxO (max j k) (f n) (g n)) +; maxO i (osucc (i > j) p) (osucc (i > k) q) = + osucc (max j k) (maxO (max j k) p q) +-- CANNOT DEFINE MISSION CLAUSES +} + +fun idO : [i : Size] -> Ord i -> Ord i +{ idO i (ozero (i > j) ) = ozero j +; idO i (osucc (i > j) p) = osucc j (idO j p) +; idO i (olim (i > j) f) = olim j (\ n -> idO j (f n)) +} diff --git a/test/succeed/streamIdentityNatRecursive.ma b/test/succeed/streamIdentityNatRecursive.ma new file mode 100644 --- /dev/null +++ b/test/succeed/streamIdentityNatRecursive.ma @@ -0,0 +1,20 @@ + +sized data SNat : Size -> Set +{ + zero : (i : Size) -> SNat ($ i); + succ : (i : Size) -> SNat i -> SNat ($ i) +} + +sized codata Stream : Size -> Set { + cons : (i : Size) -> SNat # -> Stream i -> Stream ($ i) +} + + +-- a silly stream identity +-- this is refuted by Karl's overly restrictive admissibility test + +fun sid : (i : Size) -> SNat i -> (j : Size) -> Stream j -> Stream j +{ + sid .($ i) (zero i) j xs = xs ; + sid .($ i) (succ i y) j xs = sid i y j xs +} diff --git a/test/succeed/subset.ma b/test/succeed/subset.ma new file mode 100644 --- /dev/null +++ b/test/succeed/subset.ma @@ -0,0 +1,43 @@ +-- 2012-01-22 parameters gone from constructors + +data Subset (A : Set) (P : A -> Set) : Set +{ + put : (get : A) -> [P get] -> Subset A P +} + +data Nat : Set +{ + zero : Nat; + succ : Nat -> Nat +} + +data Odd : Nat -> Set +{ + odd1 : Odd (succ zero); + odd3 : Odd (succ (succ (succ zero))); + oddSS : [n : Nat] -> Odd n -> Odd (succ (succ n)) +} + + +data Eq (A : Set)(a : A) : A -> Set +{ + refl : Eq A a a +} + +let OddN : Set + = Subset Nat Odd + +let one : Nat + = succ zero + +let three : Nat + = succ (succ one) + +let o3 : OddN + = put three odd3 + +let o3' : OddN + = put three (oddSS one odd1) + +let p : Eq OddN o3 o3' + = refl diff --git a/test/succeed/tailStream.ma b/test/succeed/tailStream.ma new file mode 100644 --- /dev/null +++ b/test/succeed/tailStream.ma @@ -0,0 +1,11 @@ + +sized codata Stream (+ A : Set) : Size -> Set { + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +-- tail is fine since it is non-recursive, so the type need not be +-- admissible +fun tail : (A : Set) -> (i : Size) -> Stream A ($ i) -> Stream A i +{ + tail A i (cons .i x xs) = xs +} diff --git a/test/succeed/vec.ma b/test/succeed/vec.ma new file mode 100644 --- /dev/null +++ b/test/succeed/vec.ma @@ -0,0 +1,46 @@ +data Nat : Set +{ + zero : Nat; + succ : (pred : Nat) -> Nat +} + +fun add : Nat -> Nat -> Nat +{ + add zero y = y; + add (succ x) y = succ (add x y) +} + +data Vec' (+A : Set) : Nat -> Set +{ + vnil' : Vec' A zero; + vcons' : [n : Nat] -> (head' : A) -> (tail' : Vec' A n) -> Vec' A (succ n) +} + +data Vec (+A : Set) : Nat -> Set +{ + vnil : Vec A zero; + vcons : (head : A) -> [n : Nat] -> (tail : Vec A n) -> Vec A (succ n) +} + +fun length : [A : Set] -> [n : Nat] -> Vec A n -> Nat +{ + length A .zero vnil = zero; + length A .(succ n) (vcons x n xs) = succ (length A n xs); +} + +fun append : [A : Set] -> [n : Nat] -> Vec A n -> + [m : Nat] -> Vec A m -> Vec A (add n m) +{ + append A .zero vnil m ys = ys; + append A .(succ n) (vcons x n xs) m ys = + vcons x (add n m) (append A n xs m ys) +} + +data Id (A : Set)(a : A) : A -> Set +{ refl : Id A a a +} + +let vec0vnil : (A : Set) -> (v : Vec A zero) -> Id (Vec A zero) v vnil + = \ A -> \ v -> refl + + diff --git a/test/succeed/wkStream.ma b/test/succeed/wkStream.ma new file mode 100644 --- /dev/null +++ b/test/succeed/wkStream.ma @@ -0,0 +1,111 @@ +data Nat : Set +{ + zero : Nat ; + succ : (x : Nat) -> Nat +} + +fun add : Nat -> Nat -> Nat +{ +add x zero = x; +add x (succ y) = succ (add x y); +} + +eval let one : Nat = succ zero + +sized codata Stream (A : Set) : Size -> Set +{ + cons : (i : Size) -> A -> Stream A i -> Stream A ($ i) +} + +cofun zeroes : (i : Size ) -> Stream Nat i +{ +zeroes ($ i) = cons i zero (zeroes i) +} + +cofun ones : (i : Size) -> Stream Nat i +{ +ones ($ i) = cons i one (ones i) +} + +eval let ones' : Stream Nat # = ones # + +cofun map : (A : Set) -> (B : Set) -> (i : Size) -> + (A -> B) -> Stream A # -> Stream B i +{ +map A B ($ i) f (cons .# a as) = cons i (f a) (map A B i f as) +} + +eval let twos : Stream Nat # = map Nat Nat # ( \ x -> succ x) ones' + + + +-- tail is a fun +fun tail : (A : Set) -> Stream A # -> Stream A # +{ +tail A (cons .# a as) = as +} + + +eval let twos' : Stream Nat # = tail Nat twos + +fun head : (A : Set) -> Stream A # -> A +{ +head A (cons .# a as) = a +} + +eval let two : Nat = head Nat twos +eval let two' : Nat = head Nat twos' + +eval let twos2 : Stream Nat # = map Nat Nat # succ ones' +eval let twos2' : Stream Nat # = tail Nat twos2 + +cofun zipWith : ( A : Set ) -> ( B : Set ) -> (C : Set) -> ( i : Size ) -> + (A -> B -> C) -> Stream A # -> Stream B # -> Stream C i +{ +zipWith A B C ($ i) f (cons .# a as) (cons .# b bs) = + cons i (f a b) (zipWith A B C i f as bs) +} + + + +fun nth : Nat -> Stream Nat # -> Nat +{ +nth zero ns = head Nat ns; +nth (succ x) ns = nth x (tail Nat ns) +} + +eval let fours : Stream Nat # = zipWith Nat Nat Nat # add twos twos +eval let four : Nat = head Nat fours + + + +cofun fib : (x : Nat ) -> (y : Nat ) -> (i : Size ) -> Stream Nat i +{ +fib x y ($ i) = (cons ($ i) x (cons i y (fib y (add x y) i))) +} + +eval let fib' : Stream Nat # = tail Nat (fib zero zero #) + + +eval let fib8 : Nat = nth (add four four) (fib zero zero #) + +eval let fib2 : Nat = head Nat (tail Nat (fib zero zero #)) + +cofun nats : (i : Size ) -> Nat -> Stream Nat i +{ +nats ($ i) x = (cons i x (nats i (succ x))) +} + +eval let nats' : Stream Nat # = tail Nat (nats # zero) + + +--- weakening +eval let wkStream : ( A : Set ) -> ( i : Size ) -> Stream A ($ i) -> Stream A i = \ A -> \ i -> \ s -> s + +-- should be ok but does not pass admissibility check +cofun wkStream_ok : ( A : Set ) -> (i : Size ) -> Stream A ($ i) -> Stream A i +{ +wkStream_ok A ($ i) (cons .($ i) x xs) = cons i x (wkStream A i xs) +} + +